Thread: [Toss-devel-svn] SF.net SVN: toss:[1691] trunk/Toss (Page 13)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2012-03-12 00:27:30
|
Revision: 1691
http://toss.svn.sourceforge.net/toss/?rev=1691&view=rev
Author: lukaszkaiser
Date: 2012-03-12 00:27:22 +0000 (Mon, 12 Mar 2012)
Log Message:
-----------
Both current and starting structure parsing, many small corrections.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Main.js
trunk/Toss/Client/Play.js
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/www/codebasics.xml
trunk/Toss/www/create.xml
trunk/Toss/www/ideas.xml
trunk/Toss/www/navigation.xml
trunk/Toss/www/ocaml.xml
trunk/Toss/www/play.xml
trunk/Toss/www/xsl/common.xsl
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/Arena.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -47,7 +47,7 @@
parameters : (string * float) list ;
rule : string ;
next_loc : int ;
- matching : (string * int) list ;
+ matching : (string * string) list ;
}
(* State of the game and additional information. *)
@@ -101,7 +101,7 @@
let move_str (lb, i) = Printf.sprintf "[%s -> %i]" (label_str lb) i
let pmv_str (pl, lb, i) = Printf.sprintf "[%s,%s -> %i]" pl (label_str lb) i
-let fprint_loc_body_in struc pnames f player {payoff = in_p; moves = in_m} =
+let fprint_loc_body_in pnames f player {payoff = in_p; moves = in_m} =
Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
(fun f (payoff, moves) ->
Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
@@ -120,20 +120,16 @@
Format.fprintf f "@ ->@ %d@]@,]" target)) moves
) (in_p, in_m)
-let fprint_loc_body struc pnames f loc =
- Array.iteri (fun p l -> fprint_loc_body_in struc pnames f p l) loc
+let fprint_loc_body pnames f loc =
+ Array.iteri (fun p l -> fprint_loc_body_in pnames f p l) loc
let equational_def_style = ref true
-let fprint_game_move ?(as_ints=false) struc f
+let fprint_game_move f
({mv_time = t; parameters = pl; rule = rn;
next_loc = l; matching = m}, rtime) =
let m_s = String.concat ", "
- (List.map (fun (e, x) ->
- if as_ints then
- Printf.sprintf "%s: %i" e x
- else
- Printf.sprintf "%s: %s" e (Structure.elem_str struc x))
+ (List.map (fun (e, x) -> Printf.sprintf "%s: %s" e x)
(List.sort Pervasives.compare m)) in
let rt = match rtime with None -> "" | Some f -> " " ^ (string_of_float f) in
if (pl = []) then
@@ -144,9 +140,8 @@
Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
)
-let sprint_game_move st gm = AuxIO.sprint_of_fprint (fprint_game_move st) gm
-let game_move_str st gm = sprint_game_move st (gm, None)
-let game_move_gs_str st gm = sprint_game_move st.struc (gm, None)
+let sprint_game_move gm = AuxIO.sprint_of_fprint fprint_game_move gm
+let game_move_str gm = sprint_game_move (gm, None)
let fprint_only_state ?(ext_struct=false) ppf
{struc = struc;
@@ -159,7 +154,7 @@
(Structure.fprint ~show_empty:true)) struc;
if (hist <> []) then
Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
- (Aux.fprint_sep_list ";\n" (fprint_game_move struc)) hist;
+ (Aux.fprint_sep_list ";\n" fprint_game_move) hist;
if cur_loc <> 0 then
Format.fprintf ppf "@[<1>STATE LOC@ %d@]@ " cur_loc;
if time <> 0. then
@@ -174,11 +169,13 @@
player_names = player_names;
data = data;
defined_rels = defined_rels;
- starting_struc = struc;
+ starting_struc = start_struc;
},
- {time = time;
- cur_loc = cur_loc;
- history = hist;
+ {
+ struc = cur_struc;
+ time = time;
+ cur_loc = cur_loc;
+ history = hist;
}) =
Format.fprintf ppf "@[<v>";
List.iter (fun (drel, (args, body)) ->
@@ -205,17 +202,20 @@
(ContinuousRule.fprint_full print_compiled_rules) r) rules;
Array.iteri (fun loc_id loc ->
Format.fprintf ppf "@[<0>LOC@ %d@ {@,@[<2> %a@]@]@,}@ "
- loc_id (fprint_loc_body struc player_names) loc) graph;
+ loc_id (fprint_loc_body player_names) loc) graph;
Format.fprintf ppf "@[<1>START@ %a@]@ "
(if ext_struct then (Structure.fprint_ext_structure ~show_empty:true) else
- (Structure.fprint ~show_empty:true)) struc;
+ (Structure.fprint ~show_empty:true)) start_struc;
if (hist <> []) then
Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
- (Aux.fprint_sep_list ";\n" (fprint_game_move ~as_ints:true struc)) hist;
+ (Aux.fprint_sep_list ";\n" fprint_game_move) hist;
if cur_loc <> 0 then
Format.fprintf ppf "@[<1>STATE LOC@ %d@]@ " cur_loc;
if time <> 0. then
Format.fprintf ppf "@[<1>TIME@ %F@]@ " time;
+ if ext_struct then
+ Format.fprintf ppf "@[<1>CURRENT@ %a@]@ "
+ (Structure.fprint_ext_structure ~show_empty:true) cur_struc;
Format.fprintf ppf "@]"
let fprint_state = fprint_state_full false
@@ -266,11 +266,10 @@
(* The order of following entries matters: [DefPlayers] adds more
players, with consecutive numbers starting from first available;
- later [StateStruc], [StateTime] and [StateLoc] entries override
- earlier ones; later [DefLoc] with already existing location ID
+ later [StartStruc], [CurrentStruc], [StateTime] and [StateLoc] entries
+ override earlier ones; later [DefLoc] with already existing location ID
replaces the earlier one. The default state is the empty state,
- default location is 0, default time is 0.0, default data is
- empty. *)
+ default location is 0, default time is 0.0, default data is empty. *)
type definition =
| DefRule of string * (
(string * int) list ->
@@ -283,7 +282,8 @@
| DefRel of string * string list * Formula.formula
(* add a defined relation *)
| DefPattern of Formula.real_expr (* Pattern definition *)
- | StateStruc of Structure.structure (* initial/saved state *)
+ | StartStruc of Structure.structure (* initial structure *)
+ | CurrentStruc of Structure.structure (* current structure *)
| History of (move * float option) list (* Move history *)
| StateTime of float (* initial/saved time *)
| StateLoc of int (* initial/saved location *)
@@ -327,14 +327,16 @@
(* Helper: Apply a move to a game state, get the new state. *)
let apply_move rules state (m, t) =
let r = List.assoc m.rule rules in
- match ContinuousRule.rewrite_single state.struc state.time m.matching r
+ let mtch =
+ List.map (fun (v, e) -> v, Structure.elem_nbr state.struc e) m.matching in
+ match ContinuousRule.rewrite_single state.struc state.time mtch r
m.mv_time m.parameters with
| Some (new_struc, new_time, _) ->
{ struc = new_struc;
time = new_time;
history = (m, t) :: state.history;
cur_loc = m.next_loc }
- | _ -> failwith ("move " ^ (sprint_game_move state.struc (m,t)) ^
+ | _ -> failwith ("move " ^ (sprint_game_move (m,t)) ^
" inapplicable to " ^ (sprint_only_state state))
(* Make a move in a game. *)
@@ -344,76 +346,74 @@
list of definitions (usually corresponding to a ".toss" file.) *)
let process_definition ?extend_state defs =
let (old_rules, old_locs, players, old_defined_rels,
- state, time, cur_loc, patterns, data) =
+ strucs, time, cur_loc, patterns, data) =
match extend_state with
| None ->
- [], [], [], [], Structure.empty_structure (), 0.0, 0, [], []
+ [], [], [], [], (Structure.empty_structure (), None), 0.0, 0, [], []
| Some (game, gstate) ->
game.rules, Array.to_list (Array.mapi (fun i l -> i, l) game.graph),
List.map fst (List.sort (fun (_,x) (_,y) -> x-y) game.player_names),
List.map (fun (rel, (args, body)) -> rel, args, body) game.defined_rels,
- gstate.struc, gstate.time, gstate.cur_loc,
+ (game.starting_struc, Some gstate.struc), gstate.time, gstate.cur_loc,
game.patterns, game.data in
LOG 3 "process_definition: %d old rules, %d old locs\n%!"
(List.length old_rules) (List.length old_locs);
let rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist =
+ strucs, time, cur_loc, patterns, data, hist =
List.fold_left (fun (rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist) def ->
+ strucs, time, cur_loc, patterns, data, hist) def ->
match def with
| DefRule (rname, r) ->
((rname, r)::rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefLoc loc ->
(rules, loc::locations, players, defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefPlayers more_players ->
(rules, locations, players @ more_players, defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefRel (rel, args, body) ->
(rules, locations, players,
(rel, args, body)::defined_rels,
- state, time, cur_loc, patterns, data, hist)
+ strucs, time, cur_loc, patterns, data, hist)
| DefPattern pat ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, pat :: patterns, data, hist)
- | StateStruc struc ->
+ strucs, time, cur_loc, pat :: patterns, data, hist)
+ | StartStruc struc ->
(rules, locations, players, defined_rels,
- struc, time, cur_loc, patterns, data, hist)
+ (struc, snd strucs), time, cur_loc, patterns, data, hist)
+ | CurrentStruc struc ->
+ (rules, locations, players, defined_rels,
+ (fst strucs, Some struc), time, cur_loc, patterns, data, hist)
| History h ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data, h @ hist)
+ strucs, time, cur_loc, patterns, data, h @ hist)
| StateTime ntime ->
(rules, locations, players, defined_rels,
- state, ntime, cur_loc, patterns, data, hist)
+ strucs, ntime, cur_loc, patterns, data, hist)
| StateLoc ncur_loc ->
(rules, locations, players, defined_rels,
- state, time, ncur_loc, patterns, data, hist)
+ strucs, time, ncur_loc, patterns, data, hist)
| StateData more_data ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, patterns, data @ more_data, hist)
- ) ([], [], players, [],
- state, time, cur_loc, patterns, data, []) defs in
+ strucs, time, cur_loc, patterns, data @ more_data, hist)
+ ) ([], [], players, [], strucs, time, cur_loc, patterns, data, []) defs in
LOG 3 "process_definition: %d new rules, %d new defined rels\n%!"
(List.length rules) (List.length defined_rels);
let defined_rels = old_defined_rels @ List.rev defined_rels in
let def_rels_pure =
List.map (fun (rel, args, body) -> (rel, (args, body))) defined_rels in
let player_names =
- Array.to_list (Array.mapi (fun i pname->pname, i)
- (Array.of_list players)) in
+ Array.to_list (Array.mapi (fun i pname->pname,i) (Array.of_list players)) in
let num_players = List.length player_names in
- let signature = Structure.rel_signature state in
+ let signature = Structure.rel_signature (fst strucs) in
LOG 3 "process_definition: parsing new rules...%!";
- let rules =
- old_rules @ List.map (fun (name, r) ->
- name, r signature def_rels_pure name) rules in
+ let rules = old_rules @ List.map (fun (name, r) ->
+ name, r signature def_rels_pure name) rules in
LOG 3 " parsed\n%!";
- let rules =
- List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
+ let rules = List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
let updated_locs =
- if old_locs = [] then old_locs
- else
+ if old_locs = [] then old_locs else
let more = num_players - Array.length (snd (List.hd old_locs)) in
let add_more (i,loc) =
i, Array.append loc (Array.make more zero_loc) in
@@ -432,13 +432,13 @@
let graph = Aux.array_from_assoc (List.rev locations) in
let pats=List.rev_map (FormulaSubst.subst_rels_expr def_rels_pure) patterns in
let apply_moves rules mvs s = List.fold_left (apply_move rules) s mvs in
- let result_state =
- apply_moves rules (List.rev hist) {
- struc = state;
- time = time;
- cur_loc = cur_loc;
- history = [];
- } in
+ let result_state = match snd strucs with
+ | None ->
+ let st = apply_moves rules (List.rev hist)
+ { snd empty_state with struc = fst strucs } in
+ { st with time = time; cur_loc = cur_loc; history = hist }
+ | Some struc ->
+ { struc = struc; time = time; cur_loc = cur_loc; history = hist; } in
{
rules = rules;
patterns = pats;
@@ -447,7 +447,7 @@
player_names = player_names;
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
- starting_struc = state;
+ starting_struc = fst strucs;
}, result_state
@@ -611,7 +611,8 @@
parameters = [];
rule = label.lb_rule;
next_loc = next_loc;
- matching = emb
+ matching =
+ List.map (fun (v, e) -> (v, Structure.elem_name model e)) emb
} |]
else
let param_names, params_in =
@@ -631,9 +632,10 @@
parameters = List.combine param_names params;
rule = label.lb_rule;
next_loc = next_loc;
- matching = emb}
- ) grid
- ) matchings))
+ matching =
+ List.map (fun (v, e) -> (v, Structure.elem_name model e)) emb
+ }) grid
+ ) matchings))
(* Check if the before-part of the precondition of the rule holds on history. *)
let check_history_pre r hist =
@@ -649,6 +651,8 @@
Aux.map_some (fun mv ->
let rule = List.assoc mv.rule rules in
if check_history_pre rule.ContinuousRule.discrete state.history then
+ let mtch = List.map (fun (v, e) ->
+ v, Structure.elem_nbr state.struc e) mv.matching in
Aux.map_option
(fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *)
(mv,
@@ -656,7 +660,7 @@
history = (mv, None) :: state.history;
struc = model;
time = time}))
- (ContinuousRule.rewrite_single state.struc time mv.matching
+ (ContinuousRule.rewrite_single state.struc time mtch
rule mv.mv_time mv.parameters)
else None) (Array.to_list moves)
@@ -712,15 +716,17 @@
r_name (ContinuousRule.matching_str struc mtch) player
(String.concat ", " (List.map (fun (lb,_) -> lb.lb_rule) mv_loc.moves))
(String.concat "; " (List.map (fun m ->
- m.rule ^ ":" ^ ContinuousRule.matching_str struc m.matching
+ let mstr = List.map (fun (v, e) ->
+ v, Structure.elem_nbr state.struc e) m.matching in
+ m.rule ^ ":" ^ ContinuousRule.matching_str struc mstr
) (Array.to_list moves)));
let pos = (
try
for i = 0 to Array.length moves - 1 do
let mov = moves.(i) in
- if r_name = mov.rule && List.for_all
- (fun (e, f) -> f = List.assoc e mov.matching) mtch then
- raise (Found i)
+ if r_name = mov.rule && List.for_all (fun (e, f) ->
+ Structure.elem_name state.struc f = List.assoc e mov.matching) mtch
+ then raise (Found i)
done;
LOG 1 "apply_rewrite: failed for pl. num %d, r_name=%s\n%!"
player r_name;
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/Arena.mli 2012-03-12 00:27:22 UTC (rev 1691)
@@ -40,7 +40,7 @@
parameters : (string * float) list ;
rule : string ;
next_loc : int ;
- matching : (string * int) list ;
+ matching : (string * string) list ;
}
@@ -94,17 +94,15 @@
(** For the rules of the game, also print their compiled forms. *)
val sprint_state_full : game * game_state -> string
-val sprint_game_move : Structure.structure -> move * float option -> string
-val game_move_str : Structure.structure -> move -> string
-val game_move_gs_str : game_state -> move -> string
+val sprint_game_move : move * float option -> string
+val game_move_str : move -> string
(** The order of following entries matters: [DefPlayers] adds more
- players, with consecutive numbers starting from first available;
- later [StateStruc], [StateTime] and [StateLoc] entries override
- earlier ones; later [DefLoc] with already existing location ID
- replaces the earlier one. The default state is the empty state,
- default location is 0, default time is 0.0, default data is
- empty. *)
+ players, with consecutive numbers starting from first available;
+ later [StartStruc], [CurrentStruc], [StateTime] and [StateLoc] entries
+ override earlier ones; later [DefLoc] with already existing location ID
+ replaces the earlier one. The default state is the empty state,
+ default location is 0, default time is 0.0, default data is empty. *)
type definition =
| DefRule of string * (
(string * int) list ->
@@ -117,7 +115,8 @@
| DefRel of string * string list * Formula.formula
(** add a defined relation *)
| DefPattern of Formula.real_expr (** Pattern definition *)
- | StateStruc of Structure.structure (** initial/saved state *)
+ | StartStruc of Structure.structure (** initial structure *)
+ | CurrentStruc of Structure.structure (** current structure *)
| History of (move * float option) list (** Move history *)
| StateTime of float (** initial/saved time *)
| StateLoc of int (** initial/saved location *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-03-12 00:27:22 UTC (rev 1691)
@@ -85,13 +85,13 @@
game_move_timed:
| OPENSQ r = id_int t = FLOAT RARR l = INT EMB
- emb = separated_list (COMMA, separated_pair (ID, COLON, INT)) CLOSESQ
+ emb = separated_list (COMMA, separated_pair (ID, COLON, id_int)) CLOSESQ
{ ({mv_time = t; parameters = []; rule = r; next_loc = l; matching = emb;},
None) }
| OPENSQ r = id_int t = FLOAT COMMA
p = separated_list (COMMA, separated_pair (ID, COLON, FLOAT))
RARR l = INT EMB
- emb = separated_list (COMMA, separated_pair (ID, COLON, INT)) CLOSESQ
+ emb = separated_list (COMMA, separated_pair (ID, COLON, id_int)) CLOSESQ
f = FLOAT
{ ({mv_time = t; parameters = p; rule = r; next_loc = l; matching = emb;},
Some f) }
@@ -123,10 +123,15 @@
body = formula_expr_err
{ DefRel (rel, arg, body) }
| START model = struct_expr
- { StateStruc model }
+ { StartStruc model }
| START model = struct_expr WITH
defs = separated_list (SEMICOLON, rel_def_simple)
- { StateStruc (Arena.add_def_rels model defs) }
+ { StartStruc (Arena.add_def_rels model defs) }
+ | CURRENT model = struct_expr
+ { CurrentStruc model }
+ | CURRENT model = struct_expr WITH
+ defs = separated_list (SEMICOLON, rel_def_simple)
+ { CurrentStruc (Arena.add_def_rels model defs) }
| MOVES moves = separated_list (SEMICOLON, game_move_timed)
{ History (moves) }
| TIME_MOD t = FLOAT
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -85,10 +85,9 @@
parameters = [];
rule = "rule";
next_loc = 1;
- matching = [("x", 1)];
+ matching = [("x", "1")];
} in
- let s = Structure.empty_structure () in
- assert_equal ~printer:(fun x -> x) (Arena.game_move_str s mv)
+ assert_equal ~printer:(fun x -> x) (Arena.game_move_str mv)
"[rule 0. -> 1 emb x: 1]"
);
]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/JsHandler.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -1,8 +1,5 @@
(* JavaScript Handler for a subset of ReqHandler.handle_http_post requests. *)
-
-(* In-source definitions of several games, loading games from strings. *)
-
type game_state_data = {
heuristic : Formula.real_expr array array; (** heuristic *)
game_state : (Arena.game * Arena.game_state); (** game and state *)
@@ -143,10 +140,8 @@
let _ = set_handle "test_handle" test_handle
let js_of_move game state move_id (player, move, _) =
- let struc = state.Arena.struc in
let matched = Js.array
- (Aux.array_map_of_list (fun (_, e) ->
- js (Structure.elem_name struc e)) move.Arena.matching) in
+ (Aux.array_map_of_list (fun (_, e) -> js e) move.Arena.matching) in
let js_move = jsnew js_object () in
let player_name = Aux.rev_assoc game.Arena.player_names player in
Js.Unsafe.set js_move (js"matched") matched;
@@ -156,7 +151,7 @@
js_move
(* Translate current structure into an "info_obj" format. *)
-let js_of_game_state game state =
+let js_of_game_state ?(show_payoffs=true) game state =
let struc = state.Arena.struc in
let get_pos e =
Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
@@ -201,7 +196,7 @@
if !cur_all_moves <> [||] then
Js.Unsafe.set info_obj (js"moves")
(Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
- else ( (* find payoffs *)
+ else if show_payoffs then ( (* find payoffs *)
let payoffs = Array.mapi
(fun i v -> i, Solver.M.get_real_val v.Arena.payoff struc)
game.Arena.graph.(state.Arena.cur_loc) in
@@ -212,7 +207,8 @@
let player_name = Aux.rev_assoc game.Arena.player_names i in
Js.Unsafe.set result (js player_name) (Js.float payoff))
payoffs;
- Js.Unsafe.set info_obj (js"result") result);
+ Js.Unsafe.set info_obj (js"result") result
+ );
LOG 0 "%s" "js_of_game_state: Game prepared. Sending...";
info_obj
@@ -244,11 +240,10 @@
let preview_move move_nbr =
let n = List.length !play_states - (move_nbr + 1) in
- if n < 0 then Js.null
- else
+ if n < 0 then Js.null else
let game, _ = !cur_game.game_state in
let state = List.nth !play_states n in
- Js.some (js_of_game_state game state)
+ Js.some (js_of_game_state ~show_payoffs:(n = 0) game state)
let _ = set_handle "prev_move" preview_move
@@ -325,7 +320,7 @@
let game, _ = !cur_game.game_state in
let move_s, state = of_js move_js, List.hd !play_states in
let move_id = Aux.array_argfind
- (fun (_,m,_) -> Arena.game_move_gs_str state m = move_s) !cur_all_moves in
+ (fun (_,m,_) -> Arena.game_move_str m = move_s) !cur_all_moves in
let result =
js_of_move game state move_id (!cur_all_moves.(move_id)) in
Js.Unsafe.set result (js"comp_iters")
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/Main.js 2012-03-12 00:27:22 UTC (rev 1691)
@@ -69,12 +69,12 @@
document.getElementById ("topuser").innerHTML = game;
document.getElementById ("game-title").style.display = "none";
document.getElementById ("game-title-move").style.display = "none";
- document.getElementById ("game-info-par").style.paddingBottom = "1em";
document.getElementById ("welcome").style.display = "none";
new_play_do ("computer", function () { });
}
function new_play_do (opp_uid, continuation) {
+ if (GAME_NAME === "Gomoku") { document.getElementById ("speed").value = 3; }
document.getElementById ("working").innerHTML = "Loading "+GAME_NAME+"...";
document.getElementById ("working").style.display = "block";
document.getElementById ("welcome").style.display = "none";
@@ -83,13 +83,13 @@
gd.style.display = "block";
gd.setAttribute ("class", "Game-" + GAME_NAME);
document.getElementById ("game-title").innerHTML = GAME_NAME;
- document.getElementById ("game-title").style.display = "inline";
- document.getElementById ("game-title-move").style.display = "inline";
var build_play = function (state_str) {
document.getElementById ("working").style.display = "none";
document.getElementById ("toss-link").style.display = "none";
document.getElementById ("appstorelink").style.display = "none";
document.getElementById ("toprighttab").style.display = "inline";
+ document.getElementById ("game-title").style.display = "inline";
+ document.getElementById ("game-title-move").style.display = "inline";
document.getElementById ("game-desc-controls").style.display = "block";
document.getElementById ("suggestions-toggle").style.display = "inline";
document.getElementById ("game-disp").style.display = "block";
@@ -109,9 +109,6 @@
document.getElementById ('payoffs').innerHTML = "Not Finished Yet";
document.getElementById ('payoffs').style.display = "none";
document.getElementById ('new-play-par').style.display = "none";
- if (UNAME == "guest") {
- document.getElementById ("game-info-par").style.paddingBottom = "1em";
- };
toggle_suggestions ();
toggle_suggestions ();
PLAY.clear ();
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/Play.js 2012-03-12 00:27:22 UTC (rev 1691)
@@ -1,4 +1,4 @@
-// JavaScript Toss Module -- Play (requires Connect.js or JsHandler, State.js)
+// JavaScript Toss Module -- Play (requires JsHandler, State.js)
var SIMPLE_MOVES = true;
var nameDISP = undefined;
@@ -135,12 +135,9 @@
// Apply the current move in a play.
function play_move () {
- if (typeof CONN != 'undefined' && ASYNC_ALL_REQ_PENDING != 0)
- { alert ("async"); return; }
if (this.CUR_MOVE == null) return;
if (this.move_nbr < this.last_move_nbr) { return; }
- // FIXME: why - 1? Move() already subtracts 1!
- var pl_nbr = this.CUR_MOVE.player; // - 1;
+ var pl_nbr = this.CUR_MOVE.player;
if (!isNaN(pl_nbr) && this.players[pl_nbr] != this.cur_player_uid &&
this.players[pl_nbr] != "computer") {
alert ("It is your Opponent's move: pl_nbr = "+pl_nbr +
@@ -165,7 +162,6 @@
Play.prototype.move_continue = play_move_continue;
function play_prev_move () {
- var prev;
var that = this;
var disp = function (prev) {
if (prev === null || prev == "NONE") { return; }
@@ -173,17 +169,11 @@
that.move_nbr = that.move_nbr - 1;
that.redraw ();
}
- if (typeof CONN == 'undefined') {
- prev = ASYNCH ("prev_move", [this.move_nbr - 1], disp);
- } else {
- prev = CONN.prev_move (this.pid, this.move_nbr - 1);
- disp (prev);
- }
+ ASYNCH ("prev_move", [this.move_nbr - 1], disp);
}
Play.prototype.prev_move = play_prev_move;
function play_next_move () {
- var next;
var that = this;
var disp = function (next) {
if (next === null || next == "NONE") {
@@ -198,12 +188,7 @@
}
that.redraw ();
}
- if (typeof CONN == 'undefined') {
- next = ASYNCH ("prev_move", [this.move_nbr + 1], disp);
- } else {
- next = CONN.prev_move (this.pid, this.move_nbr + 1);
- disp (next);
- }
+ ASYNCH ("prev_move", [this.move_nbr + 1], disp);
}
Play.prototype.next_move = play_next_move;
@@ -236,7 +221,7 @@
var result_string = "";
if (this.cur_state.result == null) { return ""; }
winners = this.get_winners();
- if (winners == null) { return "Tie"; }
+ if (winners == null) { return "No Winners"; }
if (winners.length == 0) { return null; }
for (var i=0; i < winners.length; i++) {
if (i > 0) result_string += ', ' + disp_name(winners[i]);
@@ -282,9 +267,9 @@
if (pl == un) { return ("You Win!"); }
return (nameDISP(pl) + " Wins");
}
- var subst_pl = function (pl, str) {
+ var subst_pl = function (pl, s) {
var un = pl.cur_player_uid;
- var s = str; //strip (' ', '\n', str);
+ if (typeof s == 'undefined') { return "Not Finished" }
if (s == "0: 1., 1: -1." || s == "1: 1, 2: -1") {
return (win_s (pl.players[0], un));
}
@@ -308,10 +293,9 @@
document.getElementById("board").style.paddingTop = "0em";
}
document.getElementById("move-info-par").style.display = "none";
- document.getElementById("game-info-par").style.paddingBottom = "0em";
document.getElementById('payoffs').innerHTML =
"Result: " + subst_pl(play, play.cur_state.payoff);
- document.getElementById('payoffs').style.display = "inline";
+ document.getElementById('payoffs').style.display = "block";
document.getElementById('new-play-par').style.display = "block";
}
}
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/State.js 2012-03-12 00:27:22 UTC (rev 1691)
@@ -149,7 +149,7 @@
payoffs.push (player + ': ' + info_obj.result[player]);
}
this.payoff = payoffs.join (', ');
- } else {
+ } else if (typeof info_obj.moves != 'undefined') {
var mvs = [];
var pls = [];
for (i = 0; i < info_obj.moves.length; i++) {
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/Style.css 2012-03-12 00:27:22 UTC (rev 1691)
@@ -164,6 +164,8 @@
height: 100%;
text-align: justify;
display: block;
+ margin-top: 1em;
+ margin-bottom: 1em;
}
#more-games-bt-div {
@@ -609,7 +611,7 @@
#game-desc-controls {
position: relative;
- top: -1.5em;
+ top: -1em;
display: none;
width: 80%;
margin: auto;
@@ -835,8 +837,13 @@
#game-info-par {
font-weight: bold;
margin-bottom: 0px;
+ padding-top: 1em;
+}
+
+#payoffs {
+ display: none;
margin-top: 0.5em;
- padding: 0px;
+ font-weight: bold;
}
#nextmovebt {
@@ -875,7 +882,7 @@
position: fixed;
left: 0px;
right: 0px;
- top: 4em;
+ top: 6em;
width: 15em;
margin-left: auto;
margin-right: auto;
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Client/index.html 2012-03-12 00:27:22 UTC (rev 1691)
@@ -178,8 +178,8 @@
</button><button id="nextmovebt" class="bt" onclick="next_move_click()">
+
</button></span>
- <span id="payoffs" style="display:none;">Not Finished Yet</span>
</p>
+ <p id="payoffs">Not Finished Yet</p>
<p id="new-play-par">
<button id="new_game_me" class="bt" onclick="play_anew(true)">
New Game (You Start)
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Formula/Lexer.mll 2012-03-12 00:27:22 UTC (rev 1691)
@@ -81,7 +81,7 @@
| TIME_MOD
| PLAYER_MOD
| PLAYERS_MOD
- | MODEL_SPEC
+ | CURRENT
| RULE_SPEC
| STATE_SPEC
| CLASS
@@ -224,7 +224,7 @@
| "TIME" { TIME_MOD }
| "PLAYER" { PLAYER_MOD }
| "PLAYERS" { PLAYERS_MOD }
- | "MODEL" { MODEL_SPEC }
+ | "CURRENT" { CURRENT }
| "RULE" { RULE_SPEC }
| "STATE" { STATE_SPEC }
| "class" { CLASS }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Formula/Tokens.mly 2012-03-12 00:27:22 UTC (rev 1691)
@@ -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 MODEL_SPEC RULE_SPEC STATE_SPEC CLASS LFP GFP EOF
+%token CURRENT 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-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/GGP/TranslateGame.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -3186,8 +3186,7 @@
let tossrule = Aux.StrMap.find rname gdl.tossrule_data in
(* let rule = List.assoc rname (fst state).Arena.rules in *)
LOG 1 "GDL.translate_outgoing_move: rname=%s; emb={%s}"
- rname (String.concat ", "(List.map (fun (v, e)->
- let ename = Structure.elem_str (snd state).Arena.struc e in
+ rname (String.concat ", "(List.map (fun (v, ename)->
if ename = "control__blank_" then
AuxIO.print (Structure.sprint (snd state).Arena.struc);
v ^ ": " ^ ename
@@ -3195,7 +3194,8 @@
(* 10d *)
(* only the synchronization element should raise [Not_found] *)
- let emb = Aux.map_try (fun (v, struc_e) ->
+ let emb = Aux.map_try (fun (v, e) ->
+ let struc_e = Structure.elem_nbr (snd state).Arena.struc e in
LOG 4 "translate_outgoing_move: emb v=%s, struc_e=%d" v struc_e;
LOG 4 "translate_outgoing_move: emb lhs term=%s"
(term_str (Aux.StrMap.find v tossrule.rulevar_terms));
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/GGP/TranslateGame.mli 2012-03-12 00:27:22 UTC (rev 1691)
@@ -88,7 +88,7 @@
GDL.term list -> (int * (string * DiscreteRule.matching)) list
val translate_outgoing_move : gdl_translation ->
- (Arena.game * Arena.game_state) -> string -> (string * int) list -> string
+ (Arena.game * Arena.game_state) -> string -> (string * string) list -> string
val noop_move : gdl_translation -> Arena.game_state -> string
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -62,10 +62,10 @@
eq;
(* * Sys.remove ("./GGP/tests/"^game_name^"-temp.toss"); * *)
let rname = loc0_rule_name in
- let emb =
- Arena.matching_of_names res rname loc0_emb in
- let transl =
- TranslateGame.translate_outgoing_move gdl res rname emb in
+ let emb = Arena.matching_of_names res rname loc0_emb in
+ let emb_s = List.map (fun (v, e) ->
+ (v, Structure.elem_name (snd res).Arena.struc e)) emb in
+ let transl = TranslateGame.translate_outgoing_move gdl res rname emb_s in
assert_equal ~printer:(fun x->x) loc0_move transl;
let moves = match loc0_noop with
| Some loc0_noop -> [pte loc0_move; pte loc0_noop]
@@ -95,44 +95,6 @@
~printer:(emb_str res)
(norm_move (rname, emb)) (norm_move move)
-(* COPIED FROM ReqHandler. *)
-exception Found of int
-(* Players are indexed from 1 in graph (0 is Environment) *)
-let apply_rewrite (game,state as gstate) (player, (r_name, mtch)) =
- if r_name <> "" then (
- let {Arena.rules=rules; graph=graph} = game in
- let struc = state.Arena.struc in
- let mv_loc = graph.(state.Arena.cur_loc).(player) in
- let moves = Arena.gen_moves Arena.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
- (String.concat ", " (List.map (fun (lb,_)->lb.Arena.lb_rule)
- mv_loc.Arena.moves))
- (String.concat "; "
- (List.map (fun m->
- m.Arena.rule^":"^
- ContinuousRule.matching_str struc
- m.Arena.matching) (Array.to_list moves)));
- let pos = (
- try
- for i = 0 to Array.length moves - 1 do
- let mov = moves.(i) in
- if r_name = mov.Arena.rule && List.for_all
- (fun (e, f) -> f = List.assoc e mov.Arena.matching) mtch then
- raise (Found i)
- done;
- AuxIO.printf "apply_rewrite: failed for pl. num %d, r_name=%s\n%!"
- player r_name;
- failwith "GDL Play request: action mismatched with play state"
- with Found pos ->
- pos) in
- let req = (r_name, mtch, 0.1, []) in
- let (new_state_noloc, resp) = Arena.apply_rule_int gstate req in
- let new_loc = moves.(pos).Arena.next_loc in
- (fst new_state_noloc,
- {snd new_state_noloc with Arena.cur_loc = new_loc})
- ) else gstate
-
let simult_test_case ~game_name ~player ~plnum ~moves
~rules_and_embs =
let game = load_rules ("./GGP/examples/"^game_name^".gdl") in
@@ -158,9 +120,10 @@
rules_and_embs in
(* skipping environment -- 0th -- not given in the input array *)
let own_rname, _ = rules_and_embs.(plnum-1) in
+ let emb_s = List.map (fun (v, e) ->
+ (v, Structure.elem_name (snd res).Arena.struc e)) embs.(plnum-1) in
let transl =
- TranslateGame.translate_outgoing_move gdl res
- own_rname embs.(plnum-1) in
+ TranslateGame.translate_outgoing_move gdl res own_rname emb_s in
assert_equal ~printer:(fun x->x) moves.(plnum-1) transl;
let moves =
TranslateGame.translate_incoming_move gdl res
@@ -169,7 +132,7 @@
assert_equal ~msg:"own incoming move" ~printer:(emb_str res)
(norm_move (own_rname, embs.(plnum-1))) (norm_move move);
let res =
- List.fold_left apply_rewrite res moves in
+ List.fold_left Arena.apply_rewrite res moves in
(* TODO: perform a move by environment once it is nicely provided
by for example ReqHandler. *)
ignore res;
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -8,7 +8,7 @@
let s = "START " ^ s ^ " with Da (x, y) = ex u (R(x, u) and C(u, y));" ^
" Db (x, y) = ex u (C(x, u) and R(y, u))" in
match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
- | Arena.StateStruc struc -> struc
+ | Arena.StartStruc struc -> struc
| _ -> failwith "LearnGameTest:struc_of_string: not a structure"
else
StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Play/GameTree.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -251,7 +251,7 @@
let maxs = if maxs_exact <> [] then maxs_exact else
Aux.array_find_all (fun (_,c) -> (node_values c).(p) = mval) succ in
let nonleaf = function Leaf _ -> false | _ -> true in
- let move_s (m, n) = Arena.game_move_gs_str (state n) m in
+ let move_s (m, n) = Arena.game_move_str m in
LOG 3"\nBest Moves: %s" (String.concat ", " (List.map move_s maxs));
if List.exists (fun x -> nonleaf (snd x)) maxs then (
List.map (fun (m, t) -> (m, state t)) maxs
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Play/GameTreeTest.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -11,7 +11,7 @@
let struc_of_str s =
match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
- | Arena.StateStruc struc -> struc
+ | Arena.StartStruc struc -> struc
| _ -> failwith "GameTreeTest:struc_of_str: not a structure"
let state_of_file ?(struc="") ?(time=0.) ?(loc=0) fname =
Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Play/Play.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -50,7 +50,7 @@
try
let u = unfold_maximax ~ab:ab game heur t in
if (AuxIO.debug_level_for "Play" > 0) then AuxIO.printf "%d,%!" (size u);
- LOG 2 "(%s)," (let move_s (m, n) = Arena.game_move_gs_str n m in
+ LOG 2 "(%s)," (let move_s (m, _) = Arena.game_move_str m in
String.concat ", " (List.map move_s (List.hd mvs)));
unfold_maximax_upto ~ab:ab (count-1) game heur (u, mvs)
with
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Play/PlayTest.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -10,7 +10,7 @@
let struc_of_str s =
match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
- | Arena.StateStruc struc -> struc
+ | Arena.StartStruc struc -> struc
| _ -> failwith "GameTreeTest:struc_of_str: not a structure"
let state_of_file ?(struc="") ?(time=0.) ?(loc=0) fname =
@@ -28,7 +28,7 @@
let res_mvs = Play.maximax_unfold_choose iters g s h in
if res_mvs <> [] then
List.iter (fun (m, ns) ->
- let move_str = Arena.game_move_gs_str s m in
+ let move_str = Arena.game_move_str m in
assert_bool
(Printf.sprintf "%s: Failed move: %s." msg move_str) (cond move_str)
) res_mvs
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/Server/Server.ml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -161,7 +161,7 @@
let (move, _) = Aux.random_elem (Play.maximax_unfold_choose 1000000
(fst gs) (snd gs) heur) in
Play.cancel_timeout ();
- let resp = Arena.game_move_gs_str (snd gs) move in
+ let resp = Arena.game_move_str move in
LOG 1 "%s" resp;
http_msg false "200 OK" "text/html; charset=utf-8" [] resp
Modified: trunk/Toss/www/codebasics.xml
===================================================================
--- trunk/Toss/www/codebasics.xml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/codebasics.xml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -7,7 +7,7 @@
<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 (à anglais)</title>
+ <title lang="fr">Toss Code Basics Tutorial (en anglais)</title>
<history>
<link id="develop" href="/develop.html">Develop Toss</link>
</history>
Modified: trunk/Toss/www/create.xml
===================================================================
--- trunk/Toss/www/create.xml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/create.xml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -7,7 +7,7 @@
<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 de Nouveaux Jeux</title>
+ <title lang="fr">Créez des jeux nouveaux</title>
<history>
<link id="docs" href="/docs.html">Documentation</link>
<link id="create" href="/create.html">Create</link>
@@ -54,11 +54,11 @@
</itemize>
</section>
<section title="Fichiers toss" lang="fr">
- <par>Pour comprendre de texte dans les fichiers .toss, vous
- devriez se familiariser avec Toss: au moins parcourir
- <a href="reference/reference.pdf">Reference.pdf</a> et regardez à notre
- <a href="docs.html">documentation</a>. Après cela, vous pouvez simplement
- éditer le fichier .toss, peut-être en commençant par l'un de ces.
+ <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>
@@ -69,31 +69,28 @@
<section title="More Complex Games" lang="en">
- <par>To create more complex games, like Chess, it may be more
- convenient to edit directly the textual game definition files,
- rather than using only the GUI. Here are a few standard
- games defined in Toss. You can them use as a starting point
- for your own definitions.</par>
+ <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, kann es
- bequemer sein, direkt die text Files (.toss) 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>
+ <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,
- wygodniej edytować bezpośrednio pliki .toss niż używać tylko GUI.
+ 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="Jeux Plus Complexes" lang="fr">
- <par>
- Pour créer des jeux plus complexes, comme les échecs, il peut être plus
- pratique pour modifier directement le définition de jeu dans le fichier
- textuels .toss, plutôt que d'utiliser seulement l'interface graphique.
- Voici quelques jeux définies dans Toss. Vous pouvez les utiliser comme
- le point de départ pour vos propres définitions.
+ <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>
Modified: trunk/Toss/www/ideas.xml
===================================================================
--- trunk/Toss/www/ideas.xml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/ideas.xml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -7,7 +7,7 @@
<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 (à anglais)</title>
+ <title lang="fr">Idées de Développement (en anglais)</title>
<history>
<link id="develop" href="/develop.html">Develop Toss</link>
<link id="ideas" href="/ideas.html">Development Ideas</link>
Modified: trunk/Toss/www/navigation.xml
===================================================================
--- trunk/Toss/www/navigation.xml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/navigation.xml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -74,8 +74,8 @@
<item href="http://sourceforge.net/project/showfiles.php?group_id=115606"
>Téléchargez</item>
<menu title="Documentation" href="/docs.html" id="docs">
- <item href="/create.html" id="create">Créez des Jeux</item>
- <item href="/play.html" id="play">Regardez Toss Jouer</item>
+ <item href="/create.html" id="create">Créez des jeux</item>
+ <item href="/play.html" id="play">Regardez le Toss jouer</item>
<item href="/learn.html" id="learn">Toss Apprend</item>
<item href="/Publications/" id="Publications">Papiers, Entretiens</item>
<item href="/reference/reference.pdf" id="refpdf">Référence (pdf)</item>
Modified: trunk/Toss/www/ocaml.xml
===================================================================
--- trunk/Toss/www/ocaml.xml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/ocaml.xml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -7,7 +7,7 @@
<title lang="en">Mini OCaml Tutorial</title>
<title lang="de">Mini OCaml Tutorial (auf Englisch)</title>
<title lang="pol">Mini OCaml Tutorial (po angielsku)</title>
- <title lang="fr">Mini OCaml Tutorial (à anglais)</title>
+ <title lang="fr">Mini OCaml Tutorial (en anglais)</title>
<history>
<link id="develop" href="/develop.html">Develop Toss</link>
</history>
Modified: trunk/Toss/www/play.xml
===================================================================
--- trunk/Toss/www/play.xml 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/play.xml 2012-03-12 00:27:22 UTC (rev 1691)
@@ -7,7 +7,7 @@
<title lang="en">Watch Toss Play</title>
<title lang="de">Wie Toss Spielt</title>
<title lang="pol">Jak Toss Gra</title>
- <title lang="fr">Regardez Toss Jouer</title>
+ <title lang="fr">Regardez le Toss jouer</title>
<history>
<link id="docs" href="/docs.html">Documentation</link>
<link id="play" href="/play.html">Toss Play</link>
@@ -22,7 +22,6 @@
doing great work. Players which accept games in the GDL format can
play on the <a href="http://euklid.inf.tu-dresden.de:8180/ggpserver/">
Dresden GGP Server</a> and Toss recently started competing there as well.
- <br/>
Games in GDL format are not directly suited for online presentation, but
the <a href="http://code.google.com/p/ggp-galaxy/">GGP Galaxy Project</a>
has recently started to work on bringing them online – something
@@ -39,7 +38,6 @@
<a href="http://euklid.inf.tu-dresden.de:8180/ggpserver/">
Dresden GGP Server</a> gegeneinander spielen lassen, und Toss hat
da in letzter Zeit auch einige erfolgreiche Partien gespielt.
- <br/>
Spiele im GDL-Format lassen sich nicht direkt Online darstellen, aber
das <a href="http://code.google.com/p/ggp-galaxy/">GGP Galaxy Project</a>
hat vor kurzem angefangen zu versuchen, dieses Problem zu beseitigen.
@@ -55,7 +53,6 @@
Programy grające w gry w formacie GDL mogą rywalizować ze sobą na serwerze
<a href="http://euklid.inf.tu-dresden.de:8180/ggpserver/">
Dresden GGP Server</a>, gdzie Toss ostatnio też odnosił pewne sukcesy.
- <br/>
Gry w formacie GDL nie są niestety przystosowane do bezpośredniego
oglądania i grania przez ludzi, w przeciwieństwie do gier Tossa, choć
<a href="http://code.google.com/p/ggp-galaxy/">GGP Galaxy Project</a>
@@ -65,14 +62,15 @@
</section>
<section title="Jouer Générale (General Game Playing)" lang="fr">
<a href="http://en.wikipedia.org/wiki/General_Game_Playing">General
- Game Playing</a>, GGP, est un nom pour la tâche de jouer un jeu
- jusque-là inconnues. GGP est actuellement un domaine populaire de l'IA,
- avec des gens à <a href="http://games.stanford.edu/">Stanford</a> et en
- <a href="http://www.general-game-playing.de/">Allemagne</a> à travailler
- dessus. Les logiciels qui acceptent les jeux au format GDL peuvent jouer
- sur le <a href="http://euklid.inf.tu-dresden.de:8180/ggpserver/">
- Dresden GGP Serveur</a> et Toss récemment commencé la compétition il ainsi.
- <br/>
+ Game Playing</a>, GGP, correspond à un problème de jouer à un jeu inconnu
+ auparavant. GGP est actuellement un populaire champ de recherche de l'IA,
+ avec les équipes à <a href="http://games.stanford.edu/">Stanford</a> et
+ en <a href="http://www.general-game-playing.de/">Allemagne</a>
+ travaillant sur ce problème. Les logiciels qui acceptent les jeux en
+ format GDL peuvent jouer sur le
+ <a href="http://euklid.inf.tu-dresden.de:8180/ggpserver/">
+ Dresden GGP Serveur</a>.
+ Récemment le Toss est entré dans la compétition lui aussi.
Jeux en format GDL ne sont pas directement adaptée à la présentation
en ligne, mais le <a href="http://code.google.com/p/ggp-galaxy/">GGP
Galaxy Project</a> a récemment commencé à travailler sur la mise
Modified: trunk/Toss/www/xsl/common.xsl
===================================================================
--- trunk/Toss/www/xsl/common.xsl 2012-03-11 17:33:19 UTC (rev 1690)
+++ trunk/Toss/www/xsl/common.xsl 2012-03-12 00:27:22 UTC (rev 1691)
@@ -97,9 +97,9 @@
<p><a href="http://tplay.org">Więcej gier</a></p>
</xsl:when>
<xsl:when test="$lang='fr'">
- <h3><a href="http://tplay.org">Jouez en Ligne contre Toss</a></h3>
+ <h3><a href="http://tplay.org">Jouez en Ligne contre le Toss</a></h3>
<xsl:apply-templates />
- <p><a href="http://tplay.org">Plus de Jeux</a></p>
+ <p><a href="http://tplay.org">Plus de jeux</a></p>
</xsl:when>
<xsl:otherwise>
<h3><a href="http://tplay.org">Play Online Against Toss</a></h3>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-12 11:26:23
|
Revision: 1692
http://toss.svn.sourceforge.net/toss/?rev=1692&view=rev
Author: lukaszkaiser
Date: 2012-03-12 11:26:12 +0000 (Mon, 12 Mar 2012)
Log Message:
-----------
Small Client-Server corrections.
Modified Paths:
--------------
trunk/Toss/Client/Main.js
trunk/Toss/Client/index.html
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-12 00:27:22 UTC (rev 1691)
+++ trunk/Toss/Client/Main.js 2012-03-12 11:26:12 UTC (rev 1692)
@@ -60,7 +60,21 @@
function startup () {
- // should do some work here perhaps
+ if (navigator.userAgent.indexOf('MSIE') != -1 &&
+ navigator.userAgent.indexOf('MSIE 9') == -1) {
+ document.getElementById("nosvg").style.display = "block";
+ }
+ if (window.location.href.indexOf("?simple=true") > 0) {
+ document.getElementById ("ads").style.display = "none";
+ document.getElementById ("more-games-bt-div").style.display = "none";
+ }
+ var gindex = window.location.href.indexOf("?game=")
+ var cur_game = "";
+ if (gindex > 0) {
+ cur_game = window.location.href.substring(gindex+6,
+ window.location.href.length)
+ }
+ if (cur_game != "") { new_play_click (cur_game); }
}
function new_play_click (game) {
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-12 00:27:22 UTC (rev 1691)
+++ trunk/Toss/Client/index.html 2012-03-12 11:26:12 UTC (rev 1692)
@@ -15,6 +15,8 @@
<body onload="startup ('')">
+<div id="ads">
+</div>
<div id="main">
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-12 00:27:22 UTC (rev 1691)
+++ trunk/Toss/Server/Server.ml 2012-03-12 11:26:12 UTC (rev 1692)
@@ -3,15 +3,18 @@
let debug_level = ref 0
-let quit_on_eof = ref false
-
-let html_dir_path = ref "Client/"
-
let set_debug_level i =
debug_level := i;
AuxIO.set_debug_level "GameTree" i;
AuxIO.set_debug_level "Play" i
+
+let quit_on_eof = ref false
+let html_dir_path = ref "Client/"
+let cache_html = ref true
+let html_req_counter = ref 0
+let html_cache = Hashtbl.create 7
+
let init_state =
(None, true, Arena.empty_state, TranslateGame.empty_gdl_translation, 0)
@@ -111,6 +114,16 @@
(if cookies = [] then "" else cookies_s ^ "\r\n") ^
"Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+let mime_type fname =
+ match String.sub fname ((String.index fname '.') + 1) 2 with
+ | "ht" -> "text/html; charset=utf-8"
+ | "ic" -> "image/x-icon"
+ | "pn" -> "image/png"
+ | "cs" -> "text/css"
+ | "js" -> "text/javascript"
+ | "sv" -> "image/svg+xml"
+ | _ -> "text/html charset=utf-8"
+
let handle_http_get cmd head msg ck =
if !debug_level > 1 then (
Printf.printf "Http Get Handler\n%s%s\n%!" cmd msg;
@@ -124,20 +137,18 @@
with Not_found -> fname_in1 in
let fname = !html_dir_path ^ fname_in in
if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
- if Sys.file_exists fname && not (Sys.is_directory fname) then (
- let content = AuxIO.input_file fname in
- let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
- | "ht" -> "text/html; charset=utf-8"
- | "ic" -> "image/x-icon"
- | "pn" -> "image/png"
- | "cs" -> "text/css"
- | "js" -> "text/javascript"
- | "sv" -> "image/svg+xml"
- | _ -> "text/html charset=utf-8" in
- http_msg true "200 OK" tp [] content
- ) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
- ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
- "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
+ try if not !cache_html then raise Not_found else
+ let content = Hashtbl.find html_cache fname in
+ LOG 1 "Found %s in html cache" fname;
+ http_msg true "200 OK" (mime_type fname) [] content
+ with Not_found ->
+ if Sys.file_exists fname && not (Sys.is_directory fname) then (
+ let content = AuxIO.input_file fname in
+ if !cache_html then Hashtbl.add html_cache fname content;
+ http_msg true "200 OK" (mime_type fname) [] content
+ ) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
+ ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
+ "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
let handle_http_post msg =
let split_msg = Aux.split_charprop (fun c -> c = '#') msg in
@@ -167,7 +178,10 @@
let handle_http_msg rstate cmd head msg ck =
if String.sub cmd 0 5 = "GET /" then
- Aux.Left (rstate, handle_http_get cmd head msg ck)
+ if !html_req_counter < 50 then ( (* cache a few first requests: no fork *)
+ incr html_req_counter;
+ Aux.Left (rstate, handle_http_get cmd head msg ck)
+ ) else Aux.Right (rstate, fun () -> handle_http_get cmd head msg ck)
else if String.length cmd > 13 && String.sub cmd 0 13 = "POST /Handler" then
Aux.Right (rstate, fun () -> handle_http_post msg)
else try Aux.Left (req_handle rstate
@@ -396,6 +410,8 @@
("-fulltest", Arg.String (fun s -> test_s := s; test_full := true),
"full unit tests for given path, might take longer");
("-noprecache", Arg.Unit (fun ()-> precache := false), "do no pre-caching");
+ ("-nohttpcache", Arg.Unit (fun ()-> cache_html := false),
+ "re-read files from disk on each HTTP GET request");
("-html", Arg.String (fun s -> html_dir_path := s),
"set path to the directory with html files for the client");
("-use-parallel", Arg.Tuple [Arg.Int (fun p -> set_parallel_port p);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-15 00:19:05
|
Revision: 1694
http://toss.svn.sourceforge.net/toss/?rev=1694&view=rev
Author: lukaszkaiser
Date: 2012-03-15 00:18:58 +0000 (Thu, 15 Mar 2012)
Log Message:
-----------
Simple python script to run server and browser, other small corrections.
Modified Paths:
--------------
trunk/Toss/Client/Main.js
trunk/Toss/Client/index.html
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/Client/support.html
trunk/Toss/Toss.py
Removed Paths:
-------------
trunk/Toss/run_server.sh
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/Client/Main.js 2012-03-15 00:18:58 UTC (rev 1694)
@@ -27,9 +27,7 @@
var GAME_NAME = ""; // name of current game, e.g. "Breakthrough"
var PLAY = [];
-var SIMPLE_SET = false;
-
function disp_name (uname) {
if (uname == "guest") { return ("You"); }
if (uname == "computer") { return ("Computer"); }
@@ -66,6 +64,10 @@
}
if (window.location.href.indexOf("?simple=true") > 0) {
document.getElementById ("ads").style.display = "none";
+ document.getElementById ("leftupperlogo-link").href =
+ "index.html?simple=true";
+ document.getElementById ("backlink-games").href =
+ "index.html?simple=true";
document.getElementById ("more-games-bt-div").style.display = "none";
}
var gindex = window.location.href.indexOf("?game=")
@@ -210,7 +212,7 @@
} else {
console.log ("Discarded " + m.comp_iters +" iterations.");
}
- }, 700); // wait 500 miliseconds more than the 0.2s speedup for local
+ }, 1000); // wait 800 miliseconds more than the 0.2s speedup for local
};
// ASYNCH does not implement multiple plays
// I'm not sure about players being numbered from 1
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/Client/index.html 2012-03-15 00:18:58 UTC (rev 1694)
@@ -33,7 +33,7 @@
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
><img style="height: 24px;" src="img/appstore-small.png" /></a>
</span>
-<span id="toprighttab"><a href="index.html">Games</a></span>
+<span id="toprighttab"><a id="backlink-games" href="index.html">Games</a></span>
</div>
<div id="welcome">
Added: trunk/Toss/Client/support.html
===================================================================
--- trunk/Toss/Client/support.html (rev 0)
+++ trunk/Toss/Client/support.html 2012-03-15 00:18:58 UTC (rev 1694)
@@ -0,0 +1,113 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xmlns:svg="http://www.w3.org/2000/svg" xml:lang="en" lang="en">
+<head>
+ <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
+ <title>tPlay — Support</title>
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
+ <link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
+</head>
+
+<body>
+
+<div id="main">
+
+<div id="top">
+<div id="logo"><a href="index.html"><img src="img/logo.png" alt="tPlay" /></a></div>
+<div id="topbar"><span id="topuser">Support</span></div>
+</div>
+
+<div style="font-size: 1.1em; margin: 1em; padding: 1em;">
+
+<h2>Contact Us</h2>
+<p style="line-height: 130%;">
+Thank you for your interest in tPlay! We try to make our interface as
+intuitive and simple as possible, and we hope it is mostly self-explanatory.
+If you encounter any problems, have some remarks or just want to tell us
+how you feel about tPlay, write us an email.<br/>
+<span style="position: relative; top: 0px; left: 15em;">
+<script type="text/javascript">
+// Email address obfuscation to prevent some spamming.
+function begin_mailto (name, domain, title) {
+ var address = name + '@' + domain;
+ if(title) {
+ document.write("<a class='contact' href='mailto:" + address + "'>" +
+ title + "<span style='display: none;'>");
+ } else {
+ document.write("<a class='contact' href='mailto:" + address + "'>" +
+ address + "<span style='display: none;'>");
+ }
+}
+
+function end_mailto() {
+ document.write("</span></a>");
+}
+begin_mailto("tossplay", "gmail.com",
+ "Email tos...@gm...");</script>tossplay [AT] gmail [DOT] com
+<script type="text/javascript">end_mailto();</script>
+</span>
+<br/>
+</p>
+
+<h2>How Do I Move?</h2>
+<p style="line-height: 130%;">
+At tPlay you make moves just by clicking on the fields from and to which you
+move. In case there is only a single possible move, it is made directly to
+speed up the play. If you make moves by mistake, activate the
+<span style="font-weight: bold;">Ask Before Move</span> control
+in the bottom-left of the screen. Then you will be asked to confirm
+each selected move before it is taken.
+</p>
+
+<h2>What Are The Rules Of The Games?</h2>
+<ul>
+ <li>Breakthrough — break through opponent's lines, see
+ <a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)"
+ style="color: #400827;">Breakthrough on Wikipedia</a>
+<li>Checkers — beat opponent's pieces, see
+ <a href="http://en.wikipedia.org/wiki/English_draughts"
+ style="color: #400827;">Checkers on Wikipedia</a>
+<li>Chess — check-mate, see
+ <a href="http://en.wikipedia.org/wiki/Chess"
+ style="color: #400827;">Chess on Wikipedia</a>
+<li>Connect4 — make a line of four, see
+ <a href="http://en.wikipedia.org/wiki/Connect4"
+ style="color: #400827;">Connect4 on Wikipedia</a>
+</li>
+<li>Gomoku — make a line of five, see
+ <a href="http://en.wikipedia.org/wiki/Gomoku"
+ style="color: #400827;">Gomoku on Wikipedia</a>
+</li>
+<li>Pawn-Whopping — get a pawn to the other end, see
+ <a href="http://en.wikipedia.org/wiki/Pawn_(chess)"
+ style="color: #400827;">Pawn Moves on Wikipedia</a>
+</li>
+</ul>
+
+<h2>How Do I Set The Playing Level?</h2>
+<p style="line-height: 130%;">
+The level at tPlay varies according to the
+<span style="font-weight: bold;">Speed</span> setting in the top right
+corner of the screen. Increase the time for slower but better moves.
+</p>
+
+<h2>Can I Play Other Games?</h2>
+<p style="line-height: 130%;">
+We are adding new games to tPlay all the time.
+Email us your suggestion if you desire a particular game!
+</p>
+
+</div>
+
+<div id="bottom">
+<div id="bottomright">
+<a href="http://toss.sourceforge.net" id="toss-link">Contact</a>
+</div>
+</div>
+
+</div>
+
+
+</body>
+</html>
+
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/Server/Server.ml 2012-03-15 00:18:58 UTC (rev 1694)
@@ -156,6 +156,7 @@
LOG 2 "%s" (String.concat "\n\n" split_msg);
let timeout, gs_s, heurs_s = float_of_string (List.hd split_msg),
List.hd (List.tl split_msg), List.tl (List.tl split_msg) in
+ Play.set_timeout timeout;
let gs = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string gs_s) in
let heurs = ref (List.map (fun s ->
FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)) heurs_s) in
@@ -168,7 +169,6 @@
done;
let heur = Array.of_list (List.rev !res_lst) in
Random.self_init ();
- Play.set_timeout timeout;
let (move, _) = Aux.random_elem (Play.maximax_unfold_choose 1000000
(fst gs) (snd gs) heur) in
Play.cancel_timeout ();
Added: trunk/Toss/Toss.py
===================================================================
--- trunk/Toss/Toss.py (rev 0)
+++ trunk/Toss/Toss.py 2012-03-15 00:18:58 UTC (rev 1694)
@@ -0,0 +1,34 @@
+#!/usr/bin/env python
+
+import sys, subprocess, os
+
+def createdir (d):
+ try:
+ os.mkdir (d)
+ print (d + " created")
+ except OSError:
+ print (d + " exists")
+
+
+server = subprocess.Popen(["./TossServer"], stdout=subprocess.PIPE);
+
+caching = True
+while caching:
+ l = server.stdout.readline()
+ if (l.find("caching finished") > -1): caching = False
+
+profiledir = os.getenv("HOME") + "/.tossfirefoxprofile"
+createdir (profiledir)
+f = open (profiledir + "/user.js", "w")
+f.write ('user_pref("browser.tabs.autoHide", true);')
+f.close ()
+createdir (profiledir + "/chrome")
+f = open (profiledir + "/chrome/userChrome.css", "w")
+f.write ('#nav-bar { display: none; }')
+f.close ()
+
+subprocess.call(["firefox", "-no-remote", "--profile", profiledir,
+ "http://localhost:8110/index.html?simple=true"])
+
+server.terminate()
+print "Finished"
Property changes on: trunk/Toss/Toss.py
___________________________________________________________________
Added: svn:executable
+ *
Deleted: trunk/Toss/run_server.sh
===================================================================
--- trunk/Toss/run_server.sh 2012-03-12 14:12:20 UTC (rev 1693)
+++ trunk/Toss/run_server.sh 2012-03-15 00:18:58 UTC (rev 1694)
@@ -1,3 +0,0 @@
-#!/bin/bash
-# Example script to run the TossServer
-OCAMLRUNPARAM=b; export OCAMLRUNPARAM; /var/www/TossServer -d 0 -eof -mail -nosave -html /var/www/html/ -p 80 -s tplay.org -tID toss_id_0679_ -db /var/www/db/tossdb.sqlite &> /var/www/server_log &
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-16 01:52:31
|
Revision: 1695
http://toss.svn.sourceforge.net/toss/?rev=1695&view=rev
Author: lukaszkaiser
Date: 2012-03-16 01:52:25 +0000 (Fri, 16 Mar 2012)
Log Message:
-----------
Use gzip-compressed js files in TossServer.
Modified Paths:
--------------
trunk/Toss/Client/.cvsignore
trunk/Toss/Client/Makefile
trunk/Toss/Client/index.html
trunk/Toss/Makefile
trunk/Toss/Server/Server.ml
Property Changed:
----------------
trunk/Toss/Client/
Property changes on: trunk/Toss/Client
___________________________________________________________________
Modified: svn:ignore
- # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
clientTestRender*.png
*~
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
JsHandler.js
clientTestRender*.png
*.js.gz
*~
Modified: trunk/Toss/Client/.cvsignore
===================================================================
--- trunk/Toss/Client/.cvsignore 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Client/.cvsignore 2012-03-16 01:52:25 UTC (rev 1695)
@@ -4,4 +4,5 @@
JsHandler.js
clientTestRender*.png
+*.js.gz
*~
Modified: trunk/Toss/Client/Makefile
===================================================================
--- trunk/Toss/Client/Makefile 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Client/Makefile 2012-03-16 01:52:25 UTC (rev 1695)
@@ -4,6 +4,14 @@
make -C .. Client/JsHandler.js
phantomjs clientTest.js
+JSFILES = $(notdir $(shell find . -maxdepth 1 -name '*.js'))
+JSGZFILES = $(addsuffix .gz, $(JSFILES))
+
+%.js.gz: %.js
+ gzip --best -c $< > $@
+
+alljsgz: $(JSGZFILES)
+
tests: ClientTest
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Client/index.html 2012-03-16 01:52:25 UTC (rev 1695)
@@ -31,7 +31,7 @@
</span>
<span id="appstorelink">
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
- ><img style="height: 24px;" src="img/appstore-small.png" /></a>
+ ><img style="height: 24px; width: 69px;" src="img/appstore-small.png" /></a>
</span>
<span id="toprighttab"><a id="backlink-games" href="index.html">Games</a></span>
</div>
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Makefile 2012-03-16 01:52:25 UTC (rev 1695)
@@ -12,8 +12,10 @@
make $(basename $@).byte
$(JSOCAML) _build/$(basename $@).byte
cat _build/$@ > $@
+ gzip --best -c $@ > $@.gz
TossClient: Client/JsHandler.js
+ make -C Client alljsgz
RELEASE=0.7
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-15 00:18:58 UTC (rev 1694)
+++ trunk/Toss/Server/Server.ml 2012-03-16 01:52:25 UTC (rev 1695)
@@ -1,10 +1,9 @@
(* Server for Toss Functions. *)
open OUnit
-let debug_level = ref 0
let set_debug_level i =
- debug_level := i;
+ AuxIO.set_debug_level "Server" i;
AuxIO.set_debug_level "GameTree" i;
AuxIO.set_debug_level "Play" i
@@ -86,7 +85,7 @@
(* ------------ Http Handlers ------------ *)
-let http_msg get code mimetp cookies s =
+let http_msg ?(gz=false) get code mimetp cookies s =
let get_tm s =
let t = Unix.gmtime (Unix.gettimeofday() +. s) in
let day = match t.Unix.tm_wday with
@@ -106,16 +105,23 @@
let cookies_s = String.concat "\n" (List.map ck_str cookies) in
let expires_str = if not get then "" else
"Expires: " ^ (get_tm (float (40 * 24 * 3600))) ^ "\r\n" in
- "HTTP/1.1 " ^ code ^ "\r\n" ^
- "Date: " ^ (get_tm 0.) ^ "\r\n" ^
- "Server: Toss\r\n" ^
- expires_str ^
- "Content-Type: " ^ mimetp ^ "\r\n" ^
- (if cookies = [] then "" else cookies_s ^ "\r\n") ^
- "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+ let head =
+ "HTTP/1.1 " ^ code ^ "\r\n" ^
+ "Date: " ^ (get_tm 0.) ^ "\r\n" ^
+ "Server: Toss\r\n" ^
+ expires_str ^
+ "Content-Type: " ^ mimetp ^ "\r\n" ^
+ (if mimetp = "image/png" then "Cache-Control: public\r\n" else "") ^
+ (if gz then "Content-Encoding: gzip\r\n" else "") ^
+ (if cookies = [] then "" else cookies_s ^ "\r\n") ^
+ "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" in
+ LOG 2 "%s" head;
+ head ^ s
+let ext_two s = String.sub s ((String.index s '.') + 1) 2
+
let mime_type fname =
- match String.sub fname ((String.index fname '.') + 1) 2 with
+ match ext_two fname with
| "ht" -> "text/html; charset=utf-8"
| "ic" -> "image/x-icon"
| "pn" -> "image/png"
@@ -125,7 +131,7 @@
| _ -> "text/html charset=utf-8"
let handle_http_get cmd head msg ck =
- if !debug_level > 1 then (
+ if AuxIO.debug_level_for "Server" > 1 then (
Printf.printf "Http Get Handler\n%s%s\n%!" cmd msg;
if ck <> [] then
let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
@@ -136,16 +142,18 @@
let fname_in = try String.sub fname_in1 0 (String.index fname_in1 '?')
with Not_found -> fname_in1 in
let fname = !html_dir_path ^ fname_in in
- if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
+ let gz= ext_two fname= "js"&& Aux.str_contains head "Accept-Encoding: gzip" in
+ let fname = if gz then fname ^ ".gz" else fname in
+ LOG 1 "SERVING FILE: %s" fname;
try if not !cache_html then raise Not_found else
let content = Hashtbl.find html_cache fname in
LOG 1 "Found %s in html cache" fname;
- http_msg true "200 OK" (mime_type fname) [] content
+ http_msg ~gz true "200 OK" (mime_type fname) [] content
with Not_found ->
if Sys.file_exists fname && not (Sys.is_directory fname) then (
let content = AuxIO.input_file fname in
if !cache_html then Hashtbl.add html_cache fname content;
- http_msg true "200 OK" (mime_type fname) [] content
+ http_msg ~gz true "200 OK" (mime_type fname) [] content
) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
@@ -209,17 +217,17 @@
(String.sub line 0 (line_len-1)) in
match AuxIO.input_if_http_message line in_ch with
| Some (head, msg, cookies) ->
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
+ LOG 1 "Rcvd: %s" msg;
let strip_ws = Aux.strip_spaces in
let ck = List.map (fun (k, v) -> (strip_ws k, strip_ws v)) cookies in
("HTTP", Some (Aux.Left (line, head, msg, ck)))
| None ->
if line = "COMP" then
let res = Marshal.from_channel in_ch in
- if !debug_level > 0 then Printf.printf "COMP, %!";
+ LOG 1 "COMP";
("COMP", Some (Aux.Right res))
else (
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
+ LOG 1 "Rcvd: %s" line;
(line, None)
)
@@ -228,11 +236,8 @@
try
let time_started = Unix.gettimeofday () in
let report (new_rstate, resp) continue =
- if !debug_level > 0 then (
- Printf.printf "Resp-time: %F\n%!" (Unix.gettimeofday() -. time_started);
- if !debug_level > 1 || String.length resp < 500 then
- print_endline ("\nRepl: " ^ resp ^ "\n");
- );
+ LOG 1 "Resp-time: %F" (Unix.gettimeofday() -. time_started);
+ LOG 2 "%s\n" (if String.length resp < 500 then "\nRepl: " ^ resp else "");
output_string out_ch (resp ^ "\n");
flush out_ch;
(new_rstate, continue) in
@@ -312,8 +317,7 @@
if !continue then (* collect zombies *)
try ignore (Unix.waitpid [Unix.WNOHANG] (-1)); with
Unix.Unix_error (e,_,_) ->
- if !debug_level > 1 then
- Printf.printf "UNIX WAITPID: %s\n%!" (Unix.error_message e);
+ LOG 2 "UNIX WAITPID: %s\n%!" (Unix.error_message e);
else (try Unix.close cl_sock with _ -> (); Unix.close sock)
done
@@ -362,7 +366,6 @@
let server_tests = "Server" >::: [
"ServerGDLTest.in GDL Tic-Tac-Toe automatic" >::
(fun () ->
- (* Solver.set_debug_level 2; *)
let old_force_competitive = !Heuristic.force_competitive in
let old_use_monotonic = !Heuristic.use_monotonic in
Heuristic.use_monotonic := true;
@@ -432,7 +435,7 @@
String.sub f 0 (String.index f '.')
else f in
([String.sub name 0 slash], [file]) in
- let verbose = !debug_level > 0 in
+ let verbose = AuxIO.debug_level_for "Server" > 0 in
set_debug_level 0;
quit_on_eof := true;
ignore (OUnit.run_test_tt ~verbose
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-21 20:03:26
|
Revision: 1696
http://toss.svn.sourceforge.net/toss/?rev=1696&view=rev
Author: lukaszkaiser
Date: 2012-03-21 20:03:14 +0000 (Wed, 21 Mar 2012)
Log Message:
-----------
Client and website corrections.
Modified Paths:
--------------
trunk/Toss/Client/Main.js
trunk/Toss/Client/Play.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/www/develop.xml
trunk/Toss/www/docs.xml
trunk/Toss/www/ideas.xml
trunk/Toss/www/index.xml
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/Main.js 2012-03-21 20:03:14 UTC (rev 1696)
@@ -35,7 +35,9 @@
}
nameDISP = disp_name;
+var BLOCKED = false
function handle_elem_click (elem) {
+ if (BLOCKED) return;
PLAY.handle_click (elem);
}
@@ -108,6 +110,8 @@
document.getElementById ("game-title-move").style.display = "inline";
document.getElementById ("game-desc-controls").style.display = "block";
document.getElementById ("suggestions-toggle").style.display = "inline";
+ document.getElementById ("new_game_me_bottom").style.display = "inline";
+ document.getElementById ("new_game_opp_bottom").style.display= "inline";
document.getElementById ("game-disp").style.display = "block";
document.getElementById ("plays").style.left = "30em";
var p = new Play (GAME_NAME, [0,1], [UNAME, opp_uid], 1, 0,
@@ -197,8 +201,10 @@
var DONE_MOVES_MARKER = {}
var MOVE_INDEX = 0
function suggest_move_async (time, f) {
+ BLOCKED = true;
show_moving_msg (time);
var fm = function (m) {
+ BLOCKED = false;
document.getElementById("working").style.display = "none";
document.getElementById("working").innerHTML = "Working...";
console.log ("Algorithm performed " +m.comp_iters +" iterations.");
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/Play.js 2012-03-21 20:03:14 UTC (rev 1696)
@@ -82,8 +82,6 @@
// Handler for clicks on elements in a play.
function play_handle_click (elem) {
- if (typeof CONN != 'undefined' && ASYNC_ALL_REQ_PENDING != 0)
- { return; }
var moves = this.cur_state.get_moves (elem, this.LAST_CLICKED_ELEM);
if (moves.length == 0) {
this.LAST_CLICKED_ELEM = "";
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/Style.css 2012-03-21 20:03:14 UTC (rev 1696)
@@ -268,26 +268,50 @@
top: 2px;
}
+#speedtab {
+ position: absolute;
+ right: 5em;
+ top: .6em;
+ height: 1.5em;
+ background-color: #400827;
+ border-color: #fff1d4;
+ border-style: solid;
+ border-width: 0px 2px 0px 2px;
+ /*border-radius: 6px 6px 0px 0px; */
+ padding-top: 0.1em;
+ padding-bottom: 0.2em;
+ padding-left: 0.2em;
+ padding-right: 0.2em;
+ border-radius: 0px;
+ -moz-border-radius: 0px;
+ /*font-size: 0.9em;
+ -moz-border-radius: 6px 6px 0px 0px; */
+}
+
#speed {
position: relative;
- top: -0.1em;
font-weight: bold;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
- font-size: 0.8em;
color: #fff1d4;
- background-color: #777777;
+ background: none;
+ /* background-color: #400827 */
+ font-size: 1em;
padding: 0px;
margin: 0px;
border-color: #fff1d4;
- border-radius: 4px;
- -moz-border-radius: 4px;
+ /*border-radius: 4px;
+ -moz-border-radius: 4px;*/
border-width: 0px;
}
+#speed:hover {
+ cursor: pointer;
+}
+
.speed_val {
color: #fff1d4;
font-weight: bold;
- background-color: #666666;
+ background-color: #400827;
border-width: 0px;
}
@@ -479,19 +503,20 @@
#toprighttab {
display: none;
position: absolute;
- right: 1em;
- top: 1.3em;
- background-color: #260314;
+ right: .5em;
+ top: .6em;
+ height: 1.5em;
+ /*background-color: #260314;*/
border-color: #fff1d4;
border-style: solid;
- border-width: 2px 2px 0px 2px;
- border-radius: 6px 6px 0px 0px;
+ border-width: 0px;
+ /*border-radius: 6px 6px 0px 0px; */
padding-top: 0.1em;
padding-bottom: 0.2em;
padding-left: 0.2em;
padding-right: 0.2em;
- font-size: 0.9em;
- -moz-border-radius: 6px 6px 0px 0px;
+ /*font-size: 0.9em;
+ -moz-border-radius: 6px 6px 0px 0px; */
}
#bottom {
@@ -527,11 +552,11 @@
#bottomright {
position: absolute;
top: 0em;
- right: 1em;
+ right: 0em;
margin-right: 0em;
}
-#toss-link, .contact, #suggestions-toggle {
+#toss-link, #suggestions-toggle, #new_game_me_bottom, #new_game_opp_bottom {
position: relative;
top: -1px;
padding-left: 0.5em;
@@ -540,21 +565,27 @@
font-size: 1em;
font-weight: bold;
font-family: Verdana;
- background-color: #260314;
+ background-color: #400827; /* #260314 */
border-color: #fff1d4;
border-style: solid;
- border-width: 0px 2px 2px 2px;
+ border-width: 0px 0px 0px 2px;
+ /*border-width: 0px 2px 2px 2px;
border-radius: 0px 0px 6px 6px;
- -moz-border-radius: 0px 0px 6px 6px;
+ -moz-border-radius: 0px 0px 6px 6px;*/
}
-#suggestions-toggle {
+#toss-link {
+ border-width: 0px;
+}
+
+#suggestions-toggle, #new_game_me_bottom, #new_game_opp_bottom {
margin: 0px;
padding-top: 0px;
padding-bottom: 0px;
+ display: none;
}
-#suggestions-toggle:hover {
+#suggestions-toggle:hover,#new_game_me_bottom:hover,#new_game_opp_bottom:hover {
color: #ffffff;
text-decoration: underline;
cursor: pointer;
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/Client/index.html 2012-03-21 20:03:14 UTC (rev 1696)
@@ -33,6 +33,21 @@
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
><img style="height: 24px; width: 69px;" src="img/appstore-small.png" /></a>
</span>
+
+ <span id="speedtab" style="display: none;">
+ Speed: <select id="speed">
+ <option class="speed_val" value="1">1s</option>
+ <option class="speed_val" value="2">2s</option>
+ <option class="speed_val" value="3">3s</option>
+ <option class="speed_val" value="4">4s</option>
+ <option class="speed_val" value="5">5s</option>
+ <option class="speed_val" value="10">10s</option>
+ <option class="speed_val" value="15">15s</option>
+ <option class="speed_val" value="30">30s</option>
+ <option class="speed_val" value="60">60s</option>
+ </select>
+ </span>
+
<span id="toprighttab"><a id="backlink-games" href="index.html">Games</a></span>
</div>
@@ -384,19 +399,12 @@
onclick="toggle_suggestions()">
Ask Before Move
</button>
- <span class="contact" id="speedtab" style="display: none;">
- Speed: <select id="speed">
- <option class="speed_val" value="1">1s</option>
- <option class="speed_val" value="2">2s</option>
- <option class="speed_val" value="3">3s</option>
- <option class="speed_val" value="4">4s</option>
- <option class="speed_val" value="5">5s</option>
- <option class="speed_val" value="10">10s</option>
- <option class="speed_val" value="15">15s</option>
- <option class="speed_val" value="30">30s</option>
- <option class="speed_val" value="60">60s</option>
- </select>
- </span>
+ <button id="new_game_opp_bottom" onclick="play_anew(false)">
+ New Game (Opponent Starts)
+ </button>
+ <button id="new_game_me_bottom" onclick="play_anew(true)">
+ New Game (You Start)
+ </button>
</div>
</div>
Modified: trunk/Toss/www/develop.xml
===================================================================
--- trunk/Toss/www/develop.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/develop.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -21,7 +21,10 @@
<item>If you want to develop Toss on
<a href="http://www.ubuntu.com/">Ubuntu</a>,
here is a command with a list of packages to install.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Then download
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a>, unpack it and do <em>make; sudo make install</em>
</item>
<item>To develop Toss on
<a href="http://www.apple.com/macosx/">MacOSX</a>,
@@ -29,8 +32,8 @@
<a href="http://www.macports.org/">MacPorts</a> (Xcode required)
and do the following.<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> download
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Then download
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a>, unpack it and do <em>make; sudo make install</em>
</item>
<item>This command will checkout the
@@ -53,7 +56,11 @@
<a href="http://www.ubuntu.com/">Ubuntu</a>
kompilieren möchte, braucht man
Pakete, die mit folgender Zeile installiert werden können.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Dann muss man
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a> runterladen, auspacken und dort
+ <em>make; sudo make install</em> ausführen
</item>
<item>Um Toss unter
<a href="http://www.apple.com/macosx/">MacOSX</a>
@@ -61,8 +68,8 @@
<a href="http://www.macports.org/">MacPorts</a> (Xcode nötig).
Mit MacPorts muss man folgendes installieren.<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> dann
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Dann muss man
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a> runterladen, auspacken und dort
<em>make; sudo make install</em> ausführen
</item>
@@ -82,19 +89,21 @@
<a href="http://caml.inria.fr/">Objective Camlu</a>
i wymaga <em>ocamlbuilda</em> i <em>make</em> do kompilacji.
</item>
- <item>Pod
- <a href="http://www.ubuntu.com/">Ubuntu</a>,
+ <item>Pod <a href="http://www.ubuntu.com/">Ubuntu</a>,
poniższe polecenie zainstaluje pakiety
niezbędne do kompilacji Tossa.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Potem trzeba ściągnąć
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a>, rozpakować i wykonać <em>make; sudo make install</em>
</item>
<item>Pod <a href="http://www.apple.com/macosx/">MacOSX</a>
polecamy zainstalować
<a href="http://www.macports.org/">MacPorts</a> (wymaga Xcode)
i wywołać poniższe polecenie.<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> potem ściągnąć
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Potem trzeba ściągnąć
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a>, rozpakować i wykonać <em>make; sudo make install</em>
</item>
<item>Poniższe polecenie ściągnie
@@ -116,14 +125,17 @@
<item>Si vous souhaitez développer Toss sur
<a href="http://www.ubuntu.com/">Ubuntu</a>,
voici une commande avec une liste des paquets à installer.<br/>
- <em>sudo apt-get install menhir libjs-of-ocaml-dev phantomjs</em>
+ <em>sudo apt-get install menhir liblwt-ocaml-dev
+ phantomjs</em><br/> Ensuite téléchargez
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
+ js_of_ocaml</a>, déballer et faire <em>make; sudo make install</em>
</item>
<item>Si vous souhaitez développer Toss sur
<a href="http://www.apple.com/macosx/">MacOSX</a>, installe
<a href="http://www.macports.org/">MacPorts</a> (et Xcode) et faire<br/>
<em>sudo port install ocaml ocaml-menhir ocaml-lwt
- phantomjs</em><br/> téléchargez
- <a href="http://ocsigen.org/download/js_of_ocaml-1.0.9.tar.gz">
+ phantomjs</em><br/> Ensuite téléchargez
+ <a href="http://ocsigen.org/download/js_of_ocaml-1.1.tar.gz">
js_of_ocaml</a>, déballer et faire <em>make; sudo make install</em>
</item>
<item>Cette commande checkout du
Modified: trunk/Toss/www/docs.xml
===================================================================
--- trunk/Toss/www/docs.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/docs.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -179,10 +179,6 @@
Structure Rewriting Games</a>.
</item>
- <item><em>Idée et spécification</em> du Toss sont décrites dans
- <a href="reference/reference.pdf">reference.pdf</a>.
- </item>
-
<item><em>Complexité</em> d'un fragment syntaxique du Toss a été analysée
dans le papier <a href="pub/graph_games_short.pdf">Synthesis
for Structure Rewriting Systems</a>.
Modified: trunk/Toss/www/ideas.xml
===================================================================
--- trunk/Toss/www/ideas.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/ideas.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -13,7 +13,7 @@
<link id="ideas" href="/ideas.html">Development Ideas</link>
</history>
- <section title="Google Summer of Code 2012">
+<!-- <section title="Google Summer of Code 2012">
<par>Toss is applying to participate in <em>Google Summer of Code</em>
in 2012. This page contains a few ideas for students who wish to work
on Toss this summer. But, most importantly, we welcome new ideas from
@@ -22,7 +22,7 @@
Make sure to contact us, we are very positive about suggestions and
we think that the best proposals (and code) come from students who are
simply passionate about realizing their own ideas!<br/></par>
- </section>
+ </section>
<section title="Your Project Proposal">
<par>If you decide to present your own idea, here are a few questions
@@ -47,14 +47,10 @@
<itemize>
<item>Toss Mailing List:
<mailto address="tos...@li..."/></item>
- <item>Łukasz Kaiser (GSoC admin):
+ <item>Łukasz Kaiser:
<mailto address="luk...@gm..."/></item>
- <item>Łukasz Stafiniak (GSoC backup admin):
- <mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
- </section>
+ </section> -->
<section title="Idea: Go and Arimaa">
@@ -213,7 +209,7 @@
standard games well, including single-player games which do not translate
well now. By the end, the majority of games in GDL will translate
well and will be made usable from the web interface. The GGP Competition
- starts around the end of GSoC, so of course the best final goal would be
+ starts around autumn, so of course the best final goal would be
for Toss to score a win there!
<br/><br/></par>
<par><em>Modules (in planned construction order).</em>
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-03-16 01:52:25 UTC (rev 1695)
+++ trunk/Toss/www/index.xml 2012-03-21 20:03:14 UTC (rev 1696)
@@ -266,38 +266,6 @@
</section>
- <section title="Scientific Background of Toss" lang="en">
- <par>To learn more about the mathematical background and
- the design of Toss, use the following links.</par>
- <itemize>
- <item><em>Compact description</em> of the mathematical model behind Toss
- and our UCT game playing algorithm can be found in the paper
- <a href="pub/playing_structure_rewriting_games.pdf">Playing
- Structure Rewriting Games</a>.
- </item>
-
- <item><em>Design and specification</em> of Toss are described in
- the <a href="reference/reference.pdf">reference.pdf</a> document.
- </item>
-
- <item> <em>Complexity</em> of a syntactic fragment of Toss was analyzed in
- the paper <a href="pub/graph_games_short.pdf">Synthesis
- for Structure Rewriting Systems</a>.
- </item>
-
- <item><em>Presentation</em> on the mathematics behind Toss was given at
- <em>IIT Kanpur</em> and can be
- <a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi">
- watched</a> online.
- </item>
-
- <item><em>Shorter presentation</em> focusing on the AI side was given at
- <em>AGI 2010</em> and can also be
- <a href="http://www.vimeo.com/15326245">watched</a> online.
- </item>
- </itemize>
- </section>
-
<section title="Mathematische Grundlagen von Toss" lang="de">
<par>Um mehr über Toss zu erfahren, folge diesen Links.</par>
<itemize>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-29 22:30:15
|
Revision: 1697
http://toss.svn.sourceforge.net/toss/?rev=1697&view=rev
Author: lukaszkaiser
Date: 2012-03-29 22:30:09 +0000 (Thu, 29 Mar 2012)
Log Message:
-----------
Starting Hnefatafl implementation in Toss.
Modified Paths:
--------------
trunk/Toss/www/index.xml
Added Paths:
-----------
trunk/Toss/examples/Hnefatafl.toss
Added: trunk/Toss/examples/Hnefatafl.toss
===================================================================
--- trunk/Toss/examples/Hnefatafl.toss (rev 0)
+++ trunk/Toss/examples/Hnefatafl.toss 2012-03-29 22:30:09 UTC (rev 1697)
@@ -0,0 +1,55 @@
+PLAYERS 1, 2
+REL w(x) = wP(x) or wK(x)
+REL FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not bP(y))
+REL FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not bP(y))
+REL Col (x, y) = ex z (FreeC (x, z) and (z = y or (C(z, y) or C(y, z))))
+REL Row (x, y) = ex z (FreeR (x, z) and (z = y or (R(z, y) or R(y, z))))
+REL Line (x, y) = Col (x, y) or Row (x, y)
+REL WinWhite () = ex x (wK(x) and X(x))
+RULE WhitePawn:
+ [ a, b | wP { a } | - ] -> [ a, b | wP { b } | - ]
+ emb wP, wK, bP, X, T pre Line(a, b) and not WinWhite ()
+RULE WhiteKing:
+ [ a, b | wP { a } | - ] -> [ a, b | wP { b } | - ]
+ emb wP, wK, bP, X pre Line(a, b) and not WinWhite ()
+RULE BlackPawn:
+ [ a, b | bP { a } | - ] -> [ a, b | bP { b } | - ]
+ emb wP, wK, bP, X, T pre Line(a, b) and not WinWhite ()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WinWhite())
+ MOVES [WhitePawn -> 1]; [WhiteKing -> 1]
+ }
+ PLAYER 2 { PAYOFF -1 * :(WinWhite()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WinWhite()) }
+ PLAYER 2 {
+ PAYOFF -1 * :(WinWhite())
+ MOVES [BlackPawn -> 0]
+ }
+}
+START [ | | ] "
+ ... ... ... ... ...
+ X ... bP.bP bP.bP bP. ...X
+ ... ... ... ... ... ...
+ ... ... ...bP ... ... ...
+ ... ... ... ... ...
+ ... ... ... ... ...
+ ... ... ... ... ... ...
+ bP. ... ...wP ... ... bP.
+ ... ... ... ... ...
+ bP ... ...wP wP.wP ... ...bP
+ ... ... ...T ... ... ...
+ bP.bP ...wP wP.wK wP.wP ...bP bP.
+ ... ... ... ... ...
+ bP ... ...wP wP.wP ... ...bP
+ ... ... ... ... ... ...
+ bP. ... ...wP ... ... bP.
+ ... ... ... ... ...
+ ... ... ... ... ...
+ ... ... ... ... ... ...
+ ... ... ... ... ... ...
+ ... ... bP. ... ...
+ X ... bP.bP bP.bP bP. ...X
+"
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-03-21 20:03:14 UTC (rev 1696)
+++ trunk/Toss/www/index.xml 2012-03-29 22:30:09 UTC (rev 1697)
@@ -65,18 +65,22 @@
<section title="News">
<itemize>
+ <newsitem date="30/03/12">
+ Adding Hnefatafl to example Toss games</newsitem>
+ <newsitem date="21/03/12">
+ Toss Client and website updated to a cleaned-up JS version</newsitem>
<newsitem date="09/03/12">
First completely working all-JS Toss version</newsitem>
<newsitem date="05/03/12">
Fully integrated OCaml and JS debugging and logs</newsitem>
- <newsitem date="27/02/12">
- Compiled resources to access files from JS</newsitem>
- <newsitem date="18/02/12">
- Integrating OCaml and JS unit tests</newsitem>
- <newsitem date="11/02/12">
- Starting systematic unit tests of JS interface</newsitem>
- <newsitem date="06/02/12">
- Toss release 0.7 with many improvements</newsitem>
+ <oldnewsitem date="27/02/12">
+ Compiled resources to access files from JS</oldnewsitem>
+ <oldnewsitem date="18/02/12">
+ Integrating OCaml and JS unit tests</oldnewsitem>
+ <oldnewsitem date="11/02/12">
+ Starting systematic unit tests of JS interface</oldnewsitem>
+ <oldnewsitem date="06/02/12">
+ Toss release 0.7 with many improvements</oldnewsitem>
<oldnewsitem date="04/02/12">
Definitions use play history: new Chess toss file</oldnewsitem>
<oldnewsitem date="02/02/12">
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-04-17 18:07:44
|
Revision: 1699
http://toss.svn.sourceforge.net/toss/?rev=1699&view=rev
Author: lukaszkaiser
Date: 2012-04-17 18:07:32 +0000 (Tue, 17 Apr 2012)
Log Message:
-----------
Correcting a solver bug, learning Pawn-Whoppining works again.
Modified Paths:
--------------
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/Distinguish.mli
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGame.mli
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/Distinguish.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -1,5 +1,8 @@
open Formula
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
type logic = FO | ExFO | GuardedFO | ExGuardedFO
@@ -14,7 +17,7 @@
let eval structure phi assignment =
(Solver.M.evaluate_partial structure assignment phi) in
let elems = Assignments.set_to_set_list (Structure.elems structure) in
- let vars=Array.map varname (Array.of_list (Aux.range (Array.length tuple))) in
+ let vars =Array.map varname (Array.of_list (Aux.range (Array.length tuple))) in
let assignment = if tuple = [||] then AssignmentSet.Any else
Assignments.assignments_of_list elems vars [tuple] in
eval structure formula assignment <> AssignmentSet.Empty
@@ -185,7 +188,7 @@
List.map Array.of_list (Aux.all_ntuples (Array.to_list tup) k) in
let ktups = List.rev_map k_subtuples (Aux.unique_sorted tups) in
let ktups = Aux.unique_sorted (List.concat ktups) in
- LOG 1 "guarded_types:\t\t tuples generated";
+ if !debug_level>0 then print_endline "guarded_types:\t\t tuples generated";
let mem = Hashtbl.create 63 in
Aux.unique_sorted (List.rev_map
(guarded_type_memo existential struc mem qr) ktups)
@@ -209,7 +212,8 @@
let rec rept i l = if i < 1 then [] else l :: (rept (i-1) l) in
let atoms = Array.of_list (FormulaOps.atoms ~repetitions:repeat_vars
(Structure.rel_signature struc) (varnames 2)) in
- LOG 1 "tc_atomic:\t\t %i atoms\n%!" (Array.length atoms);
+ if !debug_level > 0 then
+ Printf.printf "tc_atomic:\t\t %i atoms\n%!" (Array.length atoms);
let choices = List.rev_map Array.of_list
(if positive then Aux.product (rept (Array.length atoms) [0; 1]) else
Aux.product (rept (Array.length atoms) [0; 1; -1])) in
@@ -257,7 +261,8 @@
(* Helper function: remove atoms from a formula if [cond] is still satisfied.
Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
let rec greedy_remove ?(pos=false) cond phi =
- LOG 2 "greedy_remove:\t\t %s\n%!" (Formula.str phi);
+ if !debug_level > 1 then
+ Printf.printf "greedy_remove:\t\t %s\n%!" (Formula.str phi);
let rec greedy_remove_list minimize constructor acc = function
| [] -> acc
| x :: xs ->
@@ -270,7 +275,7 @@
else greedy_remove_list minimize constructor (x::acc) xs in
let greedy_remove_lst cons lst =
let l = greedy_remove_list false cons [] lst in
- LOG 2 "greedy_remove_lst:\t min %i: %s"
+ if !debug_level > 1 then Printf.printf "greedy_remove_lst:\t min %i: %s\n%!"
(List.length l) (Formula.str (cons l));
greedy_remove_list true cons [] (List.rev l) in
match phi with
@@ -299,8 +304,9 @@
| ExGuardedFO -> guarded_types ~existential:true struc ~qr ~k
| FO -> ntypes struc ~qr ~k
| ExFO -> ntypes ~existential:true struc ~qr ~k in
- LOG 1 "min_type_omitting:\t types generated";
+ if !debug_level > 0 then print_endline "min_type_omitting:\t types generated";
let ok_types = List.filter (fun f -> not (List.mem f neg_types)) pos_types in
+ if !debug_level > 0 then Printf.printf "%i ok_types\n%!" (List.length ok_types);
let ok_types = List.sort !compare_types ok_types in
if ok_types = [] then None else Some (Formula.flatten_sort (List.hd ok_types))
@@ -313,17 +319,19 @@
| FO -> ntypes s ~qr ~k
| ExFO -> ntypes ~existential:true s ~qr ~k in
let neg_tps = Aux.unique_sorted (Aux.concat_map types neg_strucs) in
- LOG 1 "distinguish_upto:\t neg types done (%i): " (List.length neg_tps);
+ if !debug_level > 0 then print_endline "distinguish_upto:\t neg types done";
let fails_on_negs f = not (List.exists (fun s-> check s [||] f) neg_strucs) in
let extend_by_pos acc struc =
if check struc [||] (Or acc) then acc else
match min_type_omitting ~logic ~qr ~k neg_tps struc with
| None -> raise Not_found
- | Some f -> (greedy_remove ~pos:true fails_on_negs f) :: acc in
+ | Some f -> let g = greedy_remove ~pos:true fails_on_negs f in
+ (* Formula.print g; *) g :: acc in
let pos_formulas =
try List.fold_left extend_by_pos [] pos_strucs with Not_found -> [] in
let pos_formulas = Aux.unique_sorted ~cmp:!compare_types pos_formulas in
- LOG 1 "distinguish_upto:\t pos_formulas %i" (List.length pos_formulas);
+ if !debug_level > 0 then Printf.printf
+ "distinguish_upto:\t pos_formulas %i\n%!" (List.length pos_formulas);
if pos_formulas = [] then None else
let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
let is_ok f = fails_on_negs f && succ_pos [f] in
@@ -334,24 +342,27 @@
(* Find a formula holding on all [pos_strucs] and on no [neg_strucs].
Leaves free variables (existential) if [skip_outer_exists] is set. *)
-let distinguish ?(skip_outer_exists=false) s1 s2 =
- LOG 1 "distinguishing:\n\n%s\n\n and\n\n %s\n"
- (String.concat "\n" (List.map Structure.str s1))
- (String.concat "\n" (List.map Structure.str s2));
+let distinguish ?(use_tc=true) ?(skip_outer_exists=false) s1 s2 =
+ if !debug_level > 0 then
+ Printf.printf "distinguishing:\n\n%s\n\n and\n\n %s\n%!"
+ (String.concat "\n" (List.map Structure.str s1))
+ (String.concat "\n" (List.map Structure.str s2));
let rec diff qr k =
if qr > k then diff 0 (k+1) else (
- LOG 1 "distinguish:\t\t qr %i k %i\n%!" qr k;
+ if !debug_level > 0 then
+ Printf.printf "distinguish:\t\t qr %i k %i\n%!" qr k;
if qr = 0 then
match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
- | Some f -> f | None ->
- match tc_atomic_distinguish ~positive:true
- ~repeat_vars:false s1 s2 (3*k) with
- | Some f -> Formula.flatten_sort f | None -> diff (qr+1) k
+ | Some f -> f | None -> if not use_tc then diff (qr+1) k else
+ match tc_atomic_distinguish ~positive:true
+ ~repeat_vars:false s1 s2 (3*k) with
+ | Some f -> Formula.flatten_sort f | None -> diff (qr+1) k
else
match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
| Some f ->
if qr > 1 (* hurry up for large qr *) then f else (
- LOG 1 "distinguish:\t\t guarded found: %s\n%!" (Formula.str f);
+ if !debug_level > 0 then Printf.printf
+ "distinguish:\t\t guarded found: %s\n%!" (Formula.str f);
match distinguish_upto ~logic:ExGuardedFO ~qr ~k s1 s2 with
| Some g-> if 2*(Formula.size f) < Formula.size g then f else g
| None -> f
Modified: trunk/Toss/Learn/Distinguish.mli
===================================================================
--- trunk/Toss/Learn/Distinguish.mli 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/Distinguish.mli 2012-04-17 18:07:32 UTC (rev 1699)
@@ -90,5 +90,5 @@
(** Find a formula holding on all [pos_strucs] and on no [neg_strucs].
Leaves free variables (existential) if [skip_outer_exists] is set. *)
-val distinguish: ?skip_outer_exists: bool ->
+val distinguish: ?use_tc: bool -> ?skip_outer_exists: bool ->
Structure.structure list -> Structure.structure list -> Formula.formula
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/LearnGame.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -1,5 +1,7 @@
(* Learning games from examples. *)
+let tc = ref true
+
let rec evens ?(acc=[0]) k =
let last = (List.hd (List.rev acc)) in
if (List.hd (List.rev acc))> k then
@@ -14,7 +16,7 @@
LOG 1 "Searching WIN:\n%s \nNOT\n%s\n"
(String.concat "\n" (List.map Structure.str winningStates))
(String.concat "\n" (List.map Structure.str notWinningStates));
- let res = Distinguish.distinguish winningStates notWinningStates in
+ let res= Distinguish.distinguish ~use_tc:!tc winningStates notWinningStates in
let print_tc (i, f) =
Printf.sprintf "(tc !%i x0, x1 (%s))" i (Formula.str f) in
match !Distinguish.distinguish_result_tc with
@@ -83,7 +85,7 @@
let (good, bad) = (List.map mark mright, List.map mark mwrong) in
LOG 1 "%s" (String.concat "\n" (List.map Structure.str good));
LOG 1 "%s" (String.concat "\n" (List.map Structure.str bad));
- let pre = Distinguish.distinguish good bad in
+ let pre = Distinguish.distinguish ~use_tc:!tc good bad in
LOG 1 "pre: %s" (Formula.str pre);
let elems = Aux.range ~from:1 ((Structure.nbr_elems (fst m)) + 1) in
let let_part i = Printf.sprintf "let ch%i (x) = x = e%i in" i i in
Modified: trunk/Toss/Learn/LearnGame.mli
===================================================================
--- trunk/Toss/Learn/LearnGame.mli 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/LearnGame.mli 2012-04-17 18:07:32 UTC (rev 1699)
@@ -1,5 +1,7 @@
(** Module for learning games from examples. *)
+(** A flag whether to use the TC operator or not. *)
+val tc : bool ref
(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
game [source]: [wins0] which are now supposed to be won by Player 0,
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -96,6 +96,7 @@
("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose");
("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
("-f", Arg.String (fun s -> testname := s), "process files");
+ ("-notc", Arg.Unit (fun () -> LearnGame.tc := false), "no TC operator");
("-dir", Arg.String (fun s -> dir := s), "set files directory");
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Learn/Makefile 2012-04-17 18:07:32 UTC (rev 1699)
@@ -28,13 +28,19 @@
diff res.toss examples/$(basename $@).toss
rm res.toss
+%.learnnotc:
+ make -C .. Learn/LearnGameTest.native
+ time ../LearnGameTest.native -notc -f $(basename $@) > res.toss
+ diff res.toss examples/$(basename $@).toss
+ rm res.toss
+
learntests:
make Tic-Tac-Toe001.learn
make Tic-Tac-Toe002.learn
make Breakthrough001.learn
make Gomoku001.learn
make Connect4001.learn
- make Pawn-Whopping001.learn
+ make Pawn-Whopping001.learnnotc
%.reco:
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-04-16 19:52:08 UTC (rev 1698)
+++ trunk/Toss/Solver/Solver.ml 2012-04-17 18:07:32 UTC (rev 1699)
@@ -216,10 +216,10 @@
| Ex (vl, phi) as ephi ->
check_timeout "Solver.eval.Ex";
let aset_vars = AssignmentSet.assigned_vars [] aset in
- if (fp = [] &&
- ((List.exists (fun v->List.mem v aset_vars) vl) ||
- (aset_vars <> [] && FormulaSubst.free_vars ephi = []))) then
- let phi_asgn =
+ let in_aset =
+ if List.exists(fun v->List.mem v aset_vars) vl then Any else aset in
+ let phi_asgn =
+ if (fp = [] && FormulaSubst.free_vars ephi = []) then
try
let (res, _) = Hashtbl.find !cache_results phi in
LOG 2 "In-Eval found in cache: %s" (Formula.str phi);
@@ -228,13 +228,10 @@
LOG 1 "In-Eval_m %s" (str phi);
let phi_asgn = eval fp model elems Any phi in
Hashtbl.add !cache_results phi (phi_asgn, phi_rels phi);
- phi_asgn in
- report (simp (join aset
- (project_list elems phi_asgn (List.map var_str vl))))
- else
- let phi_asgn = eval fp model elems aset phi in
- report (simp (join aset
- (project_list elems phi_asgn (List.map var_str vl))))
+ phi_asgn
+ else eval fp model elems in_aset phi in
+ report (simp (join aset
+ (project_list elems phi_asgn (List.map var_str vl))))
| All (vl, phi) ->
check_timeout "Solver.eval.All";
let aset_vars = AssignmentSet.assigned_vars [] aset in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-05-05 21:58:15
|
Revision: 1700
http://toss.svn.sourceforge.net/toss/?rev=1700&view=rev
Author: lukaszkaiser
Date: 2012-05-05 21:58:06 +0000 (Sat, 05 May 2012)
Log Message:
-----------
Position updates work again; old rewriting exaxample ported to JS interface; many corrections and test updates.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/OUnit.ml
trunk/Toss/Formula/OUnitTest.ml
trunk/Toss/GGP/Makefile
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/DistinguishTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Makefile
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/StructureParser.mly
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/www/index.xml
Added Paths:
-----------
trunk/Toss/Client/img/Rewriting-Example.png
trunk/Toss/examples/Rewriting-Example.toss
Removed Paths:
-------------
trunk/Toss/Client/img/Breakthrough.svg
trunk/Toss/Client/img/Checkers.svg
trunk/Toss/Client/img/Chess.svg
trunk/Toss/Client/img/Connect4.svg
trunk/Toss/Client/img/Entanglement.svg
trunk/Toss/Client/img/Gomoku.svg
trunk/Toss/Client/img/Pawn-Whopping.svg
trunk/Toss/Client/img/Tic-Tac-Toe.svg
trunk/Toss/examples/rewriting_example.toss
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -71,11 +71,12 @@
"setting states from examples dir" >::
(fun () ->
(* skip_if true "Change to simpler and stable example."; *)
- let fname = "./examples/rewriting_example.toss" in
+ let fname = "./examples/Rewriting-Example.toss" in
let contents = AuxIO.input_file fname in
let gs = gs_of_str contents in
assert_equal ~printer:(fun x->x) ~msg:"from file, curly braces style"
- contents (Arena.sprint_state gs);
+ (Aux.normalize_spaces contents)
+ (Aux.normalize_spaces (Arena.sprint_state gs));
);
"move to string" >::
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -113,8 +113,9 @@
Structure.fun_val struc f e
with Not_found ->
failwith
- ("rewrite_single_nocheck: get_val: could not find "^a^
- " in matched "^String.concat "," (List.map fst m))
+ ("rewrite_single_nocheck: get_val: could not find " ^ a ^
+ " in matched " ^ String.concat "," (List.map fst m) ^
+ String.concat "," (List.map (fun (_, e) -> string_of_int e) m))
) in
List.map (fun ((f, a),_) -> Term.Const (get_val f a)) dyn in
let step vals t0 =
@@ -173,8 +174,10 @@
evolved values *)
let asg = AssignmentSet.fo_assgn_of_list m in
let upd_vals = List.map
- (fun (lhs,expr) -> lhs, Solver.M.get_real_val ~asg expr !last_struc)
- upd in
+ (fun (lhs,expr) ->
+ let res = Solver.M.get_real_val ~asg expr !last_struc in
+ LOG 1 "%s(%s) = %f (%s)" (fst lhs) (snd lhs) res (Formula.real_str expr);
+ (lhs, res)) upd in
(* we pass the evolved structure to discrete rewriting, so that
function values can be copied to new elements in case they are
not updated later *)
@@ -203,8 +206,7 @@
if r.post = Formula.And [] then matches struc r else
List.filter is_ok (matches struc r)
-(* For now, we rewrite only single rules. Returns [None] if rewriting
- fails. *)
+(* For now, we rewrite only single rules. Returns [None] if rewriting fails. *)
let rewrite_single struc cur_time m r t params =
let (res_struc, _, _ as res_struc_n_shifts) =
rewrite_single_nocheck struc cur_time m r t params in
@@ -215,21 +217,6 @@
(* -------------------------- PRINTING FUNCTION ----------------------------- *)
-(* Print a rule to string. *)
-let str r =
- let dyn_str =
- if r.dynamics = [] then "" else "\ndynamics\n" ^
- Term.eq_str ~diff:true r.dynamics in
- let upd_str =
- if r.update = [] then "" else "\nupdate\n" ^ (
- Formula.eq_str r.update
- ) ^ "\n" in
- let inv_str = " inv " ^ (Formula.str r.inv) in
- let post_str = " post " ^ (Formula.str r.post) in
- (DiscreteRule.rule_str r.discrete) ^ " " ^
- dyn_str ^ upd_str ^ inv_str ^ post_str
-
-
let has_dynamics r = r.dynamics <> []
(* List.exists (fun (_, t) -> t <> Term.Const 0.) r.dynamics *)
@@ -241,10 +228,10 @@
(DiscreteRule.fprint_full print_compiled) r.discrete;
if has_dynamics r then
Format.fprintf f "@ @[<hv>dynamics@ %a@]"
- (Term.fprint_eqs ~diff:true) r.dynamics;
+ (Term.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
if has_update r then
Format.fprintf f "@ @[<hv>update@ %a@]"
- (Formula.fprint_eqs ~diff:false) r.update;
+ (Formula.fprint_eqs ~diff:false) (List.sort Pervasives.compare r.update);
if r.inv <> Formula.And [] then
Format.fprintf f "@ @[<1>inv@ %a@]" Formula.fprint r.inv;
if r.post <> Formula.And [] then
@@ -255,6 +242,7 @@
let print r = AuxIO.print_of_fprint fprint r
let sprint r = AuxIO.sprint_of_fprint fprint r
+let str = sprint
let matching_str struc emb =
let name (lhs_v,rhs_e) =
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -26,33 +26,33 @@
) else if i+2 < l then String.sub s 0 (i+3) else s
with Not_found -> s
-let tests = "ContinuousRule" >::: [
+let eq_str msg s1 s2 = assert_equal ~msg ~printer:(fun x -> x)
+ (Aux.normalize_spaces s1) (Aux.normalize_spaces s2)
+let tests = "ContinuousRule" >::: [
"parsing" >::
(fun () ->
- let discr =
- "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] emb R with [c <- a, d <- b] " in
- let s = discr ^ " inv true post true" in
+ let discr = "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] " ^
+ " emb R with [c <- a, d <- b]" in
let signat = ["R", 2] in
- let r = rule_of_str s signat [] "rule1" in
- assert_equal ~msg:"1. no continuous" ~printer:(fun x->x) s (str r);
+ let r = rule_of_str discr signat [] "rule1" in
+ eq_str "1. no continuous" discr (str r);
let upd_eq = " :f(c) = 2. * :f(a);\n :f(d) = :f(b)\n" in
- let s = discr ^ "\nupdate\n" ^ upd_eq ^ " inv true post true" in
+ let s = discr ^ "\nupdate\n" ^ upd_eq in
let r = rule_of_str s signat [] "rule2" in
- assert_equal ~msg:"2. update" ~printer:(fun x->x) s (str r);
+ eq_str "2. update" s (str r);
let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
- let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ " inv true post true" in
+ let s = discr ^ "\ndynamics\n" ^ dyn_eq in
let r = rule_of_str s signat [] "rule3" in
- assert_equal ~msg:"3. dynamics" ~printer:(fun x->x) s (str r);
+ eq_str "3. dynamics" s (str r);
let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
let upd_eq = " :f(c) = 2. * :f(a);\n :f(d) = :f(b)\n" in
- let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
- " inv true post true" in
+ let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq in
let r = rule_of_str s signat [] "rule4" in
- assert_equal ~msg:"4. dynamics+update" ~printer:(fun x->x) s (str r);
+ eq_str "4. dynamics+update" s (str r);
);
"fprint" >::
@@ -81,14 +81,6 @@
let s = discr ^ "\n dynamics" ^ dyn_eq ^ "\n update" ^ upd_eq in
let r = rule_of_str s signat [] "rule4" in
assert_equal ~msg:"4. dynamics+update" ~printer:(fun x->x) s (sprint r);
-
- let dyn_eq = dyn_eq1 ^ "\n" ^ dyn_eq2 ^ ";\n" ^ dyn_eq1 ^ "\n" ^ dyn_eq2
- ^ ";\n" ^ dyn_eq1 ^ "\n" ^ dyn_eq2 in
- let upd_eq = upd_eq1 ^ "\n" ^ upd_eq2 ^ ";\n" ^ upd_eq1 ^ "\n" ^ upd_eq2
- ^ ";\n" ^ upd_eq1 ^ "\n" ^ upd_eq2 in
- let s = discr ^ "\n dynamics\n" ^ dyn_eq ^ "\n update\n" ^ upd_eq in
- let r = rule_of_str s signat [] "rule5" in
- assert_equal ~msg:"5. many equations" ~printer:(fun x->x) s (sprint r);
);
"rewrite" >::
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -203,7 +203,7 @@
rel_prods in
let precond =
match disjs with
- | [] -> failwith ("fluent_preconds: not a fluent: "^rel)
+ (* | [] -> failwith ("fluent_preconds: not a fluent: "^rel) *)
| [phi] -> phi
| _ -> Formula.Or disjs in
let precond = FormulaOps.prune_unused_quants precond in
@@ -252,24 +252,11 @@
module SIMap = Structure.IntMap
-(* When LHS/RHS elements are converted to variables, their names are
- used whenever they exist, if they don't, their numbers are prefixed
- with "vV", i.e. vV1, vV2, ... *)
-let elem_of_elemvar names ev =
- try SSMap.find ev names
- with Not_found ->
- int_of_string (String.sub ev 2 (String.length ev - 2))
+(* When LHS/RHS elements are converted to variables, their names are used. *)
+let elem_of_elemvar names ev = SSMap.find ev names
+let elemvar_of_elem inv_names e = SIMap.find e inv_names
-let elemvar_of_elem inv_names e =
- try SIMap.find e inv_names
- with Not_found ->
- "vV"^string_of_int e
-let elemname_of_elemvar ev =
- if String.length ev > 2 && ev.[0]='v' && ev.[1]='V'
- then String.sub ev 2 (String.length ev - 2)
- else ev
-
(* Find all embeddings of a rule. Does not guarantee that rewriting
will succeed for all of them. *)
let find_matchings model rule =
@@ -456,8 +443,7 @@
let model =
List.fold_left (fun model ne ->
let re = Aux.rev_assoc rmmap ne in
- Structure.add_rel model
- ("_right_"^elemname_of_elemvar re) [|ne|]
+ Structure.add_rel model ("_right_" ^ re) [|ne|]
) model alloc_elems in
(* Copy function values from old elements to their corresponding new
elements. *)
@@ -521,8 +507,7 @@
names due to renaming during rule compilation). *)
let model =
List.fold_left (fun model (re, me) ->
- Structure.add_rel model
- ("_right_"^elemname_of_elemvar re) [|me|]
+ Structure.add_rel model ("_right_" ^ re) [|me|]
) model rmmap in
(* Remove RHS-negated relations and add removal trace. *)
let model =
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -77,7 +77,7 @@
let s="[c, a, b |
D {(c, c); (c, a); (c, b); (b, a); (b, b)}; P {c; b}; Q {a; b};
R {(c, c); (a, c); (a, b); (b, c); (b, b)}
- | f {b->3., a->2., c->4.}; g {a->1., c->5.}
+ | f {a->2., b->3., c->4.}; g {a->1., c->5.}
] -> [b, c | D {(c, b); (c, c)}; P (b); R (c, c) | ] emb Q
with [c <- c, b <- a]" in
let r = rule_of_str ["D",2;"R",2;"Q",1;"P",1] s in
@@ -201,13 +201,13 @@
);
- "rewrite: compile_rule integers" >::
+ "rewrite: compile_rule old integers" >::
(fun () ->
let model =
- struc_of_str "[ | P:1 {}; R:2 {}; Q{1} | ]" in
- let lhs_struc = struc_of_str "[ 1 | | ]" in
- let rhs_struc = struc_of_str "[ 1, 2 | P{ (1) } | ]" in
+ struc_of_str "[ | P:1 {}; R:2 {}; Q{a1} | ]" in
+ let lhs_struc = struc_of_str "[ a1 | | ]" in
+ let rhs_struc = struc_of_str "[ a1, a2 | P{ (a1) } | ]" in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -220,13 +220,13 @@
let nmodel =
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x) ~msg:"clone, add to twin"
- "[1, 2 | P (1); Q {1; 2}; R:2 {}; _new_P (1); _right_1 (1); _right_2 (2) | ]"
+ "[a1_a1, a1_a2 | P (a1_a1); Q {a1_a1; a1_a2}; R:2 {}; _new_P (a1_a1); _right_a1 (a1_a1); _right_a2 (a1_a2) | ]"
(Structure.str nmodel);
let model =
- struc_of_str "[ | P{2}; Q{1} | ]" in
- let lhs_struc = struc_of_str "[ | Q{1} | ]" in
- let rhs_struc = struc_of_str "[ 1, 2 | Q:1{}; _opt_Q{2}; P{1} | ]" in
+ struc_of_str "[ | P{a2}; Q{a1} | ]" in
+ let lhs_struc = struc_of_str "[ | Q{a1} | ]" in
+ let rhs_struc = struc_of_str "[ a1, a2 | Q:1{}; _opt_Q{a2}; P{a1} | ]" in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -239,14 +239,14 @@
let nmodel =
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x) ~msg:"clone, remove from twin"
- "[1, 2, 3 | P {1; 2}; Q (3); _del_Q (1); _new_P (1); _right_1 (1); _right_2 (3) | ]"
+ ("[a2, a1_a1, a1_a2 | P {a2; a1_a1}; Q (a1_a2); _del_Q (a1_a1);" ^
+ " _new_P (a1_a1); _right_a1 (a1_a1); _right_a2 (a1_a2) | ]")
(Structure.str nmodel);
let model =
- struc_of_str "[ | R{1}; Q{1}; P:1{ } | ]" in
-
- let lhs_struc = struc_of_str "[ | Q{1} | ]" in
- let rhs_struc = struc_of_str "[ 1, 2 | Q:1{}; P{1} | ]" in
+ struc_of_str "[ | R{a1}; Q{a1}; P:1{ } | ]" in
+ let lhs_struc = struc_of_str "[ | Q{a1} | ]" in
+ let rhs_struc = struc_of_str "[ a1, a2 | Q:1{}; P{a1} | ]" in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -259,13 +259,16 @@
let nmodel =
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x) ~msg:"clone, remove, add to twin"
- "[1, 2 | P (1); Q:1 {}; R {1; 2}; _del_Q {1; 2}; _new_P (1); _right_1 (1); _right_2 (2) | ]"
+ ("[a1_a1, a1_a2 | P (a1_a1); Q:1 {}; R {a1_a1; a1_a2}; _del_Q {a1_a1;" ^
+ " a1_a2}; _new_P (a1_a1); _right_a1 (a1_a1); _right_a2 (a1_a2) | ]")
(Structure.str nmodel);
let model =
- struc_of_str "[ | P:1{ }; R{(1,2)}; C{(2,3)}; D{(1,3)} | ]" in
- let lhs_struc = struc_of_str "[ 1,2 | R{ (2,1) } | ]" in
- let rhs_struc = struc_of_str "[ 1,2,3 | P{ (2) }; R:2{}; _opt_R { (1,1); (1,2); (1,3); (2,2); (2,3); (3,2); (3,3) } | ]" in
+ struc_of_str "[ | P:1{ }; R{(a1,a2)}; C{(a2,a3)}; D{(a1,a3)} | ]" in
+ let lhs_struc = struc_of_str "[ a1, a2 | R{ (a2,a1) } | ]" in
+ let rhs_struc = struc_of_str
+ ("[ a1,a2,a3 | P{ (a2) }; R:2{}; _opt_R { (a1,a1); (a1,a2); (a1,a3);" ^
+ " (a2,a2); (a2,a3); (a3,a2); (a3,a3) } | ]") in
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
@@ -279,7 +282,9 @@
rewrite_single model emb rule_obj in
assert_equal ~printer:(fun x->x)
~msg:"clone, copy rels, remove, add to twin"
- "[1, 2, 3, 4 | C (1, 3); D {(2, 3); (4, 3)}; P (2); R:2 {}; _del_R {(2, 1); (4, 1)}; _new_P (2); _right_1 (1); _right_2 (2); _right_3 (4) | ]"
+ ("[a2, a1_a2, a3, a1_a3 | C (a2, a3); D {(a1_a2, a3); (a1_a3, a3)}; " ^
+ "P (a1_a2); R:2 {}; _del_R {(a1_a2, a2); (a1_a3, a2)}; _new_P " ^
+ "(a1_a2); _right_a1 (a2); _right_a2 (a1_a2); _right_a3 (a1_a3) | ]")
(Structure.str nmodel);
);
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-05 21:58:06 UTC (rev 1700)
@@ -66,6 +66,7 @@
("Gomoku", AuxIO.input_file "examples/Gomoku.toss");
("Pawn-Whopping", AuxIO.input_file "examples/Pawn-Whopping.toss");
("Tic-Tac-Toe", AuxIO.input_file "examples/Tic-Tac-Toe.toss");
+ ("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/State.js 2012-05-05 21:58:06 UTC (rev 1700)
@@ -195,6 +195,11 @@
return (elem_cl);
}
+function square_elements_game (game) {
+ return (game !== "Connect4" &&
+ game !== "Rewriting-Example")
+}
+
// Draw the model.
function state_draw_model (game) {
var draw_background = function (game) {
@@ -208,7 +213,7 @@
// Draw the element [elem].
var draw_elem = function (game, elem) {
- if (game != "Connect4") {
+ if (square_elements_game (game)) {
var r = SHAPES.rect (
elem.x, elem.y, 2 * SHAPES.elem_size_x, 2 * SHAPES.elem_size_y,
[["id", "elem_" + elem.id], ["class", elem_class(elem.id)],
@@ -244,10 +249,10 @@
}
}
if (rel.args.length == 2) {
- if (rel.name == "E") {
+ if (rel.name !== "R" && rel.name !== "C") {
var l = SHAPES.line (rel.args[0].x, rel.args[0].y,
rel.args[1].x, rel.args[1].y,
- [["class", "model-edge-E"]]);
+ [["class", "model-edge-" + rel.name]]);
document.getElementById("svg").appendChild(l);
}
}
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/Style.css 2012-05-05 21:58:06 UTC (rev 1700)
@@ -1112,9 +1112,15 @@
.model-edge-E {
fill: #260314;
stroke: #260314;
- stroke-width: 3px;
+ stroke-width: 4px;
}
+.model-edge-S {
+ fill: #400827;
+ stroke: #400827;
+ stroke-width: 2px;
+}
+
.Game-Chess .chessW .chess-path-A, .Game-Pawn-Whopping .chessW .chess-path-A {
opacity: 1;
fill: #fff1d4;
Deleted: trunk/Toss/Client/img/Breakthrough.svg
===================================================================
--- trunk/Toss/Client/img/Breakthrough.svg 2012-04-17 18:07:32 UTC (rev 1699)
+++ trunk/Toss/Client/img/Breakthrough.svg 2012-05-05 21:58:06 UTC (rev 1700)
@@ -1,3 +0,0 @@
-<?xml-stylesheet href="Style.css" type="text/css"?>
-<svg id="svg" viewBox="0 0 580 580">
-<rect class="model-elem-0" x="4.285714285714285" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_a1" ></rect><rect class="model-elem-1" x="75.71428571428572" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_b1" ></rect><rect class="model-elem-0" x="147.14285714285714" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_c1" ></rect><rect class="model-elem-1" x="218.57142857142856" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_d1" ></rect><rect class="model-elem-0" x="290" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_e1" ></rect><rect class="model-elem-1" x="361.42857142857144" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_f1" ></rect><rect class="model-elem-0" x="432.85714285714283" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_g1" ></rect><rect class="model-elem-1" x="504.2857142857143" y="504.2857142857143" width="71.42857142857143" height="71.42857142857143" id="elem_h1" ></rect><rect class="model-elem-1" x="4.285714285714285" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_a2" ></rect><rect class="model-elem-0" x="75.71428571428572" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_b2" ></rect><rect class="model-elem-1" x="147.14285714285714" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_c2" ></rect><rect class="model-elem-0" x="218.57142857142856" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_d2" ></rect><rect class="model-elem-1" x="290" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_e2" ></rect><rect class="model-elem-0" x="361.42857142857144" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_f2" ></rect><rect class="model-elem-1" x="432.85714285714283" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_g2" ></rect><rect class="model-elem-0" x="504.2857142857143" y="432.85714285714283" width="71.42857142857143" height="71.42857142857143" id="elem_h2" ></rect><rect class="model-elem-0" x="4.285714285714285" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_a3" ></rect><rect class="model-elem-1" x="75.71428571428572" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_b3" ></rect><rect class="model-elem-0" x="147.14285714285714" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_c3" ></rect><rect class="model-elem-1" x="218.57142857142856" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_d3" ></rect><rect class="model-elem-0" x="290" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_e3" ></rect><rect class="model-elem-1" x="361.42857142857144" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_f3" ></rect><rect class="model-elem-0" x="432.85714285714283" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_g3" ></rect><rect class="model-elem-1" x="504.2857142857143" y="361.42857142857144" width="71.42857142857143" height="71.42857142857143" id="elem_h3" ></rect><rect class="model-elem-1" x="4.285714285714285" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_a4" ></rect><rect class="model-elem-0" x="75.71428571428572" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_b4" ></rect><rect class="model-elem-1" x="147.14285714285714" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_c4" ></rect><rect class="model-elem-0" x="218.57142857142856" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_d4" ></rect><rect class="model-elem-1" x="290" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_e4" ></rect><rect class="model-elem-0" x="361.42857142857144" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_f4" ></rect><rect class="model-elem-1" x="432.85714285714283" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_g4" ></rect><rect class="model-elem-0" x="504.2857142857143" y="290" width="71.42857142857143" height="71.42857142857143" id="elem_h4" ></rect><rect class="model-elem-0" x="4.285714285714285" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_a5" ></rect><rect class="model-elem-1" x="75.71428571428572" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_b5" ></rect><rect class="model-elem-0" x="147.14285714285714" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_c5" ></rect><rect class="model-elem-1" x="218.57142857142856" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_d5" ></rect><rect class="model-elem-0" x="290" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_e5" ></rect><rect class="model-elem-1" x="361.42857142857144" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_f5" ></rect><rect class="model-elem-0" x="432.85714285714283" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_g5" ></rect><rect class="model-elem-1" x="504.2857142857143" y="218.57142857142856" width="71.42857142857143" height="71.42857142857143" id="elem_h5" ></rect><rect class="model-elem-1" x="4.285714285714285" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_a6" ></rect><rect class="model-elem-0" x="75.71428571428572" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_b6" ></rect><rect class="model-elem-1" x="147.14285714285714" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_c6" ></rect><rect class="model-elem-0" x="218.57142857142856" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_d6" ></rect><rect class="model-elem-1" x="290" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_e6" ></rect><rect class="model-elem-0" x="361.42857142857144" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_f6" ></rect><rect class="model-elem-1" x="432.85714285714283" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_g6" ></rect><rect class="model-elem-0" x="504.2857142857143" y="147.14285714285714" width="71.42857142857143" height="71.42857142857143" id="elem_h6" ></rect><rect class="model-elem-0" x="4.285714285714285" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_a7" ></rect><rect class="model-elem-1" x="75.71428571428572" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_b7" ></rect><rect class="model-elem-0" x="147.14285714285714" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_c7" ></rect><rect class="model-elem-1" x="218.57142857142856" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_d7" ></rect><rect class="model-elem-0" x="290" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_e7" ></rect><rect class="model-elem-1" x="361.42857142857144" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_f7" ></rect><rect class="model-elem-0" x="432.85714285714283" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_g7" ></rect><rect class="model-elem-1" x="504.2857142857143" y="75.71428571428572" width="71.42857142857143" height="71.42857142857143" id="elem_h7" ></rect><rect class="model-elem-1" x="4.285714285714285" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_a8" ></rect><rect class="model-elem-0" x="75.71428571428572" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_b8" ></rect><rect class="model-elem-1" x="147.14285714285714" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_c8" ></rect><rect class="model-elem-0" x="218.57142857142856" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_d8" ></rect><rect class="model-elem-1" x="290" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_e8" ></rect><rect class="model-elem-0" x="361.42857142857144" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_f8" ></rect><rect class="model-elem-1" x="432.85714285714283" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_g8" ></rect><rect class="model-elem-0" x="504.2857142857143" y="4.285714285714285" width="71.42857142857143" height="71.42857142857143" id="elem_h8" ></rect><circle class="model-pred-B" cx="40" cy="111.42857142857143" r="23.714285714285715" id="pred_a7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="111.42857142857143" cy="111.42857142857143" r="23.714285714285715" id="pred_b7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="182.85714285714286" cy="111.42857142857143" r="23.714285714285715" id="pred_c7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="254.28571428571428" cy="111.42857142857143" r="23.714285714285715" id="pred_d7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="325.7142857142857" cy="111.42857142857143" r="23.714285714285715" id="pred_e7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="397.14285714285717" cy="111.42857142857143" r="23.714285714285715" id="pred_f7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="468.57142857142856" cy="111.42857142857143" r="23.714285714285715" id="pred_g7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="540" cy="111.42857142857143" r="23.714285714285715" id="pred_h7_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="40" cy="40" r="23.714285714285715" id="pred_a8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="111.42857142857143" cy="40" r="23.714285714285715" id="pred_b8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="182.85714285714286" cy="40" r="23.714285714285715" id="pred_c8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="254.28571428571428" cy="40" r="23.714285714285715" id="pred_d8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="325.7142857142857" cy="40" r="23.714285714285715" id="pred_e8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="397.14285714285717" cy="40" r="23.714285714285715" id="pred_f8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="468.57142857142856" cy="40" r="23.714285714285715" id="pred_g8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-B" cx="540" cy="40" r="23.714285714285715" id="pred_h8_B" stroke-width="5.571428571428571" ></circle><circle class="model-pred-W" cx="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] |
|
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: Lukasz S. <luk...@gm...> - 2012-05-07 00:00:01
|
On Mon, May 7, 2012 at 12:17 AM, <luk...@us...> wrote: > Revision: 1701 > http://toss.svn.sourceforge.net/toss/?rev=1701&view=rev > Author: lukaszkaiser > Date: 2012-05-06 22:17:46 +0000 (Sun, 06 May 2012) > Log Message: > ----------- > Animation in JS interface - Bounce example works. Wow, gratulacje! Co u Ciebie słychać? U mnie trochę kiepsko, nie wyrabiam się chociaż tylko mam dwa wykłady i robienie zadań na dwa (od tego tygodnia trzy) kursy Stanforda. Chodzi mi po głowie żeby wrócić na taniec. Pozdrawiam. |
|
From: <luk...@us...> - 2012-05-08 23:30:27
|
Revision: 1702
http://toss.svn.sourceforge.net/toss/?rev=1702&view=rev
Author: lukaszkaiser
Date: 2012-05-08 23:30:19 +0000 (Tue, 08 May 2012)
Log Message:
-----------
Support for universal rules; first non-trivial dynamics example.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/Arena.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -33,7 +33,7 @@
type game = {
rules : (string * ContinuousRule.rule) list;
patterns : Formula.real_expr list;
- graph : player_loc array array;
+ graph : (player_loc array * string list) array;
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
@@ -67,7 +67,7 @@
let emp_struc = Structure.empty_structure () in
{rules = [];
patterns = [];
- graph = Array.make 1 (Array.make 1 zero_loc);
+ graph = Array.make 1 (Array.make 1 zero_loc, []);
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
@@ -121,7 +121,10 @@
) (in_p, in_m)
let fprint_loc_body pnames f loc =
- Array.iteri (fun p l -> fprint_loc_body_in pnames f p l) loc
+ Array.iteri (fun p l -> fprint_loc_body_in pnames f p l) (fst loc);
+ if (snd loc <> []) then
+ Format.fprintf f "@ @[<0>UNIVERSAL@ {%a}@]@ "
+ (Aux.fprint_sep_list ", " (fun f s -> Format.fprintf f "%s" s)) (snd loc)
let equational_def_style = ref true
@@ -248,7 +251,7 @@
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
- let rules_of_loc l =
+ let rules_of_loc (l,_) =
List.map (fun (lab,_) -> lab.lb_rule) l.(player_no).moves in
List.concat (List.map rules_of_loc (Array.to_list game.graph))
@@ -276,7 +279,7 @@
(string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule)
(* add a rule *)
- | DefLoc of ((string * int) list -> int * player_loc array)
+ | DefLoc of ((string * int) list -> int * (player_loc array * string list))
(* add location to graph *)
| DefPlayers of string list (* add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
@@ -317,19 +320,22 @@
) (Formula.Const 0., [], []) defs in
{ zero_loc with payoff = payoff ; moves = moves; heur = heurs }
-let make_location id loc_defs =
+let make_location id loc_defs universal_rules =
fun player_names ->
let locs = List.map
(fun (pl, pl_loc_defs) -> (pl, make_player_loc pl_loc_defs)) loc_defs in
- id, array_of_players zero_loc player_names locs
+ id, (array_of_players zero_loc player_names locs, universal_rules)
+(* Helper: get universal rules for a state. *)
+let get_univs game state =
+ let find_rule r = List.assoc r game.rules in
+ List.map find_rule (snd (game.graph.(state.cur_loc)))
(* Helper: Apply a move to a game state, get the new state. *)
-let apply_move rules state (m, t) =
- let r = List.assoc m.rule rules in
- let mtch =
- List.map (fun (v, e) -> v, Structure.elem_nbr state.struc e) m.matching in
- match ContinuousRule.rewrite_single state.struc state.time mtch r
+let apply_move game state (m, t) =
+ let mnbr x = List.map (fun (v, e) -> v, Structure.elem_nbr state.struc e) x in
+ match ContinuousRule.rewrite_single state.struc (get_univs game state)
+ state.time (mnbr m.matching) (List.assoc m.rule game.rules)
m.mv_time m.parameters with
| Some (new_struc, new_time, _) ->
{ struc = new_struc;
@@ -340,7 +346,7 @@
" inapplicable to " ^ (sprint_only_state state))
(* Make a move in a game. *)
-let make_move m (game, state) = (game, apply_move game.rules state (m, None))
+let make_move m (game, state) = (game, apply_move game state (m, None))
(* Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
@@ -414,14 +420,14 @@
let rules = List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
let updated_locs =
if old_locs = [] then old_locs else
- let more = num_players - Array.length (snd (List.hd old_locs)) in
- let add_more (i,loc) =
- i, Array.append loc (Array.make more zero_loc) in
+ let more = num_players - Array.length (fst (snd (List.hd old_locs))) in
+ let add_more (i, (loc, univs)) =
+ i, (Array.append loc (Array.make more zero_loc), univs) in
List.map add_more old_locs in
- let add_def_rel (i,loc) =
+ let add_def_rel (i, (loc, univs)) =
let sub_p l =
{ l with payoff = FormulaSubst.subst_rels_expr def_rels_pure l.payoff } in
- i, Array.map sub_p loc in
+ i, (Array.map sub_p loc, univs) in
LOG 3 "process_definition: parsing locations (registering payoffs)...%!";
let locations =
List.map (fun loc -> add_def_rel (loc player_names)) locations in
@@ -431,15 +437,7 @@
LOG 3 " parsed";
let graph = Aux.array_from_assoc (List.rev locations) in
let pats=List.rev_map (FormulaSubst.subst_rels_expr def_rels_pure) patterns in
- let apply_moves rules mvs s = List.fold_left (apply_move rules) s mvs in
- let result_state = match snd strucs with
- | None ->
- let st = apply_moves rules (List.rev hist)
- { snd empty_state with struc = fst strucs } in
- { st with time = time; cur_loc = cur_loc; history = hist }
- | Some struc ->
- { struc = struc; time = time; cur_loc = cur_loc; history = hist; } in
- {
+ let result_game = {
rules = rules;
patterns = pats;
graph = graph;
@@ -448,14 +446,23 @@
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
starting_struc = fst strucs;
- }, result_state
+ } in
+ let apply_moves rules mvs s = List.fold_left (apply_move result_game) s mvs in
+ let result_state = match snd strucs with
+ | None ->
+ let st = apply_moves rules (List.rev hist)
+ { snd empty_state with struc = fst strucs } in
+ { st with time = time; cur_loc = cur_loc; history = hist }
+ | Some struc ->
+ { struc = struc; time = time; cur_loc = cur_loc; history = hist; } in
+ (result_game, result_state)
(* -------------------- WHOLE ARENA MANIPULATION -------------------- *)
let add_new_player (state_game, state) pname =
let player = state_game.num_players in
- let add_more loc = Array.append loc [|zero_loc|] in
+ let add_more (loc, univs) = (Array.append loc [|zero_loc|], univs) in
let game = {state_game with
num_players = state_game.num_players + 1;
graph = Array.map add_more state_game.graph;
@@ -468,9 +475,9 @@
rules = List.map (fun (rn, r) ->
rn, ContinuousRule.map_to_formulas f r
) game.rules;
- graph = Array.map (fun la -> Array.map (fun loc ->
+ graph = Array.map (fun (la, univs) -> (Array.map (fun loc ->
{loc with payoff = FormulaMap.map_to_formulas_expr f loc.payoff;
- }) la) game.graph;
+ }) la, univs)) game.graph;
defined_rels = List.map (fun (drel, (args, def)) ->
drel, (args, f def)) game.defined_rels;
}
@@ -481,7 +488,7 @@
ContinuousRule.fold_over_formulas f r
) game.rules acc in
let acc =
- Array.fold_right (fun la -> Array.fold_right
+ Array.fold_right (fun (la, _) -> Array.fold_right
(fun loc -> FormulaMap.fold_over_formulas_expr f loc.payoff) la)
game.graph acc in
let acc =
@@ -549,9 +556,11 @@
let pnames2 = List.sort cmp_pn g2.player_names in
if pnames1 <> pnames2 then
raise (Diff_result "Game players are given in different order.");
- Array.iteri (fun i locarr1 ->
+ Array.iteri (fun i locarr1 ->
+ if (snd locarr1 <> snd g2.graph.(i)) then raise
+ (Diff_result(Printf.sprintf ("At location %d universal rules diff") i));
Array.iteri (fun pl loc1 ->
- let loc2 = g2.graph.(i).(pl) in
+ let loc2 = (fst g2.graph.(i)).(pl) in
let dmoves1 = Aux.list_diff loc1.moves loc2.moves in
if dmoves1 <> [] then raise (Diff_result (
let label, dest = List.hd dmoves1 in
@@ -572,7 +581,7 @@
Printf.sprintf
"At location %d, payffs for player %d differ:\n%s\nvs.\n%s"
i pl (Formula.real_str poff1) (Formula.real_str poff2)));
- ) locarr1
+ ) (fst locarr1)
) g1.graph;
if List.sort Pervasives.compare g1.defined_rels <>
List.sort Pervasives.compare g2.defined_rels
@@ -647,9 +656,9 @@
List.exists (fun (mv, _) -> mv.rule = rname) hist = b in
List.for_all constraint_satisfied prev_list
-let gen_models_list rules state time moves =
+let gen_models_list game state time moves =
Aux.map_some (fun mv ->
- let rule = List.assoc mv.rule rules in
+ let rule = List.assoc mv.rule game.rules in
if check_history_pre rule.ContinuousRule.discrete state.history then
let mtch = List.map (fun (v, e) ->
v, Structure.elem_nbr state.struc e) mv.matching in
@@ -660,24 +669,24 @@
history = (mv, None) :: state.history;
struc = model;
time = time}))
- (ContinuousRule.rewrite_single state.struc time mtch
- rule mv.mv_time mv.parameters)
+ (ContinuousRule.rewrite_single state.struc (get_univs game state)
+ time mtch rule mv.mv_time mv.parameters)
else None) (Array.to_list moves)
-let gen_models rules state time moves =
- let res = gen_models_list rules state time moves in
+let gen_models game state time moves =
+ let res = gen_models_list game state time moves in
let moves, states = List.split res in
Array.of_list (List.map fst moves), Array.of_list states
let list_moves_shifts game s =
- let select_moving a =
+ let select_moving (a, _) =
let pls = Aux.array_argfind_all (fun l -> l.moves <> []) a in
if pls = [] then [0] else pls in
let loc = game.graph.(s.cur_loc) in
let moving = select_moving loc in
let get_moves pl =
- let m = gen_moves cGRID_SIZE game.rules s.struc loc.(pl) in
- gen_models_list game.rules s s.time m in
+ let m = gen_moves cGRID_SIZE game.rules s.struc (fst loc).(pl) in
+ gen_models_list game s s.time m in
Array.of_list (List.concat (
List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
@@ -687,11 +696,11 @@
let apply_rule_int (state_game, state) (r_name, mtch, t, p) =
(let try r = List.assoc r_name state_game.rules in (
- match ContinuousRule.rewrite_single state.struc state.time mtch r t p with
+ let u = get_univs state_game state in
+ match ContinuousRule.rewrite_single state.struc u state.time mtch r t p with
| Some (new_struc, new_time, shifts) ->
let val_str ((f, e), tl) =
let ts t = string_of_float (Term.term_val t) in
- (* we've moved to using element names in Term *)
f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in
let shifts_s = String.concat "; " (List.map val_str shifts) in
((state_game, {state with struc = new_struc; time = new_time}),
@@ -711,7 +720,7 @@
if r_name <> "" then (
let {rules=rules; graph=graph} = game in
let struc = state.struc in
- let mv_loc = graph.(state.cur_loc).(player) in
+ let mv_loc = (fst graph.(state.cur_loc)).(player) in
let moves = gen_moves cGRID_SIZE rules struc mv_loc in
LOG 1 "apply_rewrite: r_name=%s; mtch=%s; player=%d; prules=%s; moves= %s"
r_name (ContinuousRule.matching_str struc mtch) player
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/Arena.mli 2012-05-08 23:30:19 UTC (rev 1702)
@@ -25,7 +25,7 @@
type game = {
rules : (string * ContinuousRule.rule) list;
patterns : Formula.real_expr list;
- graph : player_loc array array;
+ graph : (player_loc array * string list) array;
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
@@ -109,7 +109,7 @@
(string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule)
(** add a rule *)
- | DefLoc of ((string * int) list -> int * player_loc array)
+ | DefLoc of ((string * int) list -> int * (player_loc array * string list))
(** add location to graph *)
| DefPlayers of string list (** add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
@@ -135,8 +135,8 @@
int ->
(string * [< `Moves of (label * int) list
| `Payoff of Formula.real_expr
- | `Heurs of float list ] list) list ->
- (string * int) list -> int * player_loc array
+ | `Heurs of float list ] list) list -> string list ->
+ (string * int) list -> int * (player_loc array * string list)
(** Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
@@ -173,16 +173,6 @@
TODO: fixed for now. *)
val cGRID_SIZE : int
-(** Generate moves available from a state, as an array, in fixed
- order. Does not check postconditions. *)
-val gen_moves : int -> (string * ContinuousRule.rule) list ->
- Structure.structure -> player_loc -> move array
-
-(** Given moves available from a state, keep those for which
- postconditions pass, and return the respective resulting game states. *)
-val gen_models : (string * ContinuousRule.rule) list -> game_state ->
- float -> move array -> move array * game_state array
-
(** Get moves and resulting game states, like {!Move.gen_models}, but for
all rules the players can apply in the given game state. Returns
the player together with a move. *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-05-08 23:30:19 UTC (rev 1702)
@@ -10,7 +10,7 @@
%}
%start parse_game_defs parse_game_state
-%type <(string * int) list -> int * Arena.player_loc array> location
+%type <(string * int) list -> int * (Arena.player_loc array * string list)> location
%type <Arena.definition> parse_game_defs
%type <Arena.game * Arena.game_state> parse_game_state game_state
%type <Arena.game * Arena.game_state -> Arena.game * Arena.game_state> extend_game_state
@@ -69,11 +69,19 @@
location:
| ident = INT OPENCUR loc_defs = list (location_defs) CLOSECUR
{ try
- make_location ident loc_defs
+ make_location ident loc_defs []
with Arena_definition_error s ->
Lexer.report_parsing_error
$startpos(loc_defs) $endpos(loc_defs) s
- }
+ }
+ | ident = INT OPENCUR loc_defs = list (location_defs)
+ UNIVERSAL OPENCUR rs = separated_list (COMMA, ID) CLOSECUR CLOSECUR
+ { try
+ make_location ident loc_defs rs
+ with Arena_definition_error s ->
+ Lexer.report_parsing_error
+ $startpos(loc_defs) $endpos(loc_defs) s
+ }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in location definition."
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -3,6 +3,7 @@
let time_step = ref 0.1
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
+let dIFFM = 1 (* So many differentiation steps for one time step. *)
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
@@ -87,132 +88,114 @@
(* -------------------------- REWRITING ------------------------------------ *)
-(* Helper function to select from lists by position. *)
-let rec select_pos ids llst =
- if ids = [] then [] else
- (List.hd ids, List.map List.hd llst) ::
- (select_pos (List.tl ids) (List.map List.tl llst))
+(* Differential equations for a rule and a match, renamed to structure names. *)
+let rule_dynamics struc params (r, m) =
+ let p_vars, p_vals = List.split params in
+ let subst_params tm = List.hd
+ (Term.subst_simp p_vars (List.map (fun f -> Term.Const f) p_vals) [tm]) in
+ let d = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
+ Term.subst_names (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
+(* Construct diff equation system and initial values for dynamics. *)
+let construct_dynamics struc params rms =
+ let dyns = List.concat (List.map (rule_dynamics struc params) rms) in
+ let rec sum_common = function
+ | [] -> []
+ | (x, t) :: (y, s) :: rest when x = y ->
+ sum_common ((x, Term.Plus (t, s)) :: rest)
+ | eq :: rest-> eq :: (sum_common rest) in
+ let cmp ((f, x), t) ((g, y), s) =
+ let c = String.compare f g in if c <> 0 then c else
+ let d = String.compare x y in if d <> 0 then d else Term.compare t s in
+ let dyn = sum_common (List.sort cmp dyns) in
+ LOG 1 "%s" (Term.eq_str dyn);
+ let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
+ let init_vals = List.map (fun ((f, a), _) -> Term.Const (fval f a)) dyn in
+ (dyn, init_vals)
+
+
(* For now, we rewrite only single rules. Does not check postcondition. *)
-let rewrite_single_nocheck struc cur_time m r t params =
+let rewrite_single_nocheck struc univs cur_time m r t params =
+ let univ_mts = Aux.concat_map
+ (fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
+ let (dyn, init_vals) = construct_dynamics struc params ((r, m) :: univ_mts) in
+ LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
- LOG 1 "current time: %f" !time;
- let p_vars, p_vals = List.split params in
- let subst_params tm =
- List.hd
- (Term.subst_simp p_vars (List.map (fun f -> Term.Const f) p_vals) [tm]) in
- let re_sb = List.map
- (fun (p,v) -> p, Formula.Const v) params in
- let dyn = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
- let upd = List.map (fun (lhs, rhs) ->
- (lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
- let init_vals =
- let get_val f a =
- (* LHS is embedded in the model *)
- (let try e = List.assoc a m in
- Structure.fun_val struc f e
- with Not_found ->
- failwith
- ("rewrite_single_nocheck: get_val: could not find " ^ a ^
- " in matched " ^ String.concat "," (List.map fst m) ^
- String.concat "," (List.map (fun (_, e) -> string_of_int e) m))
- ) in
- List.map (fun ((f, a),_) -> Term.Const (get_val f a)) dyn in
- let step vals t0 =
- Term.rk4_step "t" t0 (Term.Const !time_step) dyn vals in
+ let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
+ let step vals t0 =
+ LOG 1 "step at time %s" (Term.str t0);
+ LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));
+ Term.rk4_step "t" t0 (Term.Const diff_step) dyn vals in
(* add the trace of the embedding to the structure, for invariants *)
- let apm s (le, se) =
- Structure.add_rel s ("_lhs_" ^ le) [|se|] in
- let cur_struc = ref (List.fold_left apm struc m) in
- (* the last structure for which the invariant holds, or the initial
- structure if the invariant doesn't hold for it *)
- let last_struc = ref !cur_struc in
- let cur_vals = ref init_vals in
- let all_vals = ref [] in
- let end_time = !time +. t -. (0.01 *. !time_step) in (*TODO: 1% is decimals!*)
+ let cur_struc = ref (List.fold_left (fun s (le, se) ->
+ Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
+ let last_struc, cur_vals, all_vals = ref !cur_struc, ref init_vals, ref [] in
+ let end_time = !time +. t -. (0.01 *. diff_step) in
LOG 1 "end time: %f" end_time;
- let is_inv s = Solver.M.check s r.inv in
- let lhs_to_model ((f, a), _) = (f, List.assoc a m) in
- let upd_struct st =
- let vals =
- List.combine (List.map lhs_to_model dyn)
- (List.map Term.term_val !cur_vals) in
- List.fold_left (fun s ((f,a), v) -> Structure.add_fun s f (a, v))
- st vals in
- while (!time < end_time) && (is_inv !cur_struc) do
- all_vals := !cur_vals :: !all_vals ;
+ let upd_struct st = List.fold_left2 (fun s ((f, e), _) v ->
+ Structure.change_fun s f e v) st dyn (List.map Term.term_val !cur_vals) in
+ while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
+ if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
+ t_mod_diff := !t_mod_diff + 1 mod dIFFM;
cur_vals := step !cur_vals (Term.Const !time) ;
- time := !time +. !time_step ;
+ time := !time +. diff_step ;
last_struc := !cur_struc ;
cur_struc := upd_struct !cur_struc ;
done ;
- if (is_inv !cur_struc) then (
+ if (Solver.M.check !cur_struc r.inv) then (
all_vals := !cur_vals :: !all_vals ;
last_struc := !cur_struc
) else (
- LOG 2 "Invariant failed.\n%s\n%s"
- (Structure.str !cur_struc) (Formula.sprint r.inv);
+ LOG 2 "Inv failed.\n%s\n%s" (Structure.str !cur_struc) (Formula.str r.inv);
if !all_vals = [] then
failwith "rewriting invariant failed in the first step; rule inapplicable"
else cur_vals := List.hd !all_vals;
);
- let lhs_to_model_str x =
- let (f, i) = lhs_to_model x in
- f, Structure.elem_str struc i in
- let all_vals_assoc =
- select_pos (List.map lhs_to_model_str dyn) (List.rev !all_vals) in
+ let rec select_pos ids llst =
+ if ids = [] then [] else (List.hd ids, List.map List.hd llst) ::
+ (select_pos (List.tl ids) (List.map List.tl llst)) in
+ let all_vals_assoc = select_pos (List.map fst dyn) (List.rev !all_vals) in
LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
(String.concat ", " (List.map (
fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));
- (*
- let val_map =
- if !cur_vals = [] then List.combine (List.map fst dyn) init_vals
- else List.combine (List.map fst dyn) !cur_vals in
- let upd_vals = Term.eq_vals
- (Term.subst_simp_eq [("t", Term.Const !time)] val_map upd) in
- *)
+ let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
let upd = List.map (fun (lhs, rhs) ->
+ (lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
+ let upd = List.map (fun (lhs, rhs) ->
(lhs, FormulaSubst.subst_real ["t", Formula.Const !time] rhs)) upd in
- (* we don't need to use val_map because !last_struc contains the
- evolved values *)
+ (* we don't need to use val_map because !last_struc contains evolved values *)
let asg = AssignmentSet.fo_assgn_of_list m in
- let upd_vals = List.map
- (fun (lhs,expr) ->
- let res = Solver.M.get_real_val ~asg expr !last_struc in
- LOG 1 "%s(%s) = %f (%s)" (fst lhs) (snd lhs) res (Formula.real_str expr);
- (lhs, res)) upd in
- (* we pass the evolved structure to discrete rewriting, so that
- function values can be copied to new elements in case they are
- not updated later *)
+ let upd_vals = List.map (fun (lhs, expr) ->
+ let res = Solver.M.get_real_val ~asg expr !last_struc in
+ LOG 1 "%s(%s) = %f (%s)" (fst lhs) (snd lhs) res (Formula.real_str expr);
+ (lhs, res)) upd in
+ (* we pass the evolved structure to discrete rewriting, so that function
+ values can be copied to new elements in case they are not updated later *)
let ns = DiscreteRule.rewrite_single !last_struc m r.discrete in
let set_val struc ((f, e), v) =
- let e_rel =
- (* DiscreteRule adds RHS element names to rewritten result,
- unless the rule is optimized (RHS renamed to use LHS names) *)
- Structure.rel_graph ("_right_" ^ e) struc in
+ let e_rel = Structure.rel_graph ("_right_" ^ e) struc in
let elem = (Structure.Tuples.choose e_rel).(0) in
Structure.add_fun struc f (elem, v) in
let upd_struc = List.fold_left set_val ns upd_vals in
- let res_struc = Structure.clear_rels upd_struc
- (fun rel ->
- match DiscreteRule.special_rel_of rel with None -> false
- | Some sp -> (* sp = "new" || sp = "del" || *) sp = "right") in
+ let res_struc = Structure.clear_rels upd_struc (fun rel ->
+ match DiscreteRule.special_rel_of rel with | None -> false
+ | Some sp -> sp = "right") in
(res_struc, !time, all_vals_assoc)
(* Matches which satisfy postcondition with time 1 and empty params *)
-let matches_post struc r cur_time =
+let matches_post struc univs r cur_time =
let is_ok m =
let (res_struc, _, _) =
- rewrite_single_nocheck struc cur_time m r 1. [] in
+ rewrite_single_nocheck struc univs cur_time m r 1. [] in
Solver.M.check res_struc r.post in
if r.post = Formula.And [] then matches struc r else
List.filter is_ok (matches struc r)
(* For now, we rewrite only single rules. Returns [None] if rewriting fails. *)
-let rewrite_single struc cur_time m r t params =
+let rewrite_single struc univs cur_time m r t params =
let (res_struc, _, _ as res_struc_n_shifts) =
- rewrite_single_nocheck struc cur_time m r t params in
+ rewrite_single_nocheck struc univs cur_time m r t params in
if r.post = Formula.And [] || Solver.M.check res_struc r.post then
Some res_struc_n_shifts
else None
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-05-08 23:30:19 UTC (rev 1702)
@@ -60,39 +60,34 @@
(** Find all matches of [r] in [struc] which satisfy [r]'s precondition. *)
-val matches :
- Structure.structure -> rule -> DiscreteRule.matching list
+val matches : Structure.structure -> rule -> DiscreteRule.matching list
(** Matches which satisfy postcondition with time 1 and empty params *)
-val matches_post :
- Structure.structure -> rule -> float -> DiscreteRule.matching list
+val matches_post : Structure.structure -> rule list ->
+ rule -> float -> DiscreteRule.matching list
(** {2 Rewriting} *)
-(** For now, we rewrite only single rules.
- [rewrite_single struc cur_time m r t params def_rels] rewrites
+(** For now, we rewrite only single rules, but with universal [univs].
+ [rewrite_single struc univs cur_time m r t params def_rels] rewrites
[struc] for the period [t] (unless invariant stops holding earlier)
starting in [cur_time], at matching [m], and returns the rewritten
structure, the time after the rewrite, and shifts (i.e. values for
functions supplied with dynamics equations, at each time step). *)
-val rewrite_single_nocheck :
- Structure.structure -> float ->
+val rewrite_single_nocheck : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
Structure.structure * float * ((string * string) * Term.term list) list
(** For now, we rewrite only single rules.
Same as {!ContinuousRule.rewrite_single_nocheck}, but check if the
postcondition holds. Returns [None] if rewriting fails. *)
-val rewrite_single :
- Structure.structure -> float ->
+val rewrite_single : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
- (Structure.structure *
- float * ((string * string) * Term.term list) list) option
+ (Structure.structure * float * ((string* string)* Term.term list) list) option
(** Compare two rules and explain the first difference
met. Formulas and expressions are compared for structural equality. *)
-val compare_diff :
- ?cmp_funs:(float -> float -> bool) ->
+val compare_diff : ?cmp_funs:(float -> float -> bool) ->
rule -> rule -> bool * string
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -97,8 +97,7 @@
let struc = struc_of_str "[ | P {a}; Q:1{} | x { a -> 0.0 } ]" in
let r = rule_of_str s signat [] "rule1" in
let m = List.hd (matches struc r) in
- let res, _, _ =
- Aux.unsome (rewrite_single struc 0.0 m r 1. []) in
+ let res, _, _ = Aux.unsome (rewrite_single struc [] 0.0 m r 1. []) in
assert_equal ~printer:(fun x->x)
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res));
@@ -118,13 +117,11 @@
let struc = struc_of_str "[ | P {a}; Q:1{} | x { a -> 0.0 } ]" in
let r = rule_of_str s signat [] "rule1" in
let m = List.hd (matches struc r) in
- let res, _, _ =
- Aux.unsome (rewrite_single struc 0.0 m r 1. []) in
+ let res, _, _ = Aux.unsome (rewrite_single struc [] 0.0 m r 1. []) in
assert_equal ~printer:(fun x->x) ~msg:"first rewrite"
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res));
- let res, _, _ =
- Aux.unsome (rewrite_single struc 0.0 m r 1. []) in
+ let res, _, _ = Aux.unsome (rewrite_single struc [] 0.0 m r 1. []) in
assert_equal ~printer:(fun x->x) ~msg:"second rewrite"
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res))
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-06 22:17:46 UTC (rev 1701)
+++ trunk/Toss/Arena/Term.ml 2012-05-08 23:30:19 UTC (rev 1702)
@@ -3,7 +3,7 @@
(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
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: <luk...@us...> - 2012-05-09 19:42:06
|
Revision: 1703
http://toss.svn.sourceforge.net/toss/?rev=1703&view=rev
Author: lukaszkaiser
Date: 2012-05-09 19:41:58 +0000 (Wed, 09 May 2012)
Log Message:
-----------
Make the Tyson Cell Cycle Model animate in JS interface, debug parameter passing.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/TermParser.mly
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Play.js
trunk/Toss/Client/State.js
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
Added Paths:
-----------
trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/Arena.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -627,7 +627,7 @@
let param_names, params_in =
List.split label.parameters_in in
let axes = List.map (fun (f_l,f_r) ->
- if grid_size < 2 then
+ if grid_size < 2 || f_r -. f_l < 0.00001 then
[(f_r +. f_l) /. 2.]
else
let df = (f_r -. f_l) /. float_of_int (grid_size - 1) in
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -3,7 +3,7 @@
let time_step = ref 0.1
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
-let dIFFM = 1 (* So many differentiation steps for one time step. *)
+let dIFFM = 20 (* So many differentiation steps for one time step. *)
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
@@ -90,9 +90,8 @@
(* Differential equations for a rule and a match, renamed to structure names. *)
let rule_dynamics struc params (r, m) =
- let p_vars, p_vals = List.split params in
- let subst_params tm = List.hd
- (Term.subst_simp p_vars (List.map (fun f -> Term.Const f) p_vals) [tm]) in
+ let (p_vars, t_vals) = params in
+ let subst_params tm = List.hd (Term.subst_simp p_vars t_vals [tm]) in
let d = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
Term.subst_names (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
@@ -107,7 +106,7 @@
let cmp ((f, x), t) ((g, y), s) =
let c = String.compare f g in if c <> 0 then c else
let d = String.compare x y in if d <> 0 then d else Term.compare t s in
- let dyn = sum_common (List.sort cmp dyns) in
+ let dyn = Term.subst_simp_eq [] [] (sum_common (List.sort cmp dyns)) in
LOG 1 "%s" (Term.eq_str dyn);
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
let init_vals = List.map (fun ((f, a), _) -> Term.Const (fval f a)) dyn in
@@ -118,7 +117,10 @@
let rewrite_single_nocheck struc univs cur_time m r t params =
let univ_mts = Aux.concat_map
(fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
- let (dyn, init_vals) = construct_dynamics struc params ((r, m) :: univ_mts) in
+ let tparams =
+ let p_vars, p_vals = List.split params in
+ (p_vars, List.map (fun f -> Term.Const f) p_vals) in
+ let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
@@ -136,7 +138,7 @@
Structure.change_fun s f e v) st dyn (List.map Term.term_val !cur_vals) in
while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
- t_mod_diff := !t_mod_diff + 1 mod dIFFM;
+ t_mod_diff := (!t_mod_diff + 1) mod dIFFM;
cur_vals := step !cur_vals (Term.Const !time) ;
time := !time +. diff_step ;
last_struc := !cur_struc ;
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/Term.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -87,17 +87,19 @@
| Times (p, q) -> (
match (simp_const p, simp_const q) with
| (Const n, Const m) -> Const (n *. m)
- | _ -> Times (p, q)
+ | (Const n, Times (Const m, t)) -> Times (Const (n *. m), t)
+ | (t, s) -> Times (t, s)
)
| Plus (p, q) -> (
match (simp_const p, simp_const q) with
| (Const n, Const m) -> Const (n +. m)
- | _ -> Plus (p, q)
+ | (Const n, Plus (Const m, t)) -> Plus (Const (n +. m), t)
+ | (t, s) -> Plus (t, s)
)
| Div (p, q) ->
match (simp_const p, simp_const q) with
| (Const n, Const m) -> Const (n /. m)
- | _ -> Div (p, q)
+ | (t, s)-> Div (t, s)
(* Convert a term to float, fail on non-constant term. *)
Modified: trunk/Toss/Arena/TermParser.mly
===================================================================
--- trunk/Toss/Arena/TermParser.mly 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Arena/TermParser.mly 2012-05-09 19:41:58 UTC (rev 1703)
@@ -18,12 +18,13 @@
| INT { Term.Const (float_of_int $1) }
| FLOAT { Term.Const ($1) }
| ID { Term.Var ($1) }
+ | MINUS ID { Term.Times (Term.Const (-1.), Term.Var ($2)) }
| COLON ID OPEN ID CLOSE { Term.FVar ($2, $4) }
| COLON ID OPEN INT CLOSE { Term.FVar ($2, string_of_int $4) }
- | term_expr FLOAT { Term.Plus ($1, Term.Const $2) } /* in x-1, "-1" is int */
+ | term_expr FLOAT { Term.Plus ($1, Term.Const $2) }
| term_expr INT { Term.Plus ($1, Term.Const (float_of_int $2)) }
| term_expr PLUS term_expr { Term.Plus ($1, $3) }
- | term_expr MINUS term_expr { Term.Plus ($1, Term.Times (Term.Const (-1.), $3)) }
+ | term_expr MINUS term_expr { Term.Plus ($1, Term.Times(Term.Const(-1.), $3))}
| term_expr TIMES term_expr { Term.Times ($1, $3) }
| term_expr DIV term_expr { Term.Div ($1, $3) }
| term_expr POW INT { Term.pow $1 $3 }
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-09 19:41:58 UTC (rev 1703)
@@ -69,6 +69,8 @@
("Hnefatafl", AuxIO.input_file "examples/Hnefatafl.toss");
("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
("Bounce", AuxIO.input_file "examples/Bounce.toss");
+ ("Yeast-Cell-Cycle-Tyson",
+ AuxIO.input_file "examples/Yeast-Cell-Cycle-Tyson.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/Play.js 2012-05-09 19:41:58 UTC (rev 1703)
@@ -165,7 +165,7 @@
var mv_time = document.getElementById("speed").value;
suggest_f (mv_time);
}
- }, info.length*TIMESTEP, this, info[info.length - 1])
+ }, (info.length-1)*TIMESTEP, this, info[info.length - 1])
}
Play.prototype.move_continue = play_move_continue;
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/State.js 2012-05-09 19:41:58 UTC (rev 1703)
@@ -56,7 +56,7 @@
function State (game, info_obj, mirror) {
// We create an SVG box with margins depending on the game.
this.game = game;
- this.mirror = mirror;
+ this.mirror = mirror || (game == "Yeast-Cell-Cycle-Tyson");
var create_svg_box = function (margx, margy, parent_id) {
var svg_e = document.getElementById("svg");
@@ -92,8 +92,8 @@
this.minx = info_obj.minx;
this.maxy = info_obj.maxy;
this.miny = info_obj.miny;
- this.width = Math.max (SVG_WIDTH / 100, (this.maxx - this.minx));
- this.height = Math.max (SVG_HEIGHT / 100, (this.maxy - this.miny));
+ this.width = Math.max (SVG_WIDTH / 1000, (this.maxx - this.minx));
+ this.height = Math.max (SVG_HEIGHT / 1000, (this.maxy - this.miny));
// List elements of the structure.
var els = info_obj.elems;
@@ -198,6 +198,7 @@
function square_elements_game (game) {
return (game !== "Connect4" &&
game !== "Bounce" &&
+ game !== "Yeast-Cell-Cycle-Tyson" &&
game !== "Rewriting-Example")
}
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/Style.css 2012-05-09 19:41:58 UTC (rev 1703)
@@ -1058,6 +1058,38 @@
stroke-width: 5px;
}
+.model-pred-Cyc {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #e5effa;
+}
+.model-pred-CycP1 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #a5afaa;
+}
+.model-pred-Cdc2 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #93a605;
+}
+.model-pred-Cdc2P1 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #3e5916;
+}
+.model-pred-Cdc2CycP1 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #f28705;
+}
+.model-pred-Cdc2CycP1P2 {
+ stroke: #260314;
+ stroke-width: 3px;
+ fill: #f25c05;
+}
+
+
.Game-Connect4 .model-pred-P {
fill: red;
stroke: #260314;
Added: trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/Client/index.html 2012-05-09 19:41:58 UTC (rev 1703)
@@ -171,7 +171,16 @@
</span>
</button>
</div>
+<div class="game-picdiv3">
+<button onclick="new_play_click ('Yeast-Cell-Cycle-Tyson')" class="game-picbt">
+ <img class="game-picimg" src="img/Yeast-Cell-Cycle-Tyson.png"
+ alt="Yeast-Cell-Cycle-Tyson" />
+ <span id="pdescYeast-Cell-Cycle-Tyson" class="game-picspan">
+ <span class="game-pictxt">Yeast-Cell-Cycle-Tyson</span>
+ </span>
+</button>
</div>
+</div>
<ul id="welcome-list-main" class="welcome-list">
<li>Play
@@ -450,9 +459,16 @@
the way discrete structure rewriting works.</p>
</div>
<div class="game-desc" id="Bounce-desc">
- <p><b>Bounce</b> is the basic example we use to illustrate
- the way continuous dynamics works with structure rewriting.</p>
+ <p><b>Bounce</b> is the basic example we use to illustrate how continuous
+ dynamics and invariants work with structure rewriting.</p>
</div>
+ <div class="game-desc" id="Yeast-Cell-Cycle-Tyson-desc">
+ <p><b>Yeast Cell Cycle</b> model by <b>Tyson</b> (1991),
+ <a href="http://www.cellerator.org/notebooks/Tyson6.html">described
+ here</a>, is a model of the cell cycle based on the interactions
+ between cdc2 and cyclin. We use it as an example of non-linear
+ dynamics with universal rules and parameters.</p>
+ </div>
</div>
<div id="bottom">
Modified: trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
===================================================================
--- trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-08 23:30:19 UTC (rev 1702)
+++ trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss 2012-05-09 19:41:58 UTC (rev 1703)
@@ -3,65 +3,73 @@
RULE k1:
[ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ]
dynamics
- :y(e1)' = 0.015
+ :y(e1)' = k1
RULE k3:
[ e1, e2, e3 | Cyc(e1); Cdc2P1(e2); Cdc2CycP1P2(e3) | ] ->
[ e1, e2, e3 | Cyc(e1); Cdc2P1(e2); Cdc2CycP1P2(e3) | ]
dynamics
- :y(e1)' = -200 * :y(e1) * :y(e2);
- :y(e2)' = -200 * :y(e1) * :y(e2);
- :y(e3)' = 200. * :y(e1) * :y(e2)
+ :y(e1)' = -k3 * :y(e1) * :y(e2);
+ :y(e2)' = -k3 * :y(e1) * :y(e2);
+ :y(e3)' = k3 * :y(e1) * :y(e2)
RULE k4p:
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ] ->
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ]
dynamics
- :y(e1)' = -0.018 * :y(e1);
- :y(e2)' = 0.0180 * :y(e1)
+ :y(e1)' = -k4p * :y(e1);
+ :y(e2)' = k4p * :y(e1)
RULE k4:
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ] ->
[ e1, e2 | Cdc2CycP1P2(e1); Cdc2CycP1(e2) | ]
dynamics
- :y(e1)' = -180 * :y(e1) * :y(e2) * :y(e2);
- :y(e2)' = 180. * :y(e1) * :y(e2) * :y(e2)
+ :y(e1)' = -k4 * :y(e1) * :y(e2) * :y(e2);
+ :y(e2)' = k4 * :y(e1) * :y(e2) * :y(e2)
RULE k6:
[ e1, e2, e3 | Cdc2CycP1(e1); CycP1(e2); Cdc2(e3) | ] ->
[ e1, e2, e3 | Cdc2CycP1(e1); CycP1(e2); Cdc2(e3) | ]
dynamics
- :y(e1)' = -1 * :y(e1);
- :y(e2)' = 1. * :y(e1);
- :y(e3)' = 1. * :y(e1)
+ :y(e1)' = -k6 * :y(e1);
+ :y(e2)' = k6 * :y(e1);
+ :y(e3)' = k6 * :y(e1)
RULE k7:
[ e1 | CycP1(e1) | ] -> [ e1 | CycP1(e1) | ]
dynamics
- :y(e1)' = -0.6 * :y(e1)
+ :y(e1)' = -k7 * :y(e1)
RULE k8:
[ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ] -> [ e1, e2 | Cdc2(e1); Cdc2P1(e2) | ]
dynamics
- :y(e1)' = -100 * :y(e1);
- :y(e2)' = 100. * :y(e1)
+ :y(e1)' = -k8 * :y(e1);
+ :y(e2)' = k8 * :y(e1)
RULE k9:
[ e1, e2 | Cdc2P1(e1); Cdc2(e2) | ] -> [ e1, e2 | Cdc2P1(e1); Cdc2(e2) | ]
dynamics
- :y(e1)' = -100 * :y(e1);
- :y(e2)' = 100. * :y(e1)
+ :y(e1)' = -k9 * :y(e1);
+ :y(e2)' = k9 * :y(e1)
RULE Move:
[ e1 | Cyc(e1) | ] -> [ e1 | Cyc(e1) | ]
LOC 0 {
- PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 0] }
+ PLAYER 1 { PAYOFF 0. MOVES [Move,
+ t : 9. -- 9.,
+ k1 : 0.015 -- 0.015,
+ k3 : 200. -- 200.,
+ k4p: 0.018 -- 0.018,
+ k4 : 180. -- 180.,
+ k6 : 1. -- 1.,
+ k7 : 0.6 -- 0.6,
+ k8 : 100. -- 100.,
+ k9 : 100. -- 100. -> 0] }
PLAYER 2 { PAYOFF 0. }
UNIVERSAL { k1, k3, k4p, k4, k6, k7, k8, k9 }
}
-START [ e1, e2, e3, e4, e5, e6 |
- Cdc2(e1); Cdc2P1(e2); Cyc(e3);
- Cdc2CycP1P2(e4); Cdc2CycP1(e5); CycP1(e6) |
- x { e1->10, e2->20, e3->30, e4->40, e5->50, e6->60 };
- y { e1->1, e2->0, e3->0, e4->0, e5->0, e6->0 } ]
+START [ e1, e2, e3, e4, e5, e6 | Cyc(e1); CycP1(e2); Cdc2(e3); Cdc2P1(e4);
+ Cdc2CycP1(e5); Cdc2CycP1P2(e6) |
+ x { e1->1, e2->2, e3->3, e4->4, e5->5, e6->6 };
+ y { e1->0, e2->0, e3->1, e4->0, e5->0, e6->0 } ]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-05-10 22:22:16
|
Revision: 1704
http://toss.svn.sourceforge.net/toss/?rev=1704&view=rev
Author: lukaszkaiser
Date: 2012-05-10 22:22:09 +0000 (Thu, 10 May 2012)
Log Message:
-----------
Corrections to term simplification, renaming example.
Modified Paths:
--------------
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/State.js
trunk/Toss/Client/index.html
trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/RealQuantElim/Poly.mli
Added Paths:
-----------
trunk/Toss/Client/img/Cell-Cycle-Tyson-1991.png
trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
Removed Paths:
-------------
trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
trunk/Toss/examples/Yeast-Cell-Cycle-Tyson.toss
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Arena/Term.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -2,6 +2,8 @@
(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
+let simp_symb = ref false
+
type term =
| Var of string
| FVar of string * string
@@ -80,27 +82,58 @@
(* -------------------- SIMPLIFICATION OF CONSTANTS ------------------------- *)
(* Basic simplification, reduces constant terms to floats. *)
-let rec simp_const = function
+let rec simp_const_only = function
| Var s -> Var s
| FVar (f, a) -> FVar (f, a)
| Const n -> Const n
| Times (p, q) -> (
- match (simp_const p, simp_const q) with
+ match (simp_const_only p, simp_const_only q) with
| (Const n, Const m) -> Const (n *. m)
- | (Const n, Times (Const m, t)) -> Times (Const (n *. m), t)
| (t, s) -> Times (t, s)
)
| Plus (p, q) -> (
- match (simp_const p, simp_const q) with
+ match (simp_const_only p, simp_const_only q) with
| (Const n, Const m) -> Const (n +. m)
- | (Const n, Plus (Const m, t)) -> Plus (Const (n +. m), t)
| (t, s) -> Plus (t, s)
)
| Div (p, q) ->
- match (simp_const p, simp_const q) with
+ match (simp_const_only p, simp_const_only q) with
| (Const n, Const m) -> Const (n /. m)
| (t, s)-> Div (t, s)
+let simp_const t =
+ let rec to_poly = function
+ | Var s -> Poly.Var ("V" ^ s)
+ | FVar (f, a) -> Poly.Var ("F" ^ f ^ "#" ^ a)
+ | Const n -> Poly.Const n
+ | Times (p, q) -> Poly.Times (to_poly p, to_poly q)
+ | Plus (p, q) -> Poly.Plus (to_poly p, to_poly q)
+ | Div _ -> raise Not_found in
+ let rec from_ord = function
+ | OrderedPoly.Const _ -> failwith "num after non-num translation"
+ | OrderedPoly.FConst num -> Const (num)
+ | OrderedPoly.Poly (v, coefs) ->
+ let w = if v.[0]= 'V' then Var (String.sub v 1 ((String.length v)-1)) else
+ let i, l = String.index v '#', String.length v in
+ FVar (String.sub v 1 (i-1), String.sub v (i+1) (l-i-1)) in
+ let res = List.fold_left (fun acc (a, j) ->
+ if j = 0 then Plus (acc, from_ord a) else
+ match from_ord a with
+ | Const n when n = 1. -> Plus (acc, pow w j)
+ | ordt -> Plus (acc, Times (ordt, pow w j))
+ ) (Const 0.) coefs in
+ LOG 1 "res %s" (str res);
+ let rec del_zero = function
+ | Plus (Const n, t) when n = 0. -> t
+ | Plus (t, s) -> Plus (del_zero t, s)
+ | t -> t in
+ del_zero res in
+ match simp_const_only t with
+ | Const n -> Const n
+ | t -> if not !simp_symb then t else
+ try let p = to_poly t in
+ from_ord (Poly.make_ordered ~use_num:false [] p)
+ with Not_found -> t
(* Convert a term to float, fail on non-constant term. *)
let term_val t = match simp_const t with
Modified: trunk/Toss/Arena/Term.mli
===================================================================
--- trunk/Toss/Arena/Term.mli 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Arena/Term.mli 2012-05-10 22:22:09 UTC (rev 1704)
@@ -16,6 +16,9 @@
(** {2 Basic functions.} *)
+(** Whether to simplify symbolically or not. Set to false by default.
+ It is nice for symbolic stuff, but slows down numerics. *)
+val simp_symb : bool ref
(** Print a term as a string. *)
val str : term -> string
Modified: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Arena/TermTest.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -74,6 +74,39 @@
assert_equal ~printer:(fun x->x) "0.005"
(String.sub (str (List.hd (
rk4_step "t" (Const 0.) (Const 0.1) eqs [Const 0.]))) 0 5);
+ );
+ "rk4 eq" >::
+ (fun () ->
+ (* Runge-Kutta symbolically with 2 free parameters. *)
+ let tyson = eqs_of_string
+ (" :y(e1)' = 0.015 + -200. * :y(e1) * :y(e4); " ^
+ ":y(e2)' = -0.6 * :y(e2) + k6 * :y(e5); " ^
+ ":y(e3)' = -100. * :y(e3) + k6 * :y(e5) + 100. * :y(e4); " ^
+ ":y(e4)' = -100.*:y(e4) + 100.*:y(e3) + -200.*:y(e1) * :y(e4); " ^
+ ":y(e5)' = -k6 * :y(e5) + 0.018 * :y(e6) + " ^
+ " k4 * :y(e6) * :y(e5) * :y(e5); " ^
+ ":y(e6)' = -0.018 * :y(e6) + 200. * :y(e1) * :y(e4) + " ^
+ " -k4 * :y(e6) * :y(e5) * :y(e5)") in
+ let init = [Const 0.; Const 0.; Const 1.; Const 0.; Const 0.; Const 0.] in
+ Term.simp_symb := true;
+ let res = rk4_step "t" (Const 0.) (Const 0.005) tyson init in
+ Term.simp_symb := false;
+ let val_str vs = String.concat ", " (List.map str vs) in
+ assert_equal ~printer:(fun x->x)
+ ("6.6076722582e-05, 3.515625e-13 * k6, 3.515625e-13 * k6 + " ^
+ "0.687499267591, 0.312491809132, -3.515625e-13 * k6 + " ^
+ "6.08239621818e-28 * k4 + 2.02139802246e-10, " ^
+ "-6.08239621818e-28 * k4 + 8.9230752782e-06") (val_str res);
+
+ (* Generate RK4 equations symbolically for [eq], step [n]. *)
+ (*let generate_rksymb eq n t0 tstep =
+ let init m = Array.to_list (Array.mapi (fun i _ ->
+ Term.Var (Printf.sprintf "v%iat%i" i m)) (Array.of_list eq)) in
+ let res = rk4_step "t" (Const t0) (Const tstep) eq (init n) in
+ String.concat "\n" (List.map2 (fun t v ->
+ (Term.str t) ^ " = " ^ (Term.str v) ^ "\n") (init (n+1)) res) in
+ assert_equal ~printer:(fun x->x) "ok" (generate_rksymb tyson 0 0. 0.005);
+ *)
);
]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -69,8 +69,8 @@
("Hnefatafl", AuxIO.input_file "examples/Hnefatafl.toss");
("Rewriting-Example", AuxIO.input_file "examples/Rewriting-Example.toss");
("Bounce", AuxIO.input_file "examples/Bounce.toss");
- ("Yeast-Cell-Cycle-Tyson",
- AuxIO.input_file "examples/Yeast-Cell-Cycle-Tyson.toss");
+ ("Cell-Cycle-Tyson-1991",
+ AuxIO.input_file "examples/Cell-Cycle-Tyson-1991.toss");
]
let gSel_games = ref [compile_game_data "Tic-Tac-Toe"
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Client/State.js 2012-05-10 22:22:09 UTC (rev 1704)
@@ -56,7 +56,7 @@
function State (game, info_obj, mirror) {
// We create an SVG box with margins depending on the game.
this.game = game;
- this.mirror = mirror || (game == "Yeast-Cell-Cycle-Tyson");
+ this.mirror = mirror || (game == "Cell-Cycle-Tyson-1991");
var create_svg_box = function (margx, margy, parent_id) {
var svg_e = document.getElementById("svg");
@@ -198,7 +198,7 @@
function square_elements_game (game) {
return (game !== "Connect4" &&
game !== "Bounce" &&
- game !== "Yeast-Cell-Cycle-Tyson" &&
+ game !== "Cell-Cycle-Tyson-1991" &&
game !== "Rewriting-Example")
}
Copied: trunk/Toss/Client/img/Cell-Cycle-Tyson-1991.png (from rev 1703, trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png)
===================================================================
(Binary files differ)
Deleted: trunk/Toss/Client/img/Yeast-Cell-Cycle-Tyson.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Client/index.html 2012-05-10 22:22:09 UTC (rev 1704)
@@ -172,11 +172,11 @@
</button>
</div>
<div class="game-picdiv3">
-<button onclick="new_play_click ('Yeast-Cell-Cycle-Tyson')" class="game-picbt">
- <img class="game-picimg" src="img/Yeast-Cell-Cycle-Tyson.png"
- alt="Yeast-Cell-Cycle-Tyson" />
- <span id="pdescYeast-Cell-Cycle-Tyson" class="game-picspan">
- <span class="game-pictxt">Yeast-Cell-Cycle-Tyson</span>
+<button onclick="new_play_click ('Cell-Cycle-Tyson-1991')" class="game-picbt">
+ <img class="game-picimg" src="img/Cell-Cycle-Tyson-1991.png"
+ alt="Cell-Cycle-Tyson-1991" />
+ <span id="pdescCell-Cycle-Tyson-1991" class="game-picspan">
+ <span class="game-pictxt">Cell-Cycle-Tyson-1991</span>
</span>
</button>
</div>
@@ -462,8 +462,8 @@
<p><b>Bounce</b> is the basic example we use to illustrate how continuous
dynamics and invariants work with structure rewriting.</p>
</div>
- <div class="game-desc" id="Yeast-Cell-Cycle-Tyson-desc">
- <p><b>Yeast Cell Cycle</b> model by <b>Tyson</b> (1991),
+ <div class="game-desc" id="Cell-Cycle-Tyson-1991-desc">
+ <p>Yeast <b>Cell Cycle</b> model by <b>Tyson (1991)</b>,
<a href="http://www.cellerator.org/notebooks/Tyson6.html">described
here</a>, is a model of the cell cycle based on the interactions
between cdc2 and cyclin. We use it as an example of non-linear
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -12,7 +12,10 @@
Poly (z, [(Poly(y, [(Poly (x, [(Const 1, 1)]), 0)]), 2);
(Poly(y, [(Poly (x, [(Const 2, 0)]), 0)]), 0)]) *)
-type polynomial = Const of num | Poly of string * (polynomial * int) list
+type polynomial =
+ | FConst of float
+ | Const of num
+ | Poly of string * (polynomial * int) list
type t = polynomial (* to be compatible with OrderedType signature *)
@@ -26,7 +29,8 @@
(* Print the given ordered polynomial as a string. *)
let rec str = function
- Const n -> string_of_num n
+ | FConst n -> string_of_float n
+ | Const n -> string_of_num n
| Poly (v, clist) ->
let estr (p, d) =
if d = 0 then "(" ^ (str p) ^ ")" else if d = 1 then
@@ -41,7 +45,8 @@
(* Check if the given ordered polynomial is equal to zero. *)
let rec is_zero = function
- Const n -> (sign_num n) = 0
+ | FConst n -> n = 0.
+ | Const n -> (sign_num n) = 0
| Poly (_, []) -> true
| Poly (_, [(c, n)]) -> n = 0 && is_zero c
| _ -> false
@@ -50,11 +55,14 @@
do not assume that both arguments are over the same set of variables. *)
let rec rcompare p1 p2 =
match (p1, p2) with
- (Const n, Const m) ->
- let c = sign_num ((abs_num n) -/ (abs_num m)) in
- if c <> 0 then c else sign_num (n -/ m)
+ | (FConst n, FConst m) -> if n > m then 1 else if m > n then -1 else 0
+ | (Const n, Const m) ->
+ let c = sign_num ((abs_num n) -/ (abs_num m)) in
+ if c <> 0 then c else sign_num (n -/ m)
| (Const _, _) -> -1
| (_, Const _) -> 1
+ | (FConst _, _) -> -1
+ | (_, FConst _) -> 1
| (Poly (v, [(c, d)]), Poly (w, [])) -> if d = 0 && is_zero c then 0 else 1
| (Poly (w, []), Poly (v, [(c, d)])) -> if d = 0 && is_zero c then 0 else -1
| (Poly (_, _::_), Poly (_, [])) -> 1
@@ -62,19 +70,19 @@
| (Poly (_, []), Poly (_, [])) -> 0
| (Poly (v, _), Poly (w, _)) when v <> w -> String.compare v w
| (Poly (v, (c1, d1)::r1), Poly (w, (c2, d2)::r2)) ->
- if d1 <> d2 then d1 - d2 else
- let c = rcompare c1 c2 in
- if c <> 0 then c else rcompare (Poly (v, r1)) (Poly (w, r2))
+ if d1 <> d2 then d1 - d2 else
+ let c = rcompare c1 c2 in
+ if c <> 0 then c else rcompare (Poly (v, r1)) (Poly (w, r2))
let rec deg_sum acc = function
- Const _ -> acc
+ | Const _ | FConst _ -> acc
| Poly (v, lst) ->
- let deg_sumi acc (p, i) = deg_sum (i + acc) p in
- List.fold_left deg_sumi acc lst
+ let deg_sumi acc (p, i) = deg_sum (i + acc) p in
+ List.fold_left deg_sumi acc lst
let compare p q =
let d = (deg_sum 0 p) - (deg_sum 0 q) in
- if d <> 0 then d else rcompare p q
+ if d <> 0 then d else rcompare p q
(* Check if two polynomials are equal. *)
let equal p1 p2 = (compare p1 p2 = 0)
@@ -85,78 +93,80 @@
(* Helper function to extract main variable from an ordered polynomial. *)
let var = function
- Const _ -> raise Unmatched_variables
+ | Const _ | FConst _ -> raise Unmatched_variables
| Poly (v, _) -> v
(* Lower the number of variables of a polynomial - remove the highest. *)
let lower = function
- Poly (v, [(q, d)]) when d = 0 -> q
+ | Poly (v, [(q, d)]) when d = 0 -> q
| _ -> failwith "cannot lower non-constant or zero polynomial"
(* Check if the given ordered polynomial has constant value. *)
let rec constant_value = function
- Const n -> Some n
+ | FConst n -> failwith "constant value for FConst; TODO move from Poly.ml"
+ | Const n -> Some n
| Poly (_, []) -> Some (num_of_int 0)
| Poly (_, (c, d) :: rest) when d = 0 -> constant_value c
| _ -> None
(* Degree of the given polynomial in its highest variable. *)
let deg = function
- Poly (_, (_, d) :: _) -> d
+ | Poly (_, (_, d) :: _) -> d
| _ -> 0
(* Leading coefficient of the given polynomial, represented as ordered
polynomial, multiplied by main variable raised to [n]-th power. *)
let leading_coeff n = function
- Poly (v, (c, _) :: _) -> Poly (v, [(c, n)])
+ | Poly (v, (c, _) :: _) -> Poly (v, [(c, n)])
| Poly (v, []) -> Poly (v, [])
| Const n -> Const n
+ | FConst n -> FConst n
(* Degree 0 coefficient of the given polynomial, if it exists and is non-0. *)
let rec const_coeff = function
- Poly (v, [(q, d)]) as p when d = 0 && not (is_zero q) -> Some p
+ | Poly (v, [(q, d)]) as p when d = 0 && not (is_zero q) -> Some p
| Poly (v, _ :: rs) -> const_coeff (Poly (v, rs))
| _ -> None
(* Omit leading coefficient in the given polynomial. *)
let omit_leading = function
- Poly (v, _ :: rest) -> Poly (v, rest)
+ | Poly (v, _ :: rest) -> Poly (v, rest)
| x -> x
(* Calculate n * p for a given polynomial p. *)
let rec multiple n = function
- Const m -> Const ((num_of_int n) */ m)
+ | FConst m -> FConst ((float_of_int n) *. m)
+ | Const m -> Const ((num_of_int n) */ m)
| Poly (v, l) ->
- if n = 0 then Poly (v, []) else
- Poly (v, List.map (fun (c, d) -> (multiple n c, d)) l)
+ if n = 0 then Poly (v, []) else
+ Poly (v, List.map (fun (c, d) -> (multiple n c, d)) l)
let rec multiple_num n = function
- Const m -> Const (n */ m)
+ | FConst m -> failwith "multiple num for FConst; TODO move from Poly.ml"
+ | Const m -> Const (n */ m)
| Poly (v, l) ->
- if sign_num n = 0 then Poly (v, []) else
- Poly (v, List.map (fun (c, d) -> (multiple_num n c, d)) l)
+ if sign_num n = 0 then Poly (v, []) else
+ Poly (v, List.map (fun (c, d) -> (multiple_num n c, d)) l)
(* If c1 * p = c2 * q for constants (c1,c2) <> (0,0), return them; else None. *)
let rec constant_factors p0 q0 =
match (p0, q0) with
- (Const n, Const m) ->
- if (sign_num m) <> 0 or (sign_num n) <> 0 then
- Some (m, n)
- else None
+ | (Const n, Const m) ->
+ if (sign_num m) <> 0 or (sign_num n) <> 0 then Some (m, n) else None
| (Poly (v, []), _) ->
- if is_zero q0 then None else Some (num_of_int 1, num_of_int 0)
+ if is_zero q0 then None else Some (num_of_int 1, num_of_int 0)
| (_, Poly (v, [])) ->
- if is_zero p0 then None else Some (num_of_int 0, num_of_int 1)
+ if is_zero p0 then None else Some (num_of_int 0, num_of_int 1)
| (Poly (v, (p, d)::ps), Poly (w, (q, e)::qs)) when w = v -> (
- if d <> e then None else match constant_factors p q with
- None -> None
- | Some (a, b) ->
- if equal (multiple_num a p0) (multiple_num b q0) then
- Some (a,b)
- else None
- )
+ if d <> e then None else match constant_factors p q with
+ | None -> None
+ | Some (a, b) ->
+ if equal (multiple_num a p0) (multiple_num b q0) then
+ Some (a,b)
+ else None
+ )
| _ -> raise Unmatched_variables
@@ -165,23 +175,24 @@
(* Add two ordered polynomials [p1] and [p2] in the same variable. *)
let rec add p1 p2 =
match (p1, p2) with
- (Const n, Const m) -> Const (n +/ m)
+ | (FConst n, FConst m) -> FConst (n +. m)
+ | (Const n, Const m) -> Const (n +/ m)
| (Poly (v, l1), Poly (w, l2)) when v = w -> Poly (v, add_lists (l1, l2))
| _ -> raise Unmatched_variables
and add_lists = function
- ([(p, d)], []) when d = 0 && is_zero p -> []
+ | ([(p, d)], []) when d = 0 && is_zero p -> []
| ([], [(p, d)]) when d = 0 && is_zero p -> []
| (l1, []) -> l1
| ([], l2) -> l2
| ((c1, d1) :: r1, (c2, d2) :: r2) ->
- if d1 > d2 then
- (c1, d1) :: (add_lists (r1, (c2, d2) :: r2))
- else if d2 > d1 then
- (c2, d2) :: (add_lists ((c1, d1) :: r1, r2))
- else let c = add c1 c2 in
- if is_zero c then add_lists (r1, r2) else
- (c, d1) :: (add_lists (r1, r2))
+ if d1 > d2 then
+ (c1, d1) :: (add_lists (r1, (c2, d2) :: r2))
+ else if d2 > d1 then
+ (c2, d2) :: (add_lists ((c1, d1) :: r1, r2))
+ else let c = add c1 c2 in
+ if is_zero c then add_lists (r1, r2) else
+ (c, d1) :: (add_lists (r1, r2))
(* Given a polynomial p, returns -p. *)
let neg p = multiple (-1) p
@@ -192,76 +203,78 @@
(* Multiply two polynomials [p1] and [p2] in the same variables. *)
let rec mul p1 p2 =
match (p1, p2) with
- (Const n, Const m) -> Const (n */ m)
+ | (FConst n, FConst m) -> FConst (n *. m)
+ | (Const n, Const m) -> Const (n */ m)
| (Poly (v, l1), Poly (w, l2)) when v = w -> Poly (v, mul_lists l1 l2)
| _ -> raise Unmatched_variables
and mul_lists l1 = function
| [] -> []
| [(c2, d2)] ->
- let append_coeff_mul (c1, d1) acc =
- let c = mul c2 c1 in
- if is_zero c then acc else (c, d1 + d2) :: acc
- in
- List.fold_right append_coeff_mul l1 []
+ let append_coeff_mul (c1, d1) acc =
+ let c = mul c2 c1 in
+ if is_zero c then acc else (c, d1 + d2) :: acc in
+ List.fold_right append_coeff_mul l1 []
| c :: rest ->
- add_lists ((mul_lists l1 [c]), (mul_lists l1 rest))
+ add_lists ((mul_lists l1 [c]), (mul_lists l1 rest))
(* Raise [p] to n-th power. *)
let rec pow p n =
if n < 1 then failwith "we only support powers > 0" else if n = 1 then p else
- let q = pow p (n / 2) in
+ let q = pow p (n / 2) in
if n mod 2 = 0 then mul q q else mul p (mul q q)
(* Given [u] and [p] return, if possible, q and r with [u] = q*[p] + r. *)
(* Based on code from Jean-Christophe Filliatre, cf. Knuth volume 2, 4.6.1. *)
let rec div ?(allow_frac=false) p q =
- match (p, q) with
- (Const n, Const m) ->
- if allow_frac then Const (n // m) else
- if sign_num (mod_num n m) = 0 then Const (n // m) else
- raise Not_found
- | (Poly (v, _), Poly (w, _)) ->
- if v <> w then raise Unmatched_variables else
- let (l, r) = div_rest ~allow_frac:allow_frac p q in
- if is_zero r then l else raise Not_found
- | _ -> raise Unmatched_variables
+ match (p, q) with
+ | (Const n, Const m) ->
+ if allow_frac then Const (n // m) else
+ if sign_num (mod_num n m) = 0 then Const (n // m) else
+ raise Not_found
+ | (Poly (v, _), Poly (w, _)) ->
+ if v <> w then raise Unmatched_variables else
+ let (l, r) = div_rest ~allow_frac:allow_frac p q in
+ if is_zero r then l else raise Not_found
+ | _ -> raise Unmatched_variables
and div_rest ?(allow_frac=false) u = function
- Poly (_, []) -> raise Not_found
+ | Poly (_, []) -> raise Not_found
+ | FConst _ -> failwith "div_rest: FConst arg"
| Const n -> (
- match u with
- Const m ->
- if allow_frac then (Const (n // m), Const (num_of_int 0)) else
- let r = mod_num n m in (Const ((n -/ r) // m), Const r)
- | Poly (_, _) -> raise Unmatched_variables
- )
+ match u with
+ | FConst _ -> failwith "div_rest: FConst u"
+ | Const m ->
+ if allow_frac then (Const (n // m), Const (num_of_int 0)) else
+ let r = mod_num n m in (Const ((n -/ r) // m), Const r)
+ | Poly (_, _) -> raise Unmatched_variables
+ )
| Poly (v, (p, d) :: ps) ->
- let rec loop k = function
- u when k < 0 -> (Poly (v, []), u)
- | Poly (w, _) when w <> v -> raise Unmatched_variables
- | Poly (_, (q, i) :: qs) when i = d + k ->
- let qk = div ~allow_frac:allow_frac q p in
- let mqkxk = Poly (v, [(neg qk, k)]) in
- let added = add (Poly (v, qs)) (mul mqkxk (Poly (v, ps))) in
- let (q, r) = loop (k - 1) added in (
- match q with
- Poly (_, ql) -> (Poly (v, (qk, k) :: ql), r)
- | _ -> failwith "error by division"
- )
- | u -> loop (k - 1) u
- in
- loop (deg u - d) u
+ let rec loop k = function
+ | u when k < 0 -> (Poly (v, []), u)
+ | Poly (w, _) when w <> v -> raise Unmatched_variables
+ | Poly (_, (q, i) :: qs) when i = d + k ->
+ let qk = div ~allow_frac:allow_frac q p in
+ let mqkxk = Poly (v, [(neg qk, k)]) in
+ let added = add (Poly (v, qs)) (mul mqkxk (Poly (v, ps))) in
+ let (q, r) = loop (k - 1) added in (
+ match q with
+ | Poly (_, ql) -> (Poly (v, (qk, k) :: ql), r)
+ | _ -> failwith "error by division"
+ )
+ | u -> loop (k - 1) u in
+ loop (deg u - d) u
(* -------------------------- DIFFERENTIATION ------------------------------- *)
let rec diff = function
- Const n -> Const (num_of_int 0)
+ | FConst _ -> FConst (0.)
+ | Const _ -> Const (num_of_int 0)
| Poly (v, l) -> Poly (v, diff_list l)
and diff_list = function
- [] -> []
+ | [] -> []
| (c, d) :: r -> if d > 0 then (multiple d c, d-1) :: (diff_list r) else []
@@ -277,21 +290,20 @@
*)
let modified_remainder p1 q =
match q with
- Const _ -> raise Unmatched_variables
+ | Const _ | FConst _ -> raise Unmatched_variables
| Poly (v, _) when var p1 <> v -> raise Unmatched_variables
| Poly (v, _) ->
- let (m, b, q') = (deg q, leading_coeff 0 q, omit_leading q) in
- if m > deg p1 then failwith "Modified reminder: wrong degree." else
- let rec mr p =
- let (n, a) = (deg p, leading_coeff 0 p) in
- if n < m then p
- else if n = m then
- sub (mul b p) (mul a q)
- else
- let bp = mul b (omit_leading p) in
- let d = sub bp (mul (leading_coeff (n-m) p) q') in
- if n - 1 = deg d then mr d else
- let bpow = pow b (n - 1 - (deg d)) in
- mr (mul bpow d)
- in
- mr p1
+ let (m, b, q') = (deg q, leading_coeff 0 q, omit_leading q) in
+ if m > deg p1 then failwith "Modified reminder: wrong degree." else
+ let rec mr p =
+ let (n, a) = (deg p, leading_coeff 0 p) in
+ if n < m then p
+ else if n = m then
+ sub (mul b p) (mul a q)
+ else
+ let bp = mul b (omit_leading p) in
+ let d = sub bp (mul (leading_coeff (n-m) p) q') in
+ if n - 1 = deg d then mr d else
+ let bpow = pow b (n - 1 - (deg d)) in
+ mr (mul bpow d) in
+ mr p1
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-05-10 22:22:09 UTC (rev 1704)
@@ -3,7 +3,10 @@
(** {2 Basic Type Definitions} *)
-type polynomial = Const of Numbers.num | Poly of string * (polynomial*int) list
+type polynomial =
+ | FConst of float
+ | Const of Numbers.num
+ | Poly of string * (polynomial * int) list
type t = polynomial (** to be compatible with OrderedType signature *)
Modified: trunk/Toss/Solver/RealQuantElim/Poly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-05-09 19:41:58 UTC (rev 1703)
+++ trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-05-10 22:22:09 UTC (rev 1704)
@@ -3,7 +3,7 @@
(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
type polynomial =
- Var of string
+ | Var of string
| Const of float
| Times of polynomial * polynomial
| Plus of polynomial * polynomial
@@ -13,16 +13,18 @@
(* Print a polynomial as a string. *)
let rec str = function
- Var s -> s
+ | Var s -> s
| Const n -> string_of_float n
- | Times (Const n, q) -> if n = 1. then str q else poly_pair_str "*" (Const n) q
+ | Times (Const n, q) ->
+ if n = 1. then str q else poly_pair_str "*" (Const n) q
| Times (p, q) -> poly_pair_str "*" p q
- | Plus (p, Const n) -> if n = 0. then str p else poly_pair_str " + " p (Const n)
+ | Plus (p, Const n) ->
+ if n = 0. then str p else poly_pair_str " + " p (Const n)
| Plus (p, q) -> poly_pair_str " + " p q
and poly_pair_str sep p q =
let brack s = if String.length s < 2 then s else "(" ^ s ^ ")" in
- (brack (str p)) ^ sep ^ (brack (str q))
+ (brack (str p)) ^ sep ^ (brack (str q))
(* ------------------ HELPER POWER FUNCTION USED IN PARSER ------------------ *)
@@ -33,27 +35,28 @@
(* Basic simplification, reduces constant polynomials to integers. *)
let rec simp_const = function
- Var s -> Var s
+ | Var s -> Var s
| Const n -> Const n
| Times (p, q) -> (
match (simp_const p, simp_const q) with
- (Const n, Const m) -> Const (n *. m)
+ | (Const n, Const m) -> Const (n *. m)
| _ -> Times (p, q)
- )
+ )
| Plus (p, q) ->
- match (simp_const p, simp_const q) with
- (Const n, Const m) -> Const (n +. m)
- | _ -> Plus (p, q)
+ match (simp_const p, simp_const q) with
+ | (Const n, Const m) -> Const (n +. m)
+ | _ -> Plus (p, q)
(* ----------------- CONVERTION TO UNORDERED POLYNOMIALS -------------------- *)
let rec make_unordered = function
+ | OrderedPoly.FConst n -> Const (n)
| OrderedPoly.Const n -> Const (Numbers.float_of_num n)
| OrderedPoly.Poly (v, lst) -> make_unordered_list v lst
and make_unordered_list v = function
- [] -> Const 0.
+ | [] -> Const 0.
| [(p, d)] when d = 0 -> make_unordered p
| [(p, d)] -> Times (make_unordered p, pow (Var v) d)
| (p, d) :: ls ->
@@ -82,7 +85,7 @@
(* List variables in the given polynomial. *)
let rec vars = function
- Var s -> [s]
+ | Var s -> [s]
| Const _ -> []
| Times (p, q) -> combine (vars p) (vars q)
| Plus (p, q) -> combine (vars p) (vars q)
@@ -91,51 +94,52 @@
let vars_list pl = List.fold_left (fun vs p -> combine vs (vars p)) [] pl
(* Make an ordered polynomial from a constant [n] in given ordered variables. *)
-let rec make_ordered_const n = function
- [] -> OrderedPoly.Const (num_of_float n)
- | v :: vs -> OrderedPoly.Poly (v, [(make_ordered_const n vs, 0)])
+let rec make_ordered_const use_num n = function
+ | [] -> if use_num then OrderedPoly.Const (num_of_float n) else
+ OrderedPoly.FConst (n)
+ | v :: vs -> OrderedPoly.Poly (v, [(make_ordered_const use_num n vs, 0)])
(* Make an ordered polynomial from a variable [v] in given ordered variables. *)
-let rec make_ordered_var v = function
- [] -> failwith "given variable not found among all variables"
- | w :: ws when v = w -> OrderedPoly.Poly (v, [(make_ordered_const 1. ws, 1)])
- | w :: ws -> OrderedPoly.Poly (w, [(make_ordered_var v ws, 0)])
+let rec make_ordered_var use_num v = function
+ | [] -> failwith "given variable not found among all variables"
+ | w :: ws when v = w ->
+ OrderedPoly.Poly (v, [(make_ordered_const use_num 1. ws, 1)])
+ | w :: ws -> OrderedPoly.Poly (w, [(make_ordered_var use_num v ws, 0)])
(* Make an ordered polynomial in given ordered variables [vars]. *)
-let rec make_ordered_poly vars = function
- Const n -> make_ordered_const n vars
- | Var v -> make_ordered_var v vars
- | Times (p, q) ->
- OrderedPoly.mul (make_ordered_poly vars p) (make_ordered_poly vars q)
- | Plus (p, q) ->
- OrderedPoly.add (make_ordered_poly vars p) (make_ordered_poly vars q)
+let rec make_ordered_poly use_num vars = function
+ | Const n -> make_ordered_const use_num n vars
+ | Var v -> make_ordered_var use_num v vars
+ | Times (p, q) -> OrderedPoly.mul
+ (make_ordered_poly use_num vars p) (make_ordered_poly use_num vars q)
+ | Plus (p, q) -> OrderedPoly.add
+ (make_ordered_poly use_num vars p) (make_ordered_poly use_num vars q)
(* Order on strings respecting priority given in [prio_list]. This means
that if x appears in [prio_list] before y then x < y. Strings not appearing
in [prio_list] at all are considered smaller than any string that appears. *)
let compare prio_list x y =
let rec cmp = function
- [] -> String.compare x y
+ | [] -> String.compare x y
| v :: vs when v = x -> if List.mem y vs 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-12 22:03:02
|
Revision: 1708
http://toss.svn.sourceforge.net/toss/?rev=1708&view=rev
Author: lukaszkaiser
Date: 2012-05-12 22:02:53 +0000 (Sat, 12 May 2012)
Log Message:
-----------
Pre-release orders.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Makefile
trunk/Toss/Toss.odocl
trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
trunk/Toss/www/Publications/all.bib
trunk/Toss/www/contact.xml
trunk/Toss/www/develop.xml
trunk/Toss/www/index.xml
trunk/Toss/www/reference/.cvsignore
trunk/Toss/www/reference/reference.bib
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/www/pub/contraintes_slides.pdf
trunk/Toss/www/pub/learning_games_descriptive_complexity.pdf
trunk/Toss/www/reference/Bknwn.png
trunk/Toss/www/reference/Bkwn0.png
trunk/Toss/www/reference/Cnw0.png
trunk/Toss/www/reference/Cnw1.png
trunk/Toss/www/reference/Cnw2.png
trunk/Toss/www/reference/Cnw3.png
trunk/Toss/www/reference/Cnwg.png
trunk/Toss/www/reference/Cw0.png
trunk/Toss/www/reference/Cw1.png
trunk/Toss/www/reference/Cw2.png
trunk/Toss/www/reference/Cw3.png
trunk/Toss/www/reference/Cwg.png
trunk/Toss/www/reference/Pw0.png
trunk/Toss/www/reference/Pw1.png
Property Changed:
----------------
trunk/Toss/www/reference/
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -3,7 +3,7 @@
let time_step = ref 0.1
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
-let dIFFM = 20 (* So many differentiation steps for one time step. *)
+let dIFFM = 10 (* So many differentiation steps for one time step. *)
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/Makefile 2012-05-12 22:02:53 UTC (rev 1708)
@@ -18,7 +18,7 @@
make -C Client alljsgz
-RELEASE=0.7
+RELEASE=0.8
Release: TossServer doc
rm -f *~ MenhirLib/*~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
Learn/*~ Language/*~ Server/*~ www/*~ WebClient/~
@@ -138,7 +138,7 @@
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
doc: $(EXTDEPS)
- $(OCAMLBUILD) $(.INC) Toss.docdir/index.html
+ $(OCAMLBUILD) -Is $(.INC) Toss.docdir/index.html
make -C www code_doc_link
Modified: trunk/Toss/Toss.odocl
===================================================================
--- trunk/Toss/Toss.odocl 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/Toss.odocl 2012-05-12 22:02:53 UTC (rev 1708)
@@ -30,7 +30,6 @@
Arena/Arena
Arena/ArenaParser
Play/Heuristic
-Play/Move
Play/GameTree
Play/Play
GGP/GDL
@@ -40,4 +39,3 @@
GGP/GameSimpl
Learn/Distinguish
Learn/LearnGame
-Server/ReqHandler
Modified: trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
===================================================================
--- trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss 2012-05-12 22:02:53 UTC (rev 1708)
@@ -57,7 +57,7 @@
LOC 0 {
PLAYER 1 { PAYOFF 0. MOVES [Move,
- t : 9. -- 9.,
+ t : 12. -- 12.,
k1 : 0.015 -- 0.015,
k3 : 200. -- 200.,
k4p: 0.018 -- 0.018,
@@ -69,6 +69,10 @@
PLAYER 2 { PAYOFF 0. }
UNIVERSAL { k1, k3, k4p, k4, k6, k7, k8, k9 }
}
+LOC 1 {
+ PLAYER 1 { PAYOFF Sum (x | Cdc2CycP1P2(x) : :y(x)) }
+ PLAYER 2 { PAYOFF 0. }
+}
START [ e1, e2, e3, e4, e5, e6 | Cyc(e1); CycP1(e2); Cdc2(e3); Cdc2P1(e4);
Cdc2CycP1(e5); Cdc2CycP1P2(e6) |
x { e1->1, e2->2, e3->3, e4->4, e5->5, e6->6 };
Modified: trunk/Toss/www/Publications/all.bib
===================================================================
--- trunk/Toss/www/Publications/all.bib 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/Publications/all.bib 2012-05-12 22:02:53 UTC (rev 1708)
@@ -4,6 +4,14 @@
# TALKS
+@inproceedings{KCONSTRAINTES11,
+ author={Toss},
+ title={Quantitative Logics on Structure Rewriting Systems},
+ url = {/pub/contraintes_slides.pdf},
+ booktitle= {EPI Contraintes Seminar, INRIA Paris-Rocquencourt},
+ year={2012 Talk}
+}
+
@inproceedings{KAAAI11,
author={Toss},
title={First Order Logic with Counting for General Game Playing},
@@ -129,6 +137,33 @@
# ARTICLES
+@inproceedings{K12,
+ author = {\L{}ukasz Kaiser},
+ title = {Learning Games from Videos Guided by Descriptive Complexity},
+ year = {2012},
+ booktitle = {Proceedings of the 26th Conference on Artificial
+ Intelligence, AAAI-12, to appear},
+ publisher = {AAAI Press},
+ url = {/pub/learning_games_descriptive_complexity.pdf},
+ abstract = {
+In recent years, several systems have been proposed that learn the rules
+of a simple card or board game solely from visual demonstration.
+These systems were constructed for specific games
+and rely on substantial background knowledge.
+We introduce a general system for learning board game rules from videos
+and demonstrate it on several well-known games. The presented algorithm
+requires only a few demonstrations and minimal background knowledge,
+and, having learned the rules, automatically derives position evaluation
+functions and can play the learned games competitively.
+Our main technique is based on descriptive complexity,
+the logical means necessary to define a set of interest. We compute formulas
+defining allowed moves and final positions in a game in different logics
+and select the most adequate ones. We show that this method is well-suited
+for board games and there is strong theoretical evidence that it
+will generalize to other problems.
+}
+}
+
@inproceedings{KS11transl,
author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak},
title = {Translating the Game Description Langauge to Toss},
Modified: trunk/Toss/www/contact.xml
===================================================================
--- trunk/Toss/www/contact.xml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/contact.xml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -280,7 +280,6 @@
<itemize>
<item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item>
<item>Łukasz Stafiniak</item>
- <item>Michał Wójcik</item>
</itemize>
<par>Friends who helped us a lot with discussion and code.</par>
<itemize>
@@ -289,6 +288,7 @@
<item>Diana Fischer</item>
<item>Tobias Ganzow</item>
<item>Simon Leßenich</item>
+ <item>Michał Wójcik</item>
</itemize>
<par>Yet another group of people, who worked on the oldest version of Toss
(around 2004), was lead by:</par>
Modified: trunk/Toss/www/develop.xml
===================================================================
--- trunk/Toss/www/develop.xml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/develop.xml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -262,8 +262,6 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
<section title="Mit Toss Team Zusammenarbeiten" lang="de">
@@ -279,8 +277,6 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
<section title="Praca z Nami" lang="pol">
@@ -296,11 +292,9 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
- <section title="Travailler avec l'Équipe de Toss" lang="fr">
+ <section title="Travailler avec l'Équipe du Toss" lang="fr">
<par>Si vous avez une idée, une demande, vous voulez devenir un développeur
ou tout simplement voudrais parler, contactez-nous! Les développeurs
Toss de plus engagés répondre aux questions Toss sur leur e-mails privés
@@ -313,8 +307,6 @@
<mailto address="luk...@gm..."/></item>
<item>Łukasz Stafiniak:
<mailto address="luk...@gm..."/></item>
- <item>Michał Wójcik:
- <mailto address="mic...@gm..."/></item>
</itemize>
</section>
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2012-05-12 20:29:37 UTC (rev 1707)
+++ trunk/Toss/www/index.xml 2012-05-12 22:02:53 UTC (rev 1708)
@@ -65,18 +65,22 @@
<section title="News">
<itemize>
+ <newsitem date="13/05/12">
+ Toss release 0.8 with full JS compatibility with dynamics</newsitem>
<newsitem date="04/05/12">
+ Dynamics debugged and animations now work in the JS interface</newsitem>
+ <newsitem date="04/05/12">
Old rewriting example works with the JS interface</newsitem>
<newsitem date="25/04/12">
Work on positioning with the JS interface</newsitem>
- <newsitem date="30/03/12">
- Adding Hnefatafl to example Toss games</newsitem>
- <newsitem date="21/03/12">
- Toss Client and website updated to a cleaned-up JS version</newsitem>
- <newsitem date="09/03/12">
- First completely working all-JS Toss version</newsitem>
- <newsitem date="05/03/12">
- Fully integrated OCaml and JS debugging and logs</newsitem>
+ <oldnewsitem date="30/03/12">
+ Adding Hnefatafl to example Toss games</oldnewsitem>
+ <oldnewsitem date="21/03/12">
+ Toss Client and website updated to a cleaned-up JS version</oldnewsitem>
+ <oldnewsitem date="09/03/12">
+ First completely working all-JS Toss version</oldnewsitem>
+ <oldnewsitem date="05/03/12">
+ Fully integrated OCaml and JS debugging and logs</oldnewsitem>
<oldnewsitem date="27/02/12">
Compiled resources to access files from JS</oldnewsitem>
<oldnewsitem date="18/02/12">
Added: trunk/Toss/www/pub/contraintes_slides.pdf
===================================================================
--- trunk/Toss/www/pub/contraintes_slides.pdf (rev 0)
+++ trunk/Toss/www/pub/contraintes_slides.pdf 2012-05-12 22:02:53 UTC (rev 1708)
@@ -0,0 +1,12989 @@
+%PDF-1.4
+%\xD0\xD4\xC5\xD8
+8 0 obj
+<< /S /GoTo /D (Outline0.1) >>
+endobj
+11 0 obj
+(Structure Rewriting Systems)
+endobj
+12 0 obj
+<< /S /GoTo /D (Outline0.1.1.3) >>
+endobj
+15 0 obj
+(Structure Transition Systems and Games)
+endobj
+16 0 obj
+<< /S /GoTo /D (Outline0.1.2.26) >>
+endobj
+19 0 obj
+(Separated Rules and Decidability)
+endobj
+20 0 obj
+<< /S /GoTo /D (Outline0.1.3.51) >>
+endobj
+23 0 obj
+(Simulation-Based Playing)
+endobj
+24 0 obj
+<< /S /GoTo /D (Outline0.1.4.66) >>
+endobj
+27 0 obj
+(Continuous Dynamics)
+endobj
+28 0 obj
+<< /S /GoTo /D (Outline0.2) >>
+endobj
+31 0 obj
+(Quantitative Logics)
+endobj
+32 0 obj
+<< /S /GoTo /D (Outline0.2.1.73) >>
+endobj
+35 0 obj
+(Standard -Calculus)
+endobj
+36 0 obj
+<< /S /GoTo /D (Outline0.2.2.92) >>
+endobj
+39 0 obj
+(Quantitative -Calculus)
+endobj
+40 0 obj
+<< /S /GoTo /D (Outline0.2.3.103) >>
+endobj
+43 0 obj
+(Model Checking on Linear Hybrid Systems)
+endobj
+44 0 obj
+<< /S /GoTo /D (Outline0.2.4.125) >>
+endobj
+47 0 obj
+(Model Checking on Increasing Tree Rewriting Systems)
+endobj
+48 0 obj
+<< /S /GoTo /D (Outline0.3) >>
+endobj
+51 0 obj
+(Summary)
+endobj
+52 0 obj
+<< /S /GoTo /D [53 0 R /Fit ] >>
+endobj
+55 0 obj <<
+/Length 770
+/Filter /FlateDecode
+>>
+stream
+x\xDA\xC5UKO1\xBE\xF3+|\xAAl\xA9k\xFC\xF6\xFAHy5\xB4E\x90\xA4\xE2@8\xAC\x92%X\x90\x8D\xD8\xFD\xF5 \xDBP 儢\xEC̎\xED\x99o\xBE\x99Y34G \xEF\xB0$\xC9Aރ\x85!iͥF\xC2
+ʅAu\x89\xAEwη}\x96\\x83\xDDZ\xA7\xA5\xBF\xCCs\xB4\xF1>\xFCD\xDCT\xA3@k\x84\x94\xD4\xE1s\xCF\xD4\xF3\xB8\x9EBij\x9CD\xD3\xC5f= UR\xAD\xCB\xF1DË\xEE?b}\xC7\xD3;e\xD8N\x803\x80\xEB7\x9AJ\xF5\x9C\x85\xE2\x94k\x83\x84\xA3,Ϸ\xB2x\xF2?\xAA"\x86^ \xDF\xC6;\xBBG|+\xF0h_#\x9C0\x83\xB8Rr\x89\xC63t\x89\xCFI\xA6pWTD\xE3ַ1 \x97\xB8$\x99`\xFF$\x9C\xE3\xE5\x9C(\xEC\xA7M2-\xAB$G`l\xEBnJ2\x87\xBB\x9A\xB8\xF5\xA1!ɂ\x89W\xB5o}5_\xEF\xE7?\x86G\xD3B\x9Crѐ\xAB\xF1ɻ=
+YD~ YpG9\xA0\xCFdNsgS\xBE\xA8
+\x88\xBE\x8F\x880\xD87ӛ\xB2&Z\xE2\xAF\xC9:\x81Gw Hs\4\x92\xED\xBC\\xF8v \x87㍂\xAA5TDj\xAA\xAD \xB9\xBCbh\x8B'\xA1\xD4J\xA3Uܺ@\x86Q),\xA8wh\xE5I\xC4oB6\x86\xE690/-\xD5 #\xE6 \xD9\xC8/"\xA1\xA0\xD7
+\x97imY\xF9\xE9\xCD\xD0G\xC0m[L\x98T\x95/n7hܠ\xCDRgY\x84\x90\xE5\xD0a\x90O& \xEE\x84_$Bo\xCAE\x94\x91\xB8\xE3\xB8\xEE\xAA\xD9]1/{t3\xA0)*\xC0\xC2pu \xBAdY\x87\xFE\xE9\xCF\x90j\x9D\xD70\xB2{\x9D \xF1\xF8{\xB2\xED\x85\xCDD\xA8d$8Π\xCCQetB\xD4\xFB\x86\xC9 ~l\xBB\xF6\xED\x90qWk\xB1\xEF\xE3\xFE\xAE\xFC\x8A\xC0\xE6\xB2n c\x9B\xF5..\xC0\xA9\xC3\xCAr:Z$\xC7+Xo\xFA\xE3Q&\xA8\xB56!R \xD1\xCF\xC1\xDE\xB19\xDE\xEB\xFD\xEF\x9FGI\xFB\xF2\xF0\xA1\xE8ۉ\xD4<\x99\xCFB \xABo\x92\xE9\xC0\x82 ӄ \xFD\xEAn\xFBbY_ \xF68\xE9\x8E:WO(\xB6\x92\xC0,̈P4W}\xBF \x9E
+\xD2 \xEE&\x96q\xE2\xC3\xCC>\xAA\x81\xAAf=\xA8YO_ \xEDbA\xC1:8 \xF6\x92
+h9\xA0\xF5M'}97\xF7]Y\xB9\xECB\x9B\xC8\xE8\xB0?)\xAF$\xF3\xF1k!}hc\xCA
+i\xE8oS\xB9\x84\x8B\x97\xA3 F\x8D\xF5C%\xB8\xB0x7\x83\xB5\xF9/ \xF0\xF8 \xC9n\xBA\x97
+endstream
+endobj
+53 0 obj <<
+/Type /Page
+/Contents 55 0 R
+/Resources 54 0 R
+/MediaBox [0 0 362.835 272.126]
+
+/Trans << /S /R >>
+/Parent 62 0 R
+>> endobj
+56 0 obj <<
+/D [53 0 R /XYZ 10.839 272.126 null]
+>> endobj
+60 0 obj <<
+/D [53 0 R /XYZ 351.995 0 null]
+>> endobj
+61 0 obj <<
+/D [53 0 R /XYZ 351.995 0 null]
+>> endobj
+54 0 obj <<
+ /ColorSpace 3 0 R /Pattern 2 0 R /ExtGState 1 0 R
+/Font << /F90 57 0 R /F91 58 0 R /F94 59 0 R >>
+/ProcSet [ /PDF /Text ]
+>> endobj
+76 0 obj <<
+/Length 738
+/Filter /FlateDecode
+>>
+stream
+x\xDA\xCDVMs\xD30\xBD\xF7W\xE8( \xAC\xEA\xDB\xF6\xB5
+Lh\x92[\xE1\xA0:n\xF0\xBB\xE0\xD8t\xFA\xEFYI\xB6\x938n \xB6䕴\xEF\xEDӮd\x86V\x88\xA1\x8B6j9\xB4 \xDAo`aHA\xA9\x91\x88\xE5 :G\xB7'W\x8B\xFEUۓ=\xA7\x85'\xCE+\xB4\xF7={>T#'\x97\x87
+\xDDٖ\xDDVR\xEE\x87\xDC[(MM*QV\xEE\xEBl\xA8\x92\xAA\x97yo\xD2\xFD\xB4\xF5lqr\xFA*E\xA52-nQB5SHhA\x8D\x94h\xB1D\xD7\xF8=\x89\xB8\xC0\xDF \x978\xAFI$\xA0_\xE4D\xE2{\xF2i\xF1\xF6'\xE1<\xC2f$\xC9\xCB\xC5-g[\x8A\x84Ԕ\xA5\x89 \xB9 \x8C1ʄ\x8E\xD3\xDDnV\xA2aF\xB4c\x8FFs\xDC F\x95'\xD2u=\xCDne\xED\xE0\xE20\x9A\xB2\x94;qzr,\xA1ܫ3'
+7u\x9B\x81H7mMR\x9C\x83H,\xC63\x81bN\xA8\xBAh\x8Aj\xACsb>\xB8צ!\xE7\xE5&\xC88\x92\xA0\xF9 \xB4\xA1\xD2( *\xA9Vi-{h\xE9\xA19\xF3\xD8\xE0{A\x94\xC65\xD1\xD8V |
|
From: <luk...@us...> - 2012-05-18 21:22:21
|
Revision: 1709
http://toss.svn.sourceforge.net/toss/?rev=1709&view=rev
Author: lukaszkaiser
Date: 2012-05-18 21:22:13 +0000 (Fri, 18 May 2012)
Log Message:
-----------
Starting to use non-symbolic RK.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermParser.mly
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Server/Tests.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Arena.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -700,7 +700,7 @@
match ContinuousRule.rewrite_single state.struc u state.time mtch r t p with
| Some (new_struc, new_time, shifts) ->
let val_str ((f, e), tl) =
- let ts t = string_of_float (Term.term_val t) in
+ let ts t = string_of_float (t) in
f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in
let shifts_s = String.concat "; " (List.map val_str shifts) in
((state_game, {state with struc = new_struc; time = new_time}),
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Arena.mli 2012-05-18 21:22:13 UTC (rev 1709)
@@ -180,7 +180,7 @@
(** As [list_moves] but with animation shifts for each move. *)
val list_moves_shifts : game -> game_state ->
- (int * (move * ((string * string) * Term.term list) list) * game_state) array
+ (int * (move * ((string * string) * float list) list) * game_state) array
val apply_rule_int : game * game_state ->
string * (string * int) list * float * (string * float) list ->
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -107,10 +107,10 @@
let c = String.compare f g in if c <> 0 then c else
let d = String.compare x y in if d <> 0 then d else Term.compare t s in
let dyn = Term.subst_simp_eq [] [] (sum_common (List.sort cmp dyns)) in
- LOG 1 "%s" (Term.eq_str dyn);
+ (*LOG 1 "%s" (Term.eq_str dyn);*)
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
- let init_vals = List.map (fun ((f, a), _) -> Term.Const (fval f a)) dyn in
- (dyn, init_vals)
+ let init_vals = List.map (fun ((f, a), _) -> fval f a) dyn in
+ (dyn, Array.of_list init_vals)
(* For now, we rewrite only single rules. Does not check postcondition. *)
@@ -121,13 +121,14 @@
let p_vars, p_vals = List.split params in
(p_vars, List.map (fun f -> Term.Const f) p_vals) in
let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
+ let dyn_c = Term.compile "t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
let step vals t0 =
- LOG 1 "step at time %s" (Term.str t0);
- LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));
- Term.rk4_step "t" t0 (Term.Const diff_step) dyn vals in
+ (*LOG 1 "step at time %s" (Term.str t0);
+ LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));*)
+ Term.rk4_step_c t0 diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
@@ -135,11 +136,11 @@
let end_time = !time +. t -. (0.01 *. diff_step) in
LOG 1 "end time: %f" end_time;
let upd_struct st = List.fold_left2 (fun s ((f, e), _) v ->
- Structure.change_fun s f e v) st dyn (List.map Term.term_val !cur_vals) in
+ Structure.change_fun s f e v) st dyn (Array.to_list !cur_vals) in
while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
t_mod_diff := (!t_mod_diff + 1) mod dIFFM;
- cur_vals := step !cur_vals (Term.Const !time) ;
+ cur_vals := step !cur_vals !time ;
time := !time +. diff_step ;
last_struc := !cur_struc ;
cur_struc := upd_struct !cur_struc ;
@@ -156,10 +157,11 @@
let rec select_pos ids llst =
if ids = [] then [] else (List.hd ids, List.map List.hd llst) ::
(select_pos (List.tl ids) (List.map List.tl llst)) in
- let all_vals_assoc = select_pos (List.map fst dyn) (List.rev !all_vals) in
- LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
+ let all_vals_assoc =
+ select_pos (List.map fst dyn) (List.rev_map Array.to_list !all_vals) in
+ (*LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
(String.concat ", " (List.map (
- fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));
+ fun t -> string_of_float (Term.term_val t)) tl))) all_vals_assoc));*)
let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
let upd = List.map (fun (lhs, rhs) ->
(lhs, FormulaSubst.subst_real re_sb rhs)) r.update in
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-05-18 21:22:13 UTC (rev 1709)
@@ -78,14 +78,14 @@
functions supplied with dynamics equations, at each time step). *)
val rewrite_single_nocheck : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
- Structure.structure * float * ((string * string) * Term.term list) list
+ Structure.structure * float * ((string * string) * float list) list
(** For now, we rewrite only single rules.
Same as {!ContinuousRule.rewrite_single_nocheck}, but check if the
postcondition holds. Returns [None] if rewriting fails. *)
val rewrite_single : Structure.structure -> rule list -> float ->
DiscreteRule.matching -> rule -> float -> (string * float) list ->
- (Structure.structure * float * ((string* string)* Term.term list) list) option
+ (Structure.structure * float * ((string* string)* float list) list) option
(** Compare two rules and explain the first difference
met. Formulas and expressions are compared for structural equality. *)
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Term.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -214,7 +214,23 @@
let new_rhs = subst_simp_f lhs subst_vals rhs in
List.combine (List.map (fun (f, a) -> (f, replace a)) lhs) new_rhs
+let rec compile_term tv eqs = function
+ | Const c -> (fun _ _ -> c)
+ | Var v -> (fun t _ -> if v = tv then t else failwith "non time var compile")
+ | FVar (f, x) -> (fun _ a -> a.(Aux.find_index (f, x) eqs))
+ | Plus (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
+ (fun t a -> (cp t a) +. (cq t a)))
+ | Times (p, q) -> (let cp, cq= compile_term tv eqs p, compile_term tv eqs q in
+ (fun t a -> (cp t a) *. (cq t a)))
+ | Div (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
+ (fun t a -> (cp t a) /. (cq t a)))
+let compile tv eqs =
+ let lhs = fst (List.split eqs) in
+ let ceqs = Array.of_list (List.map (fun (_,t)-> compile_term tv lhs t) eqs) in
+ (fun t a -> Array.map (fun f -> f t a) ceqs)
+
+
(* ---------------- RUNGE - KUTTA METHOD FOR TERM EQUATIONS ---------------- *)
(* Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
@@ -230,3 +246,16 @@
let k4 = f_of (add tinit tstep) (ladd vals_init (lmul1 tstep k3)) in
let (dk2, dk3) = (lmul1 (Const 2.) k2, lmul1 (Const 2.) k3) in
ladd vals_init (lmul1 tstepdiv6 (ladd k1 (ladd dk2 (ladd dk3 k4))))
+
+let amul c arr = Array.map (fun x -> c *. x) arr
+let aadd a1 a2 = Aux.array_map2 (fun x1 x2 -> x1 +. x2) a1 a2
+
+let rk4_step_c tinit tstep eq_f vals_arr =
+ let tstepdiv6 = tstep /. 6. in
+ let htstep = tstep /. 2. in
+ let k1 = eq_f tinit vals_arr in
+ let k2 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k1)) in
+ let k3 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k2)) in
+ let k4 = eq_f (tinit +. tstep) (aadd vals_arr (amul tstep k3)) in
+ let (dk2, dk3) = (amul (2.) k2, amul (2.) k3) in
+ aadd vals_arr (amul tstepdiv6 (aadd k1 (aadd dk2 (aadd dk3 k4))))
Modified: trunk/Toss/Arena/Term.mli
===================================================================
--- trunk/Toss/Arena/Term.mli 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/Term.mli 2012-05-18 21:22:13 UTC (rev 1709)
@@ -21,6 +21,7 @@
(** {2 Basic functions.} *)
+(*
(** Whether to simplify symbolically or not. Set to false by default.
It is nice for symbolic stuff, but slows down numerics. *)
val simp_symb : bool ref
@@ -36,8 +37,9 @@
(** Print an equation system as a string. *)
val eq_str : ?diff : bool -> eq_sys -> string
-
+*)
val fprint_eqs : ?diff : bool -> Format.formatter -> eq_sys -> unit
+(*
val print_eqs : ?diff : bool -> eq_sys -> unit
val sprint_eqs : ?diff : bool -> eq_sys -> string
@@ -53,10 +55,10 @@
(** Convert an equation system to float assciation list, fail on non-consts. *)
val eq_vals : eq_sys -> ((string * string) * float) list
+*)
-
(** {2 Simple operations.} *)
-
+(*
val add : term -> term -> term
val ladd1 : term -> term list -> term list
val ladd : term list -> term list -> term list
@@ -71,14 +73,17 @@
(** Substitute terms for variables as in [dict] in the given term. *)
val subst : (string * term) list -> term -> term
+*)
(** Substitute [vals] for [vars] in [terms] and simplify. *)
val subst_simp : string list -> term list -> term list -> term list
+(*
(** Substitute terms for function variables as in [dict] in the given term. *)
val subst_f : ((string * string) * term) list -> term -> term
(** Substitute [vals] for function [vars] in [terms] and simplify. *)
val subst_simp_f : (string * string) list -> term list -> term list -> term list
+*)
(** Substitute variables and function vals in an eq. system and simplify. *)
val subst_simp_eq : (string * term) list -> ((string * string) * term) list ->
@@ -93,4 +98,12 @@
(** Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
-val rk4_step : string -> term -> term -> eq_sys -> term list -> term list
+(*val rk4_step : string -> term -> term -> eq_sys -> term list -> term list*)
+
+
+(** Compile eq_sys to function. *)
+val compile : string -> eq_sys -> (float -> float array -> float array)
+
+(** RK4 with compiled system. *)
+val rk4_step_c : float -> float -> (float -> float array -> float array) ->
+ float array -> float array
Modified: trunk/Toss/Arena/TermParser.mly
===================================================================
--- trunk/Toss/Arena/TermParser.mly 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Arena/TermParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
@@ -27,7 +27,6 @@
| term_expr MINUS term_expr { Term.Plus ($1, Term.Times(Term.Const(-1.), $3))}
| term_expr TIMES term_expr { Term.Times ($1, $3) }
| term_expr DIV term_expr { Term.Div ($1, $3) }
- | term_expr POW INT { Term.pow $1 $3 }
| OPEN term_expr CLOSE { $2 }
eq_expr: /* differential equations only */
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Client/JsHandler.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -262,7 +262,7 @@
let len, res = List.length (snd (List.hd shifts)), ref [state] in
for i = 0 to len - 1 do
let new_struc = List.fold_left (fun struc ((fname, elem), ts) ->
- let v = Term.term_val (List.nth ts i) in
+ let v = (List.nth ts i) in
Structure.change_fun struc fname elem v) state.Arena.struc shifts in
res := { state with Arena.struc = new_struc } :: !res;
done;
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-05-12 22:02:53 UTC (rev 1708)
+++ trunk/Toss/Server/Tests.ml 2012-05-18 21:22:13 UTC (rev 1709)
@@ -31,7 +31,6 @@
]
let arena_tests = "Arena", [
- "TermTest", [TermTest.tests];
"DiscreteRuleTest", [DiscreteRuleTest.tests];
"ContinuousRuleTest", [ContinuousRuleTest.tests];
"ArenaTest", [ArenaTest.tests];
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-05-19 21:37:26
|
Revision: 1710
http://toss.svn.sourceforge.net/toss/?rev=1710&view=rev
Author: lukaszkaiser
Date: 2012-05-19 21:37:16 +0000 (Sat, 19 May 2012)
Log Message:
-----------
Moving ODE from Term to Formula as expected, adjusting examples and tests, making old speagram left-linear.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/ContinuousRuleParser.mly
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Language/BuiltinLang.ml
trunk/Toss/Language/BuiltinLang.mli
trunk/Toss/Language/Makefile
trunk/Toss/Language/ParseArc.ml
trunk/Toss/Language/ParseArc.mli
trunk/Toss/Language/Rewriting.ml
trunk/Toss/Language/Rewriting.mli
trunk/Toss/Language/SyntaxDef.ml
trunk/Toss/Language/SyntaxDef.mli
trunk/Toss/Language/System.ml
trunk/Toss/Language/System.mli
trunk/Toss/Language/Term.ml
trunk/Toss/Language/Term.mli
trunk/Toss/Language/Type.ml
trunk/Toss/Language/Type.mli
trunk/Toss/Language/library/Makefile
trunk/Toss/Language/library/arithmetics.spg
trunk/Toss/Language/library/core.spg
trunk/Toss/Language/library/lists.spg
trunk/Toss/Language/speagram.ml
trunk/Toss/Language/testsuite/differentiation.log
trunk/Toss/Language/testsuite/differentiation.spg
trunk/Toss/Language/testsuite/short_checks.log
trunk/Toss/Language/testsuite/simple_algo.log
trunk/Toss/Language/testsuite/simple_algo.spg
trunk/Toss/examples/Bounce.toss
trunk/Toss/examples/Cell-Cycle-Tyson-1991.toss
trunk/Toss/examples/Rewriting-Example.toss
trunk/Toss/menhir_conf
Removed Paths:
-------------
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/Term.mli
trunk/Toss/Arena/TermParser.mly
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Language/Normalisation.ml
trunk/Toss/Language/Normalisation.mli
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/Arena.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -95,7 +95,7 @@
f ^ ": " ^ (string_of_float fs) ^ " -- " ^ (string_of_float fe) in
let par_str = if param_intervals = [] then " " else
", " ^ (String.concat ", " (List.map fpstr param_intervals)) in
- (rr) ^ ", " ^ fpstr ("t", t_interval) ^ par_str
+ (rr) ^ ", " ^ fpstr (":t", t_interval) ^ par_str
(* Print a move as string. *)
let move_str (lb, i) = Printf.sprintf "[%s -> %i]" (label_str lb) i
@@ -112,11 +112,11 @@
lb_rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
Format.fprintf f "[@,@[<1>%s" r;
if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
- Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
+ Format.fprintf f ",@ @[<1>:t@ :@ %F@ --@ %F@]" t_l t_r;
if params <> [] then
Format.fprintf f ",@ %a"
(Aux.fprint_sep_list "," (fun f (pn, (p_l, p_r)) ->
- Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
+ Format.fprintf f "@[<1>%s@ :@ %F@ --@ %F@]" pn p_l p_r)) params;
Format.fprintf f "@ ->@ %d@]@,]" target)) moves
) (in_p, in_m)
@@ -139,7 +139,7 @@
Format.fprintf f "@[<1>[%s@ %F@ ->@ %i@ emb@ %s]%s@]" rn t l m_s rt
else (
let p_s = String.concat ", "
- (List.map (fun (p, v) -> Printf.sprintf "%s: %F" p v) pl) in
+ (List.map (fun (p, v) -> Printf.sprintf "%s : %F" p v) pl) in
Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
)
@@ -303,7 +303,7 @@
let make_move_arena rname params target_loc =
let time_in, parameters_in =
- try Aux.pop_assoc "t" params
+ try Aux.pop_assoc ":t" params
with Not_found -> (cDEFAULT_TIMESTEP, cDEFAULT_TIMESTEP), params in
{ lb_rule = rname;
time_in = time_in;
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-05-19 21:37:16 UTC (rev 1710)
@@ -23,10 +23,13 @@
| ID { $1 }
| INT { string_of_int $1 }
+param:
+ | COLON ID { ":" ^ $2 }
+
move:
| OPENSQ RULE_SPEC? r = id_int COMMA?
params = separated_list (
- COMMA, separated_pair (ID, COLON,
+ COMMA, separated_pair (param, COLON,
separated_pair (FLOAT, INTERV, FLOAT)))
RARR LOC_MOD? target = INT CLOSESQ
{ make_move_arena r params target }
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -10,11 +10,9 @@
(* Specification of a continuous rewriting rule, as in modelling document. *)
type rule = {
- discrete : DiscreteRule.rule; (* The discrete part *)
- dynamics : ((string * string) * Term.term) list; (* Equation system calD *)
- update : ((string * string) * Formula.real_expr) list;
- (* Update equations calT *)
- (* Note that, for efficiency, the precondition is part of DiscreteRule. *)
+ discrete : DiscreteRule.rule; (* The discrete part, with precondition *)
+ dynamics : ((string * string) * Formula.real_expr) list; (* Equations calD *)
+ update : ((string * string) * Formula.real_expr) list; (* Update eqs calT*)
inv : Formula.formula; (* Invariant for the evolution *)
post : Formula.formula; (* Postcondition for application *)
}
@@ -90,10 +88,13 @@
(* Differential equations for a rule and a match, renamed to structure names. *)
let rule_dynamics struc params (r, m) =
- let (p_vars, t_vals) = params in
- let subst_params tm = List.hd (Term.subst_simp p_vars t_vals [tm]) in
+ let subst_params tm = FormulaSubst.subst_real params tm in
let d = List.map (fun (lhs, rhs) -> (lhs, subst_params rhs)) r.dynamics in
- Term.subst_names (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
+ let subst_names subst ((v, e), rhs) =
+ let replace a = try List.assoc a subst with Not_found -> a in
+ ((v, replace e), FormulaSubst.subst_vars_expr subst rhs) in
+ let subst_names_l subst l = List.map (subst_names subst) l in
+ subst_names_l (List.map (fun (a,i)-> (a, Structure.elem_name struc i)) m) d
(* Construct diff equation system and initial values for dynamics. *)
let construct_dynamics struc params rms =
@@ -101,12 +102,13 @@
let rec sum_common = function
| [] -> []
| (x, t) :: (y, s) :: rest when x = y ->
- sum_common ((x, Term.Plus (t, s)) :: rest)
+ sum_common ((x, Formula.Plus (t, s)) :: rest)
| eq :: rest-> eq :: (sum_common rest) in
let cmp ((f, x), t) ((g, y), s) =
let c = String.compare f g in if c <> 0 then c else
- let d = String.compare x y in if d <> 0 then d else Term.compare t s in
- let dyn = Term.subst_simp_eq [] [] (sum_common (List.sort cmp dyns)) in
+ let d = String.compare x y in if d <> 0 then d else
+ Formula.compare_re t s in
+ let dyn = sum_common (List.sort cmp dyns) in
(*LOG 1 "%s" (Term.eq_str dyn);*)
let fval f e = Structure.fun_val struc f (Structure.elem_nbr struc e) in
let init_vals = List.map (fun ((f, a), _) -> fval f a) dyn in
@@ -117,18 +119,18 @@
let rewrite_single_nocheck struc univs cur_time m r t params =
let univ_mts = Aux.concat_map
(fun r -> List.map (fun m -> (r, m)) (matches struc r)) univs in
- let tparams =
- let p_vars, p_vals = List.split params in
- (p_vars, List.map (fun f -> Term.Const f) p_vals) in
+ let tparams = List.map (fun (v, f) -> (v, Formula.Const f)) params in
+ (*let p_vars, p_vals = List.split params in
+ (p_vars, List.map (fun f -> Term.Const f) p_vals) in *)
let (dyn, init_vals) = construct_dynamics struc tparams ((r,m) :: univ_mts) in
- let dyn_c = Term.compile "t" dyn in
+ let dyn_c = Formula.compile ":t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
let step vals t0 =
(*LOG 1 "step at time %s" (Term.str t0);
LOG 2 "%s" (Term.eq_str (List.combine (List.map fst dyn) vals));*)
- Term.rk4_step_c t0 diff_step dyn_c vals in
+ Formula.rk4_step t0 diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
@@ -218,7 +220,7 @@
(DiscreteRule.fprint_full print_compiled) r.discrete;
if has_dynamics r then
Format.fprintf f "@ @[<hv>dynamics@ %a@]"
- (Term.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
+ (Formula.fprint_eqs ~diff:true) (List.sort Pervasives.compare r.dynamics);
if has_update r then
Format.fprintf f "@ @[<hv>update@ %a@]"
(Formula.fprint_eqs ~diff:false) (List.sort Pervasives.compare r.update);
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-05-19 21:37:16 UTC (rev 1710)
@@ -10,7 +10,7 @@
Function named foo on element i is, in a term, given by variable foo_i. *)
type rule = {
discrete : DiscreteRule.rule; (** The discrete part *)
- dynamics : Term.eq_sys; (** Equation system calD *)
+ dynamics : Formula.eq_sys; (** Equation system calD *)
update : Formula.eq_sys; (** Update equations calT *)
(** Note that, for efficiency, the precondition is part of DiscreteRule. *)
inv : Formula.formula; (** Invariant for the evolution *)
@@ -21,7 +21,7 @@
val make_rule :
(string * (string list * Formula.formula)) list -> (** defined rels *)
(DiscreteRule.rule) ->
- Term.eq_sys -> Formula.eq_sys ->
+ Formula.eq_sys -> Formula.eq_sys ->
?inv:Formula.formula ->
?post:Formula.formula -> unit -> rule
Modified: trunk/Toss/Arena/ContinuousRuleParser.mly
===================================================================
--- trunk/Toss/Arena/ContinuousRuleParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRuleParser.mly 2012-05-19 21:37:16 UTC (rev 1710)
@@ -25,7 +25,7 @@
%public rule_expr:
| discr = discrete_rule_expr
- dyn = loption (preceded (DYNAMICS, eq_sys))
+ dyn = loption (preceded (DYNAMICS, expr_eq_sys))
upd = loption (preceded (UPDATE, expr_eq_sys))
pre = option (preceded (PRE, precond_expr))
inv = option (preceded (INV, formula_expr))
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -43,12 +43,12 @@
let r = rule_of_str s signat [] "rule2" in
eq_str "2. update" s (str r);
- let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
+ let dyn_eq = ":f(a)' = 2. * :f(a) + :t; :f(b)' = :f(b)" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq in
let r = rule_of_str s signat [] "rule3" in
eq_str "3. dynamics" s (str r);
- let dyn_eq = ":f(a)' = 2. * :f(a) + t; :f(b)' = :f(b)" in
+ let dyn_eq = ":f(a)' = 2. * :f(a) + :t; :f(b)' = :f(b)" in
let upd_eq = " :f(c) = 2. * :f(a);\n :f(d) = :f(b)\n" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq in
let r = rule_of_str s signat [] "rule4" in
@@ -71,7 +71,7 @@
let r = rule_of_str s signat [] "rule2" in
assert_equal ~msg:"2. update" ~printer:(fun x->x) s (sprint r);
- let dyn_eq1 = " :f(a)' = 2. * :f(a) + t;"
+ let dyn_eq1 = " :f(a)' = 2. * :f(a) + :t;"
and dyn_eq2 = " :f(b)' = :f(b)" in
let dyn_eq = dyn_eq1 ^ dyn_eq2 in
let s = discr ^ "\n dynamics" ^ dyn_eq in
@@ -88,7 +88,7 @@
let dr =
"[| P { (a) } | ] -> [| P:1{}; Q { (b) } | ] emb P with [b<-a]" in
let signat = ["P", 1; "Q", 1] in
- let dyn_eq = ":x(a)' = :x(a) + t" in
+ let dyn_eq = ":x(a)' = :x(a) + :t" in
(* due to optimization (RHS renamed to match LHS), below it is
:x(a)=:x(a) rather than :x(b)=:x(a) *)
let upd_eq = ":x(a) = :x(a)" in
@@ -107,7 +107,7 @@
(fun () ->
let dr =
"[| P { (a) } | ] -> [| P:1{}; Q { (b) } | ] emb P with [b<-a]" in
- let dyn_eq = ":x(a)' = :x(a) + t" in
+ let dyn_eq = ":x(a)' = :x(a) + :t" in
(* due to optimization (RHS renamed to match LHS), below it is
:x(a)=:x(a) rather than :x(b)=:x(a) *)
let upd_eq = ":x(a) = :x(a)" in
@@ -153,11 +153,11 @@
(ContinuousRule.compare_diff r1 r2);
let upd_eq = " :f(a) = 2. * :f(a);\n :f(b) = :f(b)\n" in
- let dyn_eq = " :f(a)' = (2. * :f(a)) + t;\n :f(b)' = :f(b)" in
+ let dyn_eq = " :f(a)' = (2. * :f(a)) + :t;\n :f(b)' = :f(b)" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
" inv true post true" in
let r1 = rule_of_str s signat [] "rule4" in
- let dyn_eq = " :f(a)' = (3. * :f(a)) + t;\n :f(b)' = :f(b)" in
+ let dyn_eq = " :f(a)' = (3. * :f(a)) + :t;\n :f(b)' = :f(b)" in
let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
" inv true post true" in
let r2 = rule_of_str s signat [] "rule5" in
Deleted: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/Term.ml 2012-05-19 21:37:16 UTC (rev 1710)
@@ -1,261 +0,0 @@
-(* Represent terms and basic operations on them. *)
-
-(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
-
-let simp_symb = ref false
-
-type term =
- | Var of string
- | FVar of string * string
- | Const of float
- | Times of term * term
- | Plus of term * term
- | Div of term * term
-
-type eq_sys = ((string * string) * term) list
-
-(* Power function used in parser. *)
-let rec pow p n =
- if n = 0 then Const 1. else if n = 1 then p else Times (p, pow p (n-1))
-
-let compare t1 t2 = match (t1, t2) with
- | (Const x, Const y) -> if x > y then 1 else if y > x then -1 else 0
- | (Const _, _) -> -1
- | (_, Const _) -> 1
- | (Var x, Var y) -> String.compare x y
- | (Var _, _) -> -1
- | (_, Var _) -> 1
- | (FVar (f, x), FVar (g, y)) ->
- let c = String.compare f g in if c <> 0 then c else String.compare x y
- | (FVar _, _) -> -1
- | (_, FVar _) -> 1
- | _ -> Pervasives.compare t1 t2
-
-
-(* Variables (pure, not applied functions) in a term. *)
-let vars t =
- let rec vars_acc = function
- | Const _ | FVar _ -> []
- | Var x -> [x]
- | Plus (t, s) | Times (t, s) | Div (t, s) -> (vars_acc t) @ (vars_acc s) in
- Aux.unique_sorted (vars_acc t)
-
-
-(* ------------------------ PRINTING FUNCTION ------------------------------- *)
-
-(* Bracket-savvy precedences: + 0, - 1, * 2, / 3 *)
-let rec fprint ?(smt2=false) ?(prec=0) ppf = function
- | Var s -> Format.pp_print_string ppf s
- | FVar (f, a) -> if smt2 then Format.fprintf ppf "%s_of_%s" f a else
- Format.fprintf ppf ":%s(%s)" f a
- | Const n -> if smt2 then if n >= 0. then Format.fprintf ppf "%F" n else
- Format.fprintf ppf "(* minusone %F)" ((-1.) *. n)
- else Format.fprintf ppf "%F" n
- | Times (p, q) ->
- let lb, rb = if prec > 2 then "(", ")" else "", "" in
- if smt2 then Format.fprintf ppf "@[<1>(* %a@ %a)@]"
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:2) q
- else Format.fprintf ppf "@[<1>%s%a@ *@ %a%s@]" lb
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:2) q rb
- | Plus (p, Times (Const c, q)) when not smt2 && c = -1. ->
- let lb, rb = if prec > 0 then "(", ")" else "", "" in
- Format.fprintf ppf "@[<1>%s%a@ -@ %a%s@]" lb
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:1) q rb
- | Plus (p, Const c) when not smt2 && c < 0. ->
- let lb, rb = if prec > 0 then "(", ")" else "", "" in
- Format.fprintf ppf "@[<1>%s%a@ -@ %a%s@]" lb
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:1) (Const (-. c)) rb
- | Plus (p, q) ->
- let lb, rb = if prec > 0 then "(", ")" else "", "" in
- if smt2 then Format.fprintf ppf "@[<1>(+ %a@ %a)@]"
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:0) q
- else Format.fprintf ppf "@[<1>%s%a@ +@ %a%s@]" lb
- (fprint ~smt2 ~prec:0) p (fprint ~smt2 ~prec:0) q rb
- | Div (p, q) ->
- let lb, rb = if prec > 2 then "(", ")" else "", "" in
- if smt2 then Format.fprintf ppf "@[<1>(/ %a@ %a)@]"
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:3) q
- else Format.fprintf ppf "@[<1>%s%a@ /@ %a%s@]" lb
- (fprint ~smt2 ~prec:2) p (fprint ~smt2 ~prec:2) q rb
-
-let print r = AuxIO.print_of_fprint fprint r
-let sprint r = AuxIO.sprint_of_fprint fprint r
-let str = sprint
-let str_smt2 r = AuxIO.sprint_of_fprint (fprint ~smt2:true) r
-
-(* Print an equation system. *)
-let fprint_eqs ?(diff=true) ppf eqs =
- let sing ppf ((f, a), t) =
- let mid_str = if diff then "'" else "" in
- Format.fprintf ppf "@[<1>:%s(%s)%s@ =@ @[<1>%a@]@]"
- f a mid_str (fprint ~smt2:false ~prec:0) t in
- Format.fprintf ppf "@[<hv>%a@]" (Aux.fprint_sep_list ";" sing) eqs
-
-let print_eqs ?diff r = AuxIO.print_of_fprint (fprint_eqs ?diff) r
-let sprint_eqs ?diff r = AuxIO.sprint_of_fprint (fprint_eqs ?diff) r
-let eq_str = sprint_eqs
-
-
-(* -------------------- SIMPLIFICATION OF CONSTANTS ------------------------- *)
-
-(* Basic simplification, reduces constant terms to floats. *)
-let rec simp_const_only = function
- | Var s -> Var s
- | FVar (f, a) -> FVar (f, a)
- | Const n -> Const n
- | Times (p, q) -> (
- match (simp_const_only p, simp_const_only q) with
- | (Const n, Const m) -> Const (n *. m)
- | (t, s) -> Times (t, s)
- )
- | Plus (p, q) -> (
- match (simp_const_only p, simp_const_only q) with
- | (Const n, Const m) -> Const (n +. m)
- | (t, s) -> Plus (t, s)
- )
- | Div (p, q) ->
- match (simp_const_only p, simp_const_only q) with
- | (Const n, Const m) -> Const (n /. m)
- | (t, s)-> Div (t, s)
-
-let simp_const t =
- let rec to_poly = function
- | Var s -> Poly.Var ("V" ^ s)
- | FVar (f, a) -> Poly.Var ("F" ^ f ^ "#" ^ a)
- | Const n -> Poly.Const n
- | Times (p, q) -> Poly.Times (to_poly p, to_poly q)
- | Plus (p, q) -> Poly.Plus (to_poly p, to_poly q)
- | Div _ -> raise Not_found in
- let rec from_ord = function
- | OrderedPoly.Const _ -> failwith "num after non-num translation"
- | OrderedPoly.FConst num -> Const (num)
- | OrderedPoly.Poly (v, coefs) ->
- let w = if v.[0]= 'V' then Var (String.sub v 1 ((String.length v)-1)) else
- let i, l = String.index v '#', String.length v in
- FVar (String.sub v 1 (i-1), String.sub v (i+1) (l-i-1)) in
- let res = List.fold_left (fun acc (a, j) ->
- if j = 0 then Plus (acc, from_ord a) else
- match from_ord a with
- | Const n when n = 1. -> Plus (acc, pow w j)
- | ordt -> Plus (acc, Times (ordt, pow w j))
- ) (Const 0.) coefs in
- LOG 1 "res %s" (str res);
- let rec del_zero = function
- | Plus (Const n, t) when n = 0. -> t
- | Plus (t, s) -> Plus (del_zero t, s)
- | t -> t in
- del_zero res in
- match simp_const_only t with
- | Const n -> Const n
- | t -> if not !simp_symb then t else
- try let p = to_poly t in
- from_ord (Poly.make_ordered ~use_num:false [] p)
- with Not_found -> t
-
-(* Convert a term to float, fail on non-constant term. *)
-let term_val t = match simp_const t with
- | Const f -> f
- | t -> failwith ("getting value from non-constant term (" ^ str t ^ ")")
-
-
-(* Convert an equation system to float assciation list, fail on non-consts. *)
-let eq_vals eqs = List.map (fun (l, r) -> (l, term_val r)) eqs
-
-
-(* ----------------------- SIMPLE OPERATIONS ------------------------------- *)
-
-let add t1 t2 = simp_const (Plus (t1, t2))
-let ladd1 t tl = List.map (fun x -> add t x) tl
-let ladd tl1 tl2 = List.map2 add tl1 tl2
-
-let mul t1 t2 = simp_const (Times (t1, t2))
-let lmul1 t tl = List.map (fun x -> mul t x) tl
-let lmul tl1 tl2 = List.map2 mul tl1 tl2
-
-
-(* ------------------ SUBSTITUTION FOR VARIABLES --------------------------- *)
-
-(* Substitute terms for variables as in [dict] in the given term. *)
-let rec subst dict = function
- | Var s as t -> (try List.assoc s dict with Not_found -> t)
- | FVar _ | Const _ as t -> t
- | Plus (p, q) -> Plus (subst dict p, subst dict q)
- | Times (p, q) -> Times (subst dict p, subst dict q)
- | Div (p, q) -> Div (subst dict p, subst dict q)
-
-(* Substitute [vals] for [vars] in [terms] and simplify. *)
-let subst_simp vars vals terms =
- List.map (fun t -> simp_const (subst (List.combine vars vals) t)) terms
-
-
-(* Substitute terms for function variables as in [dict] in the given term. *)
-let rec subst_f dict = function
- | FVar (g, b) as t -> (try List.assoc (g, b) dict with Not_found -> t)
- | Var _ | Const _ as t -> t
- | Plus (p, q) -> Plus (subst_f dict p, subst_f dict q)
- | Times (p, q) -> Times (subst_f dict p, subst_f dict q)
- | Div (p, q) -> Div (subst_f dict p, subst_f dict q)
-
-(* Substitute [vals] for function [vars] in [terms] and simplify. *)
-let subst_simp_f vars vals terms =
- List.map (fun t -> simp_const (subst_f (List.combine vars vals) t)) terms
-
-(* Substitute variables and function vals in an equation system and simplify. *)
-let subst_simp_eq vlst flst eqs =
- let ((lhs, rhs), (vvars, vvals), (fvars, fvals)) =
- (List.split eqs, List.split vlst, List.split flst) in
- List.combine lhs (subst_simp vvars vvals (subst_simp_f fvars fvals rhs))
-
-(* Substitute function argument names in an equation system, left and right. *)
-let subst_names subst eqs =
- let (lhs, rhs) = List.split eqs in
- let replace a = try List.assoc a subst with Not_found -> a in
- let subst_vals = List.map (fun (f, a) -> FVar (f, replace a)) lhs in
- let new_rhs = subst_simp_f lhs subst_vals rhs in
- List.combine (List.map (fun (f, a) -> (f, replace a)) lhs) new_rhs
-
-let rec compile_term tv eqs = function
- | Const c -> (fun _ _ -> c)
- | Var v -> (fun t _ -> if v = tv then t else failwith "non time var compile")
- | FVar (f, x) -> (fun _ a -> a.(Aux.find_index (f, x) eqs))
- | Plus (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
- (fun t a -> (cp t a) +. (cq t a)))
- | Times (p, q) -> (let cp, cq= compile_term tv eqs p, compile_term tv eqs q in
- (fun t a -> (cp t a) *. (cq t a)))
- | Div (p, q) -> (let cp, cq = compile_term tv eqs p, compile_term tv eqs q in
- (fun t a -> (cp t a) /. (cq t a)))
-
-let compile tv eqs =
- let lhs = fst (List.split eqs) in
- let ceqs = Array.of_list (List.map (fun (_,t)-> compile_term tv lhs t) eqs) in
- (fun t a -> Array.map (fun f -> f t a) ceqs)
-
-
-(* ---------------- RUNGE - KUTTA METHOD FOR TERM EQUATIONS ---------------- *)
-
-(* Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
- side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
-let rk4_step tvar tinit tstep eq_sys vals_init =
- let (vars, eq_terms) = List.split eq_sys in
- let tstepdiv6 = mul (Div (Const 1., Const 6.)) tstep in
- let htstep = mul (Const 0.5) tstep in
- let f_of t x = subst_simp_f vars x (subst_simp [tvar] [t] eq_terms) in
- let k1 = f_of tinit vals_init in
- let k2 = f_of (add tinit htstep) (ladd vals_init (lmul1 htstep k1)) in
- let k3 = f_of (add tinit htstep) (ladd vals_init (lmul1 htstep k2)) in
- let k4 = f_of (add tinit tstep) (ladd vals_init (lmul1 tstep k3)) in
- let (dk2, dk3) = (lmul1 (Const 2.) k2, lmul1 (Const 2.) k3) in
- ladd vals_init (lmul1 tstepdiv6 (ladd k1 (ladd dk2 (ladd dk3 k4))))
-
-let amul c arr = Array.map (fun x -> c *. x) arr
-let aadd a1 a2 = Aux.array_map2 (fun x1 x2 -> x1 +. x2) a1 a2
-
-let rk4_step_c tinit tstep eq_f vals_arr =
- let tstepdiv6 = tstep /. 6. in
- let htstep = tstep /. 2. in
- let k1 = eq_f tinit vals_arr in
- let k2 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k1)) in
- let k3 = eq_f (tinit +. htstep) (aadd vals_arr (amul htstep k2)) in
- let k4 = eq_f (tinit +. tstep) (aadd vals_arr (amul tstep k3)) in
- let (dk2, dk3) = (amul (2.) k2, amul (2.) k3) in
- aadd vals_arr (amul tstepdiv6 (aadd k1 (aadd dk2 (aadd dk3 k4))))
Deleted: trunk/Toss/Arena/Term.mli
===================================================================
--- trunk/Toss/Arena/Term.mli 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/Term.mli 2012-05-19 21:37:16 UTC (rev 1710)
@@ -1,109 +0,0 @@
-(** Represent terms and their operations. *)
-
-(** {2 Basic Type Definition.} *)
-
-type term =
- | Var of string
- | FVar of string * string
- | Const of float
- | Times of term * term
- | Plus of term * term
- | Div of term * term
-
-type eq_sys = ((string * string) * term) list
-
-(** Compare two terms. *)
-val compare : term -> term -> int
-
-(** Variables (pure, not applied functions) in a term. *)
-val vars : term -> string list
-
-
-(** {2 Basic functions.} *)
-
-(*
-(** Whether to simplify symbolically or not. Set to false by default.
- It is nice for symbolic stuff, but slows down numerics. *)
-val simp_symb : bool ref
-
-(** Print a term as a string, maybe in the smt2 format. *)
-val str : term -> string
-val str_smt2 : term -> string
-
-val fprint : ?smt2:bool -> ?prec:int -> Format.formatter -> term -> unit
-val print : term -> unit
-val sprint : term -> string
-
-
-(** Print an equation system as a string. *)
-val eq_str : ?diff : bool -> eq_sys -> string
-*)
-val fprint_eqs : ?diff : bool -> Format.formatter -> eq_sys -> unit
-(*
-val print_eqs : ?diff : bool -> eq_sys -> unit
-val sprint_eqs : ?diff : bool -> eq_sys -> string
-
-
-(** Power function used in parser. *)
-val pow : term -> int -> term
-
-(** Basic simplification, reduces constant terms to floats. *)
-val simp_const : term -> term
-
-(** Convert a term to float, fail on non-constant term. *)
-val term_val : term -> float
-
-(** Convert an equation system to float assciation list, fail on non-consts. *)
-val eq_vals : eq_sys -> ((string * string) * float) list
-*)
-
-(** {2 Simple operations.} *)
-(*
-val add : term -> term -> term
-val ladd1 : term -> term list -> term list
-val ladd : term list -> term list -> term list
-
-val mul : term -> term -> term
-val lmul1 : term -> term list -> term list
-val lmul : term list -> term list -> term list
-
-
-(** {2 Substitution for variables.} *)
-
-(** Substitute terms for variables as in [dict] in the given term. *)
-val subst : (string * term) list -> term -> term
-
-*)
-(** Substitute [vals] for [vars] in [terms] and simplify. *)
-val subst_simp : string list -> term list -> term list -> term list
-
-(*
-(** Substitute terms for function variables as in [dict] in the given term. *)
-val subst_f : ((string * string) * term) list -> term -> term
-
-(** Substitute [vals] for function [vars] in [terms] and simplify. *)
-val subst_simp_f : (string * string) list -> term list -> term list -> term list
-*)
-
-(** Substitute variables and function vals in an eq. system and simplify. *)
-val subst_simp_eq : (string * term) list -> ((string * string) * term) list ->
- eq_sys -> eq_sys
-
-(** Substitute function argument names in an equation system, left and right. *)
-val subst_names : (string * string) list -> eq_sys -> eq_sys
-
-
-(** {2 Runge-Kutta Method for Term Equations} *)
-
-
-(** Perform a Runge-Kutta (RK4) step for [vars] with [vals_init] and right-hand
- side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
-(*val rk4_step : string -> term -> term -> eq_sys -> term list -> term list*)
-
-
-(** Compile eq_sys to function. *)
-val compile : string -> eq_sys -> (float -> float array -> float array)
-
-(** RK4 with compiled system. *)
-val rk4_step_c : float -> float -> (float -> float array -> float array) ->
- float array -> float array
Deleted: trunk/Toss/Arena/TermParser.mly
===================================================================
--- trunk/Toss/Arena/TermParser.mly 2012-05-18 21:22:13 UTC (rev 1709)
+++ trunk/Toss/Arena/TermParser.mly 2012-05-19 21:37:16 UTC (rev 1710)
@@ -1,46 +0,0 @@
-/* Parser for Terms used in equations. */
-
-/* Tokens taken from Lexer.mll in directory above. */
-%{
- open Lexer
-%}
-
-%start parse_term parse_eqs
-%type <Term.term> parse_term term_expr
-%type <(string * string) * Term.term> eq_expr
-%type <Term.eq_sys> parse_eqs eq_sys
-
-
-%%
-
-
-%public term_expr:
- | INT { Term.Const (float_of_int $1) }
- | FLOAT { Term.Const ($1) }
- | ID { Term.Var ($1) }
- | MINUS ID { Term.Times (Term.Const (-1.), Term.Var ($2)) }
- | COLON ID OPEN ID CLOSE { Term.FVar ($2, $4) }
- | COLON ID OPEN INT CLOSE { Term.FVar ($2, string_of_int $4) }
- | term_expr FLOAT { Term.Plus ($1, Term.Const $2) }
- | term_expr INT { Term.Plus ($1, Term.Const (float_of_int $2)) }
- | term_expr PLUS term_expr { Term.Plus ($1, $3) }
- | term_expr MINUS term_expr { Term.Plus ($1, Term.Times(Term.Const(-1.), $3))}
- | term_expr TIMES term_expr { Term.Times ($1, $3) }
- | term_expr DIV term_expr { Term.Div ($1, $3) }
- | OPEN term_expr CLOSE { $2 }
-
-eq_expr: /* differential equations only */
- | COLON ID OPEN ID CLOSE APOSTROPHE EQ term_expr
- { (($2, $4), $8) }
- | COLON ID OPEN INT CLOSE APOSTROPHE EQ term_expr
- { (($2, string_of_int $4), $8) }
-
-%public eq_sys:
- | eq_expr { [$1] }
- | eq_expr SEMICOLON eq_sys { $1 :: $3 }
-
-parse_term:
- term_expr EOF { $1 }
-
-parse_eqs:
- eq_sys EOF { $1 };
Deleted: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-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-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-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-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-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-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-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: <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-05 20:14:09
|
Revision: 1721
http://toss.svn.sourceforge.net/toss/?rev=1721&view=rev
Author: lukaszkaiser
Date: 2012-06-05 20:13:57 +0000 (Tue, 05 Jun 2012)
Log Message:
-----------
The Cash-Karp non-stiff adaptive RK code.
Modified Paths:
--------------
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/examples/Parsing.toss
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/Formula/Formula.ml 2012-06-05 20:13:57 UTC (rev 1721)
@@ -637,3 +637,107 @@
let k4 = eq_f (tinit +. tstep) (aadd vals_arr (amul tstep k3)) in
let (dk2, dk3) = (amul (2.) k2, amul (2.) k3) in
aadd vals_arr (amul tstepdiv6 (aadd k1 (aadd dk2 (aadd dk3 k4))))
+
+let dist a1 a2 =
+ let d = Aux.array_fold_left2 (fun d x y -> d+.(x-.y)*.(x-.y)) 0. a1 a2 in
+ d ** 0.5
+
+let sf = 0.9
+
+let rkCK_default_start () = (ref 1.5, ref 1.1, ref 100., ref 100.)
+
+(* Implements the Cash-Karp algorithm with varying order and adaptive step,
+ precisely as described in the paper "A Variable Order Runge-Kutta Method
+ for Initial Value Problems with Varying Right-Hand Sides" by J. R. Cash and
+ Alan H. Karp, ACM Trans. Math. Software, 1990.
+ The interface is as in rk4_step above, except now the tolerance is used
+ (given by [epsilon]) and some initial references must be set (use the ones
+ from rkCK_default_start). We also return time passed and next step size.*)
+let rkCK_step ?(epsilon=0.0001) (twiddle1, twiddle2, quit1, quit2) tn h f yn =
+ let k1 = f tn yn in
+ let k2 = f (tn +. (h/.5.)) (aadd yn (amul (h/.5.) k1)) in
+ let y1 = aadd yn (amul h k1) in
+ let y2 = aadd yn (amul h (aadd (amul (-3./.2.) k1) (amul (5./.2.) k2))) in
+ let e1 = ((dist y2 y1) /. epsilon) ** (1./.2.) in
+ if e1 > !twiddle1 *. !quit1 then (* abandon the step *)
+ let esttol = e1 /. !quit1 in
+ (yn, 0., h *. (max (1. /. 5.) (sf /. esttol)))
+ else
+ let k3 = f (tn +. (3.*.h/.10.))
+ (aadd yn (aadd (amul (3.*.h/.40.) k1) (amul (9.*.h/.40.) k2))) in
+ let k4 = f (tn +. (3.*.h/.5.))
+ (aadd yn (aadd (amul (3.*.h/.10.) k1)
+ (aadd (amul (-9.*.h/.10.) k2) (amul (6.*.h/.5.) k3)))) in
+ let y3 = aadd yn (amul h
+ (aadd (amul (19./.54.) k1)
+ (aadd (amul (-10./.27.) k3) (amul(55./.54.) k4)))) in
+ let e2 = ((dist y3 y2) /. epsilon) ** (1./.3.) in
+ if e2 > !twiddle2 *. !quit2 then (* try a lower order solution *)
+ if e1 < 1. then (* check the error of the second-order solution *)
+ let res15 = aadd yn (amul (h /. 10.) (aadd k1 k2)) in
+ let res15bar = aadd yn (amul (h /. 5.) k1) in
+ if dist res15 res15bar < epsilon then (* accept second-order solution *)
+ (res15, h /. 5., h /. 5.)
+ else (* abandon the step *)
+ (yn, 0., h /. 5.)
+ else (* abandon the step *)
+ let esttol = e2 /. !quit2 in
+ (yn, 0., h *. (max (1. /. 5.) (sf /. esttol)))
+ else
+ let k5 = f (tn +. h)
+ (aadd yn (aadd (amul (-11.*.h/.54.) k1)
+ (aadd (amul (5.*.h/.2.) k2)
+ (aadd (amul (-70.*.h/.27.) k3)
+ (amul (35.*.h/.27.) k4))))) in
+ let k6 = f (tn +. (7.*.h/.8.))
+ (aadd yn (aadd (amul (1631.*.h/.55296.) k1)
+ (aadd (amul (175.*.h/.512.) k2)
+ (aadd (amul (575.*.h/.13824.) k3)
+ (aadd (amul (44275.*.h/.110592.) k4)
+ (amul (253.*.h/.4096.) k5)))))) in
+ let y4 = aadd yn (amul h
+ (aadd (amul (2825./.27648.) k1)
+ (aadd (amul (18575./.48384.) k3)
+ (aadd (amul (13525./.55296.) k4)
+ (aadd (amul (277./.14336.) k5)
+ (amul (1./.4.) k6)))))) in
+ let y5 = aadd yn (amul h
+ (aadd (amul (37./.378.) k1)
+ (aadd (amul (250./.621.) k3)
+ (aadd (amul (125./.594.) k4)
+ (amul (512./.1771.) k6))))) in
+ let e4 = ((dist y5 y4) /. epsilon) ** (1./.5.) in
+ if e4 > 1. then ( (* try a lower order solution *)
+ (* readjust twiddle factors *)
+ if e1 /. !quit1 < !twiddle1 then twiddle1 := max 1.1 (e1 /. !quit1);
+ if e2 /. !quit2 < !twiddle2 then twiddle2 := max 1.1 (e2 /. !quit2);
+ if e2 < 1. then ( (* try the order-3 solution *)
+ let res35 = aadd yn (amul h
+ (aadd (amul (1./.10.) k1)
+ (aadd (amul (2./.5.) k3)
+ (amul (1./.10.) k4)))) in
+ let res35bar = aadd yn (amul (3. *. h /. 5.) k3) in
+ if dist res35 res35bar < epsilon then (* accept order-3 solution *)
+ (res35, 3. *. h /. 5., 3. *. h /. 5.)
+ else (* try an even lower order solution *)
+ if e1 < 1. then (* check the error of the order-2 solution *)
+ let res15 = aadd yn (amul (h /. 10.) (aadd k1 k2)) in
+ let res15bar = aadd yn (amul (h /. 5.) k1) in
+ if dist res15 res15bar < epsilon then (* accept order-2 solution*)
+ (res15, h /. 5., h /. 5.)
+ else (* abandon the step *)
+ (yn, 0., h /. 5.)
+ else (* abandon the current step *)
+ (yn, 0., h *. (max (1. /. 5.) (sf /. e4)))
+ ) else (* abandon the current step *)
+ (yn, 0., h *. (max (1. /. 5.) (sf /. e4)))
+ ) else ( (* accept the full order-5 solution *)
+ let q1, q2 = e1 /. e4, e2 /. e4 in
+ let q1 = if q1 > !quit1 then min q1 (10. *. !quit1) else
+ max q1 (2. *. !quit1 /. 3.) in
+ let q2 = if q2 > !quit2 then min q2 (10. *. !quit2) else
+ max q2 (2. *. !quit2 /. 3.) in
+ quit1 := max 1. (min 10000. q1);
+ quit2 := max 1. (min 10000. q2);
+ (y5, h, h *. (min 5. (sf /. e4)))
+ )
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/Formula/Formula.mli 2012-06-05 20:13:57 UTC (rev 1721)
@@ -145,3 +145,15 @@
side [eq_terms]. Time variable [tvar] starts at [tinit] and moves [tstep]. *)
val rk4_step : float -> float -> (float -> float array -> float array) ->
float array -> float array
+
+(** Implements the Cash-Karp algorithm with varying order and adaptive step,
+ precisely as described in the paper "A Variable Order Runge-Kutta Method
+ for Initial Value Problems with Varying Right-Hand Sides" by J. R. Cash and
+ Alan H. Karp, ACM Trans. Math. Software, 1990.
+ The interface is as in rk4_step above, except now the tolerance is used
+ (given by [epsilon]) and some initial references must be set (use the ones
+ from rkCK_default_start). We also return time passed and next step size.*)
+val rkCK_default_start : unit -> float ref * float ref * float ref * float ref
+val rkCK_step: ?epsilon: float -> float ref* float ref* float ref* float ref ->
+ float -> float -> (float -> float array -> float array) ->
+ float array -> float array * float * float
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-06-05 20:13:57 UTC (rev 1721)
@@ -81,5 +81,35 @@
"0.00110, 3.6e-10, 2.99999, -1.9991, 7.16443, -0.0008"
(float_arr_str 7 (rk4_step 0. 0.02 ceqs init));
);
+
+ "rkCK" >::
+ (fun () ->
+ let float_arr_str n fa = String.concat ", " (List.map (fun f ->
+ String.sub (string_of_float f) 0 n) (Array.to_list fa)) in
+ let eqs = eqs_of_string ":f(a)' = :f(a) + :t" in
+ let ceqs = compile ":t" eqs in
+ let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.1 ceqs [|0.|] in
+ assert_equal ~printer:(fun x -> x) "0.00517" (float_arr_str 7 res);
+
+ let tyson_model_eqs = eqs_of_string
+ (" :y(e1)' = 0.015 + -200. * :y(e1) * :y(e4); " ^
+ ":y(e2)' = -0.6 * :y(e2) + 1. * :y(e5); " ^
+ ":y(e3)' = -100. * :y(e3) + 1. * :y(e5) + 100. * :y(e4); " ^
+ ":y(e4)' = -100. * :y(e4) + 100.*:y(e3) + -200.*:y(e1) * :y(e4); "^
+ ":y(e5)' = -1. * :y(e5) + 0.018 * :y(e6) + " ^
+ " 180. * :y(e6) * :y(e5) * :y(e5); " ^
+ ":y(e6)' = -0.018 * :y(e6) + 200. * :y(e1) * :y(e4) + " ^
+ " -180. * :y(e6) * :y(e5) * :y(e5)") in
+ let ceqs = compile ":t" tyson_model_eqs in
+ let init = [| 0.; 0.; 1.; 0.; 0.; 0. |] in
+ (* Step in this try is too big - should abandon, i.e. time passed = 0.*)
+ let (_, t, _) = rkCK_step (rkCK_default_start()) 0. 0.02 ceqs init in
+ assert_equal ~printer:(fun x -> string_of_float x) 0. t;
+ (* Now it is ok, should report results. *)
+ let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.003 ceqs init in
+ assert_equal ~printer:(fun x -> x)
+ "4.28845, 1.90309, 0.77440, 0.22559, 3.00456, 2.11544"
+ (float_arr_str 7 res);
+ );
]
Modified: trunk/Toss/examples/Parsing.toss
===================================================================
--- trunk/Toss/examples/Parsing.toss 2012-06-05 10:39:06 UTC (rev 1720)
+++ trunk/Toss/examples/Parsing.toss 2012-06-05 20:13:57 UTC (rev 1721)
@@ -13,4 +13,4 @@
}
START [ | Tp:2 {}; Tlist:1 {}; Pone (one); Ptrue (t); Pnil (nil);
- S { (one, t); (t, nil) } | ]
+ S { (one, t); (t, nil) } | - ]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-06-07 21:55:48
|
Revision: 1722
http://toss.svn.sourceforge.net/toss/?rev=1722&view=rev
Author: lukaszkaiser
Date: 2012-06-07 21:55:42 +0000 (Thu, 07 Jun 2012)
Log Message:
-----------
Using the new ODE solver in ContinuousRule and in the interface.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Play.js
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaTest.ml
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -1,9 +1,8 @@
(* Structure rewriting with continuous dynamics. *)
-let time_step = ref 0.1
-let get_time_step () = !time_step
-let set_time_step x = (time_step := x)
-let dIFFM = 10 (* So many differentiation steps for one time step. *)
+let time_step = 0.01
+let min_time_step = 0.1
+let max_registered_step = 0.05
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
@@ -124,40 +123,73 @@
let dyn_c = Formula.compile ":t" dyn in
LOG 1 "current time: %f" cur_time;
let time = ref cur_time in
- let diff_step, t_mod_diff = !time_step /. (float_of_int dIFFM), ref 0 in
+ let diff_step, t_mod_diff = ref time_step, ref 0 in
let step vals t0 =
LOG 1 "step at time %F" t0;
- Formula.rk4_step t0 diff_step dyn_c vals in
+ (* (Formula.rk4_step t0 !diff_step dyn_c vals, !diff_step, !diff_step) in *)
+ Formula.rkCK_step (Formula.rkCK_default_start()) t0 !diff_step dyn_c vals in
(* add the trace of the embedding to the structure, for invariants *)
let cur_struc = ref (List.fold_left (fun s (le, se) ->
Structure.add_rel s ("_lhs_" ^ le) [|se|]) struc m) in
- let last_struc, cur_vals, all_vals = ref !cur_struc, ref init_vals, ref [] in
- let end_time = !time +. t -. (0.01 *. diff_step) in
+ let last_struc, cur_vals = ref !cur_struc, ref init_vals in
+ let all_vals, reg_vals, old_time = ref [], ref [], ref 0. in
+ let end_time, reg_dtime = !time +. t, ref (max_registered_step +. 1.) in
LOG 1 "end time: %f" end_time;
let upd_struct st = List.fold_left2 (fun s ((f, e), _) v ->
Structure.change_fun s f e v) st dyn (Array.to_list !cur_vals) in
- while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
- if !t_mod_diff = 0 || dIFFM = 1 then all_vals := !cur_vals :: !all_vals;
- t_mod_diff := (!t_mod_diff + 1) mod dIFFM;
- cur_vals := step !cur_vals !time ;
- time := !time +. diff_step ;
- last_struc := !cur_struc ;
- cur_struc := upd_struct !cur_struc ;
- done ;
+ while (!time < end_time) && (Solver.M.check !cur_struc r.inv) do
+ all_vals := ( !time :: (Array.to_list !cur_vals) ) :: !all_vals;
+ if !reg_dtime > max_registered_step then (
+ reg_vals := ( !time :: (Array.to_list !cur_vals) ) :: !reg_vals;
+ reg_dtime := 0.;
+ );
+ old_time := !time;
+ diff_step := min !diff_step (end_time -. !time);
+ while !time = !old_time do
+ let (new_cur_vals, new_time, new_dstep) = step !cur_vals !time in
+ time := !time +. new_time;
+ cur_vals := new_cur_vals;
+ diff_step := min min_time_step new_dstep;
+ done;
+ LOG 1 "step to time %F new size %F" !time !diff_step;
+ reg_dtime := !reg_dtime +. (!time -. !old_time);
+ last_struc := !cur_struc;
+ cur_struc := upd_struct !cur_struc;
+ done;
if (Solver.M.check !cur_struc r.inv) then (
- all_vals := !cur_vals :: !all_vals ;
+ all_vals := ( !time :: (Array.to_list !cur_vals) ) :: !all_vals;
+ reg_vals := ( !time :: (Array.to_list !cur_vals) ) :: !reg_vals ;
last_struc := !cur_struc
) else (
LOG 2 "Inv failed.\n%s\n%s" (Structure.str !cur_struc) (Formula.str r.inv);
if !all_vals = [] then
failwith "rewriting invariant failed in the first step; rule inapplicable"
- else cur_vals := List.hd !all_vals;
+ else (
+ cur_vals := Array.of_list (List.tl (List.hd !all_vals));
+ all_vals := List.tl !all_vals;
+ time := !old_time;
+ diff_step := !diff_step /. 10.;
+ cur_struc := !last_struc;
+ while Solver.M.check !cur_struc r.inv do ( (* repeat w/ small step size *)
+ all_vals := ( !time :: (Array.to_list !cur_vals) ) :: !all_vals;
+ let (new_cur_vals, new_time, new_dstep) = step !cur_vals !time in
+ cur_vals := new_cur_vals;
+ time := !time +. new_time;
+ last_struc := !cur_struc;
+ cur_struc := upd_struct !cur_struc;
+ ) done;
+ if (Solver.M.check !cur_struc r.inv) then (
+ failwith "ContinuousRule: rewrite_single_nocheck: error: impossible";
+ ) else (
+ cur_vals := Array.of_list (List.tl (List.hd !all_vals));
+ )
+ )
);
let rec select_pos ids llst =
if ids = [] then [] else (List.hd ids, List.map List.hd llst) ::
(select_pos (List.tl ids) (List.map List.tl llst)) in
- let all_vals_assoc =
- select_pos (List.map fst dyn) (List.rev_map Array.to_list !all_vals) in
+ let all_vals_assoc = if dyn = [] then [] else
+ select_pos (("t", "") :: (List.map fst dyn)) (List.rev !reg_vals) in
LOG 1 "%s" (String.concat "\n" (List.map (fun ((a, b), tl)-> a ^"("^ b ^")" ^
(String.concat ", " (List.map string_of_float tl))) all_vals_assoc));
let re_sb = List.map (fun (p,v) -> p, Formula.Const v) params in
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Arena/ContinuousRule.mli 2012-06-07 21:55:42 UTC (rev 1722)
@@ -1,9 +1,5 @@
(** Structure rewriting with continuous dynamics. *)
-val get_time_step : unit -> float
-val set_time_step : float -> unit
-
-
(** {2 Basic Type Definition} *)
(** Specification of a continuous rewriting rule, as in modelling document.
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Client/JsHandler.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -167,7 +167,7 @@
minl posx, maxl posx, minl posy, maxl posy
(* Translate current structure into an "info_obj" format. *)
-let js_of_game_state ?(show_payoffs=true) ?dims game state =
+let js_of_game_state ?(show_payoffs=true) ?dims game (time, state) =
let struc = state.Arena.struc in
let elems = Structure.elements struc in
LOG 1 "js_of_game_state: Preparing game elements...";
@@ -196,6 +196,7 @@
(Structure.rel_signature struc)) in
let rels, rel_names = List.split rels_all in
let info_obj = jsnew js_object () in
+ Js.Unsafe.set info_obj (js"time") (num time);
Js.Unsafe.set info_obj (js"maxx") (num maxx);
Js.Unsafe.set info_obj (js"minx") (num minx);
Js.Unsafe.set info_obj (js"maxy") (num maxy);
@@ -245,7 +246,7 @@
cur_all_moves := Arena.list_moves_shifts game state;
cur_move := 0;
LOG 1 "new_play (%s): calling js_of_game_state." game_name;
- js_of_game_state game state
+ js_of_game_state game (0., state)
let _ = set_handle "new_play" new_play
@@ -254,19 +255,21 @@
if n < 0 then Js.null else
let game, _ = !cur_game.game_state in
let state = List.nth !play_states n in
- Js.some (js_of_game_state ~show_payoffs:(n = 0) game state)
+ Js.some (js_of_game_state ~show_payoffs:(n = 0) game (0., state))
let _ = set_handle "prev_move" preview_move
(* Compute all copies of [state] given by [shifts], including [state]. *)
let shifted_state state shifts =
- if shifts = [] then [state] else
- let len, res = List.length (snd (List.hd shifts)), ref [state] in
+ if shifts = [] then [(0., state)] else
+ let times, shifts = snd (List.hd shifts), List.tl shifts in
+ LOG 1 "%s" (String.concat ", " (List.map string_of_float times));
+ let len, res, t0 = List.length times, ref [(0., state)], List.hd times in
for i = 0 to len - 1 do
let new_struc = List.fold_left (fun struc ((fname, elem), ts) ->
let v = (List.nth ts i) in
Structure.change_fun struc fname elem v) state.Arena.struc shifts in
- res := { state with Arena.struc = new_struc } :: !res;
+ res := (List.nth times i -. t0, {state with Arena.struc=new_struc})::!res;
done;
!res
@@ -280,8 +283,10 @@
play_states := n_state :: !play_states;
cur_all_moves := Arena.list_moves_shifts game n_state;
cur_move := 0;
- let states = List.rev (n_state :: (shifted_state old_state shifts)) in
- let dims = List.fold_left (fun (a, b, c, d) s ->
+ let last_state = if shifts = [] then (0.1, n_state) else
+ (n_state.Arena.time -. (List.hd (snd (List.hd shifts))), n_state) in
+ let states = List.rev (last_state :: shifted_state old_state shifts) in
+ let dims = List.fold_left (fun (a, b, c, d) (_, s) ->
let (x, y, z, v) = state_dim s in
(min a x, max b y, min c z, max d v)) (state_dim n_state) states in
Js.some (Js.array (Array.of_list (List.map
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Client/Play.js 2012-06-07 21:55:42 UTC (rev 1722)
@@ -149,13 +149,12 @@
function play_move_continue (info, suggest_f) {
PlayDISP.free ();
- var TIMESTEP = 100;
for (var i = 1; i < info.length-1; i++) {
setTimeout (function (_this, cur_info) {
_this.cur_state =
new State (_this.game, cur_info, _this.cur_state.mirror);
_this.redraw ();
- }, i*TIMESTEP, this, info[i]);
+ }, info[i].time * 1000, this, info[i]);
}
setTimeout (function (_this, cur_info) {
_this.new_state (cur_info);
@@ -165,7 +164,7 @@
var mv_time = document.getElementById("speed").value;
suggest_f (mv_time);
}
- }, (info.length-1)*TIMESTEP, this, info[info.length - 1])
+ }, info[info.length-1].time * 1000, this, info[info.length - 1])
}
Play.prototype.move_continue = play_move_continue;
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Formula/Formula.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -653,7 +653,7 @@
The interface is as in rk4_step above, except now the tolerance is used
(given by [epsilon]) and some initial references must be set (use the ones
from rkCK_default_start). We also return time passed and next step size.*)
-let rkCK_step ?(epsilon=0.0001) (twiddle1, twiddle2, quit1, quit2) tn h f yn =
+let rkCK_step ?(epsilon=0.00001) (twiddle1, twiddle2, quit1, quit2) tn h f yn =
let k1 = f tn yn in
let k2 = f (tn +. (h/.5.)) (aadd yn (amul (h/.5.) k1)) in
let y1 = aadd yn (amul h k1) in
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-06-05 20:13:57 UTC (rev 1721)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-06-07 21:55:42 UTC (rev 1722)
@@ -106,9 +106,9 @@
let (_, t, _) = rkCK_step (rkCK_default_start()) 0. 0.02 ceqs init in
assert_equal ~printer:(fun x -> string_of_float x) 0. t;
(* Now it is ok, should report results. *)
- let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.003 ceqs init in
+ let (res, _, _) = rkCK_step (rkCK_default_start()) 0. 0.002 ceqs init in
assert_equal ~printer:(fun x -> x)
- "4.28845, 1.90309, 0.77440, 0.22559, 3.00456, 2.11544"
+ "2.93178, 2.62576, 0.83515, 0.16483, 6.34473, 6.82189"
(float_arr_str 7 res);
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X