toss-devel-svn Mailing List for Toss (Page 2)
Status: Beta
Brought to you by:
lukaszkaiser
You can subscribe to this list here.
2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(25) |
Dec
(62) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2011 |
Jan
(26) |
Feb
(38) |
Mar
(67) |
Apr
(22) |
May
(41) |
Jun
(30) |
Jul
(24) |
Aug
(32) |
Sep
(29) |
Oct
(34) |
Nov
(18) |
Dec
(2) |
2012 |
Jan
(19) |
Feb
(25) |
Mar
(16) |
Apr
(2) |
May
(18) |
Jun
(21) |
Jul
(11) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
From: <luk...@us...> - 2012-06-09 20:09:15
|
Revision: 1723 http://toss.svn.sourceforge.net/toss/?rev=1723&view=rev Author: lukaszkaiser Date: 2012-06-09 20:09:07 +0000 (Sat, 09 Jun 2012) Log Message: ----------- Work on the Parsing game and other small improvements. 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/State.js trunk/Toss/Client/Style.css trunk/Toss/Client/eval.html trunk/Toss/Client/img/Forces.png trunk/Toss/Client/img/Parsing.png trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/Structure.ml trunk/Toss/Solver/Structure.mli trunk/Toss/examples/Forces.toss trunk/Toss/examples/Parsing.toss trunk/Toss/www/index.xml Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Arena/Arena.ml 2012-06-09 20:09:07 UTC (rev 1723) @@ -267,6 +267,15 @@ let add_def_rels struc rels = List.fold_left add_def_rel_single struc rels +let add_def_fun_single struc (f, v, def_re) = + let elems = Structure.elements struc in + let asg e = AssignmentSet.FO (v, [(e, AssignmentSet.Any)]) in + let fval e = Solver.M.get_real_val ~asg:(asg e) def_re struc in + List.fold_left (fun s e-> Structure.change_fun_int s f e (fval e)) struc elems + +let add_def_funs struc funs = List.fold_left add_def_fun_single struc funs + + (* The order of following entries matters: [DefPlayers] adds more players, with consecutive numbers starting from first available; later [StartStruc], [CurrentStruc], [StateTime] and [StateLoc] entries Modified: trunk/Toss/Arena/Arena.mli =================================================================== --- trunk/Toss/Arena/Arena.mli 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Arena/Arena.mli 2012-06-09 20:09:07 UTC (rev 1723) @@ -70,7 +70,10 @@ val add_def_rels : Structure.structure -> (string * string list * Formula.formula) list -> Structure.structure +val add_def_funs : Structure.structure -> + (string * string * Formula.real_expr) list -> Structure.structure + (** Print a label as a string. *) val label_str : label -> string val move_str : (label * int) -> string Modified: trunk/Toss/Arena/ArenaParser.mly =================================================================== --- trunk/Toss/Arena/ArenaParser.mly 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Arena/ArenaParser.mly 2012-06-09 20:09:07 UTC (rev 1723) @@ -94,6 +94,10 @@ | rel = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE) EQ body = formula_expr_err { (rel, args, body) } +fun_def_simple: + | COLON f = ID OPEN v = ID CLOSE EQ body = real_expr + { (f, v, body) } + game_move_timed: | OPENSQ r = id_int t = FLOAT RARR l = INT EMB emb = separated_list (COMMA, separated_pair (ID, COLON, id_int)) CLOSESQ @@ -138,11 +142,19 @@ | START model = struct_expr WITH defs = separated_list (SEMICOLON, rel_def_simple) { StartStruc (Arena.add_def_rels model defs) } + | START model = struct_expr WITH + defs = separated_list (SEMICOLON, rel_def_simple) WITH + funs = separated_list (SEMICOLON, fun_def_simple) + { StartStruc (Arena.add_def_funs (Arena.add_def_rels model defs) funs) } | 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) } + | CURRENT model = struct_expr WITH + defs = separated_list (SEMICOLON, rel_def_simple) WITH + funs = separated_list (SEMICOLON, fun_def_simple) + { StartStruc (Arena.add_def_funs (Arena.add_def_rels model defs) funs) } | 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-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Arena/ArenaTest.ml 2012-06-09 20:09:07 UTC (rev 1723) @@ -17,7 +17,9 @@ "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 - 5 | | - ] with P(a) = :nbr(a)= 2" "P (e2)"; + test "P" "START [ 1 - 5 | | - ] with P(a) = :nbr(a)= 2 with :y(a) = 10*&a" + "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}"; Modified: trunk/Toss/Client/State.js =================================================================== --- trunk/Toss/Client/State.js 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Client/State.js 2012-06-09 20:09:07 UTC (rev 1723) @@ -196,10 +196,14 @@ } function square_elements_game (game) { - return (game !== "Connect4" && - game !== "Bounce" && - game !== "Cell-Cycle-Tyson-1991" && - game !== "Rewriting-Example") + return (game === "Breakthrough" || + game === "Checkers" || + game === "Chess" || + game === "Entanglement" || + game === "Gomoku" || + game === "Pawn-Whopping" || + game === "Tic-Tac-Toe" || + game === "Hnefatafl") } // Draw the model. @@ -261,8 +265,8 @@ } // Main draw_model function. - var sqrt = Math.round (Math.sqrt (this.elems.length)); - if (sqrt * sqrt == this.elems.length) { // perhaps a grid + var sqrt = Math.round (Math.sqrt (this.elems.length)); // perhaps a grid + if (sqrt * sqrt == this.elems.length && (sqrt > 4 || game=="Tic-Tac-Toe")) { SHAPES.elem_size_x = SVG_WIDTH / (2.0 * (sqrt-1)); SHAPES.elem_size_y = SVG_HEIGHT / (2.0 * (sqrt-1)); } else { Modified: trunk/Toss/Client/Style.css =================================================================== --- trunk/Toss/Client/Style.css 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Client/Style.css 2012-06-09 20:09:07 UTC (rev 1723) @@ -1055,17 +1055,17 @@ stroke-width: 5px; } -.model-pred-Cyc { +.model-pred-Cyc, .model-pred-Pone { stroke: #260314; stroke-width: 3px; fill: #e5effa; } -.model-pred-CycP1 { +.model-pred-CycP1, .model-pred-Tnbr { stroke: #260314; stroke-width: 3px; fill: #a5afaa; } -.model-pred-Cdc2 { +.model-pred-Cdc2, .model-pred-Pnil { stroke: #260314; stroke-width: 3px; fill: #93a605; @@ -1075,7 +1075,7 @@ stroke-width: 3px; fill: #3e5916; } -.model-pred-Cdc2CycP1 { +.model-pred-Cdc2CycP1, .model-pred-Tlist { stroke: #260314; stroke-width: 3px; fill: #f28705; Modified: trunk/Toss/Client/eval.html =================================================================== --- trunk/Toss/Client/eval.html 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Client/eval.html 2012-06-09 20:09:07 UTC (rev 1723) @@ -94,7 +94,8 @@ <textarea id="structure" rows="3" cols="40"> [ 1 - 5 | | - ] with -E(x, y) = &x = &y + 1</textarea> +E(x, y) = &x = &y + 1 +with :y(a) = -10 * &a</textarea> <button onclick="eval()">Eval and Draw</button> Modified: trunk/Toss/Client/img/Forces.png =================================================================== (Binary files differ) Modified: trunk/Toss/Client/img/Parsing.png =================================================================== (Binary files differ) Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Solver/Solver.ml 2012-06-09 20:09:07 UTC (rev 1723) @@ -526,13 +526,13 @@ | re -> update_cache struc; try - let (res, _) = Hashtbl.find !re_cache_results re in + let (res, _) = Hashtbl.find !re_cache_results (re, asg) in LOG 2 "found in re cache: %s" (Formula.real_str re); res with Not_found -> LOG 1 "Get real val %s" (real_str re); let re_val = get_real_val solver asg re struc in - Hashtbl.add !re_cache_results re (re_val, re_rels re); + Hashtbl.add !re_cache_results (re, asg) (re_val, re_rels re); re_val (* Evaluate i-th formula on j-th structure. *) Modified: trunk/Toss/Solver/Structure.ml =================================================================== --- trunk/Toss/Solver/Structure.ml 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Solver/Structure.ml 2012-06-09 20:09:07 UTC (rev 1723) @@ -349,11 +349,12 @@ 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 change_fun_int struc fn e x = + let assgs = StringMap.find fn struc.functions in let new_functions = StringMap.add fn (IntMap.add e x assgs) struc.functions in { struc with functions = new_functions } +let change_fun struc fn elem x = change_fun_int struc fn (elem_nbr struc elem) x (* ------------ GLOBAL FUNCTIONS TO CREATE STRUCTURES FROM LISTS ------------ *) Modified: trunk/Toss/Solver/Structure.mli =================================================================== --- trunk/Toss/Solver/Structure.mli 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/Solver/Structure.mli 2012-06-09 20:09:07 UTC (rev 1723) @@ -229,6 +229,7 @@ (** Change function [fn] assignment for element [e] to [x] in [struc]. *) val change_fun : structure -> string -> string -> float -> structure +val change_fun_int : structure -> string -> int -> float -> structure (** {2 Global function to create structures from lists} *) Modified: trunk/Toss/examples/Forces.toss =================================================================== --- trunk/Toss/examples/Forces.toss 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/examples/Forces.toss 2012-06-09 20:09:07 UTC (rev 1723) @@ -42,7 +42,7 @@ LOC 0 { PLAYER 1 { PAYOFF 0. MOVES [Move, - :t : 3. -- 3., + :t : 5. -- 5., :k : 0.1 -- 0.1, :f : 0.1 -- 0.1, :ke : 200. -- 200. -> 0] } @@ -50,6 +50,6 @@ UNIVERSAL { Coulomb, Hooke, Friction } } -START [ e5 | Start(e1); E { (e1, e2); (e1, e3); (e1, e4) } | - vx { e1->0, e2->0, e3->0, e4->0, e5->0 }; vy { e1->0, e2->0, e3->0, e4->0,e5->0 }; - x { e1->0., e2->10., e3->10., e4->10, e5->0. }; y { e1->0., e2->9, e3->0, e4->-9, e5->0 } ] +START [ | Start(e1); E { (e1, e2); (e1, e3); (e1, e4) } | + vx { e1->0, e2->0, e3->0, e4->0 }; vy { e1->0, e2->0, e3->0, e4->0 }; + x { e1->0., e2->10., e3->10., e4->10 }; y { e1->0., e2->9, e3->0, e4->-9 } ] Modified: trunk/Toss/examples/Parsing.toss =================================================================== --- trunk/Toss/examples/Parsing.toss 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/examples/Parsing.toss 2012-06-09 20:09:07 UTC (rev 1723) @@ -1,16 +1,35 @@ PLAYERS 1, 2 RULE NilList: - [e1 | Pnil(e1) | ] -> [a1, a2 | Pnil (a1); Tp (a1, a2); Tlist (a2) | ] + [e1 | Pnil(e1) | ] -> [a1, a2 | Pnil (a1); E (a1, a2); Tlist (a2) | ] emb Pnil with [a1 <- e1] update :x(a1) = :x(e1); :x(a2) = :x(e1); :y(a1) = :y(e1); - :y(a2) = :y(e1) + 1. + :y(a2) = :y(e1) - 1 +RULE OneNbr: + [e1 | Pone(e1) | ] -> [a1, a2 | Pone (a1); E (a1, a2); Tnbr (a2) | ] + emb Pone with [a1 <- e1] update + :x(a1) = :x(e1); + :x(a2) = :x(e1); + :y(a1) = :y(e1); + :y(a2) = :y(e1) - 1 + +RULE NbrList: + [e1, e2 | Tnbr(e1); Tlist(e2) | ] -> + [a1, a2, a3 | Tnbr (a1); Tlist (a2); Tlist (a3); E (a1, a3); E (a2, a3) | ] + emb Pone with [a1 <- e1, a2 <- e2] update + :x(a1) = :x(e1); + :x(a2) = :x(e2); + :x(a3) = :x(e1) + :x(e2) / 2; + :y(a1) = :y(e1); + :y(a2) = :y(e2); + :y(a3) = ((:y(e2) + :y(e2)) / 2) - 1 + LOC 0 { - PLAYER 1 { PAYOFF 0. MOVES [NilList -> 0] } + PLAYER 1 { PAYOFF 0. MOVES [NilList -> 0]; [NbrList -> 0]; [OneNbr -> 0] } PLAYER 2 { PAYOFF 0. } } -START [ | Tp:2 {}; Tlist:1 {}; Pone (one); Ptrue (t); Pnil (nil); +START [ | E:2 {}; Tlist:1 {}; Tnbr:1 {}; Pone (one); Pone (t); Pnil (nil); S { (one, t); (t, nil) } | - ] Modified: trunk/Toss/www/index.xml =================================================================== --- trunk/Toss/www/index.xml 2012-06-07 21:55:42 UTC (rev 1722) +++ trunk/Toss/www/index.xml 2012-06-09 20:09:07 UTC (rev 1723) @@ -35,18 +35,22 @@ <section title="News"> <itemize> + <newsitem date="07/06/12"> + Switching to a new ODE solver which uses the Cash-Karp method</newsitem> + <newsitem date="02/06/12"> + Starting work on an interface for structures and formula evaluation</newsitem> <newsitem date="27/05/12"> First structures defined using the term rewriting system syntax</newsitem> <newsitem date="24/05/12"> Code for Term functions cleaned up and made JS compatible</newsitem> - <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> + <oldnewsitem date="13/05/12"> + Toss release 0.8 with full JS compatibility with dynamics</oldnewsitem> + <oldnewsitem date="04/05/12"> + Dynamics debugged and animations now work in the JS interface</oldnewsitem> + <oldnewsitem date="04/05/12"> + Old rewriting example works with the JS interface</oldnewsitem> + <oldnewsitem date="25/04/12"> + Work on positioning with the JS interface</oldnewsitem> <oldnewsitem date="30/03/12"> Adding Hnefatafl to example Toss games</oldnewsitem> <oldnewsitem date="21/03/12"> 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. |
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-05 10:39:16
|
Revision: 1720 http://toss.svn.sourceforge.net/toss/?rev=1720&view=rev Author: lukstafi Date: 2012-06-05 10:39:06 +0000 (Tue, 05 Jun 2012) Log Message: ----------- Heuristic generation: bug in monotonic case (generating precondition). Modified Paths: -------------- trunk/Toss/Arena/DiscreteRule.ml Modified: trunk/Toss/Arena/DiscreteRule.ml =================================================================== --- trunk/Toss/Arena/DiscreteRule.ml 2012-06-03 22:47:21 UTC (rev 1719) +++ trunk/Toss/Arena/DiscreteRule.ml 2012-06-05 10:39:06 UTC (rev 1720) @@ -151,12 +151,14 @@ let lhs_args = match r.rlmap with | None -> (* LHS and RHS vars are the same *) - args + Some args | Some rlmap -> - Array.map (fun e->List.assoc e rlmap) args in - LOG 4 "compose_pre: rel=%s; args=%s; lhs_args=%s" rel - (String.concat ", " (Array.to_list args)) - (String.concat ", " (Array.to_list lhs_args)); + (* omit conditions not on the LHS *) + try Some (Array.map (fun e->List.assoc e rlmap) args) + with Not_found -> None in + (* LOG 4 "compose_pre: rel=%s; args=%s; lhs_args=%s" rel + (String.concat ", " (Array.to_list args)) + (String.concat ", " (Array.to_list lhs_args)); *) (* remove potential condition for absence/presence of the fluent being just added / deleted *) let body = FormulaMap.map_formula @@ -167,7 +169,7 @@ positive/negative *) FormulaMap.map_Rel = (fun b_rel b_args -> let b = rel = b_rel && lhs_args = - Array.map Formula.var_str b_args in + Some (Array.map Formula.var_str b_args) in if b && Aux.Strings.mem rel nega_frels then Formula.And [] else if b && Aux.Strings.mem rel posi_frels then Formula.Or [] else Formula.Rel (b_rel, b_args))} body in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
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)) let print_heur msg heur = @@ -770,12 +770,14 @@ let rec map_constants f = function | Const c -> Const (f c) + | Plus (e1, e2) -> + Plus (map_constants f e1, map_constants f e2) | Times (e1, e2) -> - Times (map_constants f e1, map_constants f e2) - | Plus (e1, e2) -> - Plus (map_constants f e1, map_constants f e2) + Times (map_constants f e1, map_constants f e2) + | Pow (e1, e2) -> + Pow (map_constants f e1, map_constants f e2) | Sum (vs, phi, es) -> - Sum (vs, phi, map_constants f es) + Sum (vs, phi, map_constants f es) | RVar _ | Fun _ | Char _ as expr -> expr | RLet _ as re -> map_constants f (FormulaSubst.expand_real_expr re) @@ -907,8 +909,9 @@ | Const _ | Fun _ as expr -> expr | RLet _ as re -> aux gds (FormulaSubst.expand_real_expr re) + | Plus (a, b) -> Plus (aux gds a, aux gds b) | Times (a, b) -> Times (aux gds a, aux gds b) - | Plus (a, b) -> Plus (aux gds a, aux gds b) + | Pow (a, b) -> Pow (aux gds a, aux gds b) | Char phi -> (match fluent_preconds with | None -> (* not monotonic *) @@ -1012,7 +1015,7 @@ let posi_frels, nega_frels, indef_frels = Arena.all_fluents game in let array_plus ar = - Array.fold_right (fun x y->Plus (x, y)) ar (Const 0.) in + Array.fold_right (fun x y -> Plus (x, y)) ar (Const 0.) in let all_payoffs = array_plus (Array.map (fun (loc, _) -> array_plus (Array.map (fun l -> l.Arena.payoff) loc)) graph) in Modified: trunk/Toss/Play/HeuristicTest.ml =================================================================== --- trunk/Toss/Play/HeuristicTest.ml 2012-06-02 21:13:38 UTC (rev 1718) +++ trunk/Toss/Play/HeuristicTest.ml 2012-06-03 22:47:21 UTC (rev 1719) @@ -273,14 +273,14 @@ "[a | P:1 {}; Q:1 {} | ] -> [ | P:1 {}; Q(a) | ] emb P, Q"] in assert_eq_str - "Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z))) * 0.33) - Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z))) * 0.33)" + "Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z)))^1. * 0.33) - Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z)))^1. * 0.33)" (Formula.real_str (Heuristic.map_constants (fun c->(floor (c*.100.))/.100.) (default_heuristic 1. rules (real_of_str (":("^winPxyz^") - :("^winQxyz^")"))))); assert_eq_str - "Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z))) * (:(P(x)) + :(P(y)) + :(P(z))) * 0.11) - Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(x)) + :(Q(y)) + :(Q(z))) * 0.11)" + "Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z)))^2. * 0.11) - Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z)))^2. * 0.11)" (Formula.real_str (Heuristic.map_constants (fun c->(floor (c*.100.))/.100.) (default_heuristic 2. rules @@ -296,14 +296,14 @@ "[a | P:1 {}; Q:1 {} | ] -> [ | P:1 {}; Q(a) | ] emb P, Q"] in assert_eq_str - "Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * 0.04 ) - Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * 0.04 )" + "Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z)))^2. * 0.04) - Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z)))^2. * 0.04)" (Formula.real_str ((* Heuristic.map_constants (fun c->(floor (c*.100.))/.100.) *) (default_heuristic 2. rules (real_of_str (":("^winPvwxyz^") - :("^winQvwxyz^")"))))); assert_eq_str - "Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * 0.008 ) - Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * 0.008 )" + "Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z)))^3. * 0.008) - Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z)))^3. * 0.008)" (Formula.real_str ((* Heuristic.map_constants (fun c->(floor (c*.1000.))/.1000.) *) (default_heuristic 3. rules @@ -345,7 +345,7 @@ ~advr:4.0 game in assert_eq_str - "100. * (Sum (cell_a_y8__BLANK_, cell_b_y8__BLANK_, cell_c1_y8__BLANK_, cell_d_y8__BLANK_, cell_e_y8__BLANK_ | ((cell_2x(cell_a_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and (cell_2b(cell_a_y8__BLANK_) or cell_2x(cell_a_y8__BLANK_)) and (cell_2b(cell_b_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_)) and (cell_2b(cell_c1_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_)) and (cell_2b(cell_d_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_)) and (cell_2b(cell_e_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and R2(cell_d_y8__BLANK_, cell_e_y8__BLANK_) and R2(cell_c1_y8__BLANK_, cell_d_y8__BLANK_) and R2(cell_b_y8__BLANK_, cell_c1_y8__BLANK_) and R2(cell_a_y8__BLANK_, cell_b_y8__BLANK_)) : (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * 0.0016 ) + Sum (cell_x14_y18__BLANK_, cell_x15_y17__BLANK_, cell_x16_y16__BLANK_, cell_x17_y15__BLANK_, cell_x18_y14__BLANK_ | ((cell_2x(cell_x14_y18__BLANK_) or cell_2x(cell_x15_y17__BLANK_) or cell_2x(cell_x16_y16__BLANK_) or cell_2x(cell_x17_y15__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and (cell_2b(cell_x14_y18__BLANK_) or cell_2x(cell_x14_y18__BLANK_)) and (cell_2b(cell_x15_y17__BLANK_) or cell_2x(cell_x15_y17__BLANK_)) and (cell_2b(cell_x16_y16__BLANK_) or cell_2x(cell_x16_y16__BLANK_)) and (cell_2b(cell_x17_y15__BLANK_) or cell_2x(cell_x17_y15__BLANK_)) and (cell_2b(cell_x18_y14__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and R1(cell_x17_y15__BLANK_, cell_x18_y14__BLANK_) and R1(cell_x16_y16__BLANK_, cell_x17_y15__BLANK_) and R1(cell_x15_y17__BLANK_, cell_x16_y16__BLANK_) and R1(cell_x14_y18__BLANK_, cell_x15_y17__BLANK_)) : (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * 0.0016 ) + Sum (cell_x10_y10__BLANK_, cell_x11_y11__BLANK_, cell_x12_y12__BLANK_, cell_x13_y13__BLANK_, cell_x9_y9__BLANK_ | ((cell_2x(cell_x10_y10__BLANK_) or cell_2x(cell_x11_y11__BLANK_) or cell_2x(cell_x12_y12__BLANK_) or cell_2x(cell_x13_y13__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and (cell_2b(cell_x10_y10__BLANK_) or cell_2x(cell_x10_y10__BLANK_)) and (cell_2b(cell_x11_y11__BLANK_) or cell_2x(cell_x11_y11__BLANK_)) and (cell_2b(cell_x12_y12__BLANK_) or cell_2x(cell_x12_y12__BLANK_)) and (cell_2b(cell_x13_y13__BLANK_) or cell_2x(cell_x13_y13__BLANK_)) and (cell_2b(cell_x9_y9__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and R0(cell_x9_y9__BLANK_, cell_x10_y10__BLANK_) and R0(cell_x12_y12__BLANK_, cell_x13_y13__BLANK_) and R0(cell_x11_y11__BLANK_, cell_x12_y12__BLANK_) and R0(cell_x10_y10__BLANK_, cell_x11_y11__BLANK_)) : (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * 0.0016 ) + Sum (cell_x8_a0__BLANK_, cell_x8_b0__BLANK_, cell_x8_c2__BLANK_, cell_x8_d0__BLANK_, cell_x8_e0__BLANK_ | ((cell_2x(cell_x8_a0__BLANK_) or cell_2x(cell_x8_b0__BLANK_) or cell_2x(cell_x8_c2__BLANK_) or cell_2x(cell_x8_d0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and (cell_2b(cell_x8_a0__BLANK_) or cell_2x(cell_x8_a0__BLANK_)) and (cell_2b(cell_x8_b0__BLANK_) or cell_2x(cell_x8_b0__BLANK_)) and (cell_2b(cell_x8_c2__BLANK_) or cell_2x(cell_x8_c2__BLANK_)) and (cell_2b(cell_x8_d0__BLANK_) or cell_2x(cell_x8_d0__BLANK_)) and (cell_2b(cell_x8_e0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and R(cell_x8_d0__BLANK_, cell_x8_e0__BLANK_) and R(cell_x8_c2__BLANK_, cell_x8_d0__BLANK_) and R(cell_x8_b0__BLANK_, cell_x8_c2__BLANK_) and R(cell_x8_a0__BLANK_, cell_x8_b0__BLANK_)) : (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * 0.0016 )) + 50. * Sum ( | false : 0. * 0. * 0. * 0. * inf)" + "100. * (Sum (cell_a_y8__BLANK_, cell_b_y8__BLANK_, cell_c1_y8__BLANK_, cell_d_y8__BLANK_, cell_e_y8__BLANK_ | ((cell_2x(cell_a_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and (cell_2b(cell_a_y8__BLANK_) or cell_2x(cell_a_y8__BLANK_)) and (cell_2b(cell_b_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_)) and (cell_2b(cell_c1_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_)) and (cell_2b(cell_d_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_)) and (cell_2b(cell_e_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and R2(cell_d_y8__BLANK_, cell_e_y8__BLANK_) and R2(cell_c1_y8__BLANK_, cell_d_y8__BLANK_) and R2(cell_b_y8__BLANK_, cell_c1_y8__BLANK_) and R2(cell_a_y8__BLANK_, cell_b_y8__BLANK_)) : (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_)))^4. * 0.0016 ) + Sum (cell_x14_y18__BLANK_, cell_x15_y17__BLANK_, cell_x16_y16__BLANK_, cell_x17_y15__BLANK_, cell_x18_y14__BLANK_ | ((cell_2x(cell_x14_y18__BLANK_) or cell_2x(cell_x15_y17__BLANK_) or cell_2x(cell_x16_y16__BLANK_) or cell_2x(cell_x17_y15__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and (cell_2b(cell_x14_y18__BLANK_) or cell_2x(cell_x14_y18__BLANK_)) and (cell_2b(cell_x15_y17__BLANK_) or cell_2x(cell_x15_y17__BLANK_)) and (cell_2b(cell_x16_y16__BLANK_) or cell_2x(cell_x16_y16__BLANK_)) and (cell_2b(cell_x17_y15__BLANK_) or cell_2x(cell_x17_y15__BLANK_)) and (cell_2b(cell_x18_y14__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and R1(cell_x17_y15__BLANK_, cell_x18_y14__BLANK_) and R1(cell_x16_y16__BLANK_, cell_x17_y15__BLANK_) and R1(cell_x15_y17__BLANK_, cell_x16_y16__BLANK_) and R1(cell_x14_y18__BLANK_, cell_x15_y17__BLANK_)) : (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_)))^4. * 0.0016 ) + Sum (cell_x10_y10__BLANK_, cell_x11_y11__BLANK_, cell_x12_y12__BLANK_, cell_x13_y13__BLANK_, cell_x9_y9__BLANK_ | ((cell_2x(cell_x10_y10__BLANK_) or cell_2x(cell_x11_y11__BLANK_) or cell_2x(cell_x12_y12__BLANK_) or cell_2x(cell_x13_y13__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and (cell_2b(cell_x10_y10__BLANK_) or cell_2x(cell_x10_y10__BLANK_)) and (cell_2b(cell_x11_y11__BLANK_) or cell_2x(cell_x11_y11__BLANK_)) and (cell_2b(cell_x12_y12__BLANK_) or cell_2x(cell_x12_y12__BLANK_)) and (cell_2b(cell_x13_y13__BLANK_) or cell_2x(cell_x13_y13__BLANK_)) and (cell_2b(cell_x9_y9__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and R0(cell_x9_y9__BLANK_, cell_x10_y10__BLANK_) and R0(cell_x12_y12__BLANK_, cell_x13_y13__BLANK_) and R0(cell_x11_y11__BLANK_, cell_x12_y12__BLANK_) and R0(cell_x10_y10__BLANK_, cell_x11_y11__BLANK_)) : (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_)))^4. * 0.0016 ) + Sum (cell_x8_a0__BLANK_, cell_x8_b0__BLANK_, cell_x8_c2__BLANK_, cell_x8_d0__BLANK_, cell_x8_e0__BLANK_ | ((cell_2x(cell_x8_a0__BLANK_) or cell_2x(cell_x8_b0__BLANK_) or cell_2x(cell_x8_c2__BLANK_) or cell_2x(cell_x8_d0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and (cell_2b(cell_x8_a0__BLANK_) or cell_2x(cell_x8_a0__BLANK_)) and (cell_2b(cell_x8_b0__BLANK_) or cell_2x(cell_x8_b0__BLANK_)) and (cell_2b(cell_x8_c2__BLANK_) or cell_2x(cell_x8_c2__BLANK_)) and (cell_2b(cell_x8_d0__BLANK_) or cell_2x(cell_x8_d0__BLANK_)) and (cell_2b(cell_x8_e0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and R(cell_x8_d0__BLANK_, cell_x8_e0__BLANK_) and R(cell_x8_c2__BLANK_, cell_x8_d0__BLANK_) and R(cell_x8_b0__BLANK_, cell_x8_c2__BLANK_) and R(cell_x8_a0__BLANK_, cell_x8_b0__BLANK_)) : (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_)))^4. * 0.0016 )) + 50. * Sum ( | false : 0.^4. * inf)" (Formula.real_str loc_heurs.(0).(0)); ); Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2012-06-02 21:13:38 UTC (rev 1718) +++ trunk/Toss/Solver/Solver.ml 2012-06-03 22:47:21 UTC (rev 1719) @@ -261,8 +261,8 @@ let rec fo_vars_r_rec = function | RVar s -> [] | Const _ -> [] - | Times (r1, r2) -> List.rev_append (fo_vars_r_rec r1) (fo_vars_r_rec r2) - | Plus (r1, r2) -> List.rev_append (fo_vars_r_rec r1) (fo_vars_r_rec r2) + | Plus (r1, r2) | Times (r1, r2) | Pow (r1, r2) -> + List.rev_append (fo_vars_r_rec r1) (fo_vars_r_rec r2) | Fun (s, v) -> [v] | Char phi -> let fv = FormulaSubst.free_vars phi in @@ -284,11 +284,16 @@ | MSO _ -> failwith "free MSO vars in real exprs and sums not supported" | Real [[(poly, _)]] -> poly | Real _ -> failwith "too many polynomials in assignement to sum over" in + let rec pow p n = + if n = 0 then Const 1. else if n = 1 then p else Times (p, pow p (n-1)) in let rec poly_of assgn = function | RVar s -> Poly.Var s | Const f -> Poly.Const f | Times (r1, r2) -> Poly.Times (poly_of assgn r1, poly_of assgn r2) | Plus (r1, r2) -> Poly.Plus (poly_of assgn r1, poly_of assgn r2) + | Pow (r, Const (f)) when let n = int_of_float f in n >= 0 && float n = f -> + let n = int_of_float f in poly_of assgn (pow r n) + | Pow (_, _) -> failwith "poly_of: powers not supported" | Fun (s, v) -> (try let e = List.assoc v assgn in @@ -465,10 +470,12 @@ match expr with | Char phi -> if check_fa phi then 1. else 0. | Const v -> v + | Plus (e1, e2) -> + (get_real_val solver asg e1 struc) +. (get_real_val solver asg e2 struc) | Times (e1, e2) -> (get_real_val solver asg e1 struc) *. (get_real_val solver asg e2 struc) - | Plus (e1, e2) -> - (get_real_val solver asg e1 struc) +. (get_real_val solver asg e2 struc) + | Pow (e1, e2) -> + (get_real_val solver asg e1 struc) ** (get_real_val solver asg e2 struc) | Fun (fname, var) when List.length (AssignmentSet.assigned_elems (var_str var) asg) = 1 -> let elem = List.hd (AssignmentSet.assigned_elems (var_str var) asg) in @@ -513,6 +520,9 @@ | Times (e1, e2) -> (get_real_val_cache ~asg solver struc e1) *. (get_real_val_cache ~asg solver struc e2) + | Pow (e1, e2) -> + (get_real_val_cache ~asg solver struc e1) ** + (get_real_val_cache ~asg solver struc e2) | re -> update_cache struc; try Added: trunk/Toss/examples/Forces.toss =================================================================== --- trunk/Toss/examples/Forces.toss (rev 0) +++ trunk/Toss/examples/Forces.toss 2012-06-03 22:47:21 UTC (rev 1719) @@ -0,0 +1,55 @@ +PLAYERS 1, 2 + +RULE Coulomb: + [ e1, e2 | | ] -> [ e1, e2 | | ] + dynamics + :vx(e1)' = :ke *(:x(e1)-:x(e2)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^1.5; + :vy(e1)' = :ke *(:y(e1)-:y(e2)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^1.5; + :vx(e2)' = :ke *(:x(e2)-:x(e1)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^1.5; + :vy(e2)' = :ke *(:y(e2)-:y(e1)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^1.5; + :x(e1)' = :vx(e1); + :y(e1)' = :vy(e1); + :x(e2)' = :vx(e2); + :y(e2)' = :vy(e2) + pre :x(e1) > :x(e2) + +RULE Hooke: + [ e1, e2 | E (e1, e2) | ] -> [ e1, e2 | E (e1, e2) | ] emb E + dynamics + :vx(e1)' = -:k*((:x(e1)-:x(e2)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5) + * (((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5 - 15.); + :vy(e1)' = -:k*((:y(e1)-:y(e2)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5) + * (((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5 - 15.); + :vx(e2)' = -:k*((:x(e2)-:x(e1)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5) + * (((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5 - 15.); + :vy(e2)' = -:k*((:y(e2)-:y(e1)) / ((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5) + * (((:x(e1)-:x(e2))^2+(:y(e1)-:y(e2))^2)^0.5 - 15.); + :x(e1)' = 0.; + :y(e1)' = 0.; + :x(e2)' = 0.; + :y(e2)' = 0. + +RULE Friction: + [ e1 | | ] -> [ e1 | | ] + dynamics + :vx(e1)' = -:f * :vx(e1); + :vy(e1)' = -:f * :vy(e1); + :x(e1)' = 0.; + :y(e1)' = 0. + +RULE Move: + [ e1 | Start(e1) | ] -> [ e1 | Start(e1) | ] + +LOC 0 { + PLAYER 1 { PAYOFF 0. MOVES [Move, + :t : 3. -- 3., + :k : 0.1 -- 0.1, + :f : 0.1 -- 0.1, + :ke : 200. -- 200. -> 0] } + PLAYER 2 { PAYOFF 0. } + UNIVERSAL { Coulomb, Hooke, Friction } +} + +START [ e5 | Start(e1); E { (e1, e2); (e1, e3); (e1, e4) } | + vx { e1->0, e2->0, e3->0, e4->0, e5->0 }; vy { e1->0, e2->0, e3->0, e4->0,e5->0 }; + x { e1->0., e2->10., e3->10., e4->10, e5->0. }; y { e1->0., e2->9, e3->0, e4->-9, e5->0 } ] Added: trunk/Toss/examples/Parsing.toss =================================================================== --- trunk/Toss/examples/Parsing.toss (rev 0) +++ trunk/Toss/examples/Parsing.toss 2012-06-03 22:47:21 UTC (rev 1719) @@ -0,0 +1,16 @@ +PLAYERS 1, 2 +RULE NilList: + [e1 | Pnil(e1) | ] -> [a1, a2 | Pnil (a1); Tp (a1, a2); Tlist (a2) | ] + emb Pnil with [a1 <- e1] update + :x(a1) = :x(e1); + :x(a2) = :x(e1); + :y(a1) = :y(e1); + :y(a2) = :y(e1) + 1. + +LOC 0 { + PLAYER 1 { PAYOFF 0. MOVES [NilList -> 0] } + PLAYER 2 { PAYOFF 0. } +} + +START [ | Tp:2 {}; Tlist:1 {}; Pone (one); Ptrue (t); Pnil (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-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 -> - (string * int option * string array list) list -> structure +val create_from_lists_position: ?struc:structure -> + string list -> (string * int option * string array list) list -> structure +val create_from_lists_range: float -> ?struc:structure -> + string list -> (string * int option * string array list) list -> structure + (** {2 Removing relation tuples and elements from a structure} *) (** Remove the tuple [tp] from relation [rn] in structure [struc]. *) Modified: trunk/Toss/Solver/StructureParser.mly =================================================================== --- trunk/Toss/Solver/StructureParser.mly 2012-06-01 21:20:46 UTC (rev 1717) +++ trunk/Toss/Solver/StructureParser.mly 2012-06-02 21:13:38 UTC (rev 1718) @@ -70,6 +70,23 @@ rels = separated_list (SEMICOLON, rel_expr) MID MINUS CLOSESQ { fun struc -> create_from_lists_position ~struc elems rels } + | OPENSQ n = INT MINUS k = INT + MID + rels = separated_list (SEMICOLON, rel_expr) + MID + funs = separated_list (SEMICOLON, fun_expr) + CLOSESQ + { let elems = + List.map (fun i -> "e" ^ (string_of_int i)) (Aux.range ~from:n (k+1)) in + fun struc -> create_from_lists ~struc elems rels funs } + | OPENSQ n = INT MINUS k = INT + MID + rels = separated_list (SEMICOLON, rel_expr) + MID MINUS CLOSESQ + { let elems = + List.map (fun i -> "e" ^ (string_of_int i)) (Aux.range ~from:n (k+1)) in + fun struc -> + create_from_lists_range (float n) ~struc elems rels } | OPENSQ separated_list (COMMA, ID) MID Modified: trunk/Toss/Solver/StructureTest.ml =================================================================== --- trunk/Toss/Solver/StructureTest.ml 2012-06-01 21:20:46 UTC (rev 1717) +++ trunk/Toss/Solver/StructureTest.ml 2012-06-02 21:13:38 UTC (rev 1718) @@ -63,6 +63,14 @@ "[ | R (a, b) | f { a-> 1.3, b->2, c->3.3 } ; g { b -> 2 } ]" ); + "parse range" >:: + (fun () -> + test_parse + ~result:("[e2, e3, e4 | | nbr {e2->2., e3->3., e4->4.}; "^ + "x {e2->0., e3->15., e4->30.}; y {e2->0., e3->0., e4->0.}]") + "[ 2 - 4 | | - ]"; + ); + "incident" >:: (fun () -> test_incident "[a, b | R (a, b) | ]" This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <ab...@us...> - 2012-06-01 21:20:52
|
Revision: 1717 http://toss.svn.sourceforge.net/toss/?rev=1717&view=rev Author: abuzaid Date: 2012-06-01 21:20:46 +0000 (Fri, 01 Jun 2012) Log Message: ----------- Added simple evaluator interface to Client Added Paths: ----------- trunk/Toss/Client/JsEval.ml trunk/Toss/Client/SimpleEvaluator.ml trunk/Toss/Client/SimpleEvaluator.mli trunk/Toss/Client/SimpleEvaluatorTest.ml Added: trunk/Toss/Client/JsEval.ml =================================================================== --- trunk/Toss/Client/JsEval.ml (rev 0) +++ trunk/Toss/Client/JsEval.ml 2012-06-01 21:20:46 UTC (rev 1717) @@ -0,0 +1,32 @@ +open SimpleEvaluator + +(* 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 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 + let handle = Js.Unsafe.get js_handler fname in + let result = Js.Unsafe.fun_call handle (Js.to_array args) in + 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|] + +let _ = Js.Unsafe.set (Js.Unsafe.variable "self") (Js.string "onmessage") onmessage + +(* 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 _ = Js.Unsafe.set js_handler (Js.string "eval") (Js.wrap_callback js_eval) \ No newline at end of file Added: trunk/Toss/Client/SimpleEvaluator.ml =================================================================== --- trunk/Toss/Client/SimpleEvaluator.ml (rev 0) +++ trunk/Toss/Client/SimpleEvaluator.ml 2012-06-01 21:20:46 UTC (rev 1717) @@ -0,0 +1,10 @@ +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 Added: trunk/Toss/Client/SimpleEvaluator.mli =================================================================== --- trunk/Toss/Client/SimpleEvaluator.mli (rev 0) +++ trunk/Toss/Client/SimpleEvaluator.mli 2012-06-01 21:20:46 UTC (rev 1717) @@ -0,0 +1,4 @@ +(** 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 Added: trunk/Toss/Client/SimpleEvaluatorTest.ml =================================================================== --- trunk/Toss/Client/SimpleEvaluatorTest.ml (rev 0) +++ trunk/Toss/Client/SimpleEvaluatorTest.ml 2012-06-01 21:20:46 UTC (rev 1717) @@ -0,0 +1,12 @@ +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)"); + ); +] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
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))) | _ -> raise (DECODE "char") - let code_string s = let rec char_list i = if i < 0 then [] else s.[i] :: char_list (i-1) in let chars = List.rev (char_list ((String.length s) - 1)) in Modified: trunk/Toss/Term/Term.mli =================================================================== --- trunk/Toss/Term/Term.mli 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/Term/Term.mli 2012-05-27 21:18:03 UTC (rev 1716) @@ -39,6 +39,7 @@ val bits_to_int : int list -> int val code_bit : int -> term val decode_bit : term -> int +val decode_bit_list : term -> int val code_char : char -> term val decode_char : term -> char val code_string : string -> term Modified: trunk/Toss/Term/lib/arithmetics.trs =================================================================== --- trunk/Toss/Term/lib/arithmetics.trs 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/Term/lib/arithmetics.trs 2012-05-27 21:18:03 UTC (rev 1716) @@ -89,6 +89,12 @@ New variable m' as binary number. New variable k' as binary number. +New function ''to_bits'' ''('' binary number '')'' as bit list. +Let to_bits (0) be [bit 0]. +Let to_bits (1) be [bit 1]. +Let to_bits (n0) be bit 0, to_bits (n). +Let to_bits (n1) be bit 1, to_bits (n). + 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. @@ -427,6 +433,9 @@ as natural number. Let min (k, n) be if k <= n then k else n. +Function ''from'' natural number ''to'' natural number as natural number list. +Let from n to m be if m < n then [] else n, from n+1 to m. + Close context. Modified: trunk/Toss/Term/lib/basic.trs =================================================================== --- trunk/Toss/Term/lib/basic.trs 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/Term/lib/basic.trs 2012-05-27 21:18:03 UTC (rev 1716) @@ -2,4 +2,35 @@ Load state library:/lists. +// SET COMMANDS FOR ELEMENTS AND RELATIONS IN STRUCTURES. +New variable x as ?a. +New variable n as natural number. +New variable m as natural number. +New function ''put'' ?a ''at'' natural number '','' natural number + as set command list. +Let put x at n, m be set funx of x to to_bits (to_binary (n)), + set funy of x to to_bits (to_binary (m)). + +New function ''elements'' ?a list ''at'' funtype [?a] -> natural number + '','' funtype [?a] -> natural number as set command list. +New variable ''f'' ''('' ?a '')'' as natural number. +New variable ''g'' ''('' ?a '')'' as natural number. +New variable l as ?a list. +Let elements [] at f({}), g({}) be []. +Let elements x, l at f({}), g({}) be + put x at f(x), g(x) + elements l at f({}), g({}). + +Close context. + +New function ''relation'' string ''on'' ?a list ''given'' ''by'' + funtype [?a] -> (?a list) as set command list. +New variable s as string. +New variable ''f'' ''('' ?a '')'' as ?a list. +New variable x as ?a. +New variable l as ?a list. +Let relation s on [] given by f ({}) be []. +Let relation s on x, l given by f ({}) be + set addrel of s to f(x), relation s on l given by f({}). + +Close context. Modified: trunk/Toss/Term/tests/short_checks.log =================================================================== --- trunk/Toss/Term/tests/short_checks.log 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/Term/tests/short_checks.log 2012-05-27 21:18:03 UTC (rev 1716) @@ -58,6 +58,11 @@ Result: {false as boolean} +// SETTING STRUCTURE ELEMENTS BASIC TEST. + +Processed multiple set commands from: + put ""a"" at 10 , 20. + // LISTS TEST. New function "swap" "(" X_1 ")" declared. Modified: trunk/Toss/Term/tests/short_checks.trs =================================================================== --- trunk/Toss/Term/tests/short_checks.trs 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/Term/tests/short_checks.trs 2012-05-27 21:18:03 UTC (rev 1716) @@ -37,7 +37,10 @@ apply dbn {} 18. +// SETTING STRUCTURE ELEMENTS BASIC TEST. +Put "a" at 10, 20. + // LISTS TEST. New function ''swap('' boolean '')'' as boolean. Modified: trunk/Toss/www/codebasics.xml =================================================================== --- trunk/Toss/www/codebasics.xml 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/www/codebasics.xml 2012-05-27 21:18:03 UTC (rev 1716) @@ -15,17 +15,22 @@ and the last one contains the main executable and uses all previous ones. <itemize> <item><em>Formula</em> contains the type definition for formulas and - functions which operate on formulas only — substitutions for - variables, normal forms, simplifications, parsing and printing. - We also keep the module <em>Aux</em>, with many useful auxiliary - functions, in this directory. + functions which operate on formulas only — substitutions for + variables, normal forms, simplifications, parsing and printing. + We also keep the module <em>Aux</em>, with many useful auxiliary + functions, in this directory. </item> + <item><em>Term</em> contains the type definition for typed terms and + functions for term rewriting, type reconstruction and type-aware parsing. + It also contains a basic term rewriting language which is then used for + example for defining structures. + </item> <item><em>Solver</em> directory contains type definitions for structures, - variable assignments to structure elements, and the solver module for - calculating the assignments which satisfy a formula on - a structure. + variable assignments to structure elements, and the solver module for + calculating the assignments which satisfy a formula on + a structure. </item> - <item><em>Arena</em> is the directory in which we define structure + <item><em>Arena</em> is the directory in which we define structure rewriting games — discrete and continuous rewriting rules first, and finally the whole games in the <em>Arena</em> module. Discrete rule application is handled in the <em>DiscreteRule</em> module @@ -33,27 +38,29 @@ is split into the <em>Term</em> module and <em>ContinuousRule</em>. The parser for complete Toss games, i.e. the <em>.toss</em> files, is defined in <em>ArenaParser.mly</em>. - </item> - <item><em>Play</em> contains the modules related to making Toss play + </item> + <item><em>Play</em> contains the modules related to making Toss play any defined game automatically — we generate heuristics in the <em>Heuristic</em> module and use <em>GameTree</em> to implement a search to finally <em>Play</em>. - </item> - <item><em>GGP</em> is a directory devoted to translating games in the GDL + </item> + <item><em>GGP</em> is a directory devoted to translating games in the GDL language (Game Description Language) to the Toss format. We implement GDL parsing, basic operations, stepwise translation and finally some simplification of the resulting games. There are also tests in the <em>GGP/examples</em> sub-directory. - </item> - <item><em>Language</em> is not used for now, we keep it because we plan - to experiment with better syntax for Toss in the future. - </item> - <item><em>Server</em> contains the main executable of Toss (in the file + </item> + <item><em>Learn</em> contains the algorithm for differentiating structures + by formulas of various logics, which is then used to learn games from + example plays. We also keep there a program to recognize plays from + videos, which allows to go from video demonstrations to game playing. + </item> + <item><em>Server</em> contains the main executable of Toss (in the file <em>Server.ml</em>) and the main request handler in the <em>ReqHandler</em> module, with other files as needed (e.g. database connection handler in <em>DB</em>). We also keep the lists of all unit tests there, in <em>Server/Tests.ml</em>. - </item> + </item> </itemize> The command <em>make TossFullTest</em> runs all unit tests for all modules from all directories. As this takes some time, we often execute only @@ -70,7 +77,7 @@ so if you intend to only operate on formulas, you should add your module to the <em>Formula</em> directory. If you want to be able to use all functions of Toss (or just not worry about the dependencies for now), - add your module to the <em>Server</em> directory, which incldues all + add your module to the <em>Server</em> directory, which includes all other directories in its dependency list.<br/> As a starting example, let's add a module that parses a formula and a structure from strings and returns a print-out of the satisfying Modified: trunk/Toss/www/index.xml =================================================================== --- trunk/Toss/www/index.xml 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/www/index.xml 2012-05-27 21:18:03 UTC (rev 1716) @@ -35,6 +35,8 @@ <section title="News"> <itemize> + <newsitem date="27/05/12"> + First structures defined using the term rewriting system syntax</newsitem> <newsitem date="24/05/12"> Code for Term functions cleaned up and made JS compatible</newsitem> <newsitem date="13/05/12"> Modified: trunk/Toss/www/ocaml.xml =================================================================== --- trunk/Toss/www/ocaml.xml 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/www/ocaml.xml 2012-05-27 21:18:03 UTC (rev 1716) @@ -12,7 +12,7 @@ <section title="Task: Simple Formula Library"> We think it is best to illustrate the problems encountered and how we - decided to organise code in Toss on an example task. In this + decided to organize code in Toss on an example task. In this tutorial, we will build a very simple program to manipulate propositional formulas. Let's state the task as follows: <em>Build a program to compute the NNF of formulas given on input.</em> We will construct the @@ -76,7 +76,7 @@ </section> <section title="Step 3 — Lexer and Parser"> - To allow the user to input formuas, we have to construct a lexer and + To allow the user to input formulas, we have to construct a lexer and a parser. We will not do it by hand, but use a parser generator called <a href="http://gallium.inria.fr/~fpottier/menhir/">menhir</a>. Here is the simple lexer file we use for lexing formulas. @@ -345,19 +345,19 @@ functions <em>formula_of_string</em> and <em>nnf</em> as in previous steps. The only difference is that we have to convert from JavaScript strings to OCaml with <em>Js.to_string</em> and back with <em>Js.string</em>. In the - last line, we regiser the <em>js_nnf</em> OCaml function under the name + last line, we register the <em>js_nnf</em> OCaml function under the name <em>nnf</em> in JavaScript. It is then called in JavaScript using the invocation <em>ASYNCH ("nnf", [args], continuation)</em>, as shown above in the <em>index.html</em> file. Here is how we compile <em>JsClient.ml</em>. <pre> -camlbuild -use-menhir -menhir "menhir --external-tokens Lexer" \ +ocamlbuild -use-menhir -menhir "menhir --external-tokens Lexer" \ -pp "camlp4o -I /opt/local/lib/ocaml/site-lib js_of_ocaml/pa_js.cmo" \ -cflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml -libs js_of_ocaml \ -lflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml JsClient.byte js_of_ocaml JsClient.byte </pre> Note that the first command is just a standard ocamlbuild call, only this - time we compile to bytcode, not to a native executable, and we use the + time we compile to bytecode, not to a native executable, and we use the preprocessor that comes with js_of_ocaml (used e.g. in the call <em>event##data##args</em>). The second command invokes <em>js_of_ocaml</em> and compiles the bytecode to a JavaScript file <em>JsClient.js</em>. Modified: trunk/Toss/www/pub/fmt12_slides.pdf =================================================================== --- trunk/Toss/www/pub/fmt12_slides.pdf 2012-05-26 22:28:13 UTC (rev 1715) +++ trunk/Toss/www/pub/fmt12_slides.pdf 2012-05-27 21:18:03 UTC (rev 1716) @@ -3727,22 +3727,15 @@ /Filter /FlateDecode >> stream -x\xDA\xC5XMo\xE36\xBD\xE7W\xF0(\xC3\xEF\x8FܲE\xEC\xB6(\xBAY=\xA4{\xD0ڌ\xAC-\xA5\xB1\xD2\xFD\xFB\x8A\x92cɲ\xB4\x86\xB8([\x94E\xCE{\xCE\xE3\x8CH\xD0twEzW -W -\xD7\xE0\x82\xB8b\xD8p\x89\x98f\x982\x85^z\xBC\xFAx2\xE8\xFF\xBA\xB6dO\x9Ec\x85\xC2W\xE75\xEA\xDC\xDF\xFF |
From: <luk...@us...> - 2012-05-26 22:28:22
|
Revision: 1715 http://toss.svn.sourceforge.net/toss/?rev=1715&view=rev Author: lukaszkaiser Date: 2012-05-26 22:28:13 +0000 (Sat, 26 May 2012) Log Message: ----------- Update www and make it english-only, extend OCaml tutorial to cover our use of js_of_ocaml. Modified Paths: -------------- trunk/Toss/www/.cvsignore trunk/Toss/www/Makefile trunk/Toss/www/Publications/Makefile trunk/Toss/www/Publications/all.bib trunk/Toss/www/bin/hrefprocess trunk/Toss/www/codebasics.xml trunk/Toss/www/contact.xml trunk/Toss/www/create.xml trunk/Toss/www/develop.xml trunk/Toss/www/docs.xml trunk/Toss/www/ideas.xml trunk/Toss/www/index.xml trunk/Toss/www/learn.xml trunk/Toss/www/navigation.xml trunk/Toss/www/ocaml.xml trunk/Toss/www/play.xml trunk/Toss/www/xsl/layout.xsl trunk/Toss/www/xsl/main.xsl Added Paths: ----------- trunk/Toss/www/pub/fmt12_slides.pdf Removed Paths: ------------- trunk/Toss/www/default.mak Property Changed: ---------------- trunk/Toss/www/ Property changes on: trunk/Toss/www ___________________________________________________________________ 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 . *.html *.html.de *.html.en *.html.fr *.html.pol *.texml *.xml.de *.xml.en *.xml.fr *.xml.pol reference.xml code_doc *.ps *.dvi *.aux *.out *.log *.bbl *.blg *.idx *.thm *.snm *.nav *.toc *.flc *~ + # 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 . *.html *.texml code_doc *~ Modified: trunk/Toss/www/.cvsignore =================================================================== --- trunk/Toss/www/.cvsignore 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/.cvsignore 2012-05-26 22:28:13 UTC (rev 1715) @@ -3,28 +3,6 @@ # svn propset svn:ignore -F .cvsignore . *.html -*.html.de -*.html.en -*.html.fr -*.html.pol *.texml -*.xml.de -*.xml.en -*.xml.fr -*.xml.pol -reference.xml code_doc -*.ps -*.dvi -*.aux -*.out -*.log -*.bbl -*.blg -*.idx -*.thm -*.snm -*.nav -*.toc -*.flc *~ Modified: trunk/Toss/www/Makefile =================================================================== --- trunk/Toss/www/Makefile 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/Makefile 2012-05-26 22:28:13 UTC (rev 1715) @@ -1,11 +1,76 @@ TOPDIR = . -include $(TOPDIR)/default.mak +BINDIR = $(TOPDIR)/bin +BIB_FILES = $(wildcard ./*.bib) +BIBTEXML_TEX_FILES = $(patsubst %.bib,%.texml,$(BIB_FILES)) +BIBTEXML_FILES = $(patsubst %.bib,%.xml,$(BIB_FILES)) + +AUXILIARY_FILES = $(TOPDIR)/navigation.xml $(TOPDIR)/people.xml $(TOPDIR)/Publications/all.bib + +XML_FILES = $(filter-out $(AUXILIARY_FILES) $(foreach lang,$(LANGS),$(wildcard ./*.$(lang).xml)) $(BIBTEXML_FILES),$(wildcard ./*.xml)) + +ALL_HTML_FILES = $(patsubst %.xml,%.html,$(XML_FILES)) +HTML_FILES = $(filter-out $(patsubst %.xml,%.html,$(BIBTEXML_FILES)),$(ALL_HTML_FILES)) + +XSL_FILES = $(wildcard ./$(TOPDIR)/xsl/*.xsl) $(wildcard ./$(TOPDIR)/xsl/include/*.xsl) + + +XSLTPROC_PARAM = --stringparam "year" "`date -r $< +"%Y"`" \ + --stringparam "last-mod" "`date -r $< +"%d %B %Y"`" \ + --stringparam "topdir" "$(TOPDIR)" \ + --stringparam "title" "" + +# create a list of all subdirs and move Publications (if it exists) to the first +# position +ALLSUBDIRS = $(shell find . -maxdepth 1 -mindepth 1 -path './.svn*'\ + -prune -o -type d -path './[A-Z]*' -printf '%P ') +SUBDIRS = $(findstring Publications, $(ALLSUBDIRS)) \ + $(filter-out Publications,$(ALLSUBDIRS)) + + +all: allsubdirs $(XML_FILES) $(HTML_FILES) $(HTML_FILES) bib + +allsubdirs: + for d in $(SUBDIRS); do (make -C $$d) done + + +bib: $(BIBTEXML_FILES) $(BIBTEXML_TEX_FILES) + + +%.texml: %.bib + $(BINDIR)/bib2xml $< | $(BINDIR)/unflatten.py --unflatten -\ + | sed 's/<?xml version="1.0" ?>/<?xml version="1.0" ?>\n/' > $@ + +%.xml: %.bib $(BINDIR)/tex2html + $(BINDIR)/bib2xml $< | $(BINDIR)/unflatten.py --unflatten -\ + | sed 's/<?xml version="1.0" ?>/<?xml version="1.0" ?>\n/'\ + | $(BINDIR)/tex2html $(TOPDIR) > $@ + + +XML_LANG_PATTERN = $(foreach lang,$(LANGS),%.xml.$(lang)) + +$(XML_LANG_PATTERN) : %.xml $(AUXILIARY_FILES) $(XSL_FILES) + for lang in $(LANGS); do \ + xsltproc --stringparam "lang" "$$lang" $(TOPDIR)/xsl/language.xsl $< \ + > $*.xml.$$lang ;\ + chmod 664 $*.xml.$$lang ;\ + done + + +%.html : %.xml $(AUXILIARY_FILES) $(XSL_FILES) $(BIBTEXML_FILES) + xsltproc $(XSLTPROC_PARAM) --stringparam "lang" "en" --stringparam "uri" "$<" $< \ + | $(BINDIR)/hrefprocess "$(TOPDIR)" "en" > $@ ;\ + chmod 664 $@ ;\ + code_doc_link: ln -s ../_build/Toss.docdir code_doc rm -f code_doc/Toss.docdir - cp code_doc/index.html code_doc/index.html.en - cp code_doc/index.html code_doc/index.html.de - cp code_doc/index.html code_doc/index.html.pol - cp code_doc/index.html code_doc/index.html.fr + + +clean: + rm -f $(HTML_FILES) + rm -f $(BIBTEXML_FILES) + rm -f $(BIBTEXML_TEX_FILES) + for d in $(SUBDIRS); do (make -C $$d clean) done + rm -f *~ Modified: trunk/Toss/www/Publications/Makefile =================================================================== --- trunk/Toss/www/Publications/Makefile 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/Publications/Makefile 2012-05-26 22:28:13 UTC (rev 1715) @@ -1,6 +1,5 @@ TOPDIR = .. BINDIR = $(TOPDIR)/bin -LANGS = de en fr pol BIB_FILES = $(wildcard ./*.bib) BIBTEXML_TEX_FILES = $(patsubst %.bib,%.texml,$(BIB_FILES)) @@ -13,21 +12,17 @@ AUTHORS = all kaiser HTML_FILES = $(patsubst %,%.html,$(AUTHORS)) -HTML_LANG_FILES = $(foreach lang,$(LANGS),$(patsubst %.html,%.html.$(lang),$(HTML_FILES))) - XSL_FILES = $(wildcard ./$(TOPDIR)/xsl/*.xsl) $(wildcard ./$(TOPDIR)/xsl/include/*.xsl) # special parameter for html-title on publication pages!!! XSLTPROC_PARAM = --stringparam "year" "`date -r all.bib +"%Y"`" --stringparam "last-mod" "`date -r all.bib +"%d. %B %Y"`" --stringparam "topdir" "$(TOPDIR)" --stringparam "title" "Publications" -all: index bib $(HTML_LANG_FILES) +all: index bib $(HTML_FILES) -index: $(foreach lang,$(LANGS),all.html.$(lang)) - for lang in $(LANGS); do \ - cp all.html.$$lang index.html.$$lang ;\ - chmod 664 index.html.$$lang ;\ - done +index: all.html + cp all.html index.html + chmod 664 index.html bib: $(BIBTEXML_FILES) $(BIBTEXML_TEX_FILES) @@ -40,19 +35,13 @@ | sed 's/<?xml version="1.0" ?>/<?xml version="1.0" ?>\n/'\ | $(BINDIR)/tex2html $(TOPDIR) | $(BINDIR)/clean-xml-bib > $@ -HTML_LANG_PATTERN = $(foreach lang,$(LANGS),%.html.$(lang)) -$(HTML_LANG_PATTERN) : index.xml $(SUPPLEMENTARY_FILES) $(XSL_FILES) $(BIBTEXML_TEX_FILES) $(BIBTEXML_FILES) - for lang in $(LANGS); do \ - xsltproc $(XSLTPROC_PARAM) --stringparam "author" "$(basename $(basename $@))"\ - --stringparam "lang" "$$lang" --stringparam "uri" "$*.xml" index.xml \ - | $(BINDIR)/hrefprocess "$(TOPDIR)" "$$lang" > $*.html.$$lang ;\ - chmod 664 $*.html.$$lang ;\ - done +%.html : index.xml $(SUPPLEMENTARY_FILES) $(XSL_FILES) $(BIBTEXML_TEX_FILES) $(BIBTEXML_FILES) + xsltproc $(XSLTPROC_PARAM) --stringparam "author" "$(basename $(basename $@))"\ + --stringparam "lang" "en" --stringparam "uri" "$*.xml" index.xml \ + | $(BINDIR)/hrefprocess "$(TOPDIR)" "en" > $*.html + chmod 664 $*.html clean: - rm -f $(HTML_LANG_FILES) - for lang in $(LANGS); do \ - rm -f index.html.$$lang ;\ - done + rm -f $(HTML_FILES) index.html rm -f $(BIBTEXML_FILES) rm -f $(BIBTEXML_TEX_FILES) Modified: trunk/Toss/www/Publications/all.bib =================================================================== --- trunk/Toss/www/Publications/all.bib 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/Publications/all.bib 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,8 +4,16 @@ # TALKS -@inproceedings{KCONSTRAINTES11, +@inproceedings{KFMT12, author={Toss}, + title={Learning and Playing Board Games from the FMT Perspective}, + url = {/pub/fmt12_slides.pdf}, + booktitle= {FMT Workshop, Les Houches}, + year={2012 Talk} +} + +@inproceedings{KCONSTRAINTES12, + author={Toss}, title={Quantitative Logics on Structure Rewriting Systems}, url = {/pub/contraintes_slides.pdf}, booktitle= {EPI Contraintes Seminar, INRIA Paris-Rocquencourt}, @@ -168,7 +176,8 @@ author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak}, title = {Translating the Game Description Langauge to Toss}, year = {2011}, - booktitle = {to appear}, + booktitle = {Proceedings of the 2nd International General Game + Playing Workshop, GIGA'11}, url = {/pub/gdl_to_toss_translation.pdf}, abstract = { We show how to translate games defined in the Game Description Modified: trunk/Toss/www/bin/hrefprocess =================================================================== --- trunk/Toss/www/bin/hrefprocess 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/bin/hrefprocess 2012-05-26 22:28:13 UTC (rev 1715) @@ -2,7 +2,7 @@ sed 's&src="/\([^"]*\)"&src="'$1'/\1"&g' |\ sed 's&href="/\([^"]*\)"&href="'$1'/\1"&g' |\ -sed '/href="http/!s&href="\([^"]*\)/"&href="\1/index.html.'$2'"&g' |\ -sed '/href="http/!s&href="\([^"]*\)\.html"&href="\1.html.'$2'"&g' |\ +sed '/href="http/!s&href="\([^"]*\)/"&href="\1/index.html"&g' |\ +sed '/href="http/!s&href="\([^"]*\)\.html"&href="\1.html"&g' |\ sed '/href="http/!s&href="code_doc\([^"]*\)\.html.\([a-z]*\)"&href="code_doc\1.html"&g' |\ sed '' Modified: trunk/Toss/www/codebasics.xml =================================================================== --- trunk/Toss/www/codebasics.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/codebasics.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,10 +4,7 @@ <?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?> <personal> - <title lang="en">Toss Code Basics Tutorial</title> - <title lang="de">Toss Code Basics Tutorial (auf Englisch)</title> - <title lang="pol">Toss Code Basics Tutorial (po angielsku)</title> - <title lang="fr">Toss Code Basics Tutorial (en anglais)</title> + <title>Toss Code Basics Tutorial</title> <history> <link id="develop" href="/develop.html">Develop Toss</link> </history> Modified: trunk/Toss/www/contact.xml =================================================================== --- trunk/Toss/www/contact.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/contact.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,17 +4,14 @@ <?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?> <personal> - <title lang="en">Contact and Links</title> - <title lang="de">Kontakt und Links</title> - <title lang="pol">Kontakt i Linki</title> - <title lang="fr">Contact et Liens</title> + <title>Contact and Links</title> <history> <link id="contact" href="/contact.html">Contact</link> </history> <portrait src="http://sflogo.sourceforge.net/sflogo.php?group_id=115606&type=15"/> - <section title="Email" lang="en"> + <section title="Email"> <par>Toss is an open source project hosted by <a href="http://sourceforge.net">SourceForge</a> and distributed under the BSD licence.<br/></par> @@ -22,32 +19,8 @@ <mailto address="tos...@li..."/> </par> </section> - <section title="Email" lang="de"> - <par>Toss ist ein Open-Source Projekt, wird auf - <a href="http://sourceforge.net">SourceForge</a> - gehosted und unter der BSD Lizenz distribuiert.<br/></par> - <par>Man kann uns unter folgener Adresse erreichen: - <mailto address="tos...@li..."/> - </par> - </section> - <section title="Email" lang="pol"> - <par>Toss jest projektem open source z hostem na - <a href="http://sourceforge.net">SourceForge</a> - i pod licencją BSD.<br/></par> - <par>Najłatwiej się z nami skontaktować pisząc na - <mailto address="tos...@li..."/>. - </par> - </section> - <section title="Email" lang="fr"> - <par>Toss est un projet open source hébergé par - <a href="http://sourceforge.net">SourceForge</a> - et distribué sous la licence BSD.<br/></par> - <par>Contactez-nous par écrit à - <mailto address="tos...@li..."/> - </par> - </section> - <section title="Toss Links" lang="en"> + <section title="Toss Links"> <itemize> <item><a href="http://sourceforge.net/projects/toss/">Toss Project at SourceForge.net</a></item> @@ -55,33 +28,8 @@ Toss Subversion Repository</a></item> </itemize> </section> - <section title="Links zu Toss" lang="de"> - <itemize> - <item><a href="http://sourceforge.net/projects/toss/">Toss Projekt auf - SourceForge.net</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/"> - Toss Subversion Repository</a></item> - </itemize> - </section> - <section title="Linki Tossa" lang="pol"> - <itemize> - <item><a href="http://sourceforge.net/projects/toss/">Projekt Toss na - SourceForge.net</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/"> - Toss Subversion Repository</a></item> - </itemize> - </section> - <section title="Toss Liens" lang="fr"> - <itemize> - <item><a href="http://sourceforge.net/projects/toss/">Projet Toss à - SourceForge.net</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/"> - Toss Subversion Repository</a></item> - </itemize> - </section> - - <section title="Game Playing Links" lang="en"> + <section title="Game Playing Links"> <itemize> <item><a href="http://www.apronus.com/chess/wbeditor.php">Apronus Chess Board Editor</a> is our favorite site for simple chess board editing. @@ -108,97 +56,9 @@ Turn</a> allows you to play various board games online.</item> </itemize> </section> - <section title="Links zu Spielprogrammen" lang="de"> - <itemize> - <item><a href="http://www.apronus.com/chess/wbeditor.php">Apronus Chess - Board Editor</a> ist unser beliebter einfacher Schachbretteditor. - </item> - <item><a href="http://www.dozingcatsoftware.com/Gridlock/">Gridlock</a> - ist eine Sammlung von Open-Source Spielen. Es spielt gut, erlaubt - aber nicht das Spiel zu editieren. - </item> - - <item><a href="http://www.zillions-of-games.com/">Zillions of Games</a> - ist eine Sprache für Spieldefinitionen, ein Simulator und eine große - Bibliothek von Spielen. Leider ist es nicht Open-Source. - </item> - - <item><a href="http://www.kurnik.pl/">Kurnik</a> ist eine polnische - Spielseite mit verschiedenen Spielen.</item> - - <item><a href="http://abstractstrategy.com/main.html">Abstract - Strategy Games</a> erlaubt es, strategische Spiele zu lernen - und zu spielen. - </item> - - <item><a href="http://www.yourturnmyturn.com/">Your Turn My - Turn</a> erlaubt es, Brettspiele online zu spielen.</item> - </itemize> - </section> - <section title="Linki do Programów do Gier" lang="pol"> + <section title="Modelling Links"> <itemize> - <item><a href="http://www.apronus.com/chess/wbeditor.php">Apronus Chess - Board Editor</a> to nasz ulubiony prosty edytor pozycji szachowych. - </item> - - <item><a href="http://www.dozingcatsoftware.com/Gridlock/">Gridlock</a> - to zbiór gier planszowych open-source. Miło z nim grać, ale nie - pozwala edytować gry ani stanu planszy. - </item> - - <item><a href="http://www.zillions-of-games.com/">Zillions of Games</a> - to język do definicji gier wraz z symulatorem i pokaźną biblioteką - przeróżnych gier. Niestety, nie jest to program open-source. - </item> - - <item><a href="http://www.kurnik.pl/">Kurnik</a> to polska strona - na której można grać w różne gry planszowe i karciane.</item> - - <item><a href="http://abstractstrategy.com/main.html">Abstract - Strategy Games</a> pozwala uczyć się i grać w gry strategiczne. - </item> - - <item>Na <a href="http://www.yourturnmyturn.com/">Your Turn My - Turn</a> możesz zagrać w różne gry planszowe.</item> - </itemize> - </section> - <section title="Liens vers les Programmes les Jeux" lang="fr"> - <itemize> - <item><a href="http://www.apronus.com/chess/wbeditor.php">Apronus Chess - Board Editor</a> est notre site favori pour l'édition simple - d'échiquier. - </item> - - <item><a href="http://www.dozingcatsoftware.com/Gridlock/">Gridlock</a> - est une collection de jeux open-source. Il est agréable de jouer - mais ne permet pas de changer le jeu. - </item> - - <item><a href="http://www.zillions-of-games.com/">Zillions of Games</a> - est un langage de définition des jeux avec un simulateur et un grand - bibliothèque de jeux. Il est très agréable mais malheureusement - pas open source. - </item> - - <item><a href="http://www.kurnik.pl/">Kurnik</a> - est un site polonais sur lequel vous pouvez jouer à des jeux divers. - </item> - - <item><a href="http://abstractstrategy.com/main.html">Abstract - Strategy Games</a> site vous permet d'apprendre et de jouer - à des jeux abstraits de stratégie. - </item> - - <item><a href="http://www.yourturnmyturn.com/">Your Turn My - Turn</a> vous permet de jouer à divers jeux en ligne. - </item> - </itemize> - </section> - - - <section title="Modelling Links" lang="en"> - <itemize> <item><a href="http://edu.kde.org/step/">Step</a> is an open-source physics simulator, a part of the KDE Education Project. It can be used for simulation of systems with continuous @@ -216,64 +76,8 @@ </item> </itemize> </section> - <section title="Links zu Simulation- und Modellierungprogrammen" lang="de"> - <itemize> - <item><a href="http://edu.kde.org/step/">Step</a> - ist ein Open-Source Physiksimulator, ein Teil des KDE Education Project. - Man kann damit Systeme mit kontinuierliches Dynamik simulieren. - </item> - <item><a href="http://www.iseesystems.com/softwares/Education/StellaSoftware.aspx">STELLA</a> ist ein kommerzielles Simulationsprogramm und erlaubt - sowohl diskrete als auch kontinuierliche Dynamik. - </item> - - <item><a href="http://ptolemy.eecs.berkeley.edu/">Ptolemy</a> Projekt - erforscht Modellierung, Simulation und das Design von nebenläufigen in - Echtzeit laufenden eingebetteten Systemen. Es erlaubt verschiedene - Modelle von Berechnungen gleichzeitig zu verknüpfen und zu nutzen. - </item> - </itemize> - </section> - <section title="Linki do Programów do Modelowania" lang="pol"> - <itemize> - <item><a href="http://edu.kde.org/step/">Step</a> to open-sourcowy - symulator fizyki, część KDE Education Project. Pozwala na - symulację systemów z ciągłą dynamiką. - </item> - - <item><a href="http://www.iseesystems.com/softwares/Education/StellaSoftware.aspx">STELLA</a> to komercyjny symulator pozwalający definiować zarówno - ciągłą jak i dyskretną dynamikę. - </item> - - <item><a href="http://ptolemy.eecs.berkeley.edu/">Ptolemy</a> to projekt - w którym badane jest modelowanie, symulacja i design równoległych - systemów czasu rzeczywistego. Ten zaawansowany projekt pozwala łączyć - różne modele obliczeń i używać ich w tym samym projekcie. - </item> - </itemize> - </section> - <section title="Liens de Modélisation" lang="fr"> - <itemize> - <item><a href="http://edu.kde.org/step/">Step</a> - est un simulateur open-source de physique, une partie de KDE Education - Projet. Il peut être utilisé pour simulation de systèmes avec - la dynamique continue. - </item> - - <item><a href="http://www.iseesystems.com/softwares/Education/StellaSoftware.aspx">STELLA</a> est un simulateur commercial, permettant d'utiliser la - dynamique continue et discrète. - </item> - - <item><a href="http://ptolemy.eecs.berkeley.edu/">Ptolemy</a> projet - étudie de modélisation, de simulation et la conception de systèmes - concurrents, en temps réel. Ce projet permet d'utiliser différents - modèles de calcul qui régissent les interactions entre les composants. - </item> - </itemize> - </section> - - - <section title="Team" lang="en"> + <section title="Team"> <par>Toss originates from our work in the <a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a> research group. Many people contributed, here we name just a few. Current leaders:</par> @@ -297,80 +101,5 @@ <item>Peter Cholewinski</item> </itemize> </section> - <section title="Team" lang="de"> - <par>Die Arbeit an Toss begann im Graduiertenkolleg - <a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a>. - Viele haben dazu beigetragen, hier benennen wir - nur einige Mitwirkende. Zur Zeit programmieren am meisten:</par> - <itemize> - <item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item> - <item>Łukasz Stafiniak</item> - </itemize> - <par>Freunde, die uns sehr geholfen haben.</par> - <itemize> - <item>Dietmar Berwanger</item> - <item>Matko Botincan</item> - <item>Diana Fischer</item> - <item>Tobias Ganzow</item> - <item>Simon Leßenich</item> - <item>Michał Wójcik</item> - </itemize> - <par>Einige andere Mitarbeiter haben an der ältesten Version von - Toss (ca. 2004) gearbeitet.</par> - <itemize> - <item>Alexander Kharitonov</item> - <item>Peter Cholewinski</item> - </itemize> - </section> - <section title="Team" lang="pol"> - <par>Toss wywodzi się z prac i dyskusji w gronie - <a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a>. - Wiele osób pracowało nad Tossem w różnych okresach, tutaj - wymieniamy tylko niektóre z nich. Obecnie najwięcej pracują:</par> - <itemize> - <item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item> - <item>Łukasz Stafiniak</item> - </itemize> - <par>Przyjaciele, którzy bardzo nam pomogli.</par> - <itemize> - <item>Dietmar Berwanger</item> - <item>Matko Botincan</item> - <item>Diana Fischer</item> - <item>Tobias Ganzow</item> - <item>Simon Leßenich</item> - <item>Michał Wójcik</item> - </itemize> - <par>Inna grupa osób pracowała nad najstarszą wersją Tossa - (około 2004).</par> - <itemize> - <item>Alexander Kharitonov</item> - <item>Peter Cholewinski</item> - </itemize> - </section> - <section title="Team" lang="fr"> - <par>Toss Toss est originaire de notre travail dans le groupe de - recherche <a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a>. - Plusieurs personnes ont contribué, ici, nous n'en nommer pas tous. - Les dirigeants actuels:</par> - <itemize> - <item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item> - <item>Łukasz Stafiniak</item> - </itemize> - <par>Les amis qui nous ont aidé par la discussion et le code.</par> - <itemize> - <item>Dietmar Berwanger</item> - <item>Matko Botincan</item> - <item>Diana Fischer</item> - <item>Tobias Ganzow</item> - <item>Simon Leßenich</item> - <item>Michał Wójcik</item> - </itemize> - <par>Un autre groupe de personnes, qui ont travaillé sur la version - la plus ancienne de Toss (environ 2004), a été dirigée par:</par> - <itemize> - <item>Alexander Kharitonov</item> - <item>Peter Cholewinski</item> - </itemize> - </section> </personal> Modified: trunk/Toss/www/create.xml =================================================================== --- trunk/Toss/www/create.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/create.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,16 +4,13 @@ <?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?> <personal> - <title lang="en">Create New Games</title> - <title lang="de">Neue Spiele Erzeugen</title> - <title lang="pol">Stwórz Nową Grę</title> - <title lang="fr">Créez des jeux nouveaux</title> + <title>Create New Games</title> <history> <link id="docs" href="/docs.html">Documentation</link> <link id="create" href="/create.html">Create</link> </history> - <section title="Toss Files" lang="en"> + <section title="Toss Files"> <par>To understand the meaning of the fields in the .toss file, you should first be acquainted with Toss: at least skim through the <a href="reference/reference.pdf">reference.pdf</a> file and look @@ -26,73 +23,13 @@ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item> </itemize> </section> - <section title="Toss Files" lang="de"> - <par>Um die verschiedenen Felder im .toss Files zu verstehen ist es - nötig, erstmal die Grundlagen von Toss durchzuarbeiten, z.B. indem man - das <a href="reference/reference.pdf">reference.pdf</a> File wenigstens - durchblättert und die <a href="docs.html">Dokumentation</a> liest. - Danach kann man einfach die .toss Files im Editor - bearbeiten, mit einer des folgenden kann man gut anfangen. - </par> - <itemize> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item> - </itemize> - </section> - <section title="Pliki toss" lang="pol"> - <par>Żeby zrozumieć co znaczą poszczególne pola w pliku .toss trzeba - znać już podstawy Tossa – np. przekartkować plik - <a href="reference/reference.pdf">reference.pdf</a> i zerknąć na - <a href="docs.html">dokumentację</a>. Potem można po prostu - edytować pliki .toss, być może zaczynając od jednego z tych. - </par> - <itemize> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item> - </itemize> - </section> - <section title="Fichiers toss" lang="fr"> - <par>Pour comprendre le contenu des fichiers .toss, vous devriez vous - familiariser avec le Toss: au moins parcourir - <a href="reference/reference.pdf">Reference.pdf</a> et jeter un coup d'oeil - sur notre <a href="docs.html">documentation</a>. Après cela, vous pouvez - simplement éditer un fichier .toss, peut-être commençant par un de ceux-ci. - </par> - <itemize> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item> - <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item> - </itemize> - </section> - - <section title="More Complex Games" lang="en"> + <section title="More Complex Games"> <par>To create more complex games, like Chess, is it convenient to edit directly the .toss game definition files. Here are a few standard games defined in Toss. You can use them as a starting point for your own definitions.</par> </section> - <section title="Kompliziertere Spiele" lang="de"> - <par>Um kompliziertere Spiele, wie Schach, zu definieren, ist es - bequem, direkt die .toss Files zu bearbeiten. - Unten geben wir die .toss Files für einige der Standardspiele an. - Man kann diese Files auch als Anfangspunkt für eigene Spiele nutzen.</par> - </section> - <section title="Bardziej Złożone Gry" lang="pol"> - <par>Gdy definiuje się w Tossie bardziej złożone gry, takie jak szachy, - wygodnie jest edytować bezpośrednio pliki .toss. - Poniżej podajemy pliki .toss dla kilku znanych gier, możesz ich - też użyć jako podstawy do stworzenia własnej gry.</par> - </section> - <section title="Des jeux plus complèxes" lang="fr"> - <par>Dans le cas de création des jeux plus complèxes, comme les échecs, - il est plus practique de modifier la définition du jeu directement dans - un fichier textuel .toss. Voici quelques jeux définies en Toss, vous pouvez - les utiliser comme le point de départ pour vos propres définitions. - </par> - </section> <section> <itemize> Deleted: trunk/Toss/www/default.mak =================================================================== --- trunk/Toss/www/default.mak 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/default.mak 2012-05-26 22:28:13 UTC (rev 1715) @@ -1,104 +0,0 @@ -BINDIR = $(TOPDIR)/bin -LANGS = de en fr pol - -BIB_FILES = $(wildcard ./*.bib) -BIBTEXML_TEX_FILES = $(patsubst %.bib,%.texml,$(BIB_FILES)) -BIBTEXML_FILES = $(patsubst %.bib,%.xml,$(BIB_FILES)) - -AUXILIARY_FILES = $(TOPDIR)/navigation.xml $(TOPDIR)/people.xml $(TOPDIR)/Publications/all.bib - -XML_FILES = $(filter-out $(AUXILIARY_FILES) $(foreach lang,$(LANGS),$(wildcard ./*.$(lang).xml)) $(BIBTEXML_FILES),$(wildcard ./*.xml)) -XML_LANG_FILES = $(foreach lang,$(LANGS),$(patsubst %.xml,%.xml.$(lang),$(XML_FILES))) - -ALL_HTML_FILES = $(patsubst %.xml,%.html,$(XML_FILES)) -HTML_FILES = $(filter-out $(patsubst %.xml,%.html,$(BIBTEXML_FILES)),$(ALL_HTML_FILES)) -HTML_LANG_FILES = $(foreach lang,$(LANGS),$(patsubst %.html,%.html.$(lang),$(HTML_FILES))) - -XSL_FILES = $(wildcard ./$(TOPDIR)/xsl/*.xsl) $(wildcard ./$(TOPDIR)/xsl/include/*.xsl) - - -XSLTPROC_PARAM = --stringparam "year" "`date -r $< +"%Y"`" \ - --stringparam "last-mod" "`date -r $< +"%d %B %Y"`" \ - --stringparam "topdir" "$(TOPDIR)" \ - --stringparam "title" "" - -# create a list of all subdirs and move Publications (if it exists) to the first -# position -ALLSUBDIRS = $(shell find . -maxdepth 1 -mindepth 1 -path './.svn*'\ - -prune -o -type d -path './[A-Z]*' -printf '%P ') -SUBDIRS = $(findstring Publications, $(ALLSUBDIRS)) \ - $(filter-out Publications,$(ALLSUBDIRS)) - - -all: allsubdirs $(XML_LANG_FILES) $(HTML_FILES) $(HTML_LANG_FILES) bib - -allsubdirs: - for d in $(SUBDIRS); do (make -C $$d) done - - -bib: $(BIBTEXML_FILES) $(BIBTEXML_TEX_FILES) - - -%.texml: %.bib - $(BINDIR)/bib2xml $< | $(BINDIR)/unflatten.py --unflatten -\ - | sed 's/<?xml version="1.0" ?>/<?xml version="1.0" ?>\n/' > $@ - -%.xml: %.bib $(BINDIR)/tex2html - $(BINDIR)/bib2xml $< | $(BINDIR)/unflatten.py --unflatten -\ - | sed 's/<?xml version="1.0" ?>/<?xml version="1.0" ?>\n/'\ - | $(BINDIR)/tex2html $(TOPDIR) > $@ - - -XML_LANG_PATTERN = $(foreach lang,$(LANGS),%.xml.$(lang)) - -$(XML_LANG_PATTERN) : %.xml $(AUXILIARY_FILES) $(XSL_FILES) - for lang in $(LANGS); do \ - xsltproc --stringparam "lang" "$$lang" $(TOPDIR)/xsl/language.xsl $< \ - > $*.xml.$$lang ;\ - chmod 664 $*.xml.$$lang ;\ - done - - -%.html.de : LANG=de -%.html.de : %.xml.de $(AUXILIARY_FILES) $(XSL_FILES) $(BIBTEXML_FILES) - lang=$(LANG) ; if [ -n "$$lang" ] ; then \ - xsltproc $(XSLTPROC_PARAM) --stringparam "lang" "$(LANG)" --stringparam "uri" "$<" $< \ - | $(BINDIR)/hrefprocess "$(TOPDIR)" "$(LANG)" > $@ ;\ - chmod 664 $@ ;\ - fi - -%.html.en : LANG=en -%.html.en : %.xml.en $(AUXILIARY_FILES) $(XSL_FILES) $(BIBTEXML_FILES) - lang=$(LANG) ; if [ -n "$$lang" ] ; then \ - xsltproc $(XSLTPROC_PARAM) --stringparam "lang" "$(LANG)" --stringparam "uri" "$<" $< \ - | $(BINDIR)/hrefprocess "$(TOPDIR)" "$(LANG)" > $@ ;\ - chmod 664 $@ ;\ - fi - -%.html.pol : LANG=pol -%.html.pol : %.xml.pol $(AUXILIARY_FILES) $(XSL_FILES) $(BIBTEXML_FILES) - lang=$(LANG) ; if [ -n "$$lang" ] ; then \ - xsltproc $(XSLTPROC_PARAM) --stringparam "lang" "$(LANG)" --stringparam "uri" "$<" $< \ - | $(BINDIR)/hrefprocess "$(TOPDIR)" "$(LANG)" > $@ ;\ - chmod 664 $@ ;\ - fi - -%.html.fr : LANG=fr -%.html.fr : %.xml.fr $(AUXILIARY_FILES) $(XSL_FILES) $(BIBTEXML_FILES) - lang=$(LANG) ; if [ -n "$$lang" ] ; then \ - xsltproc $(XSLTPROC_PARAM) --stringparam "lang" "$(LANG)" --stringparam "uri" "$<" $< \ - | $(BINDIR)/hrefprocess "$(TOPDIR)" "$(LANG)" > $@ ;\ - chmod 664 $@ ;\ - fi - -%.html : %.html.en - @echo - -clean: - rm -f $(HTML_FILES) - rm -f $(HTML_LANG_FILES) - rm -f $(XML_LANG_FILES) - rm -f $(BIBTEXML_FILES) - rm -f $(BIBTEXML_TEX_FILES) - for d in $(SUBDIRS); do (make -C $$d clean) done - rm -f *~ Modified: trunk/Toss/www/develop.xml =================================================================== --- trunk/Toss/www/develop.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/develop.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,15 +4,12 @@ <?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?> <personal> - <title lang="en">Develop Toss</title> - <title lang="de">Toss Ausbauen</title> - <title lang="pol">Programuj Tossa</title> - <title lang="fr">Développez Toss</title> + <title>Develop Toss</title> <history> <link id="develop" href="/develop.html">Develop Toss</link> </history> - <section title="Preparation" lang="en"> + <section title="Preparation"> <itemize> <item>Toss server is programmed in <a href="http://caml.inria.fr/">Objective Caml</a> and uses @@ -46,111 +43,8 @@ it succeeds.</item> </itemize> </section> - <section title="Vorbereitung" lang="de"> - <itemize> - <item>Toss Server ist in - <a href="http://caml.inria.fr/">Objective Caml</a> geschrieben und - benutzt <em>ocamlbuild</em> und <em>make</em> zu kompilieren. - </item> - <item>Wenn man Toss unter - <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 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> - zu kompilieren, empfehlen wir - <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 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>Folgendes nutzt man, um die - <a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/">Toss - SVN Repository</a> zum <em>Toss</em> Verzeichnis auszuchecken.<br/> - <em>svn co https://toss.svn.sourceforge.net/svnroot/toss/trunk/Toss - Toss</em> - </item> - <item>Führe <em>make</em> aus im Toss Verzeichnis und überprüfe, - dass es erfolgreich funktioniert hat.</item> - </itemize> - </section> - <section title="Przygotowanie" lang="pol"> - <itemize> - <item>Server Tossa jest napisany w - <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>, - poniższe polecenie zainstaluje pakiety - niezbędne do kompilacji Tossa.<br/> - <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 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 - <a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/"> - Repozytorium SVN Tossa</a> do katalogu <em>Toss</em>.<br/> - <em>svn co https://toss.svn.sourceforge.net/svnroot/toss/trunk/Toss - Toss</em> - </item> - <item>W katalogu Toss uruchom <em>make</em> i sprawdź czy dobrze - zadziałało.</item> - </itemize> - </section> - <section title="Préparation" lang="fr"> - <itemize> - <item>Toss server est programmé en - <a href="http://caml.inria.fr/">Objective Caml</a> - et utilise <em>ocamlbuild</em> et <em>make</em> pour la compilation. - </item> - <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 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/> 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 - <a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/">Toss - SVN Repository</a> dans le répertoire <em>Toss</em>.<br/> - <em>svn co https://toss.svn.sourceforge.net/svnroot/toss/trunk/Toss - Toss</em> - </item> - <item>Dans le répertoire Toss exécuter <em>make</em> et vérifier - que c'est bien.</item> - </itemize> - </section> - - <section title="Tutorials" lang="en"> + <section title="Tutorials"> <itemize> <item>Visit <a href="http://try.ocamlpro.com">try.ocamlpro.com</a> to refresh your basic OCaml skills.</item> @@ -160,38 +54,8 @@ will learn to code basic operations with Toss.</item> </itemize> </section> - <section title="Tutorials" lang="de"> - <itemize> - <item>Besuche <a href="http://try.ocamlpro.com">try.ocamlpro.com</a> - um die Grundlagen von OCaml zu lernen.</item> - <item>Unser <a href="/ocaml.html">Mini OCaml Tutorial</a> zeigt, - wie wir OCaml Code organisieren.</item> - <item>Das <a href="/codebasics.html">Toss Code Basics Tutorial</a> zeigt, - wie man einfache Toss-Funktionen ausführt.</item> - </itemize> - </section> - <section title="Tutoriale" lang="pol"> - <itemize> - <item>Na <a href="http://try.ocamlpro.com">try.ocamlpro.com</a> - możesz szybko nauczyć się OCamla na przykładach.</item> - <item>Nasz <a href="/ocaml.html">Mini OCaml Tutorial</a> pokazuje, - jak organizujemy kod OCamla.</item> - <item><a href="/codebasics.html">Toss Code Basics Tutorial</a> pokazuje - podstawowe wywołania funkcji Tossa.</item> - </itemize> - </section> - <section title="Tutoriaux" lang="fr"> - <itemize> - <item>Visitez <a href="http://try.ocamlpro.com">try.ocamlpro.com</a> - pour actualiser vos compétences en OCaml.</item> - <item>Notre <a href="/ocaml.html">Mini OCaml Tutorial</a> montre - comment nous organiser le code OCaml.</item> - <item>Le <a href="/codebasics.html">Toss Code Basics Tutorial</a> montre - comment on utilise les fonctions de base Toss.</item> - </itemize> - </section> - <section title="Understanding Toss" lang="en"> + <section title="Understanding Toss"> <itemize> <item><a href="create.html">Create</a> at least one simple game to get started.</item> @@ -205,52 +69,8 @@ about Toss to get an idea where the ideas come from.</item> </itemize> </section> - <section title="Toss Verstehen" lang="de"> - <itemize> - <item><a href="create.html">Erzeuge</a> mindestens ein einfaches Spiel - mit Toss, um die Grundlagen zu verstehen.</item> - <item>Lese die <a href="docs.html">Dokumentation</a> von Toss. - </item> - <item>Vergiss nicht die <a href="reference/reference.pdf"> - Reference.pdf</a> durchzublättern.</item> - <item>Wenn man Toss programmiert, ist die - <a href="code_doc/">Quellcode Dokumentation</a> oft nützlich.</item> - <item>Durch die <a href="Publications/">Papers und Talks</a> kann man - verstehen, woher die Ideen hinter Toss kommen.</item> - </itemize> - </section> - <section title="Zrozumieć Tossa" lang="pol"> - <itemize> - <item><a href="create.html">Stwórz</a> przynajmniej jedną prostą - grę w Tossie na początek.</item> - <item>Zapoznaj się z <a href="docs.html">dokumentacją Tossa</a>. - </item> - <item>Przejrzyj też <a href="reference/reference.pdf"> - reference.pdf</a>.</item> - <item>Podczas programowania poręczna jest - <a href="code_doc/">dokumentacja kodu</a>.</item> - <item>Oglądając <a href="Publications/">prace i referaty</a> - można dowiedzieć się, skąd czerpaliśmy pomysły w Tossie.</item> - </itemize> - </section> - <section title="Comprendre Toss" lang="fr"> - <itemize> - <item><a href="create.html">Créez</a> au moins un jeu simple - pour commencer.</item> - <item>Familiarisez-vous avec la <a href="docs.html">documentation - Toss</a>. - </item> - <item>N'oubliez pas de lire le document - <a href="reference/reference.pdf">reference.pdf</a>.</item> - <item>Si vous commencez à regarder le code, vous pourriez trouver la - <a href="code_doc/">documentation des interfaces</a> pratique.</item> - <item>Parcourir les <a href="Publications/">papiers et entretiens</a> - sur Toss pour comprendre d'où viennent les idées.</item> - </itemize> - </section> - - <section title="Working with the Toss Team" lang="en"> + <section title="Working with the Toss Team"> <par>If you have an idea for Toss, a request, want to become a developer or just want to talk, contact us! Most engaged Toss developers do respond to Toss questions on their private emails every @@ -264,50 +84,5 @@ <mailto address="luk...@gm..."/></item> </itemize> </section> - <section title="Mit Toss Team Zusammenarbeiten" lang="de"> - <par>Wenn du eine Idee für Toss hast, einen Vorschlag, eine Anfrage, - wenn du Toss programmieren möchtest oder einfach mit uns reden, - schreibe uns! Die engagiertesten Toss Developer beantworten - täglich Fragen über Toss auch auf privaten Emails (unten), aber - es ist am besten an <em>toss-devel</em> zu schreiben.</par> - <itemize> - <item>Toss Mailingliste: - <mailto address="tos...@li..."/></item> - <item>Łukasz Kaiser: - <mailto address="luk...@gm..."/></item> - <item>Łukasz Stafiniak: - <mailto address="luk...@gm..."/></item> - </itemize> - </section> - <section title="Praca z Nami" lang="pol"> - <par>Jeśli masz pomysł na zmiany w Tossie, prośbę o poprawienie buga, - chcesz zostać developerem Tossa albo po prostu z nami porozmawiac, - napisz! Najbardziej zaangażowani programiści Tossa odpowiadają - codziennie na maile nawet na swoich prywatnych adresach (poniżej), - ale najlepiej napisać na listę <em>toss-devel</em>.</par> - <itemize> - <item>Lista mailingowa Tossa: - <mailto address="tos...@li..."/></item> - <item>Łukasz Kaiser: - <mailto address="luk...@gm..."/></item> - <item>Łukasz Stafiniak: - <mailto address="luk...@gm..."/></item> - </itemize> - </section> - <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 - (ci-dessous), mais <em>toss-devel</em> est l'adresse que nous préférons. - </par> - <itemize> - <item>Liste de diffusion de Toss: - <mailto address="tos...@li..."/></item> - <item>Łukasz Kaiser: - <mailto address="luk...@gm..."/></item> - <item>Łukasz Stafiniak: - <mailto address="luk...@gm..."/></item> - </itemize> - </section> </personal> Modified: trunk/Toss/www/docs.xml =================================================================== --- trunk/Toss/www/docs.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/docs.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,87 +4,31 @@ <?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?> <personal> - <title lang="en">Documentation</title> - <title lang="de">Dokumentation</title> - <title lang="pol">Dokumentacja</title> - <title lang="fr">Documentation</title> + <title>Documentation</title> <history> <link id="docs" href="/docs.html">Documentation</link> </history> - <section title="Using Toss" lang="en"> + <section title="Using Toss"> <par>If you want to learn how to use Toss to create games, go to the <a href="create.html">Create Games</a> page.</par> </section> - <section title="Toss Benutzen" lang="de"> - <par>Um zu lernen, wie man Toss benutzt um neue Spiele zu erschaffen, - besuche die <a href="create.html">Neue Spiele Erzeugen</a> Seite.</par> - </section> - <section title="Używanie Tossa" lang="pol"> - <par>Żeby nauczyć się tworzyć gry w Tossie najlepiej odwiedzić stronę - o <a href="create.html">Tworzeniu Nowych Gier</a>.</par> - </section> - <section title="Utilisation du Toss" lang="fr"> - <par>Si vous voulez apprendre à utiliser le Toss pour créer des jeux, - visitez la page <a href="create.html">Créez des Jeux</a>.</par> - </section> - - <section title="Reference" lang="en"> + <section title="Reference"> <par>The Toss Design and Specification reference is an evolving document in which we try to describe the high-level mathematical model of Toss and the main ideas used in the implementation. The document is best viewed as <a href="reference/reference.pdf">reference.pdf</a>.</par> </section> - <section title="Referenz" lang="de"> - <par><em>Toss Design and Specification</em> ist ein ständig aktuliesiertes - Dokument, in dem wir versuchen, eine Übersicht über die mathematische - Grundlagen von Toss und die Hauptideen der Algorithmen, die wir - implementiert haben, zu geben. Es ist am besten als - <a href="reference/reference.pdf">reference.pdf</a> zu lesen.</par> - </section> - <section title="Opis" lang="pol"> - <par>"Toss Design and Specification" to ciągle zmieniający się dokument, - w którym próbujemy opisać matematyczny model Tossa i najważniejsze - idee i algorytmy użyte w implementacji. Najlepiej oglądać ten opis - jako <a href="reference/reference.pdf">reference.pdf</a>.</par> - </section> - <section title="Référence" lang="fr"> - <par>Le Toss — Design et Spécification est un document dans - lequel nous essayons de décrire le modèle mathématique du Toss et les idées - principales utilisées dans le Toss. Nous recommandons la version - <a href="reference/reference.pdf">Reference.pdf</a>.</par> - </section> - - <section title="Code Documentation" lang="en"> + <section title="Code Documentation"> We generate <a href="code_doc/">documentation from code comments</a> using <a href="http://caml.inria.fr/pub/docs/manual-ocaml/manual029.html"> ocamldoc</a>. It gives the most up-to date information on our code, modules and their interfaces. </section> - <section title="Quellcode Dokumentation" lang="de"> - Wir erzeugen <a href="code_doc/">Quellcode Dokumentation</a> von - Kommentaren mit Hilfe von - <a href="http://caml.inria.fr/pub/docs/manual-ocaml/manual029.html"> - ocamldoc</a>. Es ist die aktuellste Information über den Toss Quellcode, - die Module und deren Zusammenhänge.</section> - <section title="Dokumentacja Kodu" lang="pol"> - <a href="code_doc/">Dokumentację z komentarzy w kodzie</a> generujemy - przy pomocy - <a href="http://caml.inria.fr/pub/docs/manual-ocaml/manual029.html"> - ocamldoca</a>. To najbardziej aktualna informacja o kodzie Tossa, - naszych modułach i ich interfejsach. - </section> - <section title="Documentation du Code" lang="fr"> - Nous générons <a href="code_doc/">la documentation</a> à partir des - commentaires de code en utilisant ocamldoc. La documentation fournit les - informations les plus actuelles sur le code, les modules et leurs - interfaces. - </section> - - <section title="Scientific Background of Toss" lang="en"> + <section title="Scientific Background of Toss"> <par>To learn more about the mathematical background and the design of Toss, use the following links.</par> <itemize> @@ -112,89 +56,4 @@ </itemize> </section> - - <section title="Mathematische Grundlagen von Toss" lang="de"> - <par>Um mehr über Toss zu erfahren, folge diesen Links.</par> - <itemize> - <item><em>Eine kompakte Darstellung</em> des mathematischen Modells auf - dem Toss basiert findet man in - <a href="pub/playing_structure_rewriting_games.pdf"> - Playing Structure Rewriting Games</a>. - </item> - - <item><em>Die Komplexität</em> eines syntaktischen Fragments von Toss - wurde in dem Paper <a href="pub/graph_games_short.pdf"> - Synthesis for Structure Rewriting Systems</a> analysiert. - </item> - - <item><em>Eine Präsentation</em> über die Mathematik von Toss wurde bei - <em>IIT Kanpur</em> gegeben und kann - <a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi"> - online angeschaut werden</a>. - </item> - - <item><em>Eine kürzere Präsentation</em> über Toss als AI Programm wurde - bei <em>AGI 2010</em> gegeben und kann ebenfalls - <a href="http://www.vimeo.com/15326245">online angeschaut werden</a>. - </item> - </itemize> - </section> - - - <section title="Matematyczne Podstawy Tossa" lang="pol"> - <par>Matematyczne podstawy Tossa są bardzo bogate. Poniższe linki - pozwalają zapoznać się z częścią z nich.</par> - <itemize> - <item><em>Zwięzły opis</em> matematycznego modelu używanego w Tossie - i algorytmu UCT znajduje się w pracy - <a href="pub/playing_structure_rewriting_games.pdf">Playing - Structure Rewriting Games</a>. - </item> - - <item><em>Złożoność</em> pewnego składniowego fragmentu Tossa została - opisana w pracy <a href="pub/graph_games_short.pdf">Synthesis - for Structure Rewriting Systems</a>. - </item> - - <item><em>Prezentacja</em> matematycznego modelu Tossa udzielona w - <em>IIT Kanpur</em> w Indiach w 2010 jest - <a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi"> - dostępna online</a>. - </item> - - <item><em>Krótsza prezentacje</em> Tossa skupiająca się na sztucznej - inteligencji była częścią <em>AGI 2010</em> i też jest - <a href="http://www.vimeo.com/15326245">dostępna online</a>. - </item> - </itemize> - </section> - - <section title="Contexte Scientifique du Toss" lang="fr"> - <par>Pour en savoir plus sur le contexte mathématique et sur l'idée - du Toss, consultez les liens suivants.</par> - <itemize> - <item><em>Une brève description</em> du modèle mathématique du Toss, - ainsi que de notre algorithme UCT, peut être trouvée dans le document - <a href="pub/playing_structure_rewriting_games.pdf">Playing - Structure Rewriting Games</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>. - </item> - - <item><em>Présentation</em> sur les mathématiques du Toss a été donné - sur <em>IIT Kanpur</em> et est - <a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi"> - en ligne</a>. - </item> - - <item><em>Courte présentation</em> concentrée sur AI a été donnée - à <em>AGI 2010</em> et est - <a href="http://www.vimeo.com/15326245">en ligne</a> aussi. - </item> - </itemize> - </section> - </personal> Modified: trunk/Toss/www/ideas.xml =================================================================== --- trunk/Toss/www/ideas.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/ideas.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -4,10 +4,7 @@ <?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?> <personal> - <title lang="en">Development Ideas</title> - <title lang="de">Ausbauideen (auf Englisch)</title> - <title lang="pol">Dalsze Pomysły (po angielsku)</title> - <title lang="fr">Idées de Développement (en anglais)</title> + <title>Development Ideas</title> <history> <link id="develop" href="/develop.html">Develop Toss</link> <link id="ideas" href="/ideas.html">Development Ideas</link> Modified: trunk/Toss/www/index.xml =================================================================== --- trunk/Toss/www/index.xml 2012-05-24 22:23:11 UTC (rev 1714) +++ trunk/Toss/www/index.xml 2012-05-26 22:28:13 UTC (rev 1715) @@ -9,7 +9,7 @@ <link href="/index.html" id="Home"></link> </history> - <section title="About" lang="en"> + <section title="About"> <par><em>Toss</em> is a program to create, modify and play games. It includes a general game playing engine so that you can play any game you create against the computer. @@ -20,36 +20,6 @@ </par> </section> - <section title="Über Toss" lang="de"> - <par><em>Toss</em> erlaubt es, Spiele zu erzeugen, zu analysieren - und zu spielen. Dank eines allgemeinen Algorithmus ist es möglich, - ein Spiel zu bauen und direkt gegen das Computer zu spielen. Hast - du Dich schon mal gefragt, wie man Schach spielt wenn die Brettmitte - fehlt? Experimentiere mit Deinen Spielideen und trete - gegen Deine Freunde online an! - </par> - </section> - - <section title="O Tossie" lang="pol"> - <par><em>Toss</em> jest programem do tworzenia, analizowania - i grania w gry. Dzięki ogólnemu algorytmowi możesz stworzyc grę - i od razu zagrać w nią z komputerem. Na przykład, jak grałoby - się w szachy bez środka planszy? Z Tossem łatwo to sprawdzić! - </par> - </section> - - <section title="À Propos du Toss" lang="fr"> - <par><em>Toss</em> est un programme pour créer les jeux, pour les analyser - et pour y jouer. Grâce à un algorithme général, vous pouvez jouer contre - l'ordinateur à tous les jeux que vous avez créés. Vous vous êtes jamais - demandés ce qui se passerait si vous supprimiez le milieu de la planche - dans votre jeu préféré? Maintenant, avec le Toss, vous pouvez experimenter! - Dès que votre jeu est prêt, vous pouvez jouer en ligne et rivaliser avec - vos amis! - </par> - </section> - - <games-section> <game-div> <game-link game="Pawn-Whopping"/> @@ -65,6 +35,8 @@ <section title="News"> <itemize> + <newsitem date="24/05/12"> + Code for Term functions cleaned up and made JS compatible</newsitem> <newsitem date="13/05/12"> Toss release 0.8 with full JS compatibility with dynamics</newsitem> <newsitem date="04/05/12"> @@ -145,30 +117,12 @@ <show-old-news-button /> </section> - <section title="Create New Games" lang="en"> - <par>Go to the <a href="create.html.en">Create Games</a> page to learn + <section title="Create New Games"> + <par>Go to the <a href="create.html">Create Games</a> page to learn how to build new games with Toss.</par> </section> - <section title="Neue Spiele Erzeugen" lang="de"> - <par> - Lerne wie man mit Toss neue <a href="create.html.de">Spiele erzeugt.</a> - </par> - </section> - - <section title="Stwórz Nową Grę" lang="pol"> - <par>Zobacz jak <a href="create.html.pol">stworzyć nową grę</a>.</par> - </section> - - <section title="Créez des jeux nouveaux" lang="fr"> - <par> - Visitez la page <a href="create.html.fr">Créer des jeux</a> pour - découvrir comment on construit des jeux nouveaux avec le Toss. - </par> - </section> - - - <section title="Toss Features" lang="en"> + <section title="Toss Features"> <par>Games in Toss are defined as mathematical structures and moves by structure rewriting rules. Payoffs are given by formulas of monadic second-order logic with real values.</par> @@ -191,187 +145,4 @@ </itemize> </section> - - <section title="Eigenschaften von Toss" lang="de"> - <par>Die Spiele in Toss sind durch relationale Strukturen definiert - und die Züge durch Graphersetzungsregeln. Das Ergebnis eines Spiels - wird durch Formeln der monadischen Logik zweiter Stufe definiert, die - in Toss mit Zählquantoren erweitert ist, um reelle Werte zu liefern.</par> - <itemize> - <item><em>Strukturen</em> in Toss können beliebige Relationen beinhalten - und zusätzlich Funktionen mit reellen Werten.</item> - <item><em>Ersetzungsregeln</em> werden ausgeführt, indem die Struktur - auf der linken Seite mit der Hauptstruktur gematcht wird und danach - durch die Struktur auf der rechten Seite ersetzt wird.</item> - <item><em>Kontinuerliche Dynamik</em> kann durch ein ODE-System - eingegeben werden. Das erlaubt die Simulation von Bewegung und - anderen physikalischen Eigenschaften der Objekte.</item> - <item><em>Zusätzliche Bedingungen</em> können die Ersetzungsregeln - einschränken. Dazu gehören Vorbedingungen, Invarianten, und - Nachbedingungen.</item> - <item><em>Logik</em> wird benutzt, um die Bedingungen und die Ergebnisse - zu definieren. In Toss ist die vollständige monadische Logik zweiter - Stufe implementiert, mit zusätzlichen Zählquantoren.</item> - <item><em>Der Solver</em> in Toss ist stark optimiert. Er eliminiert - die Quantoren wenn möglich und dekomponiert die Formel - (mit Hilfe von <a href="http://minisat.se/">MiniSat</a>).</item> - <item><em>Hinweise</em> können dadurch allgemein in allen Spielen - gegeben werden, die Zugauswahl passiert durch UCT oder Maximax.</item> - </itemize> - </section> - - <section title="Funkcje Tossa" lang="pol"> - <par>Gry w Tossie są zdefiniowane jako matematyczne struktury, - a ruchy zadane przez reguły przepisywania struktur. Wypłaty na - końcu gry definiujemy formułami monadycznej logiki drugiego rzędu, - rozszerzonej o termy z wartościami rzeczywistymi, np. zliczaniem.</par> - <itemize> - <item><em>Struktury</em> mogą zawierać dowolne relacje i dodatkowo - funkcje w wartościami rzeczywistymi.</item> - <item><em>Reguły przepisywania</em> dopasowują dowolną strukturę z - lewej strony reguły do głównej struktury i zastępują ją strukturą - z prawej strony reguły.</item> - <item><em>Dynamika</em> (ciągła) układu może być zadana systemem - zwyczajnych równań różniczkowych (ODE), co pozwala symulować ruch - i inne własności fizyczne układu.</item> - <item><em>Więzy</em> dla reguł mogą być zadane jako dowolne formuły. - Dopuszczalne są zarówno pre-kondycje, niezmienniki, jak i post-kondycje. - </item> - <item><em>Logika</em> służy do definiowania więzów jak i wyników gier - i reguł. W Tossie dopuszczmy pełną monadyczną logikę drugiego rzędu z - dodatkowymi kwantyfikatorami o wartościach rzeczywistch, - jak np. zliczanie.</item> - <item><em>Solver</em> w Tossie jest zoptymalizowany dla naszych formuł. - Wykonuje eliminację kwantyfikatorów gdzie to możliwe i rozkład formuł - (przy pomocy <a href="http://minisat.se/">MiniSata</a>).</item> - <item>Dzięki temu <em>Podpowiedzi Ruchu</em> są automatycznie generowane - dla każdej gry w Tossie. Ruch jest wybierany na bazie - UCT lub Maximaxa.</item> - </itemize> - </section> - - <section title="Fonctions du Toss... [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;; -val term_type_cons_sd : syntax_def;; -val term_type_cons_name : string;; -val term_type_fun_sd : syntax_def;; -val term_type_fun_name : string;; +val term_type_var_sd : syntax_def +val term_type_var_name : string +val term_type_cons_sd : syntax_def +val term_type_cons_name : string +val term_type_fun_sd : syntax_def +val term_type_fun_name : string -val syntax_element_sd : syntax_def;; -val syntax_element_name : string;; -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 : 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 : TermType.term_type;; -val syntax_definition_type_sd : syntax_def;; -val syntax_definition_type_name : string;; -val syntax_definition_fun_sd : syntax_def;; -val syntax_definition_fun_name : string;; -val syntax_definition_var_sd : syntax_def;; -val syntax_definition_var_name : string;; +val syntax_element_sd : syntax_def +val syntax_element_name : string +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 : 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 : TermType.term_type +val syntax_definition_type_sd : syntax_def +val syntax_definition_type_name : string +val syntax_definition_fun_sd : syntax_def +val syntax_definition_fun_name : string +val syntax_definition_var_sd : syntax_def +val syntax_definition_var_name : string -(* --------------- SYNTAX DEFINITIONS RELATED TO TERMS ------------ *) +(** {2 Syntax Definitions related to Terms} *) -val term_sd : syntax_def;; -val term_name : string;; -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 : 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 : 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 : 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 : 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 : TermType.term_type;; -val type_of_sd_sd : syntax_def;; -val type_of_name : string;; +val term_sd : syntax_def +val term_name : string +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 : 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 : 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 : 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 : 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 : TermType.term_type +val type_of_sd_sd : syntax_def +val type_of_name : string -(* ------------------------ EXCEPTION TYPE -------------------------- *) +(** {2 The Exception Type} *) -val exception_cl_sd : syntax_def;; -val exception_cl_name : string;; +val exception_cl_sd : syntax_def +val exception_cl_name : string -val exception_sd : syntax_def;; -val exception_name : string;; -val exn_ok_sd : syntax_def;; -val exn_ok_name : string;; +val exception_sd : syntax_def +val exception_name : string +val exn_ok_sd : syntax_def +val exn_ok_name : string -(* ----------- SPECIAL FUNCTIONS RECOGNIZED BY NORMALISATION --------- *) -val brackets_sd : syntax_def;; -val brackets_name : string;; +(** {2 Special functions recognized during Normalisation} *) -val verbatim_sd : syntax_def;; -val verbatim_name : string;; +val brackets_sd : syntax_def +val brackets_name : string -val if_then_else_sd : syntax_def;; -val if_then_else_name : string;; +val verbatim_sd : syntax_def +val verbatim_name : string -val eq_bool_sd : syntax_def;; -val eq_bool_name : string;; +val if_then_else_sd : syntax_def +val if_then_else_name : string +val eq_bool_sd : syntax_def +val eq_bool_name : string -(* ----------- SYNATAX DEFINITIONS OF SPECIAL META FUNCTIONS ---------- *) -val code_as_term_sd : syntax_def;; -val code_as_term_name : string;; +(** {2 Syntax Definitions for special meta-functions} *) -val get_type_definitions_sd : syntax_def;; -val get_type_definitions_name : string;; -val get_fun_definitions_sd : syntax_def;; -val get_fun_definitions_name : string;; +val code_as_term_sd : syntax_def +val code_as_term_name : string +val get_type_definitions_sd : syntax_def +val get_type_definitions_name : string +val get_fun_definitions_sd : syntax_def +val get_fun_definitions_name : string -(* --------------- SYSTEM COMMANDS SYNTAX DEFINITIONS ---------------- *) -val outside_paths_sd : syntax_def;; -val outside_paths_name : string;; -val outside_paths_tp : TermType.term_type;; +(** {2 System Commands and their Syntax Definitions} *) -val path_library_sd : syntax_def;; -val path_library_name : string;; +val outside_paths_sd : syntax_def +val outside_paths_name : string +val outside_paths_tp : TermType.term_type -val path_file_sd : syntax_def;; -val path_file_name : string;; +val path_library_sd : syntax_def +val path_library_name : string -val load_command_sd : syntax_def;; -val load_command_name : string;; -val load_command_tp : TermType.term_type;; -val load_file_sd : syntax_def;; -val load_file_name : string;; +val path_file_sd : syntax_def +val path_file_name : string -val sys_commands_sd : syntax_def;; -val sys_commands_name : string;; -val sys_commands_tp : TermType.term_type;; +val load_command_sd : syntax_def +val load_command_name : string +val load_command_tp : TermType.term_type +val load_file_sd : syntax_def +val load_file_name : string -val close_context_sd : syntax_def;; -val close_context_name : string;; +val sys_commands_sd : syntax_def +val sys_commands_name : string +val sys_commands_tp : TermType.term_type -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 close_context_sd : syntax_def +val close_context_name : string -val preprocess_sd : syntax_def;; -val preprocess_name : string;; +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 preferred_to_sd : syntax_def;; -val preferred_to_name : string;; +val preprocess_sd : syntax_def +val preprocess_name : string -val additional_xslt_sd : syntax_def;; -val additional_xslt_name : string;; +val preferred_to_sd : syntax_def +val preferred_to_name : string -val string_quote_sd : syntax_def;; -val string_quote_name : string;; +val additional_xslt_sd : syntax_def +val additional_xslt_name : string + +val string_quote_sd : syntax_def +val string_quote_name : string Added: trunk/Toss/Term/BuiltinLangTest.ml =================================================================== --- trunk/Toss/Term/BuiltinLangTest.ml (rev 0) +++ trunk/Toss/Term/BuiltinLangTest.ml 2012-05-24 22:23:11 UTC (rev 1714) @@ -0,0 +1,19 @@ +open OUnit +open TermType +open BuiltinLang + +let tests = "BuiltinLang" >::: [ + "type names" >:: + (fun () -> + let test_type_name res tp = + assert_equal ~printer:(fun x -> x) res (TermType.type_to_string tp) in + test_type_name "T\\?_list (@? a)" list_tp_a; + test_type_name "Tbit" bit_tp; + test_type_name "Tchar" char_tp; + test_type_name "Tstring" string_tp; + test_type_name "Tboolean" boolean_tp; + test_type_name "Tsyntax_definition" syntax_definition_tp; + test_type_name "Tterm" term_tp; + ); +] + Modified: trunk/Toss/Term/Makefile =================================================================== --- trunk/Toss/Term/Makefile 2012-05-21 22:07:00 UTC (rev 1713) +++ trunk/Toss/Term/Makefile 2012-05-24 22:23:11 UTC (rev 1714) @@ -1,6 +1,6 @@ all: coreparsed -MKPARSED = ../TRSTest.native -c -f -l "../Term/lib" +MKPARSED = ../TRSTest.native -l "../Term/lib" coreparsed: make -C .. ./Term/TRSTest.native Modified: trunk/Toss/Term/ParseArc.ml =================================================================== --- trunk/Toss/Term/ParseArc.ml 2012-05-21 22:07:00 UTC (rev 1713) +++ trunk/Toss/Term/ParseArc.ml 2012-05-24 22:23:11 UTC (rev 1714) @@ -1,95 +1,84 @@ (* Contains the bottom-up chart-based parser that uses syntax definitions and checks if terms are well-typed when closing arcs. *) +open List +open TermType +open SyntaxDef +open Term -open List;; -open TermType;; -open SyntaxDef;; -open Term;; - - (* The type of elements created during parsing. Tokens come just from lexer and terms are created during parsing. - Type is kept together with each term not to recalculate it too often. - *) + Type is kept together with each term not to recalculate it too often. *) type parser_elem = - Token of string + | Token of string | Typed_term of term_type * term -;; +(* Print a parser elem. *) +let elem_str = function + | Token s -> "Tok " ^ s + | Typed_term (tp, te) -> + "Te " ^ (term_to_string te) ^ " : " ^ (type_to_string tp) + (* The type of incomplete arcs that appear during parsing; The last field is the position where the arc begins and the elements on the list are in reverse order and the field after the syntax definition is the - unique name generated for this syntax def. - *) -type parser_arc = Arc of syntax_def * string * parser_elem list * int;; + unique name generated for this syntax def. *) +type parser_arc = Arc of syntax_def * string * parser_elem list * int -(* ---------------- EXTENDING AND CLOSING ARCS ------------------- *) +(* --- Extending and closing arcs --- *) +exception NOT_EXTENDED +exception NOT_CLOSED -exception NOT_EXTENDED;; -exception NOT_CLOSED;; - -(* Checking if a given parser element matches the given position - in a syntax definition. - Maching means equality for tokens and unification possibility when - a typed term is put against a type. When a typed term is - put against a constant string in syntax definition then it does not match - and if a token is put agains a type then it matches only if it has type - is exactly the string type. -*) +(* Checking if a given parser element matches the given position in a syntax + definition. Maching means equality for tokens and unification possibility + when a typed term is put against a type. When a typed term is put against + a constant string in syntax definition then it does not match and if a token + is put agains a type then it matches only if its type is the string type. *) let matches_position elem sd i = let sel = syntax_elems_of_sd sd in let sd_elem = if (length sel < i) then None else Some (nth sel (i-1)) in match (sd_elem, elem) with - (None, _) -> false - | (Some (Str s), Token t) -> s = t - | (Some (Str s), Typed_term _) -> false - | (Some (Tp ty), Token _) -> ty = BuiltinLang.string_tp - | (Some (Tp ty), Typed_term (t, _)) -> - try - let _ = mgu ([(suffix 0 ty, suffix 1 t)], []) in true - with - UNIFY -> false -;; + | (None, _) -> false + | (Some (Str s), Token t) -> s = t + | (Some (Str s), Typed_term _) -> false + | (Some (Tp ty), Token _) -> ty = BuiltinLang.string_tp + | (Some (Tp ty), Typed_term (t, _)) -> + try let _ = mgu ([(suffix 0 ty, suffix 1 t)], []) in true + with UNIFY -> false + (* This function takes a parser element and an arc and extends the arc if the next free position in the syntax definition of the arc matches the given element. - Throws NOT_EXTENDED if it was impossible to extend the arc. -*) + Throws NOT_EXTENDED if it was impossible to extend the arc. *) let extend_arc elem = function - Arc (sd, n, l, p) -> - if matches_position elem sd ((length l) + 1) then - Arc (sd, n, (elem :: l), p) - else - raise NOT_EXTENDED -;; + | Arc (sd, n, l, p) -> + if matches_position elem sd ((length l) + 1) then + Arc (sd, n, (elem :: l), p) + else raise NOT_EXTENDED + (* Extends all the arcs in the given list that can be extended - and removes all other arcs. -*) + and removes all other arcs. *) let extend_arc_list elem arcs = let extend_elem arc = try [extend_arc elem arc] with NOT_EXTENDED -> [] in flatten (map extend_elem arcs) -;; + (* Divides arcs into complete and incomplete looking at the length of the syntax definition input list and the list of parsed elements. - In other words the arc is complete if nothing can be added to it. -*) + In other words the arc is complete if nothing can be added to it. *) let divide_arcs arcs = let is_complete = function - Arc (SDtype i, _, l, _) -> length i = length l + | Arc (SDtype i, _, l, _) -> length i = length l | Arc (SDfun (i, _), _, l, _) -> length i = length l - | Arc (SDvar (i, _), _, l, _) -> length i = length l - in + | Arc (SDvar (i, _), _, l, _) -> length i = length l in (filter is_complete arcs, filter (fun a -> not (is_complete a)) arcs) -;; (* Closes an arc, also when an arc is full generates a term @@ -99,78 +88,39 @@ the type is computetd and kept in the resulting parser element. Type declarations are given as a list of pairs that gives for each term symbol the type of that symbol. - Throws NOT_CLOSED if closing fails. -*) + Throws NOT_CLOSED if closing fails. *) let match_of_tok = function - (Str _, _) -> [] + | (Str _, _) -> [] | (Tp _, Token s) -> [code_string s] | (Tp _, Typed_term (_, te)) -> [te] -;; + let close_arc type_decls = function - Arc (sd, n, l, spos) when (length l = length (syntax_elems_of_sd sd)) -> - let elems = syntax_elems_of_sd sd in - let args = flatten (map match_of_tok (combine elems (rev l))) in - let res_term = (match sd with - SDtype _ -> Term (BuiltinLang.term_type_cons_name, + | Arc (sd, n, l, spos) when (length l = length (syntax_elems_of_sd sd)) -> + let elems = syntax_elems_of_sd sd in + let args = flatten (map match_of_tok (combine elems (rev l))) in + let res_term = (match sd with + | SDtype _ -> Term (BuiltinLang.term_type_cons_name, [|code_string n; code_list (fun x -> x) args|]) | SDfun _ -> Term (n, Array.of_list args) - | SDvar (_, _) -> ( - match sd_type sd with - None -> failwith "variable syntax definition w/o type" - | Some (ty) -> Var (n, ty, 0, Array.of_list args) - ) - ) in - (try - (Typed_term (type_of_term type_decls res_term, res_term), spos) - with - NOT_WELL_TYPED _ -> raise NOT_CLOSED - ) + | SDvar (_, _) -> + (match sd_type sd with + | None -> failwith "variable syntax definition w/o type" + | Some (ty) -> Var (n, ty, 0, Array.of_list args) ) + ) in + (try (Typed_term (type_of_term type_decls res_term, res_term), spos) + with NOT_WELL_TYPED _ -> raise NOT_CLOSED) | _ -> raise NOT_CLOSED -;; (* Closes all arcs from the given list that can be closed - and returns the elements together with starting positions. -*) + and returns the elements together with starting positions. *) let close_arc_list type_decls arcs = - let close_a a = try [close_arc type_decls a] with NOT_CLOSED -> [] in - flatten (map close_a arcs) -;; + let close_a a = try [close_arc type_decls a] with NOT_CLOSED -> [] in + flatten (map close_a arcs) -(* TESTS * - let type_decls = [ - (list_cons_name, Fun_type ([|Type_var "a"; list_tp_a|], list_tp_a)); - (list_nil_name, list_tp_a); - (pair_cons_name, Fun_type ([|Type_var "a_1";Type_var "a_2"|], pair_tp)); - (boolean_true_name, boolean_tp); - (boolean_false_name, boolean_tp)];; +(* --- Parsing by adding arcs --- *) - let var_x_a_sd = SDvar ([Str "x"], Type_var "a");; - let sdefs = [list_cons_sd; list_nil_sd; pair_cons_sd; - boolean_true_sd; boolean_false_sd; var_x_a_sd];; - let arcs = map (fun sd -> Arc (sd, (name_of_sd sd), [], 0)) sdefs;; - - let var_arc = extend_arc_list (Token "x") arcs;; - let var_closed = fst (hd (close_arc_list type_decls var_arc));; - - let nil_part_arc = extend_arc_list (Token "[") arcs;; - let nil_arc = extend_arc_list (Token "]") nil_part_arc;; - let nil_closed = fst (hd (close_arc_list type_decls nil_arc));; - - let cons_part1_arc = extend_arc_list var_closed arcs;; - let cons_part2_arc = extend_arc_list (Token ":") cons_part1_arc;; - let cons_part3_arc = extend_arc_list (Token ":") cons_part2_arc;; - let cons_arc = extend_arc_list nil_closed cons_part3_arc;; - let cons_closed = fst (hd (close_arc_list type_decls cons_arc));; - - let cons_bad_arc = extend_arc_list var_closed cons_part3_arc;; - let cons_bad_closed = close_arc_list type_decls cons_bad_arc;; -*) - - -(* ------------- PARSING THROUGH ADDING ARCS ---------------- *) - (* Parsing proceeds by going from left to right through the list of tokens and extending the incomplete arcs for each position. We have our constant set of syntax definitions and in each step @@ -185,8 +135,7 @@ (3) for each new generated parser element look where its arc was starting and try extend all incomplete arcs ending there with the new element; repeat recursively until no new elements are generated. - WARINNG: at the end we need to return also the elements. -*) + WARINNG: at the end we need to return also the elements. *) let rec extend type_decls sdefs arcs_to pos elem = let arcs = (map (fun (sd, n) -> Arc (sd,n,[],pos)) sdefs)@ arcs_to.(pos-1) in let (complete_arcs, ready_arcs) = divide_arcs (extend_arc_list elem arcs) in @@ -194,7 +143,6 @@ let res = map (fun (e, s) -> extend type_decls sdefs arcs_to s e) new_els in let (res_arcs, res_elems) = List.split ((ready_arcs, new_els) :: res) in (flatten res_arcs, flatten res_elems) -;; let parse_elems type_decls sdefs elems = @@ -202,111 +150,65 @@ let arcs_to = Array.make (len + 1) [] in let parsed_elems = Array.make (len + 1) [] in let rec update i = if i > len then () else - let (arcs_i, el_i) = extend type_decls sdefs arcs_to i (nth elems (i-1)) in - ( arcs_to.(i) <- arcs_i; parsed_elems.(i) <- el_i; update (i+1) ) in + let (arcs_i,el_i) = extend type_decls sdefs arcs_to i (nth elems (i-1)) in + ( arcs_to.(i) <- arcs_i; parsed_elems.(i) <- el_i; update (i+1) ) in ( update 1; (arcs_to, parsed_elems) ) -;; + let parse_to_array type_decls sdefs_original strs = let possible_tok = function Tp _ -> true | Str s -> mem s strs in let possible_sd sd = for_all possible_tok (syntax_elems_of_sd sd) in let sdefs = filter (fun (sd, s) -> possible_sd sd) sdefs_original in snd (parse_elems type_decls sdefs (map (fun s -> Token s) strs)) -;; + let parse type_decls sdefs strs = let parsed = (parse_to_array type_decls sdefs strs).(length strs) in - let (res, _) = List.split (filter (fun (_, start) -> start = 1) parsed) in - res -;; + fst (List.split (filter (fun (_, start) -> start = 1) parsed)) -(* TESTS * - let type_decls = [ - (list_cons_name, Fun_type ([|Type_var "a"; list_tp_a|], list_tp_a)); - (list_nil_name, list_tp_a); - (pair_cons_name, Fun_type ([|Type_var "a_1";Type_var "a_2"|], pair_tp)); - (boolean_true_name, boolean_tp); - (boolean_false_name, boolean_tp)];; +(* --- Input splitting --- *) - let var_x_a_sd = SDvar ([Str "x"], Type_var "a");; - let sdefs_basic = [list_cons_sd; list_nil_sd; pair_cons_sd; - boolean_true_sd; boolean_false_sd; var_x_a_sd];; - let sdefs = map (fun sd -> (sd, name_of_sd sd)) sdefs_basic;; - - let var_parse = parse_elems type_decls sdefs [Token "x"];; - let nil_parse = parse_elems type_decls sdefs [Token "["; Token "]"];; - let cons_parse = parse_elems type_decls sdefs - [Token "x"; Token ":"; Token ":"; Token "["; Token "]"];; - let cons_bad_parse = parse_elems type_decls sdefs - [Token "x"; Token ":"; Token ":"; Token "x"];; - - let _ = parse type_decls sdefs ["x"];; - let _ = parse type_decls sdefs ["x"; ":"; ":"; "["; "]"];; - let _ = parse type_decls sdefs ["x"; ":"; ":"; "x"];; -*) - - -(* ------------------- INPUT SPLITTING ------------------ *) - (* Splitting a single word on non letters (>127 = letter for UTF). *) let split_word str = let rec clear_special = function - [] -> [] + | [] -> [] | "&" :: "\"" :: rest -> "\"" :: clear_special rest | "&" :: "." :: rest -> "." :: clear_special rest | "&" :: ";" :: rest -> ";" :: clear_special rest | r :: rest -> r :: clear_special rest in - let is_breaking c = not ((is_letter c) || (Char.code c > 127)) in + let is_breaking c = not ((Aux.is_letter c) || (Char.code c > 127)) in let len = String.length str in let rec split cur_len i = if i = len then if cur_len = 0 then [] else - [String.sub str (i-cur_len) cur_len] + [String.sub str (i-cur_len) cur_len] else if is_breaking str.[i] then if cur_len > 0 then (String.sub str (i-cur_len) cur_len) :: - (String.make 1 str.[i]) :: (split 0 (i+1)) - else - (String.make 1 str.[i]) :: (split 0 (i+1)) - else - split (cur_len+1) (i+1) in + (String.make 1 str.[i]) :: (split 0 (i+1)) + else (String.make 1 str.[i]) :: (split 0 (i+1)) + else split (cur_len+1) (i+1) in clear_special (split 0 0) -;; (* Make first letter of w lowercase if not all are uppercase. *) let word_down w = let len = String.length w in let is_uppercase c = ((Char.uppercase c) = c) in let rec is_upperword i = - if i = len then - true - else + if i = len then true else if (is_uppercase w.[i]) then is_upperword (i+1) else false in if (is_upperword 0) then w else (w.[0] <- (Char.lowercase w.[0]); w) -;; let rec first_down = function - [] -> [] + | [] -> [] | "'" :: ws -> "'" :: (first_down ws) | w :: ws -> (word_down w) :: ws -;; + (* Splitting the whole input string. *) let split_input_string str = 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 = Str.regexp "[^&]\"\\|^\"" in - let rec split_delims = function - | [] -> [] - | 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 @@ -326,35 +228,11 @@ let rec split_string_all = function | [] -> [] | Aux.Delim "\"" :: Aux.Delim "\"" :: rest -> - "\"" :: "\"" :: split_string_all (rest) + "\"" :: "\"" :: split_string_all (rest) | Aux.Delim "\"" :: Aux.Text s :: Aux.Delim "\"" :: rest -> - "\"" :: (clear_escaped s) :: "\"" :: split_string_all rest + "\"" :: (clear_escaped s) :: "\"" :: split_string_all rest | 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); *) + LOG 1 "%s" (String.concat " " res); res -;; - - -(* TESTS * - let _ = split_input_string "a1";; - let _ = split_input_string "\"a\"";; - let _ = split_input_string "a\"a b\"";; - let _ = split_input_string "&\"a b\"";; - let _ = split_input_string "& \"a b\"";; - let _ = split_input_string "a__1";; - let _ = split_input_string "a_b_";; - let _ = split_input_string "a_b1";; - let _ = split_input_string "a_bbb";; - let _ = split_input_string "a_1111";; - let _ = split_input_string "__";; - let _ = split_input_string "aaa_";; - let _ = split_input_string "aaa_aaa";; - let _ = split_input_string "aaa_aaa_11";; - let _ = split_input_string "aaa_aaa_11bb";; - let _ = split_input_string "aa1 aa_1 aa__1";; - let _ = split_input_string "b22b_22b__22";; - let _ = split_input_string "_a_b_c__a_b_c_1";; - let _ = split_input_string "var10 *x_11* of: ?a_2";; -*) Modified: trunk/Toss/Term/ParseArc.mli =================================================================== --- trunk/Toss/Term/ParseArc.mli 2012-05-21 22:07:00 UTC (rev 1713) +++ trunk/Toss/Term/ParseArc.mli 2012-05-24 22:23:11 UTC (rev 1714) @@ -1,22 +1,37 @@ -(* Signature for Parser module. *) +(** Contains the bottom-up chart-based parser that uses syntax definitions + and checks if terms are well-typed when closing arcs. **) -open TermType;; -open SyntaxDef;; +open TermType +open SyntaxDef +(** Elements used in the parser. *) type parser_elem = - Token of string + | Token of string | Typed_term of term_type * Term.term -;; -type parser_arc = Arc of syntax_def * string * parser_elem list * int;; +(** Print a parser elem. *) +val elem_str : parser_elem -> string +(** Arcs built by the parser. *) +type parser_arc = Arc of syntax_def * string * parser_elem list * int -(* ------------- PARSING THROUGH ADDING ARCS ---------------- *) +(** {2 Parsing, done by adding arcs} *) + +(** Extends all the arcs in the given list that can be extended + and removes all other arcs. *) +val extend_arc_list : parser_elem -> parser_arc list -> parser_arc list + +(** Closes all arcs from the given list that can be closed + and returns the elements together with starting positions. *) +val close_arc_list : (string, term_type) Hashtbl.t -> + parser_arc list -> (parser_elem * int) list + + val parse_to_array : (string, term_type) Hashtbl.t -> - (syntax_def * string) list -> string list -> (parser_elem * int) list array;; + (syntax_def * string) list -> string list -> (parser_elem * int) list array val parse : (string, term_type) Hashtbl.t -> (syntax_def * string) list -> - string list -> parser_elem list;; + string list -> parser_elem list -val split_input_string : string -> string list;; +val split_input_string : string -> string list Added: trunk/Toss/Term/ParseArcTest.ml =================================================================== --- trunk/Toss/Term/ParseArcTest.ml (rev 0) +++ trunk/Toss/Term/ParseArcTest.ml 2012-05-24 22:23:11 UTC (rev 1714) @@ -0,0 +1,95 @@ +open OUnit +open TermType +open SyntaxDef +open BuiltinLang +open ParseArc + +let tests = "ParseArc" >::: [ + + "extend and close arc list" >:: + (fun () -> + let elem_eq res e = assert_equal ~printer:(fun x -> x) res (elem_str e) in + let type_decls_list = [ + (list_cons_name, Fun_type ([|Type_var "a"; list_tp_a|], list_tp_a)); + (list_nil_name, list_tp_a); + (boolean_true_name, boolean_tp); + (boolean_false_name, boolean_tp)] in + let tps = Hashtbl.create 7 in + List.iter (fun (n, t) -> Hashtbl.add tps n t) type_decls_list; + let var_x_a_sd = SDvar ([Str "x"], Type_var "a") in + let sdefs = [list_cons_sd; list_nil_sd; + boolean_true_sd; boolean_false_sd; var_x_a_sd] in + let arcs = List.map (fun sd -> Arc (sd, (name_of_sd sd), [], 0)) sdefs in + + let var_arc = extend_arc_list (Token "x") arcs in + let var_closed = fst (List.hd (close_arc_list tps var_arc)) in + elem_eq "Te @V [Vx @: @? a @: 0 ] : @? a" var_closed; + + let nil_part_arcs = extend_arc_list (Token "[") arcs in + let nil_arc = extend_arc_list (Token "]") nil_part_arcs in + let nil_closed = fst (List.hd (close_arc_list tps nil_arc)) in + elem_eq "Te @L[] : T\\?_list (@? a._.5)" nil_closed; + + let cons_part1_arc = extend_arc_list var_closed arcs in + let cons_part2_arc = extend_arc_list (Token ",") cons_part1_arc in + let cons_arc = extend_arc_list nil_closed cons_part2_arc in + let cons_closed = fst (List.hd (close_arc_list tps cons_arc)) in + elem_eq "Te @L[@... [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 @ (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. Deleted: trunk/Toss/Term/lib/basic.spg =================================================================== --- trunk/Toss/Term/lib/basic.spg 2012-05-20 21:11:56 UTC (rev 1712) +++ trunk/Toss/Term/lib/basic.spg 2012-05-21 22:07:00 UTC (rev 1713) @@ -1,5 +0,0 @@ -// LoadBasicState. - -Load state library:/lists. - - Copied: trunk/Toss/Term/lib/basic.trs (from rev 1712, trunk/Toss/Term/lib/basic.spg) =================================================================== --- trunk/Toss/Term/lib/basic.trs (rev 0) +++ trunk/Toss/Term/lib/basic.trs 2012-05-21 22:07:00 UTC (rev 1713) @@ -0,0 +1,5 @@ +// LoadBasicState. + +Load state library:/lists. + + Deleted: trunk/Toss/Term/lib/core.spg =================================================================== --- trunk/Toss/Term/lib/core.spg 2012-05-20 21:11:56 UTC (rev 1712) +++ trunk/Toss/Term/lib/core.spg 2012-05-21 22:07:00 UTC (rev 1713) @@ -1,559 +0,0 @@ -// THE CORE FILE FOR ESTABLISHING PASER PRIORITIES. -// THE FUNCTIONS HERE ARE PRELIMINARY AND SHOULD BE PREFIXED WITH "spg". -// LATER AFTER BASIC LIBRARY (bools, ternary vals, lists, terms) IS DONE, - THIS FILE AND MAIN PRIORITY FUNCTION SHOULD BE REIMPLEMENTED. - -// SHORTHAND FOR OCAML LIKE LIST NOTATION. -// This shorthand was previously the default notation and is used extensively. - -Function ?a '':'' '':'' ?a list as ?a list. -Variable ''e'' as ?a. -Variable ''l'' as ?a list. -Let e :: l be e, l. - - -// SHORTHAND FOR "IS A" AND "IS AN" FOR CONSTRUCTORS. - -Function syntax element sequence ''is'' ''a'' term type as syntax definition. -Function syntax element sequence ''is'' ''an'' term type as syntax definition. -Function syntax element sequence ''is'' term type as syntax definition. -Variable ''sels'' as syntax element sequence. -Variable ''ty'' as term type. -Let sels is a ty be function sels as ty. -Let sels is an ty be function sels as ty. -Let sels is ty be function sels as ty. - - -// APPEND AND STRING PLUS. - -Function ''append'' ?a list ''to'' ?a list as ?a list. -Variable ''xs'' as ?a list. -Variable ''ys'' as ?a list. -Variable ''y'' as ?a. -Let append xs to [] be xs. -Let append xs to (y :: ys) be y :: (append xs to ys). - -Function string ''+'' string as string. -Variable ''cx'' as char list. -Variable ''cy'' as char list. -Let string from cx + string from cy be string from append cy to cx. - -Close context. - - -// BASIC OPERATION - FUNCTION TO ALLOW NOTATION WITH NEW ___. - -Function ''new'' syntax definition as syntax definition. -Variable ''sd'' as syntax definition. -Let new sd be sd. - - -// SHORTHAND SYNTAX NOTATION. -New variable ''sa'' as string. -New variable ''sb'' as string. -New variable ''sc'' as string. -New variable ''sd'' as string. -New variable ''tt'' as term type. - -New function ''variable'' string ''as'' term type as syntax definition. -Let variable sa as tt be variable ''sa'' as tt. - -New function ''variable'' string string ''as'' term type as syntax definition. -Let variable sa sb as tt be variable ''sa'' ''sb'' as tt. - -New function ''variable'' string string string ''as'' term type - as syntax definition. -Let variable sa sb sc as tt be variable ''sa'' ''sb'' ''sc'' as tt. - -New function ''variable'' string string string string ''as'' term type - as syntax definition. -Let variable sa sb sc sd as tt be variable ''sa'' ''sb'' ''sc'' ''sd'' as tt. - - -New function ''''' ''''' string string ''''' ''''' as syntax element sequence. -Let ''sa sb'' be ''sa'' ''sb''. - -New function ''''' ''''' string string ''''' ''''' syntax element sequence - as syntax element sequence. -New variable sl as syntax element sequence. -Let ''sa sb'' sl be ''sa'' ''sb'' sl. - - -New function ''''' ''''' string string string ''''' ''''' - as syntax element sequence. -Let ''sa sb sc'' be ''sa'' ''sb'' ''sc''. - -New function ''''' ''''' string string string ''''' ''''' - syntax element sequence as syntax element sequence. -Let ''sa sb sc'' sl be ''sa'' ''sb'' ''sc'' sl. - -// UNIT TYPE. - -New type ''unit type''. -New function ''unit'' as unit type. - - -// FUNCTIONS ON BOOLEANS. - -New variable var_boola as boolean. -New variable var_boolb as boolean. - -New function boolean ''as boolean'' as boolean. -Let var_boola as boolean be var_boola. - -New function boolean ''and'' boolean as boolean. -Let true and true be true. -Let false and var_boolb be false. -Let var_boola and false be false. - -New function boolean ''or'' boolean as boolean. -Let false or false be false. -Let var_boola or true be true. -Let true or var_boolb be true. - -New function ''not'' boolean as boolean. -Let not true be false. -Let not false be true. - -Close context. - -New variable x as boolean. - -x and false. - -Close context. - - -// FUNCTIONS ON TERNARY TRUTH VALUES. - -New variable var_ter as ternary truth value. -New variable var_terlist as ternary truth value list. - -New function ''reduce'' ternary truth value list ''starting'' - ''with'' ternary truth value as ternary truth value. -Let reduce [] starting with var_ter be var_ter. -Let reduce unknown :: var_terlist starting with var_ter be - reduce var_terlist starting with var_ter. -Let reduce true :: var_terlist starting with false be unknown. -Let reduce true :: var_terlist starting with var_ter be - reduce var_terlist starting with true. -Let reduce false :: var_terlist starting with true be unknown. -Let reduce false :: var_terlist starting with var_ter be - reduce var_terlist starting with false. - -New function ''reduce'' ternary truth value list - as ternary truth value. -Let reduce var_terlist be reduce var_terlist starting with unknown. - -Close context. - - -// FUNCTION TO COMPARE STRING NAMES TO DECIDE IF THE NAMES CORRESPOND. - -New variable s as string. -New variable c_a as char. -New variable c_b as char. -New variable cl_a as char list. -New variable cl_b as char list. - -New function ''is digit'' string as boolean. -Let is digit 0 be true. -Let is digit 1 be true. -Let is digit 2 be true. -Let is digit 3 be true. -Let is digit 4 be true. -Let is digit 5 be true. -Let is digit 6 be true. -Let is digit 7 be true. -Let is digit 8 be true. -Let is digit 9 be true. -Let is digit s be false. - -New function string ''is backslash'' as boolean. -Let "\" is backslash be true. -Let s is backslash be false. - -New function ''added ending'' char list as boolean. -Let added ending [] be true. -Let added ending c_a :: [] be string from c_a :: [] is backslash. -Let added ending c_a :: cl_a be - if is digit string from c_a :: [] then added ending cl_a else false. - -New function ''corresponding names'' ''after first'' string ''and'' string - as boolean. -Let corresponding names after first string from [] and string from [] be true. -Let corresponding names after first string from [] and string from c_a :: cl_a - be added ending cl_a. -Let corresponding names after first string from c_a :: cl_a and string from [] - be added ending cl_a. -Let corresponding names after first string from c_a :: cl_a - and string from c_b :: cl_b be - corresponding names after first string from cl_a and string from cl_b. -Let corresponding names after first string from c_a :: cl_a - and string from c_b :: cl_b be - added ending c_a :: cl_a and added ending c_b :: cl_b. - -New function ''corresponding names'' string ''and'' string as boolean. -Let corresponding names string from [] and string from [] be true. -Let corresponding names string from [] and string from c_a :: cl_a be - added ending cl_a. -Let corresponding names string from c_a :: cl_a and string from [] be - added ending cl_a. -Let corresponding names string from c_a :: cl_a and string from c_b :: cl_b be - corresponding names after first string from cl_a and string from cl_b. - -Close context. - - -// BASIC VARIABLES FOR TERM OPERATIONS. - -New variable s_1 as string. -New variable s_2 as string. -New variable s as string. -New variable ty_1 as term type. -New variable ty_2 as term type. -New variable bl_1 as bit list. -New variable bl_2 as bit list. -New variable t_1 as term. -New variable t_2 as term. -New variable t_3 as term. -New variable t_4 as term. -New variable t_5 as term. -New variable u_1 as term. -New variable u_2 as term. -New variable u_3 as term. -New variable u_4 as term. -New variable u_5 as term. -New variable tl_1 as term list. -New variable tl_2 as term list. - - -// THE MAIN PRIORITY FUNCTIONS. - -New function term list ''better'' term list as ternary truth value list. -Let [] better [] be []. -Let t_1 :: tl_1 better t_2 :: tl_2 be - t_1 parsed preferred to t_2 :: tl_1 better tl_2. -// Let tl_1 better tl_2 be false :: []. -Let tl_1 better tl_2 be unknown :: []. - - -// THIS SAYS THAT IF ___ ELSE X F IS IF ___ (X F) NOT (IF ___ X) F. -Let term "Fif_\?_then_\?_else_\?" - (t_1 :: t_2 :: term s_1 (t_3 :: []) :: []) parsed preferred to - term s_2 (term "Fif_\?_then_\?_else_\?" - (u_1 :: u_2 :: u_3 :: []) :: []) be - if ((t_1 = u_1 and t_2 = u_2) and s_1 = s_2) and t_3 = u_3 then - true else unknown. - -Let term s_1 (term "Fif_\?_then_\?_else_\?" - (t_1 :: t_2 :: t_3 :: []) :: []) parsed preferred to - term "Fif_\?_then_\?_else_\?" - (u_1 :: u_2 :: term s_2 (u_3 :: []) :: []) be - if ((t_1 = u_1 and t_2 = u_2) and s_1 = s_2) and t_3 = u_3 then - false else unknown. - - -// ANALOGOUS TO THE ABOVE FOR F WITH ARITY 2. -Let term "Fif_\?_then_\?_else_\?" - (t_1 :: t_2 :: term s_1 (t_3 :: t_4 :: []) :: []) parsed preferred to - term s_2 (term "Fif_\?_then_\?_else_\?" - (u_1 :: u_2 :: u_3 :: []) :: u_4 :: []) be - if (((t_1 = u_1 and t_2 = u_2) and s_1 = s_2) and t_3 = u_3) and t_4=u_4 then - true else unknown. - -Let term s_1 (term "Fif_\?_then_\?_else_\?" - (t_1 :: t_2 :: t_3 :: []) :: t_4 :: []) parsed preferred to - term "Fif_\?_then_\?_else_\?" - (u_1 :: u_2 :: term s_2 (u_3 :: u_4 :: []) :: []) be - if (((t_1 = u_1 and t_2 = u_2) and s_1 = s_2) and t_3=u_3) and t_4 = u_4 then - false else unknown. - - -// ANALOGOUS TO THE ABOVE FOR F WITH ARITY 3. -Let term "Fif_\?_then_\?_else_\?" - (t_1 :: t_2 :: term s_1 (t_3 :: t_4 :: t_5 ::[]) ::[]) parsed preferred to - term s_2 (term "Fif_\?_then_\?_else_\?" - (u_1 :: u_2 :: u_3 :: []) :: u_4 :: u_5 :: []) be - if ((((t_1 = u_1 and t_2 = u_2) and s_1 = s_2) and t_3 = u_3) and t_4=u_4) - and t_5 = u_5 then true else unknown. - -Let term s_1 (term "Fif_\?_then_\?_else_\?" - (t_1 :: t_2 :: t_3 :: []) :: t_4 :: t_5 :: []) parsed preferred to - term "Fif_\?_then_\?_else_\?" - (u_1 :: u_2 :: term s_2 (u_3 :: u_4 :: u_5 :: []) :: []) be - if ((((t_1 = u_1 and t_2 = u_2) and s_1 = s_2) and t_3 = u_3) and t_4=u_4) - and t_5 = u_5 then false else unknown. - - -// STRINGS SHOULD NOT BE TAKEN WHEN BOTTOM ALTERNATIVE IS POSSIBLE. -Let term s ([]) parsed preferred to term "Fstring_from_\?" (t_1 :: []) be true. -Let term "Fstring_from_\?" (t_1 :: []) parsed preferred to term s ([]) be false. -Let var s : ty_1 : bl_1 ([]) parsed preferred to - term "Fstring_from_\?" (t_1 :: []) be true. -Let term "Fstring_from_\?" (t_1 :: []) parsed preferred to - var s : ty_1 : bl_1 ([]) be false. - - -// NOTE THAT RULES MUST BE ADDED TO THIS FUNCTION IN REVERSE ORDER. -Let term s_1 (tl_1) parsed preferred to term s_2 (tl_2) be - if corresponding names s_1 and s_2 then reduce tl_1 better tl_2 else unknown. -Let var s_1 : ty_1 : bl_1 (tl_1) parsed preferred to var s_2 : ty_2: bl_2 (tl_2) - be if s_1 = s_2 then reduce tl_1 better tl_2 else unknown. - -// THIS IS BECAUSE THE FOLLOWING MUST BE APPLIED AS LAST RESORT. -Let t_1 parsed preferred to t_2 be unknown. - - - -// SOME BASIC FUNCTION ON TERMS THAT WE WANT TO USE. - -New function term ''equal modulo types'' ''to'' term as boolean. -New function term list ''equal modulo types'' ''to'' term list as boolean. - -Let [] equal modulo types to [] be true. -Let t_1 :: tl_1 equal modulo types to t_2 :: tl_2 be - if t_1 equal modulo types to t_2 then tl_1 equal modulo types to tl_2 - else false. -Let tl_1 equal modulo types to tl_2 be false. - -Let term s_1 (tl_1) equal modulo types to term s_2 (tl_2) be - tl_1 equal modulo types to tl_2. - -Let var s_1 : ty_1 : bl_1 (tl_1) equal modulo types to - var s_2 : ty_2 : bl_2 (tl_2) be - if s_1 =s_2 and bl_1 = bl_1 then tl_1 equal modulo types to tl_2 else false. -Let t_1 equal modulo types to t_2 be false. - - -// GENERATING RULES TO MAKE THE FUNCTION GIVEN BY NAME A WEAK CAST. -New function ''see'' string ''as non default'' ''cast'' ''for'' - term ''and'' term as - (priority input rewrite rule of ternary truth value) list. -Let see s as non default cast for t_1 and t_2 be - let major t_2 parsed preferred to term s (t_1 :: []) be - if t_2 equal modulo types to t_1 then true else - t_2 parsed preferred to t_1 :: - let major term s (t_1 :: []) parsed preferred to t_2 be - if t_2 equal modulo types to t_1 then false else - t_1 parsed preferred to t_2 :: - let major term s (t_1 :: []) parsed preferred to term s (t_2 :: []) be - t_1 parsed preferred to t_2 :: []. - -Close context. - -New variable t_u as term. -New variable t_r as term. - -// Allow new variables on right hand side of rewrite rule in - the special case when these end being bound in rewrite rule anyway. -New function ''see'' string ''as'' ''non'' ''default'' ''cast'' as - (priority input rewrite rule of ternary truth value) list. -New variable s as string. -Let see s as non default cast be - see s as non default cast for t_u and t_r. - -// SIMPLE ANTI-CAST RULES, HERE FOR TWO STANDARD CASTS (FROM CORE LANG). -See "F\?" as non default cast. -See "F\?_0\" as non default cast. - -Close context. - - -// GETTING THE NAME OF LAST DEFINED FUNCTION AND SETTING IT AS CAST. -New function ''last fun name'' ''from'' fun definition list as string. - -New variable fdl as fun definition list. -New variable ttl as term type list. -New variable tt as term type. -New variable s as string. - -Let last fun name from fun s from ttl to tt :: fdl be s. - -New function ''see last function'' ''as'' ''cast'' as - (priority input rewrite rule of ternary truth value) list. -Let see last function as cast be - <| see last fun name from get fun definitions as non default cast |>. - -Close context. - - -// GENERATING PREFERENCE RULE FOR A PAIR OF TERMS. -New function ''see'' ?a ''preferred to different'' ?b as - (priority input rewrite rule of ternary truth value) list. - -New variable x_2 as ?a. -New variable x as ?a. -New variable y as ?b. - -Let see x preferred to different y be - let major - <| code x as term |> parsed preferred to <| code y as term |> be true :: - let major - <| code y as term |> parsed preferred to - <| code x as term |> be false :: []. - - -New function ''see'' ?a ''preferred to'' ?a as - (priority input rewrite rule of ternary truth value) list. -Let see x preferred to x_2 be - <| see x preferred to different x_2 |>. - - -Close context. - - -// PREFERENCE FOR BOOLEANS OVER TERNARY TRUTH VALUES. -New variable b as boolean. -New variable t as ternary truth value. - -New function ternary truth value ''as ternary truth'' ''value'' - as ternary truth value. -Let t as ternary truth value be t. - -See true as boolean preferred to different true as ternary truth value. -See false as boolean preferred to different false as ternary truth value. - - -// PREFERENCE TO MAKE STRING ADDITION LEFT ASSOCIATIVE. -New variable s_1 as string. -New variable s_2 as string. -New variable s_3 as string. -New variable s_4 as string. -New variable s_5 as string. -New variable s_6 as string. - -See (s_1 + s_2) + s_3 preferred to s_4 + (s_5 + s_6). - - -// SHORTHAND FOR TERM TYPE USED IN TYPE DEFINITIONS. - -New function ''sth'' as syntax element. -Let sth be term type. - - -// ADDITIONAL IMPROVED LIST NOTATION. - -New variable e1 as ?a. -New variable e2 as ?a. -New variable e3 as ?a. -New variable e4 as ?a. -New variable e5 as ?a. -New variable e6 as ?a. -New variable l as ?a list. -New variable ll as ?a list list. - -New function ''['' ?a '']'' as ?a list. -Let [e1] be e1 :: []. - -New function ?a '','' ?a as ?a list. -See (e1, l) preferred to different (e2, e3). - -New function ?a list ''as'' ''list'' as ?a list. -Let l as list be l. - - -// PAIRS AND TRIPLES DEFS AND PREFERENCES. - -New type ''pair of'' sth ''and'' sth. -New function ''('' ?a '','' ?b '')'' as pair of ?a and ?b. -New variable Vpair as pair of ?a and ?b. -New function pair of ?a and ?b ''as'' ''pair'' as pair of ?a and ?b. -Let Vpair as pair be Vpair. - -See (e1, e2) as pair preferred to different (<|(e3, e4)|> as list). - - -New type ''triple of'' sth ''and'' sth ''and'' sth. -New function ''('' ?a '','' ?b '','' ?c '')'' as - triple of ?a and ?b and ?c. -New variable Vtriple as triple of ?a and ?b and ?c. -New function triple of ?a and ?b and ?c ''as'' ''triple'' - as triple of ?a and ?b and ?c. -Let Vtriple as triple be Vtriple. - -See (e1, e2, e3) as triple preferred to different - (<|(e4, e5, e6)|> as list). -See (e1, e2, e3) as triple preferred to different - (<|e4, e5|>, e6) as pair. -See (e1, e2, e3) as triple preferred to different - (e4, <|e5, e6|>) as pair. - -Let e1, e2 be e1 :: e2 :: []. - -Close context. - - -// TRIPLES FUNCTIONS. - -New variable x_1 as ?a. -New variable x_2 as ?b. -New variable x_3 as ?c. - -New function ''first of'' triple of ?a and ?b and ?c as ?a. -Let first of... [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_output_file s = (out_path := s) in + let lib_path = ref "library" in + let set_lib_path s = (lib_path := s) in + let print_mem_after = ref false in + let print_mem_set () = (print_mem_after := true) in + let builtin_out = ref false in + let set_builtin_out () = (builtin_out := true) in + let compile_mode = ref false in + let set_compile () = (compile_mode := true) in + let xml_out = ref false in + let set_xml_out () = (xml_out := true; compile_mode := true) in + let grammar_path = ref "" in + let set_gram_path s = (grammar_path := s) in + let xslt_path = ref "" in + let set_xslt_path s = (xslt_path := s) in + let opts = [ + ("-f", Arg.Unit (make_it_fail), "make speagram fail on bad parses"); + ("-v", Arg.Unit (make_verbose), "make speagram verbose"); + ("-m", Arg.Unit (print_mem_set), "show memory use when quitting"); + ("-o", Arg.String (set_output_file), "output parsed terms to file"); + ("-l", Arg.String (set_lib_path), "set path to library directory"); + ("-b", Arg.Unit (set_builtin_out), "print builtin language definitions"); + ("-c", Arg.Unit (set_compile), "work in compile and not interactive mode"); + ("-x", Arg.Unit (set_xml_out), "output normalised terms in XML format"); + ("-g", Arg.String (set_gram_path), "output (flat EBNF) grammar to file"); + ("-s", Arg.String (set_xslt_path), "output corresponding XSLT to file"); + ] in + let _ = Arg.parse opts (fun _ -> ()) "try -h for help" in + if not !should_fail then + ignore (OUnit.run_test_tt ~verbose:true tests) + else ( + let parsed_terms = ref [] 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") + else ( + if not (!compile_mode) then + print_endline "\nWELCOME TO SPEAGRAM, PARSING INPUT:\n" + else + if (!xml_out) then print_endline "<speagram-response>" else (); + run !lib_path !verbose !grammar_path !xslt_path !out_path !compile_mode + basic_sys (fun ()->input_char stdin) !should_fail !xml_out + parsed_terms (fun s -> print_endline s); + if (!print_mem_after && (not (!compile_mode))) then + let mem = Gc.allocated_bytes () in + let mem_str = string_of_int (int_of_float (mem /. 1024.0) / 1024) in + let gc_overhd= float_of_int ((Gc.get()).Gc.space_overhead+100)/.100.0 in + let min_heap_unit = float_of_int (4*(Gc.get()).Gc.minor_heap_size) in + let est_use_mem = ((mem *. gc_overhd) /. 1024.0) +. min_heap_unit in + let est_use_str = string_of_int ((int_of_float est_use_mem) / 1024) in + let est = "<est. " ^ est_use_str ^ " KB used>" in + let mem_msg = "(ocaml reports " ^ mem_str ^" MB allocated "^est^")" in + print_endline ("\n\nBYE " ^ mem_msg ^ " :)\n") + else + if not !compile_mode then + print_endline "\n\nBYE :)\n" + else + if (!xml_out) then print_endline "</speagram-response>\n" else (); + ) + ) +;; + +let _ = AuxIO.run_if_target "TRSTest" main Modified: trunk/Toss/Term/Term.ml =================================================================== --- trunk/Toss/Term/Term.ml 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/Term.ml 2012-05-20 21:11:56 UTC (rev 1712) @@ -3,7 +3,7 @@ open Array;; -open Str;; +open Aux;; open TermType;; open SyntaxDef;; @@ -528,27 +528,27 @@ let term_array_to_string ta = String.concat ", " (to_list (map term_to_string ta)) in match term with - _ when is_some (decode_string_opt term) -> + | _ when is_some (decode_string_opt term) -> let s = (match (decode_string_opt term) with Some s -> s | None -> "") in - "@`" ^ (global_replace (regexp "[\n\r\t]") " " s) ^ "@`" - | _ when is_some (decode_list_opt (fun x -> x) term) -> + "@`" ^ (Aux.normalize_spaces s) ^ "@`" + | _ when is_some (decode_list_opt (fun x -> x) term) -> (match (decode_list_opt (fun x -> x) term) with None -> "" - | Some l -> "@L["^ (String.concat ", " (List.map term_to_string l)) ^"]") - | _ when is_some (decode_term_type_opt term) -> + | Some l -> "@L["^ (String.concat ", " (List.map term_to_string l))^"]") + | _ when is_some (decode_term_type_opt term) -> (match (decode_term_type_opt term) with None -> "" - | Some ty -> "@Y " ^ (type_to_string ty)) - | _ when is_some (decode_term_opt term) -> + | Some ty -> "@Y " ^ (type_to_string ty)) + | _ when is_some (decode_term_opt term) -> (match (decode_term_opt term) with None -> "" - | Some te -> "@T " ^ (term_to_string te)) - | Var (v, t, d, [||]) -> + | Some te -> "@T " ^ (term_to_string te)) + | Var (v, t, d, [||]) -> "@V [" ^ v ^ " @: " ^ (type_to_string t) ^ " @: "^ string_of_int (d) ^ " ]" - | Var (v, t, d, a) -> + | Var (v, t, d, a) -> "@V [" ^ v ^ " @: " ^ (type_to_string t) ^ " @: "^ string_of_int (d) ^ " ] (" ^ - (term_array_to_string a) ^ " )" - | Term (n, [||]) -> n - | Term (n, a) -> + (term_array_to_string a) ^ " )" + | Term (n, [||]) -> n + | Term (n, a) -> n ^ " (" ^ (term_array_to_string a) ^ " )" ;; Modified: trunk/Toss/Term/Term.mli =================================================================== --- trunk/Toss/Term/Term.mli 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/Term.mli 2012-05-20 21:11:56 UTC (rev 1712) @@ -87,7 +87,7 @@ val display_term_xml : term -> string;; val term_to_string : term -> string;; -val parse_term : Str.split_result Stream.t -> term;; +val parse_term : Aux.split_result Stream.t -> term;; val term_of_string : string -> term;; Modified: trunk/Toss/Term/TermType.ml =================================================================== --- trunk/Toss/Term/TermType.ml 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/TermType.ml 2012-05-20 21:11:56 UTC (rev 1712) @@ -3,9 +3,7 @@ open Array;; -open Str;; - (* The type of term types. *) type term_type = Term_type of string * term_type array @@ -131,20 +129,33 @@ (* Lexer for types and terms. *) let split_to_list str = - let split_space s = split (regexp "[ \t\n\r]+") s in - let special_regexp = regexp "[(,)]\\|\\[\\|\\]\\|@[FLVYT`:\\?]" in + let split_space s = Aux.split_spaces s in + let full_special_split s = + let l = Aux.split_chars_after '@' ['F';'L';'V';'Y';'T';'`';':';'?'] s in + let is_special c = (c = '(') || (c = ')') ||(c = '[') || (c = ']') || + (c = ',') in + let divide s = + let l = Aux.split_charprop ~keep_split_chars:true is_special s in + List.map (fun s -> if String.length s = 1 && is_special s.[0] then + Aux.Delim s else Aux.Text s) l in + let restsplit = + function | Aux.Delim d -> [Aux.Delim d] | Aux.Text s -> divide s in + List.concat (List.map restsplit l) in let split_special_space s = - List.concat (List.map (full_split special_regexp) (split_space s)) in - let string_regexp = regexp "@`" in + List.concat (List.map full_special_split (split_space s)) in let rec split_special = function - [] -> [] - | Delim "@`" :: Delim "@`" :: rest -> - Delim "@`" :: Delim "@`" :: split_special (rest) - | Delim "@`" :: Text s :: Delim "@`" :: rest -> - Delim "@`" :: Text s :: Delim "@`" :: split_special (rest) - | Text s :: rest -> (split_special_space s) @ split_special (rest) - | Delim d :: rest -> Delim d :: split_special (rest) in - split_special (full_split string_regexp str) + | [] -> [] + | Aux.Delim "@`" :: Aux.Delim "@`" :: rest -> + Aux.Delim "@`" :: Aux.Delim "@`" :: split_special (rest) + | Aux.Delim "@`" :: Aux.Text s :: Aux.Delim "@`" :: rest -> + Aux.Delim "@`" :: Aux.Text s :: Aux.Delim "@`" :: split_special (rest) + | Aux.Text s :: rest -> (split_special_space s) @ split_special (rest) + | Aux.Delim d :: rest -> Aux.Delim d :: split_special (rest) in + let r1 = Aux.split_chars_after '@' ['`'] str in + (*print_endline (String.concat " |" + (List.map (function Aux.Delim d -> "D " ^ d | + Aux.Text d -> "T " ^ d) r1));*) + split_special r1 ;; (* TESTS * @@ -152,26 +163,32 @@ split_to_list "@`[] \n \t @F@` [ ]\t (@`@`, @`@`) ";; *) -let split_to_stream str = Stream.of_list (split_to_list str);; +let split_to_stream str = + let l = split_to_list str in + (*print_endline "ALA"; + print_endline (String.concat " |" + (List.map (function Aux.Delim d -> "D " ^ d | + Aux.Text d -> "T " ^ d) l));*) + Stream.of_list l (* Parser for types. *) let rec parse_type = parser - [< 'Delim "@?"; 'Text n >] -> Type_var n - | [< 'Delim "@F"; l = parse_list >] -> ( + [< 'Aux.Delim "@?"; 'Aux.Text n >] -> Type_var n + | [< 'Aux.Delim "@F"; l = parse_list >] -> ( match l with [] -> failwith "Function w/o return type." | r :: a -> Fun_type (of_list a, r) ) - | [< 'Text n; l = parse_list >] -> Term_type (n, of_list l) + | [< 'Aux.Text n; l = parse_list >] -> Term_type (n, of_list l) and parse_list = parser - [< 'Delim "("; l = parse_type_list; 'Delim ")" >] -> l + [< 'Aux.Delim "("; l = parse_type_list; 'Aux.Delim ")" >] -> l | [< >] -> [] and parse_type_list = parser [< n = parse_type; l = parse_type_list_delim >] -> n :: l | [< >] -> [] and parse_type_list_delim = parser - [< 'Delim ","; l = parse_type_list >] -> l + [< 'Aux.Delim ","; l = parse_type_list >] -> l | [< >] -> [] ;; Modified: trunk/Toss/Term/TermType.mli =================================================================== --- trunk/Toss/Term/TermType.mli 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/TermType.mli 2012-05-20 21:11:56 UTC (rev 1712) @@ -26,10 +26,10 @@ val type_to_string : term_type -> string;; (* Lexer for terms and types in internal format. *) -val split_to_stream : string -> Str.split_result Stream.t;; +val split_to_stream : string -> Aux.split_result Stream.t;; (* Parser for types in internal format from lexed stream. *) -val parse_type : Str.split_result Stream.t -> term_type;; +val parse_type : Aux.split_result Stream.t -> term_type;; (* Parsing types in internal format from string. *) val type_of_string : string -> term_type;; Deleted: trunk/Toss/Term/lib/Makefile =================================================================== --- trunk/Toss/Term/library/Makefile 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/lib/Makefile 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,104 +0,0 @@ -# -# 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. -# - -top_srcdir = .. - -OCAMLTOP = ocaml -I +camlp4 camlp4o.cma str.cma - -OCAMLCARGS = -thread -I +camlp4 -pp "camlp4o" str.cma unix.cma threads.cma -OCAMLC = ocamlc $(OCAMLCARGS) - -OCAMLOPTARGS = -thread -I +camlp4 -pp "camlp4o" str.cmxa unix.cmxa threads.cmxa -OCAMLOPT = ocamlopt $(OCAMLOPTARGS) - -DIFF = diff -SED = sed -Q = @ - - -############################################################ -# VARIABLES -############################################################ - -DISTFILES = \ - basic.spg \ - basic.spg.parsed \ - core.spg \ - core.spg.parsed \ - arithmetics.spg \ - arithmetics.spg.parsed \ - lists.spg \ - lists.spg.parsed \ - sasha.spg \ - sasha.spg.parsed \ - -SPEAGRAM_CMD = ../speagram -v -f -l "" -EXTRACT_CMD = ../spg-extract - -############################################################ -# TARGETS -############################################################ - -all: basic.spg.parsed sasha.spg.parsed - -core.spg.parsed: core.spg - $(Q)echo "Creating $@." - $(Q)$(SPEAGRAM_CMD) -o core.spg.parsed < core.spg > /dev/null - - -arithmetics.spg.parsed: arithmetics.spg core.spg.parsed - $(Q)echo "Creating $@." - $(Q)$(SPEAGRAM_CMD) -o arithmetics.spg.parsed < arithmetics.spg\ - > /dev/null - -lists.spg.parsed: lists.spg arithmetics.spg.parsed - $(Q)echo "Creating $@." - $(Q)$(SPEAGRAM_CMD) -o lists.spg.parsed < lists.spg > /dev/null - -basic.spg.parsed: basic.spg \ - core.spg.parsed \ - arithmetics.spg.parsed \ - lists.spg.parsed - $(Q)echo "Creating $@." - $(Q)$(SPEAGRAM_CMD) -o basic.spg.parsed < basic.spg > /dev/null - - -sasha.spg.parsed: sasha.spg basic.spg.parsed - $(Q)echo "Creating $@." - $(Q)$(SPEAGRAM_CMD) -o sasha.spg.parsed < sasha.spg > /dev/null - - - -.PHONY: - -tarball: - cp $(DISTFILES) $(top_srcdir)/$(DIR) - $(SED) "s/top_srcdir = ..\/../top_srcdir = .. < Makefile > Mf.adjst - mv Mf.adjst $(top_srcdir)/$(DIR)/Makefile - -clean: - rm -f *.spg.parsed *~ Deleted: trunk/Toss/Term/speagram.ml =================================================================== --- trunk/Toss/Term/speagram.ml 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/speagram.ml 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,129 +0,0 @@ -(* The speagram binary for command line use. *) - - -open List;; -open Str;; - -open Term;; -open TRS;; -open SyntaxDef;; - - -let rec run lp v grammar_path xslt_path out_path - cmode sys channel fail xmlo res = - 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 - print_endline ("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 - print_endline ("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 - print_endline ("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; - run lp v grammar_path xslt_path out_path cmode sys channel fail xmlo res) - with - End_of_file -> save_requested (); - | FAILED_PARSE_OR_EXN msg -> - (save_requested (); - if xmlo then - (print_endline "\n<speagram-failure>\n"; - print_endline (make_xml_compatible msg); - print_endline "\n</speagram-failure>\n"; - print_endline "\n</speagram-response>\n";) - else (); - failwith msg) -;; - - -let _ = - 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_output_file s = (out_path := s) in - let lib_path = ref "library" in - let set_lib_path s = (lib_path := s) in - let print_mem_after = ref false in - let print_mem_set () = (print_mem_after := true) in - let builtin_out = ref false in - let set_builtin_out () = (builtin_out := true) in - let compile_mode = ref false in - let set_compile () = (compile_mode := true) in - let xml_out = ref false in - let set_xml_out () = (xml_out := true; compile_mode := true) in - let grammar_path = ref "" in - let set_gram_path s = (grammar_path := s) in - let xslt_path = ref "" in - let set_xslt_path s = (xslt_path := s) in - let opts = [ - ("-f", Arg.Unit (make_it_fail), "make speagram fail on bad parses"); - ("-v", Arg.Unit (make_verbose), "make speagram verbose"); - ("-m", Arg.Unit (print_mem_set), "show memory use when quitting"); - ("-o", Arg.String (set_output_file), "output parsed terms to file"); - ("-l", Arg.String (set_lib_path), "set path to library directory"); - ("-b", Arg.Unit (set_builtin_out), "print builtin language definitions"); - ("-c", Arg.Unit (set_compile), "work in compile and not interactive mode"); - ("-x", Arg.Unit (set_xml_out), "output normalised terms in XML format"); - ("-g", Arg.String (set_gram_path), "output (flat EBNF) grammar to file"); - ("-s", Arg.String (set_xslt_path), "output corresponding XSLT to file"); - ] in - let _ = Arg.parse opts (fun _ -> ()) "try -h for help" in - let parsed_terms = ref [] 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") - else - ( - if not (!compile_mode) then - print_endline "\nWELCOME TO SPEAGRAM, PARSING INPUT:\n" - else - if (!xml_out) then print_endline "<speagram-response>" else (); - run !lib_path !verbose !grammar_path !xslt_path !out_path !compile_mode - basic_sys stdin !should_fail !xml_out parsed_terms; - if (!print_mem_after && (not (!compile_mode))) then - let mem = Gc.allocated_bytes () in - let mem_str = string_of_int (int_of_float (mem /. 1024.0) / 1024) in - let gc_overhd = float_of_int ((Gc.get()).Gc.space_overhead+100)/.100.0 in - let min_heap_unit = float_of_int (4 * (Gc.get()).Gc.minor_heap_size) in - let est_use_mem = ((mem *. gc_overhd) /. 1024.0) +. min_heap_unit in - let est_use_str = string_of_int ((int_of_float est_use_mem) / 1024) in - let est = "<est. " ^ est_use_str ^ " KB used>" in - let mem_msg = "(ocaml reports " ^ mem_str ^ " MB allocated "^est^")" in - print_endline ("\n\nBYE " ^ mem_msg ^ " :)\n") - else - if not !compile_mode then - print_endline "\n\nBYE :)\n" - else - if (!xml_out) then print_endline "</speagram-response>\n" else (); - ) -;; Deleted: trunk/Toss/Term/tests/Makefile =================================================================== --- trunk/Toss/Term/testsuite/Makefile 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/Makefile 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,169 +0,0 @@ -# -# 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 = -thread -I +camlp4 -pp "camlp4o" str.cma unix.cma threads.cma -OCAMLC = ocamlc $(OCAMLCARGS) - -OCAMLOPTARGS = -thread -I +camlp4 -pp "camlp4o" str.cmxa unix.cmxa threads.cmxa -OCAMLOPT = ocamlopt $(OCAMLOPTARGS) - -DIFF = diff -SED = sed -Q = @ - -top_srcdir = .. - - -SPG_TEST_IN_FILES = $(notdir $(shell find . -maxdepth 1 -name '*.spg')) -SPG_TEST_STRIP_FILES = $(basename $(SPG_TEST_IN_FILES)) -SPG_TEST_LOG_FILES = $(addsuffix .log, $(SPG_TEST_STRIP_FILES)) - -SPEAGRAM_CMD = ../speagram -c -f -l "../library" -s generated.xslt -GEN_XSLTPROC_CMD = xsltproc generated.xslt generated.xml | sed "s/>/>/g" |\ - sed "s/</</g" | sed "s/<br\/>/\n/g" | sed "s/<?xml.*?>//g"> generated.log - -all: $(SPG_TEST_LOG_FILES) - - -differentiation: differentiation.spg differentiation.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -differentiation.log: differentiation.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - - -english: english.spg english.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -english.log: english.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - - -fo_formula: fo_formula.spg fo_formula.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -fo_formula.log: fo_formula.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - - -sasha_basic: sasha_basic.spg sasha_basic.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -sasha_basic.log: sasha_basic.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - - -short_checks: short_checks.spg short_checks.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -short_checks.log: short_checks.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - - -simple_algo: simple_algo.spg simple_algo.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -simple_algo.log: simple_algo.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - -entanglement: entanglement.spg entanglement.log - $(Q)echo Testing [$@.spg]... - $(Q)$(SPEAGRAM_CMD) < $@.spg > generated.log -# $(Q)$(SPEAGRAM_CMD) -x < $@.spg > generated.xml; $(GEN_XSLTPROC_CMD) - $(Q)echo ...differences between achieved and expected output: - $(Q)($(DIFF) -Bw -s generated.log $@.log | cat -) - $(Q)echo ...differences printed. - -entanglement.log: entanglement.spg - $(Q)echo Parsing [$(addsuffix .spg, $(basename $@))]... - $(Q)$(SPEAGRAM_CMD) < $(addsuffix .spg, $(basename $@)) > generated.log - $(Q)mv generated.log $@ - - - -check: $(SPG_TEST_STRIP_FILES) - - - -.PHONY: - - -tarball: - $(Q)echo Copying tests, logs and Makefile into tarball... - $(Q)$(foreach file, $(SPG_TEST_IN_FILES), echo ...[$(file)] ;\ - cp $(file) $(top_srcdir)/$(DIR) ;) - $(Q)$(foreach file, $(SPG_TEST_LOG_FILES), echo ...[$(file)] ;\ - cp $(file) $(top_srcdir)/$(DIR) ;) - $(SED) "s/top_srcdir = ..\/../top_srcdir = .. < Makefile > Mf.adjst - $(Q)mv Mf.adjst $(top_srcdir)/$(DIR)/Makefile - -clean: - -rm -f *.exe *~ generated.log .last_tested Modified: trunk/Toss/Term/tests/differentiation.log =================================================================== --- trunk/Toss/Term/testsuite/differentiation.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/differentiation.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,4 +1,4 @@ -Loaded state ../library/basic. +Loaded state ./Term/lib/basic. // SYMBOLIC DIFFERENTIATION EXAMPLE. Modified: trunk/Toss/Term/tests/english.log =================================================================== --- trunk/Toss/Term/testsuite/english.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/english.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,4 +1,4 @@ -Loaded state ../library/basic. +Loaded state ./Term/lib/basic. New class "singular" "noun" declared. Modified: trunk/Toss/Term/tests/entanglement.log =================================================================== --- trunk/Toss/Term/testsuite/entanglement.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/entanglement.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,6 +1,6 @@ // LoadBasicState. -Loaded state ../library/basic. +Loaded state ./Term/lib/basic. // VertexAndSuccessorDeclarations. Modified: trunk/Toss/Term/tests/fo_formula.log =================================================================== --- trunk/Toss/Term/testsuite/fo_formula.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/fo_formula.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,4 +1,4 @@ -Loaded state ../library/sasha. +Loaded state ./Term/lib/sasha. New class "FO" "term" declared. Modified: trunk/Toss/Term/tests/sasha_basic.log =================================================================== --- trunk/Toss/Term/testsuite/sasha_basic.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/sasha_basic.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,4 +1,4 @@ -Loaded state ../library/sasha. +Loaded state ./Term/lib/sasha. // FIB. Modified: trunk/Toss/Term/tests/short_checks.log =================================================================== --- trunk/Toss/Term/testsuite/short_checks.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/short_checks.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,4 +1,4 @@ -Loaded state ../library/basic. +Loaded state ./Term/lib/basic. // SPEAGRAM TYPE AND NORMAL VARS. Modified: trunk/Toss/Term/tests/simple_algo.log =================================================================== --- trunk/Toss/Term/testsuite/simple_algo.log 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Term/tests/simple_algo.log 2012-05-20 21:11:56 UTC (rev 1712) @@ -1,4 +1,4 @@ -Loaded state ../library/basic. +Loaded state ./Term/lib/basic. New variable "n" declared. Modified: trunk/Toss/Toss.odocl =================================================================== --- trunk/Toss/Toss.odocl 2012-05-20 12:31:12 UTC (rev 1711) +++ trunk/Toss/Toss.odocl 2012-05-20 21:11:56 UTC (rev 1712) @@ -21,8 +21,13 @@ Solver/Solver Solver/Class Solver/ClassParser -Arena/Term -Arena/TermParser +Term/TermType +Term/SyntaxDef +Term/BuiltinLang +Term/Term +Term/Rewriting +Term/ParseArc +Term/TRS Arena/DiscreteRule Arena/DiscreteRuleParser Arena/ContinuousRule This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
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 -> false;; - -let decode_sd_opt te = - try Some (decode_syntax_definition te) with DECODE _ -> None -;; - -let decode_rr_opt te = - try Some (decode_rewrite_rule te) with DECODE _ -> None -;; - -let decode_irr_opt te = - try Some (decode_input_rewrite_rule te) with DECODE _ -> None -;; - -let decode_pirr_opt te = - 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 -;; - - -let msg_for_sels sels = - let i = ref 0 in - let msg = function - Str s -> "\"" ^ s ^ "\"" - | Tp _ -> (i := !i+1; "X_" ^ (string_of_int !i)) in - String.concat " " (map msg sels) -;; - -let recognize_list te = - if (te = code_list (fun x -> x) []) then ("", false) else - try let _ = decode_list decode_syntax_definition te in - ("syntax definitions", true) with - DECODE _ -> - try let _ = decode_list decode_priority_input_rewrite_rule te in - ("priority rewrite rules", false) with - 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) -;; - -let display_rr (l, r) = - let (ls, rs) = (display_term l, display_term r) in - if (String.length ls + String.length rs < 71) then - ls ^ " ---> " ^ rs - else - ls ^ " --->\n " ^ rs -;; - -let rec message_for_term tydecls k verbose xml_out in_pair = - let msg s1 s2 = - if xml_out then - "<speagram-message>\n" ^ - "<spg-msg-general>" ^ (make_xml_compatible s1) ^ "</spg-msg-general>\n" ^ - "<spg-msg-detail>" ^ (make_xml_compatible s2) ^ "</spg-msg-detail>\n" ^ - "</speagram-message>" - else s1 ^ "\n" ^ s2 in - match in_pair with - (te, _) when is_some (decode_sd_opt te) -> - msg (match decode_syntax_definition te with - SDtype (sels) -> "New class " ^ (msg_for_sels sels) ^ " declared." - | SDfun (sels, _) -> "New function " ^ (msg_for_sels sels) ^ " declared." - | SDvar (sels, _) -> "New variable " ^ (msg_for_sels sels) ^ " declared." - ) "" - | (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, raw) when is_some (decode_irr_opt te) -> ( - try - let rr = decode_input_rewrite_rule raw in - msg "New rewrite rule defined." (display_rr rr) - with - DECODE _ -> msg "New rewrite rule defined." (display_term raw) - ) - | (te, raw) when is_some (decode_pirr_opt te) -> ( - try - let rr = decode_priority_input_rewrite_rule te in - msg "New priority rewrite rule defined." (display_rr rr) - with - DECODE _ -> - msg "New priority rewrite rule defined." (display_term raw) - ) - | (te, raw) when not (recognize_list te = ("", false)) -> - if verbose then - let msgs = map (message_for_term tydecls k verbose false) - (decode_list (fun x -> (x, x)) te) in - msg "Processed multiple messages:" (String.concat "\n" msgs) - else - let (tp_msg , is_syn_def_lst) = recognize_list te in - if is_syn_def_lst then - let msgs = map (message_for_term tydecls k verbose false) - (decode_list (fun x -> (x, x)) te) in - msg "Processed multiple definitions." - ("SPG:" ^ (String.concat "\nSPG: " msgs)) - else - msg ("Processed multiple " ^ tp_msg ^ " from:") - (" " ^ (display_term raw) ^ ".") - | (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 - msg ("Loaded state " ^ path ^ ".") "" - | (te, _) -> - let ty = type_of_term tydecls te in - if xml_out then - "<speagram-result>\n" ^ - (display_term_xml te) ^ "\n\n" ^ (display_type_xml ty) ^ - "\n</speagram-result>" - else - "Result: " ^ - "{" ^ (display_term te) ^ " as " ^ (display_type ty) ^ "}" -;; - -exception FAILED_PARSE_OR_EXN of string;; - -let process_with_system_bs lp verbose s str fail xml_out bs = - 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 (); - flush stdout; - raise (FAILED_PARSE_OR_EXN msg)) - else - (s, [], msg) - | [x] -> - let te = normalise_with_sys s (Term (preprocess_name, [|x|])) in ( - match te with - Term (te_name, [|a|]) when te_name = exception_name -> - let msg = "SPG EXCEPTION:\n" ^ (display_term a) ^ "\n" in - if fail then raise (FAILED_PARSE_OR_EXN msg) else (s, [te], msg) - | _ -> - let Sys (_, tds, _, _, _) = s in - (update_on_term lp te s bs, [te], - message_for_term tds lp verbose xml_out (te, x)) ) - | ts -> - let msg = "AMBIGUOUS\n" ^ (terms_info verbose ts) in - if fail then - (if (not xml_out) then print_endline msg else (); - flush stdout; - raise (FAILED_PARSE_OR_EXN msg)) - else - (s, [], msg) -;; - - -(* --------------- THE BASIC SYSTEM ------------------ *) - -let basic_sdefs = [ - bit_sd; bit_0_cons_sd; bit_1_cons_sd; char_sd; char_cons_sd; term_type_sd; - list_sd; list_nil_sd; list_cons_sd; string_sd; string_cons_sd; - boolean_sd; boolean_true_sd; boolean_false_sd; ternary_truth_value_sd; - ternary_true_sd; ternary_unknown_sd; ternary_false_sd; - term_type_var_sd; term_type_cons_sd; term_type_fun_sd; - syntax_element_sd; syntax_element_str_sd; syntax_element_tp_sd; - syntax_element_list_sd; syntax_element_list_elem_sd; - syntax_element_list_cons_sd; syntax_definition_sd; syntax_definition_type_sd; - syntax_definition_fun_sd; syntax_definition_var_sd; - term_sd; term_var_cons_sd; term_term_cons_sd; - rewrite_rule_sd; rewrite_rule_cons_sd; - input_rewrite_rule_sd; let_be_sd; priority_input_rewrite_rule_sd; - 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; - 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] -;; - -let basic_rules = flatten [ - brackets_rules; verbatim_rules; if_then_else_rules; preprocess_rules; - additional_xslt_rules; string_quote_rules];; (* eq_bool_rules *) - -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 updr sys rr = update_on_rr rr sys in - 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 -;; - - -(* TESTS * - let s1 = "function *new* syntax definition as syntax definition";; - let (sys1, msg) = process_with_system basic_system s1;; - let s2 = "[]";; - let (sys2, msg) = process_with_system sys1 s2;; -*) - - - -(* -------- COMPLETE ONE STEP OF A SHELL ------- *) - - -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 - if (c = '.' || c = ';') && (not (prev = '&')) && (not (amp = 5)) && - (not (amp = 4 && c=';')) && (not (quot = 5 && c=';')) && - (not (apos = 5 && c=';')) && (not (lt = 3 && c=';')) && - (not (gt = 3 && c=';')) then - (String.make 1 prev) - else (* amp, quot, ... = number of chars in & ... seen *) - let new_amp = - if amp = 0 && c = '&' then 1 else - if amp = 1 && c = 'a' then 2 else - if amp = 2 && c = 'm' then 3 else - if amp = 3 && c = 'p' then 4 else - if amp = 4 && c = ';' then 5 else 0 in - let new_quot = - if quot = 0 && c = '&' then 1 else - if quot = 1 && c = 'q' then 2 else - if quot = 2 && c = 'u' then 3 else - if quot = 3 && c = 'o' then 4 else - if quot = 4 && c = 't' then 5 else - if quot = 5 && c = ';' then 6 else 0 in - let new_apos = - if apos = 0 && c = '&' then 1 else - if apos = 1 && c = 'a' then 2 else - if apos = 2 && c = 'p' then 3 else - if apos = 3 && c = 'o' then 4 else - if apos = 4 && c = 's' then 5 else - if apos = 5 && c = ';' then 6 else 0 in - let new_lt = - if lt = 0 && c = '&' then 1 else - if lt = 1 && c = 'l' then 2 else - if lt = 2 && c = 't' then 3 else - if lt = 3 && c = ';' then 4 else 0 in - let new_gt = - if gt = 0 && c = '&' then 1 else - if gt = 1 && c = 'g' then 2 else - if gt = 2 && c = 't' then 3 else - 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 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 - | w :: _ -> - if String.length w < 2 then false else - (w.[0] = '/') && (w.[1] = '/') -;; - -let rec strip_first_space s = - if not (s = "") then - if (s.[0] = ' ') || (s.[0] = '\t') || (s.[0] = '\n') || (s.[0] = '\r') then - strip_first_space (String.sub s 1 ((String.length s) - 1)) - else - s - else "" -;; - -let rec count_occurences s i c = - if i >= String.length s then 0 else - if s.[i] = c then (count_occurences s (i+1) c) + 1 else - count_occurences s (i+1) c -;; - -let step_shell lp verb cmode sys channel should_fail xml_out parsed = - 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 - 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 ^ ".") - else - print_endline (s ^ "."); - flush stdout; - sys - ) - else - (print_endline ("SPG: " ^ s ^ "\n"); flush stdout; sys) - else ( - print_endline ("<speagram-comment>" ^ - (make_xml_compatible (s ^ ".")) ^ "</speagram-comment>"); - sys - ) - else if not (s = "") then - ( - 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 - (parsed := (nparsed @ !parsed); - if cmode then - if (count_occurences s_read 0 '\n') > 1 then - print_endline ("\n" ^ msg) - else - print_endline msg - else - print_endline (msg ^ "\n"); - flush stdout; - nsys - ) - ) - else sys -;; - Deleted: trunk/Toss/Term/System.mli =================================================================== --- trunk/Toss/Language/System.mli 2012-05-19 21:37:16 UTC (rev 1710) +++ trunk/Toss/Term/System.mli 2012-05-20 12:31:12 UTC (rev 1711) @@ -1,37 +0,0 @@ -(* Signature for System module. *) - -open Type;; -open SyntaxDef;; - -type spg_system;; - -val syntax_defs_of_sys : spg_system -> (syntax_def * string) list;; - - -(* -------------- OPERATING WITH THE SYSTEM ----------------- *) - -val update_on_term : string -> Term.term -> spg_system -> spg_system -> - spg_system;; - -val normalise_with_sys : spg_system -> Term.term -> Term.term;; - -val parse_with_sys : spg_system -> string -> Term.term list;; -val parse_disambiguate_with_sys : - bool -> spg_system -> string -> Term.term list;; - -val message_for_term : (string, Type.term_type) Hashtbl.t -> string -> bool -> - bool -> Term.term * Term.term -> string;; - -exception FAILED_PARSE_OR_EXN of string;; - -val process_with_system : string -> bool -> spg_system -> string -> bool -> - bool -> spg_system * Term.term list * string;; - - -val basic_sdefs : syntax_def list;; -val basic_system : spg_system;; - -(* -------- COMPLETE ONE STEP OF A SHELL ------- *) - -val step_shell : string -> bool -> bool -> spg_system -> - in_channel -> bool -> bool -> Term.term list ref -> spg_system Copied: trunk/Toss/Term/TRS.ml (from rev 1710, trunk/Toss/Language/System.ml) =================================================================== --- trunk/Toss/Term/TRS.ml (rev 0) +++ trunk/Toss/Term/TRS.ml 2012-05-20 12:31:12 UTC (rev 1711) @@ -0,0 +1,616 @@ +(* The speagram system. *) + + +open List;; +open Str;; + +open TermType;; +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 -> false;; + +let decode_sd_opt te = + try Some (decode_syntax_definition te) with DECODE _ -> None +;; + +let decode_rr_opt te = + try Some (decode_rewrite_rule te) with DECODE _ -> None +;; + +let decode_irr_opt te = + try Some (decode_input_rewrite_rule te) with DECODE _ -> None +;; + +let decode_pirr_opt te = + 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 +;; + + +let msg_for_sels sels = + let i = ref 0 in + let msg = function + Str s -> "\"" ^ s ^ "\"" + | Tp _ -> (i := !i+1; "X_" ^ (string_of_int !i)) in + String.concat " " (map msg sels) +;; + +let recognize_list te = + if (te = code_list (fun x -> x) []) then ("", false) else + try let _ = decode_list decode_syntax_definition te in + ("syntax definitions", true) with + DECODE _ -> + try let _ = decode_list decode_priority_input_rewrite_rule te in + ("priority rewrite rules", false) with + 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) +;; + +let display_rr (l, r) = + let (ls, rs) = (display_term l, display_term r) in + if (String.length ls + String.length rs < 71) then + ls ^ " ---> " ^ rs + else + ls ^ " --->\n " ^ rs +;; + +let rec message_for_term tydecls k verbose xml_out in_pair = + let msg s1 s2 = + if xml_out then + "<speagram-message>\n" ^ + "<spg-msg-general>" ^ (make_xml_compatible s1) ^ "</spg-msg-general>\n" ^ + "<spg-msg-detail>" ^ (make_xml_compatible s2) ^ "</spg-msg-detail>\n" ^ + "</speagram-message>" + else s1 ^ "\n" ^ s2 in + match in_pair with + (te, _) when is_some (decode_sd_opt te) -> + msg (match decode_syntax_definition te with + SDtype (sels) -> "New class " ^ (msg_for_sels sels) ^ " declared." + | SDfun (sels, _) -> "New function " ^ (msg_for_sels sels) ^ " declared." + | SDvar (sels, _) -> "New variable " ^ (msg_for_sels sels) ^ " declared." + ) "" + | (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, raw) when is_some (decode_irr_opt te) -> ( + try + let rr = decode_input_rewrite_rule raw in + msg "New rewrite rule defined." (display_rr rr) + with + DECODE _ -> msg "New rewrite rule defined." (display_term raw) + ) + | (te, raw) when is_some (decode_pirr_opt te) -> ( + try + let rr = decode_priority_input_rewrite_rule te in + msg "New priority rewrite rule defined." (display_rr rr) + with + DECODE _ -> + msg "New priority rewrite rule defined." (display_term raw) + ) + | (te, raw) when not (recognize_list te = ("", false)) -> + if verbose then + let msgs = map (message_for_term tydecls k verbose false) + (decode_list (fun x -> (x, x)) te) in + msg "Processed multiple messages:" (String.concat "\n" msgs) + else + let (tp_msg , is_syn_def_lst) = recognize_list te in + if is_syn_def_lst then + let msgs = map (message_for_term tydecls k verbose false) + (decode_list (fun x -> (x, x)) te) in + msg "Processed multiple definitions." + ("SPG:" ^ (String.concat "\nSPG: " msgs)) + else + msg ("Processed multiple " ^ tp_msg ^ " from:") + (" " ^ (display_term raw) ^ ".") + | (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 + msg ("Loaded state " ^ path ^ ".") "" + | (te, _) -> + let ty = type_of_term tydecls te in + if xml_out then + "<speagram-result>\n" ^ + (display_term_xml te) ^ "\n\n" ^ (display_type_xml ty) ^ + "\n</speagram-result>" + else + "Result: " ^ + "{" ^ (display_term te) ^ " as " ^ (display_type ty) ^ "}" +;; + +exception FAILED_PARSE_OR_EXN of string;; + +let process_with_system_bs lp verbose s str fail xml_out bs = + 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 (); + flush stdout; + raise (FAILED_PARSE_OR_EXN msg)) + else + (s, [], msg) + | [x] -> + let te = normalise_with_sys s (Term (preprocess_name, [|x|])) in ( + match te with + Term (te_name, [|a|]) when te_name = exception_name -> + let msg = "SPG EXCEPTION:\n" ^ (display_term a) ^ "\n" in + if fail then raise (FAILED_PARSE_OR_EXN msg) else (s, [te], msg) + | _ -> + let Sys (_, tds, _, _, _) = s in + (update_on_term lp te s bs, [te], + message_for_term tds lp verbose xml_out (te, x)) ) + | ts -> + let msg = "AMBIGUOUS\n" ^ (terms_info verbose ts) in + if fail then + (if (not xml_out) then print_endline msg else (); + flush stdout; + raise (FAILED_PARSE_OR_EXN msg)) + else + (s, [], msg) +;; + + +(* --------------- THE BASIC SYSTEM ------------------ *) + +let basic_sdefs = [ + bit_sd; bit_0_cons_sd; bit_1_cons_sd; char_sd; char_cons_sd; term_type_sd; + list_sd; list_nil_sd; list_cons_sd; string_sd; string_cons_sd; + boolean_sd; boolean_true_sd; boolean_false_sd; ternary_truth_value_sd; + ternary_true_sd; ternary_unknown_sd; ternary_false_sd; + term_type_var_sd; term_type_cons_sd; term_type_fun_sd; + syntax_element_sd; syntax_element_str_sd; syntax_element_tp_sd; + syntax_element_list_sd; syntax_element_list_elem_sd; + syntax_element_list_cons_sd; syntax_definition_sd; syntax_definition_type_sd; + syntax_definition_fun_sd; syntax_definition_var_sd; + term_sd; term_var_cons_sd; term_term_cons_sd; + rewrite_rule_sd; rewrite_rule_cons_sd; + input_rewrite_rule_sd; let_be_sd; priority_input_rewrite_rule_sd; + 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; + 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] +;; + +let basic_rules = flatten [ + brackets_rules; verbatim_rules; if_then_else_rules; preprocess_rules; + additional_xslt_rules; string_quote_rules];; (* eq_bool_rules *) + +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 updr sys rr = update_on_rr rr sys in + 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 +;; + + +(* TESTS * + let s1 = "function *new* syntax definition as syntax definition";; + le... [truncated message content] |
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-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Arena/TermTest.ml 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,147 +0,0 @@ -(* Test for terms and their behaviour. *) - -open OUnit -open Term - -let term_of_string s = - TermParser.parse_term Lexer.lex (Lexing.from_string s) - -let eqs_of_string s = - TermParser.parse_eqs Lexer.lex (Lexing.from_string s) - -let tyson_model_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)") - -let tests = "Term" >::: [ - "parse" >:: - (fun () -> - let s = "(x - 0.2) / (z * y - 3.)" in - assert_equal ~printer:(fun x->x) s (str (term_of_string s)); - - let t0s = ":f(a) + t" in - assert_equal ~printer:(fun x->x) t0s (str (term_of_string t0s)); - - let eqs = ":f(a)' = :f(a) + t" in - assert_equal ~printer:(fun x->x) eqs - (eq_str ~diff:true (eqs_of_string eqs)); - - ); - - "fprint" >:: - (fun () -> - let s = "(x - 0.2) / (z * y - 3.)" in - assert_equal ~printer:(fun x->x) s (sprint (term_of_string s)); - - let t0s = ":f(a) + t" in - assert_equal ~printer:(fun x->x) t0s (sprint (term_of_string t0s)); - - let eqs = ":f(a)' = :f(a) + t" in - assert_equal ~printer:(fun x->x) eqs - (sprint_eqs ~diff:true (eqs_of_string eqs)); - - ); - - "substitute" >:: - (fun () -> - let t0 = term_of_string ":f(a) + t" in - let t1 = subst [("t", (Const 2.))] t0 in - assert_equal ~printer:(fun x->x) ":f(a) + 2." (str t1); - - assert_equal ~printer:(fun x->x) "5." - (str (List.hd (subst_simp_f ["f", "a"] [Const 3.] [t1]))); - ); - - "subst names" >:: - (fun () -> - let t0 = term_of_string "-100 * :y(e1)" in - let t0s = term_of_string "-100 * :y(e2)" in - let t1 = term_of_string "100. * :y(e1)" in - let t1s = term_of_string "100. * :y(e2)" in - let eq = [(("y", "e1"), t0); (("y", "e2"), t1)] in - let eqs = [(("y", "e2"), t0s); (("y", "e1"), t1s)] in - assert_equal ~printer:(fun x->x) (eq_str eqs) - (eq_str (subst_names [("e1", "e2"); ("e2", "e1")] eq)) - ); - - "rk4" >:: - (fun () -> - let t0 = term_of_string ":f(a) + t" in - - assert_equal ~printer:(fun x->x) "0.005" - (String.sub (str (List.hd ( - rk4_step "t" (Const 0.) (Const 0.1) - [("f", "a"), t0] [Const 0.]))) 0 5); - - let eqs = eqs_of_string ":f(a)' = :f(a) + t" in - 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 = tyson_model_eqs () 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 eqs nsteps tstep = - AuxIO.print "(set-logic QF_NRA)\n"; - AuxIO.print "(set-info :source | generated symbolic RK4 in smt2 format |)\n"; - let init m = Array.to_list (Array.mapi (fun i _ -> - Term.Var (Printf.sprintf "v%iat%i" i m)) (Array.of_list eqs)) in - let print_var_str vs = AuxIO.print ("(declare-fun " ^ vs ^ " () Real)\n") in - let print_var v = print_var_str (Term.str_smt2 v) in - print_var_str "minusone"; - let fv = List.concat (List.map (fun (_, rhs) -> Term.vars rhs) eqs) in - List.iter print_var_str (Aux.unique_sorted fv); - let gen_init_vars i = List.iter print_var (init i) in - List.iter gen_init_vars (Aux.range (nsteps+1)); - AuxIO.print "(assert (= (+ minusone 1.) 0.))\n"; - let gen_step i = - let time_i = (float i) *. tstep in - let res_i = rk4_step "t" (Const time_i) (Const tstep) eqs (init i) in - List.iter2 (fun t v -> AuxIO.print ( - "(assert (= " ^ (Term.str_smt2 t) ^" "^ (Term.str_smt2 v) ^ "))\n" - )) (init (i+1)) res_i in - List.iter gen_step (Aux.range nsteps); - AuxIO.print "(check-sat)\n" - - -(* Calling the generation from bash. *) -let main () = - AuxIO.set_optimized_gc (); - let (eqs, nsteps, tstep) = (ref (tyson_model_eqs ()), ref 0, ref 0.005) in - let dbg_level i = (AuxIO.set_debug_level "Term" i) in - let opts = [ - ("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose"); - ("-d", Arg.Int (fun i -> dbg_level i), "set debug level"); - ("-eqs", Arg.String (fun s -> eqs := eqs_of_string s), "parse ODE system"); - ("-steps", Arg.Int (fun i -> nsteps := i), "number of steps to generate"); - ("-tstep", Arg.Float (fun f -> tstep := f), "time step (default 0.005)"); - ] in - Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following."; - if !nsteps <> 0 then ( - generate_rksymb !eqs !nsteps !tstep - ) else ignore (OUnit.run_test_tt ~verbose:true tests) - -let _ = AuxIO.run_if_target "TermTest" main Modified: trunk/Toss/Formula/Formula.ml =================================================================== --- trunk/Toss/Formula/Formula.ml 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Formula/Formula.ml 2012-05-19 21:37:16 UTC (rev 1710) @@ -402,6 +402,11 @@ if phi1 == phi2 then 0 else let (s1, s2) = (size phi1, size phi2) in if s1 <> s2 then s1 - s2 else rec_compare phi1 phi2 + +let compare_re re1 re2 = + if re1 == re2 then 0 else + let (s1, s2) = (size_real re1, size_real re2) in + if s1 <> s2 then s1 - s2 else rec_compare_re re1 re2 (* --------------- BASIC HELPER FUNCTIONS USED IN PARSER ------------------- *) @@ -591,3 +596,34 @@ syntax_ok ~sg ~fp ~pos phi && syntax_ok_re ~sg ~fp ~pos r | RLet (_, re, inre) -> (* FIXME!! stupid let-check for now *) syntax_ok_re ~sg ~fp ~pos re && syntax_ok_re ~sg ~fp ~pos inre + + +(* --- Runge - Kutta method for real-expr defined equation systems. --- *) + +let rec compile_re tv eqs = function + | Const c -> (fun _ _ -> c) + | RVar v -> (fun t _ -> if v = tv then t else failwith "non time var compile") + | 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 + (fun t a -> (cp t a) *. (cq t a))) + | re -> failwith ("compilation for " ^ real_str re ^ " not implemented yet") + +let compile tv eqs = + let lhs = fst (List.split eqs) in + let ceqs = Array.of_list (List.map (fun (_,t)-> compile_re tv lhs t) eqs) in + (fun t a -> Array.map (fun f -> f t a) ceqs) + +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 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/Formula/Formula.mli =================================================================== --- trunk/Toss/Formula/Formula.mli 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Formula/Formula.mli 2012-05-19 21:37:16 UTC (rev 1710) @@ -79,6 +79,7 @@ val size_real : ?acc : int -> real_expr -> int val compare : formula -> formula -> int +val compare_re : real_expr -> real_expr -> int val is_atom : formula -> bool val is_literal : formula -> bool @@ -135,3 +136,13 @@ val flatten_sort : formula -> formula val flatten_sort_re : real_expr -> real_expr + +(** {2 Runge - Kutta method for real-expr defined equation systems.} **) + +(** Compile eq_sys to function. *) +val compile : string -> eq_sys -> (float -> float array -> float array) + +(** 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 : float -> float -> (float -> float array -> float array) -> + float array -> float array Modified: trunk/Toss/Formula/FormulaParser.mly =================================================================== --- trunk/Toss/Formula/FormulaParser.mly 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Formula/FormulaParser.mly 2012-05-19 21:37:16 UTC (rev 1710) @@ -43,6 +43,7 @@ | INT { Const (float_of_int $1) } | FLOAT { Const ($1) } | COLON ID { RVar (":" ^ $2) } + | 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)) } | real_expr FLOAT { Plus ($1, Const $2) } /* in x-1, "-1" is int */ @@ -129,6 +130,9 @@ expr_eq_expr: /* only standard equations here for now (no differentials) */ | COLON ID OPEN ID CLOSE EQ real_expr { (($2, $4), $7) } | COLON ID OPEN INT CLOSE EQ real_expr { (($2, string_of_int $4), $7) } + | COLON ID OPEN ID CLOSE APOSTROPHE EQ real_expr { (($2, $4), $8) } + | COLON ID OPEN INT CLOSE APOSTROPHE EQ real_expr + { (($2, string_of_int $4), $8) } %public expr_eq_sys: | expr_eq_expr { [$1] } Modified: trunk/Toss/Formula/FormulaTest.ml =================================================================== --- trunk/Toss/Formula/FormulaTest.ml 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Formula/FormulaTest.ml 2012-05-19 21:37:16 UTC (rev 1710) @@ -4,6 +4,9 @@ let formula_of_string s = FormulaParser.parse_formula Lexer.lex (Lexing.from_string s) +let eqs_of_string s = + FormulaParser.parse_expr_eqs Lexer.lex (Lexing.from_string s) + let rel r i = Rel (r, Array.make i (`FO "x")) @@ -53,5 +56,30 @@ test_pp "(:x - (:y + :z) < 0)"; test_pp "(:x - :y + :z < 0)"; ); + + "rk4" >:: + (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 + assert_equal ~printer:(fun x -> x) "0.00517" + (float_arr_str 7 (rk4_step 0. 0.1 ceqs [| 0. |])); + + 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 + assert_equal ~printer:(fun x -> x) + "0.00110, 3.6e-10, 2.99999, -1.9991, 7.16443, -0.0008" + (float_arr_str 7 (rk4_step 0. 0.02 ceqs init)); + ); ] Modified: trunk/Toss/Language/BuiltinLang.ml =================================================================== --- trunk/Toss/Language/BuiltinLang.ml 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/BuiltinLang.ml 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,41 +1,8 @@ -(* - Speagram +(* Basic Built-in Language Syntax for 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. - - ------------------------------------------------------------ - - Basic Built-in Language Syntax for Speagram. - -*) - open Type;; open SyntaxDef;; -(* * #load "Type.cmo";; *) -(* * #load "SyntaxDef.cmo";; *) - (* ---------------- BASIC TYPES AND SYNTAX DEFS ----------------------- *) let bit_sd = SDtype [Str "bit"];; Modified: trunk/Toss/Language/BuiltinLang.mli =================================================================== --- trunk/Toss/Language/BuiltinLang.mli 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/BuiltinLang.mli 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,35 +1,5 @@ -(* - Speagram +(* Signature for Built-in Langauge Definitions. *) - 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. - - ------------------------------------------------------------ - - Signature for Built-in Langauge Definitions. - -*) - open SyntaxDef;; Modified: trunk/Toss/Language/Makefile =================================================================== --- trunk/Toss/Language/Makefile 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/Makefile 2012-05-19 21:37:16 UTC (rev 1710) @@ -27,10 +27,10 @@ OCAMLTOP = ocaml -I +camlp4 camlp4o.cma str.cma -OCAMLCARGS = -thread -I +camlp4 -pp "camlp4o" str.cma unix.cma threads.cma +OCAMLCARGS = -I +camlp4 -pp "camlp4o" str.cma unix.cma OCAMLC = ocamlc $(OCAMLCARGS) -OCAMLOPTARGS = -thread -I +camlp4 -pp "camlp4o" str.cmxa unix.cmxa threads.cmxa +OCAMLOPTARGS = -I +camlp4 -pp "camlp4o" str.cmxa unix.cmxa OCAMLOPT = ocamlopt $(OCAMLOPTARGS) @@ -100,11 +100,10 @@ Term.cmi Term.cmo Term.cmx \ ParseArc.cmi ParseArc.cmo ParseArc.cmx \ Rewriting.cmi Rewriting.cmo Rewriting.cmx \ - Normalisation.cmi Normalisation.cmo Normalisation.cmx \ System.cmi System.cmo System.cmx $(USEDOCAML) \ Type.cmx SyntaxDef.cmx BuiltinLang.cmx Term.cmx Rewriting.cmx \ - Normalisation.cmx ParseArc.cmx System.cmx speagram.ml -o speagram + ParseArc.cmx System.cmx speagram.ml -o speagram parsed: speagram Deleted: trunk/Toss/Language/Normalisation.ml =================================================================== --- trunk/Toss/Language/Normalisation.ml 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/Normalisation.ml 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,202 +0,0 @@ -(* - 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. - - ------------------------------------------------------------ - - Contains the functions responsible for rewriting and normalisation. - -*) - - -open List;; -open Str;; - -open Type;; -open SyntaxDef;; -open BuiltinLang;; -open Term;; -open Rewriting;; -(* * #load "Type.cmo";; *) -(* * #load "SyntaxDef.cmo";; *) -(* * #load "BuiltinLang.cmo";; *) -(* * #load "Term.cmo";; *) -(* * #load "Rewriting.cmo";; *) - - -(* -------------------------- NORMALISATION ------------------------ *) - - -let rec normalise_special_id_one name = function - Term (n, [|a|]) when n = name -> a - | Term (n, a) -> Term (n, Array.map (normalise_special_id_one name) a) - | Var (n, ty, d, a) -> - Var (n, ty, d, Array.map (normalise_special_id_one name) a) -;; -let rec normalise_special_id_all name = function - Term (n, [|a|]) when n = name -> normalise_special_id_all name a - | Term (n, a) -> Term (n, Array.map (normalise_special_id_all name) a) - | Var (n, ty, d, a) -> - Var (n, ty, d, Array.map (normalise_special_id_all name) a) -;; - -let normalise_brackets = normalise_special_id_all brackets_name;; -let normalise_verbatim = normalise_special_id_one verbatim_name;; - -let rec normalise_special rr_spec = function - Term (n, [|a|]) as te when n = verbatim_name -> te - | Term (n, a) when n.[0] = 'F' -> - let normalised = Term (n, Array.map (normalise_special rr_spec) a) in - rr_spec normalised - | Term (n, a) -> - Term (n, Array.map (normalise_special rr_spec) a) - | Var (n, ty, d, a) -> - Var (n, ty, d, Array.map (normalise_special rr_spec) a) -;; - -let cTHREAD_MAX = 2;; -let cMEM_USE_INCREASE_FACTOR = 128;; - -let rec basic_normalise_t_r rr rr_spec m lock th_no res te = - res := basic_normalise rr rr_spec m lock th_no te; -and basic_normalise_th rr rr_spec m lock th_no te = - let res = ref (0, Term ("", [||])) in - if !th_no < cTHREAD_MAX then ( - Mutex.lock lock; th_no := !th_no+1; Mutex.unlock lock; - let thread = - Thread.create (basic_normalise_t_r rr rr_spec m lock th_no res) te in - (Some (thread), res) - ) - else - (None, ref (basic_normalise rr rr_spec m lock th_no te)) -and basic_normalise_arr rr rr_spec m lock th_no = function - [||] -> (0, [||]) - | [|x|] -> - let (steps, res) = basic_normalise rr rr_spec m lock th_no x in - (steps, [|res|]) - | arr -> - let th_arr = - Array.map (basic_normalise_th rr rr_spec m lock th_no) arr in - let steps = ref 0 in - let res_arr = - Array.map (function - (Some (th), res) -> - (Thread.join th; - Mutex.lock lock; th_no := !th_no-1; Mutex.unlock lock; - steps := !steps + fst (!res); - snd (!res)) - | (None, res) -> - (steps := !steps + fst (!res); snd (!res)) - ) th_arr in - (!steps, res_arr) -and basic_normalise rr rr_spec m lock th_no = function - Term (n, [|Term (f, a); r|]) when n = let_major_be_name -> - let (steps_l, na) = basic_normalise_arr rr rr_spec m lock th_no a in - let (steps_r, rs) = basic_normalise rr rr_spec m lock th_no r in - (steps_l + steps_r, Term (n, [|Term (f, na); rs|])) - | Term (n, [|a|]) as te when n = verbatim_name -> (0, te) - | Term (nm, [|c; y; n|]) when nm = if_then_else_name -> - let (steps_c, norm_cond) = basic_normalise rr rr_spec m lock th_no c in - let norm_cond_te = Term (nm, [|norm_cond; y; n|]) in - let rewritten = rr norm_cond_te in - if (rewritten = norm_cond_te) then - (steps_c, Term (nm, [|norm_cond; normalise_special rr_spec y; - normalise_special rr_spec n|])) - else - let (steps, res) = basic_normalise rr rr_spec m lock th_no rewritten in - (steps + steps_c + 1, res) - | Term (n, a) when n.[0] = 'F' -> ( - let (prev_steps, prev_res) = - basic_normalise_arr rr rr_spec m lock th_no a in - let nmlized = Term (n, prev_res) in - let found = ( - Mutex.lock lock; - let res = try - Some (TermHashtbl.find m nmlized) - with - Not_found -> None in - Mutex.unlock lock; - res - ) in - match found with Some (r) -> (prev_steps, r) | None -> - let rewritten = rr nmlized in - if rewritten = nmlized then - (prev_steps, rewritten) - else - let (steps, res) = basic_normalise rr rr_spec m lock th_no rewritten in - let memory_size = TermHashtbl.length m in - let threshold = (memory_size / cMEM_USE_INCREASE_FACTOR) + 1 in - let size_addon = min (size_up_to 256 nmlized) threshold in - if steps > threshold + size_addon then - (Mutex.lock lock; - TermHashtbl.add m nmlized res; - Mutex.unlock lock; - (0, res)) - else - (prev_steps + steps + 1, res) - ) - | Term (n, a) -> - let (steps, res) = basic_normalise_arr rr rr_spec m lock th_no a in - (steps, Term (n, res)) - | Var (n, ty, d, a) -> - let (steps, res) = basic_normalise_arr rr rr_spec m lock th_no a in - (steps, Var (n, ty, d, res)) -;; - - -let normalise mem rules is_special rewrite_special inp_term = - let term = normalise_brackets inp_term in - let rr = function - Term (n, a) as te when (is_special n) -> - rewrite_special (normalise_verbatim te) - | Term (n, a) as te -> ( - try - rewrite (Hashtbl.find rules n) te - with - Not_found -> te - ) - | te -> te in - let (_, normalised) = - basic_normalise rr rewrite_special mem (Mutex.create ()) (ref 1) term in - normalise_verbatim normalised -;; - - -(* TESTS * - let var_x_b = Var ("x", boolean_tp, 0, [||]);; - let var_y_b = Var ("y", boolean_tp, 0, [||]);; - let rr1 = - (Term ("Fand", [|code_bool true; code_bool true|]), code_bool true);; - let rr2 = (Term ("Fand", [|var_x_b; var_y_b|]), code_bool false);; - let rrs = [("Fand", [rr1; rr2])];; - - let t1 = Term ("Fand", [|code_bool true; code_bool true|]);; - let t2 = Term ("Fand", [|code_bool true; t1|]);; - let t3 = Term ("Fand", [|var_x_b; t1|]);; - let t4 = Term (if_then_else_name, [|var_x_b; t1; t1|]);; - let t5 = Term ("Ckot", [|var_x_b; t1; t1|]);; - let _ = map (normalise rrs (fun x -> false) (fun x -> x)) [t2; t3; t4; t5];; -*) - Deleted: trunk/Toss/Language/Normalisation.mli =================================================================== --- trunk/Toss/Language/Normalisation.mli 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/Normalisation.mli 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,41 +0,0 @@ -(* - 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. - - ------------------------------------------------------------ - - Signature for Rewriting module. - -*) - - -(* ----------------------- NORMALISATION ---------------------------- *) - -val normalise_brackets : Term.term -> Term.term;; - -val normalise : (Term.term Term.TermHashtbl.t) -> (* memory *) - (string, Rewriting.rrules_set) Hashtbl.t -> (* rules *) - (string -> bool) -> (Term.term -> Term.term) -> Term.term -> Term.term;; - Modified: trunk/Toss/Language/ParseArc.ml =================================================================== --- trunk/Toss/Language/ParseArc.ml 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/ParseArc.ml 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,37 +1,7 @@ -(* - Speagram +(* Contains the bottom-up chart-based parser that uses syntax definitions + and checks if terms are well-typed when closing arcs. *) - 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. - - ------------------------------------------------------------ - - Contains the bottom-up chart-based parser that uses syntax definitions - and checks if terms are well-typed when closing arcs. - -*) - - open List;; open Str;; Modified: trunk/Toss/Language/ParseArc.mli =================================================================== --- trunk/Toss/Language/ParseArc.mli 2012-05-18 21:22:13 UTC (rev 1709) +++ trunk/Toss/Language/ParseArc.mli 2012-05-19 21:37:16 UTC (rev 1710) @@ -1,35 +1,5 @@ -(* - Speagram +(* Signature for Parser module. *) - 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 DAMAGE... [truncated message content] |
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-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:\x81GwHs\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\xB2nc\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\xA3F\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\xDCF\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-12 20:29:43
|
Revision: 1707 http://toss.svn.sourceforge.net/toss/?rev=1707&view=rev Author: lukstafi Date: 2012-05-12 20:29:37 +0000 (Sat, 12 May 2012) Log Message: ----------- Minor comment fix to last commit. Modified Paths: -------------- trunk/Toss/Makefile Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2012-05-12 20:20:08 UTC (rev 1706) +++ trunk/Toss/Makefile 2012-05-12 20:29:37 UTC (rev 1707) @@ -100,7 +100,6 @@ # -------- MAIN OCAMLBUILD PART -------- -# TODO: Hard-coded path to js_of_ocaml. OCB_LFLAG=-lflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g OCB_CFLAG=-cflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g OCB_LIB=-libs unix This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2012-05-12 20:20:14
|
Revision: 1706 http://toss.svn.sourceforge.net/toss/?rev=1706&view=rev Author: lukstafi Date: 2012-05-12 20:20:08 +0000 (Sat, 12 May 2012) Log Message: ----------- Minor change: removing hard-coded paths (works after properly installing js-of-ocaml). Modified Paths: -------------- trunk/Toss/Makefile Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2012-05-11 22:17:01 UTC (rev 1705) +++ trunk/Toss/Makefile 2012-05-12 20:20:08 UTC (rev 1706) @@ -101,12 +101,12 @@ # -------- MAIN OCAMLBUILD PART -------- # TODO: Hard-coded path to js_of_ocaml. -OCB_LFLAG=-lflags -I,/usr/local/lib/ocaml/3.12.0/js_of_ocaml,-I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g -OCB_CFLAG=-cflags -I,/usr/local/lib/ocaml/3.12.0/js_of_ocaml,-I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g +OCB_LFLAG=-lflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g +OCB_CFLAG=-cflags -I,+js_of_ocaml,-I,+site-lib/js_of_ocaml,-g OCB_LIB=-libs unix OCB_LIBJS=-libs js_of_ocaml -OCB_PP=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo" -OCB_PPJS=-pp "camlp4o -unsafe -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo" +OCB_PP=-pp "camlp4o -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo" +OCB_PPJS=-pp "camlp4o -unsafe -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo" OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \ -ocamlopt "ocamlopt -inline 10" $(OCB_PP) \ $(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2012-05-11 22:17:08
|
Revision: 1705 http://toss.svn.sourceforge.net/toss/?rev=1705&view=rev Author: lukaszkaiser Date: 2012-05-11 22:17:01 +0000 (Fri, 11 May 2012) Log Message: ----------- Generate RK steps in smt2 format from TermTest. Modified Paths: -------------- trunk/Toss/Arena/Term.ml trunk/Toss/Arena/Term.mli trunk/Toss/Arena/TermTest.ml Modified: trunk/Toss/Arena/Term.ml =================================================================== --- trunk/Toss/Arena/Term.ml 2012-05-10 22:22:09 UTC (rev 1704) +++ trunk/Toss/Arena/Term.ml 2012-05-11 22:17:01 UTC (rev 1705) @@ -32,46 +32,63 @@ | _ -> 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 ?(prec=0) ppf = function +let rec fprint ?(smt2=false) ?(prec=0) ppf = function | Var s -> Format.pp_print_string ppf s - | FVar (f, a) -> Format.fprintf ppf ":%s(%s)" f a - | Const n -> Format.fprintf ppf "%F" n + | 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 - Format.fprintf ppf "@[<1>%s%a@ *@ %a%s@]" lb - (fprint ~prec:2) p (fprint ~prec:2) q rb - | Plus (p, Times (Const c, q)) when c = -1. -> - let lb, rb = - if prec > 0 then "(", ")" else "", "" in + 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 ~prec:0) p (fprint ~prec:1) q rb - | Plus (p, Const c) when c < 0. -> + (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 ~prec:0) p (fprint ~prec:1) (Const (-. c)) rb + (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:1) (Const (-. c)) rb | Plus (p, q) -> let lb, rb = if prec > 0 then "(", ")" else "", "" in - Format.fprintf ppf "@[<1>%s%a@ +@ %a%s@]" lb - (fprint ~prec:0) p (fprint ~prec:0) q rb + 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 - Format.fprintf ppf "@[<1>%s%a@ /@ %a%s@]" lb - (fprint ~prec:2) p (fprint ~prec:3) q rb + 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 ~prec:0) t in + 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 Modified: trunk/Toss/Arena/Term.mli =================================================================== --- trunk/Toss/Arena/Term.mli 2012-05-10 22:22:09 UTC (rev 1704) +++ trunk/Toss/Arena/Term.mli 2012-05-11 22:17:01 UTC (rev 1705) @@ -12,27 +12,32 @@ 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. *) +(** 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 : - ?prec:int -> Format.formatter -> term -> unit -val print : term -> unit -val sprint : term -> string - -val fprint_eqs : ?diff : bool -> - Format.formatter -> eq_sys -> unit +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 Modified: trunk/Toss/Arena/TermTest.ml =================================================================== --- trunk/Toss/Arena/TermTest.ml 2012-05-10 22:22:09 UTC (rev 1704) +++ trunk/Toss/Arena/TermTest.ml 2012-05-11 22:17:01 UTC (rev 1705) @@ -9,6 +9,15 @@ let eqs_of_string s = TermParser.parse_eqs Lexer.lex (Lexing.from_string s) +let tyson_model_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)") let tests = "Term" >::: [ "parse" >:: @@ -79,15 +88,7 @@ "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 tyson = tyson_model_eqs () 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 @@ -98,15 +99,49 @@ "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); - *) ); ] + + +(* Generate RK4 equations symbolically for [eq], step [n]. *) +let generate_rksymb eqs nsteps tstep = + AuxIO.print "(set-logic QF_NRA)\n"; + AuxIO.print "(set-info :source | generated symbolic RK4 in smt2 format |)\n"; + let init m = Array.to_list (Array.mapi (fun i _ -> + Term.Var (Printf.sprintf "v%iat%i" i m)) (Array.of_list eqs)) in + let print_var_str vs = AuxIO.print ("(declare-fun " ^ vs ^ " () Real)\n") in + let print_var v = print_var_str (Term.str_smt2 v) in + print_var_str "minusone"; + let fv = List.concat (List.map (fun (_, rhs) -> Term.vars rhs) eqs) in + List.iter print_var_str (Aux.unique_sorted fv); + let gen_init_vars i = List.iter print_var (init i) in + List.iter gen_init_vars (Aux.range (nsteps+1)); + AuxIO.print "(assert (= (+ minusone 1.) 0.))\n"; + let gen_step i = + let time_i = (float i) *. tstep in + let res_i = rk4_step "t" (Const time_i) (Const tstep) eqs (init i) in + List.iter2 (fun t v -> AuxIO.print ( + "(assert (= " ^ (Term.str_smt2 t) ^" "^ (Term.str_smt2 v) ^ "))\n" + )) (init (i+1)) res_i in + List.iter gen_step (Aux.range nsteps); + AuxIO.print "(check-sat)\n" + + +(* Calling the generation from bash. *) +let main () = + AuxIO.set_optimized_gc (); + let (eqs, nsteps, tstep) = (ref (tyson_model_eqs ()), ref 0, ref 0.005) in + let dbg_level i = (AuxIO.set_debug_level "Term" i) in + let opts = [ + ("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose"); + ("-d", Arg.Int (fun i -> dbg_level i), "set debug level"); + ("-eqs", Arg.String (fun s -> eqs := eqs_of_string s), "parse ODE system"); + ("-steps", Arg.Int (fun i -> nsteps := i), "number of steps to generate"); + ("-tstep", Arg.Float (fun f -> tstep := f), "time step (default 0.005)"); + ] in + Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following."; + if !nsteps <> 0 then ( + generate_rksymb !eqs !nsteps !tstep + ) else ignore (OUnit.run_test_tt ~verbose:true tests) + +let _ = AuxIO.run_if_target "TermTest" main 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 then -1 else 1 | v :: vs when v = y -> if List.mem x vs then 1 else -1 - | v :: vs -> cmp vs - in - if x = y then 0 else cmp prio_list + | v :: vs -> cmp vs in + if x = y then 0 else cmp prio_list (* Make an ordered polynomial from [p] with [prio_list] order on variables. *) -let make_ordered prio_list p = +let make_ordered ?(use_num=true) prio_list p = let inc_cmp x y = (-1) * (compare prio_list x y) in let ord_vars = List.sort inc_cmp (vars p) in - make_ordered_poly ord_vars p + make_ordered_poly use_num ord_vars p (* Make ordered polynomials from [ps] with [prio_list] order on variables. *) let make_ordered_list prio_list ps = let vars = vars_list ps in let ord_vars = List.sort (fun x y -> (-1) * (compare prio_list x y)) vars in - List.rev_map (make_ordered_poly ord_vars) ps + List.rev_map (make_ordered_poly true ord_vars) ps (* Make ordered polynomials from first components of [ps], [prio_list] order. *) let make_ordered_pair_list prio_list ps = let vars = List.fold_left (fun vs (p, _) -> combine vs (vars p)) [] ps in let ord_vars = List.sort (fun x y -> (-1) * (compare prio_list x y)) vars in - List.rev_map (fun (p, x) -> (make_ordered_poly ord_vars p, x)) ps + List.rev_map (fun (p, x) -> (make_ordered_poly true ord_vars p, x)) ps Modified: trunk/Toss/Solver/RealQuantElim/Poly.mli =================================================================== --- trunk/Toss/Solver/RealQuantElim/Poly.mli 2012-05-09 19:41:58 UTC (rev 1703) +++ trunk/Toss/Solver/RealQuantElim/Poly.mli 2012-05-10 22:22:09 UTC (rev 1704) @@ -43,7 +43,8 @@ (** Make an ordered polynomial from [p] with [prio_list] order on variables,i.e. 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.*) -val make_ordered : string list -> polynomial -> OrderedPoly.polynomial +val make_ordered : ?use_num: bool -> + string list -> polynomial -> OrderedPoly.polynomial (** Make ordered polynomials from [ps] with [prio_list] order on variables. *) val make_ordered_list : string list -> polynomial list -> Copied: trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss (from rev 1703, trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss) =================================================================== --- trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss (rev 0) +++ trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss 2012-05-10 22:22:09 UTC (rev 1704) @@ -0,0 +1,75 @@ +PLAYERS 1, 2 + +RULE k1: + [ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ] + dynamics + :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)' = -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)' = -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)' = -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)' = -k6 * :y(e1); + :y(e2)' = k6 * :y(e1); + :y(e3)' = k6 * :y(e1) + +RULE k7: + [ e1 | CycP1(e1) | ] -> [ e1 | CycP1(e1) | ] + dynamics + :y(e1)' = -k7 * :y(e1) + +RULE k8: + [ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ] -> [ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ] + dynamics + :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)' = -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 : 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 | 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 } ] Deleted: trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss =================================================================== --- trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-09 19:41:58 UTC (rev 1703) +++ trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-10 22:22:09 UTC (rev 1704) @@ -1,75 +0,0 @@ -PLAYERS 1, 2 - -RULE k1: - [ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ] - dynamics - :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)' = -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)' = -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)' = -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)' = -k6 * :y(e1); - :y(e2)' = k6 * :y(e1); - :y(e3)' = k6 * :y(e1) - -RULE k7: - [ e1 | CycP1(e1) | ] -> [ e1 | CycP1(e1) | ] - dynamics - :y(e1)' = -k7 * :y(e1) - -RULE k8: - [ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ] -> [ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ] - dynamics - :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)' = -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 : 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 | 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-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-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 ----------------------------- *) type term = - Var of string + | Var of string | FVar of string * string | Const of float | Times of term * term @@ -16,7 +16,20 @@ 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 + (* ------------------------ PRINTING FUNCTION ------------------------------- *) (* Bracket-savvy precedences: + 0, - 1, * 2, / 3 *) @@ -52,7 +65,7 @@ let str = sprint (* Print an equation system. *) -let fprint_eqs ?(diff=false) ppf eqs = +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@]@]" @@ -68,31 +81,31 @@ (* Basic simplification, reduces constant terms to floats. *) let rec simp_const = function - Var s -> Var s + | 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 - (Const n, Const m) -> Const (n *. m) - | _ -> Times (p, q) - ) + match (simp_const p, simp_const q) with + | (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) + ) | Div (p, q) -> - match (simp_const p, simp_const q) with - (Const n, Const m) -> Const (n /. m) - | _ -> Div (p, q) + match (simp_const p, simp_const q) with + | (Const n, Const m) -> Const (n /. m) + | _ -> Div (p, q) (* 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 ^ ")") + | 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 @@ -110,34 +123,30 @@ (* ------------------ SUBSTITUTION FOR VARIABLES --------------------------- *) -(* Substitute term [t] for variable [v] in the given term. *) -let rec subst (v, t) = function - Var s when s = v -> t - | Var _ | FVar _ | Const _ as p -> p - | Plus (p, q) -> Plus (subst (v, t) p, subst (v, t) q) - | Times (p, q) -> Times (subst (v, t) p, subst (v, t) q) - | Div (p, q) -> Div (subst (v, t) p, subst (v, t) q) +(* 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) -let subst_list l t = List.fold_left (fun t s -> subst s t) t l - (* Substitute [vals] for [vars] in [terms] and simplify. *) let subst_simp vars vals terms = - List.map (fun t -> simp_const (subst_list (List.combine vars vals) t)) terms + List.map (fun t -> simp_const (subst (List.combine vars vals) t)) terms -(* Substitute term [t] for function variable [f, a] in the given term. *) -let rec subst_f ((f, a) as v, t) = function - FVar (g, b) when g = f && b = a -> t - | FVar _ | Var _ | Const _ as p -> p - | Plus (p, q) -> Plus (subst_f (v, t) p, subst_f (v, t) q) - | Times (p, q) -> Times (subst_f (v, t) p, subst_f (v, t) q) - | Div (p, q) -> Div (subst_f (v, t) p, subst_f (v, t) q) +(* 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) -let subst_list_f l t = List.fold_left (fun t s -> subst_f s t) t l - (* Substitute [vals] for function [vars] in [terms] and simplify. *) let subst_simp_f vars vals terms = - List.map (fun t -> simp_const (subst_list_f (List.combine vars vals) t)) 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 = @@ -145,7 +154,15 @@ (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 + (* ---------------- RUNGE - KUTTA METHOD FOR TERM EQUATIONS ---------------- *) (* Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand Modified: trunk/Toss/Arena/Term.mli =================================================================== --- trunk/Toss/Arena/Term.mli 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Arena/Term.mli 2012-05-08 23:30:19 UTC (rev 1702) @@ -3,7 +3,7 @@ (** {2 Basic Type Definition.} *) type term = - Var of string + | Var of string | FVar of string * string | Const of float | Times of term * term @@ -12,6 +12,7 @@ type eq_sys = ((string * string) * term) list +val compare : term -> term -> int (** {2 Basic functions.} *) @@ -59,14 +60,14 @@ (** {2 Substitution for variables.} *) -(** Substitute term [t] for variable [v] in the given term. *) -val subst : string * term -> term -> term +(** 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 term [t] for function variable [f, a] in the given term. *) -val subst_f : (string * string) * term -> term -> term +(** 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 @@ -75,7 +76,10 @@ 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} *) Modified: trunk/Toss/Arena/TermTest.ml =================================================================== --- trunk/Toss/Arena/TermTest.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Arena/TermTest.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -42,13 +42,25 @@ "substitute" >:: (fun () -> let t0 = term_of_string ":f(a) + t" in - let t1 = subst ("t", (Const 2.)) t0 in + let t1 = subst [("t", (Const 2.))] t0 in assert_equal ~printer:(fun x->x) ":f(a) + 2." (str t1); assert_equal ~printer:(fun x->x) "5." (str (List.hd (subst_simp_f ["f", "a"] [Const 3.] [t1]))); ); + "subst names" >:: + (fun () -> + let t0 = term_of_string "-100 * :y(e1)" in + let t0s = term_of_string "-100 * :y(e2)" in + let t1 = term_of_string "100. * :y(e1)" in + let t1s = term_of_string "100. * :y(e2)" in + let eq = [(("y", "e1"), t0); (("y", "e2"), t1)] in + let eqs = [(("y", "e2"), t0s); (("y", "e1"), t1s)] in + assert_equal ~printer:(fun x->x) (eq_str eqs) + (eq_str (subst_names [("e1", "e2"); ("e2", "e1")] eq)) + ); + "rk4" >:: (fun () -> let t0 = term_of_string ":f(a) + t" in Modified: trunk/Toss/Client/JsHandler.ml =================================================================== --- trunk/Toss/Client/JsHandler.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Client/JsHandler.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -206,7 +206,7 @@ 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 + (fst game.Arena.graph.(state.Arena.cur_loc)) in let result = jsnew js_object () in Array.iter (fun (i, payoff) -> Modified: trunk/Toss/Formula/Lexer.mll =================================================================== --- trunk/Toss/Formula/Lexer.mll 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Formula/Lexer.mll 2012-05-08 23:30:19 UTC (rev 1702) @@ -82,6 +82,7 @@ | PLAYER_MOD | PLAYERS_MOD | CURRENT + | UNIVERSAL | RULE_SPEC | STATE_SPEC | CLASS @@ -225,6 +226,7 @@ | "PLAYER" { PLAYER_MOD } | "PLAYERS" { PLAYERS_MOD } | "CURRENT" { CURRENT } + | "UNIVERSAL" { UNIVERSAL } | "RULE" { RULE_SPEC } | "STATE" { STATE_SPEC } | "class" { CLASS } Modified: trunk/Toss/Formula/Tokens.mly =================================================================== --- trunk/Toss/Formula/Tokens.mly 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Formula/Tokens.mly 2012-05-08 23:30:19 UTC (rev 1702) @@ -11,7 +11,7 @@ %token WITH EMB PRE BEFORE INV POST UPDATE DYNAMICS TRUE FALSE ASSOC COND PAYOFF %token MOVES MATCH ADD_CMD DEL_CMD GET_CMD SET_CMD LET_CMD START %token ELEM_MOD ELEMS_MOD REL_MOD RELS_MOD ALLOF_MOD SIG_MOD FUN_MOD DATA_MOD LOC_MOD TIMEOUT_MOD TIME_MOD PLAYER_MOD PLAYERS_MOD -%token CURRENT RULE_SPEC STATE_SPEC CLASS LFP GFP EOF +%token CURRENT UNIVERSAL RULE_SPEC STATE_SPEC CLASS LFP GFP EOF /* List in order of increasing precedence. */ %nonassoc LET_CMD Modified: trunk/Toss/GGP/TranslateGame.ml =================================================================== --- trunk/Toss/GGP/TranslateGame.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/GGP/TranslateGame.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -2956,7 +2956,7 @@ let game = { Arena.rules = rules; patterns = []; - graph = graph; + graph = Array.map (fun l -> l, []) graph; num_players = List.length player_names; player_names = player_names; data = []; @@ -3068,7 +3068,7 @@ let translate_incoming_move_turnbased gdl state actions noops = let loc = (snd state).Arena.cur_loc in let actions = Array.of_list actions in - let location = (fst state).Arena.graph.(loc) in + let location = fst (fst state).Arena.graph.(loc) in let loc_player = Aux.array_argfind (fun l -> l.Arena.moves <> []) location in let move = actions.(loc_player) in @@ -3110,7 +3110,7 @@ rules have been applied, the server should apply the environment rule. *) let translate_incoming_move_concurrent gdl (game,state as gstate) actions = (* there is only location 0; Environment is not among [actions] *) - let loc = game.Arena.graph.(0) in + let loc = fst game.Arena.graph.(0) in let actions = Array.of_list actions in (* let location = state.Arena.graph.(0) in *) let struc = state.Arena.struc in Modified: trunk/Toss/Play/GameTree.ml =================================================================== --- trunk/Toss/Play/GameTree.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Play/GameTree.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -1,7 +1,7 @@ (* Game Tree used for choosing moves. *) (* TODO; FIXME; THIS IS A STUB, TRUE CONCURRENCY SUPPORT NEEDED. *) -let moving_player = Aux.array_argfind (fun l -> l.Arena.moves <> []) +let moving_player (a, _) = Aux.array_argfind (fun l -> l.Arena.moves <> []) a let parallel_toss = ref (0, "localhost") @@ -191,7 +191,7 @@ let info_terminal_f f depth game state player leaf_info = let calc re = Solver.M.get_real_val re state.Arena.struc in let payoff_terms = Array.map (fun l -> l.Arena.payoff) - game.Arena.graph.(state.Arena.cur_loc) in + (fst game.Arena.graph.(state.Arena.cur_loc)) in let payoffs = Array.map calc payoff_terms in { payoffs = payoffs; heurs_t = leaf_info.heurs ; info_t = f depth game state } Modified: trunk/Toss/Play/GameTreeTest.ml =================================================================== --- trunk/Toss/Play/GameTreeTest.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Play/GameTreeTest.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -61,7 +61,7 @@ let u = GameTree.unfold g h i_l i_n ch t in let moving_player = Aux.array_argfind (fun l -> l.Arena.moves <> []) in assert_equal ~printer:(fun x -> string_of_int x) (GameTree.player u) - (moving_player g.Arena.graph.((GameTree.state u).Arena.cur_loc)); + (moving_player (fst g.Arena.graph.((GameTree.state u).Arena.cur_loc))); ); ] Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Play/Heuristic.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -1014,7 +1014,7 @@ let array_plus ar = Array.fold_right (fun x y->Plus (x, y)) ar (Const 0.) in let all_payoffs = - array_plus (Array.map (fun loc -> + array_plus (Array.map (fun (loc, _) -> array_plus (Array.map (fun l -> l.Arena.payoff) loc)) graph) in let posi_poff_rels, nega_poff_rels = FormulaOps.rels_signs_expr all_payoffs in @@ -1045,7 +1045,7 @@ Some (DiscreteRule.fluent_preconds drules signat posi_frels nega_frels indef_frels) else None in - Array.mapi (fun i node -> + Array.mapi (fun i (node, _) -> let res = Array.map (fun payoff -> LOG 2 "default_heuristic: Computing for loc %d" i; @@ -1132,6 +1132,6 @@ (i+1, Formula.Plus (pat, h)) in snd (List.fold_left add_pat (0, Formula.Const 0.) l.Arena.heur) in try - let res = Array.map (fun a-> Array.map pl_heur a) game.Arena.graph in + let res = Array.map (fun (a,_) -> Array.map pl_heur a) game.Arena.graph in res with Not_found -> default_heuristic ~struc:state.Arena.struc game Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2012-05-06 22:17:46 UTC (rev 1701) +++ trunk/Toss/Server/Server.ml 2012-05-08 23:30:19 UTC (rev 1702) @@ -350,7 +350,7 @@ Solver.eval_counter := 0; done; let payoffs = Array.map (fun l -> l.Arena.payoff) - game.Arena.graph.(!cur_state.Arena.cur_loc) in + (fst game.Arena.graph.(!cur_state.Arena.cur_loc)) in let payoff = Array.map (fun p -> Solver.M.get_real_val p (!cur_state).Arena.struc) payoffs in Printf.printf "Game payoffs %f, %f\n%!" payoff.(0) payoff.(1) Added: trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss =================================================================== --- trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss (rev 0) +++ trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-08 23:30:19 UTC (rev 1702) @@ -0,0 +1,67 @@ +PLAYERS 1, 2 + +RULE k1: + [ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ] + dynamics + :y(e1)' = 0.015 + +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) + +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) + +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) + +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) + +RULE k7: + [ e1 | CycP1(e1) | ] -> [ e1 | CycP1(e1) | ] + dynamics + :y(e1)' = -0.6 * :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) + +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) + +RULE Move: + [ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ] + +LOC 0 { + PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 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 } ] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
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-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 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="40" cy="540" r="23.714285714285715" id="pred_a1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="111.42857142857143" cy="540" r="23.714285714285715" id="pred_b1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="182.85714285714286" cy="540" r="23.714285714285715" id="pred_c1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="254.28571428571428" cy="540" r="23.714285714285715" id="pred_d1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="325.7142857142857" cy="540" r="23.714285714285715" id="pred_e1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="397.14285714285717" cy="540" r="23.714285714285715" id="pred_f1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="468.57142857142856" cy="540" r="23.714285714285715" id="pred_g1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="540" cy="540" r="23.714285714285715" id="pred_h1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="40" cy="468.57142857142856" r="23.714285714285715" id="pred_a2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="111.42857142857143" cy="468.57142857142856" r="23.714285714285715" id="pred_b2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="182.85714285714286" cy="468.57142857142856" r="23.714285714285715" id="pred_c2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="254.28571428571428" cy="468.57142857142856" r="23.714285714285715" id="pred_d2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="325.7142857142857" cy="468.57142857142856" r="23.714285714285715" id="pred_e2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="397.14285714285717" cy="468.57142857142856" r="23.714285714285715" id="pred_f2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="468.57142857142856" cy="468.57142857142856" r="23.714285714285715" id="pred_g2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="540" cy="468.57142857142856" r="23.714285714285715" id="pred_h2_W" stroke-width="5.571428571428571" ></circle></svg> Deleted: trunk/Toss/Client/img/Checkers.svg =================================================================== --- trunk/Toss/Client/img/Checkers.svg 2012-04-17 18:07:32 UTC (rev 1699) +++ trunk/Toss/Client/img/Checkers.svg 2012-05-05 21:58:06 UTC (rev 1700) @@ -1,2 +0,0 @@ -<?xml-stylesheet href="Style2.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-W" cx="40" cy="540" r="23.714285714285715" id="pred_a1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="182.85714285714286" cy="540" r="23.714285714285715" id="pred_c1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="325.7142857142857" cy="540" r="23.714285714285715" id="pred_e1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="468.57142857142856" cy="540" r="23.714285714285715" id="pred_g1_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="111.42857142857143" cy="468.57142857142856" r="23.714285714285715" id="pred_b2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="254.28571428571428" cy="468.57142857142856" r="23.714285714285715" id="pred_d2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="397.14285714285717" cy="468.57142857142856" r="23.714285714285715" id="pred_f2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="540" cy="468.57142857142856" r="23.714285714285715" id="pred_h2_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="40" cy="397.14285714285717" r="23.714285714285715" id="pred_a3_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="182.85714285714286" cy="397.14285714285717" r="23.714285714285715" id="pred_c3_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="325.7142857142857" cy="397.14285714285717" r="23.714285714285715" id="pred_e3_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="468.57142857142856" cy="397.14285714285717" r="23.714285714285715" id="pred_g3_W" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="111.42857142857143" cy="182.85714285714286" r="23.714285714285715" id="pred_b6_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="254.28571428571428" cy="182.85714285714286" r="23.714285714285715" id="pred_d6_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="397.14285714285717" cy="182.85714285714286" r="23.714285714285715" id="pred_f6_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="540" cy="182.85714285714286" r="23.714285714285715" id="pred_h6_B" stroke-width="5.571428571428571" ></circle><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="182.85714285714286" cy="111.42857142857143" r="23.714285714285715" id="pred_c7_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="468.57142857142856" cy="111.42857142857143" r="23.714285714285715" id="pred_g7_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="254.28571428571428" cy="40" r="23.714285714285715" id="pred_d8_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="540" cy="40" r="23.714285714285715" id="pred_h8_B" stroke-width="5.571428571428571" ></circle></svg> Deleted: trunk/Toss/Client/img/Chess.svg =================================================================== --- trunk/Toss/Client/img/Chess.svg 2012-04-17 18:07:32 UTC (rev 1699) +++ trunk/Toss/Client/img/Chess.svg 2012-05-05 21:58:06 UTC (rev 1700) @@ -1,2 +0,0 @@ -<?xml-stylesheet href="Style2.css" type="text/css"?> -<svg id="svg" class="Game-Chess" 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><g transform="translate(40,40) scale(1.2857142857142858,1.2857142857142858)"><g class="chessB" id="pred_a8_bR" ><g transform="translate(-22.5,-22.5)"> <path d="M 9,39 L 36,39 L 36,36 L 9,36 L 9,39 z " style="stroke-linecap:butt;" class="chess-path-Bx"></path> <path d="M 12,36 L 12,32 L 33,32 L 33,36 L 12,36 z " style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 11,14 L 11,9 L 15,9 L 15,11 L 20,11 L 20,9 L 25,9 L 25,11 L 30,11 L 30,9 L 34,9 L 34,14" style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 34,14 L 31,17 L 14,17 L 11,14" style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 31,17 L 31,29.5 L 14,29.5 L 14,17" style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 31,29.5 L 32.5,32 L 12.5,32 L 14,29.5" class="chess-path-B"></path> <path d="M 11,14 L 34,14" class="chess-path-D"></path> </g></g> </g><g transform="translate(540,40) scale(1.2857142857142858,1.2857142857142858)"><g class="chessB" id="pred_h8_bR" ><g transform="translate(-22.5,-22.5)"> <path d="M 9,39 L 36,39 L 36,36 L 9,36 L 9,39 z " style="stroke-linecap:butt;" class="chess-path-Bx"></path> <path d="M 12,36 L 12,32 L 33,32 L 33,36 L 12,36 z " style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 11,14 L 11,9 L 15,9 L 15,11 L 20,11 L 20,9 L 25,9 L 25,11 L 30,11 L 30,9 L 34,9 L 34,14" style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 34,14 L 31,17 L 14,17 L 11,14" style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 31,17 L 31,29.5 L 14,29.5 L 14,17" style="stroke-linecap:butt;" class="chess-path-B"></path> <path d="M 31,29.5 L 32.5,32 L 12.5,32 L 14,29.5" class="chess-path-B"></path> <path d="M 11,14 L 34,14" class="chess-path-D"></path> </g></g> </g><g transform="translate(254.28571428571428,540) scale(1.2857142857142858,1.2857142857142858)"><g class="chessW" id="pred_d1_wQ" ><g transform="translate(-22.5,-22.5)"> <path d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" transform="translate(-1,-1)" style="fill-rule: none;" class="chess-path-BW"></path> <path d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" transform="translate(15.5,-5.5)" style="fill-rule: none;" class="chess-path-BW"></path> <path d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" transform="translate(32,-1)" style="fill-rule: none;" class="chess-path-BW"></path> <path d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" transform="translate(7,-4.5)" style="fill-rule: none;" class="chess-path-BW"></path> <path d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" transform="translate(24,-4)" style="fill-rule: none;" class="chess-path-BW"></path> <path d="M 9,26 C 17.5,24.5 30,24.5 36,26 L 38,14 L 31,25 L 31,11 L 25.5,24.5 L 22.5,9.5 L 19.5,24.5 L 14,10.5 L 14,25 L 7,14 L 9,26 z " style="stroke-linecap:butt;" class="chess-path-BW"></path> <path d="M 9,26 C 9,28 10.5,28 11.5,30 C 12.5,31.5 12.5,31 12,33.5 C 10.5,34.5 10.5,36 10.5,36 C 9,37.5 11,38.5 11,38.5 C 17.5,39.5 27.5,39.5 34,38.5 C 34,38.5 35.5,37.5 34,36 C 34,36 34.5,34.5 33,33.5 C 32.5,31 32.5,31.5 33.5,30 C 34.5,28 36,28 36,26 C 27.5,24.5 17.5,24.5 9,26 z " style="stroke-linecap:butt;" class="chess-path-BW"></path> <path d="M 11.5,30 C 15,29 30,29 33.5,30" class="chess-path-DW"></path> <path d="M 12,33.5 C 18,32.5 27,32.5 33,33.5" class="chess-path-DW"></path> <path d="M 10.5,36 C 15.5,35 29,35 34,36" class="chess-path-DW"></path> </g></g> </g><g transform="translate(182.85714285714286,540) scale(1.2857142857142858,1.2857142857142858)"><g class="chessW" id="pred_c1_wB" ><g transform="translate(-22.5,-22.5)"> <path d="M 9,36 C 12.385,35.028 19.115,36.431 22.5,34 C 25.885,36.431 32.615,35.028 36,36 C 36,36 37.646,36.542 39,38 C 38.323,38.972 37.354,38.986 36,38.5 C 32.615,37.528 25.885,38.958 22.5,37.5 C 19.115,38.958 12.385,37.528 9,38.5 C 7.6459,38.986 6.6771,38.972 6,38 C 7.3541,36.055 9,36 9,36 z " style="stroke-linecap:butt;" class="chess-path-BW"></path> <path d="M 15,32 C 17.5,34.5 27.5,34.5 30,32 C 30.5,30.5 30,30 30,30 C 30,27.5 27.5,26 27.5,26 C 33,24.5 33.5,14.5 22.5,10.5 C 11.5,14.5 12,24.5 17.5,26 C 17.5,26 15,27.5 15,30 C 15,30 14.5,30.5 15,32 z " style="stroke-linecap:butt;" class="chess-path-BW"></path> <path d="M 25 10 A 2.5 2.5 0 1 1 20,10 A 2.5 2.5 0 1 1 25 10 z" transform="translate(0,-2)" style="stroke-linecap:butt;" class="chess-path-BxW"></path> <path d="M 17.5,26 L 27.5,26" style="stroke-linecap:butt;" class="chess-path-DW"></path> <path d="M 15,30 L 30,30" style="stroke-linecap:butt;" class="chess-path-DW"></path> <path d="M 22.5,15.5 L 22.5,20.5" style="stroke-linecap:butt;" class="chess-path-DW"></path> <path d="M 20,18 L 25,18" style="stroke-linecap:butt;" class="chess-path-DW"></path> </g></g> </g><g transform="translate(397.14285714285717,540) scale(1.2857142857142858,1.2857142857142858)"><g class="chessW" id="pred_f1_wB" ><g transform="translate(-22.5,-22.5)"> <path d="M 9,36 C 12.385,35.028 19.115,36.431 22.5,34 C 25.885,36.431 32.615,35.028 36,36 C 36,36 37.646,36.542 39,38 C 38.323,38.972 37.354,38.986 36,38.5 C 32.615,37.528 25.885,38.958 22.5,37.5 C 19.115,38.958 12.385,37.528 9,38.5 C 7.6459,38.986 6.6771,38.972 6,38 C 7.3541,36.055 9,36 9,36 z " style="stroke-linecap:butt;" class="chess-path-BW"></path> <path d="M 15,32 C 17.5,34.5 27.5,34.5 30,32 C 30.5,30.5 30,30 30,30 C 30,27.5 27.5,26 27.5,26 C 33,24.5... [truncated message content] |