Thread: [Toss-devel-svn] SF.net SVN: toss:[1691] trunk/Toss (Page 13)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2012-03-12 00:27:30
|
Revision: 1691
http://toss.svn.sourceforge.net/toss/?rev=1691&view=rev
Author: lukaszkaiser
Date: 2012-03-12 00:27:22 +0000 (Mon, 12 Mar 2012)
Log Message:
-----------
Both current and starting structure parsing, many small corrections.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Main.js
trunk/Toss/Client/Play.js
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/www/codebasics.xml
trunk/Toss/www/create.xml
trunk/Toss/www/ideas.xml
trunk/Toss/www/navigation.xml
trunk/Toss/www/ocaml.xml
trunk/Toss/www/play.xml
trunk/Toss/www/xsl/common.xsl
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/Arena.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -47,7 +47,7 @@
parameters : (string * float) list ;
rule : string ;
next_loc : int ;
- matching : (string * int) list ;
+ matching : (string * string) list ;
}
(* State of the game and additional information. *)
@@ -101,7 +101,7 @@
let move_str (lb, i) = Printf.sprintf "[%s -> %i]" (label_str lb) i
let pmv_str (pl, lb, i) = Printf.sprintf "[%s,%s -> %i]" pl (label_str lb) i
-let fprint_loc_body_in struc pnames f player {payoff = in_p; moves = in_m} =
+let fprint_loc_body_in pnames f player {payoff = in_p; moves = in_m} =
Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
(fun f (payoff, moves) ->
Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
@@ -120,20 +120,16 @@
Format.fprintf f "@ ->@ %d@]@,]" target)) moves
) (in_p, in_m)
-let fprint_loc_body struc pnames f loc =
- Array.iteri (fun p l -> fprint_loc_body_in struc pnames f p l) loc
+let fprint_loc_body pnames f loc =
+ Array.iteri (fun p l -> fprint_loc_body_in pnames f p l) loc
let equational_def_style = ref true
-let fprint_game_move ?(as_ints=false) struc f
+let fprint_game_move f
({mv_time = t; parameters = pl; rule = rn;
next_loc = l; matching = m}, rtime) =
let m_s = String.concat ", "
- (List.map (fun (e, x) ->
- if as_ints then
- Printf.sprintf "%s: %i" e x
- else
- Printf.sprintf "%s: %s" e (Structure.elem_str struc x))
+ (List.map (fun (e, x) -> Printf.sprintf "%s: %s" e x)
(List.sort Pervasives.compare m)) in
let rt = match rtime with None -> "" | Some f -> " " ^ (string_of_float f) in
if (pl = []) then
@@ -144,9 +140,8 @@
Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
)
-let sprint_game_move st gm = AuxIO.sprint_of_fprint (fprint_game_move st) gm
-let game_move_str st gm = sprint_game_move st (gm, None)
-let game_move_gs_str st gm = sprint_game_move st.struc (gm, None)
+let sprint_game_move gm = AuxIO.sprint_of_fprint fprint_game_move gm
+let game_move_str gm = sprint_game_move (gm, None)
let fprint_only_state ?(ext_struct=false) ppf
{struc = struc;
@@ -159,7 +154,7 @@
(Structure.fprint ~show_empty:true)) struc;
if (hist <> []) then
Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
- (Aux.fprint_sep_list ";\n" (fprint_game_move struc)) hist;
+ (Aux.fprint_sep_list ";\n" fprint_game_move) hist;
if cur_loc <> 0 then
Format.fprintf ppf "@[<1>STATE LOC@ %d@]@ " cur_loc;
if time <> 0. then
@@ -174,11 +169,13 @@
player_names = player_names;
data = data;
defined_rels = defined_rels;
- starting_struc = struc;
+ starting_struc = start_struc;
},
- {time = time;
- cur_loc = cur_loc;
- history = hist;
+ {
+ struc = cur_struc;
+ time = time;
+ cur_loc = cur_loc;
+ history = hist;
}) =
Format.fprintf ppf "@[<v>";
List.iter (fun (drel, (args, body)) ->
@@ -205,17 +202,20 @@
(ContinuousRule.fprint_full print_compiled_rules) r) rules;
Array.iteri (fun loc_id loc ->
Format.fprintf ppf "@[<0>LOC@ %d@ {@,@[<2> %a@]@]@,}@ "
- loc_id (fprint_loc_body struc player_names) loc) graph;
+ loc_id (fprint_loc_body player_names) loc) graph;
Format.fprintf ppf "@[<1>START@ %a@]@ "
(if ext_struct then (Structure.fprint_ext_structure ~show_empty:true) else
- (Structure.fprint ~show_empty:true)) struc;
+ (Structure.fprint ~show_empty:true)) start_struc;
if (hist <> []) then
Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
- (Aux.fprint_sep_list ";\n" (fprint_game_move ~as_ints:true struc)) hist;
+ (Aux.fprint_sep_list ";\n" fprint_game_move) hist;
if cur_loc <> 0 then
Format.fprintf ppf "@[<1>STATE LOC@ %d@]@ " cur_loc;
if time <> 0. then
Format.fprintf ppf "@[<1>TIME@ %F@]@ " time;
+ if ext_struct then
+ Format.fprintf ppf "@[<1>CURRENT@ %a@]@ "
+ (Structure.fprint_ext_structure ~show_empty:true) cur_struc;
Format.fprintf ppf "@]"
let fprint_state = fprint_state_full false
@@ -266,11 +266,10 @@
(* The order of following entries matters: [DefPlayers] adds more
players, with consecutive numbers starting from first available;
- later [StateStruc], [StateTime] and [StateLoc] entries override
- earlier ones; later [DefLoc] with already existing location ID
+ later [StartStruc], [CurrentStruc], [StateTime] and [StateLoc] entries
+ override earlier ones; later [DefLoc] with already existing location ID
replaces the earlier one. The default state is the empty state,
- default location is 0, default time is 0.0, default data is
- empty. *)
+ default location is 0, default time is 0.0, default data is empty. *)
type definition =
| DefRule of string * (
(string * int) list ->
@@ -283,7 +282,8 @@
| DefRel of string * string list * Formula.formula
(* add a defined relation *)
| DefPattern of Formula.real_expr (* Pattern definition *)
- | StateStruc of Structure.structure (* initial/saved state *)
+ | StartStruc of Structure.structure (* initial structure *)
+ | CurrentStruc of Structure.structure (* current structure *)
| History of (move * float option) list (* Move history *)
| StateTime of float (* initial/saved time *)
| StateLoc of int (* initial/saved location *)
@@ -327,14 +327,16 @@
(* Helper: Apply a move to a game state, get the new state. *)
let apply_move rules state (m, t) =
let r = List.assoc m.rule rules in
- match ContinuousRule.rewrite_single state.struc state.time m.matching r
+ let mtch =
+ List.map (fun (v, e) -> v, Structure.elem_nbr state.struc e) m.matching in
+ match ContinuousRule.rewrite_single state.struc state.time mtch r
m.mv_time m.parameters with
| Some (new_struc, new_time, _) ->
{ struc = new_struc;
time = new_time;
history = (m, t) :: state.history;
cur_loc = m.next_loc }
- | _ -> failwith ("move " ^ (sprint_game_move state.struc (m,t)) ^
+ | _ -> failwith ("move " ^ (sprint_game_move (m,t)) ^
" inapplicable to " ^ (sprint_only_state state))
(* Make a move in a game. *)
@@ -344,76 +346,74 @@
list of definitions (usually corresponding to a ".toss" file.) *)
let process_definition ?extend_state defs =
let (old_rules, old_locs, players, old_defined_rels,
- state, time, cur_loc, patterns, data) =
+ strucs, time, cur_loc, patterns, data) =
match extend_state with
| None ->
- [], [], [], [], Structure.empty_structure (), 0.0, 0, [], []
+ [], [], [], [], (Structure.empty_structure (), None), 0.0, 0, [], []
| Some (game, gstate) ->
game.rules, Array.to_list (Array.mapi (fun i l -> i, l) game.graph),
List.map fst (List.sort (fun (_,x) (_,y) -> x-y) game.player_names),
List.map (fun (rel, (args, body)) -> rel, args, body) game.defined_rels,
- gstate.struc, gstate.time, gstate.cur_loc,
+ (game.starting_struc, Some gstate.struc), gstate.time, gstate.cur_loc,
game.patterns, game.data in
LOG 3 "process_definition: %d old rules, %d old locs\n%!"
(List.length old_rules) (List.length old_locs);
let rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist =
+ strucs, time, cur_loc, patterns, data, hist =
List.fold_left (fun (rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist) def ->
+ strucs, time, cur_loc, patterns, data, hist) def ->
match def with
| DefRule (rname, r) ->
((rname, r)::rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefLoc loc ->
(rules, loc::locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefPlayers more_players ->
(rules, locations, players @ more_players, defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefRel (rel, args, body) ->
(rules, locations, players,
(rel, args, body)::defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefPattern pat ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, pat :: patterns, data, hist)
- | StateStruc struc ->
+ strucs, time, cur_loc, pat :: patterns, data, hist)
+ | StartStruc struc ->
(rules, locations, players, defined_rels,
- struc, time, cur_loc, patterns, data, hist)
+ (struc, snd strucs), time, cur_loc, patterns, data, hist)
+ | CurrentStruc struc ->
+ (rules, locations, players, defined_rels,
+ (fst strucs, Some struc), time, cur_loc, patterns, data, hist)
| History h ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, h @ hist)
+ strucs, time, cur_loc, patterns, data, h @ hist)
| StateTime ntime ->
(rules, locations, players, defined_rels,
- state, ntime, cur_loc, patterns, data, hist)
+ strucs, ntime, cur_loc, patterns, data, hist)
| StateLoc ncur_loc ->
(rules, locations, players, defined_rels,
- state, time, ncur_loc, patterns, data, hist)
+ strucs, time, ncur_loc, patterns, data, hist)
| StateData more_data ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data @ more_data, hist)
- ) ([], [], players, [],
- state, time, cur_loc, patterns, data, []) defs in
+ strucs, time, cur_loc, patterns, data @ more_data, hist)
+ ) ([], [], players, [], strucs, time, cur_loc, patterns, data, []) defs in
LOG 3 "process_definition: %d new rules, %d new defined rels\n%!"
(List.length rules) (List.length defined_rels);
let defined_rels = old_defined_rels @ List.rev defined_rels in
let def_rels_pure =
List.map (fun (rel, args, body) -> (rel, (args, body))) defined_rels in
let player_names =
- Array.to_list (Array.mapi (fun i pname->pname, i)
- (Array.of_list players)) in
+ Array.to_list (Array.mapi (fun i pname->pname,i) (Array.of_list players)) in
let num_players = List.length player_names in
- let signature = Structure.rel_signature state in
+ let signature = Structure.rel_signature (fst strucs) in
LOG 3 "process_definition: parsing new rules...%!";
- let rules =
- old_rules @ List.map (fun (name, r) ->
- name, r signature def_rels_pure name) rules in
+ let rules = old_rules @ List.map (fun (name, r) ->
+ name, r signature def_rels_pure name) rules in
LOG 3 " parsed\n%!";
- let rules =
- List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
+ let rules = List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
let updated_locs =
- if old_locs = [] then old_locs
- else
+ if old_locs = [] then old_locs else
let more = num_players - Array.length (snd (List.hd old_locs)) in
let add_more (i,loc) =
i, Array.append loc (Array.make more zero_loc) in
@@ -432,13 +432,13 @@
let graph = Aux.array_from_assoc (List.rev locations) in
let pats=List.rev_map (FormulaSubst.subst_rels_expr def_rels_pure) patterns in
let apply_moves rules mvs s = List.fold_left (apply_move rules) s mvs in
- let result_state =
- apply_moves rules (List.rev hist) {
- struc = state;
- time = time;
- cur_loc = cur_loc;
- history = [];
- } in
+ let result_state = match snd strucs with
+ | None ->
+ let st = apply_moves rules (List.rev hist)
+ { snd empty_state with struc = fst strucs } in
+ { st with time = time; cur_loc = cur_loc; history = hist }
+ | Some struc ->
+ { struc = struc; time = time; cur_loc = cur_loc; history = hist; } in
{
rules = rules;
patterns = pats;
@@ -447,7 +447,7 @@
player_names = player_names;
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
- starting_struc = state;
+ starting_struc = fst strucs;
}, result_state
@@ -611,7 +611,8 @@
parameters = [];
rule = label.lb_rule;
next_loc = next_loc;
- matching = emb
+ matching =
+ List.map (fun (v, e) -> (v, Structure.elem_name model e)) emb
} |]
else
let param_names, params_in =
@@ -631,9 +632,10 @@
parameters = List.combine param_names params;
rule = label.lb_rule;
next_loc = next_loc;
- matching = emb}
- ) grid
- ) matchings))
+ matching =
+ List.map (fun (v, e) -> (v, Structure.elem_name model e)) emb
+ }) grid
+ ) matchings))
(* Check if the before-part of the precondition of the rule holds on history. *)
let check_history_pre r hist =
@@ -649,6 +651,8 @@
Aux.map_some (fun mv ->
let rule = List.assoc mv.rule rules in
if check_history_pre rule.ContinuousRule.discrete state.history then
+ let mtch = List.map (fun (v, e) ->
+ v, Structure.elem_nbr state.struc e) mv.matching in
Aux.map_option
(fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *)
(mv,
@@ -656,7 +660,7 @@
history = (mv, None) :: state.history;
struc = model;
time = time}))
- (ContinuousRule.rewrite_single state.struc time mv.matching
+ (ContinuousRule.rewrite_single state.struc time mtch
rule mv.mv_time mv.parameters)
else None) (Array.to_list moves)
@@ -712,15 +716,17 @@
r_name (ContinuousRule.matching_str struc mtch) player
(String.concat ", " (List.map (fun (lb,_) -> lb.lb_rule) mv_loc.moves))
(String.concat "; " (List.map (fun m ->
- m.rule ^ ":" ^ ContinuousRule.matching_str struc m.matching
+ let mstr = List.map (fun (v, e) ->
+ v, Structure.elem_nbr state.struc e) m.matching in
+ m.rule ^ ":" ^ ContinuousRule.matching_str struc mstr
) (Array.to_list moves)));
let pos = (
try
for i = 0 to Array.length moves - 1 do
let mov = moves.(i) in
- if r_name = mov.rule && List.for_all
- (fun (e, f) -> f = List.assoc e mov.matching) mtch then
- raise (Found i)
+ if r_name = mov.rule && List.for_all (fun (e, f) ->
+ Structure.elem_name state.struc f = List.assoc e mov.matching) mtch
+ then raise (Found i)
done;
LOG 1 "apply_rewrite: failed for pl. num %d, r_name=%s\n%!"
player r_name;
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/Arena.mli 2012-03-12 00:27:22 UTC (rev 1691)
@@ -40,7 +40,7 @@
parameters : (string * float) list ;
rule : string ;
next_loc : int ;
- matching : (string * int) list ;
+ matching : (string * string) list ;
}
@@ -94,17 +94,15 @@
(** For the rules of the game, also print their compiled forms. *)
val sprint_state_full : game * game_state -> string
-val sprint_game_move : Structure.structure -> move * float option -> string
-val game_move_str : Structure.structure -> move -> string
-val game_move_gs_str : game_state -> move -> string
+val sprint_game_move : move * float option -> string
+val game_move_str : move -> string
(** The order of following entries matters: [DefPlayers] adds more
- players, with consecutive numbers starting from first available;
- later [StateStruc], [StateTime] and [StateLoc] entries override
- earlier ones; later [DefLoc] with already existing location ID
- replaces the earlier one. The default state is the empty state,
- default location is 0, default time is 0.0, default data is
- empty. *)
+ players, with consecutive numbers starting from first available;
+ later [StartStruc], [CurrentStruc], [StateTime] and [StateLoc] entries
+ override earlier ones; later [DefLoc] with already existing location ID
+ replaces the earlier one. The default state is the empty state,
+ default location is 0, default time is 0.0, default data is empty. *)
type definition =
| DefRule of string * (
(string * int) list ->
@@ -117,7 +115,8 @@
| DefRel of string * string list * Formula.formula
(** add a defined relation *)
| DefPattern of Formula.real_expr (** Pattern definition *)
- | StateStruc of Structure.structure (** initial/saved state *)
+ | StartStruc of Structure.structure (** initial structure *)
+ | CurrentStruc of Structure.structure (** current structure *)
| History of (move * float option) list (** Move history *)
| StateTime of float (** initial/saved time *)
| StateLoc of int (** initial/saved location *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-03-12 00:27:22 UTC (rev 1691)
@@ -85,13 +85,13 @@
game_move_timed:
| OPENSQ r = id_int t = FLOAT RARR l = INT EMB
- emb = separated_list (COMMA, separated_pair (ID, COLON, INT)) CLOSESQ
+ emb = separated_list (COMMA, separated_pair (ID, COLON, id_int)) CLOSESQ
{ ({mv_time = t; parameters = []; rule = r; next_loc = l; matching = emb;},
None) }
| OPENSQ r = id_int t = FLOAT COMMA
p = separated_list (COMMA, separated_pair (ID, COLON, FLOAT))
RARR l = INT EMB
- emb = separated_list (COMMA, separated_pair (ID, COLON, INT)) CLOSESQ
+ emb = separated_list (COMMA, separated_pair (ID, COLON, id_int)) CLOSESQ
f = FLOAT
{ ({mv_time = t; parameters = p; rule = r; next_loc = l; matching = emb;},
Some f) }
@@ -123,10 +123,15 @@
body = formula_expr_err
{ DefRel (rel, arg, body) }
| START model = struct_expr
- { StateStruc model }
+ { StartStruc model }
| START model = struct_expr WITH
defs = separated_list (SEMICOLON, rel_def_simple)
- { StateStruc (Arena.add_def_rels model defs) }
+ { StartStruc (Arena.add_def_rels model defs) }
+ | CURRENT model = struct_expr
+ { CurrentStruc model }
+ | CURRENT model = struct_expr WITH
+ defs = separated_list (SEMICOLON, rel_def_simple)
+ { CurrentStruc (Arena.add_def_rels model defs) }
| MOVES moves = separated_list (SEMICOLON, game_move_timed)
{ History (moves) }
| TIME_MOD t = FLOAT
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -85,10 +85,9 @@
parameters = [];
rule = "rule";
next_loc = 1;
- matching = [("x", 1)];
+ matching = [("x", "1")];
} in
- let s = Structure.empty_structure () in
- assert_equal ~printer:(fun x -> x) (Arena.game_move_str s mv)
+ assert_equal ~printer:(fun x -> x) (Arena.game_move_str mv)
"[rule 0. -> 1 emb x: 1]"
);
]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/JsHandler.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -1,8 +1,5 @@
(* JavaScript Handler for a subset of ReqHandler.handle_http_post requests. *)
-
-(* In-source definitions of several games, loading games from strings. *)
-
type game_state_data = {
heuristic : Formula.real_expr array array; (** heuristic *)
game_state : (Arena.game * Arena.game_state); (** game and state *)
@@ -143,10 +140,8 @@
let _ = set_handle "test_handle" test_handle
let js_of_move game state move_id (player, move, _) =
- let struc = state.Arena.struc in
let matched = Js.array
- (Aux.array_map_of_list (fun (_, e) ->
- js (Structure.elem_name struc e)) move.Arena.matching) in
+ (Aux.array_map_of_list (fun (_, e) -> js e) move.Arena.matching) in
let js_move = jsnew js_object () in
let player_name = Aux.rev_assoc game.Arena.player_names player in
Js.Unsafe.set js_move (js"matched") matched;
@@ -156,7 +151,7 @@
js_move
(* Translate current structure into an "info_obj" format. *)
-let js_of_game_state game state =
+let js_of_game_state ?(show_payoffs=true) game state =
let struc = state.Arena.struc in
let get_pos e =
Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
@@ -201,7 +196,7 @@
if !cur_all_moves <> [||] then
Js.Unsafe.set info_obj (js"moves")
(Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
- else ( (* find payoffs *)
+ else if show_payoffs then ( (* find payoffs *)
let payoffs = Array.mapi
(fun i v -> i, Solver.M.get_real_val v.Arena.payoff struc)
game.Arena.graph.(state.Arena.cur_loc) in
@@ -212,7 +207,8 @@
let player_name = Aux.rev_assoc game.Arena.player_names i in
Js.Unsafe.set result (js player_name) (Js.float payoff))
payoffs;
- Js.Unsafe.set info_obj (js"result") result);
+ Js.Unsafe.set info_obj (js"result") result
+ );
LOG 0 "%s" "js_of_game_state: Game prepared. Sending...";
info_obj
@@ -244,11 +240,10 @@
let preview_move move_nbr =
let n = List.length !play_states - (move_nbr + 1) in
- if n < 0 then Js.null
- else
+ if n < 0 then Js.null else
let game, _ = !cur_game.game_state in
let state = List.nth !play_states n in
- Js.some (js_of_game_state game state)
+ Js.some (js_of_game_state ~show_payoffs:(n = 0) game state)
let _ = set_handle "prev_move" preview_move
@@ -325,7 +320,7 @@
let game, _ = !cur_game.game_state in
let move_s, state = of_js move_js, List.hd !play_states in
let move_id = Aux.array_argfind
- (fun (_,m,_) -> Arena.game_move_gs_str state m = move_s) !cur_all_moves in
+ (fun (_,m,_) -> Arena.game_move_str m = move_s) !cur_all_moves in
let result =
js_of_move game state move_id (!cur_all_moves.(move_id)) in
Js.Unsafe.set result (js"comp_iters")
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/Main.js 2012-03-12 00:27:22 UTC (rev 1691)
@@ -69,12 +69,12 @@
document.getElementById ("topuser").innerHTML = game;
document.getElementById ("game-title").style.display = "none";
document.getElementById ("game-title-move").style.display = "none";
- document.getElementById ("game-info-par").style.paddingBottom = "1em";
document.getElementById ("welcome").style.display = "none";
new_play_do ("computer", function () { });
}
function new_play_do (opp_uid, continuation) {
+ if (GAME_NAME === "Gomoku") { document.getElementById ("speed").value = 3; }
document.getElementById ("working").innerHTML = "Loading "+GAME_NAME+"...";
document.getElementById ("working").style.display = "block";
document.getElementById ("welcome").style.display = "none";
@@ -83,13 +83,13 @@
gd.style.display = "block";
gd.setAttribute ("class", "Game-" + GAME_NAME);
document.getElementById ("game-title").innerHTML = GAME_NAME;
- document.getElementById ("game-title").style.display = "inline";
- document.getElementById ("game-title-move").style.display = "inline";
var build_play = function (state_str) {
document.getElementById ("working").style.display = "none";
document.getElementById ("toss-link").style.display = "none";
document.getElementById ("appstorelink").style.display = "none";
document.getElementById ("toprighttab").style.display = "inline";
+ document.getElementById ("game-title").style.display = "inline";
+ document.getElementById ("game-title-move").style.display = "inline";
document.getElementById ("game-desc-controls").style.display = "block";
document.getElementById ("suggestions-toggle").style.display = "inline";
document.getElementById ("game-disp").style.display = "block";
@@ -109,9 +109,6 @@
document.getElementById ('payoffs').innerHTML = "Not Finished Yet";
document.getElementById ('payoffs').style.display = "none";
document.getElementById ('new-play-par').style.display = "none";
- if (UNAME == "guest") {
- document.getElementById ("game-info-par").style.paddingBottom = "1em";
- };
toggle_suggestions ();
toggle_suggestions ();
PLAY.clear ();
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/Play.js 2012-03-12 00:27:22 UTC (rev 1691)
@@ -1,4 +1,4 @@
-// JavaScript Toss Module -- Play (requires Connect.js or JsHandler, State.js)
+// JavaScript Toss Module -- Play (requires JsHandler, State.js)
var SIMPLE_MOVES = true;
var nameDISP = undefined;
@@ -135,12 +135,9 @@
// Apply the current move in a play.
function play_move () {
- if (typeof CONN != 'undefined' && ASYNC_ALL_REQ_PENDING != 0)
- { alert ("async"); return; }
if (this.CUR_MOVE == null) return;
if (this.move_nbr < this.last_move_nbr) { return; }
- // FIXME: why - 1? Move() already subtracts 1!
- var pl_nbr = this.CUR_MOVE.player; // - 1;
+ var pl_nbr = this.CUR_MOVE.player;
if (!isNaN(pl_nbr) && this.players[pl_nbr] != this.cur_player_uid &&
this.players[pl_nbr] != "computer") {
alert ("It is your Opponent's move: pl_nbr = "+pl_nbr +
@@ -165,7 +162,6 @@
Play.prototype.move_continue = play_move_continue;
function play_prev_move () {
- var prev;
var that = this;
var disp = function (prev) {
if (prev === null || prev == "NONE") { return; }
@@ -173,17 +169,11 @@
that.move_nbr = that.move_nbr - 1;
that.redraw ();
}
- if (typeof CONN == 'undefined') {
- prev = ASYNCH ("prev_move", [this.move_nbr - 1], disp);
- } else {
- prev = CONN.prev_move (this.pid, this.move_nbr - 1);
- disp (prev);
- }
+ ASYNCH ("prev_move", [this.move_nbr - 1], disp);
}
Play.prototype.prev_move = play_prev_move;
function play_next_move () {
- var next;
var that = this;
var disp = function (next) {
if (next === null || next == "NONE") {
@@ -198,12 +188,7 @@
}
that.redraw ();
}
- if (typeof CONN == 'undefined') {
- next = ASYNCH ("prev_move", [this.move_nbr + 1], disp);
- } else {
- next = CONN.prev_move (this.pid, this.move_nbr + 1);
- disp (next);
- }
+ ASYNCH ("prev_move", [this.move_nbr + 1], disp);
}
Play.prototype.next_move = play_next_move;
@@ -236,7 +221,7 @@
var result_string = "";
if (this.cur_state.result == null) { return ""; }
winners = this.get_winners();
- if (winners == null) { return "Tie"; }
+ if (winners == null) { return "No Winners"; }
if (winners.length == 0) { return null; }
for (var i=0; i < winners.length; i++) {
if (i > 0) result_string += ', ' + disp_name(winners[i]);
@@ -282,9 +267,9 @@
if (pl == un) { return ("You Win!"); }
return (nameDISP(pl) + " Wins");
}
- var subst_pl = function (pl, str) {
+ var subst_pl = function (pl, s) {
var un = pl.cur_player_uid;
- var s = str; //strip (' ', '\n', str);
+ if (typeof s == 'undefined') { return "Not Finished" }
if (s == "0: 1., 1: -1." || s == "1: 1, 2: -1") {
return (win_s (pl.players[0], un));
}
@@ -308,10 +293,9 @@
document.getElementById("board").style.paddingTop = "0em";
}
document.getElementById("move-info-par").style.display = "none";
- document.getElementById("game-info-par").style.paddingBottom = "0em";
document.getElementById('payoffs').innerHTML =
"Result: " + subst_pl(play, play.cur_state.payoff);
- document.getElementById('payoffs').style.display = "inline";
+ document.getElementById('payoffs').style.display = "block";
document.getElementById('new-play-par').style.display = "block";
}
}
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/State.js 2012-03-12 00:27:22 UTC (rev 1691)
@@ -149,7 +149,7 @@
payoffs.push (player + ': ' + info_obj.result[player]);
}
this.payoff = payoffs.join (', ');
- } else {
+ } else if (typeof info_obj.moves != 'undefined') {
...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-12 11:26:23
|
Revision: 1692
http://toss.svn.sourceforge.net/toss/?rev=1692&view=rev
Author: lukaszkaiser
Date: 2012-03-12 11:26:12 +0000 (Mon, 12 Mar 2012)
Log Message:
-----------
Small Client-Server corrections.
Modified Paths:
--------------
trunk/Toss/Client/Main.js
trunk/Toss/Client/index.html
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-12 00:27:22 UTC (rev 1691)
+++ trunk/Toss/Client/Main.js 2012-03-12 11:26:12 UTC (rev 1692)
@@ -60,7 +60,21 @@
function startup () {
- // should do some work here perhaps
+ if (navigator.userAgent.indexOf('MSIE') != -1 &&
+ navigator.userAgent.indexOf('MSIE 9') == -1) {
+ document.getElementById("nosvg").style.display = "block";
+ }
+ if (window.location.href.indexOf("?simple=true") > 0) {
+ document.getElementById ("ads").style.display = "none";
+ document.getElementById ("more-games-bt-div").style.display = "none";
+ }
+ var gindex = window.location.href.indexOf("?game=")
+ var cur_game = "";
+ if (gindex > 0) {
+ cur_game = window.location.href.substring(gindex+6,
+ window.location.href.length)
+ }
+ if (cur_game != "") { new_play_click (cur_game); }
}
function new_play_click (game) {
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-12 00:27:22 UTC (rev 1691)
+++ trunk/Toss/Client/index.html 2012-03-12 11:26:12 UTC (rev 1692)
@@ -15,6 +15,8 @@
<body onload="startup ('')">
+<div id="ads">
+</div>
<div id="main">
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-12 00:27:22 UTC (rev 1691)
+++ trunk/Toss/Server/Server.ml 2012-03-12 11:26:12 UTC (rev 1692)
@@ -3,15 +3,18 @@
let debug_level = ref 0
-let quit_on_eof = ref false
-
-let html_dir_path = ref "Client/"
-
let set_debug_level i =
debug_level := i;
AuxIO.set_debug_level "GameTree" i;
AuxIO.set_debug_level "Play" i
+
+let quit_on_eof = ref false
+let html_dir_path = ref "Client/"
+let cache_html = ref true
+let html_req_counter = ref 0
+let html_cache = Hashtbl.create 7
+
let init_state =
(None, true, Arena.empty_state, TranslateGame.empty_gdl_translation, 0)
@@ -111,6 +114,16 @@
(if cookies = [] then "" else cookies_s ^ "\r\n") ^
"Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+let mime_type fname =
+ match String.sub fname ((String.index fname '.') + 1) 2 with
+ | "ht" -> "text/html; charset=utf-8"
+ | "ic" -> "image/x-icon"
+ | "pn" -> "image/png"
+ | "cs" -> "text/css"
+ | "js" -> "text/javascript"
+ | "sv" -> "image/svg+xml"
+ | _ -> "text/html charset=utf-8"
+
let handle_http_get cmd head msg ck =
if !debug_level > 1 then (
Printf.printf "Http Get Handler\n%s%s\n%!" cmd msg;
@@ -124,20 +137,18 @@
with Not_found -> fname_in1 in
let fname = !html_dir_path ^ fname_in in
if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
- if Sys.file_exists fname && not (Sys.is_directory fname) then (
- let content = AuxIO.input_file fname in
- let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
- | "ht" -> "text/html; charset=utf-8"
- | "ic" -> "image/x-icon"
- | "pn" -> "image/png"
- | "cs" -> "text/css"
- | "js" -> "text/javascript"
- | "sv" -> "image/svg+xml"
- | _ -> "text/html charset=utf-8" in
- http_msg true "200 OK" tp [] content
- ) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
- ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
- "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
+ try if not !cache_html then raise Not_found else
+ let content = Hashtbl.find html_cache fname in
+ LOG 1 "Found %s in html cache" fname;
+ http_msg true "200 OK" (mime_type fname) [] content
+ with Not_found ->
+ if Sys.file_exists fname && not (Sys.is_directory fname) then (
+ let content = AuxIO.input_file fname in
+ if !cache_html then Hashtbl.add html_cache fname content;
+ http_msg true "200 OK" (mime_type fname) [] content
+ ) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
+ ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
+ "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
let handle_http_post msg =
let split_msg = Aux.split_charprop (fun c -> c = '#') msg in
@@ -167,7 +178,10 @@
let handle_http_msg rstate cmd head msg ck =
if String.sub cmd 0 5 = "GET /" then
- Aux.Left (rstate, handle_http_get cmd head msg ck)
+ if !html_req_counter < 50 then ( (* cache a few first requests: no fork *)
+ incr html_req_counter;
+ Aux.Left (rstate, handle_http_get cmd head msg ck)
+ ) else Aux.Right (rstate, fun () -> handle_http_get cmd head msg ck)
else if String.length cmd > 13 && String.sub cmd 0 13 = "POST /Handler" then
Aux.Right (rstate, fun () -> handle_http_post msg)
else try Aux.Left (req_handle rstate
@@ -396,6 +410,8 @@
("-fulltest", Arg.String (fun s -> test_s := s; test_full := true),
"full unit tests for given path, might take longer");
("-noprecache", Arg.Unit (fun ()-> precache := false), "do no pre-caching");
+ ("-nohttpcache", Arg.Unit (fun ()-> cache_html := false),
+ "re-read files from disk on each HTTP GET request");
("-html", Arg.String (fun s -> html_dir_path := s),
"set path to the directory with html files for the client");
("-use-parallel", Arg.Tuple [Arg.Int (fun p -> set_parallel_port p);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-15 00:19:05
|
Revision: 1694
http://toss.svn.sourceforge.net/toss/?rev=1694&view=rev
Author: lukaszkaiser
Date: 2012-03-15 00:18:58 +0000 (Thu, 15 Mar 2012)
Log Message:
-----------
Simple python script to run server and browser, other small corrections.
Modified Paths:
--------------
trunk/Toss/Client/Main.js
trunk/Toss/Client/index.html
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/Client/support.html
trunk/Toss/Toss.py
Removed Paths:
-------------
trunk/Toss/run_server.sh
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/Client/Main.js 2012-03-15 00:18:58 UTC (rev 1694)
@@ -27,9 +27,7 @@
var GAME_NAME = ""; // name of current game, e.g. "Breakthrough"
var PLAY = [];
-var SIMPLE_SET = false;
-
function disp_name (uname) {
if (uname == "guest") { return ("You"); }
if (uname == "computer") { return ("Computer"); }
@@ -66,6 +64,10 @@
}
if (window.location.href.indexOf("?simple=true") > 0) {
document.getElementById ("ads").style.display = "none";
+ document.getElementById ("leftupperlogo-link").href =
+ "index.html?simple=true";
+ document.getElementById ("backlink-games").href =
+ "index.html?simple=true";
document.getElementById ("more-games-bt-div").style.display = "none";
}
var gindex = window.location.href.indexOf("?game=")
@@ -210,7 +212,7 @@
} else {
console.log ("Discarded " + m.comp_iters +" iterations.");
}
- }, 700); // wait 500 miliseconds more than the 0.2s speedup for local
+ }, 1000); // wait 800 miliseconds more than the 0.2s speedup for local
};
// ASYNCH does not implement multiple plays
// I'm not sure about players being numbered from 1
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/Client/index.html 2012-03-15 00:18:58 UTC (rev 1694)
@@ -33,7 +33,7 @@
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
><img style="height: 24px;" src="img/appstore-small.png" /></a>
</span>
-<span id="toprighttab"><a href="index.html">Games</a></span>
+<span id="toprighttab"><a id="backlink-games" href="index.html">Games</a></span>
</div>
<div id="welcome">
Added: trunk/Toss/Client/support.html
===================================================================
--- trunk/Toss/Client/support.html (rev 0)
+++ trunk/Toss/Client/support.html 2012-03-15 00:18:58 UTC (rev 1694)
@@ -0,0 +1,113 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xmlns:svg="http://www.w3.org/2000/svg" xml:lang="en" lang="en">
+<head>
+ <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
+ <title>tPlay — Support</title>
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
+ <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
+</head>
+
+<body>
+
+<div id="main">
+
+<div id="top">
+<div id="logo"><a href="index.html"><img src="img/logo.png" alt="tPlay" /></a></div>
+<div id="topbar"><span id="topuser">Support</span></div>
+</div>
+
+<div style="font-size: 1.1em; margin: 1em; padding: 1em;">
+
+<h2>Contact Us</h2>
+<p style="line-height: 130%;">
+Thank you for your interest in tPlay! We try to make our interface as
+intuitive and simple as possible, and we hope it is mostly self-explanatory.
+If you encounter any problems, have some remarks or just want to tell us
+how you feel about tPlay, write us an email.<br/>
+<span style="position: relative; top: 0px; left: 15em;">
+<script type="text/javascript">
+// Email address obfuscation to prevent some spamming.
+function begin_mailto (name, domain, title) {
+ var address = name + '@' + domain;
+ if(title) {
+ document.write("<a class='contact' href='mailto:" + address + "'>" +
+ title + "<span style='display: none;'>");
+ } else {
+ document.write("<a class='contact' href='mailto:" + address + "'>" +
+ address + "<span style='display: none;'>");
+ }
+}
+
+function end_mailto() {
+ document.write("</span></a>");
+}
+begin_mailto("tossplay", "gmail.com",
+ "Email tos...@gm...");</script>tossplay [AT] gmail [DOT] com
+<script type="text/javascript">end_mailto();</script>
+</span>
+<br/>
+</p>
+
+<h2>How Do I Move?</h2>
+<p style="line-height: 130%;">
+At tPlay you make moves just by clicking on the fields from and to which you
+move. In case there is only a single possible move, it is made directly to
+speed up the play. If you make moves by mistake, activate the
+<span style="font-weight: bold;">Ask Before Move</span> control
+in the bottom-left of the screen. Then you will be asked to confirm
+each selected move before it is taken.
+</p>
+
+<h2>What Are The Rules Of The Games?</h2>
+<ul>
+ <li>Breakthrough — break through opponent's lines, see
+ <a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)"
+ style="color: #400827;">Breakthrough on Wikipedia</a>
+<li>Checkers — beat opponent's pieces, see
+ <a href="http://en.wikipedia.org/wiki/English_draughts"
+ style="color: #400827;">Checkers on Wikipedia</a>
+<li>Chess — check-mate, see
+ <a href="http://en.wikipedia.org/wiki/Chess"
+ style="color: #400827;">Chess on Wikipedia</a>
+<li>Connect4 — make a line of four, see
+ <a href="http://en.wikipedia.org/wiki/Connect4"
+ style="color: #400827;">Connect4 on Wikipedia</a>
+</li>
+<li>Gomoku — make a line of five, see
+ <a href="http://en.wikipedia.org/wiki/Gomoku"
+ style="color: #400827;">Gomoku on Wikipedia</a>
+</li>
+<li>Pawn-Whopping — get a pawn to the other end, see
+ <a href="http://en.wikipedia.org/wiki/Pawn_(chess)"
+ style="color: #400827;">Pawn Moves on Wikipedia</a>
+</li>
+</ul>
+
+<h2>How Do I Set The Playing Level?</h2>
+<p style="line-height: 130%;">
+The level at tPlay varies according to the
+<span style="font-weight: bold;">Speed</span> setting in the top right
+corner of the screen. Increase the time for slower but better moves.
+</p>
+
+<h2>Can I Play Other Games?</h2>
+<p style="line-height: 130%;">
+We are adding new games to tPlay all the time.
+Email us your suggestion if you desire a particular game!
+</p>
+
+</div>
+
+<div id="bottom">
+<div id="bottomright">
+<a href="http://toss.sourceforge.net" id="toss-link">Contact</a>
+</div>
+</div>
+
+</div>
+
+
+</body>
+</html>
+
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/Server/Server.ml 2012-03-15 00:18:58 UTC (rev 1694)
@@ -156,6 +156,7 @@
LOG 2 "%s" (String.concat "\n\n" split_msg);
let timeout, gs_s, heurs_s = float_of_string (List.hd split_msg),
List.hd (List.tl split_msg), List.tl (List.tl split_msg) in
+ Play.set_timeout timeout;
let gs = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string gs_s) in
let heurs = ref (List.map (fun s ->
FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)) heurs_s) in
@@ -168,7 +169,6 @@
done;
let heur = Array.of_list (List.rev !res_lst) in
Random.self_init ();
- Play.set_timeout timeout;
let (move, _) = Aux.random_elem (Play.maximax_unfold_choose 1000000
(fst gs) (snd gs) heur) in
Play.cancel_timeout ();
Added: trunk/Toss/Toss.py
===================================================================
--- trunk/Toss/Toss.py (rev 0)
+++ trunk/Toss/Toss.py 2012-03-15 00:18:58 UTC (rev 1694)
@@ -0,0 +1,34 @@
+#!/usr/bin/env python
+
+import sys, subprocess, os
+
+def createdir (d):
+ try:
+ os.mkdir (d)
+ print (d + " created")
+ except OSError:
+ print (d + " exists")
+
+
+server = subprocess.Popen(["./TossServer"], stdout=subprocess.PIPE);
+
+caching = True
+while caching:
+ l = server.stdout.readline()
+ if (l.find("caching finished") > -1): caching = False
+
+profiledir = os.getenv("HOME") + "/.tossfirefoxprofile"
+createdir (profiledir)
+f = open (profiledir + "/user.js", "w")
+f.write ('user_pref("browser.tabs.autoHide", true);')
+f.close ()
+createdir (profiledir + "/chrome")
+f = open (profiledir + "/chrome/userChrome.css", "w")
+f.write ('#nav-bar { display: none; }')
+f.close ()
+
+subprocess.call(["firefox", "-no-remote", "--profile", profiledir,
+ "http://localhost:8110/index.html?simple=true"])
+
+server.terminate()
+print "Finished"
Property changes on: trunk/Toss/Toss.py
___________________________________________________________________
Added: svn:executable
+ *
Deleted: trunk/Toss/run_server.sh
===================================================================
--- trunk/Toss/run_server.sh 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/run_server.sh 2012-03-15 00:18:58 UTC (rev 1694)
@@ -1,3 +0,0 @@
-#!/bin/bash
-# Example script to run the TossServer
-OCAMLRUNPARAM=b; export OCAMLRUNPARAM; /var/www/TossServer -d 0 -eof -mail -nosave -html /var/www/html/ -p 80 -s tplay.org -tID toss_id_0679_ -db /var/www/db/tossdb.sqlite &> /var/www/server_log &
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-16 01:52:31
|
Revision: 1695
http://toss.svn.sourceforge.net/toss/?rev=1695&view=rev
Author: lukaszkaiser
Date: 2012-03-16 01:52:25 +0000 (Fri, 16 Mar 2012)
Log Message:
-----------
Use gzip-compressed js files in TossServer.
Modified Paths:
--------------
trunk/Toss/Client/.cvsignore
trunk/Toss/Client/Makefile
trunk/Toss/Client/index.html
trunk/Toss/Makefile
trunk/Toss/Server/Server.ml
Property Changed:
----------------
trunk/Toss/Client/
Property changes on: trunk/Toss/Client
___________________________________________________________________
Modified: svn:ignore
- # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
clientTestRender*.png
*~
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
clientTestRender*.png
*.js.gz
*~
Modified: trunk/Toss/Client/.cvsignore
===================================================================
--- trunk/Toss/Client/.cvsignore 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Client/.cvsignore 2012-03-16 01:52:25 UTC (rev 1695)
@@ -4,4 +4,5 @@
JsHandler.js
clientTestRender*.png
+*.js.gz
*~
Modified: trunk/Toss/Client/Makefile
===================================================================
--- trunk/Toss/Client/Makefile 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Client/Makefile 2012-03-16 01:52:25 UTC (rev 1695)
@@ -4,6 +4,14 @@
make -C .. Client/JsHandler.js
phantomjs clientTest.js
+JSFILES = $(notdir $(shell find . -maxdepth 1 -name '*.js'))
+JSGZFILES = $(addsuffix .gz, $(JSFILES))
+
+%.js.gz: %.js
+ gzip --best -c $< > $@
+
+alljsgz: $(JSGZFILES)
+
tests: ClientTest
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Client/index.html 2012-03-16 01:52:25 UTC (rev 1695)
@@ -31,7 +31,7 @@
</span>
<span id="appstorelink">
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
- ><img style="height: 24px;" src="img/appstore-small.png" /></a>
+ ><img style="height: 24px; width: 69px;" src="img/appstore-small.png" /></a>
</span>
<span id="toprighttab"><a id="backlink-games" href="index.html">Games</a></span>
</div>
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Makefile 2012-03-16 01:52:25 UTC (rev 1695)
@@ -12,8 +12,10 @@
make $(basename $@).byte
$(JSOCAML) _build/$(basename $@).byte
cat _build/$@ > $@
+ gzip --best -c $@ > $@.gz
TossClient: Client/JsHandler.js
+ make -C Client alljsgz
RELEASE=0.7
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Server/Server.ml 2012-03-16 01:52:25 UTC (rev 1695)
@@ -1,10 +1,9 @@
(* Server for Toss Functions. *)
open OUnit
-let debug_level = ref 0
let set_debug_level i =
- debug_level := i;
+ AuxIO.set_debug_level "Server" i;
AuxIO.set_debug_level "GameTree" i;
AuxIO.set_debug_level "Play" i
@@ -86,7 +85,7 @@
(* ------------ Http Handlers ------------ *)
-let http_msg get code mimetp cookies s =
+let http_msg ?(gz=false) get code mimetp cookies s =
let get_tm s =
let t = Unix.gmtime (Unix.gettimeofday() +. s) in
let day = match t.Unix.tm_wday with
@@ -106,16 +105,23 @@
let cookies_s = String.concat "\n" (List.map ck_str cookies) in
let expires_str = if not get then "" else
"Expires: " ^ (get_tm (float (40 * 24 * 3600))) ^ "\r\n" in
- "HTTP/1.1 " ^ code ^ "\r\n" ^
- "Date: " ^ (get_tm 0.) ^ "\r\n" ^
- "Server: Toss\r\n" ^
- expires_str ^
- "Content-Type: " ^ mimetp ^ "\r\n" ^
- (if cookies = [] then "" else cookies_s ^ "\r\n") ^
- "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+ let head =
+ "HTTP/1.1 " ^ code ^ "\r\n" ^
+ "Date: " ^ (get_tm 0.) ^ "\r\n" ^
+ "Server: Toss\r\n" ^
+ expires_str ^
+ "Content-Type: " ^ mimetp ^ "\r\n" ^
+ (if mimetp = "image/png" then "Cache-Control: public\r\n" else "") ^
+ (if gz then "Content-Encoding: gzip\r\n" else "") ^
+ (if cookies = [] then "" else cookies_s ^ "\r\n") ^
+ "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" in
+ LOG 2 "%s" head;
+ head ^ s
+let ext_two s = String.sub s ((String.index s '.') + 1) 2
+
let mime_type fname =
- match String.sub fname ((String.index fname '.') + 1) 2 with
+ match ext_two fname with
| "ht" -> "text/html; charset=utf-8"
| "ic" -> "image/x-icon"
| "pn" -> "image/png"
@@ -125,7 +131,7 @@
| _ -> "text/html charset=utf-8"
let handle_http_get cmd head msg ck =
- if !debug_level > 1 then (
+ if AuxIO.debug_level_for "Server" > 1 then (
Printf.printf "Http Get Handler\n%s%s\n%!" cmd msg;
if ck <> [] then
let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
@@ -136,16 +142,18 @@
let fname_in = try String.sub fname_in1 0 (String.index fname_in1 '?')
with Not_found -> fname_in1 in
let fname = !html_dir_path ^ fname_in in
- if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
+ let gz= ext_two fname= "js"&& Aux.str_contains head "Accept-Encoding: gzip" in
+ let fname = if gz then fname ^ ".gz" else fname in
+ LOG 1 "SERVING FILE: %s" fname;
try if not !cache_html then raise Not_found else
let content = Hashtbl.find html_cache fname in
LOG 1 "Found %s in html cache" fname;
- http_msg true "200 OK" (mime_type fname) [] content
+ http_msg ~gz true "200 OK" (mime_type fname) [] content
with Not_found ->
if Sys.file_exists fname && not (Sys.is_directory fname) then (
let content = AuxIO.input_file fname in
if !cache_html then Hashtbl.add html_cache fname content;
- http_msg true "200 OK" (mime_type fname) [] content
+ http_msg ~gz true "200 OK" (mime_type fname) [] content
) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
@@ -209,17 +217,17 @@
(String.sub line 0 (line_len-1)) in
match AuxIO.input_if_http_message line in_ch with
| Some (head, msg, cookies) ->
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
+ LOG 1 "Rcvd: %s" msg;
let strip_ws = Aux.strip_spaces in
let ck = List.map (fun (k, v) -> (strip_ws k, strip_ws v)) cookies in
("HTTP", Some (Aux.Left (line, head, msg, ck)))
| None ->
if line = "COMP" then
let res = Marshal.from_channel in_ch in
- if !debug_level > 0 then Printf.printf "COMP, %!";
+ LOG 1 "COMP";
("COMP", Some (Aux.Right res))
else (
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
+ LOG 1 "Rcvd: %s" line;
(line, None)
)
@@ -228,11 +236,8 @@
try
let time_started = Unix.gettimeofday () in
let report (new_rstate, resp) continue =
- if !debug_level > 0 then (
- Printf.printf "Resp-time: %F\n%!" (Unix.gettimeofday() -. time_started);
- if !debug_level > 1 || String.length resp < 500 then
- print_endline ("\nRepl: " ^ resp ^ "\n");
- );
+ LOG 1 "Resp-time: %F" (Unix.gettimeofday() -. time_started);
+ LOG 2 "%s\n" (if String.length resp < 500 then "\nRepl: " ^ resp else "");
output_string out_ch (resp ^ "\n");
flush out_ch;
(new_rstate, continue) in
@@ -312,8 +317,7 @@
if !continue then (* collect zombies *)
try ignore (Unix.waitpid [Unix.WNOHANG] (-1)); with
Unix.Unix_error (e,_,_) ->
- if !debug_level > 1 then
- Printf.printf "UNIX WAITPID: %s\n%!" (Unix.error_message e);
+ LOG 2 "UNIX WAITPID: %s\n%!" (Unix.error_message e);
else (try Unix.close cl_sock with _ -> (); Unix.close sock)
done
@@ -362,7 +366,6 @@
let server_tests = "Server" >::: [
"ServerGDLTest.in GDL Tic-Tac-Toe automatic" >::
(fun () ->
- (* Solver.set_debug_level 2; *)
let old_force_competitive = !Heuristic.force_competitive in
let old_use_monotonic = !Heuristic.use_monotonic in
Heuristic.use_monotonic := true;
@@ -432,7 +435,7 @@
String.sub f 0 (String.index f '.')
else f in
([String.sub name 0 slash], [file]) in
- let verbose = !debug_level > 0 in
+ let verbose = AuxIO.debug_level_for "Server" > 0 in
set_debug_level 0;
quit_on_eof := true;
ignore (OUnit.run_test_tt ~verbose
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-21 20:03:26
|
Revision: 1696
http://toss.svn.sourceforge.net/toss/?rev=1696&view=rev
Author: lukaszkaiser
Date: 2012-03-21 20:03:14 +0000 (Wed, 21 Mar 2012)
Log Message:
-----------
Client and website corrections.
Modified Paths:
--------------
trunk/Toss/Client/Main.js
trunk/Toss/Client/Play.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/www/develop.xml
trunk/Toss/www/docs.xml
trunk/Toss/www/ideas.xml
trunk/Toss/www/index.xml
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/Main.js 2012-03-21 20:03:14 UTC (rev 1696)
@@ -35,7 +35,9 @@
}
nameDISP = disp_name;
+var BLOCKED = false
function handle_elem_click (elem) {
+ if (BLOCKED) return;
PLAY.handle_click (elem);
}
@@ -108,6 +110,8 @@
document.getElementById ("game-title-move").style.display = "inline";
document.getElementById ("game-desc-controls").style.display = "block";
document.getElementById ("suggestions-toggle").style.display = "inline";
+ document.getElementById ("new_game_me_bottom").style.display = "inline";
+ document.getElementById ("new_game_opp_bottom").style.display= "inline";
document.getElementById ("game-disp").style.display = "block";
document.getElementById ("plays").style.left = "30em";
var p = new Play (GAME_NAME, [0,1], [UNAME, opp_uid], 1, 0,
@@ -197,8 +201,10 @@
var DONE_MOVES_MARKER = {}
var MOVE_INDEX = 0
function suggest_move_async (time, f) {
+ BLOCKED = true;
show_moving_msg (time);
var fm = function (m) {
+ BLOCKED = false;
document.getElementById("working").style.display = "none";
document.getElementById("working").innerHTML = "Working...";
console.log ("Algorithm performed " +m.comp_iters +" iterations.");
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/Play.js 2012-03-21 20:03:14 UTC (rev 1696)
@@ -82,8 +82,6 @@
// Handler for clicks on elements in a play.
function play_handle_click (elem) {
- if (typeof CONN != 'undefined' && ASYNC_ALL_REQ_PENDING != 0)
- { return; }
var moves = this.cur_state.get_moves (elem, this.LAST_CLICKED_ELEM);
if (moves.length == 0) {
this.LAST_CLICKED_ELEM = "";
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/Style.css 2012-03-21 20:03:14 UTC (rev 1696)
@@ -268,26 +268,50 @@
top: 2px;
}
+#speedtab {
+ position: absolute;
+ right: 5em;
+ top: .6em;
+ height: 1.5em;
+ background-color: #400827;
+ border-color: #fff1d4;
+ border-style: solid;
+ border-width: 0px 2px 0px 2px;
+ /*border-radius: 6px 6px 0px 0px; */
+ padding-top: 0.1em;
+ padding-bottom: 0.2em;
+ padding-left: 0.2em;
+ padding-right: 0.2em;
+ border-radius: 0px;
+ -moz-border-radius: 0px;
+ /*font-size: 0.9em;
+ -moz-border-radius: 6px 6px 0px 0px; */
+}
+
#speed {
position: relative;
- top: -0.1em;
font-weight: bold;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
- font-size: 0.8em;
color: #fff1d4;
- background-color: #777777;
+ background: none;
+ /* background-color: #400827 */
+ font-size: 1em;
padding: 0px;
margin: 0px;
border-color: #fff1d4;
- border-radius: 4px;
- -moz-border-radius: 4px;
+ /*border-radius: 4px;
+ -moz-border-radius: 4px;*/
border-width: 0px;
}
+#speed:hover {
+ cursor: pointer;
+}
+
.speed_val {
color: #fff1d4;
font-weight: bold;
- background-color: #666666;
+ background-color: #400827;
border-width: 0px;
}
@@ -479,19 +503,20 @@
#toprighttab {
display: none;
position: absolute;
- right: 1em;
- top: 1.3em;
- background-color: #260314;
+ right: .5em;
+ top: .6em;
+ height: 1.5em;
+ /*background-color: #260314;*/
border-color: #fff1d4;
border-style: solid;
- border-width: 2px 2px 0px 2px;
- border-radius: 6px 6px 0px 0px;
+ border-width: 0px;
+ /*border-radius: 6px 6px 0px 0px; */
padding-top: 0.1em;
padding-bottom: 0.2em;
padding-left: 0.2em;
padding-right: 0.2em;
- font-size: 0.9em;
- -moz-border-radius: 6px 6px 0px 0px;
+ /*font-size: 0.9em;
+ -moz-border-radius: 6px 6px 0px 0px; */
}
#bottom {
@@ -527,11 +552,11 @@
#bottomright {
position: absolute;
top: 0em;
- right: 1em;
+ right: 0em;
margin-right: 0em;
}
-#toss-link, .contact, #suggestions-toggle {
+#toss-link, #suggestions-toggle, #new_game_me_bottom, #new_game_opp_bottom {
position: relative;
top: -1px;
padding-left: 0.5em;
@@ -540,21 +565,27 @@
font-size: 1em;
font-weight: bold;
font-family: Verdana;
- background-color: #260314;
+ background-color: #400827; /* #260314 */
border-color: #fff1d4;
border-style: solid;
- border-width: 0px 2px 2px 2px;
+ border-width: 0px 0px 0px 2px;
+ /*border-width: 0px 2px 2px 2px;
border-radius: 0px 0px 6px 6px;
- -moz-border-radius: 0px 0px 6px 6px;
+ -moz-border-radius: 0px 0px 6px 6px;*/
}
-#suggestions-toggle {
+#toss-link {
+ border-width: 0px;
+}
+
+#suggestions-toggle, #new_game_me_bottom, #new_game_opp_bottom {
margin: 0px;
padding-top: 0px;
padding-bottom: 0px;
+ display: none;
}
-#suggestions-toggle:hover {
+#suggestions-toggle:hover,#new_game_me_bottom:hover,#new_game_opp_bottom:hover {
color: #ffffff;
text-decoration: underline;
cursor: pointer;
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/index.html 2012-03-21 20:03:14 UTC (rev 1696)
@@ -33,6 +33,21 @@
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
><img style="height: 24px; width: 69px;" src="img/appstore-small.png" /></a>
</span>
+
+ <span id="speedtab" style="display: none;">
+ Speed: <select id="speed">
+ <option class="speed_val" value="1">1s</option>
+ <option class="speed_val" value="2">2s</option>
+ <option class="speed_val" value="3">3s</option>
+ <option class="speed_val" value="4">4s</option>
+ <option class="speed_val" value="5">5s</option>
+ <option class="speed_val" value="10">10s</option>
+ <option class="speed_val" value="15">15s</option>
+ <option class="speed_val" value="30">30s</option>
+ <option class="speed_val" value="60">60s</option>
+ </select>
+ </span>
+
<span id="toprighttab"><a id="backlink-games" href="index.html">Games</a></span>
</div>
@@ -384,19 +399,12 @@
onclick="toggle_suggestions()">
Ask Before Move
</button>
- <span class="contact" id="speedtab" style="display: none;">
- Speed: <select id="speed">
- <option class="speed_val" value="1">1s</option>
- <option class="speed_val" value="2">2s</option>
- <option class="speed_val" value="3">3s</option>
- <option class="speed_val" value="4">4s</option>
- <option class="speed_val" value="5">5s</option>
- <option class="speed_val" value="10">10s</option>
- <option class="speed_val" value="15">15s</option>
- <option class="speed_val" value="30">30s</option>
- <option class="speed_val" value="60">60s</option>
- </select>
- </span>
+ <button id="new_game_opp_bottom" onclick="play_anew(false)">
+ New Game (Opponent Starts)
+ </button>
+ <button id="new_game_me_bottom" onclick="play_anew(true)">
+ New Game (You Start)
+ </button>
</div>
</div>
Modified: trunk/Toss/www/develop.xml
===================================================================
--- trunk/Toss/www/develop.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/develop.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -21,7 +21,10 @@
<item>If you want to develop Toss on
<a href="http://www.ubuntu.com/">Ubuntu</a>,
here is a command with a list of packages to install.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Then download
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a>, unpack it and do <em>make; sudo make install</em>
</item>
<item>To develop Toss on
<a href="http://www.apple.com/macosx/">MacOSX</a>,
@@ -29,8 +32,8 @@
<a href="http://www.macports.org/">MacPorts</a> (Xcode required)
and do the following.<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> download
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Then download
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a>, unpack it and do <em>make; sudo make install</em>
</item>
<item>This command will checkout the
@@ -53,7 +56,11 @@
<a href="http://www.ubuntu.com/">Ubuntu</a>
kompilieren möchte, braucht man
Pakete, die mit folgender Zeile installiert werden können.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Dann muss man
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a> runterladen, auspacken und dort
+ <em>make; sudo make install</em> ausführen
</item>
<item>Um Toss unter
<a href="http://www.apple.com/macosx/">MacOSX</a>
@@ -61,8 +68,8 @@
<a href="http://www.macports.org/">MacPorts</a> (Xcode nötig).
Mit MacPorts muss man folgendes installieren.<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> dann
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Dann muss man
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a> runterladen, auspacken und dort
<em>make; sudo make install</em> ausführen
</item>
@@ -82,19 +89,21 @@
<a href="http://caml.inria.fr/">Objective Camlu</a>
i wymaga <em>ocamlbuilda</em> i <em>make</em> do kompilacji.
</item>
- <item>Pod
- <a href="http://www.ubuntu.com/">Ubuntu</a>,
+ <item>Pod <a href="http://www.ubuntu.com/">Ubuntu</a>,
poniższe polecenie zainstaluje pakiety
niezbędne do kompilacji Tossa.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Potem trzeba ściągnąć
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a>, rozpakować i wykonać <em>make; sudo make install</em>
</item>
<item>Pod <a href="http://www.apple.com/macosx/">MacOSX</a>
polecamy zainstalować
<a href="http://www.macports.org/">MacPorts</a> (wymaga Xcode)
i wywołać poniższe polecenie.<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> potem ściągnąć
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Potem trzeba ściągnąć
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a>, rozpakować i wykonać <em>make; sudo make install</em>
</item>
<item>Poniższe polecenie ściągnie
@@ -116,14 +125,17 @@
<item>Si vous souhaitez développer Toss sur
<a href="http://www.ubuntu.com/">Ubuntu</a>,
voici une commande avec une liste des paquets à installer.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Ensuite téléchargez
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a>, déballer et faire <em>make; sudo make install</em>
</item>
<item>Si vous souhaitez développer Toss sur
<a href="http://www.apple.com/macosx/">MacOSX</a>, installe
<a href="http://www.macports.org/">MacPorts</a> (et Xcode) et faire<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> téléchargez
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Ensuite téléchargez
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a>, déballer et faire <em>make; sudo make install</em>
</item>
<item>Cette commande checkout du
Modified: trunk/Toss/www/docs.xml
===================================================================
--- trunk/Toss/www/docs.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/docs.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -179,10 +179,6 @@
Structure Rewriting Games</a>.
</item>
- <item><em>Idée et spécification</em> du Toss sont décrites dans
- <a href="reference/reference.pdf">reference.pdf</a>.
- </item>
-
<item><em>Complexité</em> d'un fragment syntaxique du Toss a été analysée
dans le papier <a href="pub/graph_games_short.pdf">Synthesis
for Structure Rewriting Systems</a>.
Modified: trunk/Toss/www/ideas.xml
===================================================================
--- trunk/Toss/www/ideas.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/ideas.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -13,7 +13,7 @@
<link id="ideas" href="/ideas.html">Development Ideas</link>
</history>
- <section title="Google Summer of Code 2012">
+<!-- <section title="Google Summer of Code 2012">
<par>Toss is applying to participate in <em>Google Summer of Code</em>
in 2012. This page contains a few ideas for students who wish to work
on Toss this summer. But, most importantly, we welcome new ideas from
@@ -22,7 +22,7 @@
Make sure to contact us, we are very positive about suggestions and
we think that the best proposals (and code) come from students who are
simply passionate about realizing their own ideas!<br/></par>
- </section>
+ </section>
<section title="Your Project Proposal">
<par>If you decide to present your own idea, here are a few questions
@@ -47,14 +47,10 @@
<itemize>
<item>Toss Mailing List:
<mailto address="tos...@li..."/></item>
- <item>Łukasz Kaiser (GSoC admin):
+ <item>Łukasz Kaiser:
<mailto address="luk...@gm..."/></item>
- <item>Łukasz Stafiniak (GSoC backup admin):
- <mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
- </section>
+ </section> -->
<section title="Idea: Go and Arimaa">
@@ -213,7 +209,7 @@
standard games well, including single-player games which do not translate
well now. By the end, the majority of games in GDL will translate
well and will be made usable from the web interface. The GGP Competition
- starts around the end of GSoC, so of course the best final goal would be
+ starts around autumn, so of course the best final goal would be
for Toss to score a win there!
<br/><br/></par>
<par><em>Modules (in planned construction order).</em>
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/index.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -266,38 +266,6 @@
</section>
- <section title="Scientific Background of Toss" lang="en">
- <par>To learn more about the mathematical background and
- the design of Toss, use the following links.</par>
- <itemize>
- <item><em>Compact description</em> of the mathematical model behind Toss
- and our UCT game playing algorithm can be found in the paper
- <a href="pub/playing_structure_rewriting_games.pdf">Playing
- Structure Rewriting Games</a>.
- </item>
-
- <item><em>Design and specification</em> of Toss are described in
- the <a href="reference/reference.pdf">reference.pdf</a> document.
- </item>
-
- <item> <em>Complexity</em> of a syntactic fragment of Toss was analyzed in
- the paper <a href="pub/graph_games_short.pdf">Synthesis
- for Structure Rewriting Systems</a>.
- </item>
-
- <item><em>Presentation</em> on the mathematics behind Toss was given at
- <em>IIT Kanpur</em> and can be
- <a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi">
- watched</a> online.
- </item>
-
- <item><em>Shorter presentation</em> focusing on the AI side was given at
- <em>AGI 2010</em> and can also be
- <a href="http://www.vimeo.com/15326245">watched</a> online.
- </item>
- </itemize>
- </section>
-
<section title="Mathematische Grundlagen von Toss" lang="de">
<par>Um mehr über Toss zu erfahren, folge diesen Links.</par>
<itemize>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-29 22:30:15
|
Revision: 1697
http://toss.svn.sourceforge.net/toss/?rev=1697&view=rev
Author: lukaszkaiser
Date: 2012-03-29 22:30:09 +0000 (Thu, 29 Mar 2012)
Log Message:
-----------
Starting Hnefatafl implementation in Toss.
Modified Paths:
--------------
trunk/Toss/www/index.xml
Added Paths:
-----------
trunk/Toss/examples/Hnefatafl.toss
Added: trunk/Toss/examples/Hnefatafl.toss
===================================================================
--- trunk/Toss/examples/Hnefatafl.toss (rev 0)
+++ trunk/Toss/examples/Hnefatafl.toss 2012-03-29 22:30:09 UTC (rev 1697)
@@ -0,0 +1,55 @@
+PLAYERS 1, 2
+REL w(x) = wP(x) or wK(x)
+REL FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not bP(y))
+REL FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not bP(y))
+REL Col (x, y) = ex z (FreeC (x, z) and (z = y or (C(z, y) or C(y, z))))
+REL Row (x, y) = ex z (FreeR (x, z) and (z = y or (R(z, y) or R(y, z))))
+REL Line (x, y) = Col (x, y) or Row (x, y)
+REL WinWhite () = ex x (wK(x) and X(x))
+RULE WhitePawn:
+ [ a, b | wP { a } | - ] -> [ a, b | wP { b } | - ]
+ emb wP, wK, bP, X, T pre Line(a, b) and not WinWhite ()
+RULE WhiteKing:
+ [ a, b | wP { a } | - ] -> [ a, b | wP { b } | - ]
+ emb wP, wK, bP, X pre Line(a, b) and not WinWhite ()
+RULE BlackPawn:
+ [ a, b | bP { a } | - ] -> [ a, b | bP { b } | - ]
+ emb wP, wK, bP, X, T pre Line(a, b) and not WinWhite ()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WinWhite())
+ MOVES [WhitePawn -> 1]; [WhiteKing -> 1]
+ }
+ PLAYER 2 { PAYOFF -1 * :(WinWhite()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WinWhite()) }
+ PLAYER 2 {
+ PAYOFF -1 * :(WinWhite())
+ MOVES [BlackPawn -> 0]
+ }
+}
+START [ | | ] "
+ ... ... ... ... ...
+ X ... bP.bP bP.bP bP. ...X
+ ... ... ... ... ... ...
+ ... ... ...bP ... ... ...
+ ... ... ... ... ...
+ ... ... ... ... ...
+ ... ... ... ... ... ...
+ bP. ... ...wP ... ... bP.
+ ... ... ... ... ...
+ bP ... ...wP wP.wP ... ...bP
+ ... ... ...T ... ... ...
+ bP.bP ...wP wP.wK wP.wP ...bP bP.
+ ... ... ... ... ...
+ bP ... ...wP wP.wP ... ...bP
+ ... ... ... ... ... ...
+ bP. ... ...wP ... ... bP.
+ ... ... ... ... ...
+ ... ... ... ... ...
+ ... ... ... ... ... ...
+ ... ... ... ... ... ...
+ ... ... bP. ... ...
+ X ... bP.bP bP.bP bP. ...X
+"
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-03-21 20:03:14 UTC (rev 1696)
+++ trunk/Toss/www/index.xml 2012-03-29 22:30:09 UTC (rev 1697)
@@ -65,18 +65,22 @@
<section title="News">
<itemize>
+ <newsitem date="30/03/12">
+ Adding Hnefatafl to example Toss games</newsitem>
+ <newsitem date="21/03/12">
+ Toss Client and website updated to a cleaned-up JS version</newsitem>
<newsitem date="09/03/12">
First completely working all-JS Toss version</newsitem>
<newsitem date="05/03/12">
Fully integrated OCaml and JS debugging and logs</newsitem>
- <newsitem date="27/02/12">
- Compiled resources to access files from JS</newsitem>
- <newsitem date="18/02/12">
- Integrating OCaml and JS unit tests</newsitem>
- <newsitem date="11/02/12">
- Starting systematic unit tests of JS interface</newsitem>
- <newsitem date="06/02/12">
- Toss release 0.7 with many improvements</newsitem>
+ <oldnewsitem date="27/02/12">
+ Compiled resources to access files from JS</oldnewsitem>
+ <oldnewsitem date="18/02/12">
+ Integrating OCaml and JS unit tests</oldnewsitem>
+ <oldnewsitem date="11/02/12">
+ Starting systematic unit tests of JS interface</oldnewsitem>
+ <oldnewsitem date="06/02/12">
+ Toss release 0.7 with many improvements</oldnewsitem>
<oldnewsitem date="04/02/12">
Definitions use play history: new Chess toss file</oldnewsitem>
<oldnewsitem date="02/02/12">
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-04-17 18:07:44
|
Revision: 1699
http://toss.svn.sourceforge.net/toss/?rev=1699&view=rev
Author: lukaszkaiser
Date: 2012-04-17 18:07:32 +0000 (Tue, 17 Apr 2012)
Log Message:
-----------
Correcting a solver bug, learning Pawn-Whoppining works again.
Modified Paths:
--------------
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/Distinguish.mli
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGame.mli
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/Distinguish.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -1,5 +1,8 @@
open Formula
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
type logic = FO | ExFO | GuardedFO | ExGuardedFO
@@ -14,7 +17,7 @@
let eval structure phi assignment =
(Solver.M.evaluate_partial structure assignment phi) in
let elems = Assignments.set_to_set_list (Structure.elems structure) in
- let vars=Array.map varname (Array.of_list (Aux.range (Array.length tuple))) in
+ let vars =Array.map varname (Array.of_list (Aux.range (Array.length tuple))) in
let assignment = if tuple = [||] then AssignmentSet.Any else
Assignments.assignments_of_list elems vars [tuple] in
eval structure formula assignment <> AssignmentSet.Empty
@@ -185,7 +188,7 @@
List.map Array.of_list (Aux.all_ntuples (Array.to_list tup) k) in
let ktups = List.rev_map k_subtuples (Aux.unique_sorted tups) in
let ktups = Aux.unique_sorted (List.concat ktups) in
- LOG 1 "guarded_types:\t\t tuples generated";
+ if !debug_level>0 then print_endline "guarded_types:\t\t tuples generated";
let mem = Hashtbl.create 63 in
Aux.unique_sorted (List.rev_map
(guarded_type_memo existential struc mem qr) ktups)
@@ -209,7 +212,8 @@
let rec rept i l = if i < 1 then [] else l :: (rept (i-1) l) in
let atoms = Array.of_list (FormulaOps.atoms ~repetitions:repeat_vars
(Structure.rel_signature struc) (varnames 2)) in
- LOG 1 "tc_atomic:\t\t %i atoms\n%!" (Array.length atoms);
+ if !debug_level > 0 then
+ Printf.printf "tc_atomic:\t\t %i atoms\n%!" (Array.length atoms);
let choices = List.rev_map Array.of_list
(if positive then Aux.product (rept (Array.length atoms) [0; 1]) else
Aux.product (rept (Array.length atoms) [0; 1; -1])) in
@@ -257,7 +261,8 @@
(* Helper function: remove atoms from a formula if [cond] is still satisfied.
Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
let rec greedy_remove ?(pos=false) cond phi =
- LOG 2 "greedy_remove:\t\t %s\n%!" (Formula.str phi);
+ if !debug_level > 1 then
+ Printf.printf "greedy_remove:\t\t %s\n%!" (Formula.str phi);
let rec greedy_remove_list minimize constructor acc = function
| [] -> acc
| x :: xs ->
@@ -270,7 +275,7 @@
else greedy_remove_list minimize constructor (x::acc) xs in
let greedy_remove_lst cons lst =
let l = greedy_remove_list false cons [] lst in
- LOG 2 "greedy_remove_lst:\t min %i: %s"
+ if !debug_level > 1 then Printf.printf "greedy_remove_lst:\t min %i: %s\n%!"
(List.length l) (Formula.str (cons l));
greedy_remove_list true cons [] (List.rev l) in
match phi with
@@ -299,8 +304,9 @@
| ExGuardedFO -> guarded_types ~existential:true struc ~qr ~k
| FO -> ntypes struc ~qr ~k
| ExFO -> ntypes ~existential:true struc ~qr ~k in
- LOG 1 "min_type_omitting:\t types generated";
+ if !debug_level > 0 then print_endline "min_type_omitting:\t types generated";
let ok_types = List.filter (fun f -> not (List.mem f neg_types)) pos_types in
+ if !debug_level > 0 then Printf.printf "%i ok_types\n%!" (List.length ok_types);
let ok_types = List.sort !compare_types ok_types in
if ok_types = [] then None else Some (Formula.flatten_sort (List.hd ok_types))
@@ -313,17 +319,19 @@
| FO -> ntypes s ~qr ~k
| ExFO -> ntypes ~existential:true s ~qr ~k in
let neg_tps = Aux.unique_sorted (Aux.concat_map types neg_strucs) in
- LOG 1 "distinguish_upto:\t neg types done (%i): " (List.length neg_tps);
+ if !debug_level > 0 then print_endline "distinguish_upto:\t neg types done";
let fails_on_negs f = not (List.exists (fun s-> check s [||] f) neg_strucs) in
let extend_by_pos acc struc =
if check struc [||] (Or acc) then acc else
match min_type_omitting ~logic ~qr ~k neg_tps struc with
| None -> raise Not_found
- | Some f -> (greedy_remove ~pos:true fails_on_negs f) :: acc in
+ | Some f -> let g = greedy_remove ~pos:true fails_on_negs f in
+ (* Formula.print g; *) g :: acc in
let pos_formulas =
try List.fold_left extend_by_pos [] pos_strucs with Not_found -> [] in
let pos_formulas = Aux.unique_sorted ~cmp:!compare_types pos_formulas in
- LOG 1 "distinguish_upto:\t pos_formulas %i" (List.length pos_formulas);
+ if !debug_level > 0 then Printf.printf
+ "distinguish_upto:\t pos_formulas %i\n%!" (List.length pos_formulas);
if pos_formulas = [] then None else
let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
let is_ok f = fails_on_negs f && succ_pos [f] in
@@ -334,24 +342,27 @@
(* Find a formula holding on all [pos_strucs] and on no [neg_strucs].
Leaves free variables (existential) if [skip_outer_exists] is set. *)
-let distinguish ?(skip_outer_exists=false) s1 s2 =
- LOG 1 "distinguishing:\n\n%s\n\n and\n\n %s\n"
- (String.concat "\n" (List.map Structure.str s1))
- (String.concat "\n" (List.map Structure.str s2));
+let distinguish ?(use_tc=true) ?(skip_outer_exists=false) s1 s2 =
+ if !debug_level > 0 then
+ Printf.printf "distinguishing:\n\n%s\n\n and\n\n %s\n%!"
+ (String.concat "\n" (List.map Structure.str s1))
+ (String.concat "\n" (List.map Structure.str s2));
let rec diff qr k =
if qr > k then diff 0 (k+1) else (
- LOG 1 "distinguish:\t\t qr %i k %i\n%!" qr k;
+ if !debug_level > 0 then
+ Printf.printf "distinguish:\t\t qr %i k %i\n%!" qr k;
if qr = 0 then
match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
- | Some f -> f | None ->
- match tc_atomic_distinguish ~positive:true
- ~repeat_vars:false s1 s2 (3*k) with
- | Some f -> Formula.flatten_sort f | None -> diff (qr+1) k
+ | Some f -> f | None -> if not use_tc then diff (qr+1) k else
+ match tc_atomic_distinguish ~positive:true
+ ~repeat_vars:false s1 s2 (3*k) with
+ | Some f -> Formula.flatten_sort f | None -> diff (qr+1) k
else
match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
| Some f ->
if qr > 1 (* hurry up for large qr *) then f else (
- LOG 1 "distinguish:\t\t guarded found: %s\n%!" (Formula.str f);
+ if !debug_level > 0 then Printf.printf
+ "distinguish:\t\t guarded found: %s\n%!" (Formula.str f);
match distinguish_upto ~logic:ExGuardedFO ~qr ~k s1 s2 with
| Some g-> if 2*(Formula.size f) < Formula.size g then f else g
| None -> f
Modified: trunk/Toss/Learn/Distinguish.mli
===================================================================
--- trunk/Toss/Learn/Distinguish.mli 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/Distinguish.mli 2012-04-17 18:07:32 UTC (rev 1699)
@@ -90,5 +90,5 @@
(** Find a formula holding on all [pos_strucs] and on no [neg_strucs].
Leaves free variables (existential) if [skip_outer_exists] is set. *)
-val distinguish: ?skip_outer_exists: bool ->
+val distinguish: ?use_tc: bool -> ?skip_outer_exists: bool ->
Structure.structure list -> Structure.structure list -> Formula.formula
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/LearnGame.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -1,5 +1,7 @@
(* Learning games from examples. *)
+let tc = ref true
+
let rec evens ?(acc=[0]) k =
let last = (List.hd (List.rev acc)) in
if (List.hd (List.rev acc))> k then
@@ -14,7 +16,7 @@
LOG 1 "Searching WIN:\n%s \nNOT\n%s\n"
(String.concat "\n" (List.map Structure.str winningStates))
(String.concat "\n" (List.map Structure.str notWinningStates));
- let res = Distinguish.distinguish winningStates notWinningStates in
+ let res= Distinguish.distinguish ~use_tc:!tc winningStates notWinningStates in
let print_tc (i, f) =
Printf.sprintf "(tc !%i x0, x1 (%s))" i (Formula.str f) in
match !Distinguish.distinguish_result_tc with
@@ -83,7 +85,7 @@
let (good, bad) = (List.map mark mright, List.map mark mwrong) in
LOG 1 "%s" (String.concat "\n" (List.map Structure.str good));
LOG 1 "%s" (String.concat "\n" (List.map Structure.str bad));
- let pre = Distinguish.distinguish good bad in
+ let pre = Distinguish.distinguish ~use_tc:!tc good bad in
LOG 1 "pre: %s" (Formula.str pre);
let elems = Aux.range ~from:1 ((Structure.nbr_elems (fst m)) + 1) in
let let_part i = Printf.sprintf "let ch%i (x) = x = e%i in" i i in
Modified: trunk/Toss/Learn/LearnGame.mli
===================================================================
--- trunk/Toss/Learn/LearnGame.mli 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/LearnGame.mli 2012-04-17 18:07:32 UTC (rev 1699)
@@ -1,5 +1,7 @@
(** Module for learning games from examples. *)
+(** A flag whether to use the TC operator or not. *)
+val tc : bool ref
(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
game [source]: [wins0] which are now supposed to be won by Player 0,
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -96,6 +96,7 @@
("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose");
("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
("-f", Arg.String (fun s -> testname := s), "process files");
+ ("-notc", Arg.Unit (fun () -> LearnGame.tc := false), "no TC operator");
("-dir", Arg.String (fun s -> dir := s), "set files directory");
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/Makefile 2012-04-17 18:07:32 UTC (rev 1699)
@@ -28,13 +28,19 @@
diff res.toss examples/$(basename $@).toss
rm res.toss
+%.learnnotc:
+ make -C .. Learn/LearnGameTest.native
+ time ../LearnGameTest.native -notc -f $(basename $@) > res.toss
+ diff res.toss examples/$(basename $@).toss
+ rm res.toss
+
learntests:
make Tic-Tac-Toe001.learn
make Tic-Tac-Toe002.learn
make Breakthrough001.learn
make Gomoku001.learn
make Connect4001.learn
- make Pawn-Whopping001.learn
+ make Pawn-Whopping001.learnnotc
%.reco:
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Solver/Solver.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -216,10 +216,10 @@
| Ex (vl, phi) as ephi ->
check_timeout "Solver.eval.Ex";
let aset_vars = AssignmentSet.assigned_vars [] aset in
- if (fp = [] &&
- ((List.exists (fun v->List.mem v aset_vars) vl) ||
- (aset_vars <> [] && FormulaSubst.free_vars ephi = []))) then
- let phi_asgn =
+ let in_aset =
+ if List.exists(fun v->List.mem v aset_vars) vl then Any else aset in
+ let phi_asgn =
+ if (fp = [] && FormulaSubst.free_vars ephi = []) then
try
let (res, _) = Hashtbl.find !cache_results phi in
LOG 2 "In-Eval found in cache: %s" (Formula.str phi);
@@ -228,13 +228,10 @@
LOG 1 "In-Eval_m %s" (str phi);
let phi_asgn = eval fp model elems Any phi in
Hashtbl.add !cache_results phi (phi_asgn, phi_rels phi);
- phi_asgn in
- report (simp (join aset
- (project_list elems phi_asgn (List.map var_str vl))))
- else
- let phi_asgn = eval fp model elems aset phi in
- report (simp (join aset
- (project_list elems phi_asgn (List.map var_str vl))))
+ phi_asgn
+ else eval fp model elems in_aset phi in
+ report (simp (join aset
+ (project_list elems phi_asgn (List.map var_str vl))))
| All (vl, phi) ->
check_timeout "Solver.eval.All";
let aset_vars = AssignmentSet.assigned_vars [] aset in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-05-05 21:58:15
|
Revision: 1700
http://toss.svn.sourceforge.net/toss/?rev=1700&view=rev
Author: lukaszkaiser
Date: 2012-05-05 21:58:06 +0000 (Sat, 05 May 2012)
Log Message:
-----------
Position updates work again; old rewriting exaxample ported to JS interface; many corrections and test updates.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/OUnit.ml
trunk/Toss/Formula/OUnitTest.ml
trunk/Toss/GGP/Makefile
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/DistinguishTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Makefile
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/StructureParser.mly
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/www/index.xml
Added Paths:
-----------
trunk/Toss/Client/img/Rewriting-Example.png
trunk/Toss/examples/Rewriting-Example.toss
Removed Paths:
-------------
trunk/Toss/Client/img/Breakthrough.svg
trunk/Toss/Client/img/Checkers.svg
trunk/Toss/Client/img/Chess.svg
trunk/Toss/Client/img/Connect4.svg
trunk/Toss/Client/img/Entanglement.svg
trunk/Toss/Client/img/Gomoku.svg
trunk/Toss/Client/img/Pawn-Whopping.svg
trunk/Toss/Client/img/Tic-Tac-Toe.svg
trunk/Toss/examples/rewriting_example.toss
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -71,11 +71,12 @@
"setting states from examples dir" >::
(fun () ->
(* skip_if true "Change to simpler and stable example."; *)
- let fname = "./examples/rewriting_example.toss" in
+ let fname = "./examples/Rewriting-Example.toss" in
let contents = AuxIO.input_file fname in
let gs = gs_of_str contents in
assert_equal ~printer:(fun x->x) ~msg:"from file, curly braces style"
- contents (Arena.sprint_state gs);
+ (Aux.normalize_spaces contents)
+ (Aux.normalize_spaces (Arena.sprint_state gs));
);
"move to string" >::
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -113,8 +113,9 @@
Structure.fun_val struc f e
with Not_found ->
failwith
- ("rewrite_single_nocheck: get_val: could not find "^a^
- " in matched "^String.concat "," (List.map fst m))
+ ("rewrite_single_nocheck: get_val: could not find " ^ a ^
+ " in matched " ^ String.concat "," (List.map fst m) ^
+ String.concat "," (List.map (fun (_, e) -> string_of_int e) m))
) in
List.map (fun ((f, a),_) -> Term.Const (get_val f a)) dyn in
let step vals t0 =
@@ -173,8 +174,10 @@
evolved values *)
let asg = AssignmentSet.fo_assgn_of_list m in
let upd_vals = List.map
- (fun (lhs,expr) -> lhs, Solver.M.get_real_val ~asg expr !last_struc)
- upd in
+ (fun (lhs,expr) ->
+ let res = Solver.M.get_real_val ~asg expr !last_struc in
+ LOG 1 "%s(%s) = %f (%s)" (fst lhs) (snd lhs) res (Formula.real_str expr);
+ (lhs, res)) upd in
(* we pass the evolved structure to discrete rewriting, so that
function values can be copied to new elements in case they are
not updated later *)
@@ -203,8 +206,7 @@
if r.post = Formula.And [] then matches struc r else
List.filter is_ok (matches struc r)
-(* For now, we rewrite only single rules. Returns [None] if rewriting
- fails. *)
+(* For now, we rewrite only single rules. Returns [None] if rewriting fails. *)
let rewrite_single struc cur_time m r t params =
let (res_struc, _, _ as res_struc_n_shifts) =
rewrite_single_nocheck struc cur_time m r t params in
@@ -215,21 +217,6 @@
(* -------------------------- PRINTING FUNCTION ----------------------------- *)
-(* Print a rule to string. *)
-let str r =
- let dyn_str =
- if r.dynamics = [] then "" else "\ndynamics\n" ^
- Term.eq_str ~diff:true r.dynamics in
- let upd_str =
- if r.update = [] then "" else "\nupdate\n" ^ (
- Formula.eq_str r.update
- ) ^ "\n" in
- let inv_str = " inv " ^ (Formula.str r.inv) in
- let post_str = " post " ^ (Formula.str r.post) in
- (DiscreteRule.rule_str r.discrete) ^ " " ^
- dyn_str ^ upd_str ^ inv_str ^ post_str
-
-
let has_dynamics r = r.dynamics <> []
(* List.exists (fun (_, t) -> t <> Term.Const 0.) r.dynamics *)
@@ -241,10 +228,10 @@
(DiscreteRule.fprint_full print_compiled) r.discrete;
if has_dynamics r then
Format.fprintf f "@ @[<hv>dynamics@ %a@]"
- (Term.fprint_eqs ~diff:true) r.dynamics;
+ (Term.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
if has_update r then
Format.fprintf f "@ @[<hv>update@ %a@]"
- (Formula.fprint_eqs ~diff:false) r.update;
+ (Formula.fprint_eqs ~diff:false) (List.sort Pervasives.compare r.update);
if r.inv <> Formula.And [] then
Format.fprintf f "@ @[<1>inv@ %a@]" Formula.fprint r.inv;
if r.post <> Formula.And [] then
@@ -255,6 +242,7 @@
let print r = AuxIO.print_of_fprint fprint r
let sprint r = AuxIO.sprint_of_fprint fprint r
+let str = sprint
let matching_str struc emb =
let name (lhs_v,rhs_e) =
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -26,33 +26,33 @@
) else if i+2 < l then String.sub s 0 (i+3) else s
with Not_found -> s
-let tests = "ContinuousRule" >::: [
+let eq_str msg s1 s2 = assert_equal ~msg ~printer:(fun x -> x)
+ (Aux.normalize_spaces s1) (Aux.normalize_spaces s2)
+let tests = "ContinuousRule" >::: [
"parsing" >::
(fun () ->
- let discr =
- "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] emb R with [c <- a, d <- b] " in
- let s = discr ^ " inv true post true" in
+ let discr = "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] " ^
+ " emb R with [c <- a, d <- b]" in
let signat = ["R", 2] in
- let r = rule_of_str s signat [] "rule1" in
- assert_equal ~msg:"1. no continuous" ~printer:(fun x->x) s (str r);
+ let r = rule_of_str discr signat [] "rule1" in
+ eq_str "1. no continuous" discr (str r);
let upd_eq = " :f(c) = 2. * :f(a);\n :f(d) = :f(b)\n" in
- let s = discr ^ "\nupdate\n" ^ upd_eq ^ " inv true post true" in
+ let s = discr ^ "\nupdate\n" ^ upd_eq in
let r = rule_of_str s signat [] "rule2" in
- assert_equal ~msg:"2. update" ~printer:(fun x->x) s (str r);
+ eq_str "2. update" s (str r);
let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
- let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ " inv true post true" in
+ let s = discr ^ "\ndynamics\n" ^ dyn_eq in
let r = rule_of_str s signat [] "rule3" in
- assert_equal ~msg:"3. dynamics" ~printer:(fun x->x) s (str r);
+ eq_str "3. dynamics" s (str r);
let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
let upd_eq = " :f(c) = 2. * :f(a);\n :f(d) = :f(b)\n" in
- let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
- " inv true post true" in
+ let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq in
let r = rule_of_str s signat [] "rule4" in
- assert_equal ~msg:"4. dynamics+update" ~printer:(fun x->x) s (str r);
+ eq_str "4. dynamics+update" s (str r);
);
"fprint" >::
@@ -81,14 +81,6 @@
let s = discr ^ "\n dynamics" ^ dyn_eq ^ "\n update" ^ upd_eq in
let r = rule_of_str s signat [] "rule4" in
assert_equal ~msg:"4. dynamics+update" ~printer:(fun x->x) s (sprint r);
-
- let dyn_eq = dyn_eq1 ^ "\n" ^ dyn_eq2 ^ ";\n" ^ dyn_eq1 ^ "\n" ^ dyn_eq2
- ^ ";\n" ^ dyn_eq1 ^ "\n" ^ dyn_eq2 in
- let upd_eq = upd_eq1 ^ "\n" ^ upd_eq2 ^ ";\n" ^ upd_eq1 ^ "\n" ^ upd_eq2
- ^ ";\n" ^ upd_eq1 ^ "\n" ^ upd_eq2 in
- let s = discr ^ "\n dynamics\n" ^ dyn_eq ^ "\n update\n" ^ upd_eq in
- let r = rule_of_str s signat [] "rule5" in
- assert_equal ~msg:"5. many equations" ~printer:(fun x->x) s (sprint r);
);
"rewrite" >::
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -203,7 +203,7 @@
rel_prods in
let precond =
match disjs with
- | [] -> failwith ("fluent_preconds: not a fluent: "^rel)
+ (* | [] -> failwith ("fluent_preconds: not a fluent: "^rel) *)
| [phi] -> phi
| _ -> Formula.Or disjs in
let precond = FormulaOps.prune_unused_quants precond in
@@ -252,24 +252,11 @@
module SIMap = Structure.IntMap
-(* When LHS/RHS elements are converted to variables, their names are
- used whenever they exist, if they don't, their numbers are prefixed
- with "vV", i.e. vV1, vV2, ... *)
-let elem_of_elemvar names ev =
- try SSMap.find ev names
- with Not_found ->
- int_of_string (String.sub ev 2 (String.length ev - 2))
+(* When LHS/RHS elements are converted to variables, their names are used. *)
+let elem_of_elemvar names ev = SSMap.find ev names
+let elemvar_of_elem inv_names e = SIMap.find e inv_names
-let elemvar_of_elem inv_names e =
- try SIMap.find e inv_names
- with Not_found ->
- "vV"^string_of_int e
-let elemname_of_elemvar ev =
- if String.length ev > 2 && ev.[0]='v' && ev.[1]='V'
- then String.sub ev 2 (String.length ev - 2)
- else ev
-
(* Find all embeddings of a rule. Does not guarantee that rewriting
will succeed for all of them. *)
let find_matchings model rule =
@@ -456,8 +443,7 @@
let model =
List.fold_left (fun model ne ->
let re = Aux.rev_assoc rmmap ne in
- Structure.add_rel model
- ("_right_"^elemname_of_elemvar re) [|ne|]
+ Structure.add_rel model ("_right_" ^ re) [|ne|]
) model alloc_elems in
(* Copy function values from old elements to their corresponding new
elements. *)
@@ -521,8 +507,7 @@
names due to renaming during rule compilation). *)
let model =
List.fold_left (fun model (re, me) ->
- Structure.add_rel model
- ("_right_"^elemname_of_elemvar re) [|me|]
+ Structure.add_rel model ("_right_" ^ re) [|me|]
) model rmmap in
(* Remove RHS-negated relations and add removal trace. *)
let model =
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -77,7 +77,7 @@
let s="[c, a, b |
D {(c, c); (c, a); (c, b); (b, a); (b, b)}; P {c; b}; Q {a; b};
R {(c, c); (a, c); (a, b); (b, c); (b, b)}
- | f {b->3., a->2., c->4.}; g {a->1., c->5.}
+ | f {a->2., b->3., c->4.}; g {a->1., c->5.}
] -> [b, c | D {(c, b); (c, c)}; P (b); R (c, c) | ] emb Q
with [c <- c, b <- a]" in
let r = rule_of_str ["D",2;"R",2;"Q",1;"P",1] s in
@@ -201,13 +201,13 @@
);
- "rewrite: compile_rule integers" >::
+ "rewrite: compile_rule old integers" >::
(fun () ->
let model =
- struc_of_str "[ | P:1 {}; R:2 {}; Q{1} | ]" in
- let lhs_struc = struc_of_str "[ 1 | | ]" in
- let rhs_struc = struc_of_str "[ 1, 2 | P{ (1) } | ]" in
+ struc_of_str "[ | P:1 {}; R:2 {}; Q{a1} | ]" in
+ let lhs_struc = struc_of_str "[ a1 | | ]" in
+ let rhs_struc = struc_of_str "[ a1, a2 | P{ (a1) } | ]" in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -220,13 +220,13 @@
let nmodel =
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x) ~msg:"clone, add to twin"
- "[1, 2 | P (1); Q {1; 2}; R:2 {}; _new_P (1); _right_1 (1); _right_2 (2) | ]"
+ "[a1_a1, a1_a2 | P (a1_a1); Q {a1_a1; a1_a2}; R:2 {}; _new_P (a1_a1); _right_a1 (a1_a1); _right_a2 (a1_a2) | ]"
(Structure.str nmodel);
let model =
- struc_of_str "[ | P{2}; Q{1} | ]" in
- let lhs_struc = struc_of_str "[ | Q{1} | ]" in
- let rhs_struc = struc_of_str "[ 1, 2 | Q:1{}; _opt_Q{2}; P{1} | ]" in
+ struc_of_str "[ | P{a2}; Q{a1} | ]" in
+ let lhs_struc = struc_of_str "[ | Q{a1} | ]" in
+ let rhs_struc = struc_of_str "[ a1, a2 | Q:1{}; _opt_Q{a2}; P{a1} | ]" in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -239,14 +239,14 @@
let nmodel =
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x) ~msg:"clone, remove from twin"
- "[1, 2, 3 | P {1; 2}; Q (3); _del_Q (1); _new_P (1); _right_1 (1); _right_2 (3) | ]"
+ ("[a2, a1_a1, a1_a2 | P {a2; a1_a1}; Q (a1_a2); _del_Q (a1_a1);" ^
+ " _new_P (a1_a1); _right_a1 (a1_a1); _right_a2 (a1_a2) | ]")
(Structure.str nmodel);
let model =
- struc_of_str "[ | R{1}; Q{1}; P:1{ } | ]" in
-
- let lhs_struc = struc_of_str "[ | Q{1} | ]" in
- let rhs_struc = struc_of_str "[ 1, 2 | Q:1{}; P{1} | ]" in
+ struc_of_str "[ | R{a1}; Q{a1}; P:1{ } | ]" in
+ let lhs_struc = struc_of_str "[ | Q{a1} | ]" in
+ let rhs_struc = struc_of_str "[ a1, a2 | Q:1{}; P{a1} | ]" in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -259,13 +259,16 @@
let nmodel =
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x) ~msg:"clone, remove, add to twin"
- "[1, 2 | P (1); Q:1 {}; R {1; 2}; _del_Q {1; 2}; _new_P (1); _right_1 (1); _right_2 (2) | ]"
+ ("[a1_a1, a1_a2 | P (a1_a1); Q:1 {}; R {a1_a1; a1_a2}; _del_Q {a1_a1;" ^
+ " a1_a2}; _new_P (a1_a1); _right_a1 (a1_a1); _right_a2 (a1_a2) | ]")
(Structure.str nmodel);
let model =
- struc_of_str "[ | P:1{ }; R{(1,2)}; C{(2,3)}; D{(1,3)} | ]" in
- let lhs_struc = struc_of_str "[ 1,2 | R{ (2,1) } | ]" in
- let rhs_struc = struc_of_str "[ 1,2,3 | P{ (2) }; R:2{}; _opt_R { (1,1); (1,2); (1,3); (2,2); (2,3); (3,2); (3,3) } | ]" in
+ struc_of_str "[ | P:1{ }; R{(a1,a2)}; C{(a2,a3)}; D{(a1,a3)} | ]" in
+ let lhs_struc = struc_of_str "[ a1, a2 | R{ (a2,a1) } | ]" in
+ let rhs_struc = struc_of_str
+ ("[ a1,a2,a3 | P{ (a2) }; R:2{}; _opt_R { (a1,a1); (a1,a2); (a1,a3);" ^
+ " (a2,a2); (a2,a3); (a3,a2); (a3,a3) } | ]") in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -279,7 +282,9 @@
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x)
~msg:"clone, copy rels, remove, add to twin"
- "[1, 2, 3, 4 | C (1, 3); D {(2, 3); (4, 3)}; P (2); R:2 {}; _del_R {(2, 1); (4, 1)}; _new_P (2); _right_1 (1); _right_2 (2); _right_3 (4) | ]"
+ ("[a2, a1_a2, a3, a1_a3 | C (a2, a3); D {(a1_a2, a3); (a1_a3, a3)}; " ^
+ "P (a1_a2); R:2 {}; _del_R {(a1_a2, a2); (a1_a3, a2)}; _new_P " ^
+ "(a1_a2); _right_a1 (a2); _right_a2 (a1_a2); _right_a3 (a1_a3) | ]")
(Structure.str nmodel);
);
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -66,6 +66,7 @@
("Gomoku", AuxIO.input_file "examples/Gomoku.toss");
("Pawn-Whopping", AuxIO.input_file "examples/Pawn-Whopping.toss");
("Tic-Tac-Toe", AuxIO.input_file "examples/Tic-Tac-Toe.toss");
+ ("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/State.js 2012-05-05 21:58:06 UTC (rev 1700)
@@ -195,6 +195,11 @@
return (elem_cl);
}
+function square_elements_game (game) {
+ return (game !== "Connect4" &&
+ game !== "Rewriting-Example")
+}
+
// Draw the model.
function state_draw_model (game) {
var draw_background = function (game) {
@@ -208,7 +213,7 @@
// Draw the element [elem].
var draw_elem = function (game, elem) {
- if (game != "Connect4") {
+ if (square_elements_game (game)) {
var r = SHAPES.rect (
elem.x, elem.y, 2 * SHAPES.elem_size_x, 2 * SHAPES.elem_size_y,
[["id", "elem_" + elem.id], ["class", elem_class(elem.id)],
@@ -244,10 +249,10 @@
}
}
if (rel.args.length == 2) {
- if (rel.name == "E") {
+ if (rel.name !== "R" && rel.name !== "C") {
var l = SHAPES.line (rel.args[0].x, rel.args[0].y,
rel.args[1].x, rel.args[1].y,
- [["class", "model-edge-E"]]);
+ [["class", "model-edge-" + rel.name]]);
document.getElementById("svg").appendChild(l);
}
}
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/Style.css 2012-05-05 21:58:06 UTC (rev 1700)
@@ -1112,9 +1112,15 @@
.model-edge-E {
fill: #260314;
stroke: #260314;
- stroke-width: 3px;
+ stroke-width: 4px;
}
+.model-edge-S {
+ fill: #400827;
+ stroke: #400827;
+ stroke-width: 2px;
+}
+
.Game-Chess .chessW .chess-path-A, .Game-Pawn-Whopping .chessW .chess-path-A {
opacity: 1;
fill: #fff1d4;
Deleted: trunk/Toss/Client/img/Breakthrough.svg
===================================================================
--- trunk/Toss/Client/img/Breakthrough.svg 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/img/Breakthrough.svg 2012-05-05 21:58:06 UTC (rev 1700)
@@ -1,3 +0,0 @@
-<?xml-stylesheet href="Style.css" type="text/css"?>
-<svg id="svg" viewBox="0 0 580 580">
-<rect class="model-elem-0" x="4.285714285714285" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_a1" ></rect><rect class="model-elem-1" x="75.71428571428572" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_b1" ></rect><rect class="model-elem-0" x="147.14285714285714" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_c1" ></rect><rect class="model-elem-1" x="218.57142857142856" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_d1" ></rect><rect class="model-elem-0" x="290" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_e1" ></rect><rect class="model-elem-1" x="361.42857142857144" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_f1" ></rect><rect class="model-elem-0" x="432.85714285714283" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_g1" ></rect><rect class="model-elem-1" x="504.2857142857143" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_h1" ></rect><rect class="model-elem-1" x="4.285714285714285" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_a2" ></rect><rect class="model-elem-0" x="75.71428571428572" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_b2" ></rect><rect class="model-elem-1" x="147.14285714285714" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_c2" ></rect><rect class="model-elem-0" x="218.57142857142856" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_d2" ></rect><rect class="model-elem-1" x="290" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_e2" ></rect><rect class="model-elem-0" x="361.42857142857144" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_f2" ></rect><rect class="model-elem-1" x="432.85714285714283" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_g2" ></rect><rect class="model-elem-0" x="504.2857142857143" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_h2" ></rect><rect class="model-elem-0" x="4.285714285714285" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_a3" ></rect><rect class="model-elem-1" x="75.71428571428572" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_b3" ></rect><rect class="model-elem-0" x="147.14285714285714" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_c3" ></rect><rect class="model-elem-1" x="218.57142857142856" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_d3" ></rect><rect class="model-elem-0" x="290" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_e3" ></rect><rect class="model-elem-1" x="361.42857142857144" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_f3" ></rect><rect class="model-elem-0" x="432.85714285714283" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_g3" ></rect><rect class="model-elem-1" x="504.2857142857143" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_h3" ></rect><rect class="model-elem-1" x="4.285714285714285" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_a4" ></rect><rect class="model-elem-0" x="75.71428571428572" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_b4" ></rect><rect class="model-elem-1" x="147.14285714285714" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_c4" ></rect><rect class="model-elem-0" x="218.57142857142856" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_d4" ></rect><rect class="model-elem-1" x="290" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_e4" ></rect><rect class="model-elem-0" x="361.42857142857144" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_f4" ></rect><rect class="model-elem-1" x="432.85714285714283" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_g4" ></rect><rect class="model-elem-0" x="504.2857142857143" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_h4" ></rect><rect class="model-elem-0" x="4.285714285714285" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_a5" ></rect><rect class="model-elem-1" x="75.71428571428572" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_b5" ></rect><rect class="model-elem-0" x="147.14285714285714" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_c5" ></rect><rect class="model-elem-1" x="218.57142857142856" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_d5" ></rect><rect class="model-elem-0" x="290" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_e5" ></rect><rect class="model-elem-1" x="361.42857142857144" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_f5" ></rect><rect class="model-elem-0" x="432.85714285714283" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_g5" ></rect><rect class="model-elem-1" x="504.2857142857143" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_h5" ></rect><rect class="model-elem-1" x="4.285714285714285" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_a6" ></rect><rect class="model-elem-0" x="75.71428571428572" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_b6" ></rect><rect class="model-elem-1" x="147.14285714285714" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_c6" ></rect><rect class="model-elem-0" x="218.57142857142856" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_d6" ></rect><rect class="model-elem-1" x="290" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_e6" ></rect><rect class="model-elem-0" x="361.42857142857144" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_f6" ></rect><rect class="model-elem-1" x="432.85714285714283" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_g6" ></rect><rect class="model-elem-0" x="504.2857142857143" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_h6" ></rect><rect class="model-elem-0" x="4.285714285714285" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_a7" ></rect><rect class="model-elem-1" x="75.71428571428572" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_b7" ></rect><rect class="model-elem-0" x="147.14285714285714" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_c7" ></rect><rect class="model-elem-1" x="218.57142857142856" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_d7" ></rect><rect class="model-elem-0" x="290" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_e7" ></rect><rect class="model-elem-1" x="361.42857142857144" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_f7" ></rect><rect class="model-elem-0" x="432.85714285714283" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_g7" ></rect><rect class="model-elem-1" x="504.2857142857143" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_h7" ></rect><rect class="model-elem-1" x="4.285714285714285" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_a8" ></rect><rect class="model-elem-0" x="75.71428571428572" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_b8" ></rect><rect class="model-elem-1" x="147.14285714285714" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_c8" ></rect><rect class="model-elem-0" x="218.57142857142856" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_d8" ></rect><rect class="model-elem-1" x="290" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_e8" ></rect><rect class="model-elem-0" x="361.42857142857144" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_f8" ></rect><rect class="model-elem-1" x="432.85714285714283" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_g8" ></rect><rect class="model-elem-0" x="504.2857142857143" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_h8" ></rect><circle class="model-pred-B" cx="40" cy="111.42857142857143" r="23.714285714285715" id="pred_a7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="111.42857142857143" cy="111.42857142857143" r="23.714285714285715" id="pred_b7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="182.85714285714286" cy="111.42857142857143" r="23.714285714285715" id="pred_c7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="254.28571428571428" cy="111.42857142857143" r="23.714285714285715" id="pred_d7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="325.7142857142857" cy="111.42857142857143" r="23.714285714285715" id="pred_e7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="397.14285714285717" cy="111.42857142857143" r="23.714285714285715" id="pred_f7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="468.57142857142856" cy="111.42857142857143" r="23.714285714285715" id="pred_g7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="540" cy="111.42857142857143" r="23.714285714285715" id="pred_h7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="40" cy="40" r="23.714285714285715" id="pred_a8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="111.42857142857143" cy="40" r="23.714285714285715" id="pred_b8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="182.85714285714286" cy="40" r="23.714285714285715" id="pred_c8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="254.28571428571428" cy="40" r="23.714285714285715" id="pred_d8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="325.7142857142857" cy="40" r="23.714285714285715" id="pred_e8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="397.14285714285717" cy="40" r="23.714285714285715" id="pred_f8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="468.57142857142856" cy="40" r="23.714285714285715" id="pred_g8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="540" cy="40" r="23.714285714285715" id="pred_h8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx=...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-06 22:17:54
|
Revision: 1701
http://toss.svn.sourceforge.net/toss/?rev=1701&view=rev
Author: lukaszkaiser
Date: 2012-05-06 22:17:46 +0000 (Sun, 06 May 2012)
Log Message:
-----------
Animation in JS interface - Bounce example works.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Main.js
trunk/Toss/Client/Play.js
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/examples/Hnefatafl.toss
Added Paths:
-----------
trunk/Toss/Client/img/Bounce.png
trunk/Toss/Client/img/Hnefatafl.png
trunk/Toss/examples/Bounce.toss
Removed Paths:
-------------
trunk/Toss/examples/bounce.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Arena/Arena.ml 2012-05-06 22:17:46 UTC (rev 1701)
@@ -654,8 +654,8 @@
let mtch = List.map (fun (v, e) ->
v, Structure.elem_nbr state.struc e) mv.matching in
Aux.map_option
- (fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *)
- (mv,
+ (fun (model, time, shifts) ->
+ ((mv, shifts),
{cur_loc = mv.next_loc;
history = (mv, None) :: state.history;
struc = model;
@@ -667,9 +667,9 @@
let gen_models rules state time moves =
let res = gen_models_list rules state time moves in
let moves, states = List.split res in
- Array.of_list moves, Array.of_list states
+ Array.of_list (List.map fst moves), Array.of_list states
-let list_moves game s =
+let list_moves_shifts game s =
let select_moving a =
let pls = Aux.array_argfind_all (fun l -> l.moves <> []) a in
if pls = [] then [0] else pls in
@@ -677,13 +677,14 @@
let moving = select_moving loc in
let get_moves pl =
let m = gen_moves cGRID_SIZE game.rules s.struc loc.(pl) in
- (gen_models_list game.rules s s.time m) in
+ gen_models_list game.rules s s.time m in
Array.of_list (List.concat (
List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
+let list_moves game s =
+ Array.map (fun (p,a,b) -> (p, fst a, b)) (list_moves_shifts game s)
-
let apply_rule_int (state_game, state) (r_name, mtch, t, p) =
(let try r = List.assoc r_name state_game.rules in (
match ContinuousRule.rewrite_single state.struc state.time mtch r t p with
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Arena/Arena.mli 2012-05-06 22:17:46 UTC (rev 1701)
@@ -188,6 +188,9 @@
the player together with a move. *)
val list_moves : game -> game_state -> (int * move * game_state) array
+(** As [list_moves] but with animation shifts for each move. *)
+val list_moves_shifts : game -> game_state ->
+ (int * (move * ((string * string) * Term.term list) list) * game_state) array
val apply_rule_int : game * game_state ->
string * (string * int) list * float * (string * float) list ->
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-06 22:17:46 UTC (rev 1701)
@@ -96,7 +96,7 @@
(* For now, we rewrite only single rules. Does not check postcondition. *)
let rewrite_single_nocheck struc cur_time m r t params =
let time = ref cur_time in
- LOG 2 "current time: %f" !time;
+ LOG 1 "current time: %f" !time;
let p_vars, p_vals = List.split params in
let subst_params tm =
List.hd
@@ -130,11 +130,9 @@
let cur_vals = ref init_vals in
let all_vals = ref [] in
let end_time = !time +. t -. (0.01 *. !time_step) in (*TODO: 1% is decimals!*)
- LOG 2 "end time: %f" end_time;
+ LOG 1 "end time: %f" end_time;
let is_inv s = Solver.M.check s r.inv in
- let lhs_to_model ((f, a), _) =
- (* dynamics refer to elements by LHS matches *)
- (f, List.assoc a m) in
+ let lhs_to_model ((f, a), _) = (f, List.assoc a m) in
let upd_struct st =
let vals =
List.combine (List.map lhs_to_model dyn)
@@ -154,13 +152,18 @@
) else (
LOG 2 "Invariant failed.\n%s\n%s"
(Structure.str !cur_struc) (Formula.sprint r.inv);
- cur_vals := List.hd !all_vals;
+ if !all_vals = [] then
+ failwith "rewriting invariant failed in the first step; rule inapplicable"
+ else cur_vals := List.hd !all_vals;
);
let lhs_to_model_str x =
let (f, i) = lhs_to_model x in
f, Structure.elem_str struc i in
let all_vals_assoc =
select_pos (List.map lhs_to_model_str dyn) (List.rev !all_vals) in
+ LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
+ (String.concat ", " (List.map (
+ fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));
(*
let val_map =
if !cur_vals = [] then List.combine (List.map fst dyn) init_vals
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-06 22:17:46 UTC (rev 1701)
@@ -66,7 +66,9 @@
("Gomoku", AuxIO.input_file "examples/Gomoku.toss");
("Pawn-Whopping", AuxIO.input_file "examples/Pawn-Whopping.toss");
("Tic-Tac-Toe", AuxIO.input_file "examples/Tic-Tac-Toe.toss");
+ ("Hnefatafl", AuxIO.input_file "examples/Hnefatafl.toss");
("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
+ ("Bounce", AuxIO.input_file "examples/Bounce.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
@@ -108,8 +110,7 @@
Js.Unsafe.set js_handler (js name) (Js.wrap_callback f)
(* In case the handler is used in the same thread: *)
-let _ =
- Js.Unsafe.set self (js"LOCAL") js_handler
+let _ = Js.Unsafe.set self (js"LOCAL") js_handler
(* In case the handler is used as Web Worker: *)
let postMessage = Js.Unsafe.variable "postMessage"
@@ -140,7 +141,7 @@
js ("Now " ^ of_js s ^ " tested")
let _ = set_handle "test_handle" test_handle
-let js_of_move game state move_id (player, move, _) =
+let js_of_move game state move_id (player, (move, _), _) =
let matched = Js.array
(Aux.array_map_of_list (fun (_, e) -> js e) move.Arena.matching) in
let js_move = jsnew js_object () in
@@ -151,25 +152,30 @@
Js.Unsafe.set js_move (js"id") (Js.float (float_of_int move_id));
js_move
-(* Translate current structure into an "info_obj" format. *)
-let js_of_game_state ?(show_payoffs=true) game state =
+(* Get dimensions of a structure (minx, maxx, miny, maxy). *)
+let state_dim state =
let struc = state.Arena.struc in
- let get_pos e =
- Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
- LOG 1 "js_of_game_state: Preparing game elements...";
+ let get_pos e= Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
let elems = Structure.elements struc in
let (posx, posy) = List.split (List.map get_pos elems) in
let mkfl f l = List.fold_left f (List.hd l) (List.tl l) in
let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
- let minx, maxx, miny, maxy = minl posx, maxl posx, minl posy, maxl posy in
+ minl posx, maxl posx, minl posy, maxl posy
+
+(* Translate current structure into an "info_obj" format. *)
+let js_of_game_state ?(show_payoffs=true) ?dims game state =
+ let struc = state.Arena.struc in
+ let elems = Structure.elements struc in
+ LOG 1 "js_of_game_state: Preparing game elements...";
+ let get_pos e = Structure.fun_val struc "x" e,Structure.fun_val struc "y" e in
+ let minx, maxx, miny, maxy = match dims with
+ | None -> state_dim state | Some d -> d in
(* elems are arrays of element name and position *)
- let elems = Array.of_list
- (List.map
- (fun e ->
- let e0 = js (Structure.elem_name struc e) in
- let x, y = get_pos e in
- Js.array [|js_any e0; js_any (Js.float x); js_any (Js.float y)|])
- elems) in
+ let elems = Array.of_list (List.map (fun e ->
+ let e0 = js (Structure.elem_name struc e) in
+ let x, y = get_pos e in
+ Js.array [|js_any e0; js_any (Js.float x); js_any (Js.float y)|]
+ ) elems) in
(* rels are arrays of element names, with additional "name" field *)
let num = Js.number_of_float in
LOG 1 "js_of_game_state: Preparing game relations...";
@@ -197,7 +203,7 @@
if !cur_all_moves <> [||] then
Js.Unsafe.set info_obj (js"moves")
(Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
- else if show_payoffs then ( (* find payoffs *)
+ else if show_payoffs then ( (* find payoffs *)
let payoffs = Array.mapi
(fun i v -> i, Solver.M.get_real_val v.Arena.payoff struc)
game.Arena.graph.(state.Arena.cur_loc) in
@@ -232,7 +238,7 @@
let game, state = game_data.game_state in
cur_game := game_data;
play_states := [state];
- cur_all_moves := Arena.list_moves game state;
+ cur_all_moves := Arena.list_moves_shifts game state;
cur_move := 0;
LOG 1 "new_play (%s): calling js_of_game_state." game_name;
js_of_game_state game state
@@ -248,17 +254,34 @@
let _ = set_handle "prev_move" preview_move
+(* Compute all copies of [state] given by [shifts], including [state]. *)
+let shifted_state state shifts =
+ if shifts = [] then [state] else
+ let len, res = List.length (snd (List.hd shifts)), ref [state] in
+ for i = 0 to len - 1 do
+ let new_struc = List.fold_left (fun struc ((fname, elem), ts) ->
+ let v = Term.term_val (List.nth ts i) in
+ Structure.change_fun struc fname elem v) state.Arena.struc shifts in
+ res := { state with Arena.struc = new_struc } :: !res;
+ done;
+ !res
+
let make_move move_id =
let move_id = int_of_float (Js.to_float move_id) in
LOG 1 "make_move: move_id=%d" move_id;
if !play_states = [] then Js.null
else
- let (p, m, n_state) = !cur_all_moves.(move_id) in
- let game, _ = !cur_game.game_state in
+ let (p, (_, shifts), n_state) = !cur_all_moves.(move_id) in
+ let game, old_state = !cur_game.game_state in
play_states := n_state :: !play_states;
- cur_all_moves := Arena.list_moves game n_state;
+ cur_all_moves := Arena.list_moves_shifts game n_state;
cur_move := 0;
- Js.some (js_of_game_state game n_state)
+ let states = List.rev (n_state :: (shifted_state old_state shifts)) in
+ let dims = List.fold_left (fun (a, b, c, d) s ->
+ let (x, y, z, v) = state_dim s in
+ (min a x, max b y, min c z, max d v)) (state_dim n_state) states in
+ Js.some (Js.array (Array.of_list (List.map
+ (js_of_game_state ~dims game) states)))
let _ = set_handle "make_move" make_move
@@ -301,7 +324,7 @@
let algo_iters = large_iters - !Play.latest_unfold_iters_left in
LOG 0 "iters: %i" algo_iters;
let move_id = Aux.array_argfind
- (fun (_, m, _) -> m = move) !cur_all_moves in
+ (fun (_, (m, _), _) -> m = move) !cur_all_moves in
let result =
js_of_move game state move_id (!cur_all_moves.(move_id)) in
Js.Unsafe.set result (js"comp_iters")
@@ -321,7 +344,7 @@
let game, _ = !cur_game.game_state in
let move_s, state = of_js move_js, List.hd !play_states in
let move_id = Aux.array_argfind
- (fun (_,m,_) -> Arena.game_move_str m = move_s) !cur_all_moves in
+ (fun (_, (m,_), _) -> Arena.game_move_str m = move_s) !cur_all_moves in
let result =
js_of_move game state move_id (!cur_all_moves.(move_id)) in
Js.Unsafe.set result (js"comp_iters")
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Client/Main.js 2012-05-06 22:17:46 UTC (rev 1701)
@@ -278,10 +278,12 @@
var bt = document.getElementById ("more-games-bt");
if (bt.innerHTML.indexOf ("More") > -1) {
bt.innerHTML = "Less Games";
- document.getElementById ("moregames").style.display = "block";
+ document.getElementById ("moregames1").style.display = "block";
+ document.getElementById ("moregames2").style.display = "block";
} else {
bt.innerHTML = "More Games";
- document.getElementById ("moregames").style.display = "none";
+ document.getElementById ("moregames1").style.display = "none";
+ document.getElementById ("moregames2").style.display = "none";
}
}
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Client/Play.js 2012-05-06 22:17:46 UTC (rev 1701)
@@ -149,13 +149,23 @@
function play_move_continue (info, suggest_f) {
PlayDISP.free ();
- this.new_state (info);
- this.redraw ();
- if (this.cur_state.players.length == 1 &&
- this.players[this.cur_state.players[0]] == "computer") {
- var mv_time = document.getElementById("speed").value;
- suggest_f (mv_time);
+ var TIMESTEP = 100;
+ for (var i = 1; i < info.length-1; i++) {
+ setTimeout (function (_this, cur_info) {
+ _this.cur_state =
+ new State (_this.game, cur_info, _this.cur_state.mirror);
+ _this.redraw ();
+ }, i*TIMESTEP, this, info[i]);
}
+ setTimeout (function (_this, cur_info) {
+ _this.new_state (cur_info);
+ _this.redraw ();
+ if (_this.cur_state.players.length == 1 &&
+ _this.players[_this.cur_state.players[0]] == "computer") {
+ var mv_time = document.getElementById("speed").value;
+ suggest_f (mv_time);
+ }
+ }, info.length*TIMESTEP, this, info[info.length - 1])
}
Play.prototype.move_continue = play_move_continue;
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Client/State.js 2012-05-06 22:17:46 UTC (rev 1701)
@@ -197,6 +197,7 @@
function square_elements_game (game) {
return (game !== "Connect4" &&
+ game !== "Bounce" &&
game !== "Rewriting-Example")
}
@@ -442,12 +443,17 @@
default_rel["Bq"] = '<g class="chessB">' + DEFqueen + '</g>';
default_rel["wK"] = '<g class="chessW">' + DEFking + '</g>';
default_rel["bK"] = '<g class="chessB">' + DEFking + '</g>';
- default_rel["P"] =
- '<g class="model-pred-P">' + // Cross
+ default_rel["P"] = // Cross
+ '<g class="model-pred-P">' +
'<line x1="-17" y1="-17" x2="17" y2="17" />' +
'<line x1="17" y1="-17" x2="-17" y2="17" /></g>';
- default_rel["Q"] =
- '<circle class="model-pred-Q" cx="0" cy="0" r="17" />'; // Circle
+ default_rel["X"] = default_rel["P"] // Cross
+ default_rel["Q"] = // Circle
+ '<circle class="model-pred-Q" cx="0" cy="0" r="17" />';
+ default_rel["T"] = // Plus
+ '<g class="model-pred-T">' +
+ '<line x1="0" y1="-17" x2="0" y2="17" />' +
+ '<line x1="17" y1="0" x2="-17" y2="0" /></g>';
default_rel["IsFirst"] =
'<circle class="model-pred-Q" cx="0" cy="0" r="0" />'; // Empty
default_rel["IsSecond"] =
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Client/Style.css 2012-05-06 22:17:46 UTC (rev 1701)
@@ -175,9 +175,12 @@
width: 100%;
}
-#moregames {
+#moregames1 {
display: none;
}
+#moregames2 {
+ display: none;
+}
.game-picdiv1 {
position: relative;
@@ -1049,7 +1052,7 @@
}
-.model-pred-P {
+.model-pred-P, .model-pred-X, .model-pred-T {
fill: #400827;
stroke: #260314;
stroke-width: 5px;
@@ -1121,7 +1124,8 @@
stroke-width: 2px;
}
-.Game-Chess .chessW .chess-path-A, .Game-Pawn-Whopping .chessW .chess-path-A {
+.Game-Chess .chessW .chess-path-A, .Game-Pawn-Whopping .chessW .chess-path-A,
+ .Game-Hnefatafl .chessW .chess-path-A {
opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
@@ -1151,7 +1155,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-A, .Game-Pawn-Whopping .chessB .chess-path-A {
+.Game-Chess .chessB .chess-path-A, .Game-Pawn-Whopping .chessB .chess-path-A,
+ .Game-Hnefatafl .chessB .chess-path-A {
opacity: 1;
fill: #400827;
fill-opacity: 1;
@@ -1181,7 +1186,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessW .chess-path-B, .Game-Pawn-Whopping .chessW .chess-path-B {
+.Game-Chess .chessW .chess-path-B, .Game-Pawn-Whopping .chessW .chess-path-B,
+ .Game-Hnefatafl .chessW .chess-path-B {
opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
@@ -1209,7 +1215,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-B, .Game-Pawn-Whopping .chessB .chess-path-B {
+.Game-Chess .chessB .chess-path-B, .Game-Pawn-Whopping .chessB .chess-path-B,
+ .Game-Hnefatafl .chessB .chess-path-B {
opacity: 1;
fill: #400827;
fill-opacity: 1;
@@ -1238,7 +1245,8 @@
}
-.Game-Chess .chessW .chess-path-Bx, .Game-Pawn-Whopping .chessW .chess-path-Bx {
+.Game-Chess .chessW .chess-path-Bx, .Game-Pawn-Whopping .chessW .chess-path-Bx,
+ .Game-Hnefatafl .chessW .chess-path-Bx {
opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
@@ -1266,7 +1274,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-Bx, .Game-Pawn-Whopping .chessB .chess-path-Bx {
+.Game-Chess .chessB .chess-path-Bx, .Game-Pawn-Whopping .chessB .chess-path-Bx,
+ .Game-Hnefatafl .chessB .chess-path-Bx {
opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
@@ -1294,7 +1303,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessW .chess-path-C, .Game-Pawn-Whopping .chessW .chess-path-C {
+.Game-Chess .chessW .chess-path-C, .Game-Pawn-Whopping .chessW .chess-path-C,
+ .Game-Hnefatafl .chessW .chess-path-C {
opacity: 1;
fill: #400827;
fill-opacity: 1;
@@ -1320,7 +1330,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-C, .Game-Pawn-Whopping .chessB .chess-path-C {
+.Game-Chess .chessB .chess-path-C, .Game-Pawn-Whopping .chessB .chess-path-C,
+ .Game-Hnefatafl .chessB .chess-path-C {
opacity:1;
fill: #fff1d4;
fill-opacity: 1;
@@ -1346,7 +1357,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessW .chess-path-D, .Game-Pawn-Whopping .chessW .chess-path-D {
+.Game-Chess .chessW .chess-path-D, .Game-Pawn-Whopping .chessW .chess-path-D,
+ .Game-Hnefatafl .chessW .chess-path-D {
fill: #fff1d4;
fill-opacity: 0.75;
fill-rule: evenodd;
@@ -1372,7 +1384,8 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-D, .Game-Pawn-Whopping .chessB .chess-path-D {
+.Game-Chess .chessB .chess-path-D, .Game-Pawn-Whopping .chessB .chess-path-D,
+ .Game-Hnefatafl .chessB .chess-path-D {
fill: #400827;
fill-opacity: 0.75;
fill-rule: evenodd;
Added: trunk/Toss/Client/img/Bounce.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/Client/img/Bounce.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: trunk/Toss/Client/img/Hnefatafl.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/Client/img/Hnefatafl.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Client/index.html 2012-05-06 22:17:46 UTC (rev 1701)
@@ -31,7 +31,8 @@
</span>
<span id="appstorelink">
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
- ><img style="height: 24px; width: 69px;" src="img/appstore-small.png" /></a>
+ ><img style="height: 24px; width: 69px;" alt="App Store"
+ src="img/appstore-small.png" /></a>
</span>
<span id="speedtab" style="display: none;">
@@ -121,13 +122,13 @@
>More Games</button>
</div>
-<div id="moregames" class="game-line">
+<div id="moregames1" class="game-line">
<div class="game-picdiv1">
-<button onclick="new_play_click ('Entanglement')" class="game-picbt">
- <img class="game-picimg" src="img/Entanglement.png"
- alt="Entanglement Graph" />
- <span id="pdescEntanglement" class="game-picspan">
- <span class="game-pictxt">Entanglement</span>
+<button onclick="new_play_click ('Hnefatafl')" class="game-picbt">
+ <img class="game-picimg" src="img/Hnefatafl.png"
+ alt="Hnefatafl" />
+ <span id="pdescHnefatafl" class="game-picspan">
+ <span class="game-pictxt">Hnefatafl</span>
</span>
</button>
</div>
@@ -141,15 +142,36 @@
</button>
</div>
<div class="game-picdiv3">
+<button onclick="new_play_click ('Entanglement')" class="game-picbt">
+ <img class="game-picimg" src="img/Entanglement.png"
+ alt="Entanglement Graph" />
+ <span id="pdescEntanglement" class="game-picspan">
+ <span class="game-pictxt">Entanglement</span>
+ </span>
+</button>
+</div>
+</div>
+
+<div id="moregames2" class="game-line">
+<div class="game-picdiv1">
<button onclick="new_play_click ('Rewriting-Example')" class="game-picbt">
<img class="game-picimg" src="img/Rewriting-Example.png"
alt="Rewriting-Example" />
- <span id="pdescExample" class="game-picspan">
+ <span id="pdescRewriting-Example" class="game-picspan">
<span class="game-pictxt">Rewriting-Example</span>
</span>
</button>
</div>
+<div class="game-picdiv2">
+<button onclick="new_play_click ('Bounce')" class="game-picbt">
+ <img class="game-picimg" src="img/Bounce.png"
+ alt="Bounce" />
+ <span id="pdescBounce" class="game-picspan">
+ <span class="game-pictxt">Bounce</span>
+ </span>
+</button>
</div>
+</div>
<ul id="welcome-list-main" class="welcome-list">
<li>Play
@@ -288,7 +310,7 @@
two bishops, and eight pawns. Pieces move in different assigned ways
according to their type, and accordingly are used to attack and capture
the opponent's pieces. The object of the game is to checkmate
- the opponent's king.
+ the opponent's king.</p>
<p><b>Moves.</b> The moves differ by figure. Please consult the chess link
above for a complete explanation with examples.</p>
<ul>
@@ -314,7 +336,8 @@
diagonally in front of it on an adjacent file, capturing that piece.
The pawn has two special moves: the en passant capture and pawn
promotion. In the first it captures another pawn which has just made a
- two-field move, in the other one it becomes a queen in the last row.</p>
+ two-field move, in the other one it becomes a queen in the last
+ row.</li>
</ul>
<p><b>Objective.</b>
When a king is under immediate attack by one or more of the opponent's
@@ -399,6 +422,37 @@
respective marks in a horizontal, vertical, or diagonal row
wins the game.</p>
</div>
+ <div class="game-desc" id="Hnefatafl-desc">
+ <p><a href="http://hem.bredband.net/b512479/">Hnefatafl</a> is a strategic
+ board game of the Vikings. There are many variations, but the most
+ popular modern one is played on an 11×11 grid.</p>
+ <p><b>Warning!</b> The game is incomplete and very slow for now!</p>
+ <p><b>Moves.</b> Players move on free straight lines,
+ vertical or horizontal.</p>
+ <p><b>Capturing Pawns.</b> All pieces except the king are captured if they
+ are sandwiched between two enemy pieces, or between an enemy piece and a
+ hostile square, along a column or a row. A piece is only captured if
+ the trap is closed by a move of the opponent, and it is thus allowed to
+ move in between two enemy pieces. The king may take part in captures.</p>
+ <p><b>Capturing the King</b> The king himself is captured like all other
+ pieces, except when he is standing on the throne or on one of the four
+ squares next to the throne. When the king is standing on the throne,
+ the attackers must surround him in all four cardinal points. When he is
+ on a square next to the throne, the attackers must occupy all surrounding
+ squares in the four points of the compass except the throne.</p>
+ <p><b>Objective.</b> The objective for the king's side is to move the king
+ to any of the four corner squares. In that case, the king has escaped
+ and his side wins. The attackers win if they can capture the king before
+ he escapes.</p>
+ </div>
+ <div class="game-desc" id="Rewriting-Example-desc">
+ <p><b>Rewriting Example</b> is the basic example we use to illustrate
+ the way discrete structure rewriting works.</p>
+ </div>
+ <div class="game-desc" id="Bounce-desc">
+ <p><b>Bounce</b> is the basic example we use to illustrate
+ the way continuous dynamics works with structure rewriting.</p>
+ </div>
</div>
<div id="bottom">
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Solver/Structure.ml 2012-05-06 22:17:46 UTC (rev 1701)
@@ -347,7 +347,13 @@
let add_funs struc fn assgns =
List.fold_left (fun s a -> add_fun s fn a) struc assgns
+(* Change function [fn] assignment for element [e] to [x] in [struc]. *)
+let change_fun struc fn elem x =
+ let assgs, e = StringMap.find fn struc.functions, elem_nbr struc elem in
+ let new_functions = StringMap.add fn (IntMap.add e x assgs) struc.functions in
+ { struc with functions = new_functions }
+
(* ------------ GLOBAL FUNCTIONS TO CREATE STRUCTURES FROM LISTS ------------ *)
(** Map a function over an array threading an accumulator. *)
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/Solver/Structure.mli 2012-05-06 22:17:46 UTC (rev 1701)
@@ -227,7 +227,10 @@
(** Add function assignments [assgns] to [fn] in structure [struc]. *)
val add_funs : structure -> string -> (int * float) list -> structure
+(** Change function [fn] assignment for element [e] to [x] in [struc]. *)
+val change_fun : structure -> string -> string -> float -> structure
+
(** {2 Global function to create structures from lists} *)
val create_from_lists : ?struc:structure -> string list ->
Copied: trunk/Toss/examples/Bounce.toss (from rev 1700, trunk/Toss/examples/bounce.toss)
===================================================================
--- trunk/Toss/examples/Bounce.toss (rev 0)
+++ trunk/Toss/examples/Bounce.toss 2012-05-06 22:17:46 UTC (rev 1701)
@@ -0,0 +1,25 @@
+PLAYERS 1, 2
+RULE Move:
+ [ e1 | Q(e1) | vx { e1->0. }; vy { e1->0. }; x { e1->-10. }; y { e1->-60. } ]
+ ->
+ [ e1 | Q(e1) | vx { e1->0. }; vy { e1->0. }; x { e1->-10. }; y { e1->-30. } ]
+ emb Q
+ dynamics
+ :vy(e1)' = 50.;
+ :vx(e1)' = 0.;
+ :y(e1)' = :vy(e1);
+ :x(e1)' = :vx(e1)
+ update
+ :vy(e1) = (-1.) * :vy(e1);
+ :vx(e1) = :vx(e1);
+ :y(e1) = :y(e1);
+ :x(e1) = :x(e1)
+ inv ex x ((_lhs_e1(x) and ((((:y(x) + (-1. * 0.)) +
+ (-1. * 0.)) + (-1. * 0.)) < 0)))
+LOC 0 {
+ PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 0] }
+ PLAYER 2 { PAYOFF 0. }
+}
+START [ e1, e2, e3 | Q(e1); E { (e2, e3); (e3, e2) } |
+ vx { e1->0., e2->0., e3->0. }; vy { e1->27., e2->0., e3->0. };
+ x { e1->-140., e2->-160., e3->-120. }; y { e1->-40., e2->3.5, e3->3.5 } ]
Modified: trunk/Toss/examples/Hnefatafl.toss
===================================================================
--- trunk/Toss/examples/Hnefatafl.toss 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/examples/Hnefatafl.toss 2012-05-06 22:17:46 UTC (rev 1701)
@@ -1,4 +1,6 @@
PLAYERS 1, 2
+SET Sum (x | wP(x) : 1)
+SET Sum (x | bP(x) : 1)
REL w(x) = wP(x) or wK(x)
REL FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not bP(y))
REL FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not bP(y))
@@ -17,14 +19,16 @@
emb wP, wK, bP, X, T pre Line(a, b) and not WinWhite ()
LOC 0 {
PLAYER 1 {
+ COND 1; -1
PAYOFF :(WinWhite())
MOVES [WhitePawn -> 1]; [WhiteKing -> 1]
}
- PLAYER 2 { PAYOFF -1 * :(WinWhite()) }
+ PLAYER 2 { COND -1; 1 PAYOFF -1 * :(WinWhite()) }
}
LOC 1 {
- PLAYER 1 { PAYOFF :(WinWhite()) }
+ PLAYER 1 { COND 1; -1 PAYOFF :(WinWhite()) }
PLAYER 2 {
+ COND -1; 1
PAYOFF -1 * :(WinWhite())
MOVES [BlackPawn -> 0]
}
@@ -49,7 +53,7 @@
... ... ... ... ...
... ... ... ... ...
... ... ... ... ... ...
- ... ... ... ... ... ...
- ... ... bP. ... ...
+ ... ... ...bP ... ... ...
+ ... ... ... ... ...
X ... bP.bP bP.bP bP. ...X
"
Deleted: trunk/Toss/examples/bounce.toss
===================================================================
--- trunk/Toss/examples/bounce.toss 2012-05-05 21:58:06 UTC (rev 1700)
+++ trunk/Toss/examples/bounce.toss 2012-05-06 22:17:46 UTC (rev 1701)
@@ -1,26 +0,0 @@
-PLAYERS 1, 2
-RULE Move:
- [ 1 | | vx { 1->0. }; vy { 1->0. }; x { 1->-11. }; y { 1->-60.5 } ]
- ->
- [ 1 | | vx { 1->0. }; vy { 1->0. }; x { 1->-14.3 }; y { 1->-34.1 } ]
- dynamics
- :vy(1)' = 50.;
- :vx(1)' = 0.;
- :y(1)' = :vy(1);
- :x(1)' = :vx(1)
- update
- :vy(1) = (-1.) * :vy(1);
- :vx(1) = :vx(1);
- :y(1) = :y(1);
- :x(1) = :x(1)
- pre true
- inv ex x ((_lhs_1(x) and ((((:y(x) + (-1. * 0.)) +
- (-1. * 0.)) + (-1. * 0.)) < 0)))
- post true
-LOC 0 {
- PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 0] }
- PLAYER 2 { PAYOFF 0. }
-}
-START [ 1, 2, 3 | G { (2, 3); (3, 2) } |
- vx { 1->0., 2->0., 3->0. }; vy { 1->27., 2->0., 3->0. };
- x { 1->-140., 2->-160., 3->-120. }; y { 1->-40.2673662018, 2->3.5, 3->3.5 } ]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open S...
[truncated message content] |
|
From: Lukasz S. <luk...@gm...> - 2012-05-07 00:00:01
|
On Mon, May 7, 2012 at 12:17 AM, <luk...@us...> wrote: > Revision: 1701 > http://toss.svn.sourceforge.net/toss/?rev=1701&view=rev > Author: lukaszkaiser > Date: 2012-05-06 22:17:46 +0000 (Sun, 06 May 2012) > Log Message: > ----------- > Animation in JS interface - Bounce example works. Wow, gratulacje! Co u Ciebie słychać? U mnie trochę kiepsko, nie wyrabiam się chociaż tylko mam dwa wykłady i robienie zadań na dwa (od tego tygodnia trzy) kursy Stanforda. Chodzi mi po głowie żeby wrócić na taniec. Pozdrawiam. |
|
From: <luk...@us...> - 2012-05-08 23:30:27
|
Revision: 1702
http://toss.svn.sourceforge.net/toss/?rev=1702&view=rev
Author: lukaszkaiser
Date: 2012-05-08 23:30:19 +0000 (Tue, 08 May 2012)
Log Message:
-----------
Support for universal rules; first non-trivial dynamics example.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/Arena.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -33,7 +33,7 @@
type game = {
rules : (string * ContinuousRule.rule) list;
patterns : Formula.real_expr list;
- graph : player_loc array array;
+ graph : (player_loc array * string list) array;
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
@@ -67,7 +67,7 @@
let emp_struc = Structure.empty_structure () in
{rules = [];
patterns = [];
- graph = Array.make 1 (Array.make 1 zero_loc);
+ graph = Array.make 1 (Array.make 1 zero_loc, []);
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
@@ -121,7 +121,10 @@
) (in_p, in_m)
let fprint_loc_body pnames f loc =
- Array.iteri (fun p l -> fprint_loc_body_in pnames f p l) loc
+ Array.iteri (fun p l -> fprint_loc_body_in pnames f p l) (fst loc);
+ if (snd loc <> []) then
+ Format.fprintf f "@ @[<0>UNIVERSAL@ {%a}@]@ "
+ (Aux.fprint_sep_list ", " (fun f s -> Format.fprintf f "%s" s)) (snd loc)
let equational_def_style = ref true
@@ -248,7 +251,7 @@
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
- let rules_of_loc l =
+ let rules_of_loc (l,_) =
List.map (fun (lab,_) -> lab.lb_rule) l.(player_no).moves in
List.concat (List.map rules_of_loc (Array.to_list game.graph))
@@ -276,7 +279,7 @@
(string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule)
(* add a rule *)
- | DefLoc of ((string * int) list -> int * player_loc array)
+ | DefLoc of ((string * int) list -> int * (player_loc array * string list))
(* add location to graph *)
| DefPlayers of string list (* add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
@@ -317,19 +320,22 @@
) (Formula.Const 0., [], []) defs in
{ zero_loc with payoff = payoff ; moves = moves; heur = heurs }
-let make_location id loc_defs =
+let make_location id loc_defs universal_rules =
fun player_names ->
let locs = List.map
(fun (pl, pl_loc_defs) -> (pl, make_player_loc pl_loc_defs)) loc_defs in
- id, array_of_players zero_loc player_names locs
+ id, (array_of_players zero_loc player_names locs, universal_rules)
+(* Helper: get universal rules for a state. *)
+let get_univs game state =
+ let find_rule r = List.assoc r game.rules in
+ List.map find_rule (snd (game.graph.(state.cur_loc)))
(* Helper: Apply a move to a game state, get the new state. *)
-let apply_move rules state (m, t) =
- let r = List.assoc m.rule rules in
- let mtch =
- List.map (fun (v, e) -> v, Structure.elem_nbr state.struc e) m.matching in
- match ContinuousRule.rewrite_single state.struc state.time mtch r
+let apply_move game state (m, t) =
+ let mnbr x = List.map (fun (v, e) -> v, Structure.elem_nbr state.struc e) x in
+ match ContinuousRule.rewrite_single state.struc (get_univs game state)
+ state.time (mnbr m.matching) (List.assoc m.rule game.rules)
m.mv_time m.parameters with
| Some (new_struc, new_time, _) ->
{ struc = new_struc;
@@ -340,7 +346,7 @@
" inapplicable to " ^ (sprint_only_state state))
(* Make a move in a game. *)
-let make_move m (game, state) = (game, apply_move game.rules state (m, None))
+let make_move m (game, state) = (game, apply_move game state (m, None))
(* Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
@@ -414,14 +420,14 @@
let rules = List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
let updated_locs =
if old_locs = [] then old_locs else
- let more = num_players - Array.length (snd (List.hd old_locs)) in
- let add_more (i,loc) =
- i, Array.append loc (Array.make more zero_loc) in
+ let more = num_players - Array.length (fst (snd (List.hd old_locs))) in
+ let add_more (i, (loc, univs)) =
+ i, (Array.append loc (Array.make more zero_loc), univs) in
List.map add_more old_locs in
- let add_def_rel (i,loc) =
+ let add_def_rel (i, (loc, univs)) =
let sub_p l =
{ l with payoff = FormulaSubst.subst_rels_expr def_rels_pure l.payoff } in
- i, Array.map sub_p loc in
+ i, (Array.map sub_p loc, univs) in
LOG 3 "process_definition: parsing locations (registering payoffs)...%!";
let locations =
List.map (fun loc -> add_def_rel (loc player_names)) locations in
@@ -431,15 +437,7 @@
LOG 3 " parsed";
let graph = Aux.array_from_assoc (List.rev locations) in
let pats=List.rev_map (FormulaSubst.subst_rels_expr def_rels_pure) patterns in
- let apply_moves rules mvs s = List.fold_left (apply_move rules) s mvs in
- let result_state = match snd strucs with
- | None ->
- let st = apply_moves rules (List.rev hist)
- { snd empty_state with struc = fst strucs } in
- { st with time = time; cur_loc = cur_loc; history = hist }
- | Some struc ->
- { struc = struc; time = time; cur_loc = cur_loc; history = hist; } in
- {
+ let result_game = {
rules = rules;
patterns = pats;
graph = graph;
@@ -448,14 +446,23 @@
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
starting_struc = fst strucs;
- }, result_state
+ } in
+ let apply_moves rules mvs s = List.fold_left (apply_move result_game) s mvs in
+ let result_state = match snd strucs with
+ | None ->
+ let st = apply_moves rules (List.rev hist)
+ { snd empty_state with struc = fst strucs } in
+ { st with time = time; cur_loc = cur_loc; history = hist }
+ | Some struc ->
+ { struc = struc; time = time; cur_loc = cur_loc; history = hist; } in
+ (result_game, result_state)
(* -------------------- WHOLE ARENA MANIPULATION -------------------- *)
let add_new_player (state_game, state) pname =
let player = state_game.num_players in
- let add_more loc = Array.append loc [|zero_loc|] in
+ let add_more (loc, univs) = (Array.append loc [|zero_loc|], univs) in
let game = {state_game with
num_players = state_game.num_players + 1;
graph = Array.map add_more state_game.graph;
@@ -468,9 +475,9 @@
rules = List.map (fun (rn, r) ->
rn, ContinuousRule.map_to_formulas f r
) game.rules;
- graph = Array.map (fun la -> Array.map (fun loc ->
+ graph = Array.map (fun (la, univs) -> (Array.map (fun loc ->
{loc with payoff = FormulaMap.map_to_formulas_expr f loc.payoff;
- }) la) game.graph;
+ }) la, univs)) game.graph;
defined_rels = List.map (fun (drel, (args, def)) ->
drel, (args, f def)) game.defined_rels;
}
@@ -481,7 +488,7 @@
ContinuousRule.fold_over_formulas f r
) game.rules acc in
let acc =
- Array.fold_right (fun la -> Array.fold_right
+ Array.fold_right (fun (la, _) -> Array.fold_right
(fun loc -> FormulaMap.fold_over_formulas_expr f loc.payoff) la)
game.graph acc in
let acc =
@@ -549,9 +556,11 @@
let pnames2 = List.sort cmp_pn g2.player_names in
if pnames1 <> pnames2 then
raise (Diff_result "Game players are given in different order.");
- Array.iteri (fun i locarr1 ->
+ Array.iteri (fun i locarr1 ->
+ if (snd locarr1 <> snd g2.graph.(i)) then raise
+ (Diff_result(Printf.sprintf ("At location %d universal rules diff") i));
Array.iteri (fun pl loc1 ->
- let loc2 = g2.graph.(i).(pl) in
+ let loc2 = (fst g2.graph.(i)).(pl) in
let dmoves1 = Aux.list_diff loc1.moves loc2.moves in
if dmoves1 <> [] then raise (Diff_result (
let label, dest = List.hd dmoves1 in
@@ -572,7 +581,7 @@
Printf.sprintf
"At location %d, payffs for player %d differ:\n%s\nvs.\n%s"
i pl (Formula.real_str poff1) (Formula.real_str poff2)));
- ) locarr1
+ ) (fst locarr1)
) g1.graph;
if List.sort Pervasives.compare g1.defined_rels <>
List.sort Pervasives.compare g2.defined_rels
@@ -647,9 +656,9 @@
List.exists (fun (mv, _) -> mv.rule = rname) hist = b in
List.for_all constraint_satisfied prev_list
-let gen_models_list rules state time moves =
+let gen_models_list game state time moves =
Aux.map_some (fun mv ->
- let rule = List.assoc mv.rule rules in
+ let rule = List.assoc mv.rule game.rules in
if check_history_pre rule.ContinuousRule.discrete state.history then
let mtch = List.map (fun (v, e) ->
v, Structure.elem_nbr state.struc e) mv.matching in
@@ -660,24 +669,24 @@
history = (mv, None) :: state.history;
struc = model;
time = time}))
- (ContinuousRule.rewrite_single state.struc time mtch
- rule mv.mv_time mv.parameters)
+ (ContinuousRule.rewrite_single state.struc (get_univs game state)
+ time mtch rule mv.mv_time mv.parameters)
else None) (Array.to_list moves)
-let gen_models rules state time moves =
- let res = gen_models_list rules state time moves in
+let gen_models game state time moves =
+ let res = gen_models_list game state time moves in
let moves, states = List.split res in
Array.of_list (List.map fst moves), Array.of_list states
let list_moves_shifts game s =
- let select_moving a =
+ let select_moving (a, _) =
let pls = Aux.array_argfind_all (fun l -> l.moves <> []) a in
if pls = [] then [0] else pls in
let loc = game.graph.(s.cur_loc) in
let moving = select_moving loc in
let get_moves pl =
- let m = gen_moves cGRID_SIZE game.rules s.struc loc.(pl) in
- gen_models_list game.rules s s.time m in
+ let m = gen_moves cGRID_SIZE game.rules s.struc (fst loc).(pl) in
+ gen_models_list game s s.time m in
Array.of_list (List.concat (
List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
@@ -687,11 +696,11 @@
let apply_rule_int (state_game, state) (r_name, mtch, t, p) =
(let try r = List.assoc r_name state_game.rules in (
- match ContinuousRule.rewrite_single state.struc state.time mtch r t p with
+ let u = get_univs state_game state in
+ match ContinuousRule.rewrite_single state.struc u state.time mtch r t p with
| Some (new_struc, new_time, shifts) ->
let val_str ((f, e), tl) =
let ts t = string_of_float (Term.term_val t) in
- (* we've moved to using element names in Term *)
f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in
let shifts_s = String.concat "; " (List.map val_str shifts) in
((state_game, {state with struc = new_struc; time = new_time}),
@@ -711,7 +720,7 @@
if r_name <> "" then (
let {rules=rules; graph=graph} = game in
let struc = state.struc in
- let mv_loc = graph.(state.cur_loc).(player) in
+ let mv_loc = (fst graph.(state.cur_loc)).(player) in
let moves = gen_moves cGRID_SIZE rules struc mv_loc in
LOG 1 "apply_rewrite: r_name=%s; mtch=%s; player=%d; prules=%s; moves= %s"
r_name (ContinuousRule.matching_str struc mtch) player
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/Arena.mli 2012-05-08 23:30:19 UTC (rev 1702)
@@ -25,7 +25,7 @@
type game = {
rules : (string * ContinuousRule.rule) list;
patterns : Formula.real_expr list;
- graph : player_loc array array;
+ graph : (player_loc array * string list) array;
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
@@ -109,7 +109,7 @@
(string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule)
(** add a rule *)
- | DefLoc of ((string * int) list -> int * player_loc array)
+ | DefLoc of ((string * int) list -> int * (player_loc array * string list))
(** add location to graph *)
| DefPlayers of string list (** add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
@@ -135,8 +135,8 @@
int ->
(string * [< `Moves of (label * int) list
| `Payoff of Formula.real_expr
- | `Heurs of float list ] list) list ->
- (string * int) list -> int * player_loc array
+ | `Heurs of float list ] list) list -> string list ->
+ (string * int) list -> int * (player_loc array * string list)
(** Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
@@ -173,16 +173,6 @@
TODO: fixed for now. *)
val cGRID_SIZE : int
-(** Generate moves available from a state, as an array, in fixed
- order. Does not check postconditions. *)
-val gen_moves : int -> (string * ContinuousRule.rule) list ->
- Structure.structure -> player_loc -> move array
-
-(** Given moves available from a state, keep those for which
- postconditions pass, and return the respective resulting game states. *)
-val gen_models : (string * ContinuousRule.rule) list -> game_state ->
- float -> move array -> move array * game_state array
-
(** Get moves and resulting game states, like {!Move.gen_models}, but for
all rules the players can apply in the given game state. Returns
the player together with a move. *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-05-08 23:30:19 UTC (rev 1702)
@@ -10,7 +10,7 @@
%}
%start parse_game_defs parse_game_state
-%type <(string * int) list -> int * Arena.player_loc array> location
+%type <(string * int) list -> int * (Arena.player_loc array * string list)> location
%type <Arena.definition> parse_game_defs
%type <Arena.game * Arena.game_state> parse_game_state game_state
%type <Arena.game * Arena.game_state -> Arena.game * Arena.game_state> extend_game_state
@@ -69,11 +69,19 @@
location:
| ident = INT OPENCUR loc_defs = list (location_defs) CLOSECUR
{ try
- make_location ident loc_defs
+ make_location ident loc_defs []
with Arena_definition_error s ->
Lexer.report_parsing_error
$startpos(loc_defs) $endpos(loc_defs) s
- }
+ }
+ | ident = INT OPENCUR loc_defs = list (location_defs)
+ UNIVERSAL OPENCUR rs = separated_list (COMMA, ID) CLOSECUR CLOSECUR
+ { try
+ make_location ident loc_defs rs
+ with Arena_definition_error s ->
+ Lexer.report_parsing_error
+ $startpos(loc_defs) $endpos(loc_defs) s
+ }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in location definition."
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -3,6 +3,7 @@
let time_step = ref 0.1
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
+let dIFFM = 1 (* So many differentiation steps for one time step. *)
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
@@ -87,132 +88,114 @@
(* -------------------------- REWRITING ------------------------------------ *)
-(* Helper function to select from lists by position. *)
-let rec select_pos ids llst =
- if ids = [] then [] else
- (List.hd ids, List.map List.hd llst) ::
- (select_pos (List.tl ids) (List.map List.tl llst))
+(* Differential equations for a rule and a match, renamed to structure names. *)
+let rule_dynamics struc params (r, m) =
+ let p_vars, p_vals = List.split params in
+ let subst_params tm = List.hd
+ (Term.subst_simp p_vars (List.map (fun f -> Term.Const f) p_vals) [tm]) in
+ let d = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
+ Term.subst_names (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
+(* Construct diff equation system and initial values for dynamics. *)
+let construct_dynamics struc params rms =
+ let dyns = List.concat (List.map (rule_dynamics struc params) rms) in
+ let rec sum_common = function
+ | [] -> []
+ | (x, t) :: (y, s) :: rest when x = y ->
+ sum_common ((x, Term.Plus (t, s)) :: rest)
+ | eq :: rest-> eq :: (sum_common rest) in
+ let cmp ((f, x), t) ((g, y), s) =
+ let c = String.compare f g in if c <> 0 then c else
+ let d = String.compare x y in if d <> 0 then d else Term.compare t s in
+ let dyn = sum_common (List.sort cmp dyns) in
+ LOG 1 "%s" (Term.eq_str dyn);
+ let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
+ let init_vals = List.map (fun ((f, a), _) -> Term.Const (fval f a)) dyn in
+ (dyn, init_vals)
+
+
(* For now, we rewrite only single rules. Does not check postcondition. *)
-let rewrite_single_nocheck struc cur_time m r t params =
+let rewrite_single_nocheck struc univs cur_time m r t params =
+ let univ_mts = Aux.concat_map
+ (fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
+ let (dyn, init_vals) = construct_dynamics struc params ((r, m) :: univ_mts) in
+ LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
- LOG 1 "current time: %f" !time;
- let p_vars, p_vals = List.split params in
- let subst_params tm =
- List.hd
- (Term.subst_simp p_vars (List.map (fun f -> Term.Const f) p_vals) [tm]) in
- let re_sb = List.map
- (fun (p,v) -> p, Formula.Const v) params in
- let dyn = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
- let upd = List.map (fun (lhs, rhs) ->
- (lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
- let init_vals =
- let get_val f a =
- (* LHS is embedded in the model *)
- (let try e = List.assoc a m in
- Structure.fun_val struc f e
- with Not_found ->
- failwith
- ("rewrite_single_nocheck: get_val: could not find " ^ a ^
- " in matched " ^ String.concat "," (List.map fst m) ^
- String.concat "," (List.map (fun (_, e) -> string_of_int e) m))
- ) in
- List.map (fun ((f, a),_) -> Term.Const (get_val f a)) dyn in
- let step vals t0 =
- Term.rk4_step "t" t0 (Term.Const !time_step) dyn vals in
+ let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
+ let step vals t0 =
+ LOG 1 "step at time %s" (Term.str t0);
+ LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));
+ Term.rk4_step "t" t0 (Term.Const diff_step) dyn vals in
(* add the trace of the embedding to the structure, for invariants *)
- let apm s (le, se) =
- Structure.add_rel s ("_lhs_" ^ le) [|se|] in
- let cur_struc = ref (List.fold_left apm struc m) in
- (* the last structure for which the invariant holds, or the initial
- structure if the invariant doesn't hold for it *)
- let last_struc = ref !cur_struc in
- let cur_vals = ref init_vals in
- let all_vals = ref [] in
- let end_time = !time +. t -. (0.01 *. !time_step) in (*TODO: 1% is decimals!*)
+ let cur_struc = ref (List.fold_left (fun s (le, se) ->
+ Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
+ let last_struc, cur_vals, all_vals = ref !cur_struc, ref init_vals, ref [] in
+ let end_time = !time +. t -. (0.01 *. diff_step) in
LOG 1 "end time: %f" end_time;
- let is_inv s = Solver.M.check s r.inv in
- let lhs_to_model ((f, a), _) = (f, List.assoc a m) in
- let upd_struct st =
- let vals =
- List.combine (List.map lhs_to_model dyn)
- (List.map Term.term_val !cur_vals) in
- List.fold_left (fun s ((f,a), v) -> Structure.add_fun s f (a, v))
- st vals in
- while (!time < end_time) && (is_inv !cur_struc) do
- all_vals := !cur_vals :: !all_vals ;
+ let upd_struct st = List.fold_left2 (fun s ((f, e), _) v ->
+ Structure.change_fun s f e v) st dyn (List.map Term.term_val !cur_vals) in
+ while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
+ if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
+ t_mod_diff := !t_mod_diff + 1 mod dIFFM;
cur_vals := step !cur_vals (Term.Const !time) ;
- time := !time +. !time_step ;
+ time := !time +. diff_step ;
last_struc := !cur_struc ;
cur_struc := upd_struct !cur_struc ;
done ;
- if (is_inv !cur_struc) then (
+ if (Solver.M.check !cur_struc r.inv) then (
all_vals := !cur_vals :: !all_vals ;
last_struc := !cur_struc
) else (
- LOG 2 "Invariant failed.\n%s\n%s"
- (Structure.str !cur_struc) (Formula.sprint r.inv);
+ LOG 2 "Inv failed.\n%s\n%s" (Structure.str !cur_struc) (Formula.str r.inv);
if !all_vals = [] then
failwith "rewriting invariant failed in the first step; rule inapplicable"
else cur_vals := List.hd !all_vals;
);
- let lhs_to_model_str x =
- let (f, i) = lhs_to_model x in
- f, Structure.elem_str struc i in
- let all_vals_assoc =
- select_pos (List.map lhs_to_model_str dyn) (List.rev !all_vals) in
+ let rec select_pos ids llst =
+ if ids = [] then [] else (List.hd ids, List.map List.hd llst) ::
+ (select_pos (List.tl ids) (List.map List.tl llst)) in
+ let all_vals_assoc = select_pos (List.map fst dyn) (List.rev !all_vals) in
LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
(String.concat ", " (List.map (
fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));
- (*
- let val_map =
- if !cur_vals = [] then List.combine (List.map fst dyn) init_vals
- else List.combine (List.map fst dyn) !cur_vals in
- let upd_vals = Term.eq_vals
- (Term.subst_simp_eq [("t", Term.Const !time)] val_map upd) in
- *)
+ let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
let upd = List.map (fun (lhs, rhs) ->
+ (lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
+ let upd = List.map (fun (lhs, rhs) ->
(lhs, FormulaSubst.subst_real ["t", Formula.Const !time] rhs)) upd in
- (* we don't need to use val_map because !last_struc contains the
- evolved values *)
+ (* we don't need to use val_map because !last_struc contains evolved values *)
let asg = AssignmentSet.fo_assgn_of_list m in
- let upd_vals = List.map
- (fun (lhs,expr) ->
- let res = Solver.M.get_real_val ~asg expr !last_struc in
- LOG 1 "%s(%s) = %f (%s)" (fst lhs) (snd lhs) res (Formula.real_str expr);
- (lhs, res)) upd in
- (* we pass the evolved structure to discrete rewriting, so that
- function values can be copied to new elements in case they are
- not updated later *)
+ let upd_vals = List.map (fun (lhs, expr) ->
+ let res = Solver.M.get_real_val ~asg expr !last_struc in
+ LOG 1 "%s(%s) = %f (%s)" (fst lhs) (snd lhs) res (Formula.real_str expr);
+ (lhs, res)) upd in
+ (* we pass the evolved structure to discrete rewriting, so that function
+ values can be copied to new elements in case they are not updated later *)
let ns = DiscreteRule.rewrite_single !last_struc m r.discrete in
let set_val struc ((f, e), v) =
- let e_rel =
- (* DiscreteRule adds RHS element names to rewritten result,
- unless the rule is optimized (RHS renamed to use LHS names) *)
- Structure.rel_graph ("_right_" ^ e) struc in
+ let e_rel = Structure.rel_graph ("_right_" ^ e) struc in
let elem = (Structure.Tuples.choose e_rel).(0) in
Structure.add_fun struc f (elem, v) in
let upd_struc = List.fold_left set_val ns upd_vals in
- let res_struc = Structure.clear_rels upd_struc
- (fun rel ->
- match DiscreteRule.special_rel_of rel with None -> false
- | Some sp -> (* sp = "new" || sp = "del" || *) sp = "right") in
+ let res_struc = Structure.clear_rels upd_struc (fun rel ->
+ match DiscreteRule.special_rel_of rel with | None -> false
+ | Some sp -> sp = "right") in
(res_struc, !time, all_vals_assoc)
(* Matches which satisfy postcondition with time 1 and empty params *)
-let matches_post struc r cur_time =
+let matches_post struc univs r cur_time =
let is_ok m =
let (res_struc, _, _) =
- rewrite_single_nocheck struc cur_time m r 1. [] in
+ rewrite_single_nocheck struc univs cur_time m r 1. [] in
Solver.M.check res_struc r.post in
if r.post = Formula.And [] then matches struc r else
List.filter is_ok (matches struc r)
(* For now, we rewrite only single rules. Returns [None] if rewriting fails. *)
-let rewrite_single struc cur_time m r t params =
+let rewrite_single struc univs cur_time m r t params =
let (res_struc, _, _ as res_struc_n_shifts) =
- rewrite_single_nocheck struc cur_time m r t params in
+ rewrite_single_nocheck struc univs cur_time m r t params in
if r.post = Formula.And [] || Solver.M.check res_struc r.post then
Some res_struc_n_shifts
else None
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-05-08 23:30:19 UTC (rev 1702)
@@ -60,39 +60,34 @@
(** Find all matches of [r] in [struc] which satisfy [r]'s precondition. *)
-val matches :
- Structure.structure -> rule -> DiscreteRule.matching list
+val matches : Structure.structure -> rule -> DiscreteRule.matching list
(** Matches which satisfy postcondition with time 1 and empty params *)
-val matches_post :
- Structure.structure -> rule -> float -> DiscreteRule.matching list
+val matches_post : Structure.structure -> rule list ->
+ rule -> float -> DiscreteRule.matching list
(** {2 Rewriting} *)
-(** For now, we rewrite only single rules.
- [rewrite_single struc cur_time m r t params def_rels] rewrites
+(** For now, we rewrite only single rules, but with universal [univs].
+ [rewrite_single struc univs cur_time m r t params def_rels] rewrites
[struc] for the period [t] (unless invariant stops holding earlier)
starting in [cur_time], at matching [m], and returns the rewritten
structure, the time after the rewrite, and shifts (i.e. values for
functions supplied with dynamics equations, at each time step). *)
-val rewrite_single_nocheck :
- Structure.structure -> float ->
+val rewrite_single_nocheck : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
Structure.structure * float * ((string * string) * Term.term list) list
(** For now, we rewrite only single rules.
Same as {!ContinuousRule.rewrite_single_nocheck}, but check if the
postcondition holds. Returns [None] if rewriting fails. *)
-val rewrite_single :
- Structure.structure -> float ->
+val rewrite_single : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
- (Structure.structure *
- float * ((string * string) * Term.term list) list) option
+ (Structure.structure * float * ((string* string)* Term.term list) list) option
(** Compare two rules and explain the first difference
met. Formulas and expressions are compared for structural equality. *)
-val compare_diff :
- ?cmp_funs:(float -> float -> bool) ->
+val compare_diff : ?cmp_funs:(float -> float -> bool) ->
rule -> rule -> bool * string
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -97,8 +97,7 @@
let struc = struc_of_str "[ | P {a}; Q:1{} | x { a -> 0.0 } ]" in
let r = rule_of_str s signat [] "rule1" in
let m = List.hd (matches struc r) in
- let res, _, _ =
- Aux.unsome (rewrite_single struc 0.0 m r 1. []) in
+ let res, _, _ = Aux.unsome (rewrite_single struc [] 0.0 m r 1. []) in
assert_equal ~printer:(fun x->x)
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res));
@@ -118,13 +117,11 @@
let struc = struc_of_str "[ | P {a}; Q:1{} | x { a -> 0.0 } ]" in
let r = rule_of_str s signat [] "rule1" in
let m = List.hd (matches struc r) in
- let res, _, _ =
- Aux.unsome (rewrite_single struc 0.0 m r 1. []) in
+ let res, _, _ = Aux.unsome (rewrite_single struc [] 0.0 m r 1. []) in
assert_equal ~printer:(fun x->x) ~msg:"first rewrite"
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res));
- let res, _, _ =
- Aux.unsome (rewrite_single struc 0.0 m r 1. []) in
+ let res, _, _ = Aux.unsome (rewrite_single struc [] 0.0 m r 1. []) in
assert_equal ~printer:(fun x->x) ~msg:"second rewrite"
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res))
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/Term.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -3,7 +3,7 @@
(* ---------------------- BASIC TYPE DEFINITION --------...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-09 19:42:06
|
Revision: 1703
http://toss.svn.sourceforge.net/toss/?rev=1703&view=rev
Author: lukaszkaiser
Date: 2012-05-09 19:41:58 +0000 (Wed, 09 May 2012)
Log Message:
-----------
Make the Tyson Cell Cycle Model animate in JS interface, debug parameter passing.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/TermParser.mly
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Play.js
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
Added Paths:
-----------
trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/Arena.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -627,7 +627,7 @@
let param_names, params_in =
List.split label.parameters_in in
let axes = List.map (fun (f_l,f_r) ->
- if grid_size < 2 then
+ if grid_size < 2 || f_r -. f_l < 0.00001 then
[(f_r +. f_l) /. 2.]
else
let df = (f_r -. f_l) /. float_of_int (grid_size - 1) in
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -3,7 +3,7 @@
let time_step = ref 0.1
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
-let dIFFM = 1 (* So many differentiation steps for one time step. *)
+let dIFFM = 20 (* So many differentiation steps for one time step. *)
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
@@ -90,9 +90,8 @@
(* Differential equations for a rule and a match, renamed to structure names. *)
let rule_dynamics struc params (r, m) =
- let p_vars, p_vals = List.split params in
- let subst_params tm = List.hd
- (Term.subst_simp p_vars (List.map (fun f -> Term.Const f) p_vals) [tm]) in
+ let (p_vars, t_vals) = params in
+ let subst_params tm = List.hd (Term.subst_simp p_vars t_vals [tm]) in
let d = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
Term.subst_names (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
@@ -107,7 +106,7 @@
let cmp ((f, x), t) ((g, y), s) =
let c = String.compare f g in if c <> 0 then c else
let d = String.compare x y in if d <> 0 then d else Term.compare t s in
- let dyn = sum_common (List.sort cmp dyns) in
+ let dyn = Term.subst_simp_eq [] [] (sum_common (List.sort cmp dyns)) in
LOG 1 "%s" (Term.eq_str dyn);
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
let init_vals = List.map (fun ((f, a), _) -> Term.Const (fval f a)) dyn in
@@ -118,7 +117,10 @@
let rewrite_single_nocheck struc univs cur_time m r t params =
let univ_mts = Aux.concat_map
(fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
- let (dyn, init_vals) = construct_dynamics struc params ((r, m) :: univ_mts) in
+ let tparams =
+ let p_vars, p_vals = List.split params in
+ (p_vars, List.map (fun f -> Term.Const f) p_vals) in
+ let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
@@ -136,7 +138,7 @@
Structure.change_fun s f e v) st dyn (List.map Term.term_val !cur_vals) in
while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
- t_mod_diff := !t_mod_diff + 1 mod dIFFM;
+ t_mod_diff := (!t_mod_diff + 1) mod dIFFM;
cur_vals := step !cur_vals (Term.Const !time) ;
time := !time +. diff_step ;
last_struc := !cur_struc ;
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/Term.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -87,17 +87,19 @@
| Times (p, q) -> (
match (simp_const p, simp_const q) with
| (Const n, Const m) -> Const (n *. m)
- | _ -> Times (p, q)
+ | (Const n, Times (Const m, t)) -> Times (Const (n *. m), t)
+ | (t, s) -> Times (t, s)
)
| Plus (p, q) -> (
match (simp_const p, simp_const q) with
| (Const n, Const m) -> Const (n +. m)
- | _ -> Plus (p, q)
+ | (Const n, Plus (Const m, t)) -> Plus (Const (n +. m), t)
+ | (t, s) -> Plus (t, s)
)
| Div (p, q) ->
match (simp_const p, simp_const q) with
| (Const n, Const m) -> Const (n /. m)
- | _ -> Div (p, q)
+ | (t, s)-> Div (t, s)
(* Convert a term to float, fail on non-constant term. *)
Modified: trunk/Toss/Arena/TermParser.mly
===================================================================
--- trunk/Toss/Arena/TermParser.mly 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/TermParser.mly 2012-05-09 19:41:58 UTC (rev 1703)
@@ -18,12 +18,13 @@
| INT { Term.Const (float_of_int $1) }
| FLOAT { Term.Const ($1) }
| ID { Term.Var ($1) }
+ | MINUS ID { Term.Times (Term.Const (-1.), Term.Var ($2)) }
| COLON ID OPEN ID CLOSE { Term.FVar ($2, $4) }
| COLON ID OPEN INT CLOSE { Term.FVar ($2, string_of_int $4) }
- | term_expr FLOAT { Term.Plus ($1, Term.Const $2) } /* in x-1, "-1" is int */
+ | term_expr FLOAT { Term.Plus ($1, Term.Const $2) }
| term_expr INT { Term.Plus ($1, Term.Const (float_of_int $2)) }
| term_expr PLUS term_expr { Term.Plus ($1, $3) }
- | term_expr MINUS term_expr { Term.Plus ($1, Term.Times (Term.Const (-1.), $3)) }
+ | term_expr MINUS term_expr { Term.Plus ($1, Term.Times(Term.Const(-1.), $3))}
| term_expr TIMES term_expr { Term.Times ($1, $3) }
| term_expr DIV term_expr { Term.Div ($1, $3) }
| term_expr POW INT { Term.pow $1 $3 }
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -69,6 +69,8 @@
("Hnefatafl", AuxIO.input_file "examples/Hnefatafl.toss");
("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
("Bounce", AuxIO.input_file "examples/Bounce.toss");
+ ("Yeast-Cell-Cycle-Tyson",
+ AuxIO.input_file "examples/Yeast-Cell-Cycle-Tyson.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/Play.js 2012-05-09 19:41:58 UTC (rev 1703)
@@ -165,7 +165,7 @@
var mv_time = document.getElementById("speed").value;
suggest_f (mv_time);
}
- }, info.length*TIMESTEP, this, info[info.length - 1])
+ }, (info.length-1)*TIMESTEP, this, info[info.length - 1])
}
Play.prototype.move_continue = play_move_continue;
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/State.js 2012-05-09 19:41:58 UTC (rev 1703)
@@ -56,7 +56,7 @@
function State (game, info_obj, mirror) {
// We create an SVG box with margins depending on the game.
this.game = game;
- this.mirror = mirror;
+ this.mirror = mirror || (game == "Yeast-Cell-Cycle-Tyson");
var create_svg_box = function (margx, margy, parent_id) {
var svg_e = document.getElementById("svg");
@@ -92,8 +92,8 @@
this.minx = info_obj.minx;
this.maxy = info_obj.maxy;
this.miny = info_obj.miny;
- this.width = Math.max (SVG_WIDTH / 100, (this.maxx - this.minx));
- this.height = Math.max (SVG_HEIGHT / 100, (this.maxy - this.miny));
+ this.width = Math.max (SVG_WIDTH / 1000, (this.maxx - this.minx));
+ this.height = Math.max (SVG_HEIGHT / 1000, (this.maxy - this.miny));
// List elements of the structure.
var els = info_obj.elems;
@@ -198,6 +198,7 @@
function square_elements_game (game) {
return (game !== "Connect4" &&
game !== "Bounce" &&
+ game !== "Yeast-Cell-Cycle-Tyson" &&
game !== "Rewriting-Example")
}
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/Style.css 2012-05-09 19:41:58 UTC (rev 1703)
@@ -1058,6 +1058,38 @@
stroke-width: 5px;
}
+.model-pred-Cyc {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #e5effa;
+}
+.model-pred-CycP1 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #a5afaa;
+}
+.model-pred-Cdc2 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #93a605;
+}
+.model-pred-Cdc2P1 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #3e5916;
+}
+.model-pred-Cdc2CycP1 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #f28705;
+}
+.model-pred-Cdc2CycP1P2 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #f25c05;
+}
+
+
.Game-Connect4 .model-pred-P {
fill: red;
stroke: #260314;
Added: trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/index.html 2012-05-09 19:41:58 UTC (rev 1703)
@@ -171,7 +171,16 @@
</span>
</button>
</div>
+<div class="game-picdiv3">
+<button onclick="new_play_click ('Yeast-Cell-Cycle-Tyson')" class="game-picbt">
+ <img class="game-picimg" src="img/Yeast-Cell-Cycle-Tyson.png"
+ alt="Yeast-Cell-Cycle-Tyson" />
+ <span id="pdescYeast-Cell-Cycle-Tyson" class="game-picspan">
+ <span class="game-pictxt">Yeast-Cell-Cycle-Tyson</span>
+ </span>
+</button>
</div>
+</div>
<ul id="welcome-list-main" class="welcome-list">
<li>Play
@@ -450,9 +459,16 @@
the way discrete structure rewriting works.</p>
</div>
<div class="game-desc" id="Bounce-desc">
- <p><b>Bounce</b> is the basic example we use to illustrate
- the way continuous dynamics works with structure rewriting.</p>
+ <p><b>Bounce</b> is the basic example we use to illustrate how continuous
+ dynamics and invariants work with structure rewriting.</p>
</div>
+ <div class="game-desc" id="Yeast-Cell-Cycle-Tyson-desc">
+ <p><b>Yeast Cell Cycle</b> model by <b>Tyson</b> (1991),
+ <a href="http://www.cellerator.org/notebooks/Tyson6.html">described
+ here</a>, is a model of the cell cycle based on the interactions
+ between cdc2 and cyclin. We use it as an example of non-linear
+ dynamics with universal rules and parameters.</p>
+ </div>
</div>
<div id="bottom">
Modified: trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
===================================================================
--- trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-09 19:41:58 UTC (rev 1703)
@@ -3,65 +3,73 @@
RULE k1:
[ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ]
dynamics
- :y(e1)' = 0.015
+ :y(e1)' = k1
RULE k3:
[ e1, e2, e3 | Cyc(e1); Cdc2P1(e2); Cdc2CycP1P2(e3) | ] ->
[ e1, e2, e3 | Cyc(e1); Cdc2P1(e2); Cdc2CycP1P2(e3) | ]
dynamics
- :y(e1)' = -200 * :y(e1) * :y(e2);
- :y(e2)' = -200 * :y(e1) * :y(e2);
- :y(e3)' = 200. * :y(e1) * :y(e2)
+ :y(e1)' = -k3 * :y(e1) * :y(e2);
+ :y(e2)' = -k3 * :y(e1) * :y(e2);
+ :y(e3)' = k3 * :y(e1) * :y(e2)
RULE k4p:
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ] ->
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ]
dynamics
- :y(e1)' = -0.018 * :y(e1);
- :y(e2)' = 0.0180 * :y(e1)
+ :y(e1)' = -k4p * :y(e1);
+ :y(e2)' = k4p * :y(e1)
RULE k4:
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ] ->
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ]
dynamics
- :y(e1)' = -180 * :y(e1) * :y(e2) * :y(e2);
- :y(e2)' = 180. * :y(e1) * :y(e2) * :y(e2)
+ :y(e1)' = -k4 * :y(e1) * :y(e2) * :y(e2);
+ :y(e2)' = k4 * :y(e1) * :y(e2) * :y(e2)
RULE k6:
[ e1, e2, e3 | Cdc2CycP1(e1); CycP1(e2); Cdc2(e3) | ] ->
[ e1, e2, e3 | Cdc2CycP1(e1); CycP1(e2); Cdc2(e3) | ]
dynamics
- :y(e1)' = -1 * :y(e1);
- :y(e2)' = 1. * :y(e1);
- :y(e3)' = 1. * :y(e1)
+ :y(e1)' = -k6 * :y(e1);
+ :y(e2)' = k6 * :y(e1);
+ :y(e3)' = k6 * :y(e1)
RULE k7:
[ e1 | CycP1(e1) | ] -> [ e1 | CycP1(e1) | ]
dynamics
- :y(e1)' = -0.6 * :y(e1)
+ :y(e1)' = -k7 * :y(e1)
RULE k8:
[ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ] -> [ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ]
dynamics
- :y(e1)' = -100 * :y(e1);
- :y(e2)' = 100. * :y(e1)
+ :y(e1)' = -k8 * :y(e1);
+ :y(e2)' = k8 * :y(e1)
RULE k9:
[ e1, e2 | Cdc2P1(e1); Cdc2(e2) | ] -> [ e1, e2 | Cdc2P1(e1); Cdc2(e2) | ]
dynamics
- :y(e1)' = -100 * :y(e1);
- :y(e2)' = 100. * :y(e1)
+ :y(e1)' = -k9 * :y(e1);
+ :y(e2)' = k9 * :y(e1)
RULE Move:
[ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ]
LOC 0 {
- PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 0] }
+ PLAYER 1 { PAYOFF 0. MOVES [Move,
+ t : 9. -- 9.,
+ k1 : 0.015 -- 0.015,
+ k3 : 200. -- 200.,
+ k4p: 0.018 -- 0.018,
+ k4 : 180. -- 180.,
+ k6 : 1. -- 1.,
+ k7 : 0.6 -- 0.6,
+ k8 : 100. -- 100.,
+ k9 : 100. -- 100. -> 0] }
PLAYER 2 { PAYOFF 0. }
UNIVERSAL { k1, k3, k4p, k4, k6, k7, k8, k9 }
}
-START [ e1, e2, e3, e4, e5, e6 |
- Cdc2(e1); Cdc2P1(e2); Cyc(e3);
- Cdc2CycP1P2(e4); Cdc2CycP1(e5); CycP1(e6) |
- x { e1->10, e2->20, e3->30, e4->40, e5->50, e6->60 };
- y { e1->1, e2->0, e3->0, e4->0, e5->0, e6->0 } ]
+START [ e1, e2, e3, e4, e5, e6 | Cyc(e1); CycP1(e2); Cdc2(e3); Cdc2P1(e4);
+ Cdc2CycP1(e5); Cdc2CycP1P2(e6) |
+ x { e1->1, e2->2, e3->3, e4->4, e5->5, e6->6 };
+ y { e1->0, e2->0, e3->1, e4->0, e5->0, e6->0 } ]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-05-10 22:22:16
|
Revision: 1704
http://toss.svn.sourceforge.net/toss/?rev=1704&view=rev
Author: lukaszkaiser
Date: 2012-05-10 22:22:09 +0000 (Thu, 10 May 2012)
Log Message:
-----------
Corrections to term simplification, renaming example.
Modified Paths:
--------------
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/State.js
trunk/Toss/Client/index.html
trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/RealQuantElim/Poly.mli
Added Paths:
-----------
trunk/Toss/Client/img/Cell-Cycle-Tyson-1991.png
trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
Removed Paths:
-------------
trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Arena/Term.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -2,6 +2,8 @@
(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
+let simp_symb = ref false
+
type term =
| Var of string
| FVar of string * string
@@ -80,27 +82,58 @@
(* -------------------- SIMPLIFICATION OF CONSTANTS ------------------------- *)
(* Basic simplification, reduces constant terms to floats. *)
-let rec simp_const = function
+let rec simp_const_only = function
| Var s -> Var s
| FVar (f, a) -> FVar (f, a)
| Const n -> Const n
| Times (p, q) -> (
- match (simp_const p, simp_const q) with
+ match (simp_const_only p, simp_const_only q) with
| (Const n, Const m) -> Const (n *. m)
- | (Const n, Times (Const m, t)) -> Times (Const (n *. m), t)
| (t, s) -> Times (t, s)
)
| Plus (p, q) -> (
- match (simp_const p, simp_const q) with
+ match (simp_const_only p, simp_const_only q) with
| (Const n, Const m) -> Const (n +. m)
- | (Const n, Plus (Const m, t)) -> Plus (Const (n +. m), t)
| (t, s) -> Plus (t, s)
)
| Div (p, q) ->
- match (simp_const p, simp_const q) with
+ match (simp_const_only p, simp_const_only q) with
| (Const n, Const m) -> Const (n /. m)
| (t, s)-> Div (t, s)
+let simp_const t =
+ let rec to_poly = function
+ | Var s -> Poly.Var ("V" ^ s)
+ | FVar (f, a) -> Poly.Var ("F" ^ f ^ "#" ^ a)
+ | Const n -> Poly.Const n
+ | Times (p, q) -> Poly.Times (to_poly p, to_poly q)
+ | Plus (p, q) -> Poly.Plus (to_poly p, to_poly q)
+ | Div _ -> raise Not_found in
+ let rec from_ord = function
+ | OrderedPoly.Const _ -> failwith "num after non-num translation"
+ | OrderedPoly.FConst num -> Const (num)
+ | OrderedPoly.Poly (v, coefs) ->
+ let w = if v.[0]= 'V' then Var (String.sub v 1 ((String.length v)-1)) else
+ let i, l = String.index v '#', String.length v in
+ FVar (String.sub v 1 (i-1), String.sub v (i+1) (l-i-1)) in
+ let res = List.fold_left (fun acc (a, j) ->
+ if j = 0 then Plus (acc, from_ord a) else
+ match from_ord a with
+ | Const n when n = 1. -> Plus (acc, pow w j)
+ | ordt -> Plus (acc, Times (ordt, pow w j))
+ ) (Const 0.) coefs in
+ LOG 1 "res %s" (str res);
+ let rec del_zero = function
+ | Plus (Const n, t) when n = 0. -> t
+ | Plus (t, s) -> Plus (del_zero t, s)
+ | t -> t in
+ del_zero res in
+ match simp_const_only t with
+ | Const n -> Const n
+ | t -> if not !simp_symb then t else
+ try let p = to_poly t in
+ from_ord (Poly.make_ordered ~use_num:false [] p)
+ with Not_found -> t
(* Convert a term to float, fail on non-constant term. *)
let term_val t = match simp_const t with
Modified: trunk/Toss/Arena/Term.mli
===================================================================
--- trunk/Toss/Arena/Term.mli 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Arena/Term.mli 2012-05-10 22:22:09 UTC (rev 1704)
@@ -16,6 +16,9 @@
(** {2 Basic functions.} *)
+(** Whether to simplify symbolically or not. Set to false by default.
+ It is nice for symbolic stuff, but slows down numerics. *)
+val simp_symb : bool ref
(** Print a term as a string. *)
val str : term -> string
Modified: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Arena/TermTest.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -74,6 +74,39 @@
assert_equal ~printer:(fun x->x) "0.005"
(String.sub (str (List.hd (
rk4_step "t" (Const 0.) (Const 0.1) eqs [Const 0.]))) 0 5);
+ );
+ "rk4 eq" >::
+ (fun () ->
+ (* Runge-Kutta symbolically with 2 free parameters. *)
+ let tyson = eqs_of_string
+ (" :y(e1)' = 0.015 + -200. * :y(e1) * :y(e4); " ^
+ ":y(e2)' = -0.6 * :y(e2) + k6 * :y(e5); " ^
+ ":y(e3)' = -100. * :y(e3) + k6 * :y(e5) + 100. * :y(e4); " ^
+ ":y(e4)' = -100.*:y(e4) + 100.*:y(e3) + -200.*:y(e1) * :y(e4); " ^
+ ":y(e5)' = -k6 * :y(e5) + 0.018 * :y(e6) + " ^
+ " k4 * :y(e6) * :y(e5) * :y(e5); " ^
+ ":y(e6)' = -0.018 * :y(e6) + 200. * :y(e1) * :y(e4) + " ^
+ " -k4 * :y(e6) * :y(e5) * :y(e5)") in
+ let init = [Const 0.; Const 0.; Const 1.; Const 0.; Const 0.; Const 0.] in
+ Term.simp_symb := true;
+ let res = rk4_step "t" (Const 0.) (Const 0.005) tyson init in
+ Term.simp_symb := false;
+ let val_str vs = String.concat ", " (List.map str vs) in
+ assert_equal ~printer:(fun x->x)
+ ("6.6076722582e-05, 3.515625e-13 * k6, 3.515625e-13 * k6 + " ^
+ "0.687499267591, 0.312491809132, -3.515625e-13 * k6 + " ^
+ "6.08239621818e-28 * k4 + 2.02139802246e-10, " ^
+ "-6.08239621818e-28 * k4 + 8.9230752782e-06") (val_str res);
+
+ (* Generate RK4 equations symbolically for [eq], step [n]. *)
+ (*let generate_rksymb eq n t0 tstep =
+ let init m = Array.to_list (Array.mapi (fun i _ ->
+ Term.Var (Printf.sprintf "v%iat%i" i m)) (Array.of_list eq)) in
+ let res = rk4_step "t" (Const t0) (Const tstep) eq (init n) in
+ String.concat "\n" (List.map2 (fun t v ->
+ (Term.str t) ^ " = " ^ (Term.str v) ^ "\n") (init (n+1)) res) in
+ assert_equal ~printer:(fun x->x) "ok" (generate_rksymb tyson 0 0. 0.005);
+ *)
);
]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -69,8 +69,8 @@
("Hnefatafl", AuxIO.input_file "examples/Hnefatafl.toss");
("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
("Bounce", AuxIO.input_file "examples/Bounce.toss");
- ("Yeast-Cell-Cycle-Tyson",
- AuxIO.input_file "examples/Yeast-Cell-Cycle-Tyson.toss");
+ ("Cell-Cycle-Tyson-1991",
+ AuxIO.input_file "examples/Cell-Cycle-Tyson-1991.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Client/State.js 2012-05-10 22:22:09 UTC (rev 1704)
@@ -56,7 +56,7 @@
function State (game, info_obj, mirror) {
// We create an SVG box with margins depending on the game.
this.game = game;
- this.mirror = mirror || (game == "Yeast-Cell-Cycle-Tyson");
+ this.mirror = mirror || (game == "Cell-Cycle-Tyson-1991");
var create_svg_box = function (margx, margy, parent_id) {
var svg_e = document.getElementById("svg");
@@ -198,7 +198,7 @@
function square_elements_game (game) {
return (game !== "Connect4" &&
game !== "Bounce" &&
- game !== "Yeast-Cell-Cycle-Tyson" &&
+ game !== "Cell-Cycle-Tyson-1991" &&
game !== "Rewriting-Example")
}
Copied: trunk/Toss/Client/img/Cell-Cycle-Tyson-1991.png (from rev 1703, trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png)
===================================================================
(Binary files differ)
Deleted: trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Client/index.html 2012-05-10 22:22:09 UTC (rev 1704)
@@ -172,11 +172,11 @@
</button>
</div>
<div class="game-picdiv3">
-<button onclick="new_play_click ('Yeast-Cell-Cycle-Tyson')" class="game-picbt">
- <img class="game-picimg" src="img/Yeast-Cell-Cycle-Tyson.png"
- alt="Yeast-Cell-Cycle-Tyson" />
- <span id="pdescYeast-Cell-Cycle-Tyson" class="game-picspan">
- <span class="game-pictxt">Yeast-Cell-Cycle-Tyson</span>
+<button onclick="new_play_click ('Cell-Cycle-Tyson-1991')" class="game-picbt">
+ <img class="game-picimg" src="img/Cell-Cycle-Tyson-1991.png"
+ alt="Cell-Cycle-Tyson-1991" />
+ <span id="pdescCell-Cycle-Tyson-1991" class="game-picspan">
+ <span class="game-pictxt">Cell-Cycle-Tyson-1991</span>
</span>
</button>
</div>
@@ -462,8 +462,8 @@
<p><b>Bounce</b> is the basic example we use to illustrate how continuous
dynamics and invariants work with structure rewriting.</p>
</div>
- <div class="game-desc" id="Yeast-Cell-Cycle-Tyson-desc">
- <p><b>Yeast Cell Cycle</b> model by <b>Tyson</b> (1991),
+ <div class="game-desc" id="Cell-Cycle-Tyson-1991-desc">
+ <p>Yeast <b>Cell Cycle</b> model by <b>Tyson (1991)</b>,
<a href="http://www.cellerator.org/notebooks/Tyson6.html">described
here</a>, is a model of the cell cycle based on the interactions
between cdc2 and cyclin. We use it as an example of non-linear
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -12,7 +12,10 @@
Poly (z, [(Poly(y, [(Poly (x, [(Const 1, 1)]), 0)]), 2);
(Poly(y, [(Poly (x, [(Const 2, 0)]), 0)]), 0)]) *)
-type polynomial = Const of num | Poly of string * (polynomial * int) list
+type polynomial =
+ | FConst of float
+ | Const of num
+ | Poly of string * (polynomial * int) list
type t = polynomial (* to be compatible with OrderedType signature *)
@@ -26,7 +29,8 @@
(* Print the given ordered polynomial as a string. *)
let rec str = function
- Const n -> string_of_num n
+ | FConst n -> string_of_float n
+ | Const n -> string_of_num n
| Poly (v, clist) ->
let estr (p, d) =
if d = 0 then "(" ^ (str p) ^ ")" else if d = 1 then
@@ -41,7 +45,8 @@
(* Check if the given ordered polynomial is equal to zero. *)
let rec is_zero = function
- Const n -> (sign_num n) = 0
+ | FConst n -> n = 0.
+ | Const n -> (sign_num n) = 0
| Poly (_, []) -> true
| Poly (_, [(c, n)]) -> n = 0 && is_zero c
| _ -> false
@@ -50,11 +55,14 @@
do not assume that both arguments are over the same set of variables. *)
let rec rcompare p1 p2 =
match (p1, p2) with
- (Const n, Const m) ->
- let c = sign_num ((abs_num n) -/ (abs_num m)) in
- if c <> 0 then c else sign_num (n -/ m)
+ | (FConst n, FConst m) -> if n > m then 1 else if m > n then -1 else 0
+ | (Const n, Const m) ->
+ let c = sign_num ((abs_num n) -/ (abs_num m)) in
+ if c <> 0 then c else sign_num (n -/ m)
| (Const _, _) -> -1
| (_, Const _) -> 1
+ | (FConst _, _) -> -1
+ | (_, FConst _) -> 1
| (Poly (v, [(c, d)]), Poly (w, [])) -> if d = 0 && is_zero c then 0 else 1
| (Poly (w, []), Poly (v, [(c, d)])) -> if d = 0 && is_zero c then 0 else -1
| (Poly (_, _::_), Poly (_, [])) -> 1
@@ -62,19 +70,19 @@
| (Poly (_, []), Poly (_, [])) -> 0
| (Poly (v, _), Poly (w, _)) when v <> w -> String.compare v w
| (Poly (v, (c1, d1)::r1), Poly (w, (c2, d2)::r2)) ->
- if d1 <> d2 then d1 - d2 else
- let c = rcompare c1 c2 in
- if c <> 0 then c else rcompare (Poly (v, r1)) (Poly (w, r2))
+ if d1 <> d2 then d1 - d2 else
+ let c = rcompare c1 c2 in
+ if c <> 0 then c else rcompare (Poly (v, r1)) (Poly (w, r2))
let rec deg_sum acc = function
- Const _ -> acc
+ | Const _ | FConst _ -> acc
| Poly (v, lst) ->
- let deg_sumi acc (p, i) = deg_sum (i + acc) p in
- List.fold_left deg_sumi acc lst
+ let deg_sumi acc (p, i) = deg_sum (i + acc) p in
+ List.fold_left deg_sumi acc lst
let compare p q =
let d = (deg_sum 0 p) - (deg_sum 0 q) in
- if d <> 0 then d else rcompare p q
+ if d <> 0 then d else rcompare p q
(* Check if two polynomials are equal. *)
let equal p1 p2 = (compare p1 p2 = 0)
@@ -85,78 +93,80 @@
(* Helper function to extract main variable from an ordered polynomial. *)
let var = function
- Const _ -> raise Unmatched_variables
+ | Const _ | FConst _ -> raise Unmatched_variables
| Poly (v, _) -> v
(* Lower the number of variables of a polynomial - remove the highest. *)
let lower = function
- Poly (v, [(q, d)]) when d = 0 -> q
+ | Poly (v, [(q, d)]) when d = 0 -> q
| _ -> failwith "cannot lower non-constant or zero polynomial"
(* Check if the given ordered polynomial has constant value. *)
let rec constant_value = function
- Const n -> Some n
+ | FConst n -> failwith "constant value for FConst; TODO move from Poly.ml"
+ | Const n -> Some n
| Poly (_, []) -> Some (num_of_int 0)
| Poly (_, (c, d) :: rest) when d = 0 -> constant_value c
| _ -> None
(* Degree of the given polynomial in its highest variable. *)
let deg = function
- Poly (_, (_, d) :: _) -> d
+ | Poly (_, (_, d) :: _) -> d
| _ -> 0
(* Leading coefficient of the given polynomial, represented as ordered
polynomial, multiplied by main variable raised to [n]-th power. *)
let leading_coeff n = function
- Poly (v, (c, _) :: _) -> Poly (v, [(c, n)])
+ | Poly (v, (c, _) :: _) -> Poly (v, [(c, n)])
| Poly (v, []) -> Poly (v, [])
| Const n -> Const n
+ | FConst n -> FConst n
(* Degree 0 coefficient of the given polynomial, if it exists and is non-0. *)
let rec const_coeff = function
- Poly (v, [(q, d)]) as p when d = 0 && not (is_zero q) -> Some p
+ | Poly (v, [(q, d)]) as p when d = 0 && not (is_zero q) -> Some p
| Poly (v, _ :: rs) -> const_coeff (Poly (v, rs))
| _ -> None
(* Omit leading coefficient in the given polynomial. *)
let omit_leading = function
- Poly (v, _ :: rest) -> Poly (v, rest)
+ | Poly (v, _ :: rest) -> Poly (v, rest)
| x -> x
(* Calculate n * p for a given polynomial p. *)
let rec multiple n = function
- Const m -> Const ((num_of_int n) */ m)
+ | FConst m -> FConst ((float_of_int n) *. m)
+ | Const m -> Const ((num_of_int n) */ m)
| Poly (v, l) ->
- if n = 0 then Poly (v, []) else
- Poly (v, List.map (fun (c, d) -> (multiple n c, d)) l)
+ if n = 0 then Poly (v, []) else
+ Poly (v, List.map (fun (c, d) -> (multiple n c, d)) l)
let rec multiple_num n = function
- Const m -> Const (n */ m)
+ | FConst m -> failwith "multiple num for FConst; TODO move from Poly.ml"
+ | Const m -> Const (n */ m)
| Poly (v, l) ->
- if sign_num n = 0 then Poly (v, []) else
- Poly (v, List.map (fun (c, d) -> (multiple_num n c, d)) l)
+ if sign_num n = 0 then Poly (v, []) else
+ Poly (v, List.map (fun (c, d) -> (multiple_num n c, d)) l)
(* If c1 * p = c2 * q for constants (c1,c2) <> (0,0), return them; else None. *)
let rec constant_factors p0 q0 =
match (p0, q0) with
- (Const n, Const m) ->
- if (sign_num m) <> 0 or (sign_num n) <> 0 then
- Some (m, n)
- else None
+ | (Const n, Const m) ->
+ if (sign_num m) <> 0 or (sign_num n) <> 0 then Some (m, n) else None
| (Poly (v, []), _) ->
- if is_zero q0 then None else Some (num_of_int 1, num_of_int 0)
+ if is_zero q0 then None else Some (num_of_int 1, num_of_int 0)
| (_, Poly (v, [])) ->
- if is_zero p0 then None else Some (num_of_int 0, num_of_int 1)
+ if is_zero p0 then None else Some (num_of_int 0, num_of_int 1)
| (Poly (v, (p, d)::ps), Poly (w, (q, e)::qs)) when w = v -> (
- if d <> e then None else match constant_factors p q with
- None -> None
- | Some (a, b) ->
- if equal (multiple_num a p0) (multiple_num b q0) then
- Some (a,b)
- else None
- )
+ if d <> e then None else match constant_factors p q with
+ | None -> None
+ | Some (a, b) ->
+ if equal (multiple_num a p0) (multiple_num b q0) then
+ Some (a,b)
+ else None
+ )
| _ -> raise Unmatched_variables
@@ -165,23 +175,24 @@
(* Add two ordered polynomials [p1] and [p2] in the same variable. *)
let rec add p1 p2 =
match (p1, p2) with
- (Const n, Const m) -> Const (n +/ m)
+ | (FConst n, FConst m) -> FConst (n +. m)
+ | (Const n, Const m) -> Const (n +/ m)
| (Poly (v, l1), Poly (w, l2)) when v = w -> Poly (v, add_lists (l1, l2))
| _ -> raise Unmatched_variables
and add_lists = function
- ([(p, d)], []) when d = 0 && is_zero p -> []
+ | ([(p, d)], []) when d = 0 && is_zero p -> []
| ([], [(p, d)]) when d = 0 && is_zero p -> []
| (l1, []) -> l1
| ([], l2) -> l2
| ((c1, d1) :: r1, (c2, d2) :: r2) ->
- if d1 > d2 then
- (c1, d1) :: (add_lists (r1, (c2, d2) :: r2))
- else if d2 > d1 then
- (c2, d2) :: (add_lists ((c1, d1) :: r1, r2))
- else let c = add c1 c2 in
- if is_zero c then add_lists (r1, r2) else
- (c, d1) :: (add_lists (r1, r2))
+ if d1 > d2 then
+ (c1, d1) :: (add_lists (r1, (c2, d2) :: r2))
+ else if d2 > d1 then
+ (c2, d2) :: (add_lists ((c1, d1) :: r1, r2))
+ else let c = add c1 c2 in
+ if is_zero c then add_lists (r1, r2) else
+ (c, d1) :: (add_lists (r1, r2))
(* Given a polynomial p, returns -p. *)
let neg p = multiple (-1) p
@@ -192,76 +203,78 @@
(* Multiply two polynomials [p1] and [p2] in the same variables. *)
let rec mul p1 p2 =
match (p1, p2) with
- (Const n, Const m) -> Const (n */ m)
+ | (FConst n, FConst m) -> FConst (n *. m)
+ | (Const n, Const m) -> Const (n */ m)
| (Poly (v, l1), Poly (w, l2)) when v = w -> Poly (v, mul_lists l1 l2)
| _ -> raise Unmatched_variables
and mul_lists l1 = function
| [] -> []
| [(c2, d2)] ->
- let append_coeff_mul (c1, d1) acc =
- let c = mul c2 c1 in
- if is_zero c then acc else (c, d1 + d2) :: acc
- in
- List.fold_right append_coeff_mul l1 []
+ let append_coeff_mul (c1, d1) acc =
+ let c = mul c2 c1 in
+ if is_zero c then acc else (c, d1 + d2) :: acc in
+ List.fold_right append_coeff_mul l1 []
| c :: rest ->
- add_lists ((mul_lists l1 [c]), (mul_lists l1 rest))
+ add_lists ((mul_lists l1 [c]), (mul_lists l1 rest))
(* Raise [p] to n-th power. *)
let rec pow p n =
if n < 1 then failwith "we only support powers > 0" else if n = 1 then p else
- let q = pow p (n / 2) in
+ let q = pow p (n / 2) in
if n mod 2 = 0 then mul q q else mul p (mul q q)
(* Given [u] and [p] return, if possible, q and r with [u] = q*[p] + r. *)
(* Based on code from Jean-Christophe Filliatre, cf. Knuth volume 2, 4.6.1. *)
let rec div ?(allow_frac=false) p q =
- match (p, q) with
- (Const n, Const m) ->
- if allow_frac then Const (n // m) else
- if sign_num (mod_num n m) = 0 then Const (n // m) else
- raise Not_found
- | (Poly (v, _), Poly (w, _)) ->
- if v <> w then raise Unmatched_variables else
- let (l, r) = div_rest ~allow_frac:allow_frac p q in
- if is_zero r then l else raise Not_found
- | _ -> raise Unmatched_variables
+ match (p, q) with
+ | (Const n, Const m) ->
+ if allow_frac then Const (n // m) else
+ if sign_num (mod_num n m) = 0 then Const (n // m) else
+ raise Not_found
+ | (Poly (v, _), Poly (w, _)) ->
+ if v <> w then raise Unmatched_variables else
+ let (l, r) = div_rest ~allow_frac:allow_frac p q in
+ if is_zero r then l else raise Not_found
+ | _ -> raise Unmatched_variables
and div_rest ?(allow_frac=false) u = function
- Poly (_, []) -> raise Not_found
+ | Poly (_, []) -> raise Not_found
+ | FConst _ -> failwith "div_rest: FConst arg"
| Const n -> (
- match u with
- Const m ->
- if allow_frac then (Const (n // m), Const (num_of_int 0)) else
- let r = mod_num n m in (Const ((n -/ r) // m), Const r)
- | Poly (_, _) -> raise Unmatched_variables
- )
+ match u with
+ | FConst _ -> failwith "div_rest: FConst u"
+ | Const m ->
+ if allow_frac then (Const (n // m), Const (num_of_int 0)) else
+ let r = mod_num n m in (Const ((n -/ r) // m), Const r)
+ | Poly (_, _) -> raise Unmatched_variables
+ )
| Poly (v, (p, d) :: ps) ->
- let rec loop k = function
- u when k < 0 -> (Poly (v, []), u)
- | Poly (w, _) when w <> v -> raise Unmatched_variables
- | Poly (_, (q, i) :: qs) when i = d + k ->
- let qk = div ~allow_frac:allow_frac q p in
- let mqkxk = Poly (v, [(neg qk, k)]) in
- let added = add (Poly (v, qs)) (mul mqkxk (Poly (v, ps))) in
- let (q, r) = loop (k - 1) added in (
- match q with
- Poly (_, ql) -> (Poly (v, (qk, k) :: ql), r)
- | _ -> failwith "error by division"
- )
- | u -> loop (k - 1) u
- in
- loop (deg u - d) u
+ let rec loop k = function
+ | u when k < 0 -> (Poly (v, []), u)
+ | Poly (w, _) when w <> v -> raise Unmatched_variables
+ | Poly (_, (q, i) :: qs) when i = d + k ->
+ let qk = div ~allow_frac:allow_frac q p in
+ let mqkxk = Poly (v, [(neg qk, k)]) in
+ let added = add (Poly (v, qs)) (mul mqkxk (Poly (v, ps))) in
+ let (q, r) = loop (k - 1) added in (
+ match q with
+ | Poly (_, ql) -> (Poly (v, (qk, k) :: ql), r)
+ | _ -> failwith "error by division"
+ )
+ | u -> loop (k - 1) u in
+ loop (deg u - d) u
(* -------------------------- DIFFERENTIATION ------------------------------- *)
let rec diff = function
- Const n -> Const (num_of_int 0)
+ | FConst _ -> FConst (0.)
+ | Const _ -> Const (num_of_int 0)
| Poly (v, l) -> Poly (v, diff_list l)
and diff_list = function
- [] -> []
+ | [] -> []
| (c, d) :: r -> if d > 0 then (multiple d c, d-1) :: (diff_list r) else []
@@ -277,21 +290,20 @@
*)
let modified_remainder p1 q =
match q with
- Const _ -> raise Unmatched_variables
+ | Const _ | FConst _ -> raise Unmatched_variables
| Poly (v, _) when var p1 <> v -> raise Unmatched_variables
| Poly (v, _) ->
- let (m, b, q') = (deg q, leading_coeff 0 q, omit_leading q) in
- if m > deg p1 then failwith "Modified reminder: wrong degree." else
- let rec mr p =
- let (n, a) = (deg p, leading_coeff 0 p) in
- if n < m then p
- else if n = m then
- sub (mul b p) (mul a q)
- else
- let bp = mul b (omit_leading p) in
- let d = sub bp (mul (leading_coeff (n-m) p) q') in
- if n - 1 = deg d then mr d else
- let bpow = pow b (n - 1 - (deg d)) in
- mr (mul bpow d)
- in
- mr p1
+ let (m, b, q') = (deg q, leading_coeff 0 q, omit_leading q) in
+ if m > deg p1 then failwith "Modified reminder: wrong degree." else
+ let rec mr p =
+ let (n, a) = (deg p, leading_coeff 0 p) in
+ if n < m then p
+ else if n = m then
+ sub (mul b p) (mul a q)
+ else
+ let bp = mul b (omit_leading p) in
+ let d = sub bp (mul (leading_coeff (n-m) p) q') in
+ if n - 1 = deg d then mr d else
+ let bpow = pow b (n - 1 - (deg d)) in
+ mr (mul bpow d) in
+ mr p1
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-05-10 22:22:09 UTC (rev 1704)
@@ -3,7 +3,10 @@
(** {2 Basic Type Definitions} *)
-type polynomial = Const of Numbers.num | Poly of string * (polynomial*int) list
+type polynomial =
+ | FConst of float
+ | Const of Numbers.num
+ | Poly of string * (polynomial * int) list
type t = polynomial (** to be compatible with OrderedType signature *)
Modified: trunk/Toss/Solver/RealQuantElim/Poly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -3,7 +3,7 @@
(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
type polynomial =
- Var of string
+ | Var of string
| Const of float
| Times of polynomial * polynomial
| Plus of polynomial * polynomial
@@ -13,16 +13,18 @@
(* Print a polynomial as a string. *)
let rec str = function
- Var s -> s
+ | Var s -> s
| Const n -> string_of_float n
- | Times (Const n, q) -> if n = 1. then str q else poly_pair_str "*" (Const n) q
+ | Times (Const n, q) ->
+ if n = 1. then str q else poly_pair_str "*" (Const n) q
| Times (p, q) -> poly_pair_str "*" p q
- | Plus (p, Const n) -> if n = 0. then str p else poly_pair_str " + " p (Const n)
+ | Plus (p, Const n) ->
+ if n = 0. then str p else poly_pair_str " + " p (Const n)
| Plus (p, q) -> poly_pair_str " + " p q
and poly_pair_str sep p q =
let brack s = if String.length s < 2 then s else "(" ^ s ^ ")" in
- (brack (str p)) ^ sep ^ (brack (str q))
+ (brack (str p)) ^ sep ^ (brack (str q))
(* ------------------ HELPER POWER FUNCTION USED IN PARSER ------------------ *)
@@ -33,27 +35,28 @@
(* Basic simplification, reduces constant polynomials to integers. *)
let rec simp_const = function
- Var s -> Var s
+ | Var s -> Var s
| Const n -> Const n
| Times (p, q) -> (
match (simp_const p, simp_const q) with
- (Const n, Const m) -> Const (n *. m)
+ | (Const n, Const m) -> Const (n *. m)
| _ -> Times (p, q)
- )
+ )
| Plus (p, q) ->
- match (simp_const p, simp_const q) with
- (Const n, Const m) -> Const (n +. m)
- | _ -> Plus (p, q)
+ match (simp_const p, simp_const q) with
+ | (Const n, Const m) -> Const (n +. m)
+ | _ -> Plus (p, q)
(* ----------------- CONVERTION TO UNORDERED POLYNOMIALS -------------------- *)
let rec make_unordered = function
+ | OrderedPoly.FConst n -> Const (n)
| OrderedPoly.Const n -> Const (Numbers.float_of_num n)
| OrderedPoly.Poly (v, lst) -> make_unordered_list v lst
and make_unordered_list v = function
- [] -> Const 0.
+ | [] -> Const 0.
| [(p, d)] when d = 0 -> make_unordered p
| [(p, d)] -> Times (make_unordered p, pow (Var v) d)
| (p, d) :: ls ->
@@ -82,7 +85,7 @@
(* List variables in the given polynomial. *)
let rec vars = function
- Var s -> [s]
+ | Var s -> [s]
| Const _ -> []
| Times (p, q) -> combine (vars p) (vars q)
| Plus (p, q) -> combine (vars p) (vars q)
@@ -91,51 +94,52 @@
let vars_list pl = List.fold_left (fun vs p -> combine vs (vars p)) [] pl
(* Make an ordered polynomial from a constant [n] in given ordered variables. *)
-let rec make_ordered_const n = function
- [] -> OrderedPoly.Const (num_of_float n)
- | v :: vs -> OrderedPoly.Poly (v, [(make_ordered_const n vs, 0)])
+let rec make_ordered_const use_num n = function
+ | [] -> if use_num then OrderedPoly.Const (num_of_float n) else
+ OrderedPoly.FConst (n)
+ | v :: vs -> OrderedPoly.Poly (v, [(make_ordered_const use_num n vs, 0)])
(* Make an ordered polynomial from a variable [v] in given ordered variables. *)
-let rec make_ordered_var v = function
- [] -> failwith "given variable not found among all variables"
- | w :: ws when v = w -> OrderedPoly.Poly (v, [(make_ordered_const 1. ws, 1)])
- | w :: ws -> OrderedPoly.Poly (w, [(make_ordered_var v ws, 0)])
+let rec make_ordered_var use_num v = function
+ | [] -> failwith "given variable not found among all variables"
+ | w :: ws when v = w ->
+ OrderedPoly.Poly (v, [(make_ordered_const use_num 1. ws, 1)])
+ | w :: ws -> OrderedPoly.Poly (w, [(make_ordered_var use_num v ws, 0)])
(* Make an ordered polynomial in given ordered variables [vars]. *)
-let rec make_ordered_poly vars = function
- Const n -> make_ordered_const n vars
- | Var v -> make_ordered_var v vars
- | Times (p, q) ->
- OrderedPoly.mul (make_ordered_poly vars p) (make_ordered_poly vars q)
- | Plus (p, q) ->
- OrderedPoly.add (make_ordered_poly vars p) (make_ordered_poly vars q)
+let rec make_ordered_poly use_num vars = function
+ | Const n -> make_ordered_const use_num n vars
+ | Var v -> make_ordered_var use_num v vars
+ | Times (p, q) -> OrderedPoly.mul
+ (make_ordered_poly use_num vars p) (make_ordered_poly use_num vars q)
+ | Plus (p, q) -> OrderedPoly.add
+ (make_ordered_poly use_num vars p) (make_ordered_poly use_num vars q)
(* Order on strings respecting priority given in [prio_list]. This means
that if x appears in [prio_list] before y then x < y. Strings not appearing
in [prio_list] at all are considered smaller than any string that appears. *)
let compare prio_list x y =
let rec cmp = function
- [] -> String.compare x y
+ | [] -> String.compare x y
| v :: vs when v = x -> if List.mem y vs the...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-12 22:03:02
|
Revision: 1708
http://toss.svn.sourceforge.net/toss/?rev=1708&view=rev
Author: lukaszkaiser
Date: 2012-05-12 22:02:53 +0000 (Sat, 12 May 2012)
Log Message:
-----------
Pre-release orders.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Makefile
trunk/Toss/Toss.odocl
trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
trunk/Toss/www/Publications/all.bib
trunk/Toss/www/contact.xml
trunk/Toss/www/develop.xml
trunk/Toss/www/index.xml
trunk/Toss/www/reference/.cvsignore
trunk/Toss/www/reference/reference.bib
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/www/pub/contraintes_slides.pdf
trunk/Toss/www/pub/learning_games_descriptive_complexity.pdf
trunk/Toss/www/reference/Bknwn.png
trunk/Toss/www/reference/Bkwn0.png
trunk/Toss/www/reference/Cnw0.png
trunk/Toss/www/reference/Cnw1.png
trunk/Toss/www/reference/Cnw2.png
trunk/Toss/www/reference/Cnw3.png
trunk/Toss/www/reference/Cnwg.png
trunk/Toss/www/reference/Cw0.png
trunk/Toss/www/reference/Cw1.png
trunk/Toss/www/reference/Cw2.png
trunk/Toss/www/reference/Cw3.png
trunk/Toss/www/reference/Cwg.png
trunk/Toss/www/reference/Pw0.png
trunk/Toss/www/reference/Pw1.png
Property Changed:
----------------
trunk/Toss/www/reference/
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -3,7 +3,7 @@
let time_step = ref 0.1
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
-let dIFFM = 20 (* So many differentiation steps for one time step. *)
+let dIFFM = 10 (* So many differentiation steps for one time step. *)
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/Makefile 2012-05-12 22:02:53 UTC (rev 1708)
@@ -18,7 +18,7 @@
make -C Client alljsgz
-RELEASE=0.7
+RELEASE=0.8
Release: TossServer doc
rm -f *~ MenhirLib/*~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
Learn/*~ Language/*~ Server/*~ www/*~ WebClient/~
@@ -138,7 +138,7 @@
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
doc: $(EXTDEPS)
- $(OCAMLBUILD) $(.INC) Toss.docdir/index.html
+ $(OCAMLBUILD) -Is $(.INC) Toss.docdir/index.html
make -C www code_doc_link
Modified: trunk/Toss/Toss.odocl
===================================================================
--- trunk/Toss/Toss.odocl 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/Toss.odocl 2012-05-12 22:02:53 UTC (rev 1708)
@@ -30,7 +30,6 @@
Arena/Arena
Arena/ArenaParser
Play/Heuristic
-Play/Move
Play/GameTree
Play/Play
GGP/GDL
@@ -40,4 +39,3 @@
GGP/GameSimpl
Learn/Distinguish
Learn/LearnGame
-Server/ReqHandler
Modified: trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
===================================================================
--- trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss 2012-05-12 22:02:53 UTC (rev 1708)
@@ -57,7 +57,7 @@
LOC 0 {
PLAYER 1 { PAYOFF 0. MOVES [Move,
- t : 9. -- 9.,
+ t : 12. -- 12.,
k1 : 0.015 -- 0.015,
k3 : 200. -- 200.,
k4p: 0.018 -- 0.018,
@@ -69,6 +69,10 @@
PLAYER 2 { PAYOFF 0. }
UNIVERSAL { k1, k3, k4p, k4, k6, k7, k8, k9 }
}
+LOC 1 {
+ PLAYER 1 { PAYOFF Sum (x | Cdc2CycP1P2(x) : :y(x)) }
+ PLAYER 2 { PAYOFF 0. }
+}
START [ e1, e2, e3, e4, e5, e6 | Cyc(e1); CycP1(e2); Cdc2(e3); Cdc2P1(e4);
Cdc2CycP1(e5); Cdc2CycP1P2(e6) |
x { e1->1, e2->2, e3->3, e4->4, e5->5, e6->6 };
Modified: trunk/Toss/www/Publications/all.bib
===================================================================
--- trunk/Toss/www/Publications/all.bib 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/Publications/all.bib 2012-05-12 22:02:53 UTC (rev 1708)
@@ -4,6 +4,14 @@
# TALKS
+@inproceedings{KCONSTRAINTES11,
+ author={Toss},
+ title={Quantitative Logics on Structure Rewriting Systems},
+ url = {/pub/contraintes_slides.pdf},
+ booktitle= {EPI Contraintes Seminar, INRIA Paris-Rocquencourt},
+ year={2012 Talk}
+}
+
@inproceedings{KAAAI11,
author={Toss},
title={First Order Logic with Counting for General Game Playing},
@@ -129,6 +137,33 @@
# ARTICLES
+@inproceedings{K12,
+ author = {\L{}ukasz Kaiser},
+ title = {Learning Games from Videos Guided by Descriptive Complexity},
+ year = {2012},
+ booktitle = {Proceedings of the 26th Conference on Artificial
+ Intelligence, AAAI-12, to appear},
+ publisher = {AAAI Press},
+ url = {/pub/learning_games_descriptive_complexity.pdf},
+ abstract = {
+In recent years, several systems have been proposed that learn the rules
+of a simple card or board game solely from visual demonstration.
+These systems were constructed for specific games
+and rely on substantial background knowledge.
+We introduce a general system for learning board game rules from videos
+and demonstrate it on several well-known games. The presented algorithm
+requires only a few demonstrations and minimal background knowledge,
+and, having learned the rules, automatically derives position evaluation
+functions and can play the learned games competitively.
+Our main technique is based on descriptive complexity,
+the logical means necessary to define a set of interest. We compute formulas
+defining allowed moves and final positions in a game in different logics
+and select the most adequate ones. We show that this method is well-suited
+for board games and there is strong theoretical evidence that it
+will generalize to other problems.
+}
+}
+
@inproceedings{KS11transl,
author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak},
title = {Translating the Game Description Langauge to Toss},
Modified: trunk/Toss/www/contact.xml
===================================================================
--- trunk/Toss/www/contact.xml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/contact.xml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -280,7 +280,6 @@
<itemize>
<item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item>
<item>Łukasz Stafiniak</item>
- <item>Michał Wójcik</item>
</itemize>
<par>Friends who helped us a lot with discussion and code.</par>
<itemize>
@@ -289,6 +288,7 @@
<item>Diana Fischer</item>
<item>Tobias Ganzow</item>
<item>Simon Leßenich</item>
+ <item>Michał Wójcik</item>
</itemize>
<par>Yet another group of people, who worked on the oldest version of Toss
(around 2004), was lead by:</par>
Modified: trunk/Toss/www/develop.xml
===================================================================
--- trunk/Toss/www/develop.xml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/develop.xml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -262,8 +262,6 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
<section title="Mit Toss Team Zusammenarbeiten" lang="de">
@@ -279,8 +277,6 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
<section title="Praca z Nami" lang="pol">
@@ -296,11 +292,9 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
- <section title="Travailler avec l'Équipe de Toss" lang="fr">
+ <section title="Travailler avec l'Équipe du Toss" lang="fr">
<par>Si vous avez une idée, une demande, vous voulez devenir un développeur
ou tout simplement voudrais parler, contactez-nous! Les développeurs
Toss de plus engagés répondre aux questions Toss sur leur e-mails privés
@@ -313,8 +307,6 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/index.xml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -65,18 +65,22 @@
<section title="News">
<itemize>
+ <newsitem date="13/05/12">
+ Toss release 0.8 with full JS compatibility with dynamics</newsitem>
<newsitem date="04/05/12">
+ Dynamics debugged and animations now work in the JS interface</newsitem>
+ <newsitem date="04/05/12">
Old rewriting example works with the JS interface</newsitem>
<newsitem date="25/04/12">
Work on positioning with the JS interface</newsitem>
- <newsitem date="30/03/12">
- Adding Hnefatafl to example Toss games</newsitem>
- <newsitem date="21/03/12">
- Toss Client and website updated to a cleaned-up JS version</newsitem>
- <newsitem date="09/03/12">
- First completely working all-JS Toss version</newsitem>
- <newsitem date="05/03/12">
- Fully integrated OCaml and JS debugging and logs</newsitem>
+ <oldnewsitem date="30/03/12">
+ Adding Hnefatafl to example Toss games</oldnewsitem>
+ <oldnewsitem date="21/03/12">
+ Toss Client and website updated to a cleaned-up JS version</oldnewsitem>
+ <oldnewsitem date="09/03/12">
+ First completely working all-JS Toss version</oldnewsitem>
+ <oldnewsitem date="05/03/12">
+ Fully integrated OCaml and JS debugging and logs</oldnewsitem>
<oldnewsitem date="27/02/12">
Compiled resources to access files from JS</oldnewsitem>
<oldnewsitem date="18/02/12">
Added: trunk/Toss/www/pub/contraintes_slides.pdf
===================================================================
--- trunk/Toss/www/pub/contraintes_slides.pdf (rev 0)
+++ trunk/Toss/www/pub/contraintes_slides.pdf 2012-05-12 22:02:53 UTC (rev 1708)
@@ -0,0 +1,12989 @@
+%PDF-1.4
+%\xD0\xD4\xC5\xD8
+8 0 obj
+<< /S /GoTo /D (Outline0.1) >>
+endobj
+11 0 obj
+(Structure Rewriting Systems)
+endobj
+12 0 obj
+<< /S /GoTo /D (Outline0.1.1.3) >>
+endobj
+15 0 obj
+(Structure Transition Systems and Games)
+endobj
+16 0 obj
+<< /S /GoTo /D (Outline0.1.2.26) >>
+endobj
+19 0 obj
+(Separated Rules and Decidability)
+endobj
+20 0 obj
+<< /S /GoTo /D (Outline0.1.3.51) >>
+endobj
+23 0 obj
+(Simulation-Based Playing)
+endobj
+24 0 obj
+<< /S /GoTo /D (Outline0.1.4.66) >>
+endobj
+27 0 obj
+(Continuous Dynamics)
+endobj
+28 0 obj
+<< /S /GoTo /D (Outline0.2) >>
+endobj
+31 0 obj
+(Quantitative Logics)
+endobj
+32 0 obj
+<< /S /GoTo /D (Outline0.2.1.73) >>
+endobj
+35 0 obj
+(Standard -Calculus)
+endobj
+36 0 obj
+<< /S /GoTo /D (Outline0.2.2.92) >>
+endobj
+39 0 obj
+(Quantitative -Calculus)
+endobj
+40 0 obj
+<< /S /GoTo /D (Outline0.2.3.103) >>
+endobj
+43 0 obj
+(Model Checking on Linear Hybrid Systems)
+endobj
+44 0 obj
+<< /S /GoTo /D (Outline0.2.4.125) >>
+endobj
+47 0 obj
+(Model Checking on Increasing Tree Rewriting Systems)
+endobj
+48 0 obj
+<< /S /GoTo /D (Outline0.3) >>
+endobj
+51 0 obj
+(Summary)
+endobj
+52 0 obj
+<< /S /GoTo /D [53 0 R /Fit ] >>
+endobj
+55 0 obj <<
+/Length 770
+/Filter /FlateDecode
+>>
+stream
+x\xDA\xC5UKO1\xBE\xF3+|\xAAl\xA9k\xFC\xF6\xFAHy5\xB4E\x90\xA4\xE2@8\xAC\x92%X\x90\x8D\xD8\xFD\xF5 \xDBP 儢\xEC̎\xED\x99o\xBE\x99Y34G \xEF\xB0$\xC9Aރ\x85!iͥF\xC2
+ʅAu\x89\xAEwη}\x96\\x83\xDDZ\xA7\xA5\xBF\xCCs\xB4\xF1>\xFCD\xDCT\xA3@k\x84\x94\xD4\xE1s\xCF\xD4\xF3\xB8\x9EBij\x9CD\xD3\xC5f= UR\xAD\xCB\xF1DË\xEE?b}\xC7\xD3;e\xD8N\x803\x80\xEB7\x9AJ\xF5\x9C\x85\xE2\x94k\x83\x84\xA3,Ϸ\xB2x\xF2?\xAA"\x86^ \xDF\xC6;\xBBG|+\xF0h_#\x9C0\x83\xB8Rr\x89\xC63t\x89\xCFI\xA6pWTD\xE3ַ1 \x97\xB8$\x99`\xFF$\x9C\xE3\xE5\x9C(\xEC\xA7M2-\xAB$G`l\xEBnJ2\x87\xBB\x9A\xB8\xF5\xA1!ɂ\x89W\xB5o}5_\xEF\xE7?\x86G\xD3B\x9Crѐ\xAB\xF1ɻ=
+YD~ YpG9\xA0\xCFdNsgS\xBE\xA8
+\x88\xBE\x8F\x880\xD87ӛ\xB2&Z\xE2\xAF\xC9:\x81Gw Hs\4\x92\xED\xBC\\xF8v \x87㍂\xAA5TDj\xAA\xAD \xB9\xBCbh\x8B'\xA1\xD4J\xA3Uܺ@\x86Q),\xA8wh\xE5I\xC4oB6\x86\xE690/-\xD5 #\xE6 \xD9\xC8/"\xA1\xA0\xD7
+\x97imY\xF9\xE9\xCD\xD0G\xC0m[L\x98T\x95/n7hܠ\xCDRgY\x84\x90\xE5\xD0a\x90O& \xEE\x84_$Bo\xCAE\x94\x91\xB8\xE3\xB8\xEE\xAA\xD9]1/{t3\xA0)*\xC0\xC2pu \xBAdY\x87\xFE\xE9\xCF\x90j\x9D\xD70\xB2{\x9D \xF1\xF8{\xB2\xED\x85\xCDD\xA8d$8Π\xCCQetB\xD4\xFB\x86\xC9 ~l\xBB\xF6\xED\x90qWk\xB1\xEF\xE3\xFE\xAE\xFC\x8A\xC0\xE6\xB2n c\x9B\xF5..\xC0\xA9\xC3\xCAr:Z$\xC7+Xo\xFA\xE3Q&\xA8\xB56!R \xD1\xCF\xC1\xDE\xB19\xDE\xEB\xFD\xEF\x9FGI\xFB\xF2\xF0\xA1\xE8ۉ\xD4<\x99\xCFB \xABo\x92\xE9\xC0\x82 ӄ \xFD\xEAn\xFBbY_ \xF68\xE9\x8E:WO(\xB6\x92\xC0,̈P4W}\xBF \x9E
+\xD2 \xEE&\x96q\xE2\xC3\xCC>\xAA\x81\xAAf=\xA8YO_ \xEDbA\xC1:8 \xF6\x92
+h9\xA0\xF5M'}97\xF7]Y\xB9\xECB\x9B\xC8\xE8\xB0?)\xAF$\xF3\xF1k!}hc\xCA
+i\xE8oS\xB9\x84\x8B\x97\xA3 F\x8D\xF5C%\xB8\xB0x7\x83\xB5\xF9/ \xF0\xF8 \xC9n\xBA\x97
+endstream
+endobj
+53 0 obj <<
+/Type /Page
+/Contents 55 0 R
+/Resources 54 0 R
+/MediaBox [0 0 362.835 272.126]
+
+/Trans << /S /R >>
+/Parent 62 0 R
+>> endobj
+56 0 obj <<
+/D [53 0 R /XYZ 10.839 272.126 null]
+>> endobj
+60 0 obj <<
+/D [53 0 R /XYZ 351.995 0 null]
+>> endobj
+61 0 obj <<
+/D [53 0 R /XYZ 351.995 0 null]
+>> endobj
+54 0 obj <<
+ /ColorSpace 3 0 R /Pattern 2 0 R /ExtGState 1 0 R
+/Font << /F90 57 0 R /F91 58 0 R /F94 59 0 R >>
+/ProcSet [ /PDF /Text ]
+>> endobj
+76 0 obj <<
+/Length 738
+/Filter /FlateDecode
+>>
+stream
+x\xDA\xCDVMs\xD30\xBD\xF7W\xE8( \xAC\xEA\xDB\xF6\xB5
+Lh\x92[\xE1\xA0:n\xF0\xBB\xE0\xD8t\xFA\xEFYI\xB6\x938n \xB6䕴\xEF\xEDӮd\x86V\x88\xA1\x8B6j9\xB4 \xDAo`aHA\xA9\x91\x88\xE5 :G\xB7'W\x8B\xFEUۓ=\xA7\x85'\xCE+\xB4\xF7={>T#'\x97\x87
+\xDDٖ\xDDVR\xEE\x87\xDC[(MM*QV\xEE\xEBl\xA8\x92\xAA\x97yo\xD2\xFD\xB4\xF5lqr\xFA*E\xA52-nQB5SHhA\x8D\x94h\xB1D\xD7\xF8=\x89\xB8\xC0\xDF \x978\xAFI$\xA0_\xE4D\xE2{\xF2i\xF1\xF6'\xE1<\xC2f$\xC9\xCB\xC5-g[\x8A\x84Ԕ\xA5\x89 \xB9 \x8C1ʄ\x8E\xD3\xDDnV\xA2aF\xB4c\x8FFs\xDC F\x95'\xD2u=\xCDne\xED\xE0\xE20\x9A\xB2\x94;qzr,\xA1ܫ3'
+7u\x9B\x81H7mMR\x9C\x83H,\xC63\x81bN\xA8\xBAh\x8Aj\xACsb>\xB8צ!\xE7\xE5&\xC88\x92\xA0\xF9 \xB4\xA1\xD2( *\xA9Vi-{h\xE9\xA19\xF3\xD8\xE0{A\x94\xC65\xD1\xD8V |
|
From: <luk...@us...> - 2012-05-18 21:22:21
|
Revision: 1709
http://toss.svn.sourceforge.net/toss/?rev=1709&view=rev
Author: lukaszkaiser
Date: 2012-05-18 21:22:13 +0000 (Fri, 18 May 2012)
Log Message:
-----------
Starting to use non-symbolic RK.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermParser.mly
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Server/Tests.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Arena.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -700,7 +700,7 @@
match ContinuousRule.rewrite_single state.struc u state.time mtch r t p with
| Some (new_struc, new_time, shifts) ->
let val_str ((f, e), tl) =
- let ts t = string_of_float (Term.term_val t) in
+ let ts t = string_of_float (t) in
f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in
let shifts_s = String.concat "; " (List.map val_str shifts) in
((state_game, {state with struc = new_struc; time = new_time}),
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Arena.mli 2012-05-18 21:22:13 UTC (rev 1709)
@@ -180,7 +180,7 @@
(** As [list_moves] but with animation shifts for each move. *)
val list_moves_shifts : game -> game_state ->
- (int * (move * ((string * string) * Term.term list) list) * game_state) array
+ (int * (move * ((string * string) * float list) list) * game_state) array
val apply_rule_int : game * game_state ->
string * (string * int) list * float * (string * float) list ->
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -107,10 +107,10 @@
let c = String.compare f g in if c <> 0 then c else
let d = String.compare x y in if d <> 0 then d else Term.compare t s in
let dyn = Term.subst_simp_eq [] [] (sum_common (List.sort cmp dyns)) in
- LOG 1 "%s" (Term.eq_str dyn);
+ (*LOG 1 "%s" (Term.eq_str dyn);*)
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
- let init_vals = List.map (fun ((f, a), _) -> Term.Const (fval f a)) dyn in
- (dyn, init_vals)
+ let init_vals = List.map (fun ((f, a), _) -> fval f a) dyn in
+ (dyn, Array.of_list init_vals)
(* For now, we rewrite only single rules. Does not check postcondition. *)
@@ -121,13 +121,14 @@
let p_vars, p_vals = List.split params in
(p_vars, List.map (fun f -> Term.Const f) p_vals) in
let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
+ let dyn_c = Term.compile "t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
let step vals t0 =
- LOG 1 "step at time %s" (Term.str t0);
- LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));
- Term.rk4_step "t" t0 (Term.Const diff_step) dyn vals in
+ (*LOG 1 "step at time %s" (Term.str t0);
+ LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));*)
+ Term.rk4_step_c t0 diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
@@ -135,11 +136,11 @@
let end_time = !time +. t -. (0.01 *. diff_step) in
LOG 1 "end time: %f" end_time;
let upd_struct st = List.fold_left2 (fun s ((f, e), _) v ->
- Structure.change_fun s f e v) st dyn (List.map Term.term_val !cur_vals) in
+ Structure.change_fun s f e v) st dyn (Array.to_list !cur_vals) in
while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
t_mod_diff := (!t_mod_diff + 1) mod dIFFM;
- cur_vals := step !cur_vals (Term.Const !time) ;
+ cur_vals := step !cur_vals !time ;
time := !time +. diff_step ;
last_struc := !cur_struc ;
cur_struc := upd_struct !cur_struc ;
@@ -156,10 +157,11 @@
let rec select_pos ids llst =
if ids = [] then [] else (List.hd ids, List.map List.hd llst) ::
(select_pos (List.tl ids) (List.map List.tl llst)) in
- let all_vals_assoc = select_pos (List.map fst dyn) (List.rev !all_vals) in
- LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
+ let all_vals_assoc =
+ select_pos (List.map fst dyn) (List.rev_map Array.to_list !all_vals) in
+ (*LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
(String.concat ", " (List.map (
- fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));
+ fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));*)
let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
let upd = List.map (fun (lhs, rhs) ->
(lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-05-18 21:22:13 UTC (rev 1709)
@@ -78,14 +78,14 @@
functions supplied with dynamics equations, at each time step). *)
val rewrite_single_nocheck : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
- Structure.structure * float * ((string * string) * Term.term list) list
+ Structure.structure * float * ((string * string) * float list) list
(** For now, we rewrite only single rules.
Same as {!ContinuousRule.rewrite_single_nocheck}, but check if the
postcondition holds. Returns [None] if rewriting fails. *)
val rewrite_single : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
- (Structure.structure * float * ((string* string)* Term.term list) list) option
+ (Structure.structure * float * ((string* string)* float list) list) option
(** Compare two rules and explain the first difference
met. Formulas and expressions are compared for structural equality. *)
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Term.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -214,7 +214,23 @@
let new_rhs = subst_simp_f lhs subst_vals rhs in
List.combine (List.map (fun (f, a) -> (f, replace a)) lhs) new_rhs
+let rec compile_term tv eqs = function
+ | Const c -> (fun _ _ -> c)
+ | Var v -> (fun t _ -> if v = tv then t else failwith "non time var compile")
+ | FVar (f, x) -> (fun _ a -> a.(Aux.find_index (f, x) eqs))
+ | Plus (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
+ (fun t a -> (cp t a) +. (cq t a)))
+ | Times (p, q) -> (let cp, cq= compile_term tv eqs p, compile_term tv eqs q in
+ (fun t a -> (cp t a) *. (cq t a)))
+ | Div (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
+ (fun t a -> (cp t a) /. (cq t a)))
+let compile tv eqs =
+ let lhs = fst (List.split eqs) in
+ let ceqs = Array.of_list (List.map (fun (_,t)-> compile_term tv lhs t) eqs) in
+ (fun t a -> Array.map (fun f -> f t a) ceqs)
+
+
(* ---------------- RUNGE - KUTTA METHOD FOR TERM EQUATIONS ---------------- *)
(* Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
@@ -230,3 +246,16 @@
let k4 = f_of (add tinit tstep) (ladd vals_init (lmul1 tstep k3)) in
let (dk2, dk3) = (lmul1 (Const 2.) k2, lmul1 (Const 2.) k3) in
ladd vals_init (lmul1 tstepdiv6 (ladd k1 (ladd dk2 (ladd dk3 k4))))
+
+let amul c arr = Array.map (fun x -> c *. x) arr
+let aadd a1 a2 = Aux.array_map2 (fun x1 x2 -> x1 +. x2) a1 a2
+
+let rk4_step_c tinit tstep eq_f vals_arr =
+ let tstepdiv6 = tstep /. 6. in
+ let htstep = tstep /. 2. in
+ let k1 = eq_f tinit vals_arr in
+ let k2 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k1)) in
+ let k3 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k2)) in
+ let k4 = eq_f (tinit +. tstep) (aadd vals_arr (amul tstep k3)) in
+ let (dk2, dk3) = (amul (2.) k2, amul (2.) k3) in
+ aadd vals_arr (amul tstepdiv6 (aadd k1 (aadd dk2 (aadd dk3 k4))))
Modified: trunk/Toss/Arena/Term.mli
===================================================================
--- trunk/Toss/Arena/Term.mli 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Term.mli 2012-05-18 21:22:13 UTC (rev 1709)
@@ -21,6 +21,7 @@
(** {2 Basic functions.} *)
+(*
(** Whether to simplify symbolically or not. Set to false by default.
It is nice for symbolic stuff, but slows down numerics. *)
val simp_symb : bool ref
@@ -36,8 +37,9 @@
(** Print an equation system as a string. *)
val eq_str : ?diff : bool -> eq_sys -> string
-
+*)
val fprint_eqs : ?diff : bool -> Format.formatter -> eq_sys -> unit
+(*
val print_eqs : ?diff : bool -> eq_sys -> unit
val sprint_eqs : ?diff : bool -> eq_sys -> string
@@ -53,10 +55,10 @@
(** Convert an equation system to float assciation list, fail on non-consts. *)
val eq_vals : eq_sys -> ((string * string) * float) list
+*)
-
(** {2 Simple operations.} *)
-
+(*
val add : term -> term -> term
val ladd1 : term -> term list -> term list
val ladd : term list -> term list -> term list
@@ -71,14 +73,17 @@
(** Substitute terms for variables as in [dict] in the given term. *)
val subst : (string * term) list -> term -> term
+*)
(** Substitute [vals] for [vars] in [terms] and simplify. *)
val subst_simp : string list -> term list -> term list -> term list
+(*
(** Substitute terms for function variables as in [dict] in the given term. *)
val subst_f : ((string * string) * term) list -> term -> term
(** Substitute [vals] for function [vars] in [terms] and simplify. *)
val subst_simp_f : (string * string) list -> term list -> term list -> term list
+*)
(** Substitute variables and function vals in an eq. system and simplify. *)
val subst_simp_eq : (string * term) list -> ((string * string) * term) list ->
@@ -93,4 +98,12 @@
(** Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
-val rk4_step : string -> term -> term -> eq_sys -> term list -> term list
+(*val rk4_step : string -> term -> term -> eq_sys -> term list -> term list*)
+
+
+(** Compile eq_sys to function. *)
+val compile : string -> eq_sys -> (float -> float array -> float array)
+
+(** RK4 with compiled system. *)
+val rk4_step_c : float -> float -> (float -> float array -> float array) ->
+ float array -> float array
Modified: trunk/Toss/Arena/TermParser.mly
===================================================================
--- trunk/Toss/Arena/TermParser.mly 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/TermParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
@@ -27,7 +27,6 @@
| term_expr MINUS term_expr { Term.Plus ($1, Term.Times(Term.Const(-1.), $3))}
| term_expr TIMES term_expr { Term.Times ($1, $3) }
| term_expr DIV term_expr { Term.Div ($1, $3) }
- | term_expr POW INT { Term.pow $1 $3 }
| OPEN term_expr CLOSE { $2 }
eq_expr: /* differential equations only */
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -262,7 +262,7 @@
let len, res = List.length (snd (List.hd shifts)), ref [state] in
for i = 0 to len - 1 do
let new_struc = List.fold_left (fun struc ((fname, elem), ts) ->
- let v = Term.term_val (List.nth ts i) in
+ let v = (List.nth ts i) in
Structure.change_fun struc fname elem v) state.Arena.struc shifts in
res := { state with Arena.struc = new_struc } :: !res;
done;
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Server/Tests.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -31,7 +31,6 @@
]
let arena_tests = "Arena", [
- "TermTest", [TermTest.tests];
"DiscreteRuleTest", [DiscreteRuleTest.tests];
"ContinuousRuleTest", [ContinuousRuleTest.tests];
"ArenaTest", [ArenaTest.tests];
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-05-19 21:37:26
|
Revision: 1710
http://toss.svn.sourceforge.net/toss/?rev=1710&view=rev
Author: lukaszkaiser
Date: 2012-05-19 21:37:16 +0000 (Sat, 19 May 2012)
Log Message:
-----------
Moving ODE from Term to Formula as expected, adjusting examples and tests, making old speagram left-linear.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/ContinuousRuleParser.mly
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Language/BuiltinLang.ml
trunk/Toss/Language/BuiltinLang.mli
trunk/Toss/Language/Makefile
trunk/Toss/Language/ParseArc.ml
trunk/Toss/Language/ParseArc.mli
trunk/Toss/Language/Rewriting.ml
trunk/Toss/Language/Rewriting.mli
trunk/Toss/Language/SyntaxDef.ml
trunk/Toss/Language/SyntaxDef.mli
trunk/Toss/Language/System.ml
trunk/Toss/Language/System.mli
trunk/Toss/Language/Term.ml
trunk/Toss/Language/Term.mli
trunk/Toss/Language/Type.ml
trunk/Toss/Language/Type.mli
trunk/Toss/Language/library/Makefile
trunk/Toss/Language/library/arithmetics.spg
trunk/Toss/Language/library/core.spg
trunk/Toss/Language/library/lists.spg
trunk/Toss/Language/speagram.ml
trunk/Toss/Language/testsuite/differentiation.log
trunk/Toss/Language/testsuite/differentiation.spg
trunk/Toss/Language/testsuite/short_checks.log
trunk/Toss/Language/testsuite/simple_algo.log
trunk/Toss/Language/testsuite/simple_algo.spg
trunk/Toss/examples/Bounce.toss
trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
trunk/Toss/examples/Rewriting-Example.toss
trunk/Toss/menhir_conf
Removed Paths:
-------------
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermParser.mly
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Language/Normalisation.ml
trunk/Toss/Language/Normalisation.mli
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/Arena.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -95,7 +95,7 @@
f ^ ": " ^ (string_of_float fs) ^ " -- " ^ (string_of_float fe) in
let par_str = if param_intervals = [] then " " else
", " ^ (String.concat ", " (List.map fpstr param_intervals)) in
- (rr) ^ ", " ^ fpstr ("t", t_interval) ^ par_str
+ (rr) ^ ", " ^ fpstr (":t", t_interval) ^ par_str
(* Print a move as string. *)
let move_str (lb, i) = Printf.sprintf "[%s -> %i]" (label_str lb) i
@@ -112,11 +112,11 @@
lb_rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
Format.fprintf f "[@,@[<1>%s" r;
if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
- Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
+ Format.fprintf f ",@ @[<1>:t@ :@ %F@ --@ %F@]" t_l t_r;
if params <> [] then
Format.fprintf f ",@ %a"
(Aux.fprint_sep_list "," (fun f (pn, (p_l, p_r)) ->
- Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
+ Format.fprintf f "@[<1>%s@ :@ %F@ --@ %F@]" pn p_l p_r)) params;
Format.fprintf f "@ ->@ %d@]@,]" target)) moves
) (in_p, in_m)
@@ -139,7 +139,7 @@
Format.fprintf f "@[<1>[%s@ %F@ ->@ %i@ emb@ %s]%s@]" rn t l m_s rt
else (
let p_s = String.concat ", "
- (List.map (fun (p, v) -> Printf.sprintf "%s: %F" p v) pl) in
+ (List.map (fun (p, v) -> Printf.sprintf "%s : %F" p v) pl) in
Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
)
@@ -303,7 +303,7 @@
let make_move_arena rname params target_loc =
let time_in, parameters_in =
- try Aux.pop_assoc "t" params
+ try Aux.pop_assoc ":t" params
with Not_found -> (cDEFAULT_TIMESTEP, cDEFAULT_TIMESTEP), params in
{ lb_rule = rname;
time_in = time_in;
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-05-19 21:37:16 UTC (rev 1710)
@@ -23,10 +23,13 @@
| ID { $1 }
| INT { string_of_int $1 }
+param:
+ | COLON ID { ":" ^ $2 }
+
move:
| OPENSQ RULE_SPEC? r = id_int COMMA?
params = separated_list (
- COMMA, separated_pair (ID, COLON,
+ COMMA, separated_pair (param, COLON,
separated_pair (FLOAT, INTERV, FLOAT)))
RARR LOC_MOD? target = INT CLOSESQ
{ make_move_arena r params target }
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -10,11 +10,9 @@
(* Specification of a continuous rewriting rule, as in modelling document. *)
type rule = {
- discrete : DiscreteRule.rule; (* The discrete part *)
- dynamics : ((string * string) * Term.term) list; (* Equation system calD *)
- update : ((string * string) * Formula.real_expr) list;
- (* Update equations calT *)
- (* Note that, for efficiency, the precondition is part of DiscreteRule. *)
+ discrete : DiscreteRule.rule; (* The discrete part, with precondition *)
+ dynamics : ((string * string) * Formula.real_expr) list; (* Equations calD *)
+ update : ((string * string) * Formula.real_expr) list; (* Update eqs calT*)
inv : Formula.formula; (* Invariant for the evolution *)
post : Formula.formula; (* Postcondition for application *)
}
@@ -90,10 +88,13 @@
(* Differential equations for a rule and a match, renamed to structure names. *)
let rule_dynamics struc params (r, m) =
- let (p_vars, t_vals) = params in
- let subst_params tm = List.hd (Term.subst_simp p_vars t_vals [tm]) in
+ let subst_params tm = FormulaSubst.subst_real params tm in
let d = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
- Term.subst_names (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
+ let subst_names subst ((v, e), rhs) =
+ let replace a = try List.assoc a subst with Not_found -> a in
+ ((v, replace e), FormulaSubst.subst_vars_expr subst rhs) in
+ let subst_names_l subst l = List.map (subst_names subst) l in
+ subst_names_l (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
(* Construct diff equation system and initial values for dynamics. *)
let construct_dynamics struc params rms =
@@ -101,12 +102,13 @@
let rec sum_common = function
| [] -> []
| (x, t) :: (y, s) :: rest when x = y ->
- sum_common ((x, Term.Plus (t, s)) :: rest)
+ sum_common ((x, Formula.Plus (t, s)) :: rest)
| eq :: rest-> eq :: (sum_common rest) in
let cmp ((f, x), t) ((g, y), s) =
let c = String.compare f g in if c <> 0 then c else
- let d = String.compare x y in if d <> 0 then d else Term.compare t s in
- let dyn = Term.subst_simp_eq [] [] (sum_common (List.sort cmp dyns)) in
+ let d = String.compare x y in if d <> 0 then d else
+ Formula.compare_re t s in
+ let dyn = sum_common (List.sort cmp dyns) in
(*LOG 1 "%s" (Term.eq_str dyn);*)
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
let init_vals = List.map (fun ((f, a), _) -> fval f a) dyn in
@@ -117,18 +119,18 @@
let rewrite_single_nocheck struc univs cur_time m r t params =
let univ_mts = Aux.concat_map
(fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
- let tparams =
- let p_vars, p_vals = List.split params in
- (p_vars, List.map (fun f -> Term.Const f) p_vals) in
+ let tparams = List.map (fun (v, f) -> (v, Formula.Const f)) params in
+ (*let p_vars, p_vals = List.split params in
+ (p_vars, List.map (fun f -> Term.Const f) p_vals) in *)
let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
- let dyn_c = Term.compile "t" dyn in
+ let dyn_c = Formula.compile ":t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
let step vals t0 =
(*LOG 1 "step at time %s" (Term.str t0);
LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));*)
- Term.rk4_step_c t0 diff_step dyn_c vals in
+ Formula.rk4_step t0 diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
@@ -218,7 +220,7 @@
(DiscreteRule.fprint_full print_compiled) r.discrete;
if has_dynamics r then
Format.fprintf f "@ @[<hv>dynamics@ %a@]"
- (Term.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
+ (Formula.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
if has_update r then
Format.fprintf f "@ @[<hv>update@ %a@]"
(Formula.fprint_eqs ~diff:false) (List.sort Pervasives.compare r.update);
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-05-19 21:37:16 UTC (rev 1710)
@@ -10,7 +10,7 @@
Function named foo on element i is, in a term, given by variable foo_i. *)
type rule = {
discrete : DiscreteRule.rule; (** The discrete part *)
- dynamics : Term.eq_sys; (** Equation system calD *)
+ dynamics : Formula.eq_sys; (** Equation system calD *)
update : Formula.eq_sys; (** Update equations calT *)
(** Note that, for efficiency, the precondition is part of DiscreteRule. *)
inv : Formula.formula; (** Invariant for the evolution *)
@@ -21,7 +21,7 @@
val make_rule :
(string * (string list * Formula.formula)) list -> (** defined rels *)
(DiscreteRule.rule) ->
- Term.eq_sys -> Formula.eq_sys ->
+ Formula.eq_sys -> Formula.eq_sys ->
?inv:Formula.formula ->
?post:Formula.formula -> unit -> rule
Modified: trunk/Toss/Arena/ContinuousRuleParser.mly
===================================================================
--- trunk/Toss/Arena/ContinuousRuleParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRuleParser.mly 2012-05-19 21:37:16 UTC (rev 1710)
@@ -25,7 +25,7 @@
%public rule_expr:
| discr = discrete_rule_expr
- dyn = loption (preceded (DYNAMICS, eq_sys))
+ dyn = loption (preceded (DYNAMICS, expr_eq_sys))
upd = loption (preceded (UPDATE, expr_eq_sys))
pre = option (preceded (PRE, precond_expr))
inv = option (preceded (INV, formula_expr))
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -43,12 +43,12 @@
let r = rule_of_str s signat [] "rule2" in
eq_str "2. update" s (str r);
- let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
+ let dyn_eq = ":f(a)' = 2. * :f(a) + :t; :f(b)' = :f(b)" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq in
let r = rule_of_str s signat [] "rule3" in
eq_str "3. dynamics" s (str r);
- let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
+ let dyn_eq = ":f(a)' = 2. * :f(a) + :t; :f(b)' = :f(b)" in
let upd_eq = " :f(c) = 2. * :f(a);\n :f(d) = :f(b)\n" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq in
let r = rule_of_str s signat [] "rule4" in
@@ -71,7 +71,7 @@
let r = rule_of_str s signat [] "rule2" in
assert_equal ~msg:"2. update" ~printer:(fun x->x) s (sprint r);
- let dyn_eq1 = " :f(a)' = 2. * :f(a) + t;"
+ let dyn_eq1 = " :f(a)' = 2. * :f(a) + :t;"
and dyn_eq2 = " :f(b)' = :f(b)" in
let dyn_eq = dyn_eq1 ^ dyn_eq2 in
let s = discr ^ "\n dynamics" ^ dyn_eq in
@@ -88,7 +88,7 @@
let dr =
"[| P { (a) } | ] -> [| P:1{}; Q { (b) } | ] emb P with [b<-a]" in
let signat = ["P", 1; "Q", 1] in
- let dyn_eq = ":x(a)' = :x(a) + t" in
+ let dyn_eq = ":x(a)' = :x(a) + :t" in
(* due to optimization (RHS renamed to match LHS), below it is
:x(a)=:x(a) rather than :x(b)=:x(a) *)
let upd_eq = ":x(a) = :x(a)" in
@@ -107,7 +107,7 @@
(fun () ->
let dr =
"[| P { (a) } | ] -> [| P:1{}; Q { (b) } | ] emb P with [b<-a]" in
- let dyn_eq = ":x(a)' = :x(a) + t" in
+ let dyn_eq = ":x(a)' = :x(a) + :t" in
(* due to optimization (RHS renamed to match LHS), below it is
:x(a)=:x(a) rather than :x(b)=:x(a) *)
let upd_eq = ":x(a) = :x(a)" in
@@ -153,11 +153,11 @@
(ContinuousRule.compare_diff r1 r2);
let upd_eq = " :f(a) = 2. * :f(a);\n :f(b) = :f(b)\n" in
- let dyn_eq = " :f(a)' = (2. * :f(a)) + t;\n :f(b)' = :f(b)" in
+ let dyn_eq = " :f(a)' = (2. * :f(a)) + :t;\n :f(b)' = :f(b)" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
" inv true post true" in
let r1 = rule_of_str s signat [] "rule4" in
- let dyn_eq = " :f(a)' = (3. * :f(a)) + t;\n :f(b)' = :f(b)" in
+ let dyn_eq = " :f(a)' = (3. * :f(a)) + :t;\n :f(b)' = :f(b)" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
" inv true post true" in
let r2 = rule_of_str s signat [] "rule5" in
Deleted: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/Term.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -1,261 +0,0 @@
-(* Represent terms and basic operations on them. *)
-
-(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
-
-let simp_symb = ref false
-
-type term =
- | Var of string
- | FVar of string * string
- | Const of float
- | Times of term * term
- | Plus of term * term
- | Div of term * term
-
-type eq_sys = ((string * string) * term) list
-
-(* Power function used in parser. *)
-let rec pow p n =
- if n = 0 then Const 1. else if n = 1 then p else Times (p, pow p (n-1))
-
-let compare t1 t2 = match (t1, t2) with
- | (Const x, Const y) -> if x > y then 1 else if y > x then -1 else 0
- | (Const _, _) -> -1
- | (_, Const _) -> 1
- | (Var x, Var y) -> String.compare x y
- | (Var _, _) -> -1
- | (_, Var _) -> 1
- | (FVar (f, x), FVar (g, y)) ->
- let c = String.compare f g in if c <> 0 then c else String.compare x y
- | (FVar _, _) -> -1
- | (_, FVar _) -> 1
- | _ -> Pervasives.compare t1 t2
-
-
-(* Variables (pure, not applied functions) in a term. *)
-let vars t =
- let rec vars_acc = function
- | Const _ | FVar _ -> []
- | Var x -> [x]
- | Plus (t, s) | Times (t, s) | Div (t, s) -> (vars_acc t) @ (vars_acc s) in
- Aux.unique_sorted (vars_acc t)
-
-
-(* ------------------------ PRINTING FUNCTION ------------------------------- *)
-
-(* Bracket-savvy precedences: + 0, - 1, * 2, / 3 *)
-let rec fprint ?(smt2=false) ?(prec=0) ppf = function
- | Var s -> Format.pp_print_string ppf s
- | FVar (f, a) -> if smt2 then Format.fprintf ppf "%s_of_%s" f a else
- Format.fprintf ppf ":%s(%s)" f a
- | Const n -> if smt2 then if n >= 0. then Format.fprintf ppf "%F" n else
- Format.fprintf ppf "(* minusone %F)" ((-1.) *. n)
- else Format.fprintf ppf "%F" n
- | Times (p, q) ->
- let lb, rb = if prec > 2 then "(", ")" else "", "" in
- if smt2 then Format.fprintf ppf "@[<1>(* %a@ %a)@]"
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:2) q
- else Format.fprintf ppf "@[<1>%s%a@ *@ %a%s@]" lb
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:2) q rb
- | Plus (p, Times (Const c, q)) when not smt2 && c = -1. ->
- let lb, rb = if prec > 0 then "(", ")" else "", "" in
- Format.fprintf ppf "@[<1>%s%a@ -@ %a%s@]" lb
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:1) q rb
- | Plus (p, Const c) when not smt2 && c < 0. ->
- let lb, rb = if prec > 0 then "(", ")" else "", "" in
- Format.fprintf ppf "@[<1>%s%a@ -@ %a%s@]" lb
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:1) (Const (-. c)) rb
- | Plus (p, q) ->
- let lb, rb = if prec > 0 then "(", ")" else "", "" in
- if smt2 then Format.fprintf ppf "@[<1>(+ %a@ %a)@]"
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:0) q
- else Format.fprintf ppf "@[<1>%s%a@ +@ %a%s@]" lb
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:0) q rb
- | Div (p, q) ->
- let lb, rb = if prec > 2 then "(", ")" else "", "" in
- if smt2 then Format.fprintf ppf "@[<1>(/ %a@ %a)@]"
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:3) q
- else Format.fprintf ppf "@[<1>%s%a@ /@ %a%s@]" lb
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:2) q rb
-
-let print r = AuxIO.print_of_fprint fprint r
-let sprint r = AuxIO.sprint_of_fprint fprint r
-let str = sprint
-let str_smt2 r = AuxIO.sprint_of_fprint (fprint ~smt2:true) r
-
-(* Print an equation system. *)
-let fprint_eqs ?(diff=true) ppf eqs =
- let sing ppf ((f, a), t) =
- let mid_str = if diff then "'" else "" in
- Format.fprintf ppf "@[<1>:%s(%s)%s@ =@ @[<1>%a@]@]"
- f a mid_str (fprint ~smt2:false ~prec:0) t in
- Format.fprintf ppf "@[<hv>%a@]" (Aux.fprint_sep_list ";" sing) eqs
-
-let print_eqs ?diff r = AuxIO.print_of_fprint (fprint_eqs ?diff) r
-let sprint_eqs ?diff r = AuxIO.sprint_of_fprint (fprint_eqs ?diff) r
-let eq_str = sprint_eqs
-
-
-(* -------------------- SIMPLIFICATION OF CONSTANTS ------------------------- *)
-
-(* Basic simplification, reduces constant terms to floats. *)
-let rec simp_const_only = function
- | Var s -> Var s
- | FVar (f, a) -> FVar (f, a)
- | Const n -> Const n
- | Times (p, q) -> (
- match (simp_const_only p, simp_const_only q) with
- | (Const n, Const m) -> Const (n *. m)
- | (t, s) -> Times (t, s)
- )
- | Plus (p, q) -> (
- match (simp_const_only p, simp_const_only q) with
- | (Const n, Const m) -> Const (n +. m)
- | (t, s) -> Plus (t, s)
- )
- | Div (p, q) ->
- match (simp_const_only p, simp_const_only q) with
- | (Const n, Const m) -> Const (n /. m)
- | (t, s)-> Div (t, s)
-
-let simp_const t =
- let rec to_poly = function
- | Var s -> Poly.Var ("V" ^ s)
- | FVar (f, a) -> Poly.Var ("F" ^ f ^ "#" ^ a)
- | Const n -> Poly.Const n
- | Times (p, q) -> Poly.Times (to_poly p, to_poly q)
- | Plus (p, q) -> Poly.Plus (to_poly p, to_poly q)
- | Div _ -> raise Not_found in
- let rec from_ord = function
- | OrderedPoly.Const _ -> failwith "num after non-num translation"
- | OrderedPoly.FConst num -> Const (num)
- | OrderedPoly.Poly (v, coefs) ->
- let w = if v.[0]= 'V' then Var (String.sub v 1 ((String.length v)-1)) else
- let i, l = String.index v '#', String.length v in
- FVar (String.sub v 1 (i-1), String.sub v (i+1) (l-i-1)) in
- let res = List.fold_left (fun acc (a, j) ->
- if j = 0 then Plus (acc, from_ord a) else
- match from_ord a with
- | Const n when n = 1. -> Plus (acc, pow w j)
- | ordt -> Plus (acc, Times (ordt, pow w j))
- ) (Const 0.) coefs in
- LOG 1 "res %s" (str res);
- let rec del_zero = function
- | Plus (Const n, t) when n = 0. -> t
- | Plus (t, s) -> Plus (del_zero t, s)
- | t -> t in
- del_zero res in
- match simp_const_only t with
- | Const n -> Const n
- | t -> if not !simp_symb then t else
- try let p = to_poly t in
- from_ord (Poly.make_ordered ~use_num:false [] p)
- with Not_found -> t
-
-(* Convert a term to float, fail on non-constant term. *)
-let term_val t = match simp_const t with
- | Const f -> f
- | t -> failwith ("getting value from non-constant term (" ^ str t ^ ")")
-
-
-(* Convert an equation system to float assciation list, fail on non-consts. *)
-let eq_vals eqs = List.map (fun (l, r) -> (l, term_val r)) eqs
-
-
-(* ----------------------- SIMPLE OPERATIONS ------------------------------- *)
-
-let add t1 t2 = simp_const (Plus (t1, t2))
-let ladd1 t tl = List.map (fun x -> add t x) tl
-let ladd tl1 tl2 = List.map2 add tl1 tl2
-
-let mul t1 t2 = simp_const (Times (t1, t2))
-let lmul1 t tl = List.map (fun x -> mul t x) tl
-let lmul tl1 tl2 = List.map2 mul tl1 tl2
-
-
-(* ------------------ SUBSTITUTION FOR VARIABLES --------------------------- *)
-
-(* Substitute terms for variables as in [dict] in the given term. *)
-let rec subst dict = function
- | Var s as t -> (try List.assoc s dict with Not_found -> t)
- | FVar _ | Const _ as t -> t
- | Plus (p, q) -> Plus (subst dict p, subst dict q)
- | Times (p, q) -> Times (subst dict p, subst dict q)
- | Div (p, q) -> Div (subst dict p, subst dict q)
-
-(* Substitute [vals] for [vars] in [terms] and simplify. *)
-let subst_simp vars vals terms =
- List.map (fun t -> simp_const (subst (List.combine vars vals) t)) terms
-
-
-(* Substitute terms for function variables as in [dict] in the given term. *)
-let rec subst_f dict = function
- | FVar (g, b) as t -> (try List.assoc (g, b) dict with Not_found -> t)
- | Var _ | Const _ as t -> t
- | Plus (p, q) -> Plus (subst_f dict p, subst_f dict q)
- | Times (p, q) -> Times (subst_f dict p, subst_f dict q)
- | Div (p, q) -> Div (subst_f dict p, subst_f dict q)
-
-(* Substitute [vals] for function [vars] in [terms] and simplify. *)
-let subst_simp_f vars vals terms =
- List.map (fun t -> simp_const (subst_f (List.combine vars vals) t)) terms
-
-(* Substitute variables and function vals in an equation system and simplify. *)
-let subst_simp_eq vlst flst eqs =
- let ((lhs, rhs), (vvars, vvals), (fvars, fvals)) =
- (List.split eqs, List.split vlst, List.split flst) in
- List.combine lhs (subst_simp vvars vvals (subst_simp_f fvars fvals rhs))
-
-(* Substitute function argument names in an equation system, left and right. *)
-let subst_names subst eqs =
- let (lhs, rhs) = List.split eqs in
- let replace a = try List.assoc a subst with Not_found -> a in
- let subst_vals = List.map (fun (f, a) -> FVar (f, replace a)) lhs in
- let new_rhs = subst_simp_f lhs subst_vals rhs in
- List.combine (List.map (fun (f, a) -> (f, replace a)) lhs) new_rhs
-
-let rec compile_term tv eqs = function
- | Const c -> (fun _ _ -> c)
- | Var v -> (fun t _ -> if v = tv then t else failwith "non time var compile")
- | FVar (f, x) -> (fun _ a -> a.(Aux.find_index (f, x) eqs))
- | Plus (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
- (fun t a -> (cp t a) +. (cq t a)))
- | Times (p, q) -> (let cp, cq= compile_term tv eqs p, compile_term tv eqs q in
- (fun t a -> (cp t a) *. (cq t a)))
- | Div (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
- (fun t a -> (cp t a) /. (cq t a)))
-
-let compile tv eqs =
- let lhs = fst (List.split eqs) in
- let ceqs = Array.of_list (List.map (fun (_,t)-> compile_term tv lhs t) eqs) in
- (fun t a -> Array.map (fun f -> f t a) ceqs)
-
-
-(* ---------------- RUNGE - KUTTA METHOD FOR TERM EQUATIONS ---------------- *)
-
-(* Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
- side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
-let rk4_step tvar tinit tstep eq_sys vals_init =
- let (vars, eq_terms) = List.split eq_sys in
- let tstepdiv6 = mul (Div (Const 1., Const 6.)) tstep in
- let htstep = mul (Const 0.5) tstep in
- let f_of t x = subst_simp_f vars x (subst_simp [tvar] [t] eq_terms) in
- let k1 = f_of tinit vals_init in
- let k2 = f_of (add tinit htstep) (ladd vals_init (lmul1 htstep k1)) in
- let k3 = f_of (add tinit htstep) (ladd vals_init (lmul1 htstep k2)) in
- let k4 = f_of (add tinit tstep) (ladd vals_init (lmul1 tstep k3)) in
- let (dk2, dk3) = (lmul1 (Const 2.) k2, lmul1 (Const 2.) k3) in
- ladd vals_init (lmul1 tstepdiv6 (ladd k1 (ladd dk2 (ladd dk3 k4))))
-
-let amul c arr = Array.map (fun x -> c *. x) arr
-let aadd a1 a2 = Aux.array_map2 (fun x1 x2 -> x1 +. x2) a1 a2
-
-let rk4_step_c tinit tstep eq_f vals_arr =
- let tstepdiv6 = tstep /. 6. in
- let htstep = tstep /. 2. in
- let k1 = eq_f tinit vals_arr in
- let k2 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k1)) in
- let k3 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k2)) in
- let k4 = eq_f (tinit +. tstep) (aadd vals_arr (amul tstep k3)) in
- let (dk2, dk3) = (amul (2.) k2, amul (2.) k3) in
- aadd vals_arr (amul tstepdiv6 (aadd k1 (aadd dk2 (aadd dk3 k4))))
Deleted: trunk/Toss/Arena/Term.mli
===================================================================
--- trunk/Toss/Arena/Term.mli 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/Term.mli 2012-05-19 21:37:16 UTC (rev 1710)
@@ -1,109 +0,0 @@
-(** Represent terms and their operations. *)
-
-(** {2 Basic Type Definition.} *)
-
-type term =
- | Var of string
- | FVar of string * string
- | Const of float
- | Times of term * term
- | Plus of term * term
- | Div of term * term
-
-type eq_sys = ((string * string) * term) list
-
-(** Compare two terms. *)
-val compare : term -> term -> int
-
-(** Variables (pure, not applied functions) in a term. *)
-val vars : term -> string list
-
-
-(** {2 Basic functions.} *)
-
-(*
-(** Whether to simplify symbolically or not. Set to false by default.
- It is nice for symbolic stuff, but slows down numerics. *)
-val simp_symb : bool ref
-
-(** Print a term as a string, maybe in the smt2 format. *)
-val str : term -> string
-val str_smt2 : term -> string
-
-val fprint : ?smt2:bool -> ?prec:int -> Format.formatter -> term -> unit
-val print : term -> unit
-val sprint : term -> string
-
-
-(** Print an equation system as a string. *)
-val eq_str : ?diff : bool -> eq_sys -> string
-*)
-val fprint_eqs : ?diff : bool -> Format.formatter -> eq_sys -> unit
-(*
-val print_eqs : ?diff : bool -> eq_sys -> unit
-val sprint_eqs : ?diff : bool -> eq_sys -> string
-
-
-(** Power function used in parser. *)
-val pow : term -> int -> term
-
-(** Basic simplification, reduces constant terms to floats. *)
-val simp_const : term -> term
-
-(** Convert a term to float, fail on non-constant term. *)
-val term_val : term -> float
-
-(** Convert an equation system to float assciation list, fail on non-consts. *)
-val eq_vals : eq_sys -> ((string * string) * float) list
-*)
-
-(** {2 Simple operations.} *)
-(*
-val add : term -> term -> term
-val ladd1 : term -> term list -> term list
-val ladd : term list -> term list -> term list
-
-val mul : term -> term -> term
-val lmul1 : term -> term list -> term list
-val lmul : term list -> term list -> term list
-
-
-(** {2 Substitution for variables.} *)
-
-(** Substitute terms for variables as in [dict] in the given term. *)
-val subst : (string * term) list -> term -> term
-
-*)
-(** Substitute [vals] for [vars] in [terms] and simplify. *)
-val subst_simp : string list -> term list -> term list -> term list
-
-(*
-(** Substitute terms for function variables as in [dict] in the given term. *)
-val subst_f : ((string * string) * term) list -> term -> term
-
-(** Substitute [vals] for function [vars] in [terms] and simplify. *)
-val subst_simp_f : (string * string) list -> term list -> term list -> term list
-*)
-
-(** Substitute variables and function vals in an eq. system and simplify. *)
-val subst_simp_eq : (string * term) list -> ((string * string) * term) list ->
- eq_sys -> eq_sys
-
-(** Substitute function argument names in an equation system, left and right. *)
-val subst_names : (string * string) list -> eq_sys -> eq_sys
-
-
-(** {2 Runge-Kutta Method for Term Equations} *)
-
-
-(** Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
- side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
-(*val rk4_step : string -> term -> term -> eq_sys -> term list -> term list*)
-
-
-(** Compile eq_sys to function. *)
-val compile : string -> eq_sys -> (float -> float array -> float array)
-
-(** RK4 with compiled system. *)
-val rk4_step_c : float -> float -> (float -> float array -> float array) ->
- float array -> float array
Deleted: trunk/Toss/Arena/TermParser.mly
===================================================================
--- trunk/Toss/Arena/TermParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/TermParser.mly 2012-05-19 21:37:16 UTC (rev 1710)
@@ -1,46 +0,0 @@
-/* Parser for Terms used in equations. */
-
-/* Tokens taken from Lexer.mll in directory above. */
-%{
- open Lexer
-%}
-
-%start parse_term parse_eqs
-%type <Term.term> parse_term term_expr
-%type <(string * string) * Term.term> eq_expr
-%type <Term.eq_sys> parse_eqs eq_sys
-
-
-%%
-
-
-%public term_expr:
- | INT { Term.Const (float_of_int $1) }
- | FLOAT { Term.Const ($1) }
- | ID { Term.Var ($1) }
- | MINUS ID { Term.Times (Term.Const (-1.), Term.Var ($2)) }
- | COLON ID OPEN ID CLOSE { Term.FVar ($2, $4) }
- | COLON ID OPEN INT CLOSE { Term.FVar ($2, string_of_int $4) }
- | term_expr FLOAT { Term.Plus ($1, Term.Const $2) }
- | term_expr INT { Term.Plus ($1, Term.Const (float_of_int $2)) }
- | term_expr PLUS term_expr { Term.Plus ($1, $3) }
- | term_expr MINUS term_expr { Term.Plus ($1, Term.Times(Term.Const(-1.), $3))}
- | term_expr TIMES term_expr { Term.Times ($1, $3) }
- | term_expr DIV term_expr { Term.Div ($1, $3) }
- | OPEN term_expr CLOSE { $2 }
-
-eq_expr: /* differential equations only */
- | COLON ID OPEN ID CLOSE APOSTROPHE EQ term_expr
- { (($2, $4), $8) }
- | COLON ID OPEN INT CLOSE APOSTROPHE EQ term_expr
- { (($2, string_of_int $4), $8) }
-
-%public eq_sys:
- | eq_expr { [$1] }
- | eq_expr SEMICOLON eq_sys { $1 :: $3 }
-
-parse_term:
- term_expr EOF { $1 }
-
-parse_eqs:
- eq_sys EOF { $1 };
Deleted: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-0...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-20 12:31:20
|
Revision: 1711
http://toss.svn.sourceforge.net/toss/?rev=1711&view=rev
Author: lukaszkaiser
Date: 2012-05-20 12:31:12 +0000 (Sun, 20 May 2012)
Log Message:
-----------
Restoring symbolic RK4 in FormulaOps now, moving things around.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/BuiltinLang.mli
trunk/Toss/Term/Makefile
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArc.mli
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/Rewriting.mli
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDef.mli
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/speagram.ml
Added Paths:
-----------
trunk/Toss/Term/
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/TermType.ml
trunk/Toss/Term/TermType.mli
Removed Paths:
-------------
trunk/Toss/Language/
trunk/Toss/Term/System.ml
trunk/Toss/Term/System.mli
trunk/Toss/Term/Type.ml
trunk/Toss/Term/Type.mli
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -109,7 +109,7 @@
let d = String.compare x y in if d <> 0 then d else
Formula.compare_re t s in
let dyn = sum_common (List.sort cmp dyns) in
- (*LOG 1 "%s" (Term.eq_str dyn);*)
+ LOG 1 "%s" (Formula.eq_str ~diff:true dyn);
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
let init_vals = List.map (fun ((f, a), _) -> fval f a) dyn in
(dyn, Array.of_list init_vals)
@@ -120,16 +120,13 @@
let univ_mts = Aux.concat_map
(fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
let tparams = List.map (fun (v, f) -> (v, Formula.Const f)) params in
- (*let p_vars, p_vals = List.split params in
- (p_vars, List.map (fun f -> Term.Const f) p_vals) in *)
let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
let dyn_c = Formula.compile ":t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
let step vals t0 =
- (*LOG 1 "step at time %s" (Term.str t0);
- LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));*)
+ LOG 1 "step at time %F" t0;
Formula.rk4_step t0 diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
@@ -161,9 +158,8 @@
(select_pos (List.tl ids) (List.map List.tl llst)) in
let all_vals_assoc =
select_pos (List.map fst dyn) (List.rev_map Array.to_list !all_vals) in
- (*LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
- (String.concat ", " (List.map (
- fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));*)
+ LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
+ (String.concat ", " (List.map string_of_float tl))) all_vals_assoc));
let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
let upd = List.map (fun (lhs, rhs) ->
(lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
@@ -210,10 +206,8 @@
(* -------------------------- PRINTING FUNCTION ----------------------------- *)
let has_dynamics r = r.dynamics <> []
- (* List.exists (fun (_, t) -> t <> Term.Const 0.) r.dynamics *)
let has_update r = r.update <> []
- (* List.exists (fun ((f, a), t) -> t <> Term.FVar (f,a)) r.update *)
let fprint_full print_compiled f r =
Format.fprintf f "@[<1>%a"
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Formula/FormulaOps.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -646,6 +646,36 @@
with Unsatisfiable -> Or []
+(* --- Symbolic Runge-Kutta --- *)
+
+(* Helper function: substitute for Fun in real_expr. *)
+let subst_fun_re subst = FormulaMap.map_real_expr
+ { FormulaMap.identity_map with FormulaMap.map_Fun = (fun f v ->
+ try List.assoc (f, var_str v) subst with Not_found -> Fun (f, v)) }
+
+(* Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
+ side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
+let rk4_step_symb tvar tinit tstep eq_sys vals_init =
+ let lmul1 t tl = List.map (fun x -> Times (t, x)) tl in
+ let ladd tl1 tl2 = List.map2 (fun t1 t2 -> Plus (t1, t2)) tl1 tl2 in
+ let subst_time t rhs =
+ List.map (fun eq -> FormulaSubst.subst_real [(tvar, t)] eq) rhs in
+ let subst_fvars vars vals rhs =
+ List.map (subst_fun_re (List.combine vars vals)) rhs in
+ let (vars, eq_terms) = List.split eq_sys in
+ let tstepdiv6 = Times (Const (1. /. 6.), tstep) in
+ let htstep = Times (Const 0.5, tstep) in
+ let f_of t x = subst_fvars vars x (subst_time t eq_terms) in
+ let k1 = f_of tinit vals_init in
+ let k2 = f_of (Plus (tinit, htstep)) (ladd vals_init (lmul1 htstep k1)) in
+ let k3 = f_of (Plus (tinit, htstep)) (ladd vals_init (lmul1 htstep k2)) in
+ let k4 = f_of (Plus (tinit, tstep)) (ladd vals_init (lmul1 tstep k3)) in
+ let (dk2, dk3) = (lmul1 (Const 2.) k2, lmul1 (Const 2.) k3) in
+ let res = ladd vals_init (lmul1 tstepdiv6 (ladd k1 (ladd dk2 (ladd dk3 k4))))
+ in List.map simplify_re res
+
+
+
(* -------------------------- TYPE NORMAL FORM ----------------------------- *)
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Formula/FormulaOps.mli 2012-05-20 12:31:12 UTC (rev 1711)
@@ -100,3 +100,7 @@
the graph are not unique or graph is empty. *)
val piecewise_linear : real_expr -> (float * float) list -> real_expr
+(** Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
+ side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep].*)
+val rk4_step_symb : string -> real_expr -> real_expr -> eq_sys ->
+ real_expr list -> real_expr list
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -306,6 +306,29 @@
"not (S(x, y) or P(x))";
);
+ "rk4 symbolic" >::
+ (fun () ->
+ let eqs_of_string s =
+ FormulaParser.parse_expr_eqs Lexer.lex (Lexing.from_string s) in
+ let tyson_eqs = eqs_of_string
+ (" :y(e1)' = 0.015 + -200. * :y(e1) * :y(e4); " ^
+ ":y(e2)' = -0.6 * :y(e2) + :k6 * :y(e5); " ^
+ ":y(e3)' = -100. * :y(e3) + :k6 * :y(e5) + 100. * :y(e4); " ^
+ ":y(e4)' = -100.*:y(e4) + 100.*:y(e3) + -200.*:y(e1) * :y(e4); " ^
+ ":y(e5)' = -:k6 * :y(e5) + 0.018 * :y(e6) + " ^
+ " :k4 * :y(e6) * :y(e5) * :y(e5); " ^
+ ":y(e6)' = -0.018 * :y(e6) + 200. * :y(e1) * :y(e4) + " ^
+ " -:k4 * :y(e6) * :y(e5) * :y(e5)") in
+ let c x = Formula.Const x in
+ let init = [c 0.; c 0.; c 1.; c 0.; c 0.; c 0.] in
+ let res = FormulaOps.rk4_step_symb "t" (c 0.) (c 0.005) tyson_eqs init in
+ let val_str vs = String.concat ", " (List.map Formula.real_str vs) in
+ assert_equal ~printer:(fun x->x)
+ ("6.6076722582e-05, 3.515625e-13 * :k6, 1. + 3.515625e-13 * :k6 + " ^
+ "-0.312500732409, 0.312491809132, 6.08239621818e-28 * :k4 + " ^
+ "-3.515625e-13 * :k6 + 2.02139802246e-10, " ^
+ "-6.08239621818e-28 * :k4 + 8.9230752782e-06") (val_str res);
+ );
]
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Language/BuiltinLang.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -1,6 +1,6 @@
(* Basic Built-in Language Syntax for Speagram. *)
-open Type;;
+open TermType;;
open SyntaxDef;;
(* ---------------- BASIC TYPES AND SYNTAX DEFS ----------------------- *)
Modified: trunk/Toss/Term/BuiltinLang.mli
===================================================================
--- trunk/Toss/Language/BuiltinLang.mli 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/BuiltinLang.mli 2012-05-20 12:31:12 UTC (rev 1711)
@@ -7,7 +7,7 @@
val bit_sd : syntax_def;;
val bit_name : string;;
-val bit_tp : Type.term_type;;
+val bit_tp : TermType.term_type;;
val bit_0_cons_sd : syntax_def;;
val bit_0_cons_name : string;;
val bit_1_cons_sd : syntax_def;;
@@ -15,18 +15,18 @@
val char_sd : syntax_def;;
val char_name : string;;
-val char_tp : Type.term_type;;
+val char_tp : TermType.term_type;;
val char_cons_sd : syntax_def;;
val char_cons_name : string;;
val term_type_sd : syntax_def;;
val term_type_name : string;;
-val term_type_tp : Type.term_type;;
+val term_type_tp : TermType.term_type;;
val list_sd : syntax_def;;
val list_name : string;;
-val list_tp : Type.term_type -> Type.term_type;;
-val list_tp_a : Type.term_type;;
+val list_tp : TermType.term_type -> TermType.term_type;;
+val list_tp_a : TermType.term_type;;
val list_nil_sd : syntax_def;;
val list_nil_name : string;;
val list_cons_sd : syntax_def;;
@@ -34,13 +34,13 @@
val string_sd : syntax_def;;
val string_name : string;;
-val string_tp : Type.term_type;;
+val string_tp : TermType.term_type;;
val string_cons_sd : syntax_def;;
val string_cons_name : string;;
val boolean_sd : syntax_def;;
val boolean_name : string;;
-val boolean_tp : Type.term_type;;
+val boolean_tp : TermType.term_type;;
val boolean_true_sd : syntax_def;;
val boolean_true_name : string;;
val boolean_false_sd : syntax_def;;
@@ -48,7 +48,7 @@
val ternary_truth_value_sd : syntax_def;;
val ternary_truth_value_name : string;;
-val ternary_truth_value_tp : Type.term_type;;
+val ternary_truth_value_tp : TermType.term_type;;
val ternary_true_sd : syntax_def;;
val ternary_true_name : string;;
val ternary_unknown_sd : syntax_def;;
@@ -65,21 +65,21 @@
val syntax_element_sd : syntax_def;;
val syntax_element_name : string;;
-val syntax_element_tp : Type.term_type;;
+val syntax_element_tp : TermType.term_type;;
val syntax_element_str_sd : syntax_def;;
val syntax_element_str_name : string;;
val syntax_element_tp_sd : syntax_def;;
val syntax_element_tp_name : string;;
val syntax_element_list_sd : syntax_def;;
val syntax_element_list_name : string;;
-val syntax_element_list_tp : Type.term_type;;
+val syntax_element_list_tp : TermType.term_type;;
val syntax_element_list_elem_sd : syntax_def;;
val syntax_element_list_elem_name : string;;
val syntax_element_list_cons_sd : syntax_def;;
val syntax_element_list_cons_name : string;;
val syntax_definition_sd : syntax_def;;
val syntax_definition_name : string;;
-val syntax_definition_tp : Type.term_type;;
+val syntax_definition_tp : TermType.term_type;;
val syntax_definition_type_sd : syntax_def;;
val syntax_definition_type_name : string;;
val syntax_definition_fun_sd : syntax_def;;
@@ -92,34 +92,34 @@
val term_sd : syntax_def;;
val term_name : string;;
-val term_tp : Type.term_type;;
+val term_tp : TermType.term_type;;
val term_var_cons_sd : syntax_def;;
val term_var_cons_name : string;;
val term_term_cons_sd : syntax_def;;
val term_term_cons_name : string;;
val rewrite_rule_sd : syntax_def;;
val rewrite_rule_name : string;;
-val rewrite_rule_tp : Type.term_type;;
+val rewrite_rule_tp : TermType.term_type;;
val rewrite_rule_cons_sd : syntax_def;;
val rewrite_rule_cons_name : string;;
val input_rewrite_rule_sd : syntax_def;;
val input_rewrite_rule_name : string;;
-val input_rewrite_rule_tp : Type.term_type;;
+val input_rewrite_rule_tp : TermType.term_type;;
val let_be_sd : syntax_def;;
val let_be_name : string;;
val priority_input_rewrite_rule_sd : syntax_def;;
val priority_input_rewrite_rule_name : string;;
-val priority_input_rewrite_rule_tp : Type.term_type;;
+val priority_input_rewrite_rule_tp : TermType.term_type;;
val let_major_be_sd : syntax_def;;
val let_major_be_name : string;;
val fun_definition_sd : syntax_def;;
val fun_definition_name : string;;
-val fun_definition_tp : Type.term_type;;
+val fun_definition_tp : TermType.term_type;;
val fun_definition_cons_sd : syntax_def;;
val fun_definition_cons_name : string;;
val type_definition_sd : syntax_def;;
val type_definition_name : string;;
-val type_definition_tp : Type.term_type;;
+val type_definition_tp : TermType.term_type;;
val type_of_sd_sd : syntax_def;;
val type_of_name : string;;
@@ -164,7 +164,7 @@
val outside_paths_sd : syntax_def;;
val outside_paths_name : string;;
-val outside_paths_tp : Type.term_type;;
+val outside_paths_tp : TermType.term_type;;
val path_library_sd : syntax_def;;
val path_library_name : string;;
@@ -174,20 +174,20 @@
val load_command_sd : syntax_def;;
val load_command_name : string;;
-val load_command_tp : Type.term_type;;
+val load_command_tp : TermType.term_type;;
val load_file_sd : syntax_def;;
val load_file_name : string;;
val sys_commands_sd : syntax_def;;
val sys_commands_name : string;;
-val sys_commands_tp : Type.term_type;;
+val sys_commands_tp : TermType.term_type;;
val close_context_sd : syntax_def;;
val close_context_name : string;;
val remove_command_sd : syntax_def;;
val remove_command_name : string;;
-val remove_command_tp : Type.term_type;;
+val remove_command_tp : TermType.term_type;;
val system_remove_sd : syntax_def;;
val system_remove_name : string;;
Modified: trunk/Toss/Term/Makefile
===================================================================
--- trunk/Toss/Language/Makefile 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/Makefile 2012-05-20 12:31:12 UTC (rev 1711)
@@ -1,30 +1,3 @@
-#
-# Speagram
-#
-# Copyright (c) 2003-2006, Speagram Authors.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions are met:
-#
-# * Redistributions of source code must retain the above copyright notice,
-# this list of conditions and the following disclaimer.
-# * Redistributions in binary form must reproduce the above copyright notice,
-# this list of conditions and the following disclaimer in the documentation
-# and/or other materials provided with the distribution.
-#
-# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
-# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
-# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-#
-
OCAMLTOP = ocaml -I +camlp4 camlp4o.cma str.cma
OCAMLCARGS = -I +camlp4 -pp "camlp4o" str.cma unix.cma
@@ -94,16 +67,16 @@
speagram: speagram.ml \
- Type.cmi Type.cmo Type.cmx \
+ TermType.cmi TermType.cmo TermType.cmx \
SyntaxDef.cmi SyntaxDef.cmo SyntaxDef.cmx \
BuiltinLang.cmi BuiltinLang.cmo BuiltinLang.cmx \
Term.cmi Term.cmo Term.cmx \
ParseArc.cmi ParseArc.cmo ParseArc.cmx \
Rewriting.cmi Rewriting.cmo Rewriting.cmx \
- System.cmi System.cmo System.cmx
+ TRS.cmi TRS.cmo TRS.cmx
$(USEDOCAML) \
- Type.cmx SyntaxDef.cmx BuiltinLang.cmx Term.cmx Rewriting.cmx \
- ParseArc.cmx System.cmx speagram.ml -o speagram
+ TermType.cmx SyntaxDef.cmx BuiltinLang.cmx Term.cmx Rewriting.cmx \
+ ParseArc.cmx TRS.cmx speagram.ml -o speagram
parsed: speagram
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Language/ParseArc.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/ParseArc.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -5,7 +5,7 @@
open List;;
open Str;;
-open Type;;
+open TermType;;
open SyntaxDef;;
open Term;;
(* * #load "Type.cmo";; *)
Modified: trunk/Toss/Term/ParseArc.mli
===================================================================
--- trunk/Toss/Language/ParseArc.mli 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/ParseArc.mli 2012-05-20 12:31:12 UTC (rev 1711)
@@ -1,6 +1,6 @@
(* Signature for Parser module. *)
-open Type;;
+open TermType;;
open SyntaxDef;;
type parser_elem =
Modified: trunk/Toss/Term/Rewriting.ml
===================================================================
--- trunk/Toss/Language/Rewriting.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/Rewriting.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -3,7 +3,7 @@
open List
open Str
-open Type
+open TermType
open SyntaxDef
open BuiltinLang
open Term
Modified: trunk/Toss/Term/Rewriting.mli
===================================================================
--- trunk/Toss/Language/Rewriting.mli 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/Rewriting.mli 2012-05-20 12:31:12 UTC (rev 1711)
@@ -3,11 +3,11 @@
type rrules_set;;
-val new_rules_set : (string * Type.term_type) list ->
+val new_rules_set : (string * TermType.term_type) list ->
(Term.term * Term.term) -> rrules_set;;
-val add_first_rule : (string * Type.term_type) list ->
+val add_first_rule : (string * TermType.term_type) list ->
rrules_set -> (Term.term * Term.term) -> rrules_set;;
-val add_last_rule : (string * Type.term_type) list ->
+val add_last_rule : (string * TermType.term_type) list ->
rrules_set -> (Term.term * Term.term) -> rrules_set;;
val rewrite : rrules_set -> Term.term -> Term.term;;
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Language/SyntaxDef.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -6,7 +6,7 @@
open Array;;
open Str;;
-open Type;;
+open TermType;;
(* The type of syntax elements. *)
Modified: trunk/Toss/Term/SyntaxDef.mli
===================================================================
--- trunk/Toss/Language/SyntaxDef.mli 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/SyntaxDef.mli 2012-05-20 12:31:12 UTC (rev 1711)
@@ -2,13 +2,13 @@
(* The type of syntax elements. *)
-type syntax_elem = Str of string | Tp of Type.term_type ;;
+type syntax_elem = Str of string | Tp of TermType.term_type ;;
(* The type of syntax definitions. *)
type syntax_def =
SDtype of syntax_elem list
- | SDfun of syntax_elem list * Type.term_type
- | SDvar of syntax_elem list * Type.term_type
+ | SDfun of syntax_elem list * TermType.term_type
+ | SDvar of syntax_elem list * TermType.term_type
;;
@@ -24,9 +24,9 @@
val syntax_elems_of_sd : syntax_def -> syntax_elem list;;
val name_of_sd : syntax_def -> string;;
val unique_name_of_sd : syntax_def -> string list -> string;;
-val type_of_sd : syntax_def -> Type.term_type;;
+val type_of_sd : syntax_def -> TermType.term_type;;
-val sd_type : syntax_def -> Type.term_type option;;
+val sd_type : syntax_def -> TermType.term_type option;;
val func_sd_of_sd : syntax_def -> syntax_def list;;
@@ -40,7 +40,7 @@
(* ---------- PRETTY PRINTING TYPES AND SYNTAX DEFS ---------------- *)
val split_sdef_name : string -> string option list;;
-val display_type : Type.term_type -> string;;
+val display_type : TermType.term_type -> string;;
val pretty_print_sd : syntax_def -> string;;
Deleted: trunk/Toss/Term/System.ml
===================================================================
--- trunk/Toss/Language/System.ml 2012-05-19 21:37:16 UTC (rev 1710)
+++ trunk/Toss/Term/System.ml 2012-05-20 12:31:12 UTC (rev 1711)
@@ -1,616 +0,0 @@
-(* The speagram system. *)
-
-
-open List;;
-open Str;;
-
-open Type;;
-open SyntaxDef;;
-open BuiltinLang;;
-open Term;;
-open Rewriting;;
-open ParseArc;;
-
-
-(* The system type which is a container for syntax definitions with
- names, type declarations, rewrite rules and list of all used names.
- For now it also has list of loaded file names to prevent double-loading.
-*)
-type spg_system = Sys of
- (syntax_def * string) list * (* Syntax definitions *)
- (string, term_type) Hashtbl.t * (* Types *)
- (term TermHashtbl.t * (* Memory used by normalisation *)
- (string, Rewriting.rrules_set) Hashtbl.t) * (* Rewriting rules *)
- string list * (* Used names *)
- (string * term_type) list (* Objects with types for chronologic access *)
-;;
-
-(* -------------- GETTING SYNTAX DEFINITIONS OUT ---------------- *)
-
-let syntax_defs_of_sys = function
- Sys (sdefs, _, _, _, _) -> sdefs;;
-
-
-(* --------------- UPDATING THE SYSTEM ------------------ *)
-
-(* Updating the system when a new syntax definition appears. *)
-let update_on_sd sd = function Sys (sdefs, tdeclsh, (_, rrs), names, ts) ->
- let n = unique_name_of_sd sd names in
- let new_mem = TermHashtbl.create 512 in
- let tds = match sd_type sd with
- None -> ts
- | Some t -> (Hashtbl.add tdeclsh n t; (n, t) :: ts) in
- let add_sdefs = map (fun sd -> (sd, n)) (sd :: (func_sd_of_sd sd)) in
- Sys (add_sdefs @ sdefs, tdeclsh, (new_mem, rrs), n :: names, tds)
-;;
-
-(* Updating the system when a new rewrite rule appears. *)
-let update_on_rr rr = function Sys (sdefs, tdecls, (_, rrs), names, ts) ->
- let new_mem = TermHashtbl.create 512 in
- let new_rrs = match rr with
- (Term (f, a), r) -> (
- try
- let rs = Hashtbl.find rrs f in
- (Hashtbl.replace rrs f (add_last_rule ts rs rr); rrs)
- with
- Not_found -> (Hashtbl.add rrs f (new_rules_set ts rr); rrs)
- )
- | _ -> rrs in
- Sys (sdefs, tdecls, (new_mem, new_rrs), names, ts)
-;;
-
-(* Updating the system when a new priority rewrite rule appears. *)
-let update_on_prio_rr rr =
- function Sys (sdefs, tdecls, (_, rrs), names, ts) ->
- let new_mem = TermHashtbl.create 512 in
- let new_rrs = match rr with
- (Term (f, a), r) -> (
- try
- let rs = Hashtbl.find rrs f in
- (Hashtbl.replace rrs f (add_first_rule ts rs rr); rrs)
- with
- Not_found -> (Hashtbl.add rrs f (new_rules_set ts rr); rrs)
- )
- | _ -> rrs in
- Sys (sdefs, tdecls, (new_mem, new_rrs), names, ts)
-;;
-
-(* Update system when close context term appears - remove variables. *)
-let update_on_close_context_term te (Sys (sdefs, th, rrs, nms, tl) as sys) =
- match te with
- Term (n, [||]) when n = close_context_name ->
- let nsdefs = filter (function (SDvar _, _) -> false | x -> true) sdefs in
- Sys (nsdefs, th, rrs, nms, tl)
- | _ -> sys
-;;
-
-(* Decoding paths and load commands. *)
-let decode_path kn_path = function
- Term (n, [|s|]) when n = path_library_name ->
- if (kn_path = "") || (kn_path.[String.length kn_path - 1] = '/') then
- kn_path ^ (decode_string s)
- else
- kn_path ^ "/" ^ (decode_string s)
- | Term (n, [|s|]) when n = path_file_name -> decode_string s
- | _ -> raise (DECODE "outside path")
-;;
-
-let decode_load_command kn_path = function
- Term (n, [|p|]) when n = load_file_name -> decode_path kn_path p
- | _ -> raise (DECODE "load command")
-;;
-
-
-(* Update system when a new term appears.
- It updates accordingly if the term is a syntax definition or rewrite rule,
- loads file or closes context and does nothing in the other cases.
-*)
-let update_on_coded_list te sys =
- let upd_sd l = fold_left (fun s sd -> update_on_sd sd s) sys l in
- let upd_rr l = fold_left (fun s rr -> update_on_rr rr s) sys l in
- let upd_prr l = fold_left (fun s rr -> update_on_prio_rr rr s) sys l in
- try upd_sd (decode_list decode_syntax_definition te) with
- DECODE _ ->
- try upd_rr (decode_list decode_input_rewrite_rule te) with
- DECODE _ ->
- try upd_prr (decode_list decode_priority_input_rewrite_rule te) with
- DECODE _ ->
- try upd_rr (decode_list decode_rewrite_rule te) with
- DECODE _ ->
- update_on_close_context_term te sys
-;;
-
-
-let rec update_on_load_file k file sys bs =
- try
- let in_file = open_in (file ^ ".spg.parsed") in
- let rec process s =
- try
- let line = input_line in_file in
- if line = "" then process s else
- (
- (* print_endline ("parsing: " ^ line); *)
- let te = term_of_string line in
- s := update_on_term k te !s bs;
- process s
- )
- with
- End_of_file -> !s in
- process (ref bs)
- with
- Sys_error s -> raise (Sys_error s)
-and update_on_term k te sys bs =
- try update_on_sd (decode_syntax_definition te) sys with
- DECODE _ ->
- try update_on_rr (decode_input_rewrite_rule te) sys with
- DECODE _ ->
- try update_on_prio_rr (decode_priority_input_rewrite_rule te) sys with
- DECODE _ ->
- try update_on_rr (decode_rewrite_rule te) sys with
- DECODE _ ->
- try update_on_load_file k (decode_load_command k te) sys bs with
- DECODE _ ->
- update_on_coded_list te sys
-;;
-
-
-(* ------------ NORMALISATION WITH META FUNCS USING SYSTEM ------------- *)
-
-(* Getting elements from the system (recently added comes first). *)
-let get_elems_of_sys c (Sys (_, _, _, _, tdecls)) =
- let elem_of_td (n, ty) = if n.[0] = c then (
- match ty with
- Fun_type (a, r) -> [(n, Array.to_list a, r)]
- | _ -> [(n, [], ty)]
- )
- else [] in
- flatten (map elem_of_td tdecls)
-;;
-
-let get_funs_of_sys = get_elems_of_sys 'F';;
-
-let get_types_of_sys (Sys (sdefs, _, _, _, _)) =
- let classes = filter (function (SDtype _, _) -> true | _ -> false) sdefs in
- let get_tys sels = filter (function Tp _ -> true | _ -> false) sels in
- let td_of_sd (sd, n) = (n, length (get_tys (syntax_elems_of_sd sd))) in
- map td_of_sd classes
-;;
-
-
-(* Identifying the special functions. *)
-let is_special_fun s = (
- (s = code_as_term_name) || (s = get_type_definitions_name) ||
- (s = get_fun_definitions_name) || (s = eq_bool_name))
-;;
-
-let rec has_vars = function
- Term (_, args) -> List.exists has_vars (Array.to_list args)
- | Var _ -> true
-;;
-
-(* Rewriting special functions given a system. *)
-let rec rewrite_special_funs sys = function
- Term (n, [|a|]) when n = code_as_term_name ->
- code_term_incr_vars a
- | Term (n, [|a; b|]) when n = eq_bool_name ->
- if a = b then (code_bool true) else
- if has_vars a || has_vars b then (Term (n, [|a; b|]))
- else code_bool false
- | Term (n, [||]) when n = get_type_definitions_name ->
- code_list code_type_definition (get_types_of_sys sys)
- | Term (n, [||]) when n = get_fun_definitions_name ->
- code_list code_fun_definition (get_funs_of_sys sys)
- | te -> te
-and (* Main normalisation function. *)
- normalise_with_sys (Sys (_, _, (mem, rrs), _, _) as sys) te =
- normalise mem rrs is_special_fun (rewrite_special_funs sys) te
-;;
-
-
-(* ----------------- DISAMBIGUATION FOR FULL PARSING ------------------- *)
-
-(* Parse a string using the given system. *)
-let parse_with_sys (Sys (sdefs, tdecls, _, _, _)) str =
- let elems = parse tdecls sdefs (split_input_string str) in
- let type_of_pe = function Token _ -> [] | Typed_term (_, te) -> [te] in
- flatten (map type_of_pe elems)
-;;
-
-
-
-let is_better sys te1 te2 =
- let query = Term (preferred_to_name, [|code_term te1; code_term te2|]) in
- match normalise_with_sys sys query with
- Term (n, [||]) when n = ternary_true_name -> 1
- | Term (n, [||]) when n = ternary_false_name -> -1
- | te -> 0
-;;
-
-let is_best sys ht terms te =
- let cmp a b =
- if a = b then 0 else try Hashtbl.find ht (a, b) with
- Not_found ->
- let res = is_better sys a b in
- (Hashtbl.add ht (a, b) res; Hashtbl.add ht (b, a) (-1 * res); res) in
- let norm_te = normalise_brackets te in
- for_all (fun x -> (cmp x norm_te) <= 0) (map normalise_brackets terms)
-;;
-
-let rec remove_bracket_duplicates = function
- [] -> []
- | t :: ts -> if exists (fun x ->
- (normalise_brackets x = normalise_brackets t) && (not (x = t))) ts then
- remove_bracket_duplicates ts
- else
- t :: (remove_bracket_duplicates ts)
-;;
-
-let filter_best_terms sys = function
- [] -> []
- | [t] -> [t]
- | [u; v] ->
- let nu = normalise_brackets u in
- let nv = normalise_brackets v in
- if nu = nv then [u] else let cmp = is_better sys nu nv in
- if cmp = 1 then [u] else if cmp = -1 then [v] else [u; v]
- | t :: tes ->
- (* we rehash terms here because often first or first-parsed is best *)
- let terms = t :: (rev tes) in
- let best = filter (is_best sys (Hashtbl.create 64) terms) terms in
- remove_bracket_duplicates best
-;;
-
-let terms_info verb ts =
- let disp t = (display_term t) ^
- " [" ^ (term_to_string (normalise_brackets t)) ^ "]" in
- if (length ts > 1) then
- "Disambiguate " ^ (string_of_int (length ts)) ^ " terms\n" ^
- (String.concat "\n" (map disp ts)) ^ "\n"
- else
- ""
-;;
-
-let parse_disambiguate_with_sys verbose sys str =
- let terms = parse_with_sys sys str in
- let fails_by_match t2 t1 =
- (matches (ref []) (t1, t2)) && (not (matches (ref []) (t2, t1))) in
- let rec filter_by_match ok = function
- [] -> rev ok
- | t :: ts ->
- if (exists (fails_by_match t) ts) || (exists (fails_by_match t) ok) then
- filter_by_match ok ts
- else
- filter_by_match (t :: ok) ts in
- let prefiltered_terms = filter_by_match [] terms in
- if verbose then
- (print_string (terms_info verbose prefiltered_terms); flush stdout;
- filter_best_terms sys prefiltered_terms)
- else
- filter_best_terms sys prefiltered_terms
-;;
-
-
-(* -------------- THE MAIN PROCESSING FUNCTION ---------- *)
-
-let is_some = function Some _ -> true | None ...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-20 21:12:06
|
Revision: 1712
http://toss.svn.sourceforge.net/toss/?rev=1712&view=rev
Author: lukaszkaiser
Date: 2012-05-20 21:11:56 +0000 (Sun, 20 May 2012)
Log Message:
-----------
Term operations, rewriting and parsing adapted to current build system.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Makefile
trunk/Toss/Server/Tests.ml
trunk/Toss/Term/Makefile
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermType.ml
trunk/Toss/Term/TermType.mli
trunk/Toss/Term/tests/differentiation.log
trunk/Toss/Term/tests/english.log
trunk/Toss/Term/tests/entanglement.log
trunk/Toss/Term/tests/fo_formula.log
trunk/Toss/Term/tests/sasha_basic.log
trunk/Toss/Term/tests/short_checks.log
trunk/Toss/Term/tests/simple_algo.log
trunk/Toss/Toss.odocl
Added Paths:
-----------
trunk/Toss/Term/TRSTest.ml
trunk/Toss/Term/lib/
trunk/Toss/Term/tests/
Removed Paths:
-------------
trunk/Toss/Term/lib/Makefile
trunk/Toss/Term/library/
trunk/Toss/Term/speagram.ml
trunk/Toss/Term/tests/Makefile
trunk/Toss/Term/testsuite/
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Formula/Aux.ml 2012-05-20 21:11:56 UTC (rev 1712)
@@ -78,6 +78,30 @@
let split_newlines s = split_charprop (fun c -> c = '\n' || c = '\r') s
+
+type split_result =
+ | Text of string
+ | Delim of string
+
+(* Look for characters from the list [l] after [c], split on such pairs. *)
+let split_chars_after c l s =
+ let split_c = split_charprop ~keep_split_chars:true (fun x -> x = c) s in
+ let c_str = String.make 1 c in
+ let rec process acc = function
+ | [] -> acc | [x] -> (Text x) :: acc
+ | delim :: str :: rest when
+ delim = c_str && String.length str > 0 && List.mem str.[0] l ->
+ let d = String.make 2 c in
+ d.[1] <- str.[0];
+ let txt = String.sub str 1 ((String.length str) - 1) in
+ process ((Text txt) :: (Delim d) :: acc) rest
+ | s1 :: (delim :: str :: rest as x) when
+ delim = c_str && String.length str > 0 && List.mem str.[0] l ->
+ process ((Text s1) :: acc) x
+ | s1 :: str :: rest -> process acc ((s1 ^ str) :: rest) in
+ List.rev (process [] split_c)
+
+
let split_empty_lines s = (* Split a string on empty lines. *)
let lstr accs = if accs = "" then [] else [accs] in
let rec concat_nonempty accs = function
@@ -112,14 +136,17 @@
if pat = "" then failwith "str_subst_once: empty pattern" else
try
let i, l, pl = str_index pat s, String.length s, String.length pat in
- ((String.sub s 0 i) ^ res ^ (String.sub s (i+pl) (l-i-pl)), true)
- with Not_found -> (s, false)
+ ((String.sub s 0 i) ^ res ^ (String.sub s (i+pl) (l-i-pl)), i)
+ with Not_found -> (s, -1)
let str_subst_once pat res s = fst (str_subst_once_report pat res s)
let rec str_subst_all pat res s =
- let (new_s, didsth) = str_subst_once_report pat res s in
- if didsth then str_subst_all pat res new_s else s
+ let (new_s, index) = str_subst_once_report pat res s in
+ if index < 0 then s else
+ let sl, rl = String.length new_s, String.length res in
+ (String.sub new_s 0 (index+rl)) ^
+ (str_subst_all pat res (String.sub new_s (index+rl) (sl-index-rl)))
let str_subst_once_from_to_report sfrom sto res s =
if sfrom = "" || sto = "" then failwith "str_subst_once_from_to: empty" else
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Formula/Aux.mli 2012-05-20 21:11:56 UTC (rev 1712)
@@ -359,7 +359,15 @@
(** Split a string on characters satisfying [f]. *)
val split_charprop : ?keep_split_chars: bool ->
(char -> bool) -> string -> string list
-
+
+(** Type for some split results. *)
+type split_result =
+ | Text of string
+ | Delim of string
+
+(** Look for characters from the list [l] after [c], split on such pairs. **)
+val split_chars_after : char -> char list -> string -> split_result list
+
(** Split a string on spaces. *)
val split_spaces : string -> string list
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Makefile 2012-05-20 21:11:56 UTC (rev 1712)
@@ -116,14 +116,15 @@
FormulaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll
SolverINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
SolverINCRealQuantElimINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
-ArenaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver
-PlayINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
-LearnINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
-GGPINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play
-ServerINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn
-ClientINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
+TermINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
+ArenaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term
+PlayINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena
+LearnINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena
+GGPINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play
+ServerINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play,GGP,Learn
+ClientINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play,GGP,Learn,Server
-.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
+.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play,GGP,Learn,Server
%.native: %.ml $(EXTDEPS)
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Server/Tests.ml 2012-05-20 21:11:56 UTC (rev 1712)
@@ -36,6 +36,10 @@
"ArenaTest", [ArenaTest.tests];
]
+let term_tests = "Term", [
+ "TRSTest", [TRSTest.tests; TRSTest.bigtests];
+]
+
let play_tests = "Play", [
"HeuristicTest", [HeuristicTest.tests; HeuristicTest.bigtests];
"GameTreeTest", [GameTreeTest.tests];
@@ -62,6 +66,7 @@
formula_tests;
solver_tests;
arena_tests;
+ term_tests;
play_tests;
ggp_tests;
learn_tests;
Modified: trunk/Toss/Term/Makefile
===================================================================
--- trunk/Toss/Term/Makefile 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Term/Makefile 2012-05-20 21:11:56 UTC (rev 1712)
@@ -1,101 +1,16 @@
-OCAMLTOP = ocaml -I +camlp4 camlp4o.cma str.cma
+all: parsed
-OCAMLCARGS = -I +camlp4 -pp "camlp4o" str.cma unix.cma
-OCAMLC = ocamlc $(OCAMLCARGS)
+RUN = ../TRSTest.native -c -f -l "../Term/lib"
-OCAMLOPTARGS = -I +camlp4 -pp "camlp4o" str.cmxa unix.cmxa
-OCAMLOPT = ocamlopt $(OCAMLOPTARGS)
+parsed:
+ make -C .. ./Term/TRSTest.native
+ $(RUN) -o lib/core.spg.parsed < lib/core.spg > /dev/null
+ $(RUN) -o lib/arithmetics.spg.parsed < lib/arithmetics.spg > /dev/null
+ $(RUN) -o lib/lists.spg.parsed < lib/lists.spg > /dev/null
+ $(RUN) -o lib/basic.spg.parsed < lib/basic.spg > /dev/null
+ $(RUN) -o lib/sasha.spg.parsed < lib/sasha.spg > /dev/null
-
-LATEX = latex
-DVIPS = dvips
-PS2PDF = ps2pdf
-
-DIFF = diff
-SED = sed
-Q = @
-
-
-############################################################
-# VARIABLES
-############################################################
-
-DISTFILES = speagram speagram.exe
-
-SRCFILES = Makefile *.ml *.mli
-
-
-############################################################
-# TARGETS
-############################################################
-
-
-all: speagram
-
-%.cmi: %.mli
- $(OCAMLC) -c $(addsuffix .mli, $(basename $<))
-
-%.cmo: %.ml %.mli
- $(OCAMLC) -c $(addsuffix .ml, $(basename $@))
-
-%.cmx: %.ml %.mli
- $(OCAMLOPT) -c $(addsuffix .ml, $(basename $@))
-
-USEDOCAML = $(OCAMLOPT)
-
-#
-# Use the definitions below to compile with MetaOCaml.
-# You need to adjust MetaOCaml path in ../config.mak first.
-#
-# %.cmi: %.mli
-# $(METAOCAMLC) -c $(addsuffix .mli, $(basename $<)) -o $@
-#
-# %.cmo: %.ml %.mli
-# mv $(addsuffix .ml, $(basename $@)) tmp.ml
-# $(CAMLP4) tmp.ml > $(addsuffix .ml, $(basename $@))
-# $(METAOCAMLC) -c $(addsuffix .ml, $(basename $@))
-# mv tmp.ml $(addsuffix .ml, $(basename $@))
-#
-# %.cmx: %.ml %.mli
-# mv $(addsuffix .ml, $(basename $@)) tmp.ml
-# $(CAMLP4) tmp.ml > $(addsuffix .ml, $(basename $@))
-# $(METAOCAMLOPT) -c $(addsuffix .ml, $(basename $@))
-# mv tmp.ml $(addsuffix .ml, $(basename $@))
-#
-# USEDOCAML = $(METAOCAMLOPT)
-#
-
-
-speagram: speagram.ml \
- TermType.cmi TermType.cmo TermType.cmx \
- SyntaxDef.cmi SyntaxDef.cmo SyntaxDef.cmx \
- BuiltinLang.cmi BuiltinLang.cmo BuiltinLang.cmx \
- Term.cmi Term.cmo Term.cmx \
- ParseArc.cmi ParseArc.cmo ParseArc.cmx \
- Rewriting.cmi Rewriting.cmo Rewriting.cmx \
- TRS.cmi TRS.cmo TRS.cmx
- $(USEDOCAML) \
- TermType.cmx SyntaxDef.cmx BuiltinLang.cmx Term.cmx Rewriting.cmx \
- ParseArc.cmx TRS.cmx speagram.ml -o speagram
-
-
-parsed: speagram
- $(MAKE) -C library
-
.PHONY:
-
-check: speagram
- $(MAKE) -C testsuite check
-
-
-tarball:
- cp $(DISTFILES) $(top_srcdir)/$(DIR)
- cp $(SRCFILES) $(top_srcdir)/$(DIR)/src
-
-
clean:
- rm -rf *.cmi *.cmo *.cmx *.o *~ speagram temptemp.html
- $(MAKE) -C library clean
- $(MAKE) -C testsuite clean
-
+ rm -rf *.cmi *.cmo *.cmx *.o *~ lib/*.parsed
Modified: trunk/Toss/Term/ParseArc.ml
===================================================================
--- trunk/Toss/Term/ParseArc.ml 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Term/ParseArc.ml 2012-05-20 21:11:56 UTC (rev 1712)
@@ -3,15 +3,10 @@
open List;;
-open Str;;
open TermType;;
open SyntaxDef;;
open Term;;
-(* * #load "Type.cmo";; *)
-(* * #load "SyntaxDef.cmo";; *)
-(* * #load "BuiltinLang.cmo";; *)
-(* * #load "Term.cmo";; *)
(* The type of elements created during parsing.
@@ -298,31 +293,47 @@
(* Splitting the whole input string. *)
let split_input_string str =
- let split_space s = split (regexp "[ \t\n\r]+") s in
+ let split_space s = Aux.split_spaces s in
let split_all_nonstr s = flatten (map split_word (split_space s)) in
- let string_regexp = regexp "[^&]\"\\|^\"" in
+ (*let string_regexp = Str.regexp "[^&]\"\\|^\"" in
let rec split_delims = function
- [] -> []
- | Text s :: Delim d :: rest when String.length d = 2 && d.[1] = '\"' ->
- Text (s ^ (String.make 1 (d.[0]))) :: Delim "\"" :: split_delims rest
- | Delim d :: rest when String.length d = 2 && d.[1] = '\"' ->
- Text (String.make 1 (d.[0])) :: Delim "\"" :: split_delims rest
- | Text s :: rest -> Text s :: split_delims rest
- | Delim "\"" :: rest -> Delim "\"" :: split_delims rest
+ | [] -> []
+ | Str.Text s :: Str.Delim d :: rest when String.length d =2 && d.[1]='\"' ->
+ Aux.Text (s ^ (String.make 1 (d.[0]))) :: Aux.Delim "\"" ::
+ split_delims rest
+ | Str.Delim d :: rest when String.length d = 2 && d.[1] = '\"' ->
+ Aux.Text (String.make 1 (d.[0])) :: Aux.Delim "\"" :: split_delims rest
+ | Str.Text s :: rest -> Aux.Text s :: split_delims rest
+ | Str.Delim "\"" :: rest -> Aux.Delim "\"" :: split_delims rest
| _ -> failwith "unrecognized delimiter which can not be here!" in
+ let split_delims_str = split_delims (Str.full_split string_regexp str) in*)
+ let split_delims_str =
+ let l = Aux.split_charprop ~keep_split_chars:true (fun c->c='"') str in
+ let res = List.map (fun s -> if String.length s = 1 && s.[0] = '"' then
+ Aux.Delim s else Aux.Text s) l in
+ let last_is_and s = s.[String.length s - 1] = '&' in
+ let all_but_last s = String.sub s 0 (String.length s - 1) in
+ let rec escape_ands = function
+ | [] -> []
+ | Aux.Text s1 :: Aux.Delim _ :: Aux.Text s2 :: rest when last_is_and s1 ->
+ escape_ands ( (Aux.Text ((all_but_last s1) ^ "\"" ^ s2)) :: rest )
+ | x :: rest -> x :: (escape_ands rest) in
+ escape_ands res in
let clear_escaped s =
- let s_1 = global_replace (regexp "&\\.") "." s in
- let s_2 = global_replace (regexp "&;") ";" s_1 in
- global_replace (regexp "&\"") "\"" s_2 in
+ let s_1 = Aux.str_subst_all "&\\." "." s in
+ let s_2 = Aux.str_subst_all "&;" ";" s_1 in
+ Aux.str_subst_all "&\"" "\"" s_2 in
let rec split_string_all = function
- [] -> []
- | Delim "\"" :: Delim "\"" :: rest ->
+ | [] -> []
+ | Aux.Delim "\"" :: Aux.Delim "\"" :: rest ->
"\"" :: "\"" :: split_string_all (rest)
- | Delim "\"" :: Text s :: Delim "\"" :: rest ->
+ | Aux.Delim "\"" :: Aux.Text s :: Aux.Delim "\"" :: rest ->
"\"" :: (clear_escaped s) :: "\"" :: split_string_all rest
- | Text s :: rest -> (split_all_nonstr s) @ split_string_all rest
- | Delim d :: rest -> d :: split_string_all rest in
- first_down (split_string_all (split_delims (full_split string_regexp str)))
+ | Aux.Text s :: rest -> (split_all_nonstr s) @ split_string_all rest
+ | Aux.Delim d :: rest -> d :: split_string_all rest in
+ let res = first_down (split_string_all split_delims_str) in
+ (* print_endline (String.concat " " res); *)
+ res
;;
Modified: trunk/Toss/Term/SyntaxDef.ml
===================================================================
--- trunk/Toss/Term/SyntaxDef.ml 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Term/SyntaxDef.ml 2012-05-20 21:11:56 UTC (rev 1712)
@@ -4,7 +4,7 @@
open Array;;
-open Str;;
+open Aux;;
open TermType;;
@@ -41,8 +41,8 @@
| SDvar (se, _) -> se
;;
-let double_slash s = global_replace (regexp "\\") "\\\\\\\\" s;;
-let slash_underscore s = global_replace (regexp "_") "\\_" s;;
+let double_slash s = Aux.str_subst_all "\\" "\\\\" s;;
+let slash_underscore s = Aux.str_subst_all "_" "\\_" s;;
let name_of_se_list sel =
let n s = slash_underscore (double_slash s) in
@@ -50,27 +50,28 @@
;;
let clean_name name =
- let split_name = full_split (regexp "[(),`@']\\|\\[\\|\\]") name in
+ let split_name = Aux.split_charprop ~keep_split_chars:true (fun c ->
+ (c = '(') || (c = ')') || (c = '[') || (c = ']') || (c = ',') ||
+ (c = '`') || (c = ''') || (c = '@') ) name in
let subst = function
- Text s -> s
- | Delim "(" -> "\\lb"
- | Delim ")" -> "\\rb"
- | Delim "[" -> "\\ls"
- | Delim "]" -> "\\rs"
- | Delim "," -> "\\cm"
- | Delim "`" -> "\\qt"
- | Delim "'" -> "\\ap"
- | Delim "@" -> "\\at"
- | Delim s -> failwith ("unexpected delimiter " ^ s) in
+ | "(" -> "\\lb"
+ | ")" -> "\\rb"
+ | "[" -> "\\ls"
+ | "]" -> "\\rs"
+ | "," -> "\\cm"
+ | "`" -> "\\qt"
+ | "'" -> "\\ap"
+ | "@" -> "\\at"
+ | s -> s in
String.concat "" (List.map subst split_name)
;;
let name_of_sd sd =
let name = clean_name (name_of_se_list (syntax_elems_of_sd sd)) in
match sd with
- SDtype se -> "T" ^ name
- | SDfun (se, _) -> "F" ^ name
- | SDvar (se, _) -> "V" ^ name
+ | SDtype se -> "T" ^ name
+ | SDfun (se, _) -> "F" ^ name
+ | SDvar (se, _) -> "V" ^ name
;;
let unique_name name used =
@@ -154,7 +155,7 @@
if n.[i-1] = '\\' then 1 + prefixing_slashes n (i-1) else 0 in
let end_slashes n = prefixing_slashes n (String.length n) in
match split with
- [] -> []
+ | [] -> []
| [x] -> [x]
| Delim s :: xs -> Delim s :: (correct_split xs)
| Text s1 :: (Text s2 :: _ as xs) -> Text s1 :: (correct_split xs)
@@ -168,30 +169,28 @@
(* Adds forbidden characters that were removed. *)
let unclean_name name =
- let delim = "\\\\lb\\|\\\\rb\\|\\\\ls\\|\\\\rs\\|\\\\cm\\|" ^
- "\\\\qt\\|\\\\ap\\|\\\\at" in
- let split_name = full_split (regexp delim) name in
- let subst = function
- Text s -> s
- | Delim "\\lb" -> "("
- | Delim "\\rb" -> ")"
- | Delim "\\ls" -> "["
- | Delim "\\rs" -> "]"
- | Delim "\\cm" -> ","
- | Delim "\\qt" -> "`"
- | Delim "\\ap" -> "'"
- | Delim "\\at" -> "@"
- | Delim s -> failwith ("unexpected delimiter " ^ s) in
- String.concat "" (List.map subst (correct_split split_name))
+ Aux.str_subst_all "\\lb" "(" (
+ Aux.str_subst_all "\\rb" ")" (
+ Aux.str_subst_all "\\ls" "[" (
+ Aux.str_subst_all "\\rs" "]" (
+ Aux.str_subst_all "\\cm" "," (
+ Aux.str_subst_all "\\qt" "`" (
+ Aux.str_subst_all "\\ap" "'" (
+ Aux.str_subst_all "\\at" "@" name
+ )))))))
;;
(* Splits name generated by syntax definition on underscores. *)
let split_sd_name_underscore name =
let uncleaned_name = unclean_name (basic_name_of_sd_name name) in
- let split_name = full_split (regexp "_") uncleaned_name in
+ let split_name =
+ let l = Aux.split_charprop ~keep_split_chars:true (fun c -> c = '_')
+ uncleaned_name in
+ List.map (fun s -> if String.length s = 1 && s.[0] = '_' then
+ Aux.Delim s else Aux.Text s) l in
let corrected_split = correct_split split_name in
let rec combine_underscore = function
- Text "\\" :: Text "_" :: rest ->
+ | Text "\\" :: Text "_" :: rest ->
combine_underscore (Text "\\_" :: rest)
| Text s1 :: Text "_" :: Text s2 :: rest ->
combine_underscore (Text (s1 ^ "_" ^ s2) :: rest)
@@ -200,8 +199,8 @@
combine_underscore (corrected_split)
;;
-let undouble_slash s = global_replace (regexp "\\\\\\\\") "\\\\" s;;
-let unslash_underscore s = global_replace (regexp "\\\\_") "_" s;;
+let undouble_slash s = Aux.str_subst_all "\\\\" "\\" s;;
+let unslash_underscore s = Aux.str_subst_all "\\_" "_" s;;
(* Split name to get strings and args in syntax definition. *)
let split_sd_name name =
@@ -378,9 +377,9 @@
let print_grammar gr =
let clean_grammar_name name =
if name.[0] = '$' then
- let r1 = global_replace (regexp "\\") "bslash" name in
- let r2 = global_replace (regexp "?") "qmark" r1 in
- global_replace (regexp "@") "AT" r2
+ let r1 = Aux.str_subst_all "\\" "bslash" name in
+ let r2 = Aux.str_subst_all "?" "qmark" r1 in
+ Aux.str_subst_all "@" "AT" r2
else
name in
let get_rule_branch sl =
@@ -398,11 +397,11 @@
exception NONXSLT;;
let make_xml_compatible str =
- let s = global_replace (regexp "&") "&" str in
- let s_0 = global_replace (regexp "'") "'" s in
- let s_1 = global_replace (regexp "\"") """ s_0 in
- let s_2 = global_replace (regexp "<") "<" s_1 in
- global_replace (regexp ">") ">" s_2
+ let s = Aux.str_subst_all "&" "&" str in
+ let s_0 = Aux.str_subst_all "'" "'" s in
+ let s_1 = Aux.str_subst_all "\"" """ s_0 in
+ let s_2 = Aux.str_subst_all "<" "<" s_1 in
+ Aux.str_subst_all ">" ">" s_2
;;
let xslt_content_for_sel sels =
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Term/TRS.ml 2012-05-20 21:11:56 UTC (rev 1712)
@@ -2,7 +2,6 @@
open List;;
-open Str;;
open TermType;;
open SyntaxDef;;
@@ -127,15 +126,13 @@
let rec process s =
try
let line = input_line in_file in
- if line = "" then process s else
- (
- (* print_endline ("parsing: " ^ line); *)
- let te = term_of_string line in
- s := update_on_term k te !s bs;
- process s
+ if line = "" then process s else (
+ (* print_endline ("parsing: " ^ line); *)
+ let te = term_of_string line in
+ s := update_on_term k te !s bs;
+ process s
)
- with
- End_of_file -> !s in
+ with End_of_file -> !s in
process (ref bs)
with
Sys_error s -> raise (Sys_error s)
@@ -413,12 +410,12 @@
exception FAILED_PARSE_OR_EXN of string;;
-let process_with_system_bs lp verbose s str fail xml_out bs =
+let process_with_system_bs lp verbose s str fail xml_out bs outprint =
match parse_disambiguate_with_sys verbose s str with
[] ->
let msg = "NO PARSE" in
if fail then
- (if (not xml_out) then print_endline msg else ();
+ (if (not xml_out) then outprint msg else ();
flush stdout;
raise (FAILED_PARSE_OR_EXN msg))
else
@@ -436,7 +433,7 @@
| ts ->
let msg = "AMBIGUOUS\n" ^ (terms_info verbose ts) in
if fail then
- (if (not xml_out) then print_endline msg else ();
+ (if (not xml_out) then outprint msg else ();
flush stdout;
raise (FAILED_PARSE_OR_EXN msg))
else
@@ -481,16 +478,16 @@
fold_left updr system1 basic_rules
;;
-let process_with_system lp verbose s str fail xml_out =
- process_with_system_bs lp verbose s str fail xml_out basic_system
+let process_with_system lp verbose s str fail xml_out outprint =
+ process_with_system_bs lp verbose s str fail xml_out basic_system outprint
;;
(* TESTS *
let s1 = "function *new* syntax definition as syntax definition";;
- let (sys1, msg) = process_with_system basic_system s1;;
+ let (sys1, msg) = process_with_system basic_system s1 print_endline;;
let s2 = "[]";;
- let (sys2, msg) = process_with_system sys1 s2;;
+ let (sys2, msg) = process_with_system sys1 s2 print_endline;;
*)
@@ -501,7 +498,7 @@
let read_to_sep channel =
(* We do not break on .,;,&. and &; and amp, quot, apos, lt, gt. *)
let rec read_to_sep_prev prev amp quot apos lt gt =
- let c = input_char channel in
+ let c = channel () in
if (c = '.' || c = ';') && (not (prev = '&')) && (not (amp = 5)) &&
(not (amp = 4 && c=';')) && (not (quot = 5 && c=';')) &&
(not (apos = 5 && c=';')) && (not (lt = 3 && c=';')) &&
@@ -540,16 +537,16 @@
if gt = 3 && c = ';' then 4 else 0 in
(String.make 1 prev) ^
(read_to_sep_prev c new_amp new_quot new_apos new_lt new_gt) in
- let ch = input_char channel in
+ let ch = channel () in
let no = if ch = '&' then 1 else 0 in
if (ch = '.' || ch = ';') then "" else read_to_sep_prev ch no no no no no
;;
let starts_comment s =
- match split (regexp "[ \t\n\r]+") s with
- [] -> false
+ match Aux.split_spaces s with
+ | [] -> false
| w :: _ ->
- if String.length w < 2 then false else
+ if String.length w < 2 then false else
(w.[0] = '/') && (w.[1] = '/')
;;
@@ -568,29 +565,29 @@
count_occurences s (i+1) c
;;
-let step_shell lp verb cmode sys channel should_fail xml_out parsed =
+let step_shell lp verb cmode sys channel should_fail xml_out parsed outprint =
let _ = (if not cmode then print_string "> " else (); flush stdout;) in
let s_read = read_to_sep channel in
let s_stripped = strip_first_space s_read in
- let s_0 = global_replace (regexp "'") "'" s_stripped in
- let s_1 = global_replace (regexp """) "\"" s_0 in
- let s_2 = global_replace (regexp "<") "<" s_1 in
- let s_3 = global_replace (regexp ">") ">" s_2 in
- let s = global_replace (regexp "&") "&" s_3 in
+ let s_0 = Aux.str_subst_all "'" "'" s_stripped in
+ let s_1 = Aux.str_subst_all """ "\"" s_0 in
+ let s_2 = Aux.str_subst_all "<" "<" s_1 in
+ let s_3 = Aux.str_subst_all ">" ">" s_2 in
+ let s = Aux.str_subst_all "&" "&" s_3 in
if starts_comment s then
if not xml_out then
if cmode then
(if (count_occurences s_read 0 '\n') > 1 then
- print_endline ("\n" ^ s ^ ".")
+ outprint ("\n" ^ s ^ ".")
else
- print_endline (s ^ ".");
+ outprint (s ^ ".");
flush stdout;
sys
)
else
- (print_endline ("SPG: " ^ s ^ "\n"); flush stdout; sys)
+ (outprint ("SPG: " ^ s ^ "\n"); flush stdout; sys)
else (
- print_endline ("<speagram-comment>" ^
+ outprint ("<speagram-comment>" ^
(make_xml_compatible (s ^ ".")) ^ "</speagram-comment>");
sys
)
@@ -598,16 +595,15 @@
(
if not cmode then (print_string "SPG: "; flush stdout) else ();
let (nsys, nparsed, msg) =
- process_with_system lp verb sys s should_fail xml_out in
+ process_with_system lp verb sys s should_fail xml_out outprint in
(parsed := (nparsed @ !parsed);
if cmode then
if (count_occurences s_read 0 '\n') > 1 then
- print_endline ("\n" ^ msg)
+ outprint ("\n" ^ msg)
else
- print_endline msg
+ outprint msg
else
- print_endline (msg ^ "\n");
- flush stdout;
+ outprint (msg ^ "\n");
nsys
)
)
Modified: trunk/Toss/Term/TRS.mli
===================================================================
--- trunk/Toss/Term/TRS.mli 2012-05-20 12:31:12 UTC (rev 1711)
+++ trunk/Toss/Term/TRS.mli 2012-05-20 21:11:56 UTC (rev 1712)
@@ -25,7 +25,7 @@
exception FAILED_PARSE_OR_EXN of string;;
val process_with_system : string -> bool -> spg_system -> string -> bool ->
- bool -> spg_system * Term.term list * string;;
+ bool -> (string -> unit) -> spg_system * Term.term list * string;;
val basic_sdefs : syntax_def list;;
@@ -33,5 +33,7 @@
(* -------- COMPLETE ONE STEP OF A SHELL ------- *)
-val step_shell : string -> bool -> bool -> spg_system ->
- in_channel -> bool -> bool -> Term.term list ref -> spg_system
+(* A step of the computation. The channel (unit -> char) argument should
+ raise End_of_file on end of channel, as does input_char. *)
+val step_shell : string -> bool -> bool -> spg_system -> (unit -> char) ->
+ bool -> bool -> Term.term list ref -> (string -> unit) -> spg_system
Copied: trunk/Toss/Term/TRSTest.ml (from rev 1711, trunk/Toss/Term/speagram.ml)
===================================================================
--- trunk/Toss/Term/TRSTest.ml (rev 0)
+++ trunk/Toss/Term/TRSTest.ml 2012-05-20 21:11:56 UTC (rev 1712)
@@ -0,0 +1,167 @@
+(* The speagram binary for command line use. *)
+
+
+open List;;
+
+open Term;;
+open TRS;;
+open SyntaxDef;;
+
+open OUnit;;
+
+let rec run lp v grammar_path xslt_path out_path
+ cmode sys channel fail xmlo res outprint =
+ let save_parsed () =
+ let parsed_strs = map term_to_string (rev !res) in
+ let out_file = open_out (out_path) in
+ (if not cmode then
+ outprint ("SAVING PARSED TERMS TO " ^ out_path ^ ".")
+ else ();
+ output_string out_file ((String.concat "\n" parsed_strs) ^ "\n");
+ close_out out_file;); in
+ let save_xslt () = (
+ if not cmode then
+ outprint ("SAVING XSLT TO " ^ xslt_path ^ ".")
+ else ();
+ let addon_term = Term (BuiltinLang.additional_xslt_name, [||]) in
+ let addon_str = decode_string (normalise_with_sys !sys addon_term) in
+ let xslt_str =
+ print_xslt addon_str (syntax_defs_of_sys !sys) in
+ let out_file = open_out (xslt_path) in
+ (output_string out_file xslt_str; close_out out_file;)) in
+ let save_grammar () = (
+ if not cmode then
+ outprint ("SAVING GRAMMAR TO " ^ grammar_path ^ ".")
+ else ();
+ let grammar_str =
+ let sys_sdefs = fst (List.split (syntax_defs_of_sys !sys)) in
+ print_grammar (flat_grammar_of_sd_list (sys_sdefs)) in
+ let out_file = open_out (grammar_path) in
+ (output_string out_file grammar_str; close_out out_file;)) in
+ let save_requested () = (
+ if (not (grammar_path = "")) then save_grammar () else ();
+ if (not (xslt_path = "")) then save_xslt () else ();
+ if (not (out_path = "")) then save_parsed () else ();
+ ) in
+ try
+ (sys := step_shell lp v cmode !sys channel fail xmlo res outprint;
+ run lp v grammar_path xslt_path out_path cmode sys channel fail xmlo res outprint)
+ with
+ | End_of_file -> save_requested ();
+ | FAILED_PARSE_OR_EXN msg ->
+ (save_requested ();
+ if xmlo then
+ (outprint "\n<speagram-failure>\n";
+ outprint (make_xml_compatible msg);
+ outprint "\n</speagram-failure>\n";
+ outprint "\n</speagram-response>\n";)
+ else ();
+ failwith msg)
+;;
+
+let test fname =
+ let s = ref (AuxIO.input_file ("./Term/tests/" ^ fname ^ ".spg")) in
+ let read_s () = if !s = "" then raise End_of_file else (
+ let c = !s.[0] in s := String.sub !s 1 ((String.length !s)-1); c) in
+ let o = ref "" in
+ let print_o str = o := !o ^ str ^ "\n" in
+ run "./Term/lib" false "" "" "" true
+ (ref basic_system) read_s true false (ref []) print_o;
+ assert_equal ~printer:(fun x -> x) (Aux.normalize_spaces (
+ AuxIO.input_file ("./Term/tests/" ^ fname ^ ".log")))
+ (Aux.normalize_spaces !o)
+
+let tests = "TRS" >::: [
+ "test short_checks" >::
+ (fun () -> test "short_checks";);
+]
+
+let bigtests = "TRS" >::: [
+ "test fo_formula" >::
+ (fun () -> test "fo_formula";);
+ "test sasha_basic" >::
+ (fun () -> test "sasha_basic";);
+ "test english" >::
+ (fun () -> test "english";);
+ "test simple_algo" >::
+ (fun () -> test "simple_algo";);
+ "test entanglement" >::
+ (fun () -> test "entanglement";);
+ "test differentiation" >::
+ (fun () -> test "differentiation";);
+]
+
+
+let main () =
+ let _ = Gc.set { (Gc.get()) with
+ Gc.space_overhead = 128; Gc.max_overhead = 512;
+ Gc.minor_heap_size = 1048576; Gc.major_heap_increment = 4194304 } in
+ let should_fail = ref false in
+ let make_it_fail () = (should_fail := true) in
+ let verbose = ref false in
+ let make_verbose () = (verbose := true) in
+ let out_path = ref "" in
+ let set_o...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-21 22:07:09
|
Revision: 1713
http://toss.svn.sourceforge.net/toss/?rev=1713&view=rev
Author: lukaszkaiser
Date: 2012-05-21 22:07:00 +0000 (Mon, 21 May 2012)
Log Message:
-----------
Correcting Term functions, merging old docs.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Term/.cvsignore
trunk/Toss/Term/Makefile
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/TRSTest.ml
trunk/Toss/www/reference/Makefile
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/Term/lib/.cvsignore
trunk/Toss/Term/lib/arithmetics.trs
trunk/Toss/Term/lib/basic.trs
trunk/Toss/Term/lib/core.trs
trunk/Toss/Term/lib/lists.trs
trunk/Toss/Term/lib/sasha.trs
trunk/Toss/Term/tests/differentiation.trs
trunk/Toss/Term/tests/english.trs
trunk/Toss/Term/tests/entanglement.trs
trunk/Toss/Term/tests/fo_formula.trs
trunk/Toss/Term/tests/sasha_basic.trs
trunk/Toss/Term/tests/short_checks.trs
trunk/Toss/Term/tests/simple_algo.trs
trunk/Toss/www/reference/parser.tex
trunk/Toss/www/reference/rewriting.tex
trunk/Toss/www/reference/simplification.tex
trunk/Toss/www/reference/syntax_definitions.tex
trunk/Toss/www/reference/terms.tex
trunk/Toss/www/reference/types.tex
Removed Paths:
-------------
trunk/Toss/Term/lib/arithmetics.spg
trunk/Toss/Term/lib/basic.spg
trunk/Toss/Term/lib/core.spg
trunk/Toss/Term/lib/lists.spg
trunk/Toss/Term/lib/sasha.spg
trunk/Toss/Term/tests/differentiation.spg
trunk/Toss/Term/tests/english.spg
trunk/Toss/Term/tests/entanglement.spg
trunk/Toss/Term/tests/fo_formula.spg
trunk/Toss/Term/tests/sasha_basic.spg
trunk/Toss/Term/tests/short_checks.spg
trunk/Toss/Term/tests/simple_algo.spg
Property Changed:
----------------
trunk/Toss/Term/
trunk/Toss/Term/lib/
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Makefile 2012-05-21 22:07:00 UTC (rev 1713)
@@ -61,7 +61,7 @@
NAMEPATTERN = f$(subst .,_,$(subst -,_,$(subst /,_,$(basename $@))))
%.resource:
@echo -n 'let $(NAMEPATTERN) = "' >> Formula/Resources.ml
- @cat $(basename $@) | sed 's/"/\\"/g' >> Formula/Resources.ml
+ @cat $(basename $@) | sed 's/\\/\\\\/g' | sed 's/"/\\"/g' >> Formula/Resources.ml
@echo '"' >> Formula/Resources.ml
@echo '' >> Formula/Resources.ml
@echo 'let _ = files := ("$(basename $@)", $(NAMEPATTERN)) :: !files' \
@@ -72,6 +72,15 @@
TOSSEXFILES = $(shell find examples -name "*.toss")
TOSSEXRESC = $(addsuffix .resource, $(TOSSEXFILES))
+TRSPARSEDFILES = $(shell find Term/lib -name "*.trs.parsed")
+TRSPARSEDRESC = $(addsuffix .resource, $(TRSPARSEDFILES))
+
+TRSTESTFILES = $(shell find Term/tests -name "*.trs")
+TRSTESTRESC = $(addsuffix .resource, $(TRSTESTFILES))
+
+TRSTESTLOGFILES = $(shell find Term/tests -name "*.log")
+TRSTESTLOGRESC = $(addsuffix .resource, $(TRSTESTLOGFILES))
+
new_resource_file:
@echo "(* Automatically Constructed Resources *)" > Formula/Resources.ml
@echo "" >> Formula/Resources.ml
@@ -80,7 +89,7 @@
@echo "let get_file fn = List.assoc fn !files" >> Formula/Resources.ml
@echo "" >> Formula/Resources.ml
-all_resources: $(TOSSEXRESC) \
+all_resources: $(TOSSEXRESC) $(TRSPARSEDRESC) $(TRSTESTRESC) $(TRSTESTLOGRESC) \
GGP/tests/connect5-simpl.toss.resource \
GGP/tests/breakthrough-simpl.toss.resource \
GGP/examples/connect5.gdl.resource \
@@ -93,11 +102,23 @@
Formula/Resources.ml:
@make new_resource_file > /dev/null
+ @make allparsed
@make all_resources
EXTDEPS = caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo Formula/Resources.ml
+MKPARSED = ./TRSTest.native -c -f -l "Term/lib"
+
+%.trs.parsed: %.trs
+ make ./Term/TRSTest.native
+ $(MKPARSED) -o $@ < $< > /dev/null
+
+allparsed: Term/lib/core.trs.parsed Term/lib/arithmetics.trs.parsed \
+ Term/lib/lists.trs.parsed Term/lib/basic.trs.parsed \
+ Term/lib/sasha.trs.parsed
+
+
# -------- MAIN OCAMLBUILD PART --------
OCB_LFLAG=-lflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g
@@ -176,6 +197,14 @@
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Solver -v
+# Term tests
+TermTests: TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
+ ./TossServer -fulltest Term
+TermTestsVerbose: TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
+ ./TossServer -fulltest Term -v
+
# Arena tests
ArenaTests: TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
@@ -251,3 +280,4 @@
rm -f *.cmx *.cmi *.o *.cmo *.a *.cmxa *.cma *.annot *~ TossServer
rm -f Formula/*~ Solver/*~ Arena/*~ Learn/*~ Play/*~ GGP/*~ Server/*~
rm -f caml_extensions/*.cmo caml_extensions/*.cmi Formula/Resources.ml
+ rm -f Term/lib/*.trs.parsed
Property changes on: trunk/Toss/Term
___________________________________________________________________
Modified: svn:ignore
- # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
speagram
*.mly.debug
*.cmx
*.cmo
*.cmi
*.annot
*~
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
*~
Modified: trunk/Toss/Term/.cvsignore
===================================================================
--- trunk/Toss/Term/.cvsignore 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Term/.cvsignore 2012-05-21 22:07:00 UTC (rev 1713)
@@ -2,11 +2,4 @@
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
-speagram
-
-*.mly.debug
-*.cmx
-*.cmo
-*.cmi
-*.annot
*~
Modified: trunk/Toss/Term/Makefile
===================================================================
--- trunk/Toss/Term/Makefile 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Term/Makefile 2012-05-21 22:07:00 UTC (rev 1713)
@@ -1,14 +1,10 @@
-all: parsed
+all: coreparsed
-RUN = ../TRSTest.native -c -f -l "../Term/lib"
+MKPARSED = ../TRSTest.native -c -f -l "../Term/lib"
-parsed:
+coreparsed:
make -C .. ./Term/TRSTest.native
- $(RUN) -o lib/core.spg.parsed < lib/core.spg > /dev/null
- $(RUN) -o lib/arithmetics.spg.parsed < lib/arithmetics.spg > /dev/null
- $(RUN) -o lib/lists.spg.parsed < lib/lists.spg > /dev/null
- $(RUN) -o lib/basic.spg.parsed < lib/basic.spg > /dev/null
- $(RUN) -o lib/sasha.spg.parsed < lib/sasha.spg > /dev/null
+ $(MKPARSED) -o lib/core.trs.parsed < lib/core.trs > /dev/null
.PHONY:
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Term/TRS.ml 2012-05-21 22:07:00 UTC (rev 1713)
@@ -24,6 +24,7 @@
(string * term_type) list (* Objects with types for chronologic access *)
;;
+
(* -------------- GETTING SYNTAX DEFINITIONS OUT ---------------- *)
let syntax_defs_of_sys = function
@@ -121,21 +122,16 @@
let rec update_on_load_file k file sys bs =
- try
- let in_file = open_in (file ^ ".spg.parsed") in
- let rec process s =
- try
- let line = input_line in_file in
- if line = "" then process s else (
- (* print_endline ("parsing: " ^ line); *)
- let te = term_of_string line in
- s := update_on_term k te !s bs;
- process s
- )
- with End_of_file -> !s in
- process (ref bs)
- with
- Sys_error s -> raise (Sys_error s)
+ let rec process s = function
+ | [] -> !s
+ | line :: rest ->
+ if line = "" then process s rest else (
+ let te = term_of_string line in
+ s := update_on_term k te !s bs;
+ process s rest
+ ) in
+ let fname = file ^ ".trs.parsed" in
+ process (ref bs) (Aux.split_newlines (AuxIO.input_file fname))
and update_on_term k te sys bs =
try update_on_sd (decode_syntax_definition te) sys with
DECODE _ ->
@@ -469,7 +465,7 @@
brackets_rules; verbatim_rules; if_then_else_rules; preprocess_rules;
additional_xslt_rules; string_quote_rules];; (* eq_bool_rules *)
-let basic_system =
+let basic_system () =
let upd sys sd = update_on_sd sd sys in
let mem_rrs = (TermHashtbl.create 512, Hashtbl.create 512) in
let emptys = Sys ([], Hashtbl.create 512, mem_rrs, [], []) in
@@ -479,7 +475,7 @@
;;
let process_with_system lp verbose s str fail xml_out outprint =
- process_with_system_bs lp verbose s str fail xml_out basic_system outprint
+ process_with_system_bs lp verbose s str fail xml_out (basic_system()) outprint
;;
Modified: trunk/Toss/Term/TRS.mli
===================================================================
--- trunk/Toss/Term/TRS.mli 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Term/TRS.mli 2012-05-21 22:07:00 UTC (rev 1713)
@@ -29,7 +29,7 @@
val basic_sdefs : syntax_def list;;
-val basic_system : spg_system;;
+val basic_system : unit -> spg_system;;
(* -------- COMPLETE ONE STEP OF A SHELL ------- *)
Modified: trunk/Toss/Term/TRSTest.ml
===================================================================
--- trunk/Toss/Term/TRSTest.ml 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Term/TRSTest.ml 2012-05-21 22:07:00 UTC (rev 1713)
@@ -60,13 +60,13 @@
;;
let test fname =
- let s = ref (AuxIO.input_file ("./Term/tests/" ^ fname ^ ".spg")) in
+ let s = ref (AuxIO.input_file ("./Term/tests/" ^ fname ^ ".trs")) in
let read_s () = if !s = "" then raise End_of_file else (
let c = !s.[0] in s := String.sub !s 1 ((String.length !s)-1); c) in
let o = ref "" in
let print_o str = o := !o ^ str ^ "\n" in
run "./Term/lib" false "" "" "" true
- (ref basic_system) read_s true false (ref []) print_o;
+ (ref (basic_system ())) read_s true false (ref []) print_o;
assert_equal ~printer:(fun x -> x) (Aux.normalize_spaces (
AuxIO.input_file ("./Term/tests/" ^ fname ^ ".log")))
(Aux.normalize_spaces !o)
@@ -133,7 +133,7 @@
ignore (OUnit.run_test_tt ~verbose:true tests)
else (
let parsed_terms = ref [] in
- let basic_sys = ref basic_system in
+ let basic_sys = ref (basic_system ()) in
if !builtin_out then
let defs = String.concat "\n" (map pretty_print_sd basic_sdefs) in
print_endline ("// SPEAGRAM BUILT-IN DEFS.\n" ^ defs ^ "\n")
Property changes on: trunk/Toss/Term/lib
___________________________________________________________________
Added: svn:ignore
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
*.parsed
*~
Added: trunk/Toss/Term/lib/.cvsignore
===================================================================
--- trunk/Toss/Term/lib/.cvsignore (rev 0)
+++ trunk/Toss/Term/lib/.cvsignore 2012-05-21 22:07:00 UTC (rev 1713)
@@ -0,0 +1,6 @@
+# We are still using .cvsignore files as we find them easier to manage
+# than svn properties. Therefore if you change .cvsignore do the following.
+# svn propset svn:ignore -F .cvsignore .
+
+*.parsed
+*~
Deleted: trunk/Toss/Term/lib/arithmetics.spg
===================================================================
--- trunk/Toss/Term/lib/arithmetics.spg 2012-05-20 21:11:56 UTC (rev 1712)
+++ trunk/Toss/Term/lib/arithmetics.spg 2012-05-21 22:07:00 UTC (rev 1713)
@@ -1,462 +0,0 @@
-Load state library:/core.
-
-// BASIC NUMBER TYPES.
-
-// BINARY NUMEBERS.
-
-New type ''binary number''.
-New function ''0'' as binary number.
-New function ''1'' as binary number.
-New function binary number ''0'' as binary number.
-New function binary number ''1'' as binary number.
-
-// TYPE CAST TO ENFORCE NATURAL NUMBER TYPE.
-New function binary number ''as binary number'' as binary number.
-New variable b as binary number.
-Let b as binary number be b.
-Close context.
-
-// NATURAL NUMBERS.
-New type ''natural number''.
-New function ''0'' as natural number.
-New function ''1'' as natural number.
-New function ''2'' as natural number.
-New function ''3'' as natural number.
-New function ''4'' as natural number.
-New function ''5'' as natural number.
-New function ''6'' as natural number.
-New function ''7'' as natural number.
-New function ''8'' as natural number.
-New function ''9'' as natural number.
-New function natural number ''0'' as natural number.
-New function natural number ''1'' as natural number.
-New function natural number ''2'' as natural number.
-New function natural number ''3'' as natural number.
-New function natural number ''4'' as natural number.
-New function natural number ''5'' as natural number.
-New function natural number ''6'' as natural number.
-New function natural number ''7'' as natural number.
-New function natural number ''8'' as natural number.
-New function natural number ''9'' as natural number.
-
-// TYPE CAST TO ENFORCE NATURAL NUMBER TYPE.
-New function natural number ''as natural number'' as natural number.
-New variable n as natural number.
-Let n as natural number be n.
-Close context.
-
-// Standard numbers 0 and 1 are natural and not binary.
-See 0 as natural number preferred to different 0 as binary number.
-See 1 as natural number preferred to different 1 as binary number.
-
-
-// This number-append is necessary for division later.
-New function natural number ''@'' natural number as natural number.
-New variable varnat_a as natural number.
-New variable varnat_b as natural number.
-Let varnat_a @ 0 be varnat_a 0.
-Let varnat_a @ 1 be varnat_a 1.
-Let varnat_a @ 2 be varnat_a 2.
-Let varnat_a @ 3 be varnat_a 3.
-Let varnat_a @ 4 be varnat_a 4.
-Let varnat_a @ 5 be varnat_a 5.
-Let varnat_a @ 6 be varnat_a 6.
-Let varnat_a @ 7 be varnat_a 7.
-Let varnat_a @ 8 be varnat_a 8.
-Let varnat_a @ 9 be varnat_a 9.
-Let varnat_a @ (varnat_b 0) be (varnat_a @ varnat_b) 0.
-Let varnat_a @ (varnat_b 1) be (varnat_a @ varnat_b) 1.
-Let varnat_a @ (varnat_b 2) be (varnat_a @ varnat_b) 2.
-Let varnat_a @ (varnat_b 3) be (varnat_a @ varnat_b) 3.
-Let varnat_a @ (varnat_b 4) be (varnat_a @ varnat_b) 4.
-Let varnat_a @ (varnat_b 5) be (varnat_a @ varnat_b) 5.
-Let varnat_a @ (varnat_b 6) be (varnat_a @ varnat_b) 6.
-Let varnat_a @ (varnat_b 7) be (varnat_a @ varnat_b) 7.
-Let varnat_a @ (varnat_b 8) be (varnat_a @ varnat_b) 8.
-Let varnat_a @ (varnat_b 9) be (varnat_a @ varnat_b) 9.
-
-Close context.
-
-
-// ARITHMETIC FUNCTION DECLARATIONS.
-
-// BINARY NUMBERS.
-
-New variable n as binary number.
-New variable m as binary number.
-New variable k as binary number.
-New variable n' as binary number.
-New variable m' as binary number.
-New variable k' as binary number.
-
-New function binary number ''+'' binary number as binary number.
-See (n+(m0)) preferred to (n'+m')0.
-See (n+(m1)) preferred to (n'+m')1.
-See ((n+m)+k) as binary number preferred to (n'+(m'+k')).
-Let 0 + n be n.
-Let n + 0 be n.
-Let 1 + 1 be 10.
-Let n0 + 1 be n1.
-Let n1 + 1 be (n+1)0.
-Let 1 + n0 be n1.
-Let 1 + n1 be (n+1)0.
-Let n0 + m0 be (n+m)0.
-Let n0 + m1 be (n+m)1.
-Let n1 + m0 be (n+m)1.
-Let n1 + m1 be (n+1+m)0.
-
-New function binary number ''*'' binary number as binary number.
-See (n*(m0)) preferred to (n'*m')0.
-See (n*(m1)) preferred to (n'*m')1.
-See ((n*m)*k) preferred to (n'*(m'*k')).
-See ((n*m)+k) preferred to (n'*(m'+k')).
-See (k+(n*m)) preferred to ((k'+n')*m').
-Let 0 * n be 0.
-Let n * 0 be 0.
-Let 1 * n be n.
-Let n * 1 be n.
-Let n0 * m0 be (n*m)00.
-Let n1 * m0 be (n*m)00 + m0.
-Let n0 * m1 be (n*m)00 + n0.
-Let n1 * m1 be (n*m)00 + m0 + n1.
-
-New function binary number ''<='' binary number as boolean.
-Let 0 <= n be true.
-Let 1 <= 0 be false.
-Let 1 <= 1 be true.
-Let n0 <= 0 be n <= 0.
-Let n1 <= 0 be false.
-Let 1 <= n0 be 1 <= n.
-Let 1 <= n1 be true.
-Let n0 <= 1 be n <= 0.
-Let n1 <= 1 be n <= 0.
-Let m0 <= n0 be m <= n.
-Let m1 <= n1 be m <= n.
-Let m0 <= n1 be m <= n.
-Let m1 <= n0 be m+1 <= n.
-
-New function ''truncate'' binary number as binary number.
-See truncate (n0) preferred to (truncate m)0.
-See truncate (n1) preferred to (truncate m)1.
-Let truncate 0 be 0.
-Let truncate 1 be 1.
-Let truncate n0 be if n <= 0 then 0 else (truncate n)0.
-Let truncate n1 be if n <= 0 then 1 else (truncate n)1.
-
-New function binary number ''=='' binary number as boolean.
-Let n == m be truncate n = truncate m.
-
-New function binary number ''<'' binary number as boolean.
-Let n < m be if n == m then false else n <= m.
-
-New function binary number ''>'' binary number as boolean.
-Let n > m be m < n.
-
-New function binary number ''>='' binary number as boolean.
-Let n >= m be m <= n.
-
-New function ''max'' ''('' binary number '','' binary number '')''
- as binary number.
-Let max (n, m) be if n >= m then n else m.
-
-New function ''min'' ''('' binary number '','' binary number '')''
- as binary number.
-Let min (n, m) be if n <= m then n else m.
-
-New function binary number ''-'' ''>'' ''-'' binary number as binary number.
-See (n ->- (m0)) preferred to (n' ->- m')0.
-See (n ->- (m1)) preferred to (n' ->- m')1.
-Let n ->- 0 be n.
-Let 1 ->- 1 be 0.
-Let 0 ->- 1 be 0.
-Let 10 ->- 1 be 1.
-Let n1 ->- 1 be n0.
-Let n0 ->- 1 be (n ->- 1)1.
-Let n0 ->- m0 be if n == m then 0 else (n ->- m)0.
-Let n1 ->- m1 be if n == m then 0 else (n ->- m)0.
-Let n1 ->- m0 be if n == m then 1 else (n ->- m)1.
-Let n0 ->- m1 be if (n ->- 1) ->- m == 0 then 1 else ((n ->- 1) ->- m)1.
-
-New function binary number ''-'' binary number as binary number.
-See (n - (m0)) preferred to (n' - m')0.
-See (n - (m1)) preferred to (n' - m')1.
-See ((n-m)-k) preferred to (n'-(m'-k')).
-See ((n+m)-k) preferred to (n'+(m'-k')).
-See ((n*m)-k) preferred to (n'*(m'-k')).
-Let n - 0 be n.
-Let 1 - 1 be 0.
-Let 10 - 1 be 1.
-Let n1 - 1 be n0.
-Let n0 - 1 be (n-1)1.
-Let n0 - m0 be if n == m then 0 else (n-m)0.
-Let n1 - m1 be if n == m then 0 else (n-m)0.
-Let n1 - m0 be if n == m then 1 else (n-m)1.
-Let n0 - m1 be if n-1-m == 0 then 1 else (n-1-m)1.
-//Let n - m be 0. // negative number NOT supported with this.
-Let n - m be if n <= m then 0 else (n ->- m).
-
-Close context.
-
-
-New variable n as binary number.
-New variable k as binary number.
-New variable n' as binary number.
-New variable k' as binary number.
-New variable idiv as binary number.
-New variable imod as binary number.
-
-New function ''divide'' binary number ''by'' binary number ''with rest''
- as pair of binary number and binary number.
-
-New function binary number ''/'' binary number as binary number.
-See (n/(k0)) preferred to (n'/k')0.
-See (n/(k1)) preferred to (n'/k')1.
-Let n / k be first of divide n by k with rest.
-
-New function binary number ''%'' binary number as binary number.
-See (n % (k0)) preferred to (n' % k')0.
-See (n % (k1)) preferred to (n' % k')1.
-Let n % k be second of divide n by k with rest.
-
-
-Let divide n by 0 with rest be (0, n).
-Let divide 0 by k with rest be (0, 0).
-Let divide 1 by k with rest be if k > 1 then (0, 1) else (1, 0).
-
-New function ''divide induct'' ''rest zero for'' binary number
- ''with induct'' pair of binary number and binary number
- as pair of binary number and binary number.
-Let divide induct rest zero for k with induct (idiv, imod) be
- if imod 0 < k then
- (idiv 0, 10*imod)
- else
- (idiv 1, 10*imod - k).
-
-New function ''divide induct'' ''rest one for'' binary number
- ''with induct'' pair of binary number and binary number
- as pair of binary number and binary number.
-Let divide induct rest one for k with induct (idiv, imod) be
- if imod 1 < k then
- (idiv 0, 10*imod+1)
- else
- (idiv 1, (10*imod+1)-k).
-
-Let divide n0 by k with rest be
- if k > n then
- if k > n0 then (0, n0) else (1, n0-k)
- else
- divide induct rest zero for k with induct divide n by k with rest.
-
-Let divide n1 by k with rest be
- if k > n then
- if k > n1 then (0, n1) else (1, n1-k)
- else
- divide induct rest one for k with induct divide n by k with rest.
-
-Close context.
-
-// NATURAL NUMBERS.
-
-New function ''to_binary'' ''('' natural number '')'' as binary number.
-New variable n as natural number.
-Let to_binary(0) be 0.
-Let to_binary(1) be 1.
-Let to_binary(2) be 10.
-Let to_binary(3) be 11.
-Let to_binary(4) be 100.
-Let to_binary(5) be 101.
-Let to_binary(6) be 110.
-Let to_binary(7) be 111.
-Let to_binary(8) be 1000.
-Let to_binary(9) be 1001.
-Let to_binary(n0) be 1010*to_binary(n).
-Let to_binary(n1) be 1 + 1010*to_binary(n).
-Let to_binary(n2) be 10 + 1010*to_binary(n).
-Let to_binary(n3) be 11 + 1010*to_binary(n).
-Let to_binary(n4) be 100 + 1010*to_binary(n).
-Let to_binary(n5) be 101 + 1010*to_binary(n).
-Let to_binary(n6) be 110 + 1010*to_binary(n).
-Let to_binary(n7) be 111 + 1010*to_binary(n).
-Let to_binary(n8) be 1000 + 1010*to_binary(n).
-Let to_binary(n9) be 1001 + 1010*to_binary(n).
-Close context.
-
-New function ''digit'' ''('' binary number '')'' as natural number.
-Let digit(0) be 0.
-Let digit(1) be 1.
-Let digit(10) be 2.
-Let digit(11) be 3.
-Let digit(100) be 4.
-Let digit(101) be 5.
-Let digit(110) be 6.
-Let digit(111) be 7.
-Let digit(1000) be 8.
-Let digit(1001) be 9.
-Close context.
-
-New function ''to_decimal'' ''('' binary number '')'' as natural number.
-New variable n as binary number.
-Let to_decimal (0) be 0.
-Let to_decimal (1) be 1.
-Let to_decimal (n0) be
- if (n0) < 1010 then digit (n0) else
- to_decimal((n0) / (1010)) @ digit((n0) % (1010)).
-Let to_decimal (n1) be
- if (n1) < 1010 then digit (n1) else
- to_decimal((n1) / (1010)) @ digit((n1) % (1010)).
-
-Close context.
-
-// NATURAL NUMBERS.
-
-New variable n as natural number.
-New variable m as natural number.
-New variable k as natural number.
-New variable n' as natural number.
-New variable m' as natural number.
-New variable k' as natural number.
-
-
-New function natural number ''+'' natural number as natural number.
-See (n+(m0)) preferred to (n'+m')0.
-See (n+(m1)) preferred to (n'+m')1.
-See (n+(m2)) preferred to (n'+m')2.
-See (n+(m3)) preferred to (n'+m')3.
-See (n+(m4)) preferred to (n'+m')4.
-See (n+(m5)) preferred to (n'+m')5.
-See (n+(m6)) preferred to (n'+m')6.
-See (n+(m7)) preferred to (n'+m')7.
-See (n+(m8)) preferred to (n'+m')8.
-See (n+(m9)) preferred to (n'+m')9.
-See ((n+m)+k) as natural number preferred to (n'+(m'+k')).
-
-New function natural number ''-'' natural number as natural number.
-See (n-(m0)) preferred to (n'-m')0.
-See (n-(m1)) preferred to (n'-m')1.
-See (n-(m2)) preferred to (n'-m')2.
-See (n-(m3)) preferred to (n'-m')3.
-See (n-(m4)) preferred to (n'-m')4.
-See (n-(m5)) preferred to (n'-m')5.
-See (n-(m6)) preferred to (n'-m')6.
-See (n-(m7)) preferred to (n'-m')7.
-See (n-(m8)) preferred to (n'-m')8.
-See (n-(m9)) preferred to (n'-m')9.
-See ((n-m)-k) as natural number preferred to (n'-(m'-k')).
-See ((n+m)-k) as natural number preferred to (n'+(m'-k')).
-See ((n-m)+k) as natural number preferred to (n'-(m'+k')).
-
-New function natural number ''*'' natural number as natural number.
-See (n*(m0)) preferred to (n'*m')0.
-See (n*(m1)) preferred to (n'*m')1.
-See (n*(m2)) preferred to (n'*m')2.
-See (n*(m3)) preferred to (n'*m')3.
-See (n*(m4)) preferred to (n'*m')4.
-See (n*(m5)) preferred to (n'*m')5.
-See (n*(m6)) preferred to (n'*m')6.
-See (n*(m7)) preferred to (n'*m')7.
-See (n*(m8)) preferred to (n'*m')8.
-See (n*(m9)) preferred to (n'*m')9.
-See ((n*m)*k) as natural number preferred to (n'*(m'*k')).
-See ((n*m)+k) as natural number preferred to (n'*(m'+k')).
-See (k+(n*m)) as natural number preferred to ((k'+n')*m').
-See ((n*m)-k) as natural number preferred to (n'*(m'-k')).
-See (k-(n*m)) as natural number preferred to ((k'-n')*m').
-
-New function natural number ''/'' natural number as natural number.
-See (n+(m0)) preferred to (n'+m')0.
-See (n/(m1)) preferred to (n'/m')1.
-See (n/(m2)) preferred to (n'/m')2.
-See (n/(m3)) preferred to (n'/m')3.
-See (n/(m4)) preferred to (n'/m')4.
-See (n/(m5)) preferred to (n'/m')5.
-See (n/(m6)) preferred to (n'/m')6.
-See (n/(m7)) preferred to (n'/m')7.
-See (n/(m8)) preferred to (n'/m')8.
-See (n/(m9)) preferred to (n'/m')9.
-See ((n/m)/k) as natural number preferred to (n'/(m'/k')).
-See ((n/m)+k) as natural number preferred to (n'/(m'+k')).
-See (k+(n/m)) as natural number preferred to ((k'+n')/m').
-See ((n/m)-k) as natural number preferred to (n'/(m'-k')).
-See (k-(n/m)) as natural number preferred to ((k'-n')/m').
-
-New function natural number ''%'' natural number as natural number.
-See (n%(m0)) preferred to (n'%m')0.
-See (n%(m1)) preferred to (n'%m')1.
-See (n%(m2)) preferred to (n'%m')2.
-See (n%(m3)) preferred to (n'%m')3.
-See (n%(m4)) preferred to (n'%m')4.
-See (n%(m5)) preferred to (n'%m')5.
-See (n%(m6)) preferred to (n'%m')6.
-See (n%(m7)) preferred to (n'%m')7.
-See (n%(m8)) preferred to (n'%m')8.
-See (n%(m9)) preferred to (n'%m')9.
-See ((n%m)%k) as natural number preferred to (n'%(m'%k')).
-See ((n%m)+k) as natural number preferred to (n'%(m'+k')).
-See (k+(n%m)) as natural number preferred to ((k'+n')%m').
-See ((n%m)-k) as natural number preferred to (n'%(m'-k')).
-See (k-(n%m)) as natural number preferred to ((k'-n')%m').
-
-
-Let k + n be to_decimal (to_binary (k) + to_binary (n)).
-Let k - n be to_decimal (to_binary (k) - to_binary (n)).
-Let k * n be to_decimal (to_binary (k) * to_binary (n)).
-Let k / n be to_decimal (to_binary (k) / to_binary (n)).
-Let k % n be to_decimal (to_binary (k) % to_binary (n)).
-
-
-New function natural number ''<'' natural number as boolean.
-Let k < n be to_binary (k) < to_binary (n).
-
-New function natural number ''<='' natural number as boolean.
-Let k <= n be to_binary (k) <= to_binary (n).
-
-New function natural number ''>'' natural number as boolean.
-Let k > n be to_binary (k) > to_binary (n).
-
-New function natural number ''>='' natural number as boolean.
-Let k >= n be to_binary (k) >= to_binary (n).
-
-New function natural number ''=='' natural number as boolean.
-Let k == n be to_binary (k) == to_binary (n).
-
-New function ''max'' ''('' natural number '','' natural number '')''
- as natural number.
-Let max (k, n) be if k >= n then k else n.
-
-New function ''min'' ''('' natural number '','' natural number '')''
- as natural number.
-Let min (k, n) be if k <= n then k else n.
-
-Close context.
-
-
-// INTEGERS AND FLOATS ARE STILL MISSING, BUT THIS IS THE IDEA.
-
-
-// INTEGERS, NATURALS TO INTEGERS CAST.
-
-New type ''integer''.
-New function ''+'' natural number as integer.
-New function ''-'' natural number as integer.
-
-New function natural number as integer.
-New variable varnat as natural number.
-Let varnat be + varnat.
-
-See last function as cast.
-
-Close context.
-
-
-// FLOATS, INTEGERS TO FLOATS CAST.
-
-New type ''float''.
-New function integer ''e'' integer as float.
-
-New function integer as float.
-New variable var_int as integer.
-Let var_int be var_int e + 0.
-
-See last function as cast.
-
-Close context.
Copied: trunk/Toss/Term/lib/arithmetics.trs (from rev 1712, trunk/Toss/Term/lib/arithmetics.spg)
===================================================================
--- trunk/Toss/Term/lib/arithmetics.trs (rev 0)
+++ trunk/Toss/Term/lib/arithmetics.trs 2012-05-21 22:07:00 UTC (rev 1713)
@@ -0,0 +1,462 @@
+Load state library:/core.
+
+// BASIC NUMBER TYPES.
+
+// BINARY NUMEBERS.
+
+New type ''binary number''.
+New function ''0'' as binary number.
+New function ''1'' as binary number.
+New function binary number ''0'' as binary number.
+New function binary number ''1'' as binary number.
+
+// TYPE CAST TO ENFORCE NATURAL NUMBER TYPE.
+New function binary number ''as binary number'' as binary number.
+New variable b as binary number.
+Let b as binary number be b.
+Close context.
+
+// NATURAL NUMBERS.
+New type ''natural number''.
+New function ''0'' as natural number.
+New function ''1'' as natural number.
+New function ''2'' as natural number.
+New function ''3'' as natural number.
+New function ''4'' as natural number.
+New function ''5'' as natural number.
+New function ''6'' as natural number.
+New function ''7'' as natural number.
+New function ''8'' as natural number.
+New function ''9'' as natural number.
+New function natural number ''0'' as natural number.
+New function natural number ''1'' as natural number.
+New function natural number ''2'' as natural number.
+New function natural number ''3'' as natural number.
+New function natural number ''4'' as natural number.
+New function natural number ''5'' as natural number.
+New function natural number ''6'' as natural number.
+New function natural number ''7'' as natural number.
+New function natural number ''8'' as natural number.
+New function natural number ''9'' as natural number.
+
+// TYPE CAST TO ENFORCE NATURAL NUMBER TYPE.
+New function natural number ''as natural number'' as natural number.
+New variable n as natural number.
+Let n as natural number be n.
+Close context.
+
+// Standard numbers 0 and 1 are natural and not binary.
+See 0 as natural number preferred to different 0 as binary number.
+See 1 as natural number preferred to different 1 as binary number.
+
+
+// This number-append is necessary for division later.
+New function natural number ''@'' natural number as natural number.
+New variable varnat_a as natural number.
+New variable varnat_b as natural number.
+Let varnat_a @ 0 be varnat_a 0.
+Let varnat_a @ 1 be varnat_a 1.
+Let varnat_a @ 2 be varnat_a 2.
+Let varnat_a @ 3 be varnat_a 3.
+Let varnat_a @ 4 be varnat_a 4.
+Let varnat_a @ 5 be varnat_a 5.
+Let varnat_a @ 6 be varnat_a 6.
+Let varnat_a @ 7 be varnat_a 7.
+Let varnat_a @ 8 be varnat_a 8.
+Let varnat_a @ 9 be varnat_a 9.
+Let varnat_a @ (varnat_b 0) be (varnat_a @ varnat_b) 0.
+Let varnat_a @ (varnat_b 1) be (varnat_a @ varnat_b) 1.
+Let varnat_a @ (varnat_b 2) be (varnat_a @ varnat_b) 2.
+Let varnat_a @ (varnat_b 3) be (varnat_a @ varnat_b) 3.
+Let varnat_a @ (varnat_b 4) be (varnat_a @ varnat_b) 4.
+Let varnat_a @ (varnat_b 5) be (varnat_a @ varnat_b) 5.
+Let varnat_a @ (varnat_b 6) be (varnat_a @ varnat_b) 6.
+Let varnat_a @ (varnat_b 7) be (varnat_a @ varnat_b) 7.
+Let varnat_a @ (var...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-24 22:23:20
|
Revision: 1714
http://toss.svn.sourceforge.net/toss/?rev=1714&view=rev
Author: lukaszkaiser
Date: 2012-05-24 22:23:11 +0000 (Thu, 24 May 2012)
Log Message:
-----------
Code cleanup and tests in Term.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Makefile
trunk/Toss/Server/Tests.ml
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/BuiltinLang.mli
trunk/Toss/Term/Makefile
trunk/Toss/Term/ParseArc.ml
trunk/Toss/Term/ParseArc.mli
trunk/Toss/Term/Rewriting.ml
trunk/Toss/Term/Rewriting.mli
trunk/Toss/Term/SyntaxDef.ml
trunk/Toss/Term/SyntaxDef.mli
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/TRSTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/TermType.ml
trunk/Toss/Term/TermType.mli
trunk/Toss/Term/lib/core.trs
trunk/Toss/Term/lib/lists.trs
trunk/Toss/Term/tests/fo_formula.log
trunk/Toss/Term/tests/sasha_basic.log
trunk/Toss/Term/tests/sasha_basic.trs
trunk/Toss/www/reference/parser.tex
trunk/Toss/www/reference/simplification.tex
trunk/Toss/www/reference/syntax_definitions.tex
trunk/Toss/www/reference/terms.tex
trunk/Toss/www/reference/types.tex
Added Paths:
-----------
trunk/Toss/Term/BuiltinLangTest.ml
trunk/Toss/Term/ParseArcTest.ml
trunk/Toss/Term/RewritingTest.ml
trunk/Toss/Term/SyntaxDefTest.ml
trunk/Toss/Term/TermTest.ml
trunk/Toss/Term/TermTypeTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Formula/Aux.ml 2012-05-24 22:23:11 UTC (rev 1714)
@@ -45,10 +45,6 @@
if n < 0 then 0
else aux x 1 n
-let is_digit c =
- (c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') ||
- (c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9')
-
let is_space c = c = ' ' || c = '\n' || c = '\r' || c = '\t'
let strip_charprop f s =
@@ -230,6 +226,7 @@
(k0, [v0], []) tl in
List.rev ((k0,List.rev vs)::l)
+
let rec concat_foldr f l init =
match l with
| [] -> init
@@ -556,6 +553,23 @@
r
end
+let array_for_all2 f a1 a2 =
+ let len1, len2 = Array.length a1, Array.length a2 in
+ if len1 <> len2 then raise (Invalid_argument "Aux.array_for_all2") else
+ let rec fa2_rec i =
+ if i = len1 then true else
+ if (f a1.(i) a2.(i)) then fa2_rec (i+1) else false in
+ fa2_rec 0
+
+let array_fold_left2 f start a1 a2 =
+ let len1, len2 = Array.length a1, Array.length a2 in
+ if len1 <> len2 then raise (Invalid_argument "Aux.array_fold_left2") else
+ let rec fl2_rec acc i =
+ if i = len1 then acc else
+ fl2_rec (f acc a1.(i) a2.(i)) (i+1) in
+ fl2_rec start 0
+
+
let array_combine a b =
array_map2 (fun x y->x,y) a b
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Formula/Aux.mli 2012-05-24 22:23:11 UTC (rev 1714)
@@ -250,6 +250,13 @@
[Invalid_argument] if the arrays are of different lengths. *)
val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+(** For all on two arrays. *)
+val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+
+(** Fold-left on two arrays. *)
+val array_fold_left2 :
+ ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+
(** Zip two arrays into an array of pairs. Raises [Invalid_argument
"Aux.array_map2"] if the arrays are of different lengths. *)
val array_combine : 'a array -> 'b array -> ('a * 'b) array
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Formula/AuxIO.ml 2012-05-24 22:23:11 UTC (rev 1714)
@@ -52,6 +52,12 @@
if test_fname then f ()
) ENDIF
+let input_stdin_char () =
+ IFDEF JAVASCRIPT THEN (
+ failwith "no stdin in JS"
+ ) ELSE (
+ input_char stdin
+ ) ENDIF
let input_file fn_in =
let fn =
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Formula/AuxIO.mli 2012-05-24 22:23:11 UTC (rev 1714)
@@ -16,6 +16,9 @@
(** Get a backtrace as a string (native mode only). *)
val backtrace : unit -> string
+(** Input one character from standard input. Fails in JavaScript. *)
+val input_stdin_char : unit -> char
+
(** Input a file with given filename to a string. *)
val input_file : string -> string
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Makefile 2012-05-24 22:23:11 UTC (rev 1714)
@@ -108,7 +108,7 @@
EXTDEPS = caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo Formula/Resources.ml
-MKPARSED = ./TRSTest.native -c -f -l "Term/lib"
+MKPARSED = ./TRSTest.native -l "Term/lib"
%.trs.parsed: %.trs
make ./Term/TRSTest.native
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Server/Tests.ml 2012-05-24 22:23:11 UTC (rev 1714)
@@ -37,6 +37,12 @@
]
let term_tests = "Term", [
+ "TermTypeTest", [TermTypeTest.tests];
+ "SyntaxDefTest", [SyntaxDefTest.tests];
+ "BuiltinLangTest", [BuiltinLangTest.tests];
+ "TermTest", [TermTest.tests];
+ "RewritingTest", [RewritingTest.tests];
+ "ParseArcTest", [ParseArcTest.tests];
"TRSTest", [TRSTest.tests; TRSTest.bigtests];
]
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-05-24 22:23:11 UTC (rev 1714)
@@ -1,291 +1,291 @@
-(* Basic Built-in Language Syntax for Speagram. *)
+(* Basic Built-in TRS Language Syntax. *)
-open TermType;;
-open SyntaxDef;;
+open TermType
+open SyntaxDef
-(* ---------------- BASIC TYPES AND SYNTAX DEFS ----------------------- *)
-let bit_sd = SDtype [Str "bit"];;
-let bit_name = name_of_sd bit_sd;;
-let bit_tp = type_of_sd bit_sd;;
+(* --- Basic Types and Syntax Definitions --- *)
-let bit_0_cons_sd = SDfun ([Str "bit"; Str "0"], bit_tp);;
-let bit_0_cons_name = name_of_sd bit_0_cons_sd;;
-let bit_1_cons_sd = SDfun ([Str "bit"; Str "1"], bit_tp);;
-let bit_1_cons_name = name_of_sd bit_1_cons_sd;;
+let bit_sd = SDtype [Str "bit"]
+let bit_name = name_of_sd bit_sd
+let bit_tp = type_of_sd bit_sd
-let char_sd = SDtype [Str "char"];;
-let char_name = name_of_sd char_sd;;
-let char_tp = type_of_sd char_sd;;
+let bit_0_cons_sd = SDfun ([Str "bit"; Str "0"], bit_tp)
+let bit_0_cons_name = name_of_sd bit_0_cons_sd
+let bit_1_cons_sd = SDfun ([Str "bit"; Str "1"], bit_tp)
+let bit_1_cons_name = name_of_sd bit_1_cons_sd
+let char_sd = SDtype [Str "char"]
+let char_name = name_of_sd char_sd
+let char_tp = type_of_sd char_sd
+
let char_cons_sd = SDfun ([Str "char"; Str "code"; Tp bit_tp; Tp bit_tp;
- Tp bit_tp; Tp bit_tp; Tp bit_tp; Tp bit_tp; Tp bit_tp; Tp bit_tp], char_tp);;
-let char_cons_name = name_of_sd char_cons_sd;;
+ Tp bit_tp; Tp bit_tp; Tp bit_tp; Tp bit_tp; Tp bit_tp; Tp bit_tp], char_tp)
+let char_cons_name = name_of_sd char_cons_sd
-let term_type_sd = SDtype [Str "term"; Str "type"];;
-let term_type_name = name_of_sd term_type_sd;;
-let term_type_tp = type_of_sd term_type_sd;;
+let term_type_sd = SDtype [Str "term"; Str "type"]
+let term_type_name = name_of_sd term_type_sd
+let term_type_tp = type_of_sd term_type_sd
-let list_sd = SDtype [Tp term_type_tp; Str "list"];;
-let list_name = name_of_sd list_sd;;
-let list_tp t = Term_type (list_name, [|t|]);;
-let list_tp_a = list_tp (Type_var "a");;
+let list_sd = SDtype [Tp term_type_tp; Str "list"]
+let list_name = name_of_sd list_sd
+let list_tp t = Term_type (list_name, [|t|])
+let list_tp_a = list_tp (Type_var "a")
-let list_nil_sd = SDfun ([Str "["; Str "]"], list_tp_a);;
-let list_nil_name = name_of_sd list_nil_sd;;
+let list_nil_sd = SDfun ([Str "["; Str "]"], list_tp_a)
+let list_nil_name = name_of_sd list_nil_sd
let list_cons_sd = SDfun ([Tp (Type_var "a"); Str ","; Tp list_tp_a],
- list_tp_a);;
-let list_cons_name = name_of_sd list_cons_sd;;
+ list_tp_a)
+let list_cons_name = name_of_sd list_cons_sd
-let string_sd = SDtype [Str "string"];;
-let string_name = name_of_sd string_sd;;
-let string_tp = type_of_sd string_sd;;
+let string_sd = SDtype [Str "string"]
+let string_name = name_of_sd string_sd
+let string_tp = type_of_sd string_sd
let string_cons_sd = SDfun ([Str "string"; Str "from"; Tp (list_tp char_tp)],
- string_tp);;
-let string_cons_name = name_of_sd string_cons_sd;;
+ string_tp)
+let string_cons_name = name_of_sd string_cons_sd
-let boolean_sd = SDtype [Str "boolean"];;
-let boolean_name = name_of_sd boolean_sd;;
-let boolean_tp = type_of_sd boolean_sd;;
+let boolean_sd = SDtype [Str "boolean"]
+let boolean_name = name_of_sd boolean_sd
+let boolean_tp = type_of_sd boolean_sd
-let boolean_true_sd = SDfun ([Str "true"], boolean_tp);;
-let boolean_true_name = name_of_sd boolean_true_sd;;
-let boolean_false_sd = SDfun ([Str "false"], boolean_tp);;
-let boolean_false_name = name_of_sd boolean_false_sd;;
+let boolean_true_sd = SDfun ([Str "true"], boolean_tp)
+let boolean_true_name = name_of_sd boolean_true_sd
+let boolean_false_sd = SDfun ([Str "false"], boolean_tp)
+let boolean_false_name = name_of_sd boolean_false_sd
let ternary_truth_value_sd =
- SDtype ([Str "ternary"; Str "truth"; Str "value"]);;
-let ternary_truth_value_name = name_of_sd ternary_truth_value_sd;;
-let ternary_truth_value_tp = type_of_sd ternary_truth_value_sd;;
+ SDtype ([Str "ternary"; Str "truth"; Str "value"])
+let ternary_truth_value_name = name_of_sd ternary_truth_value_sd
+let ternary_truth_value_tp = type_of_sd ternary_truth_value_sd
-let ternary_true_sd = SDfun ([Str "true"], ternary_truth_value_tp);;
-let ternary_true_name = unique_name_of_sd ternary_true_sd [boolean_true_name];;
-let ternary_unknown_sd = SDfun ([Str "unknown"], ternary_truth_value_tp);;
-let ternary_unknown_name = name_of_sd ternary_unknown_sd;;
-let ternary_false_sd = SDfun ([Str "false"], ternary_truth_value_tp);;
+let ternary_true_sd = SDfun ([Str "true"], ternary_truth_value_tp)
+let ternary_true_name = unique_name_of_sd ternary_true_sd [boolean_true_name]
+let ternary_unknown_sd = SDfun ([Str "unknown"], ternary_truth_value_tp)
+let ternary_unknown_name = name_of_sd ternary_unknown_sd
+let ternary_false_sd = SDfun ([Str "false"], ternary_truth_value_tp)
let ternary_false_name =
- unique_name_of_sd ternary_false_sd [boolean_false_name];;
+ unique_name_of_sd ternary_false_sd [boolean_false_name]
-let term_type_var_sd = SDfun ([Str "?"; Tp string_tp], term_type_tp);;
-let term_type_var_name = name_of_sd term_type_var_sd;;
+let term_type_var_sd = SDfun ([Str "?"; Tp string_tp], term_type_tp)
+let term_type_var_name = name_of_sd term_type_var_sd
let term_type_cons_sd = SDfun ([Str "type"; Tp string_tp; Str ":";
- Tp (list_tp term_type_tp)], term_type_tp);;
-let term_type_cons_name = name_of_sd term_type_cons_sd;;
+ Tp (list_tp term_type_tp)], term_type_tp)
+let term_type_cons_name = name_of_sd term_type_cons_sd
let term_type_fun_sd = SDfun ([Str "funtype"; Tp (list_tp term_type_tp);
- Str "-"; Str ">"; Tp term_type_tp], term_type_tp);;
-let term_type_fun_name = name_of_sd term_type_fun_sd;;
+ Str "-"; Str ">"; Tp term_type_tp], term_type_tp)
+let term_type_fun_name = name_of_sd term_type_fun_sd
-(* -------------------- SYNTAX ELEMENTS AND DEFINITIONS ------------------- *)
+(* --- Syntax Elements and Definitions --- *)
+let syntax_element_sd = SDtype [Str "syntax"; Str "element"]
+let syntax_element_name = name_of_sd syntax_element_sd
+let syntax_element_tp = type_of_sd syntax_element_sd
-let syntax_element_sd = SDtype [Str "syntax"; Str "element"];;
-let syntax_element_name = name_of_sd syntax_element_sd;;
-let syntax_element_tp = type_of_sd syntax_element_sd;;
-
let syntax_element_str_sd = SDfun (
- [Str "'"; Str "'"; Tp string_tp; Str "'"; Str "'"], syntax_element_tp);;
-let syntax_element_str_name = name_of_sd syntax_element_str_sd;;
-let syntax_element_tp_sd = SDfun ([Tp term_type_tp], syntax_element_tp);;
-let syntax_element_tp_name = name_of_sd syntax_element_tp_sd;;
+ [Str "'"; Str "'"; Tp string_tp; Str "'"; Str "'"], syntax_element_tp)
+let syntax_element_str_name = name_of_sd syntax_element_str_sd
+let syntax_element_tp_sd = SDfun ([Tp term_type_tp], syntax_element_tp)
+let syntax_element_tp_name = name_of_sd syntax_element_tp_sd
let syntax_element_list_sd =
- SDtype [Str "syntax"; Str "element"; Str "sequence"];;
-let syntax_element_list_name = name_of_sd syntax_element_list_sd;;
-let syntax_element_list_tp = type_of_sd syntax_element_list_sd;;
+ SDtype [Str "syntax"; Str "element"; Str "sequence"]
+let syntax_element_list_name = name_of_sd syntax_element_list_sd
+let syntax_element_list_tp = type_of_sd syntax_element_list_sd
let syntax_element_list_elem_sd =
- SDfun ([Tp syntax_element_tp], syntax_element_list_tp);;
+ SDfun ([Tp syntax_element_tp], syntax_element_list_tp)
let syntax_element_list_elem_name =
- unique_name_of_sd syntax_element_list_elem_sd [syntax_element_tp_name];;
+ unique_name_of_sd syntax_element_list_elem_sd [syntax_element_tp_name]
let syntax_element_list_cons_sd = SDfun ([Tp syntax_element_tp;
- Tp syntax_element_list_tp], syntax_element_list_tp);;
-let syntax_element_list_cons_name = name_of_sd syntax_element_list_cons_sd;;
+ Tp syntax_element_list_tp], syntax_element_list_tp)
+let syntax_element_list_cons_name = name_of_sd syntax_element_list_cons_sd
-let syntax_definition_sd = SDtype [Str "syntax"; Str "definition"];;
-let syntax_definition_name = name_of_sd syntax_definition_sd;;
-let syntax_definition_tp = type_of_sd syntax_definition_sd;;
+let syntax_definition_sd = SDtype [Str "syntax"; Str "definition"]
+let syntax_definition_name = name_of_sd syntax_definition_sd
+let syntax_definition_tp = type_of_sd syntax_definition_sd
let syntax_definition_type_sd =
- SDfun ([Str "type"; Tp syntax_element_list_tp], syntax_definition_tp);;
-let syntax_definition_type_name = name_of_sd syntax_definition_type_sd;;
+ SDfun ([Str "type"; Tp syntax_element_list_tp], syntax_definition_tp)
+let syntax_definition_type_name = name_of_sd syntax_definition_type_sd
let syntax_definition_fun_sd =
SDfun ([Str "function"; Tp syntax_element_list_tp; Str "as"; Tp term_type_tp],
- syntax_definition_tp);;
-let syntax_definition_fun_name = name_of_sd syntax_definition_fun_sd;;
+ syntax_definition_tp)
+let syntax_definition_fun_name = name_of_sd syntax_definition_fun_sd
let syntax_definition_var_sd =
SDfun ([Str "variable"; Tp syntax_element_list_tp;Str "as"; Tp term_type_tp],
- syntax_definition_tp);;
-let syntax_definition_var_name = name_of_sd syntax_definition_var_sd;;
+ syntax_definition_tp)
+let syntax_definition_var_name = name_of_sd syntax_definition_var_sd
-(* ------------- SYNTAX DEFINITIONS RELATED TO TERMS ---------------- *)
+(* --- Syntax Definitions related to Terms --- *)
-let term_sd = SDtype [Str "term"];;
-let term_name = name_of_sd term_sd;;
-let term_tp = type_of_sd term_sd;;
+let term_sd = SDtype [Str "term"]
+let term_name = name_of_sd term_sd
+let term_tp = type_of_sd term_sd
let term_var_cons_sd = SDfun ([Str "var"; Tp string_tp; Str ":";
Tp term_type_tp; Str ":"; Tp (list_tp bit_tp);
- Str "("; Tp (list_tp term_tp); Str ")"], term_tp);;
-let term_var_cons_name = name_of_sd term_var_cons_sd;;
+ Str "("; Tp (list_tp term_tp); Str ")"], term_tp)
+let term_var_cons_name = name_of_sd term_var_cons_sd
let term_term_cons_sd = SDfun ([Str "term"; Tp string_tp; Str "(";
- Tp (list_tp term_tp); Str ")"], term_tp);;
-let term_term_cons_name = name_of_sd term_term_cons_sd;;
+ Tp (list_tp term_tp); Str ")"], term_tp)
+let term_term_cons_name = name_of_sd term_term_cons_sd
-let rewrite_rule_sd = SDtype ([Str "rewrite"; Str "rule"]);;
-let rewrite_rule_name = name_of_sd rewrite_rule_sd;;
-let rewrite_rule_tp = type_of_sd rewrite_rule_sd;;
+let rewrite_rule_sd = SDtype ([Str "rewrite"; Str "rule"])
+let rewrite_rule_name = name_of_sd rewrite_rule_sd
+let rewrite_rule_tp = type_of_sd rewrite_rule_sd
let rewrite_rule_cons_sd = SDfun ([Str "rewrite"; Tp term_tp;
- Str "to"; Tp term_tp], rewrite_rule_tp);;
-let rewrite_rule_cons_name = name_of_sd rewrite_rule_cons_sd;;
+ Str "to"; Tp term_tp], rewrite_rule_tp)
+let rewrite_rule_cons_name = name_of_sd rewrite_rule_cons_sd
let input_rewrite_rule_sd = SDtype ([Str "input"; Str "rewrite";
- Str "rule"; Str "of"; Tp term_type_tp]);;
-let input_rewrite_rule_name = name_of_sd input_rewrite_rule_sd;;
-let input_rewrite_rule_tp = type_of_sd input_rewrite_rule_sd;;
+ Str "rule"; Str "of"; Tp term_type_tp])
+let input_rewrite_rule_name = name_of_sd input_rewrite_rule_sd
+let input_rewrite_rule_tp = type_of_sd input_rewrite_rule_sd
let let_be_sd = SDfun ([Str "let"; Tp (Type_var "a_1"); Str "be";
- Tp (Type_var "a_1")], input_rewrite_rule_tp);;
-let let_be_name = name_of_sd let_be_sd;;
+ Tp (Type_var "a_1")], input_rewrite_rule_tp)
+let let_be_name = name_of_sd let_be_sd
let priority_input_rewrite_rule_sd = SDtype ([Str "priority";
- Str "input"; Str "rewrite"; Str "rule"; Str "of"; Tp term_type_tp]);;
+ Str "input"; Str "rewrite"; Str "rule"; Str "of"; Tp term_type_tp])
let priority_input_rewrite_rule_name =
- name_of_sd priority_input_rewrite_rule_sd;;
+ name_of_sd priority_input_rewrite_rule_sd
let priority_input_rewrite_rule_tp =
- type_of_sd priority_input_rewrite_rule_sd;;
+ type_of_sd priority_input_rewrite_rule_sd
let let_major_be_sd = SDfun ([Str "let"; Str "major"; Tp (Type_var "a_1");
- Str "be"; Tp (Type_var "a_1")], priority_input_rewrite_rule_tp);;
-let let_major_be_name = name_of_sd let_major_be_sd;;
+ Str "be"; Tp (Type_var "a_1")], priority_input_rewrite_rule_tp)
+let let_major_be_name = name_of_sd let_major_be_sd
-let fun_definition_sd = SDtype ([Str "fun"; Str "definition"]);;
-let fun_definition_name = name_of_sd fun_definition_sd;;
-let fun_definition_tp = type_of_sd fun_definition_sd;;
+let fun_definition_sd = SDtype ([Str "fun"; Str "definition"])
+let fun_definition_name = name_of_sd fun_definition_sd
+let fun_definition_tp = type_of_sd fun_definition_sd
let fun_definition_cons_sd = SDfun ([Str "fun"; Tp string_tp;
Str "from"; Tp (list_tp term_type_tp); Str "to"; Tp term_type_tp],
- fun_definition_tp);;
-let fun_definition_cons_name = name_of_sd fun_definition_cons_sd;;
+ fun_definition_tp)
+let fun_definition_cons_name = name_of_sd fun_definition_cons_sd
-let type_definition_sd = SDtype ([Str "type"; Str "definition"]);;
-let type_definition_name = name_of_sd type_definition_sd;;
-let type_definition_tp = type_of_sd type_definition_sd;;
+let type_definition_sd = SDtype ([Str "type"; Str "definition"])
+let type_definition_name = name_of_sd type_definition_sd
+let type_definition_tp = type_of_sd type_definition_sd
let type_of_sd_sd = SDfun ([Str "type"; Str "of"; Tp term_type_tp],
- type_definition_tp);;
-let type_of_name = name_of_sd type_of_sd_sd;;
+ type_definition_tp)
+let type_of_name = name_of_sd type_of_sd_sd
-(* ---------------------- EXCEPTION TYPE ----------------------------- *)
+(* --- The Exception Type --- *)
-let exception_cl_sd = SDtype [Tp term_type_tp; Str "exception"];;
-let exception_cl_name = name_of_sd exception_cl_sd;;
-let exception_cl_tp t = Term_type (exception_cl_name, [|t|]);;
+let exception_cl_sd = SDtype [Tp term_type_tp; Str "exception"]
+let exception_cl_name = name_of_sd exception_cl_sd
+let exception_cl_tp t = Term_type (exception_cl_name, [|t|])
let exception_sd =
SDfun ([Str "!"; Str "!"; Tp (Type_var "a"); Str "!";Str "!";],
- exception_cl_tp (Type_var "other_than_a!"));;
-let exception_name = name_of_sd exception_sd;;
+ exception_cl_tp (Type_var "other_than_a!"))
+let exception_name = name_of_sd exception_sd
let exn_ok_sd =
SDfun ([Str "+"; Str "+"; Tp (Type_var "a"); Str "+";Str "+";],
- exception_cl_tp (Type_var "a"));; (* Here it should be a! *)
-let exn_ok_name = name_of_sd exception_sd;;
+ exception_cl_tp (Type_var "a")) (* Here it should be a! *)
+let exn_ok_name = name_of_sd exception_sd
-(* ----------- SPECIAL FUNCTIONS RECOGNIZED BY NORMALISATION --------- *)
+(* --- Special functions recognized during Normalisation --- *)
let brackets_sd = SDfun ([Str "("; Tp (Type_var "b"); Str ")"],
- Type_var "b");;
-let brackets_name = name_of_sd brackets_sd;;
+ Type_var "b")
+let brackets_name = name_of_sd brackets_sd
let verbatim_sd =
- SDfun ([Str "<"; Str "|"; Tp (Type_var "b"); Str "|"; Str ">"], Type_var "b");;
-let verbatim_name = name_of_sd verbatim_sd;;
+ SDfun ([Str "<"; Str "|"; Tp (Type_var "b"); Str "|"; Str ">"], Type_var "b")
+let verbatim_name = name_of_sd verbatim_sd
let if_then_else_sd = SDfun ([Str "if"; Tp boolean_tp; Str "then";
- Tp (Type_var "a"); Str "else"; Tp (Type_var "a")], Type_var "a");;
-let if_then_else_name = name_of_sd if_then_else_sd;;
+ Tp (Type_var "a"); Str "else"; Tp (Type_var "a")], Type_var "a")
+let if_then_else_name = name_of_sd if_then_else_sd
let eq_bool_sd = SDfun ([Tp (Type_var "a"); Str "="; Tp (Type_var "a")],
- boolean_tp);;
-let eq_bool_name = name_of_sd eq_bool_sd;;
+ boolean_tp)
+let eq_bool_name = name_of_sd eq_bool_sd
-(* ----------- SYNATAX DEFINITIONS OF SPECIAL META FUNCTIONS ---------- *)
+(* --- Syntax Definitions for special meta-functions --- *)
let code_as_term_sd = SDfun ([Str "code"; Tp (Type_var "a");
- Str "as"; Str "term"], term_tp);;
-let code_as_term_name = name_of_sd code_as_term_sd;;
+ Str "as"; Str "term"], term_tp)
+let code_as_term_name = name_of_sd code_as_term_sd
let get_type_definitions_sd = SDfun ([Str "get"; Str "type"; Str "definitions"],
- list_tp type_definition_tp);;
-let get_type_definitions_name = name_of_sd get_type_definitions_sd;;
+ list_tp type_definition_tp)
+let get_type_definitions_name = name_of_sd get_type_definitions_sd
let get_fun_definitions_sd = SDfun ([Str "get"; Str "fun"; Str "definitions"],
- list_tp fun_definition_tp);;
-let get_fun_definitions_name = name_of_sd get_fun_definitions_sd;;
+ list_tp fun_definition_tp)
+let get_fun_definitions_name = name_of_sd get_fun_definitions_sd
-(* ---------------- SYSTEM COMMANDS SYNTAX DEFINITIONS ----------------- *)
+(* --- System Commands and their Syntax Definitions --- *)
-let outside_paths_sd = SDtype ([Str "outside"; Str "paths"]);;
-let outside_paths_name = name_of_sd outside_paths_sd;;
-let outside_paths_tp = type_of_sd outside_paths_sd;;
+let outside_paths_sd = SDtype ([Str "outside"; Str "paths"])
+let outside_paths_name = name_of_sd outside_paths_sd
+let outside_paths_tp = type_of_sd outside_paths_sd
let path_library_sd = SDfun ([Str "library"; Str ":"; Str "/";
- Tp string_tp], outside_paths_tp);;
-let path_library_name = name_of_sd path_library_sd;;
+ Tp string_tp], outside_paths_tp)
+let path_library_name = name_of_sd path_library_sd
let path_file_sd = SDfun ([Str "file"; Str ":"; Str "/";
- Tp string_tp], outside_paths_tp);;
-let path_file_name = name_of_sd path_file_sd;;
+ Tp string_tp], outside_paths_tp)
+let path_file_name = name_of_sd path_file_sd
-let load_command_sd = SDtype ([Str "load"; Str "command"]);;
-let load_command_name = name_of_sd load_command_sd;;
-let load_command_tp = type_of_sd load_command_sd;;
+let load_command_sd = SDtype ([Str "load"; Str "command"])
+let load_command_name = name_of_sd load_command_sd
+let load_command_tp = type_of_sd load_command_sd
let load_file_sd = SDfun ([Str "load"; Str "state";
- Tp outside_paths_tp], load_command_tp);;
-let load_file_name = name_of_sd load_file_sd;;
+ Tp outside_paths_tp], load_command_tp)
+let load_file_name = name_of_sd load_file_sd
let sys_commands_sd = SDtype ([Str "system"; Str "commands"; Str "of";
- Tp term_type_tp]);;
-let sys_commands_name = name_of_sd sys_commands_sd;;
-let sys_commands_tp = type_of_sd sys_commands_sd;;
+ Tp term_type_tp])
+let sys_commands_name = name_of_sd sys_commands_sd
+let sys_commands_tp = type_of_sd sys_commands_sd
-let close_context_sd = SDfun ([Str "close"; Str "context"], sys_commands_tp);;
-let close_context_name = name_of_sd close_context_sd;;
+let close_context_sd = SDfun ([Str "close"; Str "context"], sys_commands_tp)
+let close_context_name = name_of_sd close_context_sd
-let remove_command_sd = SDtype ([Str "remove"; Str "command"]);;
-let remove_command_name = name_of_sd remove_command_sd;;
-let remove_command_tp = type_of_sd remove_command_sd;;
+let remove_command_sd = SDtype ([Str "remove"; Str "command"])
+let remove_command_name = name_of_sd remove_command_sd
+let remove_command_tp = type_of_sd remove_command_sd
let system_remove_sd = SDfun ([Str "system"; Str "remove";
- Tp (list_tp string_tp)], remove_command_tp);;
-let system_remove_name = name_of_sd system_remove_sd;;
+ Tp (list_tp string_tp)], remove_command_tp)
+let system_remove_name = name_of_sd system_remove_sd
let preprocess_sd =
- SDfun ([Str "#"; Str "#"; Str "#"; Tp (Type_var "p")], Type_var "q");;
-let preprocess_name = name_of_sd preprocess_sd;;
+ SDfun ([Str "#"; Str "#"; Str "#"; Tp (Type_var "p")], Type_var "q")
+let preprocess_name = name_of_sd preprocess_sd
let preferred_to_sd =
SDfun ([Tp term_tp; Str "parsed"; Str "preferred"; Str "to"; Tp term_tp],
- ternary_truth_value_tp);;
-let preferred_to_name = name_of_sd preferred_to_sd;;
+ ternary_truth_value_tp)
+let preferred_to_name = name_of_sd preferred_to_sd
let additional_xslt_sd =
- SDfun ([Str "additional"; Str "xslt"], string_tp);;
-let additional_xslt_name = name_of_sd additional_xslt_sd;;
+ SDfun ([Str "additional"; Str "xslt"], string_tp)
+let additional_xslt_name = name_of_sd additional_xslt_sd
let string_quote_sd =
- SDfun ([Str "\""; Tp string_tp; Str "\""], string_tp);;
-let string_quote_name = name_of_sd string_quote_sd;;
+ SDfun ([Str "\""; Tp string_tp; Str "\""], string_tp)
+let string_quote_name = name_of_sd string_quote_sd
Modified: trunk/Toss/Term/BuiltinLang.mli
===================================================================
--- trunk/Toss/Term/BuiltinLang.mli 2012-05-21 22:07:00 UTC (rev 1713)
+++ trunk/Toss/Term/BuiltinLang.mli 2012-05-24 22:23:11 UTC (rev 1714)
@@ -1,204 +1,205 @@
-(* Signature for Built-in Langauge Definitions. *)
+(** Basic Built-in TRS Language Syntax *)
-open SyntaxDef;;
+open SyntaxDef
-(* ---------------- BASIC TYPES AND SYNTAX DEFS ----------------------- *)
+(** {2 Basic Types and Syntax Definitions} *)
-val bit_sd : syntax_def;;
-val bit_name : string;;
-val bit_tp : TermType.term_type;;
-val bit_0_cons_sd : syntax_def;;
-val bit_0_cons_name : string;;
-val bit_1_cons_sd : syntax_def;;
-val bit_1_cons_name : string;;
+val bit_sd : syntax_def
+val bit_name : string
+val bit_tp : TermType.term_type
+val bit_0_cons_sd : syntax_def
+val bit_0_cons_name : string
+val bit_1_cons_sd : syntax_def
+val bit_1_cons_name : string
-val char_sd : syntax_def;;
-val char_name : string;;
-val char_tp : TermType.term_type;;
-val char_cons_sd : syntax_def;;
-val char_cons_name : string;;
+val char_sd : syntax_def
+val char_name : string
+val char_tp : TermType.term_type
+val char_cons_sd : syntax_def
+val char_cons_name : string
-val term_type_sd : syntax_def;;
-val term_type_name : string;;
-val term_type_tp : TermType.term_type;;
+val term_type_sd : syntax_def
+val term_type_name : string
+val term_type_tp : TermType.term_type
-val list_sd : syntax_def;;
-val list_name : string;;
-val list_tp : TermType.term_type -> TermType.term_type;;
-val list_tp_a : TermType.term_type;;
-val list_nil_sd : syntax_def;;
-val list_nil_name : string;;
-val list_cons_sd : syntax_def;;
-val list_cons_name : string;;
+val list_sd : syntax_def
+val list_name : string
+val list_tp : TermType.term_type -> TermType.term_type
+val list_tp_a : TermType.term_type
+val list_nil_sd : syntax_def
+val list_nil_name : string
+val list_cons_sd : syntax_def
+val list_cons_name : string
-val string_sd : syntax_def;;
-val string_name : string;;
-val string_tp : TermType.term_type;;
-val string_cons_sd : syntax_def;;
-val string_cons_name : string;;
+val string_sd : syntax_def
+val string_name : string
+val string_tp : TermType.term_type
+val string_cons_sd : syntax_def
+val string_cons_name : string
-val boolean_sd : syntax_def;;
-val boolean_name : string;;
-val boolean_tp : TermType.term_type;;
-val boolean_true_sd : syntax_def;;
-val boolean_true_name : string;;
-val boolean_false_sd : syntax_def;;
-val boolean_false_name : string;;
+val boolean_sd : syntax_def
+val boolean_name : string
+val boolean_tp : TermType.term_type
+val boolean_true_sd : syntax_def
+val boolean_true_name : string
+val boolean_false_sd : syntax_def
+val boolean_false_name : string
-val ternary_truth_value_sd : syntax_def;;
-val ternary_truth_value_name : string;;
-val ternary_truth_value_tp : TermType.term_type;;
-val ternary_true_sd : syntax_def;;
-val ternary_true_name : string;;
-val ternary_unknown_sd : syntax_def;;
-val ternary_unknown_name : string;;
-val ternary_false_sd : syntax_def;;
-val ternary_false_name : string;;
+val ternary_truth_value_sd : syntax_def
+val ternary_truth_value_name : string
+val ternary_truth_value_tp : TermType.term_type
+val ternary_true_sd : syntax_def
+val ternary_true_name : string
+val ternary_unknown_sd : syntax_def
+val ternary_unknown_name : string
+val ternary_false_sd : syntax_def
+val ternary_false_name : string
-val term_type_var_sd : syntax_def;;
-val term_type_var_name : string...
[truncated message content] |
|
From: <luk...@us...> - 2012-05-27 21:18:11
|
Revision: 1716
http://toss.svn.sourceforge.net/toss/?rev=1716&view=rev
Author: lukaszkaiser
Date: 2012-05-27 21:18:03 +0000 (Sun, 27 May 2012)
Log Message:
-----------
Defining structures using term rewriting systems and syntax.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/Term/BuiltinLang.ml
trunk/Toss/Term/BuiltinLang.mli
trunk/Toss/Term/TRS.ml
trunk/Toss/Term/TRS.mli
trunk/Toss/Term/TRSTest.ml
trunk/Toss/Term/Term.ml
trunk/Toss/Term/Term.mli
trunk/Toss/Term/lib/arithmetics.trs
trunk/Toss/Term/lib/basic.trs
trunk/Toss/Term/tests/short_checks.log
trunk/Toss/Term/tests/short_checks.trs
trunk/Toss/www/codebasics.xml
trunk/Toss/www/index.xml
trunk/Toss/www/ocaml.xml
trunk/Toss/www/pub/fmt12_slides.pdf
trunk/Toss/www/upload_sourceforge.sh
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Makefile 2012-05-27 21:18:03 UTC (rev 1716)
@@ -20,8 +20,8 @@
RELEASE=0.8
Release: TossServer doc
- rm -f *~ MenhirLib/*~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
- Learn/*~ Language/*~ Server/*~ www/*~ WebClient/~
+ rm -f *~ MenhirLib/*~ Formula/*~ Term/*~ Solver/*~ Arena/*~ Play/*~ \
+ GGP/*~ Learn/*~ Server/*~ www/*~ WebClient/~
make -C www/reference
make -C www
make -C .
@@ -135,17 +135,17 @@
FormulaINCSatINC=MenhirLib,Formula
FormulaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll
-SolverINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
-SolverINCRealQuantElimINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
-TermINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
-ArenaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term
-PlayINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena
-LearnINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena
-GGPINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play
-ServerINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play,GGP,Learn
-ClientINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play,GGP,Learn,Server
+TermINC=Formula,Term
+SolverINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
+SolverINCRealQuantElimINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
+ArenaINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver
+PlayINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
+LearnINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
+GGPINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play
+ServerINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn
+ClientINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
-.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Term,Arena,Play,GGP,Learn,Server
+.INC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
%.native: %.ml $(EXTDEPS)
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
@@ -276,8 +276,8 @@
clean:
ocamlbuild -clean
- rm -f Client/JsHandler.js
+ rm -f Client/*~ Client/JsHandler.js
rm -f *.cmx *.cmi *.o *.cmo *.a *.cmxa *.cma *.annot *~ TossServer
rm -f Formula/*~ Solver/*~ Arena/*~ Learn/*~ Play/*~ GGP/*~ Server/*~
rm -f caml_extensions/*.cmo caml_extensions/*.cmi Formula/Resources.ml
- rm -f Term/lib/*.trs.parsed
+ rm -f Term/*~ Term/lib/*.trs.parsed
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Solver/Structure.ml 2012-05-27 21:18:03 UTC (rev 1716)
@@ -213,6 +213,7 @@
else if e = -1 then add_new_elem struc ~name ()
else {struc with elements = Elems.add e struc.elements}, e
+
(* --------- ADDING RELATION TUPLES POSSIBLY WITH NAMED ELEMENTS ---------- *)
(* Ensure relation named [rn] exists in [struc], check arity, add the
@@ -511,6 +512,28 @@
let clear_fun struc fn =
{ struc with functions = StringMap.remove fn struc.functions }
+(* --- Structure operations by TRS --- *)
+
+let trs_set_struc s = function
+ | ("addrel", te_rel, te_arglist) ->
+ let rname = Term.decode_string te_rel in
+ let args = Term.decode_list Term.term_to_string te_arglist in
+ let (struc, args) = List.fold_left (fun (st, a) e ->
+ let (s1, i) = find_or_new_elem st e in (s1, i :: a)) (s, []) args in
+ add_rel struc rname (Array.of_list (List.rev args))
+ | (str, te, arg) when String.length str > 3 && String.sub str 0 3 = "fun" ->
+ let fname = String.sub str 3 ((String.length str) - 3) in
+ let (struc, i) = find_or_new_elem s (Term.term_to_string te) in
+ let v = Term.decode_bit_list arg in
+ add_fun struc fname (i, float v)
+ | _-> raise (Term.DECODE "Structure.trs_set_struc not a structure update set")
+
+let struc_from_trs str =
+ let (o, trs, _) = TRS.run_shell_str str in
+ let svals = TRS.set_vals_of_sys trs in
+ (o, List.fold_left trs_set_struc (empty_structure ()) svals)
+
+
(* ------------------------ PRINTING STRUCTURES ----------------------------- *)
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Solver/Structure.mli 2012-05-27 21:18:03 UTC (rev 1716)
@@ -273,7 +273,12 @@
(** Differing relations (used in solver cache) *)
val diffrels_struc: structure -> structure -> string list option
+(** {2 Creating a structure from a TRS string} *)
+(** Parse the TRS string, output messages and the resulting structure. *)
+val struc_from_trs : string -> string * structure
+
+
(** {2 Parser Helpers} *)
exception Board_parse_error of string
Modified: trunk/Toss/Solver/StructureTest.ml
===================================================================
--- trunk/Toss/Solver/StructureTest.ml 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Solver/StructureTest.ml 2012-05-27 21:18:03 UTC (rev 1716)
@@ -351,6 +351,26 @@
\"";
);
+ "struc from trs" >::
+ (fun () ->
+ let s = "
+ Load state library:/basic.
+ New function ''id'' natural number as natural number.
+ New variable n as natural number.
+ Let id n be n.
+ Elements from 0 to 5 at id {}, id {}.
+ New function ''succ'' natural number as natural number list.
+ Let succ n be n, n+1.
+ Relation R on from 0 to 4 given by succ {}.
+ " in
+ let (_, st) = struc_from_trs s in
+ assert_equal ~printer:(fun x -> x)
+ ("[F0_0\\, F1_0\\, F2, F3, F4, F5 | R {(F0_0\\, F1_0\\); (F1_0\\, F2);"^
+ " (F2, F3); (F3, F4); (F4, F5)} | x {F0_0\\->0., F1_0\\->1.," ^
+ " F2->2., F3->3., F4->4., F5->5.}; y {F0_0\\->0., F1_0\\->1.," ^
+ " F2->2., F3->3., F4->4., F5->5.}]") (Structure.str st);
+ );
+
"sprint simple" >::
(fun () ->
test_sprint
Modified: trunk/Toss/Term/BuiltinLang.ml
===================================================================
--- trunk/Toss/Term/BuiltinLang.ml 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Term/BuiltinLang.ml 2012-05-27 21:18:03 UTC (rev 1716)
@@ -271,7 +271,15 @@
Tp (list_tp string_tp)], remove_command_tp)
let system_remove_name = name_of_sd system_remove_sd
+let set_command_sd = SDtype ([Str "set"; Str "command"])
+let set_command_name = name_of_sd set_command_sd
+let set_command_tp = type_of_sd set_command_sd
+let set_prop_sd = SDfun ([Str "set"; Tp (string_tp); Str "of";
+ Tp (Type_var "a"); Str "to"; Tp (Type_var "b")], set_command_tp)
+let set_prop_name = name_of_sd set_prop_sd
+
+
let preprocess_sd =
SDfun ([Str "#"; Str "#"; Str "#"; Tp (Type_var "p")], Type_var "q")
let preprocess_name = name_of_sd preprocess_sd
Modified: trunk/Toss/Term/BuiltinLang.mli
===================================================================
--- trunk/Toss/Term/BuiltinLang.mli 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Term/BuiltinLang.mli 2012-05-27 21:18:03 UTC (rev 1716)
@@ -186,12 +186,18 @@
val close_context_sd : syntax_def
val close_context_name : string
-val remove_command_sd : syntax_def
+(*val remove_command_sd : syntax_def
val remove_command_name : string
val remove_command_tp : TermType.term_type
val system_remove_sd : syntax_def
-val system_remove_name : string
+val system_remove_name : string*)
+val set_command_sd : syntax_def
+val set_command_name : string
+val set_command_tp : TermType.term_type
+val set_prop_sd : syntax_def
+val set_prop_name : string
+
val preprocess_sd : syntax_def
val preprocess_name : string
Modified: trunk/Toss/Term/TRS.ml
===================================================================
--- trunk/Toss/Term/TRS.ml 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Term/TRS.ml 2012-05-27 21:18:03 UTC (rev 1716)
@@ -12,60 +12,64 @@
(* The system type which is a container for syntax definitions with
names, type declarations, rewrite rules and list of all used names.
For now it also has list of loaded file names to prevent double-loading. *)
-type trs = Sys of
- (syntax_def * string) list * (* Syntax definitions *)
- (string, term_type) Hashtbl.t * (* Types *)
- (term TermHashtbl.t * (* Memory used by normalisation *)
- (string, Rewriting.rrules_set) Hashtbl.t) * (* Rewriting rules *)
- string list * (* Used names *)
- (string * term_type) list (* Objects with types for chronologic access *)
+type trs = {
+ sdefs : (syntax_def * string) list; (* Syntax definitions *)
+ types : (string, term_type) Hashtbl.t; (* Types *)
+ mem : (term TermHashtbl.t); (* Memory used by normalisation *)
+ rrules : (string, Rewriting.rrules_set) Hashtbl.t; (* Rewriting rules *)
+ names : string list; (* Used names *)
+ hist : (string * term_type) list; (* Chronologic access *)
+ setvals: (string * term * term) list; (* Values set *)
+}
-
(* Get syntax definitions from a TRS. *)
-let syntax_defs_of_sys = function | Sys (sdefs, _, _, _, _) -> sdefs
+let syntax_defs_of_sys sys = sys.sdefs
+(* Get set values (chronologically) from a TRS. *)
+let set_vals_of_sys sys = List.rev sys.setvals
+
(* --- Updating the TRS --- *)
(* Updating the system when a new syntax definition appears. *)
-let update_on_sd sd = function Sys (sdefs, tdeclsh, (_, rrs), names, ts) ->
- let n = unique_name_of_sd sd names in
- let new_mem = TermHashtbl.create 512 in
+let update_on_sd sd sys =
+ let n = unique_name_of_sd sd sys.names in
let tds = match sd_type sd with
- | None -> ts
- | Some t -> (Hashtbl.add tdeclsh n t; (n, t) :: ts) in
+ | None -> sys.hist
+ | Some t -> (Hashtbl.add sys.types n t; (n, t) :: sys.hist) in
let add_sdefs = map (fun sd -> (sd, n)) (sd :: (func_sd_of_sd sd)) in
- Sys (add_sdefs @ sdefs, tdeclsh, (new_mem, rrs), n :: names, tds)
+ { sys with
+ sdefs = add_sdefs @ sys.sdefs;
+ mem = TermHashtbl.create 512;
+ names = n :: sys.names;
+ hist = tds }
(* Updating the system when a new rewrite rule appears. *)
-let update_on_rr rr = function Sys (sdefs, tdecls, (_, rrs), names, ts) ->
- let new_mem = TermHashtbl.create 512 in
- let new_rrs = match rr with
+let update_on_rr rr sys =
+ (match rr with
| (Term (f, a), r) ->
- (try let rs = Hashtbl.find rrs f in
- (Hashtbl.replace rrs f (add_last_rule rs rr); rrs)
- with Not_found -> (Hashtbl.add rrs f (new_rules_set [rr]); rrs) )
- | _ -> rrs in
- Sys (sdefs, tdecls, (new_mem, new_rrs), names, ts)
+ (try let rs = Hashtbl.find sys.rrules f in
+ Hashtbl.replace sys.rrules f (add_last_rule rs rr)
+ with Not_found -> Hashtbl.add sys.rrules f (new_rules_set [rr]) )
+ | _ -> ()
+ ); { sys with mem = TermHashtbl.create 512 }
(* Updating the system when a new priority rewrite rule appears. *)
-let update_on_prio_rr rr =
- function Sys (sdefs, tdecls, (_, rrs), names, ts) ->
- let new_mem = TermHashtbl.create 512 in
- let new_rrs = match rr with
- | (Term (f, a), r) ->
- (try let rs = Hashtbl.find rrs f in
- (Hashtbl.replace rrs f (add_first_rule rs rr); rrs)
- with Not_found -> (Hashtbl.add rrs f (new_rules_set [rr]); rrs) )
- | _ -> rrs in
- Sys (sdefs, tdecls, (new_mem, new_rrs), names, ts)
+let update_on_prio_rr rr sys =
+ (match rr with
+ | (Term (f, a), r) ->
+ (try let rs = Hashtbl.find sys.rrules f in
+ Hashtbl.replace sys.rrules f (add_first_rule rs rr)
+ with Not_found -> Hashtbl.add sys.rrules f (new_rules_set [rr]) )
+ | _ -> ()
+ ); { sys with mem = TermHashtbl.create 512 }
(* Update system when close context term appears - remove variables. *)
-let update_on_close_context_term te (Sys (sdefs, th, rrs, nms, tl) as sys) =
+let update_on_close_context_term te sys =
match te with
| Term (n, [||]) when n = close_context_name ->
- let nsdefs = filter (function (SDvar _, _) -> false | x -> true) sdefs in
- Sys (nsdefs, th, rrs, nms, tl)
+ let nsds = filter (function (SDvar _, _) -> false | _-> true) sys.sdefs in
+ { sys with sdefs = nsds }
| _ -> sys
(* Decoding paths and load commands. *)
@@ -77,27 +81,37 @@
| Term (n, [|s|]) when n = path_file_name -> decode_string s
| _ -> raise (DECODE "outside path")
-let decode_load_command kn_path = function
+let decode_load_cmd kn_path = function
| Term (n, [|p|]) when n = load_file_name -> decode_path kn_path p
| _ -> raise (DECODE "load command")
+(* Decode set command *)
+let decode_set_command = function
+ | Term (n, [|s; a; b|]) when n = set_prop_name ->
+ (decode_string s, a, b)
+ | _ -> raise (DECODE "set command")
+let update_on_set (s, a, b) sys =
+ { sys with setvals = (s, a, b) :: sys.setvals }
+
(* Update system when a new term appears.
It updates accordingly if the term is a syntax definition or rewrite rule,
loads file or closes context and does nothing in the other cases. *)
let update_on_coded_list te sys =
+ let upd_set l = fold_left (fun s sd -> update_on_set sd s) sys l in
let upd_sd l = fold_left (fun s sd -> update_on_sd sd s) sys l in
let upd_rr l = fold_left (fun s rr -> update_on_rr rr s) sys l in
let upd_prr l = fold_left (fun s rr -> update_on_prio_rr rr s) sys l in
- try upd_sd (decode_list decode_syntax_definition te) with
+ try upd_set (decode_list decode_set_command te) with
| DECODE _ ->
- try upd_rr (decode_list decode_input_rewrite_rule te) with
- | DECODE _ ->
+ try upd_sd (decode_list decode_syntax_definition te) with
+ | DECODE _ ->
try upd_prr (decode_list decode_priority_input_rewrite_rule te) with
- | DECODE _ ->
- try upd_rr (decode_list decode_rewrite_rule te) with
+ | DECODE _ ->
+ try upd_rr (decode_list decode_input_rewrite_rule te) with
| DECODE _ ->
- update_on_close_context_term te sys
+ try upd_rr (decode_list decode_rewrite_rule te) with
+ | DECODE _ -> update_on_close_context_term te sys
(* Update on file loading command. *)
@@ -112,23 +126,27 @@
) in
let fname = file ^ ".trs.parsed" in
process (ref bs) (Aux.split_newlines (AuxIO.input_file fname))
-and update_on_term k te sys bs =
- try update_on_sd (decode_syntax_definition te) sys with
+
+and update_on_term k te sys bs =
+ try update_on_set (decode_set_command te) sys with
| DECODE _ ->
- try update_on_rr (decode_input_rewrite_rule te) sys with
+ try update_on_sd (decode_syntax_definition te) sys with
| DECODE _ ->
try update_on_prio_rr (decode_priority_input_rewrite_rule te) sys with
| DECODE _ ->
- try update_on_rr (decode_rewrite_rule te) sys with
- | DECODE _ ->
- try update_on_load_file k (decode_load_command k te) sys bs
- with DECODE _ -> update_on_coded_list te sys
+ try update_on_rr (decode_input_rewrite_rule te) sys with
+ | DECODE _ ->
+ try update_on_rr (decode_rewrite_rule te) sys with
+ | DECODE _ ->
+ try update_on_load_file k (decode_load_cmd k te) sys bs
+ with DECODE _ -> update_on_coded_list te sys
(* --- Normalisation with meta-functions using the TRS --- *)
(* Getting elements from the system (recently added comes first). *)
-let get_elems_of_sys c (Sys (_, _, _, _, tdecls)) =
+let get_elems_of_sys c sys =
+ let tdecls = sys.hist in
let elem_of_td (n, ty) =
if n.[0] = c then
match ty with
@@ -139,8 +157,8 @@
let get_funs_of_sys = get_elems_of_sys 'F'
-let get_types_of_sys (Sys (sdefs, _, _, _, _)) =
- let classes = filter (function (SDtype _, _) -> true | _ -> false) sdefs in
+let get_types_of_sys sys =
+ let classes = filter (function (SDtype _, _) -> true | _-> false) sys.sdefs in
let get_tys sels = filter (function Tp _ -> true | _ -> false) sels in
let td_of_sd (sd, n) = (n, length (get_tys (syntax_elems_of_sd sd))) in
map td_of_sd classes
@@ -167,16 +185,16 @@
| Term (n, [||]) when n = get_fun_definitions_name ->
code_list code_fun_definition (get_funs_of_sys sys)
| te -> te
-and normalise_with_sys (Sys (_, _, (mem, rrs), _, _) as sys) te =
+and normalise_with_sys sys te =
(* This is the main normalisation function. *)
- normalise mem rrs is_special_fun (rewrite_special_funs sys) te
+ normalise sys.mem sys.rrules is_special_fun (rewrite_special_funs sys) te
(* --- Disambiguation for full parsing --- *)
(* Parse a string using the given system. *)
-let parse_with_sys (Sys (sdefs, tdecls, _, _, _)) str =
- let elems = parse tdecls sdefs (split_input_string str) in
+let parse_with_sys sys str =
+ let elems = parse sys.types sys.sdefs (split_input_string str) in
let type_of_pe = function Token _ -> [] | Typed_term (_, te) -> [te] in
flatten (map type_of_pe elems)
@@ -260,8 +278,10 @@
try Some (decode_priority_input_rewrite_rule te) with DECODE _ -> None
let decode_load_command_opt kn_path te =
- try Some (decode_load_command kn_path te) with DECODE _ -> None
+ try Some (decode_load_cmd kn_path te) with DECODE _ -> None
+let decode_set_opt te = try Some (decode_set_command te) with DECODE _ -> None
+
let msg_for_sels sels =
let i = ref 0 in
let msg = function
@@ -276,13 +296,16 @@
| DECODE _ ->
try let _ = decode_list decode_priority_input_rewrite_rule te in
("priority rewrite rules", false) with
- | DECODE _ ->
+ | DECODE _ ->
try let _ = decode_list decode_input_rewrite_rule te in
("rewrite rules", false) with
| DECODE _ ->
try let _ = decode_list decode_rewrite_rule te in
("rewrite rules", false) with
- | DECODE _ -> ("", false)
+ | DECODE _ ->
+ try let _=decode_list decode_set_command te
+ in ("set commands", false) with
+ | DECODE _ -> ("", false)
let display_rr (l, r) =
@@ -310,6 +333,9 @@
| (te, _) when is_some (decode_rr_opt te) ->
let rr = decode_rewrite_rule te in
msg "New rewrite rule defined.\n" (display_rr rr)
+ | (te, _) when is_some (decode_set_opt te) ->
+ let (s, k, v) = decode_set_command te in
+ msg "New value set." (s ^" ("^(display_term k)^" ) = "^(display_term v))
| (te, raw) when is_some (decode_irr_opt te) -> (
try
let rr = decode_input_rewrite_rule raw in
@@ -341,7 +367,7 @@
| (Term (n, [||]), _) when n = close_context_name ->
msg "Closed context." ""
| (te, _) when is_some (decode_load_command_opt k te) ->
- let path = decode_load_command k te in
+ let path = decode_load_cmd k te in
msg ("Loaded state " ^ path ^ ".") ""
| (te, _) ->
let ty = type_of_term tydecls te in
@@ -357,7 +383,7 @@
let process_with_system_bs lp verbose s str xml_out bs outprint =
match parse_disambiguate_with_sys verbose s str with
| [] ->
- let msg = "NO PARSE" in
+ let msg = ("NO PARSE: " ^ str) in
(if (not xml_out) then outprint msg else ();
raise (FAILED_PARSE_OR_EXN msg))
| [x] ->
@@ -367,9 +393,8 @@
let msg = "TRS EXCEPTION:\n" ^ (display_term a) ^ "\n" in
raise (FAILED_PARSE_OR_EXN msg)
| _ ->
- let Sys (_, tds, _, _, _) = s in
(update_on_term lp te s bs, [te],
- message_for_term tds lp verbose xml_out (te, x))
+ message_for_term s.types lp verbose xml_out (te, x))
)
| ts ->
let msg = "AMBIGUOUS\n" ^ (terms_info verbose ts) in
@@ -395,10 +420,10 @@
let_major_be_sd; fun_definition_sd; fun_definition_cons_sd;
type_definition_sd; type_of_sd_sd; brackets_sd; verbatim_sd; if_then_else_sd;
code_as_term_sd; get_type_definitions_sd; get_fun_definitions_sd;
- outside_paths_sd; path_library_sd; path_file_sd;
+ outside_paths_sd; path_library_sd; path_file_sd; set_command_sd; set_prop_sd;
load_command_sd; load_file_sd; preprocess_sd; sys_commands_sd;
close_context_sd; exception_cl_sd; exception_sd; exn_ok_sd; preferred_to_sd;
- additional_xslt_sd; string_quote_sd; eq_bool_sd]
+ additional_xslt_sd; string_quote_sd; eq_bool_sd]
let basic_rules = flatten [
brackets_rules; verbatim_rules; if_then_else_rules; preprocess_rules;
@@ -406,9 +431,15 @@
let basic_system () =
let upd sys sd = update_on_sd sd sys in
- let mem_rrs = (TermHashtbl.create 512, Hashtbl.create 512) in
- let emptys = Sys ([], Hashtbl.create 512, mem_rrs, [], []) in
- let system1 = fold_left upd emptys basic_sdefs in
+ let empty_sys = {
+ sdefs = [];
+ types = Hashtbl.create 512;
+ mem = TermHashtbl.create 512;
+ rrules = Hashtbl.create 512;
+ names = [];
+ hist = [];
+ setvals = []; } in
+ let system1 = fold_left upd empty_sys basic_sdefs in
let updr sys rr = update_on_rr rr sys in
fold_left updr system1 basic_rules
@@ -510,3 +541,28 @@
else outprint msg;
nsys
) else sys
+
+
+let rec run_shell lp v sys chann xmlo res outprint =
+ try
+ (sys := step_shell lp v !sys chann xmlo res outprint;
+ run_shell lp v sys chann xmlo res outprint)
+ with
+ | End_of_file -> ()
+ | FAILED_PARSE_OR_EXN msg ->
+ if xmlo then (
+ outprint "\n<trs-failure>\n";
+ outprint (make_xml_compatible msg);
+ outprint "\n</trs-failure>\n";
+ outprint "\n</trs-response>\n";
+ );
+ raise (FAILED_PARSE_OR_EXN msg)
+
+let run_shell_str ?(libpath="./Term/lib") str =
+ let s = ref str in
+ let rds () = if !s = "" then raise End_of_file else (
+ let c = !s.[0] in s := String.sub !s 1 ((String.length !s)-1); c) in
+ let o, sys, terms = ref "", ref (basic_system ()), ref [] in
+ let print_o str = o := !o ^ str ^ "\n" in
+ run_shell libpath false sys rds false terms print_o;
+ (!o, !sys, List.rev !terms)
Modified: trunk/Toss/Term/TRS.mli
===================================================================
--- trunk/Toss/Term/TRS.mli 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Term/TRS.mli 2012-05-27 21:18:03 UTC (rev 1716)
@@ -4,9 +4,13 @@
type trs
+(** Get syntax definitions from a TRS. *)
val syntax_defs_of_sys : trs -> (syntax_def * string) list
+(** Get set values (chronologically) from a TRS. *)
+val set_vals_of_sys : trs -> (string * Term.term * Term.term) list
+
(** {2 Operating on the TRS} *)
val update_on_term : string -> Term.term -> trs -> trs -> trs
@@ -34,3 +38,14 @@
should raise End_of_file on end of channel, as does input_char. *)
val step_shell : string -> bool -> trs -> (unit -> char) ->
bool -> Term.term list ref -> (string -> unit) -> trs
+
+(** A full run of the TRS computation. The channel (unit -> char) argument
+ should raise End_of_file on end of channel, as does input_char.
+ The trs reference gets updated to the result, and the term list reference
+ to the list of parsed terms. *)
+val run_shell : string -> bool -> trs ref -> (unit -> char) ->
+ bool -> Term.term list ref -> (string -> unit) -> unit
+
+(** Simplified interface to TRS computation, returns the messages,
+ resulting system and the list of parsed terms, chronologically. *)
+val run_shell_str: ?libpath: string -> string -> (string * trs * Term.term list)
Modified: trunk/Toss/Term/TRSTest.ml
===================================================================
--- trunk/Toss/Term/TRSTest.ml 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Term/TRSTest.ml 2012-05-27 21:18:03 UTC (rev 1716)
@@ -4,55 +4,14 @@
open Term
open TRS
open SyntaxDef
-
open OUnit
-let rec run lp v grammar_path xslt_path out_path sys chann xmlo res outprint =
- let save_parsed () =
- let parsed_strs = map term_to_string (rev !res) in
- AuxIO.output_file ~fname:out_path ((String.concat "\n" parsed_strs)^"\n") in
- let save_xslt () =
- let addon_term = Term (BuiltinLang.additional_xslt_name, [||]) in
- let addon_str = decode_string (normalise_with_sys !sys addon_term) in
- let xslt_str = print_xslt addon_str (syntax_defs_of_sys !sys) in
- AuxIO.output_file ~fname:xslt_path xslt_str in
- let save_grammar () =
- let grammar_str =
- let sys_sdefs = fst (List.split (syntax_defs_of_sys !sys)) in
- print_grammar (flat_grammar_of_sd_list (sys_sdefs)) in
- AuxIO.output_file ~fname:grammar_path grammar_str in
- let save_requested () = (
- if (not (grammar_path = "")) then save_grammar () else ();
- if (not (xslt_path = "")) then save_xslt () else ();
- if (not (out_path = "")) then save_parsed () else ();
- ) in
- try
- (sys := step_shell lp v !sys chann xmlo res outprint;
- run lp v grammar_path xslt_path out_path sys chann xmlo res outprint)
- with
- | End_of_file -> save_requested ();
- | FAILED_PARSE_OR_EXN msg ->
- (save_requested ();
- if xmlo then
- (outprint "\n<trs-failure>\n";
- outprint (make_xml_compatible msg);
- outprint "\n</trs-failure>\n";
- outprint "\n</trs-response>\n";)
- else ();
- failwith msg)
-
-
let test fname =
- let s = ref (AuxIO.input_file ("./Term/tests/" ^ fname ^ ".trs")) in
- let read_s () = if !s = "" then raise End_of_file else (
- let c = !s.[0] in s := String.sub !s 1 ((String.length !s)-1); c) in
- let o = ref "" in
- let print_o str = o := !o ^ str ^ "\n" in
- run "./Term/lib" false "" "" "" (ref (basic_system ())) read_s false (ref [])
- print_o;
+ let s = AuxIO.input_file ("./Term/tests/" ^ fname ^ ".trs") in
+ let (o, _, _) = run_shell_str s in
assert_equal ~printer:(fun x -> x) (Aux.normalize_spaces (
AuxIO.input_file ("./Term/tests/" ^ fname ^ ".log")))
- (Aux.normalize_spaces !o)
+ (Aux.normalize_spaces o)
let tests = "TRS" >::: [
"basic operation" >::
@@ -69,6 +28,15 @@
assert_equal ~printer:(fun x -> x) "Result: {[] as ?a._.5 list}" m;
);
+ "simple parsing" >::
+ (fun () ->
+ let s = "Load state library:/basic.\n From 0 to 5." in
+ let (o, _, _) = run_shell_str s in
+ assert_equal ~printer:(fun x->x)
+ ("Loaded state ./Term/lib/basic.\n\n" ^
+ "Result: {[0, 1, 2, 3, 4, 5] as natural number list}\n") o;
+ );
+
"test short_checks" >::
(fun () -> test "short_checks";);
]
@@ -113,19 +81,33 @@
if !lib_path = "N/O/N/I/N/T/E/R" then
ignore (OUnit.run_test_tt ~verbose:true tests)
else (
- let parsed_terms = ref [] in
- let basic_sys = ref (basic_system ()) in
+ let parsed_terms, sys = ref [], ref (basic_system ()) in
if !builtin_out then
let defs = String.concat "\n" (map pretty_print_sd basic_sdefs) in
AuxIO.print ("// TRS BUILT-IN DEFS.\n" ^ defs ^ "\n\n")
else (
if (!xml_out) then AuxIO.print "<trs-response>\n" else ();
- run !lib_path !verbose !grammar_path !xslt_path !out_path basic_sys
- AuxIO.input_stdin_char !xml_out parsed_terms
- (fun s -> AuxIO.print s; AuxIO.print "\n");
+ run_shell !lib_path !verbose sys AuxIO.input_stdin_char !xml_out
+ parsed_terms (fun s -> AuxIO.print s; AuxIO.print "\n");
+ if not (!out_path = "") then (
+ let parsed_strs = map term_to_string (rev !parsed_terms) in
+ AuxIO.output_file ~fname:!out_path
+ ((String.concat "\n" parsed_strs) ^ "\n");
+ );
+ if (not (!grammar_path = "")) then (
+ let grammar_str =
+ let sys_sdefs = fst (List.split (syntax_defs_of_sys !sys)) in
+ print_grammar (flat_grammar_of_sd_list (sys_sdefs)) in
+ AuxIO.output_file ~fname:!grammar_path grammar_str
+ );
+ if (not (!xslt_path = "")) then (
+ let addon_term = Term (BuiltinLang.additional_xslt_name, [||]) in
+ let addon_str = decode_string (normalise_with_sys !sys addon_term) in
+ let xslt_str = print_xslt addon_str (syntax_defs_of_sys !sys) in
+ AuxIO.output_file ~fname:!xslt_path xslt_str
+ );
if (!xml_out) then AuxIO.print "</trs-response>\n" else ();
)
)
-
let _ = AuxIO.run_if_target "TRSTest" main
Modified: trunk/Toss/Term/Term.ml
===================================================================
--- trunk/Toss/Term/Term.ml 2012-05-26 22:28:13 UTC (rev 1715)
+++ trunk/Toss/Term/Term.ml 2012-05-27 21:18:03 UTC (rev 1716)
@@ -72,6 +72,7 @@
| Term (n, [||]) when n = bit_1_cons_name -> 1
| _ -> raise (DECODE "bit")
+let decode_bit_list bl = bits_to_int (decode_list decode_bit bl)
let code_char c =
let bits = int_to_bits (Char.code c) in
@@ -79,13 +80,11 @@
let eight_bits = bits @ zeros (8 - List.length bits) in
Term (char_cons_name, of_list (List.map code_bit eight_bits))
-
let decode_char = function
| Term (n, bits) when n = char_cons_name ->
Char.chr (bits_to_int (to_list (map decode_bit bits)))
...
[truncated message content] |
|
From: <luk...@us...> - 2012-06-02 21:13:48
|
Revision: 1718
http://toss.svn.sourceforge.net/toss/?rev=1718&view=rev
Author: lukaszkaiser
Date: 2012-06-02 21:13:38 +0000 (Sat, 02 Jun 2012)
Log Message:
-----------
Debugging and some evaluator improvements.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Client/.cvsignore
trunk/Toss/Client/JsEval.ml
trunk/Toss/Client/Makefile
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Makefile
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureParser.mly
trunk/Toss/Solver/StructureTest.ml
Added Paths:
-----------
trunk/Toss/Client/eval.html
Removed Paths:
-------------
trunk/Toss/Client/SimpleEvaluator.ml
trunk/Toss/Client/SimpleEvaluator.mli
trunk/Toss/Client/SimpleEvaluatorTest.ml
Property Changed:
----------------
trunk/Toss/Client/
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -4,8 +4,34 @@
let gs_of_str s =
ArenaParser.parse_game_state Lexer.lex (Lexing.from_string s)
+let struc_of_str s =
+ match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
+ | Arena.StartStruc struc -> struc
+ | _ -> failwith "GameTreeTest:struc_of_str: not a structure"
+let rel_str rel struc_str =
+ let s = struc_of_str struc_str in
+ Structure.rel_str s rel (Structure.rel_graph rel s)
+
let tests = "Arena" >::: [
+ "structure with rels parsing" >::
+ (fun () ->
+ let test p s res = assert_equal ~printer:(fun x -> x) res (rel_str p s) in
+ test "P" "START [ 1 - 5 | | - ] with P(a) = :nbr(a) = 2" "P (e2)";
+ test "P" ("START [ 1 - 10 | | - ] with P(z) = &z > 1 and " ^
+ "all x, y (&x * &y = &z -> (&x = 1 or &y = 1))")
+ "P {e2; e3; e5; e7}";
+ test "P" ("START [ 1 - 3 | | - ] with E(x, y) = &y = &x + 1; " ^
+ "P(x, y) = &x != &y and tc x, y E(x, y)")
+ "P {(e1, e2); (e1, e3); (e2, e3)}";
+ test "S" ("START [ 1 - 10 | | - ] with P(z) = &z > 1 and " ^
+ "all x, y (&x * &y = &z -> (&x = 1 or &y = 1));" ^
+ "E(x, y) = P(x) and P(y) and &x < &y and " ^
+ " all z (&x < &z and &z < &y -> not P(z));" ^
+ "S(x, y) = x != y and tc x, y E(x, y)")
+ "S {(e2, e3); (e2, e5); (e2, e7); (e3, e5); (e3, e7); (e5, e7)}";
+ );
+
"simple parsing and printing" >::
(fun () ->
let s = "PLAYERS white, black
@@ -93,3 +119,19 @@
);
]
+let bigtests = "ArenaBig" >::: [
+ "structure with rels: 3 coloring" >::
+ (fun () ->
+ let test p s res = assert_equal ~printer:(fun x -> x) res (rel_str p s) in
+ test "C" ("START [ 1 - 3 | | - ] with E(x, y) = x != y; " ^
+ "C(z) = ex R, G, B all x, y ( (x in R or x in G or x in B)"^
+ " and ( E(x,y) -> not ( (x in R and y in R) or (x in G and"^
+ " y in G) or (x in B and y in B) ) ) )")
+ "C {e1; e2; e3}";
+ test "C" ("START [ 1 - 4 | | - ] with E(x, y) = x != y; " ^
+ "C(z) = ex R, G, B all x, y ( (x in R or x in G or x in B)"^
+ " and ( E(x,y) -> not ( (x in R and y in R) or (x in G and"^
+ " y in G) or (x in B and y in B) ) ) )")
+ "C:1 {}";
+ );
+]
Property changes on: trunk/Toss/Client
___________________________________________________________________
Modified: svn:ignore
- # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
clientTestRender*.png
*.js.gz
*~
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
JsEval.js
clientTestRender*.png
*.js.gz
*~
Modified: trunk/Toss/Client/.cvsignore
===================================================================
--- trunk/Toss/Client/.cvsignore 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Client/.cvsignore 2012-06-02 21:13:38 UTC (rev 1718)
@@ -3,6 +3,7 @@
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
+JsEval.js
clientTestRender*.png
*.js.gz
*~
Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Client/JsEval.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -1,13 +1,11 @@
-open SimpleEvaluator
+(* Evaluating formulas on structures for JS. *)
-(* Boilerplate code for calling OCaml in the worker thread. *)
+(* --- Boilerplate code for calling OCaml in the worker thread. --- *)
let js_object = Js.Unsafe.variable "Object"
let js_handler = jsnew js_object ()
let postMessage = Js.Unsafe.variable "postMessage"
+let js_any = Js.Unsafe.inject
-let log s = ignore (Js.Unsafe.call postMessage (Js.Unsafe.variable "self")
- [|Js.Unsafe.inject (Js.string s)|])
-
let onmessage event =
let fname = event##data##fname in
let args = event##data##args in
@@ -16,17 +14,81 @@
let response = jsnew js_object () in
Js.Unsafe.set response (Js.string "fname") fname;
Js.Unsafe.set response (Js.string "result") result;
- Js.Unsafe.call postMessage (Js.Unsafe.variable "self") [|Js.Unsafe.inject response|]
+ Js.Unsafe.call postMessage (Js.Unsafe.variable "self") [|js_any response|]
-let _ = Js.Unsafe.set (Js.Unsafe.variable "self") (Js.string "onmessage") onmessage
+let _ =
+ Js.Unsafe.set (Js.Unsafe.variable "self") (Js.string "onmessage") onmessage
+let set_handle name f =
+ Js.Unsafe.set js_handler (Js.string name) (Js.wrap_callback f)
+
+
+(* --- Main part: communication with JS and evaluation --- *)
+
+(* Translate a structure into an "info_obj" format used by State.js. *)
+let js_of_struc struc =
+ let elems = Structure.elements struc in
+ LOG 0 "js_of_struc: preparing structure elements...";
+ let get_pos e = Structure.fun_val struc "x" e,Structure.fun_val struc "y" e in
+ let minx, maxx, miny, maxy =
+ let (posx, posy) = List.split (List.map get_pos elems) in
+ let mkfl f l = List.fold_left f (List.hd l) (List.tl l) in
+ let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
+ minl posx, maxl posx, minl posy, maxl posy in
+ (* elems in JS are arrays of element name and position *)
+ let elems = Array.of_list (List.map (fun e ->
+ let e0 = Js.string (Structure.elem_name struc e) in
+ let x, y = get_pos e in
+ Js.array [|js_any e0; js_any (Js.float x); js_any (Js.float y)|]
+ ) elems) in
+ (* rels in JS are arrays of element names, with additional "name" field *)
+ let num = Js.number_of_float in
+ LOG 0 "js_of_struc: preparing relations...";
+ let rels_all =
+ (Aux.concat_map
+ (fun (rel, _) ->
+ let tups = Structure.Tuples.elements
+ (Structure.rel_graph rel struc) in
+ let tups = List.map
+ (fun args -> Js.array
+ (Array.map (fun e-> Js.string (Structure.elem_name struc e)) args))
+ tups in
+ List.map (fun args -> (args, Js.string rel)) tups)
+ (Structure.rel_signature struc)) in
+ let rels, rel_names = List.split rels_all in
+ let info_obj = jsnew js_object () in
+ let js = Js.string in
+ Js.Unsafe.set info_obj (js"maxx") (num maxx);
+ Js.Unsafe.set info_obj (js"minx") (num minx);
+ Js.Unsafe.set info_obj (js"maxy") (num maxy);
+ Js.Unsafe.set info_obj (js"miny") (num miny);
+ Js.Unsafe.set info_obj (js"elems") (Js.array elems);
+ Js.Unsafe.set info_obj (js"rels") (Js.array (Array.of_list rels));
+ Js.Unsafe.set info_obj (js"rel_names") (Js.array (Array.of_list rel_names));
+ info_obj
+
+(* Parse a formula. *)
+let formula_of_string s = FormulaParser.parse_formula Lexer.lex
+ (Lexing.from_string (Aux.normalize_spaces s))
+
+(* Parse a structure. *)
+let structure_of_string s =
+ let str = "START " ^ (Aux.normalize_spaces s) in
+ match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string str) with
+ | Arena.StartStruc struc -> struc
+ | _ -> failwith "not a structure"
+
+(* Parse a structure from a JS string and return in "info_obj" format. *)
+let info_obj_of_string s = js_of_struc (structure_of_string (Js.to_string s))
+
+let _ = set_handle "info_obj" info_obj_of_string
+
+
(* The Formula evaluation and registration in JS. *)
let js_eval phi struc =
- log ("Evaluation of " ^ (Js.to_string phi) ^ " on " ^ (Js.to_string struc));
- (**log( (SimpleEvaluator.show_satisfying (Js.to_string phi) (Js.to_string struc)));*)
- Js.string (SimpleEvaluator.show_satisfying
- ~structure:(Js.to_string struc)
- ~formula:(Js.to_string phi)
- )
+ let (phi, struc) = (Js.to_string phi, Js.to_string struc) in
+ LOG 0 "Evaluation of %s on %s" phi struc;
+ let (f, struc) = (formula_of_string phi, structure_of_string struc) in
+ Js.string (AssignmentSet.named_str struc (Solver.M.evaluate struc f))
-let _ = Js.Unsafe.set js_handler (Js.string "eval") (Js.wrap_callback js_eval)
\ No newline at end of file
+let _ = set_handle "eval" js_eval
Modified: trunk/Toss/Client/Makefile
===================================================================
--- trunk/Toss/Client/Makefile 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Client/Makefile 2012-06-02 21:13:38 UTC (rev 1718)
@@ -2,6 +2,7 @@
ClientTest:
make -C .. Client/JsHandler.js
+ make -C .. Client/JsEval.js
phantomjs clientTest.js
JSFILES = $(notdir $(shell find . -maxdepth 1 -name '*.js'))
Deleted: trunk/Toss/Client/SimpleEvaluator.ml
===================================================================
--- trunk/Toss/Client/SimpleEvaluator.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Client/SimpleEvaluator.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -1,10 +0,0 @@
-let formula_of_string s =
- FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-
-let structure_of_string s =
- StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-
-let show_satisfying ~formula ~structure =
- let (f, struc) = (formula_of_string formula, structure_of_string structure) in
- AssignmentSet.named_str struc (Solver.M.evaluate struc f)
-
\ No newline at end of file
Deleted: trunk/Toss/Client/SimpleEvaluator.mli
===================================================================
--- trunk/Toss/Client/SimpleEvaluator.mli 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Client/SimpleEvaluator.mli 2012-06-02 21:13:38 UTC (rev 1718)
@@ -1,4 +0,0 @@
-(** Simple module for evaluating formalas in a given structure *)
-
-(** Parse a formula and a structure and return the satisfying assignments. *)
-val show_satisfying : formula: string -> structure: string -> string
\ No newline at end of file
Deleted: trunk/Toss/Client/SimpleEvaluatorTest.ml
===================================================================
--- trunk/Toss/Client/SimpleEvaluatorTest.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Client/SimpleEvaluatorTest.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -1,12 +0,0 @@
-open OUnit
-
-let tests = "SimpleEvaluator" >::: [
- "show_satisfying" >::
- (fun () ->
- assert_equal ~printer:(fun x -> x)
- "{ y->b, y->c }"
- (SimpleEvaluator.show_satisfying
- ~structure:"[ | R { (a, b); (a, c) } | ]"
- ~formula:"ex x R (x, y)");
- );
-]
Added: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html (rev 0)
+++ trunk/Toss/Client/eval.html 2012-06-02 21:13:38 UTC (rev 1718)
@@ -0,0 +1,122 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xmlns:svg="http://www.w3.org/2000/svg" xml:lang="en" lang="en">
+<head>
+ <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
+ <title>Toss Formula Evaluator</title>
+ <meta name="Description" content="Evaluate Formulas on Structures." />
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
+ <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
+ <script type="text/javascript" src="State.js"> </script>
+ <script type="text/javascript">
+<!--
+var worker = new Worker ("JsEval.js");
+var worker_handler = new Object ();
+
+worker.onmessage = function (m) {
+ if (typeof m.data == 'string') {
+ console.log("" + m.data);
+ } else {
+ console.log ("[ASYNCH] back from " + m.data.fname);
+ var handler = worker_handler[m.data.fname];
+ handler (m.data.result);
+ }
+}
+
+function ASYNCH (action_name, action_args, cont) {
+ worker_handler[action_name] = cont;
+ worker.postMessage ({fname: action_name, args: action_args});
+ console.log ("[ASYNCH] " + action_name + " (" + action_args + ")");
+}
+
+function eval () {
+ var phi = document.getElementById ("formula").value;
+ var struc = document.getElementById ("structure").value;
+ ASYNCH ("info_obj", [struc], function (obj) {
+ var struc = new State ("nogame", obj, 0);
+ struc.draw_model ("nogame");
+ })
+ document.getElementById ("result").innerHTML = "Evaluating...";
+ ASYNCH ("eval", [phi, struc], function (resp) {
+ var res = document.getElementById ("result");
+ res.innerHTML = resp;
+ })
+}
+
+function handle_elem_click (eid) { console.log (eid); }
+
+function example_primes () {
+ document.getElementById ("formula").value = "P(x)";
+ document.getElementById ("structure").value = "[ 1 - 10 | | - ] with " +
+ "\nP(z) = &z > 1 and all x, y \n (&x * &y = &z -> (&x = 1 or &y = 1))";
+ eval ();
+}
+
+function example_tc () {
+ document.getElementById ("formula").value = "S(x, y)";
+ document.getElementById ("structure").value =
+ "[ 1 - 3 | | - ] with " +
+ "\nE(x, y) = &y = &x + 1;" +
+ "\nS(x, y) = x != y and tc x, y E(x, y)";
+ eval ();
+}
+
+function example_3col () {
+ document.getElementById ("formula").value =
+ "ex R, G, B all x, y ( \n (x in R or x in G or x in B) and (" +
+ "\n E(x,y) -> not ( (x in R and y in R) " +
+ "\n or (x in G and y in G) or (x in B and y in B) ) ) )";
+ document.getElementById ("structure").value =
+ "[ | E { (a, b); (b, c); (c, a) } | " +
+ "\n x { a -> 1, b -> 2, c -> 3 }; " +
+ "\n y { a -> 0, b -> -1, c -> 0 } ]";
+ eval ();
+}
+//-->
+</script>
+</head>
+
+<body>
+<div id="main">
+
+<div id="top">
+<div id="logo">
+ <a id="leftupperlogo-link" href="eval.html">
+ <img id="leftupperlogo-img" src="img/logo.png" alt="back" />
+ </a>
+</div>
+</div>
+
+<div style="position: relative; top: 4em; left: 1em">
+
+<textarea id="formula" rows="3" cols="40">
+E(x, y)</textarea>
+
+<textarea id="structure" rows="3" cols="40">
+[ 1 - 5 | | - ] with
+E(x, y) = &x = &y + 1</textarea>
+
+<button onclick="eval()">Eval and Draw</button>
+
+Examples:
+
+<button onclick="example_primes()">Primes</button>
+
+<button onclick="example_tc()">TC</button>
+
+<button onclick="example_3col()">3col</button>
+
+<p id="result"> </p>
+
+<div id="board"> </div>
+</div>
+
+<div id="bottom">
+ <div id="bottomright">
+ <a href="http://toss.sourceforge.net" id="toss-link">Contact</a>
+ </div>
+</div>
+
+</div>
+</body>
+</html>
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-06-02 21:13:38 UTC (rev 1718)
@@ -46,6 +46,8 @@
| MINUS COLON ID { Times (Const (-1.), RVar (":" ^ $3)) }
| COLON ID OPEN ID CLOSE { Fun ($2, fo_var_of_s $4) }
| COLON ID OPEN INT CLOSE { Fun ($2, fo_var_of_s (string_of_int $4)) }
+ | AMP ID { Fun ("nbr", fo_var_of_s $2) }
+ | AMP INT { Fun ("nbr", fo_var_of_s (string_of_int $2)) }
| real_expr FLOAT { Plus ($1, Const $2) } /* in x-1, "-1" is int */
| real_expr INT { Plus ($1, Const (float_of_int $2)) }
| real_expr PLUS real_expr { Plus ($1, $3) }
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Makefile 2012-06-02 21:13:38 UTC (rev 1718)
@@ -2,7 +2,8 @@
SHELL := /bin/bash
-TossServer: Server/Server.native
+TossServer:
+ make Server/Server.native
cp _build/Server/Server.native TossServer
JSOCAML=js_of_ocaml
@@ -14,12 +15,12 @@
cat _build/$@ > $@
gzip --best -c $@ > $@.gz
-TossClient: Client/JsHandler.js
+TossClient: Client/JsHandler.js Client/JsEval.js
make -C Client alljsgz
RELEASE=0.8
-Release: TossServer doc
+Release: TossClient Server/Server.native TossServer doc
rm -f *~ MenhirLib/*~ Formula/*~ Term/*~ Solver/*~ Arena/*~ Play/*~ \
GGP/*~ Learn/*~ Server/*~ www/*~ WebClient/~
make -C www/reference
@@ -166,11 +167,11 @@
# ---------- TESTS --------
-%Test: TossServer
+%Test: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest $@
-%TestVerbose: TossServer
+%TestVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -v -fulltest $(subst TestVerbose,Test,$@)
@@ -182,83 +183,83 @@
gprof _build/$< > $@.log
# Formula tests
-FormulaTests: TossServer
+FormulaTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Formula
-FormulaTestsVerbose: TossServer
+FormulaTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Formula -v
# Solver tests
-SolverTests: TossServer
+SolverTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Solver
-SolverTestsVerbose: TossServer
+SolverTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Solver -v
# Term tests
-TermTests: TossServer
+TermTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Term
-TermTestsVerbose: TossServer
+TermTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Term -v
# Arena tests
-ArenaTests: TossServer
+ArenaTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Arena
-ArenaTestsVerbose: TossServer
+ArenaTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Arena -v
# Play tests
-PlayTests: TossServer
+PlayTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Play
-PlayTestsVerbose: TossServer
+PlayTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Play -v
# GGP tests
-GGPTests: TossServer
+GGPTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest GGP
-GGPTestsVerbose: TossServer
+GGPTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest GGP -v
-GGPTestsExtra: TossServer
+GGPTestsExtra: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest GGP
# Learn tests
-LearnTests: TossServer
+LearnTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Learn
-LearnTestsVerbose: TossServer
+LearnTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Learn -v
-LearnTestsExtra: TossServer
+LearnTestsExtra: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest Learn
# Server tests
-ServerTests: TossServer
+ServerTests: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Server
-ServerTestsVerbose: TossServer
+ServerTestsVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest Server -v
# All OCaml tests
-TossTest: TossServer
+TossTest: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test ""
-TossTestVerbose: TossServer
+TossTestVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -v -test ""
-TossFullTest: TossServer
+TossFullTest: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest ""
-TossFullTestVerbose: TossServer
+TossFullTestVerbose: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -v -fulltest ""
# Client tests
@@ -276,7 +277,7 @@
clean:
ocamlbuild -clean
- rm -f Client/*~ Client/JsHandler.js
+ rm -f Client/*~ Client/JsEval.js Client/JsHandler.js
rm -f *.cmx *.cmi *.o *.cmo *.a *.cmxa *.cma *.annot *~ TossServer
rm -f Formula/*~ Solver/*~ Arena/*~ Learn/*~ Play/*~ GGP/*~ Server/*~
rm -f caml_extensions/*.cmo caml_extensions/*.cmi Formula/Resources.ml
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Server/Tests.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -13,6 +13,16 @@
"FFTNFTest", [FFTNFTest.tests];
]
+let term_tests = "Term", [
+ "TermTypeTest", [TermTypeTest.tests];
+ "SyntaxDefTest", [SyntaxDefTest.tests];
+ "BuiltinLangTest", [BuiltinLangTest.tests];
+ "TermTest", [TermTest.tests];
+ "RewritingTest", [RewritingTest.tests];
+ "ParseArcTest", [ParseArcTest.tests];
+ "TRSTest", [TRSTest.tests; TRSTest.bigtests];
+]
+
let solver_tests = "Solver", [
"NaturalsTest", [NaturalsTest.tests];
"IntegersTest", [IntegersTest.tests; IntegersTest.bigtests];
@@ -33,19 +43,9 @@
let arena_tests = "Arena", [
"DiscreteRuleTest", [DiscreteRuleTest.tests];
"ContinuousRuleTest", [ContinuousRuleTest.tests];
- "ArenaTest", [ArenaTest.tests];
+ "ArenaTest", [ArenaTest.tests; ArenaTest.bigtests];
]
-let term_tests = "Term", [
- "TermTypeTest", [TermTypeTest.tests];
- "SyntaxDefTest", [SyntaxDefTest.tests];
- "BuiltinLangTest", [BuiltinLangTest.tests];
- "TermTest", [TermTest.tests];
- "RewritingTest", [RewritingTest.tests];
- "ParseArcTest", [ParseArcTest.tests];
- "TRSTest", [TRSTest.tests; TRSTest.bigtests];
-]
-
let play_tests = "Play", [
"HeuristicTest", [HeuristicTest.tests; HeuristicTest.bigtests];
"GameTreeTest", [GameTreeTest.tests];
@@ -70,9 +70,9 @@
let tests_l = [
formula_tests;
+ term_tests;
solver_tests;
arena_tests;
- term_tests;
play_tests;
ggp_tests;
learn_tests;
@@ -90,4 +90,3 @@
let fts = if dirs = [] then tests_l else
List.filter (fun (d, _) -> List.mem d dirs) tests_l in
"T" >::: (List.flatten (List.map filter_tst fts))
-
Modified: trunk/Toss/Solver/AssignmentSet.ml
===================================================================
--- trunk/Toss/Solver/AssignmentSet.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Solver/AssignmentSet.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -122,23 +122,23 @@
List.rev_map Array.of_list
(Aux.product
(List.rev_map (fun _ -> Structure.Elems.elements elems) vars))
- | FO (v, (e,other_aset)::asg_list) when e < 0 ->
+ | FO (v, (e,other_aset)::asg_list) as asg when e < 0 ->
let asg_list = List.map (fun e ->
e, try List.assoc e asg_list with Not_found -> other_aset)
(Structure.Elems.elements elems) in
let (idx, vs) =
try (Aux.find_index v vars, Aux.remove_one v vars)
- with Not_found -> failwith ("assigned var " ^ v ^ " not in " ^
- (String.concat "," vars)) in
+ with Not_found -> failwith ("tuples: in " ^ (str asg) ^ " assigned var "^
+ v ^" not in "^ (String.concat "," vars)) in
let prolong e asg =
Array.of_list (Aux.insert_nth idx e (Array.to_list asg)) in
List.concat (List.rev_map (fun (e, asg) ->
List.rev_map (prolong e) (tuples elems vs asg)) asg_list)
- | FO (v, asg_list) ->
+ | FO (v, asg_list) as asg ->
let (idx, vs) =
try (Aux.find_index v vars, Aux.remove_one v vars)
- with Not_found -> failwith ("assigned var " ^ v ^ " not in " ^
- (String.concat "," vars)) in
+ with Not_found -> failwith ("tuples: in " ^ (str asg) ^ " assigned var "^
+ v ^" not in "^ (String.concat "," vars)) in
let prolong e asg =
Array.of_list (Aux.insert_nth idx e (Array.to_list asg)) in
List.concat (List.rev_map (fun (e, asg) ->
Modified: trunk/Toss/Solver/Assignments.mli
===================================================================
--- trunk/Toss/Solver/Assignments.mli 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Solver/Assignments.mli 2012-06-02 21:13:38 UTC (rev 1718)
@@ -10,7 +10,10 @@
If an assignment set is not Empty, then it cannot contain Empty leafs. *)
type assignment_set = AssignmentSet.assignment_set
+(* The order on variables we use; might differ from Formula.compare_vars! *)
+val compare_vars : string -> string -> int
+
(** {2 List or Set Type} *)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Solver/Solver.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -272,8 +272,9 @@
| Sum (vl, _, r) ->
List.filter (fun w -> not (List.mem w vl)) (fo_vars_r_rec r)
| RLet _ as re -> fo_vars_r_rec (FormulaSubst.expand_real_expr re) in
+ let cmp_vars v1 v2 = Assignments.compare_vars (var_str v1) (var_str v2) in
let fo_vars_real re =
- remove_dup_vars [] (List.sort compare_vars (fo_vars_r_rec re)) in
+ remove_dup_vars [] (List.sort cmp_vars (fo_vars_r_rec re)) in
let rec sum_polys = function
| Empty -> Poly.Const 0.
| Any -> failwith "absolute assignement for sum,impossible to calc"
@@ -330,7 +331,7 @@
let asg_list = List.fold_left append_elem_asg [] (slist elems) in
if asg_list = [] then Empty else
FO (var_str v, List.rev asg_list) in
- process_vars [] (List.sort Formula.compare_vars (fo_vars_real p))
+ process_vars [] (List.sort cmp_vars (fo_vars_real p))
let eval_counter = ref 0
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Solver/SolverTest.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -160,7 +160,10 @@
"{ x->3 }";
eval_eq "[ | R { (a, a); (a, b) } | ] " ":(all y (R (x, y))) > 0"
"{ x->1 }";
- );
+ eval_eq "[ 1 - 4 | | - ]"
+ "all a, b( :nbr(a) * :nbr(b) = :nbr(z) ->(:nbr(a) = 1 or :nbr(b) = 1) )"
+ "{ z->1, z->2, z->3 }";
+ );
"eval: game heuristic tests" >::
(fun () ->
@@ -349,6 +352,19 @@
\"" (chess_phi ^ "IsA8(x) and not CheckW()") "{ x->57 }";
);
+ "eval: three coloring" >::
+ (fun () ->
+ eval_eq "[ | E { (a, b); (b, a); (a, c); (c, a); (b, c); (c, b) } | ]"
+ ("ex R, G, B all x, y ( (x in R or x in G or x in B) and ( E(x,y) -> "^
+ "not( (x in R and y in R) or (x in G and y in G) or " ^
+ " (x in B and y in B) ) ) )") "T";
+ eval_eq ("[ | E { (a, b); (b, a); (a, c); (c, a); (b, c); (c, b); " ^
+ " (a, d); (d, a); (b, d); (d, b); (c, d); (d, c) } | ]")
+ ("ex R, G, B all x, y ( (x in R or x in G or x in B) and ( E(x,y) -> "^
+ "not( (x in R and y in R) or (x in G and y in G) or " ^
+ " (x in B and y in B) ) ) )") "{}";
+ );
+
(*"eval: four points problem" >::
(fun () ->
eval_eq "[ | P {x}; Q {y}; Z {z}; S {v} | ]"
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Solver/Structure.ml 2012-06-02 21:13:38 UTC (rev 1718)
@@ -403,13 +403,25 @@
let create_from_lists_position ?struc els rels =
let s = create_from_lists ?struc els rels [] in
- let elems = Elems.elements s.elements in
+ let elems = List.sort (fun x y -> x - y) (Elems.elements s.elements) in
let zero = List.map (fun e -> (e, 0.)) elems in
- let next = List.map (fun e -> (e, cBOARD_DX*. (float_of_int (e-1)))) elems in
+ let (_, next) = List.fold_left (fun (cur, acc) e ->
+ (cur +. cBOARD_DX, (e, cur) :: acc)) (0., []) elems in
let afuns s (fn, asg) = add_funs s fn asg in
List.fold_left afuns s [("x", next); ("y", zero); ("vx", zero); ("vy", zero)]
+let create_from_lists_range start ?struc els rels =
+ let s = create_from_lists ?struc els rels [] in
+ let elems = List.sort (fun x y -> x - y) (Elems.elements s.elements) in
+ let zero = List.map (fun e -> (e, 0.)) elems in
+ let (_, nextnbr) = List.fold_left (fun (cur, acc) e ->
+ (cur +. 1., (e, cur) :: acc)) (start, []) elems in
+ let (_, nextx) = List.fold_left (fun (cur, acc) e ->
+ (cur +. cBOARD_DX, (e, cur) :: acc)) (0., []) elems in
+ let afuns s (fn, asg) = add_funs s fn asg in
+ List.fold_left afuns s [("x", nextx); ("y", zero); ("nbr", nextnbr);]
+
(* ---------- REMOVING RELATION TUPLES AND ELEMENTS FROM A STRUCTURE -------- *)
(* Remove the tuple [tp] from relation [rn] in structure [struc]. *)
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2012-06-01 21:20:46 UTC (rev 1717)
+++ trunk/Toss/Solver/Structure.mli 2012-06-02 21:13:38 UTC (rev 1718)
@@ -237,10 +237,13 @@
(string * int option * string array list) list ->
(string * (string * float) list) list -> structure
-val create_from_lists_position : ?struc:structure -> string list ->
- (str...
[truncated message content] |
|
From: <luk...@us...> - 2012-06-03 22:47:29
|
Revision: 1719
http://toss.svn.sourceforge.net/toss/?rev=1719&view=rev
Author: lukaszkaiser
Date: 2012-06-03 22:47:21 +0000 (Sun, 03 Jun 2012)
Log Message:
-----------
Adding power to real_expr, working on new examples.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Main.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaMap.ml
trunk/Toss/Formula/FormulaMap.mli
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/FormulaSubst.ml
trunk/Toss/Makefile
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Solver/Solver.ml
Added Paths:
-----------
trunk/Toss/Client/img/Forces.png
trunk/Toss/Client/img/Parsing.png
trunk/Toss/examples/Forces.toss
trunk/Toss/examples/Parsing.toss
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -149,7 +149,7 @@
(* Encapsulate the precondition as a defined relation *)
let compose_pre r body args =
let lhs_args =
- match r.rlmap with
+ match r.rlmap with
| None -> (* LHS and RHS vars are the same *)
args
| Some rlmap ->
@@ -203,7 +203,6 @@
rel_prods in
let precond =
match disjs with
- (* | [] -> failwith ("fluent_preconds: not a fluent: "^rel) *)
| [phi] -> phi
| _ -> Formula.Or disjs in
let precond = FormulaOps.prune_unused_quants precond in
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Client/JsHandler.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -71,6 +71,8 @@
("Bounce", AuxIO.input_file "examples/Bounce.toss");
("Cell-Cycle-Tyson-1991",
AuxIO.input_file "examples/Cell-Cycle-Tyson-1991.toss");
+ ("Parsing", AuxIO.input_file "examples/Parsing.toss");
+ ("Forces", AuxIO.input_file "examples/Forces.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Client/Main.js 2012-06-03 22:47:21 UTC (rev 1719)
@@ -280,10 +280,12 @@
bt.innerHTML = "Less Games";
document.getElementById ("moregames1").style.display = "block";
document.getElementById ("moregames2").style.display = "block";
+ document.getElementById ("moregames3").style.display = "block";
} else {
bt.innerHTML = "More Games";
document.getElementById ("moregames1").style.display = "none";
document.getElementById ("moregames2").style.display = "none";
+ document.getElementById ("moregames3").style.display = "none";
}
}
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Client/Style.css 2012-06-03 22:47:21 UTC (rev 1719)
@@ -175,12 +175,9 @@
width: 100%;
}
-#moregames1 {
+#moregames1, #moregames2, #moregames3 {
display: none;
}
-#moregames2 {
- display: none;
-}
.game-picdiv1 {
position: relative;
Added: trunk/Toss/Client/img/Forces.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/Client/img/Forces.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: trunk/Toss/Client/img/Parsing.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/Client/img/Parsing.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Client/index.html 2012-06-03 22:47:21 UTC (rev 1719)
@@ -182,6 +182,25 @@
</div>
</div>
+<div id="moregames3" class="game-line">
+<div class="game-picdiv1">
+<button onclick="new_play_click ('Parsing')" class="game-picbt">
+ <img class="game-picimg" src="img/Parsing.png" alt="Parsing" />
+ <span id="pdescParsing" class="game-picspan">
+ <span class="game-pictxt">Parsing</span>
+ </span>
+</button>
+</div>
+<div class="game-picdiv2">
+<button onclick="new_play_click ('Forces')" class="game-picbt">
+ <img class="game-picimg" src="img/Forces.png" alt="Forces" />
+ <span id="pdescForces" class="game-picspan">
+ <span class="game-pictxt">Forces</span>
+ </span>
+</button>
+</div>
+</div>
+
<ul id="welcome-list-main" class="welcome-list">
<li>Play
<a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)"
@@ -469,6 +488,14 @@
between cdc2 and cyclin. We use it as an example of non-linear
dynamics with universal rules and parameters.</p>
</div>
+ <div class="game-desc" id="Parsing-desc">
+ <p><b>Parsing</b> is a basic example to illustrate how parsing with type
+ reconstruction can be represented as structure rewriting.</p>
+ </div>
+ <div class="game-desc" id="Forces-desc">
+ <p><b>Forces</b> can be represented using continuous dynamics, and in this
+ example we show how to use them for graph drawing.</p>
+ </div>
</div>
<div id="bottom">
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/AuxIO.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -4,6 +4,8 @@
let default_debug_level = ref 0
+(* This flag, if set, makes Toss input from Resources ml even in non-JS mode. *)
+let input_from_resources = ref false
let gettimeofday () =
IFDEF JAVASCRIPT THEN (
@@ -68,7 +70,8 @@
try Resources.get_file fn with Not_found ->
failwith ("File " ^ fn ^ " not found")
) ELSE (
- try Resources.get_file fn with Not_found -> (
+ let input_from_rescs()= if not !input_from_resources then raise Not_found in
+ try input_from_rescs(); Resources.get_file fn with Not_found -> (
let input_file_desc file =
let buf = Buffer.create 256 in
(try
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/Formula.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -115,8 +115,9 @@
and real_expr =
| RVar of string
| Const of float
+ | Plus of real_expr * real_expr
| Times of real_expr * real_expr
- | Plus of real_expr * real_expr
+ | Pow of real_expr * real_expr
| Fun of string * fo_var
| Char of formula
| Sum of fo_var list * formula * real_expr
@@ -132,11 +133,6 @@
| f -> is_atom f
-(* Helper power function, used in parser. *)
-let rec pow p n =
- if n = 0 then Const 1. else if n = 1 then p else Times (p, pow p (n-1))
-
-
(* ----------------------- PRINTING FUNCTIONS ------------------------------- *)
let rec mona_str = function
@@ -234,6 +230,10 @@
let lb, rb = if prec > 0 then "(", ")" else "", "" in
Format.fprintf f "@[<1>%s%a@ +@ %a%s@]" lb
(fprint_real_prec 0) r1 (fprint_real_prec 0) r2 rb
+ | Pow (r1, r2) ->
+ let lb, rb = if prec > 2 then "(", ")" else "", "" in
+ Format.fprintf f "@[<1>%s%a^%a%s@]" lb
+ (fprint_real_prec 4) r1 (fprint_real_prec 4) r2 rb
| Fun (s, v) -> Format.fprintf f ":%s(%s)" s (var_str v)
| Char phi -> Format.fprintf f "@[<1>:(@,%a@,)@]" (fprint_prec 0) phi
| Sum (vl, phi, r) ->
@@ -326,7 +326,7 @@
List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
and size_real ?(acc=0) = function
| RVar _ | Const _ | Fun _ -> acc + 1
- | Times (r1, r2) | Plus (r1, r2) ->
+ | Times (r1, r2) | Plus (r1, r2) | Pow (r1, r2) ->
let s1 = size_real ~acc:(acc + 1) r1 in size_real ~acc:s1 r2
| Char phi -> size ~acc phi
| Sum (_, phi, re) ->
@@ -473,6 +473,14 @@
| (flat1, Const 1.) -> flat1
| (flat1, flat2) -> Times (flat1, flat2)
)
+ | Pow (re1, re2) ->
+ (match flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2 with
+ | (Const 0., _) -> Const 0.
+ | (Const 1., _) -> Const 1.
+ | (_, Const 0.) -> Const 1.
+ | (flat1, Const 1.) -> flat1
+ | (flat1, flat2) -> Pow (flat1, flat2)
+ )
| Char (phi) -> Char (flatten_f f_or f_and phi)
| Sum (vl, phi, r) ->
Sum (vl, flatten_f f_or f_and phi, flatten_re_f f_or f_and r)
@@ -489,7 +497,7 @@
(* Helper function: delete duplicates in ordered list. *)
let rec del_dupl_ord acc = function
- [] -> List.rev acc
+ | [] -> List.rev acc
| [x] -> List.rev (x :: acc)
| x :: y :: xs when x = y -> del_dupl_ord acc (y :: xs)
| x :: y :: xs -> del_dupl_ord (x :: acc) (y :: xs)
@@ -589,7 +597,7 @@
and syntax_ok_re ?(sg=ref []) ?(fp=[]) ?(pos=true) = function
| RVar _ | Const _ | Fun _ -> true
- | Times (re1, re2) | Plus (re1, re2) ->
+ | Times (re1, re2) | Plus (re1, re2) | Pow (re1, re2) ->
syntax_ok_re ~sg ~fp ~pos re1 && syntax_ok_re ~sg ~fp ~pos re2
| Char phi -> syntax_ok ~sg ~fp ~pos phi
| Sum (_, phi, r) ->
@@ -606,8 +614,10 @@
| Fun (f, x) -> (fun _ a -> a.(Aux.find_index (f, var_str x) eqs))
| Plus (p, q) -> (let cp, cq = compile_re tv eqs p, compile_re tv eqs q in
(fun t a -> (cp t a) +. (cq t a)))
- | Times (p, q) -> (let cp, cq= compile_re tv eqs p, compile_re tv eqs q in
+ | Times (p, q) -> (let cp, cq = compile_re tv eqs p, compile_re tv eqs q in
(fun t a -> (cp t a) *. (cq t a)))
+ | Pow (p, q) -> (let cp, cq = compile_re tv eqs p, compile_re tv eqs q in
+ (fun t a -> (cp t a) ** (cq t a)))
| re -> failwith ("compilation for " ^ real_str re ^ " not implemented yet")
let compile tv eqs =
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/Formula.mli 2012-06-03 22:47:21 UTC (rev 1719)
@@ -66,15 +66,14 @@
and real_expr =
| RVar of string
| Const of float
- | Times of real_expr * real_expr
| Plus of real_expr * real_expr
+ | Times of real_expr * real_expr
+ | Pow of real_expr * real_expr
| Fun of string * fo_var
| Char of formula
| Sum of fo_var list * formula * real_expr
| RLet of string * real_expr * real_expr
-val pow : real_expr -> int -> real_expr
-
val size : ?acc : int -> formula -> int
val size_real : ?acc : int -> real_expr -> int
Modified: trunk/Toss/Formula/FormulaMap.ml
===================================================================
--- trunk/Toss/Formula/FormulaMap.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/FormulaMap.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -21,10 +21,12 @@
and map_to_literals_expr f g = function
| RVar _ | Const _ | Fun _ as x -> g x
+ | Plus (r1, r2) ->
+ Plus (map_to_literals_expr f g r1, map_to_literals_expr f g r2)
| Times (r1, r2) ->
Times (map_to_literals_expr f g r1, map_to_literals_expr f g r2)
- | Plus (r1, r2) ->
- Plus (map_to_literals_expr f g r1, map_to_literals_expr f g r2)
+ | Pow (r1, r2) ->
+ Pow (map_to_literals_expr f g r1, map_to_literals_expr f g r2)
| Char (phi) -> Char (map_to_literals f g phi)
| Sum (vs, phi, r) ->
Sum (vs, map_to_literals f g phi, map_to_literals_expr f g r)
@@ -71,8 +73,9 @@
map_RVar : string -> real_expr;
map_Const : float -> real_expr;
+ map_Plus : real_expr -> real_expr -> real_expr;
map_Times : real_expr -> real_expr -> real_expr;
- map_Plus : real_expr -> real_expr -> real_expr;
+ map_Pow : real_expr -> real_expr -> real_expr;
map_Fun : string -> fo_var -> real_expr;
map_Char : formula -> real_expr;
map_Sum : fo_var list -> formula -> real_expr -> real_expr;
@@ -96,8 +99,9 @@
map_RVar = (fun v -> RVar v);
map_Const = (fun c -> Const c);
+ map_Plus = (fun expr1 expr2 -> Plus (expr1, expr2));
map_Times = (fun expr1 expr2 -> Times (expr1, expr2));
- map_Plus = (fun expr1 expr2 -> Plus (expr1, expr2));
+ map_Pow = (fun expr1 expr2 -> Pow (expr1, expr2));
map_Fun = (fun f v -> Fun (f, v));
map_Char = (fun phi -> Char phi);
map_Sum = (fun vs guard expr -> Sum (vs, guard, expr));
@@ -124,10 +128,12 @@
and map_real_expr gmap = function
| RVar v -> gmap.map_RVar v
| Const c -> gmap.map_Const c
+ | Plus (expr1, expr2) ->
+ gmap.map_Plus (map_real_expr gmap expr1) (map_real_expr gmap expr2)
| Times (expr1, expr2) ->
gmap.map_Times (map_real_expr gmap expr1) (map_real_expr gmap expr2)
- | Plus (expr1, expr2) ->
- gmap.map_Plus (map_real_expr gmap expr1) (map_real_expr gmap expr2)
+ | Pow (expr1, expr2) ->
+ gmap.map_Pow (map_real_expr gmap expr1) (map_real_expr gmap expr2)
| Fun (f, v) -> gmap.map_Fun f v
| Char phi -> gmap.map_Char (map_formula gmap phi)
| Sum (vs, guard, expr) ->
@@ -154,8 +160,9 @@
fold_RVar : string -> 'a;
fold_Const : float -> 'a;
+ fold_Plus : 'a -> 'a -> 'a;
fold_Times : 'a -> 'a -> 'a;
- fold_Plus : 'a -> 'a -> 'a;
+ fold_Pow : 'a -> 'a -> 'a;
fold_Fun : string -> fo_var -> 'a;
fold_Char : 'a -> 'a;
fold_Sum : fo_var list -> 'a -> 'a -> 'a;
@@ -179,8 +186,9 @@
fold_RVar = (fun _ -> empty);
fold_Const = (fun _ -> empty);
+ fold_Plus = union;
fold_Times = union;
- fold_Plus = union;
+ fold_Pow = union;
fold_Fun = (fun _ _ -> empty);
fold_Char = (fun phi -> phi);
fold_Sum = (fun _ guard expr -> union guard expr);
@@ -219,10 +227,12 @@
and fold_real_expr gfold = function
| RVar v -> gfold.fold_RVar v
| Const c -> gfold.fold_Const c
+ | Plus (expr1, expr2) ->
+ gfold.fold_Plus (fold_real_expr gfold expr1) (fold_real_expr gfold expr2)
| Times (expr1, expr2) ->
gfold.fold_Times (fold_real_expr gfold expr1) (fold_real_expr gfold expr2)
- | Plus (expr1, expr2) ->
- gfold.fold_Plus (fold_real_expr gfold expr1) (fold_real_expr gfold expr2)
+ | Pow (expr1, expr2) ->
+ gfold.fold_Pow (fold_real_expr gfold expr1) (fold_real_expr gfold expr2)
| Fun (f, v) -> gfold.fold_Fun f v
| Char phi -> gfold.fold_Char (fold_formula gfold phi)
| Sum (vs, guard, expr) ->
@@ -230,14 +240,16 @@
| RLet (f, body, scope) ->
gfold.fold_RLet f (fold_real_expr gfold body) (fold_real_expr gfold scope)
-(* Map [f] to top-level formulas in the real expression ([Char]s and
- [Sum] guards). *)
+(* Map [f] to top-level formulas in the real expression
+ ([Char]s and [Sum] guards). *)
let rec map_to_formulas_expr f = function
| RVar _ | Const _ | Fun _ as x -> x
+ | Plus (r1, r2) ->
+ Plus (map_to_formulas_expr f r1, map_to_formulas_expr f r2)
| Times (r1, r2) ->
Times (map_to_formulas_expr f r1, map_to_formulas_expr f r2)
- | Plus (r1, r2) ->
- Plus (map_to_formulas_expr f r1, map_to_formulas_expr f r2)
+ | Pow (r1, r2) ->
+ Pow (map_to_formulas_expr f r1, map_to_formulas_expr f r2)
| Char (phi) -> Char (f phi)
| Sum (vs, phi, r) ->
Sum (vs, f phi, map_to_formulas_expr f r)
@@ -247,8 +259,7 @@
let rec fold_over_formulas_expr f r acc =
match r with
| RVar _ | Const _ | Fun _ -> acc
- | Times (r1, r2)
- | Plus (r1, r2) ->
+ | Plus (r1, r2) | Times (r1, r2) | Pow (r1, r2) ->
fold_over_formulas_expr f r1 (fold_over_formulas_expr f r2 acc)
| Char (phi) -> f phi acc
| Sum (vs, phi, r) ->
Modified: trunk/Toss/Formula/FormulaMap.mli
===================================================================
--- trunk/Toss/Formula/FormulaMap.mli 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/FormulaMap.mli 2012-06-03 22:47:21 UTC (rev 1719)
@@ -41,8 +41,9 @@
map_RVar : string -> real_expr;
map_Const : float -> real_expr;
+ map_Plus : real_expr -> real_expr -> real_expr;
map_Times : real_expr -> real_expr -> real_expr;
- map_Plus : real_expr -> real_expr -> real_expr;
+ map_Pow : real_expr -> real_expr -> real_expr;
map_Fun : string -> fo_var -> real_expr;
map_Char : formula -> real_expr;
map_Sum : fo_var list -> formula -> real_expr -> real_expr;
@@ -74,8 +75,9 @@
fold_RVar : string -> 'a;
fold_Const : float -> 'a;
+ fold_Plus : 'a -> 'a -> 'a;
fold_Times : 'a -> 'a -> 'a;
- fold_Plus : 'a -> 'a -> 'a;
+ fold_Pow : 'a -> 'a -> 'a;
fold_Fun : string -> fo_var -> 'a;
fold_Char : 'a -> 'a;
fold_Sum : fo_var list -> 'a -> 'a -> 'a;
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/FormulaOps.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -475,6 +475,10 @@
Times (p, q)
else
simplify_re ~do_pnf ~do_formula ~ni (Times (simp_p, simp_q))
+ | Pow (p, q) ->
+ let simp_p = simplify_re ~do_pnf ~do_formula ~ni p in
+ let simp_q = simplify_re ~do_pnf ~do_formula ~ni q in
+ Pow (simp_p, simp_q)
| RLet _ as re -> simplify_re ~do_pnf ~do_formula ~ni (expand_real_expr re)
@@ -847,8 +851,9 @@
and tnf_re_fun = function
| RVar _ | Const _ | Fun _ as x -> x
+ | Plus (re1, re2) -> Plus (tnf_re_fun re1, tnf_re_fun re2)
| Times (re1, re2) -> Times (tnf_re_fun re1, tnf_re_fun re2)
- | Plus (re1, re2) -> Plus (tnf_re_fun re1, tnf_re_fun re2)
+ | Pow (re1, re2) -> Pow (tnf_re_fun re1, tnf_re_fun re2)
| Char (phi) -> Char (flatten_sort (tnf_fun (flatten_sort phi)))
| Sum (vl, f, r) -> Sum (vl, tnf_fun f, tnf_re_fun r)
| RLet _ as re -> tnf_re_fun (expand_real_expr re)
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-06-03 22:47:21 UTC (rev 1719)
@@ -53,7 +53,11 @@
| real_expr PLUS real_expr { Plus ($1, $3) }
| real_expr MINUS real_expr { Plus ($1, Times (Const (-1.), $3)) }
| real_expr TIMES real_expr { Times ($1, $3) }
- | real_expr POW INT { pow $1 $3 }
+ | real_expr DIV real_expr { Times ($1, Pow ($3, Const (-1.))) }
+ | real_expr POW INT { Pow ($1, Const (float $3)) }
+ | real_expr POW FLOAT { Pow ($1, Const ($3)) }
+ | INT POW real_expr { Pow (Const (float $1), $3) }
+ | FLOAT POW real_expr { Pow (Const ($1), $3) }
| SUM OPEN fo_var_list MID formula_expr COLON real_expr CLOSE
{ Formula.Sum ($3, $5, $7) }
| COLON OPEN formula_expr CLOSE { Char (Formula.flatten $3) }
Modified: trunk/Toss/Formula/FormulaSubst.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubst.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Formula/FormulaSubst.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -95,8 +95,9 @@
| Const _ as x -> x
| Fun (s, v) -> Fun (s, fo_var_subst subst v)
| RVar s -> RVar (try List.assoc s subst with Not_found -> s)
+ | Plus (r1, r2) -> Plus (subst_vars_expr subst r1, subst_vars_expr subst r2)
| Times (r1, r2) -> Times (subst_vars_expr subst r1,subst_vars_expr subst r2)
- | Plus (r1, r2) -> Plus (subst_vars_expr subst r1, subst_vars_expr subst r2)
+ | Pow (r1, r2) -> Pow (subst_vars_expr subst r1, subst_vars_expr subst r2)
| Char (phi) -> Char (subst_vars subst phi)
| Sum (vs, phi, r) ->
let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
@@ -206,8 +207,9 @@
(* Substitute recursively in [r] relations defined in [defs]. *)
let rec subst_rels_expr defs = function
| RVar _ | Const _ | Fun _ as x -> x
+ | Plus (r1, r2) -> Plus (subst_rels_expr defs r1, subst_rels_expr defs r2)
| Times (r1, r2) -> Times (subst_rels_expr defs r1, subst_rels_expr defs r2)
- | Plus (r1, r2) -> Plus (subst_rels_expr defs r1, subst_rels_expr defs r2)
+ | Pow (r1, r2) -> Pow (subst_rels_expr defs r1, subst_rels_expr defs r2)
| Char (phi) -> Char (subst_rels defs phi)
| Sum (vs, phi, r) -> Sum (vs, subst_rels defs phi, subst_rels_expr defs r)
| RLet _ -> failwith "FormulaSubst:subst_rels_expr: rlet substitution"
@@ -223,8 +225,9 @@
let rec subst_rvars subst = function
| Const _ | Fun _ as x -> x
| RVar s -> (try List.assoc s subst with Not_found -> RVar s)
+ | Plus (r1, r2) -> Plus (subst_rvars subst r1, subst_rvars subst r2)
| Times (r1, r2) -> Times (subst_rvars subst r1, subst_rvars subst r2)
- | Plus (r1, r2) -> Plus (subst_rvars subst r1, subst_rvars subst r2)
+ | Pow (r1, r2) -> Pow (subst_rvars subst r1, subst_rvars subst r2)
| Char (phi) -> Char (subst_rvars_f subst phi)
| Sum (vs, phi, r) -> Sum (vs, subst_rvars_f subst phi, subst_rvars subst r)
| RLet _ -> failwith "FormulaSubst:subst_rvars on rlet"
@@ -259,8 +262,9 @@
and expand_real_expr ?(defs=[]) = function
| RVar _ | Const _ | Fun _ as x -> x
+ | Plus (r1, r2) -> Plus (expand_real_expr ~defs r1, expand_real_expr ~defs r2)
| Times (r1,r2)-> Times (expand_real_expr ~defs r1, expand_real_expr ~defs r2)
- | Plus (r1, r2) -> Plus (expand_real_expr ~defs r1, expand_real_expr ~defs r2)
+ | Pow (r1, r2) -> Pow (expand_real_expr ~defs r1, expand_real_expr ~defs r2)
| Char (phi) -> Char (expand_formula ~defs phi)
| Sum (vs, phi, r) ->
Sum (vs, expand_formula ~defs phi, expand_real_expr ~defs r)
@@ -291,8 +295,8 @@
and all_vars_real = function
| RVar s -> [s]
| Const _ -> []
- | Times (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
- | Plus (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
+ | Plus (r1, r2) | Times (r1, r2) | Pow (r1, r2) ->
+ List.rev_append (all_vars_real r1) (all_vars_real r2)
| Fun (s, v) -> [var_str v]
| Char phi -> List.rev_map var_str (all_vars_acc [] phi)
| Sum (_, f, r) ->
@@ -325,8 +329,8 @@
and free_vars_real = function
| RVar s -> [s]
| Const _ -> []
- | Times (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
- | Plus (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
+ | Plus (r1, r2) | Times (r1, r2) | Pow (r1, r2) ->
+ List.rev_append (free_vars_real r1) (free_vars_real r2)
| Fun (s, v) -> [var_str v]
| Char phi -> List.rev_map var_str (free_vars_acc [] phi)
| Sum (vl, _, r) ->
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Makefile 2012-06-03 22:47:21 UTC (rev 1719)
@@ -20,7 +20,8 @@
RELEASE=0.8
-Release: TossClient Server/Server.native TossServer doc
+Release: TossClient Server/Server.native doc
+ make TossServer
rm -f *~ MenhirLib/*~ Formula/*~ Term/*~ Solver/*~ Arena/*~ Play/*~ \
GGP/*~ Learn/*~ Server/*~ www/*~ WebClient/~
make -C www/reference
@@ -167,13 +168,13 @@
# ---------- TESTS --------
-%Test: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest $@
+%Test: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest $@
-%TestVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -v -fulltest $(subst TestVerbose,Test,$@)
+%TestVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -v -fulltest $(subst TestVerbose,Test,$@)
%TestDebug: %Test.d.byte
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$<
@@ -183,83 +184,88 @@
gprof _build/$< > $@.log
# Formula tests
-FormulaTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Formula
-FormulaTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Formula -v
+FormulaTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Formula
+FormulaTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Formula -v
# Solver tests
-SolverTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Solver
-SolverTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Solver -v
+SolverTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Solver
+SolverTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Solver -v
# Term tests
-TermTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Term
-TermTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Term -v
+TermTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Term
+TermTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Term -v
# Arena tests
-ArenaTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Arena
-ArenaTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Arena -v
+ArenaTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Arena
+ArenaTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Arena -v
# Play tests
-PlayTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Play
-PlayTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Play -v
+PlayTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Play
+PlayTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Play -v
# GGP tests
-GGPTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest GGP
-GGPTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest GGP -v
+GGPTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest GGP
+GGPTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest GGP -v
GGPTestsExtra: Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest GGP
# Learn tests
-LearnTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Learn
-LearnTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Learn -v
+LearnTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Learn
+LearnTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Learn -v
-LearnTestsExtra: Server/Server.native TossServer
+LearnTestsExtra: Server/Server.native
+ cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest Learn
# Server tests
-ServerTests: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Server
-ServerTestsVerbose: Server/Server.native TossServer
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
- ./TossServer -fulltest Server -v
+ServerTests: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Server
+ServerTestsVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Server -v
# All OCaml tests
-TossTest: Server/Server.native TossServer
+TossTest: Server/Server.native
+ cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -test ""
-TossTestVerbose: Server/Server.native TossServer
+TossTestVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -v -test ""
-TossFullTest: Server/Server.native TossServer
+TossFullTest: Server/Server.native
+ cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest ""
-TossFullTestVerbose: Server/Server.native TossServer
+TossFullTestVerbose: Server/Server.native
+ cp _build/Server/Server.native TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -v -fulltest ""
# Client tests
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2012-06-02 21:13:38 UTC (rev 1718)
+++ trunk/Toss/Play/Heuristic.ml 2012-06-03 22:47:21 UTC (rev 1719)
@@ -262,7 +262,7 @@
let suggest_expansion_coef = 0.5
let f_monot adv_ratio n m =
- Times (Formula.pow n (int_of_float adv_ratio),
+ Times (Formula.Pow (n, Const (adv_ratio)),
Const (1. /. float_of_int m ** adv_ratio))...
[truncated message content] |
|
From: <luk...@us...> - 2012-06-05 20:14:09
|
Revision: 1721
http://toss.svn.sourceforge.net/toss/?rev=1721&view=rev
Author: lukaszkaiser
Date: 2012-06-05 20:13:57 +0000 (Tue, 05 Jun 2012)
Log Message:
-----------
The Cash-Karp non-stiff adaptive RK code.
Modified Paths:
--------------
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/examples/Parsing.toss
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/Formula/Formula.ml 2012-06-05 20:13:57 UTC (rev 1721)
@@ -637,3 +637,107 @@
let k4 = eq_f (tinit +. tstep) (aadd vals_arr (amul tstep k3)) in
let (dk2, dk3) = (amul (2.) k2, amul (2.) k3) in
aadd vals_arr (amul tstepdiv6 (aadd k1 (aadd dk2 (aadd dk3 k4))))
+
+let dist a1 a2 =
+ let d = Aux.array_fold_left2 (fun d x y -> d+.(x-.y)*.(x-.y)) 0. a1 a2 in
+ d ** 0.5
+
+let sf = 0.9
+
+let rkCK_default_start () = (ref 1.5, ref 1.1, ref 100., ref 100.)
+
+(* Implements the Cash-Karp algorithm with varying order and adaptive step,
+ precisely as described in the paper "A Variable Order Runge-Kutta Method
+ for Initial Value Problems with Varying Right-Hand Sides" by J. R. Cash and
+ Alan H. Karp, ACM Trans. Math. Software, 1990.
+ The interface is as in rk4_step above, except now the tolerance is used
+ (given by [epsilon]) and some initial references must be set (use the ones
+ from rkCK_default_start). We also return time passed and next step size.*)
+let rkCK_step ?(epsilon=0.0001) (twiddle1, twiddle2, quit1, quit2) tn h f yn =
+ let k1 = f tn yn in
+ let k2 = f (tn +. (h/.5.)) (aadd yn (amul (h/.5.) k1)) in
+ let y1 = aadd yn (amul h k1) in
+ let y2 = aadd yn (amul h (aadd (amul (-3./.2.) k1) (amul (5./.2.) k2))) in
+ let e1 = ((dist y2 y1) /. epsilon) ** (1./.2.) in
+ if e1 > !twiddle1 *. !quit1 then (* abandon the step *)
+ let esttol = e1 /. !quit1 in
+ (yn, 0., h *. (max (1. /. 5.) (sf /. esttol)))
+ else
+ let k3 = f (tn +. (3.*.h/.10.))
+ (aadd yn (aadd (amul (3.*.h/.40.) k1) (amul (9.*.h/.40.) k2))) in
+ let k4 = f (tn +. (3.*.h/.5.))
+ (aadd yn (aadd (amul (3.*.h/.10.) k1)
+ (aadd (amul (-9.*.h/.10.) k2) (amul (6.*.h/.5.) k3)))) in
+ let y3 = aadd yn (amul h
+ (aadd (amul (19./.54.) k1)
+ (aadd (amul (-10./.27.) k3) (amul(55./.54.) k4)))) in
+ let e2 = ((dist y3 y2) /. epsilon) ** (1./.3.) in
+ if e2 > !twiddle2 *. !quit2 then (* try a lower order solution *)
+ if e1 < 1. then (* check the error of the second-order solution *)
+ let res15 = aadd yn (amul (h /. 10.) (aadd k1 k2)) in
+ let res15bar = aadd yn (amul (h /. 5.) k1) in
+ if dist res15 res15bar < epsilon then (* accept second-order solution *)
+ (res15, h /. 5., h /. 5.)
+ else (* abandon the step *)
+ (yn, 0., h /. 5.)
+ else (* abandon the step *)
+ let esttol = e2 /. !quit2 in
+ (yn, 0., h *. (max (1. /. 5.) (sf /. esttol)))
+ else
+ let k5 = f (tn +. h)
+ (aadd yn (aadd (amul (-11.*.h/.54.) k1)
+ (aadd (amul (5.*.h/.2.) k2)
+ (aadd (amul (-70.*.h/.27.) k3)
+ (amul (35.*.h/.27.) k4))))) in
+ let k6 = f (tn +. (7.*.h/.8.))
+ (aadd yn (aadd (amul (1631.*.h/.55296.) k1)
+ (aadd (amul (175.*.h/.512.) k2)
+ (aadd (amul (575.*.h/.13824.) k3)
+ (aadd (amul (44275.*.h/.110592.) k4)
+ (amul (253.*.h/.4096.) k5)))))) in
+ let y4 = aadd yn (amul h
+ (aadd (amul (2825./.27648.) k1)
+ (aadd (amul (18575./.48384.) k3)
+ (aadd (amul (13525./.55296.) k4)
+ (aadd (amul (277./.14336.) k5)
+ (amul (1./.4.) k6)))))) in
+ let y5 = aadd yn (amul h
+ (aadd (amul (37./.378.) k1)
+ (aadd (amul (250./.621.) k3)
+ (aadd (amul (125./.594.) k4)
+ (amul (512./.1771.) k6))))) in
+ let e4 = ((dist y5 y4) /. epsilon) ** (1./.5.) in
+ if e4 > 1. then ( (* try a lower order solution *)
+ (* readjust twiddle factors *)
+ if e1 /. !quit1 < !twiddle1 then twiddle1 := max 1.1 (e1 /. !quit1);
+ if e2 /. !quit2 < !twiddle2 then twiddle2 := max 1.1 (e2 /. !quit2);
+ if e2 < 1. then ( (* try the order-3 solution *)
+ let res35 = aadd yn (amul h
+ (aadd (amul (1./.10.) k1)
+ (aadd (amul (2./.5.) k3)
+ (amul (1./.10.) k4)))) in
+ let res35bar = aadd yn (amul (3. *. h /. 5.) k3) in
+ if dist res35 res35bar < epsilon then (* accept order-3 solution *)
+ (res35, 3. *. h /. 5., 3. *. h /. 5.)
+ else (* try an even lower order solution *)
+ if e1 < 1. then (* check the error of the order-2 solution *)
+ let res15 = aadd yn (amul (h /. 10.) (aadd k1 k2)) in
+ let res15bar = aadd yn (amul (h /. 5.) k1) in
+ if dist res15 res15bar < epsilon then (* accept order-2 solution*)
+ (res15, h /. 5., h /. 5.)
+ else (* abandon the step *)
+ (yn, 0., h /. 5.)
+ else (* abandon the current step *)
+ (yn, 0., h *. (max (1. /. 5.) (sf /. e4)))
+ ) else (* abandon the current step *)
+ (yn, 0., h *. (max (1. /. 5.) (sf /. e4)))
+ ) else ( (* accept the full order-5 solution *)
+ let q1, q2 = e1 /. e4, e2 /. e4 in
+ let q1 = if q1 > !quit1 then min q1 (10. *. !quit1) else
+ max q1 (2. *. !quit1 /. 3.) in
+ let q2 = if q2 > !quit2 then min q2 (10. *. !quit2) else
+ max q2 (2. *. !quit2 /. 3.) in
+ quit1 := max 1. (min 10000. q1);
+ quit2 := max 1. (min 10000. q2);
+ (y5, h, h *. (min 5. (sf /. e4)))
+ )
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/Formula/Formula.mli 2012-06-05 20:13:57 UTC (rev 1721)
@@ -145,3 +145,15 @@
side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
val rk4_step : float -> float -> (float -> float array -> float array) ->
float array -> float array
+
+(** Implements the Cash-Karp algorithm with varying order and adaptive step,
+ precisely as described in the paper "A Variable Order Runge-Kutta Method
+ for Initial Value Problems with Varying Right-Hand Sides" by J. R. Cash and
+ Alan H. Karp, ACM Trans. Math. Software, 1990.
+ The interface is as in rk4_step above, except now the tolerance is used
+ (given by [epsilon]) and some initial references must be set (use the ones
+ from rkCK_default_start). We also return time passed and next step size.*)
+val rkCK_default_start : unit -> float ref * float ref * float ref * float ref
+val rkCK_step: ?epsilon: float -> float ref* float ref* float ref* float ref ->
+ float -> float -> (float -> float array -> float array) ->
+ float array -> float array * float * float
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-06-05 20:13:57 UTC (rev 1721)
@@ -81,5 +81,35 @@
"0.00110, 3.6e-10, 2.99999, -1.9991, 7.16443, -0.0008"
(float_arr_str 7 (rk4_step 0. 0.02 ceqs init));
);
+
+ "rkCK" >::
+ (fun () ->
+ let float_arr_str n fa = String.concat ", " (List.map (fun f ->
+ String.sub (string_of_float f) 0 n) (Array.to_list fa)) in
+ let eqs = eqs_of_string ":f(a)' = :f(a) + :t" in
+ let ceqs = compile ":t" eqs in
+ let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.1 ceqs [|0.|] in
+ assert_equal ~printer:(fun x -> x) "0.00517" (float_arr_str 7 res);
+
+ let tyson_model_eqs = eqs_of_string
+ (" :y(e1)' = 0.015 + -200. * :y(e1) * :y(e4); " ^
+ ":y(e2)' = -0.6 * :y(e2) + 1. * :y(e5); " ^
+ ":y(e3)' = -100. * :y(e3) + 1. * :y(e5) + 100. * :y(e4); " ^
+ ":y(e4)' = -100. * :y(e4) + 100.*:y(e3) + -200.*:y(e1) * :y(e4); "^
+ ":y(e5)' = -1. * :y(e5) + 0.018 * :y(e6) + " ^
+ " 180. * :y(e6) * :y(e5) * :y(e5); " ^
+ ":y(e6)' = -0.018 * :y(e6) + 200. * :y(e1) * :y(e4) + " ^
+ " -180. * :y(e6) * :y(e5) * :y(e5)") in
+ let ceqs = compile ":t" tyson_model_eqs in
+ let init = [| 0.; 0.; 1.; 0.; 0.; 0. |] in
+ (* Step in this try is too big - should abandon, i.e. time passed = 0.*)
+ let (_, t, _) = rkCK_step (rkCK_default_start()) 0. 0.02 ceqs init in
+ assert_equal ~printer:(fun x -> string_of_float x) 0. t;
+ (* Now it is ok, should report results. *)
+ let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.003 ceqs init in
+ assert_equal ~printer:(fun x -> x)
+ "4.28845, 1.90309, 0.77440, 0.22559, 3.00456, 2.11544"
+ (float_arr_str 7 res);
+ );
]
Modified: trunk/Toss/examples/Parsing.toss
===================================================================
--- trunk/Toss/examples/Parsing.toss 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/examples/Parsing.toss 2012-06-05 20:13:57 UTC (rev 1721)
@@ -13,4 +13,4 @@
}
START [ | Tp:2 {}; Tlist:1 {}; Pone (one); Ptrue (t); Pnil (nil);
- S { (one, t); (t, nil) } | ]
+ S { (one, t); (t, nil) } | - ]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-07 21:55:48
|
Revision: 1722
http://toss.svn.sourceforge.net/toss/?rev=1722&view=rev
Author: lukaszkaiser
Date: 2012-06-07 21:55:42 +0000 (Thu, 07 Jun 2012)
Log Message:
-----------
Using the new ODE solver in ContinuousRule and in the interface.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Play.js
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaTest.ml
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -1,9 +1,8 @@
(* Structure rewriting with continuous dynamics. *)
-let time_step = ref 0.1
-let get_time_step () = !time_step
-let set_time_step x = (time_step := x)
-let dIFFM = 10 (* So many differentiation steps for one time step. *)
+let time_step = 0.01
+let min_time_step = 0.1
+let max_registered_step = 0.05
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
@@ -124,40 +123,73 @@
let dyn_c = Formula.compile ":t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
- let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
+ let diff_step, t_mod_diff = ref time_step, ref 0 in
let step vals t0 =
LOG 1 "step at time %F" t0;
- Formula.rk4_step t0 diff_step dyn_c vals in
+ (* (Formula.rk4_step t0 !diff_step dyn_c vals, !diff_step, !diff_step) in *)
+ Formula.rkCK_step (Formula.rkCK_default_start()) t0 !diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
- let last_struc, cur_vals, all_vals = ref !cur_struc, ref init_vals, ref [] in
- let end_time = !time +. t -. (0.01 *. diff_step) in
+ let last_struc, cur_vals = ref !cur_struc, ref init_vals in
+ let all_vals, reg_vals, old_time = ref [], ref [], ref 0. in
+ let end_time, reg_dtime = !time +. t, ref (max_registered_step +. 1.) in
LOG 1 "end time: %f" end_time;
let upd_struct st = List.fold_left2 (fun s ((f, e), _) v ->
Structure.change_fun s f e v) st dyn (Array.to_list !cur_vals) in
- while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
- if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
- t_mod_diff := (!t_mod_diff + 1) mod dIFFM;
- cur_vals := step !cur_vals !time ;
- time := !time +. diff_step ;
- last_struc := !cur_struc ;
- cur_struc := upd_struct !cur_struc ;
- done ;
+ while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
+ all_vals := ( !time :: (Array.to_list !cur_vals) ) :: !all_vals;
+ if !reg_dtime > max_registered_step then (
+ reg_vals := ( !time :: (Array.to_list !cur_vals) ) :: !reg_vals;
+ reg_dtime := 0.;
+ );
+ old_time := !time;
+ diff_step := min !diff_step (end_time -. !time);
+ while !time = !old_time do
+ let (new_cur_vals, new_time, new_dstep) = step !cur_vals !time in
+ time := !time +. new_time;
+ cur_vals := new_cur_vals;
+ diff_step := min min_time_step new_dstep;
+ done;
+ LOG 1 "step to time %F new size %F" !time !diff_step;
+ reg_dtime := !reg_dtime +. (!time -. !old_time);
+ last_struc := !cur_struc;
+ cur_struc := upd_struct !cur_struc;
+ done;
if (Solver.M.check !cur_struc r.inv) then (
- all_vals := !cur_vals :: !all_vals ;
+ all_vals := ( !time :: (Array.to_list !cur_vals) ) :: !all_vals;
+ reg_vals := ( !time :: (Array.to_list !cur_vals) ) :: !reg_vals ;
last_struc := !cur_struc
) else (
LOG 2 "Inv failed.\n%s\n%s" (Structure.str !cur_struc) (Formula.str r.inv);
if !all_vals = [] then
failwith "rewriting invariant failed in the first step; rule inapplicable"
- else cur_vals := List.hd !all_vals;
+ else (
+ cur_vals := Array.of_list (List.tl (List.hd !all_vals));
+ all_vals := List.tl !all_vals;
+ time := !old_time;
+ diff_step := !diff_step /. 10.;
+ cur_struc := !last_struc;
+ while Solver.M.check !cur_struc r.inv do ( (* repeat w/ small step size *)
+ all_vals := ( !time :: (Array.to_list !cur_vals) ) :: !all_vals;
+ let (new_cur_vals, new_time, new_dstep) = step !cur_vals !time in
+ cur_vals := new_cur_vals;
+ time := !time +. new_time;
+ last_struc := !cur_struc;
+ cur_struc := upd_struct !cur_struc;
+ ) done;
+ if (Solver.M.check !cur_struc r.inv) then (
+ failwith "ContinuousRule: rewrite_single_nocheck: error: impossible";
+ ) else (
+ cur_vals := Array.of_list (List.tl (List.hd !all_vals));
+ )
+ )
);
let rec select_pos ids llst =
if ids = [] then [] else (List.hd ids, List.map List.hd llst) ::
(select_pos (List.tl ids) (List.map List.tl llst)) in
- let all_vals_assoc =
- select_pos (List.map fst dyn) (List.rev_map Array.to_list !all_vals) in
+ let all_vals_assoc = if dyn = [] then [] else
+ select_pos (("t", "") :: (List.map fst dyn)) (List.rev !reg_vals) in
LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
(String.concat ", " (List.map string_of_float tl))) all_vals_assoc));
let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-06-07 21:55:42 UTC (rev 1722)
@@ -1,9 +1,5 @@
(** Structure rewriting with continuous dynamics. *)
-val get_time_step : unit -> float
-val set_time_step : float -> unit
-
-
(** {2 Basic Type Definition} *)
(** Specification of a continuous rewriting rule, as in modelling document.
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Client/JsHandler.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -167,7 +167,7 @@
minl posx, maxl posx, minl posy, maxl posy
(* Translate current structure into an "info_obj" format. *)
-let js_of_game_state ?(show_payoffs=true) ?dims game state =
+let js_of_game_state ?(show_payoffs=true) ?dims game (time, state) =
let struc = state.Arena.struc in
let elems = Structure.elements struc in
LOG 1 "js_of_game_state: Preparing game elements...";
@@ -196,6 +196,7 @@
(Structure.rel_signature struc)) in
let rels, rel_names = List.split rels_all in
let info_obj = jsnew js_object () in
+ Js.Unsafe.set info_obj (js"time") (num time);
Js.Unsafe.set info_obj (js"maxx") (num maxx);
Js.Unsafe.set info_obj (js"minx") (num minx);
Js.Unsafe.set info_obj (js"maxy") (num maxy);
@@ -245,7 +246,7 @@
cur_all_moves := Arena.list_moves_shifts game state;
cur_move := 0;
LOG 1 "new_play (%s): calling js_of_game_state." game_name;
- js_of_game_state game state
+ js_of_game_state game (0., state)
let _ = set_handle "new_play" new_play
@@ -254,19 +255,21 @@
if n < 0 then Js.null else
let game, _ = !cur_game.game_state in
let state = List.nth !play_states n in
- Js.some (js_of_game_state ~show_payoffs:(n = 0) game state)
+ Js.some (js_of_game_state ~show_payoffs:(n = 0) game (0., state))
let _ = set_handle "prev_move" preview_move
(* Compute all copies of [state] given by [shifts], including [state]. *)
let shifted_state state shifts =
- if shifts = [] then [state] else
- let len, res = List.length (snd (List.hd shifts)), ref [state] in
+ if shifts = [] then [(0., state)] else
+ let times, shifts = snd (List.hd shifts), List.tl shifts in
+ LOG 1 "%s" (String.concat ", " (List.map string_of_float times));
+ let len, res, t0 = List.length times, ref [(0., state)], List.hd times in
for i = 0 to len - 1 do
let new_struc = List.fold_left (fun struc ((fname, elem), ts) ->
let v = (List.nth ts i) in
Structure.change_fun struc fname elem v) state.Arena.struc shifts in
- res := { state with Arena.struc = new_struc } :: !res;
+ res := (List.nth times i -. t0, {state with Arena.struc=new_struc})::!res;
done;
!res
@@ -280,8 +283,10 @@
play_states := n_state :: !play_states;
cur_all_moves := Arena.list_moves_shifts game n_state;
cur_move := 0;
- let states = List.rev (n_state :: (shifted_state old_state shifts)) in
- let dims = List.fold_left (fun (a, b, c, d) s ->
+ let last_state = if shifts = [] then (0.1, n_state) else
+ (n_state.Arena.time -. (List.hd (snd (List.hd shifts))), n_state) in
+ let states = List.rev (last_state :: shifted_state old_state shifts) in
+ let dims = List.fold_left (fun (a, b, c, d) (_, s) ->
let (x, y, z, v) = state_dim s in
(min a x, max b y, min c z, max d v)) (state_dim n_state) states in
Js.some (Js.array (Array.of_list (List.map
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Client/Play.js 2012-06-07 21:55:42 UTC (rev 1722)
@@ -149,13 +149,12 @@
function play_move_continue (info, suggest_f) {
PlayDISP.free ();
- var TIMESTEP = 100;
for (var i = 1; i < info.length-1; i++) {
setTimeout (function (_this, cur_info) {
_this.cur_state =
new State (_this.game, cur_info, _this.cur_state.mirror);
_this.redraw ();
- }, i*TIMESTEP, this, info[i]);
+ }, info[i].time * 1000, this, info[i]);
}
setTimeout (function (_this, cur_info) {
_this.new_state (cur_info);
@@ -165,7 +164,7 @@
var mv_time = document.getElementById("speed").value;
suggest_f (mv_time);
}
- }, (info.length-1)*TIMESTEP, this, info[info.length - 1])
+ }, info[info.length-1].time * 1000, this, info[info.length - 1])
}
Play.prototype.move_continue = play_move_continue;
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Formula/Formula.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -653,7 +653,7 @@
The interface is as in rk4_step above, except now the tolerance is used
(given by [epsilon]) and some initial references must be set (use the ones
from rkCK_default_start). We also return time passed and next step size.*)
-let rkCK_step ?(epsilon=0.0001) (twiddle1, twiddle2, quit1, quit2) tn h f yn =
+let rkCK_step ?(epsilon=0.00001) (twiddle1, twiddle2, quit1, quit2) tn h f yn =
let k1 = f tn yn in
let k2 = f (tn +. (h/.5.)) (aadd yn (amul (h/.5.) k1)) in
let y1 = aadd yn (amul h k1) in
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -106,9 +106,9 @@
let (_, t, _) = rkCK_step (rkCK_default_start()) 0. 0.02 ceqs init in
assert_equal ~printer:(fun x -> string_of_float x) 0. t;
(* Now it is ok, should report results. *)
- let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.003 ceqs init in
+ let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.002 ceqs init in
assert_equal ~printer:(fun x -> x)
- "4.28845, 1.90309, 0.77440, 0.22559, 3.00456, 2.11544"
+ "2.93178, 2.62576, 0.83515, 0.16483, 6.34473, 6.82189"
(float_arr_str 7 res);
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
Thanks for helping keep SourceForge clean.
X