Thread: [Toss-devel-svn] SF.net SVN: toss:[1662] trunk/Toss (Page 12)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2012-02-04 01:07:16
|
Revision: 1662
http://toss.svn.sourceforge.net/toss/?rev=1662&view=rev
Author: lukaszkaiser
Date: 2012-02-04 01:07:09 +0000 (Sat, 04 Feb 2012)
Log Message:
-----------
Allow play history reference in rule preconditions, shorten chess definition.
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/ContinuousRuleParser.mly
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Arena/DiscreteRuleParser.mly
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/Makefile
trunk/Toss/Play/Move.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/examples/Chess.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/Arena.ml 2012-02-04 01:07:09 UTC (rev 1662)
@@ -374,6 +374,24 @@
let equational_def_style = ref true
+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) -> Printf.sprintf "%s: %i" e x) m) in
+ let rt = match rtime with None -> "" | Some f -> " " ^ (string_of_float f) in
+ if (pl = []) then
+ 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
+ Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
+ )
+
+let sprint_game_move gm =
+ ignore (Format.flush_str_formatter ());
+ fprint_game_move Format.str_formatter gm;
+ Format.flush_str_formatter ()
+
let fprint_state_full print_compiled_rules ppf
({rules = rules;
graph = graph;
@@ -385,6 +403,7 @@
{struc = struc;
time = time;
cur_loc = cur_loc;
+ history = hist;
}) =
Format.fprintf ppf "@[<v>";
List.iter (fun (drel, (args, body)) ->
@@ -414,6 +433,9 @@
loc_id (fprint_loc_body struc player_names) loc) graph;
Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
(Structure.fprint ~show_empty:true) struc;
+ if (hist <> []) then
+ Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
+ (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
@@ -637,10 +659,11 @@
| GetTime (* Get time step and time *)
| SetState of game * game_state (* Set the full state *)
| GetState (* Return the state *)
- | SetModel of Structure.structure (* Set the model *)
- | GetModel (* Return the current model*)
+ | GetModel (* Return model+history *)
+ | SetModel of Structure.structure * (move * float option) list (* Set above *)
+
(* --------------------------- REQUEST HANDLER ------------------------------ *)
(* Apply function [f] to named structure at location [loc] in [state].
@@ -942,7 +965,7 @@
{d with DiscreteRule.match_formula = pre}
| Some rule_src ->
DiscreteRule.compile_rule signat defs
- {rule_src with DiscreteRule.pre = pre} in
+ {rule_src with DiscreteRule.pre = (pre, []) } in
let nr = (* TODO: rename lhs_* relations to be consistent with ln *)
ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
(nr, "RULE COND SET") in
@@ -953,7 +976,7 @@
let pre =
match discr.DiscreteRule.struc_rule with
| None -> discr.DiscreteRule.match_formula
- | Some struc_r -> struc_r.DiscreteRule.pre in
+ | Some struc_r -> fst struc_r.DiscreteRule.pre in
let (inv, post)=(r.ContinuousRule.inv, r.ContinuousRule.post) in
(Formula.str pre)^"; "^ (Formula.str inv) ^"; "^ (Formula.str post) in
((state_game, state),
@@ -1042,9 +1065,18 @@
get_from_rule get_assoc r_name state_game "get rule assoc")
| GetRuleMatches (r_name) -> (
+ let check_history_pre r hist =
+ match r.ContinuousRule.discrete.DiscreteRule.struc_rule with
+ | None -> true
+ | Some sr ->
+ let prev_list = snd (sr.DiscreteRule.pre) in
+ let constraint_satisfied (rname, b) =
+ List.exists (fun (mv, _) -> mv.rule = rname) hist = b in
+ List.for_all constraint_satisfied prev_list in
try
let r = List.assoc r_name state_game.rules in
- let matches = ContinuousRule.matches_post struc r state.time in
+ let matches = if not (check_history_pre r state.history) then [] else
+ ContinuousRule.matches_post struc r state.time in
(* matches are from LHS to model *)
((state_game, state),
String.concat "; " (
@@ -1064,7 +1096,11 @@
(* 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}),
+ let newmv = { mv_time = t; parameters = p; rule = r_name;
+ matching = m; next_loc = -1 (*FIX*) } in
+ let h = (newmv, None) :: state.history in
+ ((state_game,
+ {state with struc = new_struc; time = new_time; history = h}),
shifts_s)
| None -> ((state_game, state),
"ERR applying "^r_name^", postcondition fails")
@@ -1100,8 +1136,12 @@
| SetState (g, s) ->
((g, s), "STATE SET")
| GetState -> ((state_game, state), state_str (state_game, state))
- | SetModel m -> ((state_game, { state with struc = m }), "MODEL SET")
- | GetModel -> ((state_game, state), Structure.sprint state.struc)
+ | GetModel ->
+ let h_str = if state.history = [] then "" else "\nMOVES\n" ^
+ (String.concat ";\n" (List.map sprint_game_move state.history)) in
+ ((state_game, state), (Structure.sprint state.struc) ^ h_str)
+ | SetModel (m, h) ->
+ ((state_game, { state with struc = m; history = h }), "MODEL SET")
let can_modify_game = function
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/Arena.mli 2012-02-04 01:07:09 UTC (rev 1662)
@@ -232,8 +232,9 @@
| GetTime (** Get time step and time *)
| SetState of game * game_state (** Set the full state *)
| GetState (** Return the state *)
- | SetModel of Structure.structure (** Set the model *)
- | GetModel (** Return the model *)
+ | GetModel (** Return model+history *)
+ | SetModel of Structure.structure * (move * float option) list
+ (** Set the model+history *)
val handle_request :
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-02-04 01:07:09 UTC (rev 1662)
@@ -86,17 +86,21 @@
EQ body = formula_expr_err { (rel, args, body) }
game_move_timed:
- | OPENSQ RULE_SPEC? r = id_int COMMA? t = FLOAT COMMA?
+ | OPENSQ r = id_int t = FLOAT RARR l = INT EMB
+ emb = separated_list (COMMA, separated_pair (ID, COLON, 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 LOC_MOD? l = INT EMB
+ RARR l = INT EMB
emb = separated_list (COMMA, separated_pair (ID, COLON, INT)) CLOSESQ
- f = FLOAT?
+ f = FLOAT
{ ({mv_time = t; parameters = p; rule = r; next_loc = l; matching = emb;},
- f) }
+ Some f) }
| OPENSQ error
- { Lexer.report_parsing_error $startpos $endpos
+ { Lexer.report_parsing_error $startpos $endpos
"Syntax error in timed game move definition."
- }
+ }
game_defs:
| RULE_SPEC rname = id_int COLON r = rule_expr
@@ -149,6 +153,8 @@
| program = nonempty_list (game_defs)
{ process_definition program }
+move_expr:
+ | ID { Arena.empty_move with rule = $1 }
struct_location:
| MODEL_SPEC { Struct }
@@ -162,10 +168,14 @@
| SET_CMD STATE_SPEC gs=game_state { let (g, s) = gs in SetState (g, s) }
| GET_CMD STATE_SPEC { GetState }
| GET_CMD MODEL_SPEC { GetModel }
- | SET_CMD MODEL_SPEC struct_expr { SetModel $3 }
+ | SET_CMD MODEL_SPEC model = struct_expr
+ h = option (preceded (MOVES, separated_list (SEMICOLON, game_move_timed)))
+ { SetModel (model, match h with None -> [] | Some l -> l) }
| SET_CMD MODEL_SPEC model = struct_expr WITH
defs = separated_list (SEMICOLON, rel_def_simple)
- { SetModel (Arena.add_def_rels model defs) }
+ h = option (preceded (MOVES, separated_list (SEMICOLON, game_move_timed)))
+ { SetModel (Arena.add_def_rels model defs,
+ match h with None -> [] | Some l -> l) }
| ADD_CMD ELEM_MOD struct_location
{ AddElem ($3) }
| ADD_CMD REL_MOD
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-02-04 01:07:09 UTC (rev 1662)
@@ -214,9 +214,8 @@
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
- if r.post = Formula.And [] ||
- Solver.M.check res_struc r.post
- then Some res_struc_n_shifts
+ if r.post = Formula.And [] || Solver.M.check res_struc r.post then
+ Some res_struc_n_shifts
else None
Modified: trunk/Toss/Arena/ContinuousRuleParser.mly
===================================================================
--- trunk/Toss/Arena/ContinuousRuleParser.mly 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/ContinuousRuleParser.mly 2012-02-04 01:07:09 UTC (rev 1662)
@@ -14,12 +14,20 @@
%%
+constr_expr:
+ | ID { ($1, true) }
+ | NOT ID { ($2, false) }
+precond_expr:
+ | formula_expr { ($1, []) }
+ | f = formula_expr AND BEFORE
+ l = separated_list (COMMA, constr_expr) { (f, l) }
+
%public rule_expr:
| discr = discrete_rule_expr
dyn = loption (preceded (DYNAMICS, eq_sys))
upd = loption (preceded (UPDATE, expr_eq_sys))
- pre = option (preceded (PRE, formula_expr))
+ pre = option (preceded (PRE, precond_expr))
inv = option (preceded (INV, formula_expr))
post = option (preceded (POST, formula_expr))
{ fun signat defs rname ->
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-02-04 01:07:09 UTC (rev 1662)
@@ -15,7 +15,7 @@
rhs_struc : Structure.structure; (* optional tuples in _opt_R-relations *)
emb_rels : string list; (* tau_e-relations, other tau_h *)
rule_s : (int * int) list; (* map of [rhs] elements to [lhs] elements *)
- pre : Formula.formula; (* Precondition for embedding *)
+ pre : Formula.formula * (string * bool) list; (* precondition *)
}
type var_tuples = string array list
@@ -237,16 +237,17 @@
let map_to_formulas f r =
+ let f1 (a, l) = (f a, l) in
{r with
struc_rule = Aux.map_option
- (fun discr -> {discr with pre = f discr.pre}) r.struc_rule;
+ (fun discr -> {discr with pre = f1 discr.pre}) r.struc_rule;
match_formula = f r.match_formula}
let fold_over_formulas f r acc =
let acc =
match r.struc_rule with
| None -> acc
- | Some r -> f r.pre acc in
+ | Some r -> f (fst r.pre) acc in
let acc =
f r.match_formula acc in
acc
@@ -917,7 +918,7 @@
lhs_neg_tups @
List.map (function [x;y] -> Not (Eq (`FO x, `FO y))
| _ -> assert false) lhs_alldif_tups @
- (FormulaOps.as_conjuncts rule_src.pre)
+ (FormulaOps.as_conjuncts (fst rule_src.pre))
) in
(* Substitute defined relations, expanding their special variants. *)
@@ -1037,7 +1038,7 @@
List.map fst add_elems @ Aux.list_diff lhs_vars del_elems in
let match_formula = match pre with
| None -> match_formula
- | Some pre -> Formula.And [match_formula; pre] in
+ | Some (pre, _) -> Formula.And [match_formula; pre] in
let rlmap =
if add_elems = [] && del_elems = []
then None
@@ -1226,7 +1227,7 @@
rhs_struc = rhs_struc;
emb_rels = emb_rels;
rule_s = List.map (fun (_,i) ->i,i) struc_elems;
- pre = precond;
+ pre = (precond, []);
}
@@ -1263,8 +1264,12 @@
let l_str = Structure.str r.lhs_struc in
let r_str = Structure.str r.rhs_struc in
let pre_str =
- if r.pre = Formula.And [] then ""
- else " pre " ^ (Formula.str r.pre) in
+ if (fst r.pre = Formula.And [] && snd r.pre = []) then "" else
+ let s = " pre " ^ (Formula.str (fst r.pre)) in
+ if snd r.pre = [] then s else
+ let before_str (name, b) = if b then name else "not " ^ name in
+ let before_s = String.concat ", " (List.map before_str (snd r.pre)) in
+ s ^ " and before " ^ before_s in
l_str ^ " -> " ^ r_str ^ emb_str ^ assoc_str ^ pre_str
let fprint_struc_rule f r =
@@ -1282,10 +1287,13 @@
Format.fprintf f "@ @[<1>with@ [@,@[<1>%a@]@,]@]"
(Aux.fprint_sep_list "," matched) r.rule_s;
Format.fprintf f "@]";
- if r.pre <> Formula.And [] then
- Format.fprintf f "@ @[<1>pre@ %a@]" Formula.fprint r.pre
+ if (fst r.pre <> Formula.And [] || snd r.pre <> []) then
+ Format.fprintf f "@ @[<1>pre@ %a@]" Formula.fprint (fst r.pre);
+ if (snd r.pre <> []) then
+ let before_str (name, b) = if b then name else "not " ^ name in
+ let before_s = String.concat ", " (List.map before_str (snd r.pre)) in
+ Format.fprintf f "@ @[<1>and before@ %s@]" before_s
-
let rel_tups_to_atoms rel_tups =
Aux.concat_map
(fun (rel, tups) ->
@@ -1477,8 +1485,15 @@
Structure.compare_diff ~cmp_funs r1.rhs_struc r2.rhs_struc in
if not eq then raise (Diff_result (
"Rule RHS structures differ: "^msg));
- let pre1 = Formula.flatten r1.pre in
- let pre2 = Formula.flatten r2.pre in
+ if snd r1.pre <> snd r2.pre then (
+ let before_str (name, b) = if b then name else "not " ^ name in
+ let before_s r = String.concat ", " (List.map before_str (snd r.pre)) in
+ raise (Diff_result (Printf.sprintf
+ "Rule preconditions BEFORE differ:\n%s\n =/=\n%s"
+ (before_s r1) (before_s r2)));
+ );
+ let pre1 = Formula.flatten (fst r1.pre) in
+ let pre2 = Formula.flatten (fst r2.pre) in
if pre1 <> pre2 then raise (Diff_result (
Printf.sprintf "Rule preconditions differ:\n%s\n =/=\n%s"
(Formula.sprint pre1) (Formula.sprint pre2)));
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/DiscreteRule.mli 2012-02-04 01:07:09 UTC (rev 1662)
@@ -19,7 +19,7 @@
rhs_struc : Structure.structure; (** optional tuples in _opt_R-relations *)
emb_rels : string list; (** tau_e-relations, other tau_h *)
rule_s : (int * int) list; (** map of [rhs] elements to [lhs] elems *)
- pre : Formula.formula; (** Precondition for embedding *)
+ pre : Formula.formula * (string * bool) list; (** precondition *)
}
type var_tuples = string array list
@@ -135,7 +135,7 @@
Formula.formula ->
(string list * (string * string list) list) option ->
((string * string option) list * (string * string list) list) option ->
- Formula.formula option -> rule
+ (Formula.formula * (string * bool) list) option -> rule
(** Relations that can explicitly change state by rewriting (i.e. not
as a result of erasure). (A "symmetric difference" of rule sides.) *)
Modified: trunk/Toss/Arena/DiscreteRuleParser.mly
===================================================================
--- trunk/Toss/Arena/DiscreteRuleParser.mly 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/DiscreteRuleParser.mly 2012-02-04 01:07:09 UTC (rev 1662)
@@ -6,8 +6,8 @@
%start parse_discrete_rule
%type <(string * int) list ->
(string * (string list * Formula.formula)) list ->
- Formula.formula option -> DiscreteRule.rule>
- parse_discrete_rule discrete_rule_expr
+ (Formula.formula * (string * bool) list) option -> DiscreteRule.rule>
+ parse_discrete_rule discrete_rule_expr
%%
@@ -47,7 +47,7 @@
let base_struc = Structure.empty_with_signat signat in
let lhs = lhs base_struc and rhs = rhs base_struc in
let pre =
- match pre with None -> Formula.And [] | Some pre -> pre in
+ match pre with None -> (Formula.And [], []) | Some pre -> pre in
let struc_rule =
{ DiscreteRule.lhs_struc = lhs; rhs_struc = rhs;
emb_rels = emb_rels;
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-04 01:07:09 UTC (rev 1662)
@@ -132,7 +132,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = [];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -151,7 +151,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"Q"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -171,7 +171,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"Q"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -190,7 +190,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"R"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,2; 3,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -215,7 +215,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = [];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -234,7 +234,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"Q"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -254,7 +254,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"Q"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -273,7 +273,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"R"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,2; 3,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -298,7 +298,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = [];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -318,7 +318,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"Q"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -342,7 +342,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = [];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -361,7 +361,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P";"Q"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -385,7 +385,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = [];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -405,7 +405,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -430,7 +430,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = [];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -454,7 +454,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -474,7 +474,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["C"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -500,7 +500,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -520,7 +520,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = []; (* C is in $tau_h$ but loses e *)
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -540,7 +540,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["C"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -564,7 +564,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["R"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1; 2,2]} in
let embs = find_matchings model rule_obj in
assert_raises
@@ -589,7 +589,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = formula_of_str "not C(a)";
+ pre = (formula_of_str "not C(a)", []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
assert_raises
@@ -607,7 +607,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = formula_of_str "not C(a)";
+ pre = (formula_of_str "not C(a)", []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -630,7 +630,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = formula_of_str "not C(a)";
+ pre = (formula_of_str "not C(a)", []);
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -654,7 +654,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"one not opt"
"not O(e)-> true"
@@ -668,7 +668,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"del one not opt"
"O(e)-> not O(e)"
@@ -682,7 +682,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_one_of ~msg:"match defined"
["P(e) or Q(e)-> O(e)"; "Q(e) or P(e)-> O(e)"]
@@ -696,7 +696,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_one_of ~msg:"match defined 2"
["P(e) or Q(e)-> (O(e) and not P(e) and not Q(e))";
@@ -715,7 +715,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"defrel: diffthan P Q"
"(not P(e) and not Q(e))-> true"
@@ -729,7 +729,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_one_of ~msg:"del defrel"
["(O(e) and not P(e) and not Q(e) and (_del_P(e) or _del_Q(e)))-> (P(e) and not O(e))";
@@ -746,7 +746,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["O"; "D"];
- pre = Formula.And [];
+ pre = (Formula.And [], []);
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"diffthan override"
"(not O(e) and not P(e))-> (O(e) and not Q(e))"
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Formula/Lexer.mll 2012-02-04 01:07:09 UTC (rev 1662)
@@ -50,6 +50,7 @@
| WITH
| EMB
| PRE
+ | BEFORE
| INV
| POST
| UPDATE
@@ -191,6 +192,7 @@
| "with" { WITH }
| "emb" { EMB }
| "pre" { PRE }
+ | "before" { BEFORE }
| "inv" { INV }
| "post" { POST }
| "update" { UPDATE }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Formula/Tokens.mly 2012-02-04 01:07:09 UTC (rev 1662)
@@ -8,8 +8,8 @@
%token LARR LDARR RARR RDARR LRARR LRDARR INTERV
%token OPENCUR CLOSECUR OPENSQ CLOSESQ OPEN CLOSE
%token IN_MOD AND OR XOR NOT EX ALL TC
-%token WITH EMB PRE INV POST UPDATE DYNAMICS TRUE FALSE ASSOC COND PAYOFF MOVES
-%token MATCH ADD_CMD DEL_CMD GET_CMD SET_CMD LET_CMD EVAL_CMD
+%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 EVAL_CMD
%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 LEFT_SPEC RIGHT_SPEC CLASS LFP GFP EOF
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-02 11:16:52 UTC (rev 1661)
+++ trunk/Toss/Makefile 2012-02-04 01:07:09 UTC (rev 1662)
@@ -45,8 +45,9 @@
OCB_LIB=-libs str,nums,unix,oUnit,sqlite3
OCB_LIBJS=-libs str,js_of_ocaml
OCB_PP=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 ../caml_extensions/pa_let_try.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo"
-OCB_PPJS=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 ../caml_extensions/pa_let_try.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo"
-OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
+OCB_PPJS=-pp "camlp4o -unsafe -I /usr/local/lib/ocaml/3.12.0 ../caml_extensions/pa_let_try.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo"
+OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \
+ -ocamlopt "ocamlopt -inline 10" $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
OCAMLBUILDJS=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PPJS) \
$(OCB_LIBJS) $(OCB_CFLAG) $(OCB_LFLAG)
Modified: trunk/Toss/Play/Move.ml
========================...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-05 01:24:15
|
Revision: 1663
http://toss.svn.sourceforge.net/toss/?rev=1663&view=rev
Author: lukaszkaiser
Date: 2012-02-05 01:24:07 +0000 (Sun, 05 Feb 2012)
Log Message:
-----------
Pre-release preparations and bugfixes.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Play/Play.ml
trunk/Toss/Server/DB.ml
trunk/Toss/Server/DB.mli
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/profile.html
trunk/Toss/www/create.xml
trunk/Toss/www/develop.xml
trunk/Toss/www/docs.xml
trunk/Toss/www/examples.xml
trunk/Toss/www/img/Breakthrough.png
trunk/Toss/www/img/Checkers.png
trunk/Toss/www/img/Connect4.png
trunk/Toss/www/img/Gomoku.png
trunk/Toss/www/img/Pawn-Whopping.png
trunk/Toss/www/img/Tic-Tac-Toe.png
trunk/Toss/www/index.xml
trunk/Toss/www/navigation.xml
Removed Paths:
-------------
trunk/Toss/www/gui_interface.xml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Arena/Arena.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -59,8 +59,6 @@
history : (move * float option) list ;
}
-
-
let zero_loc = { payoff = Formula.Const 0. ;
view = (Formula.And [], []);
heur = [];
@@ -81,8 +79,14 @@
cur_loc = 0 ;
history = [] ;
}
-
+let equal_state gs1 gs2 =
+ if gs1 == gs2 then true else
+ if gs1.time <> gs2.time || gs1.cur_loc <> gs2.cur_loc ||
+ gs1.history <> gs2.history then false else
+ Structure.equal gs1.struc gs2.struc
+
+
(* -------------------- PARSER HELPER ------------------------------ *)
let matching_of_names (game, state) rname match_str =
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Arena/Arena.mli 2012-02-05 01:24:07 UTC (rev 1663)
@@ -55,6 +55,7 @@
}
val empty_state : game * game_state
+val equal_state : game_state -> game_state -> bool
(** Make a move in a game. *)
val make_move : move -> game * game_state -> game * game_state
Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Play/Play.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -69,6 +69,11 @@
(Aux.gettimeofday() -. !timeout) msg;
(t, mvs)
+let equal_moves m1 m2 =
+ if m1 == m2 then true else
+ let (mv1, gs1), (mv2, gs2) = m1, m2 in
+ if mv1 <> mv2 then false else Arena.equal_state gs1 gs2
+
(* Maximax unfold upto depth and choose move. *)
let maximax_unfold_choose ?(check_stable=3) count game state heur =
let ab = Heuristic.is_constant_sum heur in (* TODO: payoffs as well! *)
@@ -87,7 +92,7 @@
let rec ord_sub = function
| ([], _) -> true
| (x :: xs, []) -> false
- | (x :: xs, y :: ys) when x = y -> ord_sub (xs, ys)
+ | (x :: xs, y :: ys) when equal_moves x y -> ord_sub (xs, ys)
| (x :: xs, y :: ys) -> ord_sub (x :: xs, ys) in
let nbr mv = List.length (List.filter (fun m -> ord_sub (mv,m)) last_mvs) in
let mvs_votes = List.map (fun m -> (m, nbr m)) last_mvs in
Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Server/DB.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -113,8 +113,9 @@
let get_table dbfile ?(select="") tbl =
fst (apply_cmd dbfile select ("select * from " ^ tbl))
-let count_table dbfile ?(select="") tbl =
- let (rows, _) = apply_cmd dbfile select ("select count(*) from " ^ tbl) in
+let max_in_table ~field dbfile ?(select="") tbl =
+ let (rows, _) =
+ apply_cmd dbfile select ("select max(" ^ field ^ ") from " ^ tbl) in
int_of_string (List.hd rows).(0)
let insert_table dbfile tbl schm vals =
Modified: trunk/Toss/Server/DB.mli
===================================================================
--- trunk/Toss/Server/DB.mli 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Server/DB.mli 2012-02-05 01:24:07 UTC (rev 1663)
@@ -15,7 +15,7 @@
val get_table : string -> ?select : string -> string -> string array list
-val count_table : string -> ?select : string -> string -> int
+val max_in_table : field:string -> string -> ?select : string -> string -> int
val insert_table : string -> string -> string -> string list -> unit
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Server/ReqHandler.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -503,7 +503,7 @@
let app_plays plays g = plays ^ "@" ^ (list_plays g uid) in
let plays = List.fold_left app_plays "" !DB.tGAMES in
uid ^ "@" ^ name ^ plays in
- let get_free_id () = (DB.count_table dbFILE "cur_states") + 1 in
+ let get_free_id() = (DB.max_in_table ~field:"playid" dbFILE "cur_states")+1 in
let db_cur_insert game p1 p2 pid move toss loc info svg_str =
DB.insert_table dbFILE "cur_states"
"playid, game, player1, player2, move, toss, loc, info, svg"
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Server/Server.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -26,7 +26,8 @@
let rec accept_sock n s =
if n < 1 then failwith "Accept Sock Failed" else
- try Unix.accept s with _ -> accept_sock (n-1) s
+ try Unix.accept s with _ ->
+ if n mod 3 = 0 then Unix.sleep 1; accept_sock (n-1) s
let start_server f port addr_s =
(* Unix.establish_server f (Unix.ADDR_INET (get_inet_addr (addr_s), port))
@@ -39,7 +40,7 @@
Unix.listen sock 9; (* maximally 9 pending requests *)
let continue = ref true in
while !continue do
- let (cl_sock, _) = accept_sock 99 sock in
+ let (cl_sock, _) = accept_sock 98 sock in
continue := f (Unix.in_channel_of_descr cl_sock)
(Unix.out_channel_of_descr cl_sock);
Unix.close cl_sock;
Modified: trunk/Toss/Solver/Assignments.ml
===================================================================
--- trunk/Toss/Solver/Assignments.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Solver/Assignments.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -380,7 +380,7 @@
and complement_map_rev elems acc = function
| ([], []) -> acc
- | ([], _) -> failwith "more assigned elements as elements at all"
+ | ([], _) -> failwith "more assigned elements than elements at all"
| (e::es, []) -> complement_map_rev elems ((e, Any)::acc) (es, [])
| (e1 :: es, (e2, a) :: ms) ->
match compare_elems e1 e2 with
@@ -426,9 +426,9 @@
| (Empty, _) | (_, Any) -> Empty
| (Any, a) -> complement elems a
| (a, Empty) -> a
- | (FO (v1, map1), FO (v2, map2)) when v1 = v2 ->
+ | (FO (`FO v1, map1), FO (`FO v2, map2)) when String.compare v1 v2 = 0 ->
let resm = List.rev (complement_join_map_rev elems [] (map1, map2)) in
- if resm = [] then Empty else FO (v1, resm)
+ if resm = [] then Empty else FO (`FO v1, resm)
| (FO _, FO _) -> join aset (complement elems a) (* TODO: improve! *)
| _ -> join aset (complement elems a)
@@ -454,9 +454,10 @@
(* Helper function for assignment creation below. *)
let make_assign vl tuple =
+ if Array.length vl <> Array.length tuple then failwith "make_assign <>length";
let compare_asvs (v1, e1) (v2, e2) =
let c = compare_vars (v1 :> Formula.var) (v2 :> Formula.var) in
- if c != 0 then -c else compare_elems e1 e2 in
+ if c != 0 then -c else compare_elems e1 e2 in
List.sort compare_asvs (Array.to_list (Aux.array_combine vl tuple))
(* Create an assignment set out of a list of variables and assigned tuples. *)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/Solver/Solver.ml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -303,7 +303,7 @@
let app_re = function Fun _ -> raise Not_found | x -> x in
try
let _ = FormulaMap.map_to_atoms_full app_rel app_re phi in
- let rs = Aux.unique_sorted !rels in
+ let rs = Aux.unique_sorted ~cmp:String.compare !rels in
if !debug_level > 1 then
print_endline ("F: " ^ (Formula.str phi) ^" "^ (String.concat ", " rs));
Some rs
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/WebClient/Login.js 2012-02-05 01:24:07 UTC (rev 1663)
@@ -166,8 +166,8 @@
}
}
-function login_onenter () {
- if (window.event && window.event.keyCode == 13) { login() }
+function login_onenter (ev) {
+ if (ev && ev.keyCode == 13) { login() }
}
// Logout
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/WebClient/Main.js 2012-02-05 01:24:07 UTC (rev 1663)
@@ -202,7 +202,7 @@
par.completed_shown = false;
} else {
par.closed_play_list.style.display = "block";
- par.learn_button.style.display = "inline";
+ //par.learn_button.style.display = "inline"; skip for now
par.completed_button.innerHTML = "Completed games (Hide)";
par.completed_shown = true;
}
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/WebClient/Style.css 2012-02-05 01:24:07 UTC (rev 1663)
@@ -202,6 +202,7 @@
}
.loginput {
+ font-size: 0.8em;
border-color: #fff1d4;
border-radius: 4px;
-moz-border-radius: 4px;
@@ -234,6 +235,7 @@
}
.play_select {
+ display: none;
position: relative;
top: -0.1em;
color: #260314;
@@ -249,12 +251,14 @@
}
.play_select_opt {
+ display: none;
color: #260314;
background-color: #fff1d4;
border-width: 0px;
}
.play_learn {
+ display: none;
color: #260314;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
font-size: 0.8em;
@@ -297,6 +301,7 @@
}
#loginbt {
+ font-size: 0.8em;
position: relative;
top: -2px;
font-weight: bold;
@@ -336,13 +341,13 @@
#login2 {
position: absolute;
top: 0px;
- left: 18em;
+ left: 17em;
}
#login3 {
position: absolute;
top: 0.3em;
- left: 28em;
+ left: 27em;
}
#logo {
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/WebClient/index.html 2012-02-05 01:24:07 UTC (rev 1663)
@@ -35,12 +35,12 @@
<form id="loginform" style="display: inline;" action="">
<div id="login1">
<p class="loginsmall">Username:</p>
-<input class="loginput" type="text" name="username" id="username" size="15" />
+<input class="loginput" type="text" name="username" id="username" size="12" />
</div>
<div id="login2">
<p class="loginsmall">Password:</p>
-<input class="loginput" type="password" name="password" id="password" size="15"
- onkeypress="login_onenter()" />
+<input class="loginput" type="password" name="password" id="password" size="12"
+ onkeypress="login_onenter(event)" />
</div>
<div id="login3">
<p class="loginchk">
@@ -177,6 +177,15 @@
<div id="news">
<h3>News</h3>
<ul id="welcome-list-news" class="welcome-list">
+<li><b>04/02/12</b> Definitions use play history: new Chess toss file</li>
+<li><b>02/02/12</b> Improved stand-alone JS interface with menhirLib</li>
+<li><b>31/01/12</b> First stand-alone JS interface (with js_of_ocaml)</li>
+<li><b>22/01/12</b> Learning Connect4 and Gomoku from videos</li>
+<li><b>21/01/12</b> Learning Breakthrough and Pawn-Whopping videos</li>
+<li><b>17/01/12</b> Integrating game learning logic and video stuff</li>
+<li><b>06/01/12</b> Parametrized grid detection for video</li>
+<li><b>28/12/11</b> Game video recognition improved with Hough lines</li>
+<li><b>10/12/11</b> Starting work on game recognition from video</li>
<li><b>24/10/11</b> Learning games from examples in web interface</li>
<li><b>19/10/11</b> Games learning engine and first buttons in the UI</li>
<li><b>14/09/11</b> Simple editing of games added to web interface</li>
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/WebClient/profile.html 2012-02-05 01:24:07 UTC (rev 1663)
@@ -25,11 +25,11 @@
<form id="loginform" style="display: inline;" action="">
<div id="login1">
<p class="loginsmall">Username:</p>
-<input class="loginput" type="text" name="username" id="username" size="15" />
+<input class="loginput" type="text" name="username" id="username" size="12" />
</div>
<div id="login2">
<p class="loginsmall">Password:</p>
-<input class="loginput" type="password" name="password" id="password" size="15"
+<input class="loginput" type="password" name="password" id="password" size="12"
onkeypress="login_onenter()" />
</div>
<div id="login3">
Modified: trunk/Toss/www/create.xml
===================================================================
--- trunk/Toss/www/create.xml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/www/create.xml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -12,132 +12,6 @@
<link id="create" href="/create.html">Create</link>
</history>
-
- <section title="Two Ways to Create a New Game" lang="en">
- <par>When you are done playing the games already defined in Toss, it's
- time to start the real fun – create your own game!
- There are two ways to create a game in Toss.</par>
- <itemize>
- <item>You can use the GUI to edit and create games.</item>
- <item>You can edit the .toss files directly.</item>
- </itemize>
- <par>If you plan to make small changes or an easy experiment, the GUI might
- be the better option. For larger or completely new games, it is more
- convenient to edit the files in your favorite text editor.</par>
- </section>
-
- <section title="Zwei Methoden um ein neues Spiel in Toss zu erzeugen"
- lang="de">
- <par>Wenn man genug online gespielt hat, kann man mit dem wirklichen
- Spass in Toss anfangen und ein neues Spiel erschaffen. Zwei Wege
- kann man dazu nutzen.</par>
- <itemize>
- <item>Die Toss GUI erlaubt es, Spiele zu erzeugen.</item>
- <item>Die .toss Files kann man auch direkt editieren.</item>
- </itemize>
- <par>Um kleine Änderungen zu machen oder ein einfaches Beispiel zu
- definieren kann man die GUI benutzen. Um kompliziertere Spiele zu
- erzeugen und ganz neue Ideen zu realisieren ist es bequemer, die .toss
- Files direkt in einem Editor zu bearbeiten.</par>
- </section>
-
- <section title="Dwa Sposoby Tworzenia Nowych Gier w Tossie" lang="pol">
- <par>Gdy już znudzi Ci się granie online, czas na prawdziwą zabawę
- z Tossem – stwórz swoją własną grę! W Tossie są dwa sposoby
- na tworzenie własnych gier.</par>
- <itemize>
- <item>Można użyć interfejsu graficznego Tossa (GUI).</item>
- <item>Możliwa jest też bezpośrednia edycja plików .toss.</item>
- </itemize>
- <par>Do małych zmian i prostych eksperymentów wystarczy użycie GUI,
- natomiast dla nowych i bardziej skomplikowanych gier wygodniej jest
- bezpośrednio edytować pliki .toss w edytorze tekstu.</par>
- </section>
-
- <section title="Deux Façons de Créer un Nouveau Jeu" lang="fr">
- <par>Si vous avez fini de jouer les jeux déjà définis dans Toss,
- il est temps de commencer le vrai plaisir – créez votre propre jeu!
- Il y a deux façons de créer un jeu dans Toss.</par>
- <itemize>
- <item>Vous pouvez utiliser l'interface graphique pour éditer
- et créer des jeux.</item>
- <item>Vous pouvez éditer les fichiers .toss directement.</item>
- </itemize>
- <par>Si vous prévoyez de faire de petits changements ou une jeu facile,
- l'interface graphique pourrait être la meilleure option. Pour les
- grandes ou complètement nouveaux jeux, il est plus commode de modifier
- les fichiers dans votre éditeur de texte favori.</par>
- </section>
-
-
- <section title="Creating Games the in the Toss GUI" lang="en">
- <par>To start the Toss GUI do the following.</par>
- <itemize>
- <item><em>Download</em> Toss from the
- <a href="http://sourceforge.net/project/showfiles.php?group_id=115606">
- SourceForge Download Page</a>.</item>
- <item><em>Run Toss</em> by clicking <em>Toss.py</em>.
- You can start by opening a file from the <em>examples</em>
- directory.</item>
- </itemize>
- <par>When you have the GUI running, we recommend that you watch the
- <a href="http://vimeo.com/10110495">Toss Tutorial</a> below, which
- shows all the steps needed to define a simple game in Toss and explains
- several other features.<br/></par>
- <par><br/><toss-video/></par>
- </section>
- <section title="Spiele in das Toss GUI Erzeugen" lang="de">
- <par>Um die Toss GUI zu starten, muss man:</par>
- <itemize>
- <item>Toss <em>runterladen</em> von der
- <a href="http://sourceforge.net/project/showfiles.php?group_id=115606">
- SourceForge Seite</a>.</item>
- <item><em>Toss ausführen</em>, indem man auf <em>Toss.py</em> clickt.
- Man kann am Anfang einer der Files im <em>examples</em> Verzeichnis
- öffnen.</item>
- </itemize>
- <par>Wenn die GUI schon läuft, kann man am besten das
- <a href="http://vimeo.com/10110495">Toss Tutorial</a> unten angucken,
- wo gezeigt wird, wie man ein einfaches Spiel in Toss vollständig
- definiert und auch andere Features erklärt sind.<br/></par>
- <par><br/><toss-video/></par>
- </section>
- <section title="Tworzenie Gier w Interfejsie Graficznym Tossa" lang="pol">
- <par>Aby uruchomić interfejs graficzny Tossa:</par>
- <itemize>
- <item><em>Ściągnij</em> Tossa ze
- <a href="http://sourceforge.net/project/showfiles.php?group_id=115606">
- strony SourceForge</a>.</item>
- <item><em>Uruchom Tossa</em> klikając na <em>Toss.py</em>.
- Na początek najlepiej otworzyć przykład z katalogu <em>examples</em>.
- </item>
- </itemize>
- <par>Gdy GUI Tossa już działa, polecamy obejrzeć i wykonać poniższy
- <a href="http://vimeo.com/10110495">Toss Tutorial</a>.
- Pokazane tam są wszystkie kroki do zdefiniowania prostej gry w Tossie,
- a także wyjaśnione niektóre bardziej zaawansowane możliwości.<br/></par>
- <par><br/><toss-video/></par>
- </section>
- <section title="Créer des Jeux dans l'Interface Graphique de Toss" lang="fr">
- <par>Pour démarrer l'interface graphique de Toss, procédez comme suit.</par>
- <itemize>
- <item><em>Téléchargez</em> Toss sur la
- <a href="http://sourceforge.net/project/showfiles.php?group_id=115606">
- SourceForge Télécharger Site</a>.</item>
- <item><em>Exécutez Toss</em> en cliquant <em>Toss.py</em>.
- Vous pouvez commencer par l'ouverture d'un fichier dans du répertoire
- <em>examples</em>.</item>
- </itemize>
- <par>
- Lorsque vous avez le bon GUI, nous vous recommandons de regarder le
- <a href="http://vimeo.com/10110495">Toss Tutoriel</a> ci-dessous,
- qui montre toutes les étapes nécessaires pour définir un jeu simple
- en Toss et explique plusieurs autres fonctions.
- <br/></par>
- <par><br/><toss-video/></par>
- </section>
-
-
<section title="Creating Games in your Text Editor" lang="en">
<par>For larger games, we find it easier to edit them in text
form than from the GUI. To understand the meaning of the fields
@@ -148,9 +22,9 @@
simply edit the .toss file, maybe starting with one of these.
</par>
<itemize>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss?revision=1349">Breakthrough</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss?revision=1349">Chess</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss?revision=1349">Tic-Tac-Toe</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item>
</itemize>
</section>
<section title="Spiele in Text Form erschaffen" lang="de">
@@ -165,9 +39,9 @@
bearbeiten, mit einer des folgenden kann man gut anfangen.
</par>
<itemize>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss?revision=1349">Breakthrough</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss?revision=1349">Chess</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss?revision=1349">Tic-Tac-Toe</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item>
</itemize>
</section>
<section title="Tworzenie Gier w Edytorze Tekstu" lang="pol">
@@ -181,9 +55,9 @@
edytować pliki .toss, być może zaczynając od jednego z tych.
</par>
<itemize>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss?revision=1349">Breakthrough</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss?revision=1349">Chess</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss?revision=1349">Tic-Tac-Toe</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item>
</itemize>
</section>
<section title="La Création de Jeux dans l'Éditeur de Texte" lang="fr">
@@ -197,9 +71,9 @@
éditer le fichier .toss, peut-être en commençant par l'un de ces.
</par>
<itemize>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss?revision=1349">Breakthrough</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss?revision=1349">Chess</a></item>
- <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss?revision=1349">Tic-Tac-Toe</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss">Breakthrough</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Chess.toss">Chess</a></item>
+ <item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Tic-Tac-Toe.toss">Tic-Tac-Toe</a></item>
</itemize>
</section>
Modified: trunk/Toss/www/develop.xml
===================================================================
--- trunk/Toss/www/develop.xml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/www/develop.xml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -40,10 +40,6 @@
</item>
<item>In the Toss directory run <em>make</em> and check that
it succeeds.</item>
- <item>Go through our <a href="/ocaml.html">Mini OCaml Tutorial</a> to
- see how we organise OCaml code in general.</item>
- <item>In the <a href="/codebasics.html">Toss Code Basics Tutorial</a> you
- will learn to code basic operations with Toss.</item>
</itemize>
</section>
<section title="Vorbereitung" lang="de">
@@ -75,10 +71,6 @@
</item>
<item>Führe <em>make</em> aus im Toss Verzeichnis und überprüfe,
dass es erfolgreich funktioniert hat.</item>
- <item>Unser <a href="/ocaml.html">Mini OCaml Tutorial</a> zeigt,
- wie wir OCaml Code organisieren.</item>
- <item>Das <a href="/codebasics.html">Toss Code Basics Tutorial</a> zeigt,
- wie man einfache Toss-Funktionen ausführt.</item>
</itemize>
</section>
<section title="Przygotowanie" lang="pol">
@@ -109,10 +101,6 @@
</item>
<item>W katalogu Toss uruchom <em>make</em> i sprawdź czy dobrze
zadziałało.</item>
- <item>Nasz <a href="/ocaml.html">Mini OCaml Tutorial</a> pokazuje,
- jak organizujemy kod OCamla.</item>
- <item><a href="/codebasics.html">Toss Code Basics Tutorial</a> pokazuje
- podstawowe wywołania funkcji Tossa.</item>
</itemize>
</section>
<section title="Préparation" lang="fr">
@@ -141,10 +129,48 @@
</item>
<item>Dans le répertoire Toss exécuter <em>make</em> et vérifier
que c'est bien.</item>
+ </itemize>
+ </section>
+
+
+ <section title="Tutorials" lang="en">
+ <itemize>
+ <item>Visit <a href="http://try.ocamlpro.com">try.ocamlpro.com</a>
+ to refresh your basic OCaml skills.</item>
+ <item>Go through our <a href="/ocaml.html">Mini OCaml Tutorial</a> to
+ see how we organise OCaml code in general.</item>
+ <item>In the <a href="/codebasics.html">Toss Code Basics Tutorial</a> you
+ will learn to code basic operations with Toss.</item>
+ </itemize>
+ </section>
+ <section title="Tutorials" lang="de">
+ <itemize>
+ <item>Besuche <a href="http://try.ocamlpro.com">try.ocamlpro.com</a>
+ um die Grundlagen von OCaml zu lernen.</item>
+ <item>Unser <a href="/ocaml.html">Mini OCaml Tutorial</a> zeigt,
+ wie wir OCaml Code organisieren.</item>
+ <item>Das <a href="/codebasics.html">Toss Code Basics Tutorial</a> zeigt,
+ wie man einfache Toss-Funktionen ausführt.</item>
+ </itemize>
+ </section>
+ <section title="Tutoriale" lang="pol">
+ <itemize>
+ <item>Na <a href="http://try.ocamlpro.com">try.ocamlpro.com</a>
+ możesz szybko nauczyć się OCamla na przykładach.</item>
+ <item>Nasz <a href="/ocaml.html">Mini OCaml Tutorial</a> pokazuje,
+ jak organizujemy kod OCamla.</item>
+ <item><a href="/codebasics.html">Toss Code Basics Tutorial</a> pokazuje
+ podstawowe wywołania funkcji Tossa.</item>
+ </itemize>
+ </section>
+ <section title="Tutoriaux" lang="fr">
+ <itemize>
+ <item>Visitez <a href="http://try.ocamlpro.com">try.ocamlpro.com</a>
+ pour actualiser vos compétences en OCaml.</item>
<item>Notre <a href="/ocaml.html">Mini OCaml Tutorial</a> montre
- comment nous organiser le code OCaml.</item>
+ comment nous organiser le code OCaml.</item>
<item>Le <a href="/codebasics.html">Toss Code Basics Tutorial</a> montre
- comment on utilise les fonctions de base Toss.</item>
+ comment on utilise les fonctions de base Toss.</item>
</itemize>
</section>
Modified: trunk/Toss/www/docs.xml
===================================================================
--- trunk/Toss/www/docs.xml 2012-02-04 01:07:09 UTC (rev 1662)
+++ trunk/Toss/www/docs.xml 2012-02-05 01:24:07 UTC (rev 1663)
@@ -14,28 +14,19 @@
<section title="Using Toss" lang="en">
<par>If you want to learn how to use Toss to create games,
- go to the <a href="create.html">Create Games</a> page
- or just watch the video tutorial below to get started.<br/></par>
- <par><br/><toss-video/></par>
+ go to the <a href="create.html">Create Games</a> page.</par>
</section>
<section title="Toss Benutzen" lang="de">
<par>Um zu lernen, wie man Toss benutzt um neue Spiele zu erschaffen,
- besuche die <a href="create.html">Neue Spiele Erzeugen</a> Seite oder
- fange mit dem Video Tutorial unten an.<br/></par>
- <par><br/><toss-video/></par>
+ besuche die <a href="create.html">Neue Spiele Erzeugen</a> Seite.</par>
</section>
<section title="Używanie Tossa" lang="pol">
<par>Żeby nauczyć się tworzyć gry w Tossie najlepiej odwiedzić stronę
- o <a href="create.html">Tworzeniu Nowych Gier</a> albo szybko obejrzeć
- poniższy tutorial.<br/></par>
- <par><br/><toss-video/></par>
+ o <a href="create.html">Tworzeniu Nowych Gier</a>.</par>
</section>
<section title="Utilisation de Toss" lang="fr">
<par>Si vous voulez apprendre à utiliser Toss pour créer des jeux,
- aller à la <a href="create.html">Créez des Jeux</a> site ou
- simplement regarder la vidéo tutoriel ci-dessous pour commencer.
- <br/></par>
- <par><br/><toss-video/></par>
+ aller à la <a href="create.html">Créez des Jeux</a> site.</par>
</section>
@@ -43,34 +34,26 @@
<par>The Toss Design and Specification reference is an evolving document
in which we try to describe the high-level mathematical model of Toss
and the main ideas used in the implementation. The document is best
- viewed as <a href="reference/reference.pdf">reference.pdf</a> but
- a <a href="reference/">html version...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-05 11:15:36
|
Revision: 1664
http://toss.svn.sourceforge.net/toss/?rev=1664&view=rev
Author: lukstafi
Date: 2012-02-05 11:15:29 +0000 (Sun, 05 Feb 2012)
Log Message:
-----------
WebClient and JsHandler: worker-side Toss handler in JavaScript. AuxIO: single logging command working on both worker-side and window-side. To try the interface locally, start a browser with --allow-file-access-from-files.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Play/Move.ml
trunk/Toss/Server/GameSelection.ml
trunk/Toss/Server/JsHandler.ml
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/Local.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Play.js
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Formula/Aux.ml 2012-02-05 11:15:29 UTC (rev 1664)
@@ -772,14 +772,3 @@
) ELSE (
Str.global_replace (Str.regexp regexp) templ s
) ENDIF
-
-(* Display prominently a message and wait for user
- acknowledgement. Intended mostly for diagnostic purposes. *)
-let alert s =
- IFDEF JAVASCRIPT THEN (
- let js_alert = Js.Unsafe.variable "alert" in
- Js.Unsafe.fun_call js_alert [|Js.Unsafe.inject (Js.string s)|]
- ) ELSE (
- prerr_endline (s ^ " -- PRESS [ENTER]");
- ignore (read_line ())
- ) ENDIF
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Formula/Aux.mli 2012-02-05 11:15:29 UTC (rev 1664)
@@ -369,7 +369,3 @@
except that all substrings of [s] that match [regexp] have been
replaced by [templ]. *)
val replace_regexp : regexp:string -> templ:string -> string -> string
-
-(** Display prominently a message and wait for user
- acknowledgement. Intended mostly for diagnostic purposes. *)
-val alert : string -> unit
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-05 11:15:29 UTC (rev 1664)
@@ -119,3 +119,36 @@
(Unix.error_message e) f s;
(fun () -> f_in x)
) ENDIF
+
+IFDEF JAVASCRIPT THEN
+(* For some reason, it is difficult to check if a variable is
+ defined... *)
+let is_worker =
+ Js.to_bool (Js.Unsafe.eval_string "typeof window == 'undefined'")
+
+let self =
+ if is_worker then Js.Unsafe.variable "self"
+ else Js.Unsafe.variable "window"
+
+let postMessage = Js.Unsafe.variable "postMessage"
+
+let worker_log s =
+ ignore (Js.Unsafe.call postMessage self
+ [|Js.Unsafe.inject (Js.string s)|])
+
+(* [Firebug.console##log (s)] forces unconditional access to the "window"
+ variable. *)
+let console_log s =
+ let console = Js.Unsafe.get self (Js.string "console") in
+ let c_log = Js.Unsafe.get console (Js.string "log") in
+ Js.Unsafe.call c_log console [|Js.Unsafe.inject (Js.string s)|]
+
+ENDIF
+
+let log s =
+ IFDEF JAVASCRIPT THEN (
+ if is_worker then worker_log s else console_log s
+ ) ELSE (
+ print_endline s; flush stdout
+ ) ENDIF
+
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-05 11:15:29 UTC (rev 1664)
@@ -37,3 +37,7 @@
(2) on single-threaded servers handling calls (older Toss versions),
you have to collect the results, even on Exception in caller *)
val toss_call : int * string -> ('a -> 'b) -> 'a -> (unit -> 'b)
+
+(** Output a string in a manner visible to the programmer but not
+ obtrusive to the GUI user. *)
+val log : string -> unit
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Play/Move.ml 2012-02-05 11:15:29 UTC (rev 1664)
@@ -39,9 +39,12 @@
Aux.concat_map
(fun (label,next_loc) ->
let rule = List.assoc label.Arena.lb_rule rules in
+ AuxIO.log ("gen_moves: matchings for "^label.Arena.lb_rule);
List.map (fun emb -> label,next_loc,emb)
(ContinuousRule.matches model rule))
loc.Arena.moves in
+ AuxIO.log ("gen_moves: found "^string_of_int (List.length matchings)
+ ^" matchings.");
if matchings = [] then [| |]
else (
(* generating the grid *)
@@ -117,7 +120,11 @@
let loc = game.Arena.graph.(s.Arena.cur_loc) in
let moving = select_moving loc in
let get_moves pl =
- let m = gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc.(pl) in
+ AuxIO.log ("Move.list_moves: before getting moves for player "^
+ string_of_int pl);
+ let m =
+ gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc.(pl) in
+ AuxIO.log ("Move.list_moves: before generating models for the moves");
(gen_models_list game.Arena.rules s s.Arena.time m) in
Array.of_list (List.concat (
List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
Modified: trunk/Toss/Server/GameSelection.ml
===================================================================
--- trunk/Toss/Server/GameSelection.ml 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Server/GameSelection.ml 2012-02-05 11:15:29 UTC (rev 1664)
@@ -1,3 +1,5 @@
+(* 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 *)
@@ -21,7 +23,6 @@
Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
let compile_game_data game_name game_str =
- Aux.alert ("Preparing "^game_name^"...");
let (game, game_state as game_with_state) =
ArenaParser.parse_game_state Lexer.lex (Lexing.from_string game_str) in
let adv_ratio =
@@ -1823,14 +1824,16 @@
\"
")
-let games = ref
+let predef_games =
[
- compile_game_data "Breakthrough" breakthrough_str;
- compile_game_data "Checkers" checkers_str;
- compile_game_data "Chess" chess_str;
- compile_game_data "Connect4" connect4_str;
- compile_game_data "Entanglement" entanglement_str;
- compile_game_data "Gomoku" gomoku_str;
- compile_game_data "Pawn-Whopping" pawn_whopping_str;
- compile_game_data "Tic-Tac-Toe" tictactoe_str;
+ "Breakthrough", breakthrough_str;
+ "Checkers", checkers_str;
+ "Chess", chess_str;
+ "Connect4", connect4_str;
+ "Entanglement", entanglement_str;
+ "Gomoku", gomoku_str;
+ "Pawn-Whopping", pawn_whopping_str;
+ "Tic-Tac-Toe", tictactoe_str;
]
+
+let games = ref [compile_game_data "Tic-Tac-Toe" tictactoe_str]
Modified: trunk/Toss/Server/JsHandler.ml
===================================================================
--- trunk/Toss/Server/JsHandler.ml 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/Server/JsHandler.ml 2012-02-05 11:15:29 UTC (rev 1664)
@@ -27,11 +27,55 @@
let js_object = Js.Unsafe.variable "Object"
let js_any = Js.Unsafe.inject
-let js_handler = Js.Unsafe.variable "LOCAL"
+(* For some reason, it is difficult to check if a variable is
+ defined... *)
+let is_worker =
+ Js.to_bool (Js.Unsafe.eval_string "typeof window == 'undefined'")
+
+
+let self =
+ if is_worker then Js.Unsafe.variable "self"
+ else Js.Unsafe.variable "window"
+
+let js_handler = jsnew js_object ()
let set_handle name f =
- Js.Unsafe.set js_handler (js name) (Js.wrap_callback f)
+ 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
+(* In case the handler is used as Web Worker: *)
+let postMessage = Js.Unsafe.variable "postMessage"
+
+(* TODO: build records directly, using js_of_ocaml in a type safe
+ manner: probably creating an OCaml object. *)
+let build_js_record fields =
+ let record = jsnew js_object () in
+ List.iter (fun (field, value) ->
+ Js.Unsafe.set record (js field) value) fields;
+ record
+
+let onmessage event =
+ AuxIO.log ("worker received "^of_js event##data##fname);
+ (*Firebug.console##log_4 ("worker received fname=", event##data##fname,
+ "; args=", event##data##args);*)
+ let fname = event##data##fname in
+ let args = event##data##args in
+ let handle = Js.Unsafe.get js_handler fname in
+ let result =
+ Js.Unsafe.fun_call handle (Js.to_array args) in
+ let response =
+ build_js_record ["fname", fname; "result", result] in
+ Js.Unsafe.call postMessage self [|js_any response|]
+
+let _ = Js.Unsafe.set self (js"onmessage") onmessage
+
+let test_handle s =
+ AuxIO.log ("Testing "^of_js s);
+ js ("Now " ^ of_js s ^ " tested")
+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
@@ -50,6 +94,7 @@
let struc = state.Arena.struc in
let get_pos e =
Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
+ AuxIO.log "js_of_game_state: Preparing game elements...";
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
@@ -65,6 +110,7 @@
elems) in
(* rels are arrays of element names, with additional "name" field *)
let num = Js.number_of_float in
+ AuxIO.log "js_of_game_state: Preparing game relations...";
let rels = Array.of_list
(Aux.concat_map
(fun (rel, _) ->
@@ -85,6 +131,7 @@
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 rels);
+ AuxIO.log "js_of_game_state: Preparing game moves...";
if !cur_all_moves <> [||] then
Js.Unsafe.set info_obj (js"moves")
(Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
@@ -100,16 +147,31 @@
Js.Unsafe.set result (js player_name) (Js.float payoff))
payoffs;
Js.Unsafe.set info_obj (js"result") result);
+ AuxIO.log "js_of_game_state: Game prepared. Sending...";
info_obj
let new_play game_name pl1 pl2 =
(* players are currently not used by [JsHandler] *)
- let game_data = List.assoc (of_js game_name) !GameSelection.games in
+ let game_name = of_js game_name in
+ let game_loaded = List.mem_assoc game_name !GameSelection.games in
+ if game_loaded
+ then AuxIO.log ("new_play: "^game_name^" already loaded.")
+ else AuxIO.log ("new_play: loading "^game_name^"...");
+ let game_data =
+ try List.assoc game_name !GameSelection.games
+ with Not_found ->
+ let game_data = compile_game_data game_name
+ (List.assoc game_name GameSelection.predef_games) in
+ games := game_data :: !games;
+ snd game_data in
+ if not game_loaded then
+ AuxIO.log ("new_play: "^game_name^" loaded.");
let game, state = game_data.game_state in
cur_game := game_data;
play_states := [state];
cur_all_moves := Move.list_moves game state;
cur_move := 0;
+ AuxIO.log ("new_play ("^game_name^"): calling js_of_game_state.");
js_of_game_state game state
let _ = set_handle "new_play" new_play
@@ -124,21 +186,23 @@
let _ = set_handle "prev_move" preview_move
-let make_move move_id cont =
+let make_move move_id =
+ let move_id = int_of_float (Js.to_float move_id) in
+ AuxIO.log ("make_move: move_id="^string_of_int move_id);
if !play_states = [] then Js.null
else
- let (p, m, n_state) =
- !cur_all_moves.(int_of_float (Js.to_float move_id)) in
+ let (p, m, n_state) = !cur_all_moves.(move_id) in
let game, _ = !cur_game.game_state in
play_states := n_state :: !play_states;
cur_all_moves := Move.list_moves game n_state;
cur_move := 0;
- Js.Unsafe.fun_call cont
- [|js_any (js_of_game_state game n_state)|]
+ Js.some (js_of_game_state game n_state)
let _ = set_handle "make_move" make_move
-let suggest player_name time cont =
+(* When called in a different thread, we can't call continuation. So
+ arrange to do it from "outside". *)
+let suggest player_name time =
(* We do not use the player name. *)
Random.self_init ();
let time = Js.to_float time in
@@ -163,7 +227,7 @@
(Js.number_of_float comp_started);
Js.Unsafe.set result (js"comp_ended")
(Js.number_of_float (Aux.gettimeofday ()));
- Js.Unsafe.fun_call cont [|js_any result|]
+ Js.some result
with Not_found -> Js.null
let _ = set_handle "suggest" suggest
Modified: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js 2012-02-05 01:24:07 UTC (rev 1663)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-05 11:15:29 UTC (rev 1664)
@@ -638,7 +638,9 @@
return res;
}
function caml_is_printable(c) { return +(c > 31 && c < 127); }
+function caml_js_eval_string () {return eval(arguments[0].toString());}
function caml_js_from_array(a) { return a.slice(1); }
+function caml_js_fun_call(f, args) { return f.apply(null, args.slice(1)); }
function caml_js_to_array(a) { return [0].concat(a); }
function caml_js_wrap_callback(f) {
var toArray = Array.prototype.slice;
@@ -892,4 +894,4 @@
if( y.fun ) { x.fun = y.fun; return 0; }
var i = y.length; while (i--) x[i] = y[i]; return 0;
}
@@ Diff output truncated at 100000 characters. @@
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-05 15:33:22
|
Revision: 1665
http://toss.svn.sourceforge.net/toss/?rev=1665&view=rev
Author: lukstafi
Date: 2012-02-05 15:33:16 +0000 (Sun, 05 Feb 2012)
Log Message:
-----------
Better handling of missing functions (the fix to probable js_of_ocaml bug).
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/Local.js
Added Paths:
-----------
trunk/Toss/WebClient/MissingFunctions.js
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-05 11:15:29 UTC (rev 1664)
+++ trunk/Toss/Makefile 2012-02-05 15:33:16 UTC (rev 1665)
@@ -5,7 +5,7 @@
WebClient/JsHandler.js: Server/JsHandler.byte
js_of_ocaml _build/$<
- cp _build/Server/JsHandler.js WebClient/JsHandler.js
+ cat WebClient/MissingFunctions.js _build/Server/JsHandler.js > WebClient/JsHandler.js
%.js: %.byte
js_of_ocaml _build/$<
Modified: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js 2012-02-05 11:15:29 UTC (rev 1664)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-05 15:33:16 UTC (rev 1665)
@@ -1,3 +1,57 @@
+// A bug in js_of_ocaml: it sometimes omits the functions below, which
+// belong to its runtmie.
+
+// Applies to code below this line:
+// Js_of_ocaml runtime support
+// http://www.ocsigen.org/js_of_ocaml/
+// Copyright (C) 2010 Jérôme Vouillon
+// Laboratoire PPS - CNRS Université Paris Diderot
+//
+// This program is free software; you can redistribute it and/or modify
+// it under the terms of the GNU Lesser General Public License as published by
+// the Free Software Foundation, with linking exception;
+// either version 2.1 of the License, or (at your option) any later version.
+//
+// This program is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU Lesser General Public License for more details.
+//
+// You should have received a copy of the GNU Lesser General Public License
+// along with this program; if not, write to the Free Software
+// Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+// Provides: caml_int64_bits_of_float const
+function caml_int64_bits_of_float (x) {
+ if (!isFinite(x)) {
+ if (isNaN(x)) return [255, 1, 0, 0xfff0];
+ return (x > 0)?[255,0,0,0x7ff0]:[255,0,0,0xfff0];
+ }
+ var sign = (x>=0)?0:0x8000;
+ if (sign) x = -x;
+ var exp = Math.floor(Math.LOG2E*Math.log(x)) + 1023;
+ if (exp <= 0) {
+ exp = 0;
+ x /= Math.pow(2,-1026);
+ } else {
+ x /= Math.pow(2,exp-1027);
+ if (x < 16) { x *= 2; exp -=1; }
+ if (exp == 0) { x /= 2; }
+ }
+ var k = Math.pow(2,24);
+ var r3 = x|0;
+ x = (x - r3) * k;
+ var r2 = x|0;
+ x = (x - r2) * k;
+ var r1 = x|0;
+ r3 = (r3 &0xf) | sign | exp << 4;
+ return [255, r1, r2, r3];
+}
+//Provides: caml_int64_to_bytes
+function caml_int64_to_bytes(x) {
+ return [x[3] >> 8, x[3] & 0xff, x[2] >> 16, (x[2] >> 8) & 0xff, x[2] & 0xff,
+ x[1] >> 16, (x[1] >> 8) & 0xff, x[1] & 0xff];
+}
// This program was compiled from OCaml by js_of_ocaml 1.0
function caml_raise_with_arg (tag, arg) { throw [0, tag, arg]; }
function caml_raise_with_string (tag, msg) {
Modified: trunk/Toss/WebClient/Local.js
===================================================================
--- trunk/Toss/WebClient/Local.js 2012-02-05 11:15:29 UTC (rev 1664)
+++ trunk/Toss/WebClient/Local.js 2012-02-05 15:33:16 UTC (rev 1665)
@@ -28,61 +28,6 @@
return (res_arr);
}
-// A bug in js_of_ocaml: it sometimes omits the functions below, which
-// belong to its runtmie.
-
-// Applies to code below this line:
-// Js_of_ocaml runtime support
-// http://www.ocsigen.org/js_of_ocaml/
-// Copyright (C) 2010 Jérôme Vouillon
-// Laboratoire PPS - CNRS Université Paris Diderot
-//
-// This program is free software; you can redistribute it and/or modify
-// it under the terms of the GNU Lesser General Public License as published by
-// the Free Software Foundation, with linking exception;
-// either version 2.1 of the License, or (at your option) any later version.
-//
-// This program is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU Lesser General Public License for more details.
-//
-// You should have received a copy of the GNU Lesser General Public License
-// along with this program; if not, write to the Free Software
-// Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-// Provides: caml_int64_bits_of_float const
-function caml_int64_bits_of_float (x) {
- if (!isFinite(x)) {
- if (isNaN(x)) return [255, 1, 0, 0xfff0];
- return (x > 0)?[255,0,0,0x7ff0]:[255,0,0,0xfff0];
- }
- var sign = (x>=0)?0:0x8000;
- if (sign) x = -x;
- var exp = Math.floor(Math.LOG2E*Math.log(x)) + 1023;
- if (exp <= 0) {
- exp = 0;
- x /= Math.pow(2,-1026);
- } else {
- x /= Math.pow(2,exp-1027);
- if (x < 16) { x *= 2; exp -=1; }
- if (exp == 0) { x /= 2; }
- }
- var k = Math.pow(2,24);
- var r3 = x|0;
- x = (x - r3) * k;
- var r2 = x|0;
- x = (x - r2) * k;
- var r1 = x|0;
- r3 = (r3 &0xf) | sign | exp << 4;
- return [255, r1, r2, r3];
-}
-//Provides: caml_int64_to_bytes
-function caml_int64_to_bytes(x) {
- return [x[3] >> 8, x[3] & 0xff, x[2] >> 16, (x[2] >> 8) & 0xff, x[2] & 0xff,
- x[1] >> 16, (x[1] >> 8) & 0xff, x[1] & 0xff];
-}
-
// ********************************************************************
// Web-Worker thread
Added: trunk/Toss/WebClient/MissingFunctions.js
===================================================================
--- trunk/Toss/WebClient/MissingFunctions.js (rev 0)
+++ trunk/Toss/WebClient/MissingFunctions.js 2012-02-05 15:33:16 UTC (rev 1665)
@@ -0,0 +1,54 @@
+// A bug in js_of_ocaml: it sometimes omits the functions below, which
+// belong to its runtmie.
+
+// Applies to code below this line:
+// Js_of_ocaml runtime support
+// http://www.ocsigen.org/js_of_ocaml/
+// Copyright (C) 2010 Jérôme Vouillon
+// Laboratoire PPS - CNRS Université Paris Diderot
+//
+// This program is free software; you can redistribute it and/or modify
+// it under the terms of the GNU Lesser General Public License as published by
+// the Free Software Foundation, with linking exception;
+// either version 2.1 of the License, or (at your option) any later version.
+//
+// This program is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU Lesser General Public License for more details.
+//
+// You should have received a copy of the GNU Lesser General Public License
+// along with this program; if not, write to the Free Software
+// Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+// Provides: caml_int64_bits_of_float const
+function caml_int64_bits_of_float (x) {
+ if (!isFinite(x)) {
+ if (isNaN(x)) return [255, 1, 0, 0xfff0];
+ return (x > 0)?[255,0,0,0x7ff0]:[255,0,0,0xfff0];
+ }
+ var sign = (x>=0)?0:0x8000;
+ if (sign) x = -x;
+ var exp = Math.floor(Math.LOG2E*Math.log(x)) + 1023;
+ if (exp <= 0) {
+ exp = 0;
+ x /= Math.pow(2,-1026);
+ } else {
+ x /= Math.pow(2,exp-1027);
+ if (x < 16) { x *= 2; exp -=1; }
+ if (exp == 0) { x /= 2; }
+ }
+ var k = Math.pow(2,24);
+ var r3 = x|0;
+ x = (x - r3) * k;
+ var r2 = x|0;
+ x = (x - r2) * k;
+ var r1 = x|0;
+ r3 = (r3 &0xf) | sign | exp << 4;
+ return [255, r1, r2, r3];
+}
+//Provides: caml_int64_to_bytes
+function caml_int64_to_bytes(x) {
+ return [x[3] >> 8, x[3] & 0xff, x[2] >> 16, (x[2] >> 8) & 0xff, x[2] & 0xff,
+ x[1] >> 16, (x[1] >> 8) & 0xff, x[1] & 0xff];
+}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-06 02:18:47
|
Revision: 1667
http://toss.svn.sourceforge.net/toss/?rev=1667&view=rev
Author: lukaszkaiser
Date: 2012-02-06 02:18:40 +0000 (Mon, 06 Feb 2012)
Log Message:
-----------
Final cleanups for 0.7 release.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Play/Move.ml
trunk/Toss/README
trunk/Toss/Toss.odocl
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Play.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/local.html
trunk/Toss/www/Publications/.cvsignore
trunk/Toss/www/Publications/Makefile
trunk/Toss/www/Publications/all.bib
trunk/Toss/www/Publications/index.xml
trunk/Toss/www/create.xml
trunk/Toss/www/develop.xml
trunk/Toss/www/index.xml
trunk/Toss/www/learn.xml
trunk/Toss/www/navigation.xml
trunk/Toss/www/play.xml
Added Paths:
-----------
trunk/Toss/run_server.sh
trunk/Toss/www/pub/aaai11_slides.pdf
Removed Paths:
-------------
trunk/Toss/toss
trunk/Toss/www/examples.xml
Property Changed:
----------------
trunk/Toss/www/Publications/
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-05 17:05:10 UTC (rev 1666)
+++ trunk/Toss/Makefile 2012-02-06 02:18:40 UTC (rev 1667)
@@ -10,10 +10,10 @@
%.js: %.byte
js_of_ocaml _build/$<
-RELEASE=0.6
+RELEASE=0.7
Release: TossServer doc
- rm -f *~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
- Language/*~ Server/*~ www/*~ WebClient/~
+ rm -f *~ MenhirLib/*~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
+ Learn/*~ Language/*~ Server/*~ www/*~ WebClient/~
make -C www/reference
make -C www
make -C .
@@ -26,6 +26,7 @@
mv toss_$(RELEASE)/_build/Toss.docdir toss_$(RELEASE)/www/code_doc
rm -rf toss_$(RELEASE)/_build toss_$(RELEASE)/gmon.out
rm -rf toss_$(RELEASE)/www/pub
+ rm -rf toss_$(RELEASE)/Learn/videos
zip -r toss_$(RELEASE).zip toss_$(RELEASE)
rm -rf toss_$(RELEASE)
@@ -51,8 +52,6 @@
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
OCAMLBUILDJS=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PPJS) \
$(OCB_LIBJS) $(OCB_CFLAG) $(OCB_LFLAG)
-OCAMLBUILDNOPP=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \
- $(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
FormulaINCSatINC=MenhirLib,Formula
FormulaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll
@@ -77,7 +76,7 @@
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
doc: caml_extensions/pa_let_try.cmo
- $(OCAMLBUILDNOPP) -Is +oUnit,+sqlite3,$(.INC) Toss.docdir/index.html
+ $(OCAMLBUILD) -Is +oUnit,+sqlite3,$(.INC) Toss.docdir/index.html
make -C www code_doc_link
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2012-02-05 17:05:10 UTC (rev 1666)
+++ trunk/Toss/Play/Move.ml 2012-02-06 02:18:40 UTC (rev 1667)
@@ -39,14 +39,10 @@
Aux.concat_map
(fun (label,next_loc) ->
let rule = List.assoc label.Arena.lb_rule rules in
- AuxIO.log ("gen_moves: matchings for "^label.Arena.lb_rule);
List.map (fun emb -> label,next_loc,emb)
- (ContinuousRule.matches model rule))
+ (ContinuousRule.matches model rule))
loc.Arena.moves in
- AuxIO.log ("gen_moves: found "^string_of_int (List.length matchings)
- ^" matchings.");
- if matchings = [] then [| |]
- else (
+ if matchings = [] then [| |] else (
(* generating the grid *)
Array.concat
(List.map (fun (label,next_loc,emb) ->
@@ -120,11 +116,7 @@
let loc = game.Arena.graph.(s.Arena.cur_loc) in
let moving = select_moving loc in
let get_moves pl =
- AuxIO.log ("Move.list_moves: before getting moves for player "^
- string_of_int pl);
- let m =
- gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc.(pl) in
- AuxIO.log ("Move.list_moves: before generating models for the moves");
+ let m = gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc.(pl) in
(gen_models_list game.Arena.rules s s.Arena.time m) in
Array.of_list (List.concat (
List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
Modified: trunk/Toss/README
===================================================================
--- trunk/Toss/README 2012-02-05 17:05:10 UTC (rev 1666)
+++ trunk/Toss/README 2012-02-06 02:18:40 UTC (rev 1667)
@@ -9,7 +9,7 @@
-- Installing dependencies under Ubuntu
Run the following in terminal:
- sudo apt-get install menhir libounit-ocaml-dev libsqlite3-ocaml-dev heirloom-mailx
+ sudo apt-get install menhir libounit-ocaml-dev libsqlite3-ocaml-dev libjs-of-ocaml-dev heirloom-mailx
Finally to compile Toss just type
make
@@ -44,6 +44,7 @@
The SAT-solver in Formula/Sat/dpll/ is part of the Decision Procedure Toolkit,
and it is Copyright to Intel Corporation and distributed under a separate
license - the Apache License 2.0. See Formula/Sat/dpll/LICENSE.txt.
+The part of menhirLib we use (under MenhirLib/) also has a separate licence.
Toss is licensed under the following BSD license.
Modified: trunk/Toss/Toss.odocl
===================================================================
--- trunk/Toss/Toss.odocl 2012-02-05 17:05:10 UTC (rev 1666)
+++ trunk/Toss/Toss.odocl 2012-02-06 02:18:40 UTC (rev 1667)
@@ -1,3 +1,4 @@
+Formula/Aux
Formula/Formula
Formula/FormulaParser
Formula/FormulaMap
@@ -20,7 +21,6 @@
Solver/Solver
Solver/Class
Solver/ClassParser
-Solver/Distinguish
Arena/Term
Arena/TermParser
Arena/DiscreteRule
@@ -38,7 +38,7 @@
GGP/TranslateFormula
GGP/TranslateGame
GGP/GameSimpl
-Server/Picture
-Server/LearnGame
+Learn/Distinguish
+Learn/LearnGame
Server/DB
Server/ReqHandler
Modified: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js 2012-02-05 17:05:10 UTC (rev 1666)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-06 02:18:40 UTC (rev 1667)
@@ -948,4 +948,4 @@
if( y.fun ) { x.fun = y.fun; return 0; }
var i = y.length; while (i--) x[i] = y[i]; return 0;
}
@@ Diff output truncated at 100000 characters. @@
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-06 13:55:26
|
Revision: 1668
http://toss.svn.sourceforge.net/toss/?rev=1668&view=rev
Author: lukaszkaiser
Date: 2012-02-06 13:55:11 +0000 (Mon, 06 Feb 2012)
Log Message:
-----------
Orders in web, pictures.
Modified Paths:
--------------
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/local.html
trunk/Toss/www/contact.xml
trunk/Toss/www/develop.xml
Added Paths:
-----------
trunk/Toss/WebClient/img/
Removed Paths:
-------------
trunk/Toss/WebClient/pics/
trunk/Toss/www/img/Breakthrough.ppm
trunk/Toss/www/img/add_rule.png
trunk/Toss/www/img/breakthrough_screen.png
trunk/Toss/www/img/breakthrough_screen_small.png
trunk/Toss/www/img/draw.png
trunk/Toss/www/img/erase.png
trunk/Toss/www/img/gomoku_screen.png
trunk/Toss/www/img/gomoku_screen_small.png
trunk/Toss/www/img/match.png
trunk/Toss/www/img/move.png
trunk/Toss/www/img/redraw.png
trunk/Toss/www/img/rewrite.png
trunk/Toss/www/img/run_hint.png
trunk/Toss/www/img/run_toss.png
trunk/Toss/www/img/tic_tac_toe_screen.png
trunk/Toss/www/img/tic_tac_toe_screen_small.png
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2012-02-06 02:18:40 UTC (rev 1667)
+++ trunk/Toss/WebClient/index.html 2012-02-06 13:55:11 UTC (rev 1668)
@@ -93,7 +93,7 @@
<p id="welcome-top">Enjoy the best games on <span class="logo-in">tPlay</span>
for free <span style="float: right;">
<a href="http://itunes.apple.com/us/app/tplay/id438620686"
- ><img style="height: 24px;" src="pics/appstore-small.png" /></a>
+ ><img style="height: 24px;" src="img/appstore-small.png" /></a>
<g:plusone></g:plusone>
</span>
</p>
@@ -106,21 +106,21 @@
<p style="width:100%; text-align: justify;">
<button onclick="new_play_guest('Chess')" class="game-picbt"
title="Play Chess">
- <img style="max-width:95%" src="pics/Chess.png" alt="Chess Board" />
+ <img style="max-width:95%" src="img/Chess.png" alt="Chess Board" />
<span id="pdescChess" class="game-picspan">
<span class="game-pictxt">Chess</span>
</span>
</button>
<button onclick="new_play_guest('Connect4')" class="game-picbt"
class="boldobt" title="Play Connect4">
- <img style="max-width:95%" src="pics/Connect4.png" alt="Connect4 Board" />
+ <img style="max-width:95%" src="img/Connect4.png" alt="Connect4 Board" />
<span id="pdescConnect4" class="game-picspan">
<span class="game-pictxt">Connect4</span>
</span>
</button>
<button onclick="new_play_guest('Pawn-Whopping')" class="game-picbt"
class="boldobt" title="Play Pawn-Whopping">
- <img style="max-width:95%" src="pics/Pawn-Whopping.png"
+ <img style="max-width:95%" src="img/Pawn-Whopping.png"
alt="Pawn-Whopping Board" />
<span id="pdescPawn-Whopping" class="game-picspan">
<span class="game-pictxt">Pawn-Whopping</span>
@@ -131,7 +131,7 @@
<p style="width:100%; text-align: justify">
<button onclick="new_play_guest('Breakthrough')" class="game-picbt"
class="boldobt" title="Play Breakthrough">
- <img style="max-width:95%" src="pics/Breakthrough.png"
+ <img style="max-width:95%" src="img/Breakthrough.png"
alt="Breakthrough Board" />
<span id="pdescBreakthrough" class="game-picspan">
<span class="game-pictxt">Breakthrough</span>
@@ -139,14 +139,14 @@
</button>
<button onclick="new_play_guest('Checkers')" class="game-picbt"
class="boldobt" title="Play Checkers">
- <img style="max-width:95%" src="pics/Checkers.png" alt="Checkers Board" />
+ <img style="max-width:95%" src="img/Checkers.png" alt="Checkers Board" />
<span id="pdescCheckers" class="game-picspan">
<span class="game-pictxt">Checkers</span>
</span>
</button>
<button onclick="new_play_guest('Gomoku')" class="game-picbt"
class="boldobt" title="Play Gomoku">
- <img style="max-width:95%" src="pics/Gomoku.png" alt="Gomoku Board" />
+ <img style="max-width:95%" src="img/Gomoku.png" alt="Gomoku Board" />
<span id="pdescGomoku" class="game-picspan">
<span class="game-pictxt">Gomoku</span>
</span>
Modified: trunk/Toss/WebClient/local.html
===================================================================
--- trunk/Toss/WebClient/local.html 2012-02-06 02:18:40 UTC (rev 1667)
+++ trunk/Toss/WebClient/local.html 2012-02-06 13:55:11 UTC (rev 1668)
@@ -40,7 +40,7 @@
<p style="width:100%; text-align: justify;">
<button onclick="new_play_local('Pawn-Whopping')" class="game-picbt"
class="boldobt" title="Play Pawn-Whopping">
- <img style="max-width:95%" src="pics/Pawn-Whopping.png"
+ <img style="max-width:95%" src="img/Pawn-Whopping.png"
alt="Pawn-Whopping Board" />
<span id="pdescPawn-Whopping" class="game-picspan">
<span class="game-pictxt">Pawn-Whopping</span>
@@ -48,14 +48,14 @@
</button>
<button onclick="new_play_local('Connect4')" class="game-picbt"
class="boldobt" title="Play Connect4">
- <img style="max-width:95%" src="pics/Connect4.png" alt="Connect4 Board" />
+ <img style="max-width:95%" src="img/Connect4.png" alt="Connect4 Board" />
<span id="pdescConnect4" class="game-picspan">
<span class="game-pictxt">Connect4</span>
</span>
</button>
<button onclick="new_play_local('Breakthrough')" class="game-picbt"
class="boldobt" title="Play Breakthrough">
- <img style="max-width:95%" src="pics/Breakthrough.png"
+ <img style="max-width:95%" src="img/Breakthrough.png"
alt="Breakthrough Board" />
<span id="pdescBreakthrough" class="game-picspan">
<span class="game-pictxt">Breakthrough</span>
@@ -66,7 +66,7 @@
<p style="width:100%; text-align: justify">
<button onclick="new_play_local('Tic-Tac-Toe')" class="game-picbt"
class="boldobt" title="Play Tic-Tac-Toe">
- <img style="max-width:95%" src="pics/Tic-Tac-Toe.png"
+ <img style="max-width:95%" src="img/Tic-Tac-Toe.png"
alt="Tic-Tac-Toe Board" />
<span id="pdescTic-Tac-Toe" class="game-picspan">
<span class="game-pictxt">Tic-Tac-Toe</span>
@@ -74,14 +74,14 @@
</button>
<button onclick="new_play_local('Checkers')" class="game-picbt"
class="boldobt" title="Play Checkers">
- <img style="max-width:95%" src="pics/Checkers.png" alt="Checkers Board" />
+ <img style="max-width:95%" src="img/Checkers.png" alt="Checkers Board" />
<span id="pdescCheckers" class="game-picspan">
<span class="game-pictxt">Checkers</span>
</span>
</button>
<button onclick="new_play_local('Gomoku')" class="game-picbt"
class="boldobt" title="Play Gomoku">
- <img style="max-width:95%" src="pics/Gomoku.png" alt="Gomoku Board" />
+ <img style="max-width:95%" src="img/Gomoku.png" alt="Gomoku Board" />
<span id="pdescGomoku" class="game-picspan">
<span class="game-pictxt">Gomoku</span>
</span>
Modified: trunk/Toss/www/contact.xml
===================================================================
--- trunk/Toss/www/contact.xml 2012-02-06 02:18:40 UTC (rev 1667)
+++ trunk/Toss/www/contact.xml 2012-02-06 13:55:11 UTC (rev 1668)
@@ -279,15 +279,16 @@
Many people contributed, here we name just a few. Current leaders:</par>
<itemize>
<item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item>
- <item>Tobias Ganzow</item>
<item>Łukasz Stafiniak</item>
- <item>Michał Wójcik</item>
</itemize>
<par>Friends who helped us a lot with discussion and code.</par>
<itemize>
<item>Dietmar Berwanger</item>
<item>Matko Botincan</item>
<item>Diana Fischer</item>
+ <item>Tobias Ganzow</item>
+ <item>Simon Leßenich</item>
+ <item>Michał Wójcik</item>
</itemize>
<par>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-02-06 02:18:40 UTC (rev 1667)
+++ trunk/Toss/www/develop.xml 2012-02-06 13:55:11 UTC (rev 1668)
@@ -53,14 +53,14 @@
kompilieren möchte, braucht man
Pakete, die mit folgender Zeile installiert werden können.<br/>
<em>sudo apt-get install menhir libounit-ocaml-dev libsqlite3-ocaml-dev
- heirloom-mailx</em>
+ libjs-of-ocaml-dev heirloom-mailx</em>
</item>
<item>Um Toss unter
<a href="http://www.apple.com/macosx/">MacOSX</a>
zu kompilieren, empfehlen wir
<a href="http://www.macports.org/">MacPorts</a> (Xcode nötig).
Mit MacPorts muss man folgendes installieren.<br/>
- <em>sudo port install ocaml caml-menhir caml-ounit caml-sqlite3
+ <em>sudo port install ocaml ocaml-menhir ocaml-ounit ocaml-sqlite3
mailx</em>
</item>
<item>Folgendes nutzt man, um die
@@ -84,13 +84,13 @@
poniższe polecenie zainstaluje pakiety
niezbędne do kompilacji Tossa.<br/>
<em>sudo apt-get install menhir libounit-ocaml-dev libsqlite3-ocaml-dev
- heirloom-mailx</em>
+ libjs-of-ocaml-dev heirloom-mailx</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 caml-menhir caml-ounit caml-sqlite3
+ <em>sudo port install ocaml ocaml-menhir ocaml-ounit ocaml-sqlite3
mailx</em>
</item>
<item>Poniższe polecenie ściągnie
@@ -113,12 +113,12 @@
<a href="http://www.ubuntu.com/">Ubuntu</a>,
voici une commande avec une liste des paquets à installer.<br/>
<em>sudo apt-get install menhir libounit-ocaml-dev libsqlite3-ocaml-dev
- heirloom-mailx</em>
+ libjs-of-ocaml-dev heirloom-mailx</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 caml-menhir caml-ounit caml-sqlite3
+ <em>sudo port install ocaml ocaml-menhir ocaml-ounit ocaml-sqlite3
mailx</em>
</item>
<item>Cette commande checkout du
Deleted: trunk/Toss/www/img/Breakthrough.ppm
===================================================================
--- trunk/Toss/www/img/Breakthrough.ppm 2012-02-06 02:18:40 UTC (rev 1667)
+++ trunk/Toss/www/img/Breakthrough.ppm 2012-02-06 13:55:11 UTC (rev 1668)
@@ -1,120003 +0,0 @@
-P3
-200 200
-255
-0
-0
-0
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-43
-0
-21
-47
-0
-19
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-44
-0
-18
-49
-0
-12
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-40
-0
-13
-41
-0
-16
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-41
-0
-20
-41
-0
-20
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-41
-0
-16
-40
-0
-13
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-49
-0
-12
-44
-0
-18
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-47
-0
-19
-43
-0
-21
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-45
-0
-15
-0
-0
-0
-26
-0
-26
-38
-3
-20
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-40
-6
-21
-43
-8
-24
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-52
-17
-30
-44
-9
-24
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-9
-25
-39
-4
-21
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-40
-5
-21
-41
-7
-22
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-48
-13
-27
-45
-10
-25
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-43
-8
-23
-40
-6
-22
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-49
-14
-27
-44
-8
-23
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-45
-11
-26
-38
-3
-20
-26
-0
-26
-26
-0
-26
-39
-4
-21
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-113
-82
-73
-112
-80
-71
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-57
-22
-33
-200
-171
-132
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-197
-167
-130
-54
-20
-31
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-90
-57
-55
-144
-113
-93
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-49
-14
-27
-224
-195
-148
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-159
-128
-103
-76
-41
-46
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-72
-38
-43
-166
-136
-109
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-39
-4
-21
-26
-0
-26
-26
-0
-26
-39
-4
-21
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-113
-82
-73
-112
-80
-71
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-57
-22
-33
-200
-171
-132
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-197
-167
-130
-54
-20
-31
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-90
-57
-55
-144
-113
-93
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-49
-14
-27
-224
-195
-148
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-159
-128
-103
-76
-41
-46
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-72
-38
-43
-166
-136
-109
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-39
-4
-21
-26
-0
-26
-26
-0
-26
-39
-4
-21
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-113
-82
-73
-112
-80
-71
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-57
-22
-33
-200
-171
-132
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-197
-167
-130
-54
-20
-31
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-90
-57
-55
-144
-113
-93
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-49
-14
-27
-224
-195
-148
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-159
-128
-103
-76
-41
-46
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-72
-38
-43
-166
-136
-109
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-39
-4
-21
-26
-0
-26
-26
-0
-26
-39
-4
-21
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-207
-179
-137
-131
-99
-84
-71
-36
-43
-57
-22
-33
-63
-28
-37
-88
-53
-55
-162
-131
-105
-238
-210
-159
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-113
-82
-73
-112
-80
-71
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-249
-222
-166
-177
-147
-116
-100
-65
-62
-66
-29
-39
-57
-22
-33
-67
-32
-40
-113
-80
-71
-189
-160
-125
-253
-226
-169
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-57
-22
-33
-200
-171
-132
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-228
-199
-152
-151
-120
-98
-81
-45
-49
-60
-26
-36
-59
-24
-34
-77
-42
-46
-143
-112
-93
-221
-192
-146
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-197
-167
-130
-54
-20
-31
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-198
-169
-130
-120
-88
-77
-69
-33
-41
-57
-22
-33
-64
-30
-39
-94
-59
-58
-170
-140
-111
-245
-217
-163
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-90
-57
-55
-144
-113
-93
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-244
-216
-162
-170
-140
-111
-93
-58
-58
-64
-29
-38
-57
-22
-33
-69
-33
-41
-122
-90
-79
-199
-170
-131
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-49
-14
-27
-224
-195
-148
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-220
-191
-146
-142
-111
-92
-77
-42
-46
-58
-23
-34
-60
-26
-36
-81
-45
-49
-151
-120
-98
-229
-200
-151
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-159
-128
-103
-76
-41
-46
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-253
-226
-169
-189
-159
-124
-112
-79
-70
-67
-32
-40
-57
-22
-33
-66
-29
-39
-100
-67
-63
-178
-148
-116
-249
-222
-166
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-72
-38
-43
-166
-136
-109
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-238
-210
-159
-161
-130
-106
-87
-52
-54
-63
-28
-37
-57
-22
-33
-71
-36
-43
-131
-99
-84
-208
-180
-137
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-39
-4
-21
-26
-0
-26
-26
-0
-26
-39
-4
-21
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-227
-198
-151
-92
-58
-57
-49
-13
-27
-52
-8
-30
-56
-7
-33
-60
-7
-36
-59
-7
-36
-54
-6
-32
-52
-11
-30
-48
-13
-27
-152
-120
-98
-253
-226
-169
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-113
-82
-73
-112
-80
-71
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-182
-152
-120
-56
-21
-33
-52
-13
-31
-53
-6
-31
-58
-7
-34
-60
-7
-37
-57
-7
-35
-52
-6
-31
-52
-13
-29
-69
-34
-41
-205
-176
-136
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-57
-22
-33
-200
-171
-132
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-247
-220
-165
-127
-95
-80
-47
-11
-26
-53
-10
-30
-56
-6
-33
-59
-8
-35
-59
-7
-36
-56
-7
-33
-52
-9
-30
-48
-12
-26
-114
-80
-72
-241
-214
-160
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-197
-167
-130
-54
-20
-31
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-216
-188
-143
-78
-44
-48
-50
-14
-29
-52
-7
-30
-58
-7
-34
-61
-7
-36
-59
-7
-35
-53
-6
-31
-53
-13
-30
-51
-16
-29
-169
-138
-110
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-90
-57
-55
-144
-113
-93
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-166
-135
-108
-51
-16
-29
-53
-12
-30
-54
-6
-32
-59
-7
-35
-61
-7
-36
-58
-7
-34
-51
-7
-30
-50
-14
-29
-80
-46
-49
-218
-190
-144
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-49
-14
-27
-224
-195
-148
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-241
-213
-160
-111
-79
-71
-47
-12
-26
-51
-9
-30
-56
-7
-33
-59
-7
-36
-60
-8
-35
-55
-6
-33
-53
-10
-30
-47
-11
-26
-128
-96
-82
-248
-221
-166
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-159
-128
-103
-76
-41
-46
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-203
-174
-134
-67
-32
-40
-51
-13
-29
-52
-6
-30
-58
-7
-35
-60
-7
-37
-58
-7
-34
-52
-6
-31
-52
-13
-30
-57
-22
-33
-185
-156
-121
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-72
-38
-43
-166
-136
-109
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-253
-226
-169
-149
-118
-96
-48
-13
-27
-52
-11
-30
-54
-6
-32
-59
-7
-36
-60
-7
-36
-56
-7
-33
-52
-8
-30
-48
-12
-28
-94
-60
-58
-229
-200
-151
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-39
-4
-21
-26
-0
-26
-26
-0
-26
-39
-4
-21
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-207
-179
-137
-52
-16
-29
-54
-8
-32
-64
-8
-38
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-60
-7
-37
-51
-13
-30
-99
-66
-63
-249
-222
-166
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-113
-82
-73
-112
-80
-71
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-140
-108
-90
-48
-12
-27
-58
-7
-35
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-55
-6
-33
-46
-11
-26
-173
-142
-112
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-57
-22
-33
-200
-171
-132
-255
-228
-170
-255
-228
-170
-255
-228
-170
-255
-228
-170
-236
-208
-157
-74
-40
-46
-53
-12
-31
-62
-7
-38
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-64
-8
-39
-63
-8
-38
-54
-11
-31
-64
-29
-38
-227
-198
-151
-255
-228
-170
-2...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-07 02:10:57
|
Revision: 1669
http://toss.svn.sourceforge.net/toss/?rev=1669&view=rev
Author: lukaszkaiser
Date: 2012-02-07 02:10:47 +0000 (Tue, 07 Feb 2012)
Log Message:
-----------
Make local the default client, remove dependency on sqlite3 and many requests from ReqHandler and Arena.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Makefile
trunk/Toss/README
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Toss.odocl
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/index.html
trunk/Toss/www/develop.xml
Removed Paths:
-------------
trunk/Toss/Server/DB.ml
trunk/Toss/Server/DB.mli
trunk/Toss/Server/ServerTest.in
trunk/Toss/Server/ServerTest.out
trunk/Toss/WebClient/crypto-sha256.js
trunk/Toss/WebClient/local.html
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-02-06 13:55:11 UTC (rev 1668)
+++ trunk/Toss/Arena/Arena.ml 2012-02-07 02:10:47 UTC (rev 1669)
@@ -599,75 +599,10 @@
(* Requests which we handle. *)
type request =
- AddElem of struct_loc (* Add element to location *)
- | AddRel of struct_loc * string * string list (* Add relation tuple *)
- | DelElem of struct_loc * string (* Del element at location *)
- | DelRel of struct_loc * string * string list (* Del relation tuple *)
- | GetRelSignature of struct_loc (* List rel names and arities *)
- | GetFunSignature of struct_loc (* List function names *)
- | GetAllTuples of struct_loc * string (* Get all tuples in relation *)
- | GetAllElems of struct_loc (* List all elements *)
- | SetFun of struct_loc * string * string * float (* Set function value *)
- | GetFun of struct_loc * string * string (* Get function value *)
- | SetData of string * string (* Set data under a name *)
- | GetData of string (* Get data *)
- | SetArity of string * int (* Set arity of a relation *)
- | GetArity of string (* Get arity of a relation *)
- | RenamePlayer of string * string (* Replace player name *)
- | SetLoc of int (* Set current location *)
- | GetLoc (* Get current and # locs. *)
- | SetLocPlayer of int * string (* Set player at location *)
- | GetLocPlayer of int (* Get player at location *)
- | SetLocPayoff of int * string * Formula.real_expr(* Set payoff for player *)
- | GetLocPayoff of int * string (* Get payoff for player *)
- | GetCurPayoffs (* Payoffs in current loc *)
- | SetLocMoves of int * (label * int) list (* Set moves at location *)
- | GetLocMoves of int (* Get moves at location *)
| SuggestLocMoves of int * int * int * string * int option *
(string * Formula.real_expr) list array option * float option
- (* Suggested moves at loc, with timeout in so many seconds, for so
- much computational effort if possible before timeout, using given
- search method ("maximax", "alpha_beta", "alpha_beta_ord",
- "uct_random_playouts",
- "uct_greedy_playouts", "uct_maximax_playouts",
- "uct_no_playouts"), with optional horizon for playouts, with
- location-dependent heuristics, with advancement ratio for
- generating heuristics if they're not given *)
- | EvalFormula of Formula.formula (* Evaluate formula *)
- | EvalRealExpr of Formula.real_expr (* Evaluate real expr *)
- | SetRule of string *
- ((string * int) list ->
- (string * (string list * Formula.formula)) list -> string ->
- ContinuousRule.rule)
- (* Set a rule as given *)
- | GetRule of string (* Get a rule as string *)
- | SetRuleUpd of string * string * string * Formula.real_expr
- (* Set a rule update eq *)
- | GetRuleUpd of string * string * string (* Get a rule update eq *)
- | SetRuleDyn of string*string *string *Term.term (* Set a rule dynamics eq *)
- | GetRuleDyn of string * string * string (* Get a rule dynamics eq *)
- | SetRuleCond of string * Formula.formula * Formula.formula * Formula.formula
- (* Set a rule's precondition, invariant and postconsition *)
- | GetRuleCond of string (* Get a rule conditions *)
- | SetRuleEmb of string * string list (* Set relations to embed *)
- | GetRuleEmb of string (* Get relations to embed *)
- | SetRuleAssoc of string * string * string (* Set an association *)
- | GetRuleAssoc of string * string (* Get an association *)
- | GetRuleMatches of string (* Get matches of a rule *)
- | ApplyRule of string * (string * string) list * float * (string * float) list
- (* Apply rule at match for given time and with params *)
- | ApplyRuleInt of string * (string * int) list * float * (string * float) list
- (* Apply rule at match for given time and with params *)
- | GetRuleNames (* Get names of all rules *)
- | SetTime of float * float (* Set time step and time *)
- | GetTime (* Get time step and time *)
- | SetState of game * game_state (* Set the full state *)
- | GetState (* Return the state *)
- | GetModel (* Return model+history *)
- | SetModel of Structure.structure * (move * float option) list (* Set above *)
-
(* --------------------------- REQUEST HANDLER ------------------------------ *)
(* Apply function [f] to named structure at location [loc] in [state].
@@ -750,452 +685,21 @@
let sig_str state =
Structure.sig_str state.struc
-(* Request Handler *)
-let handle_request (state_game, state) req =
- let struc = state.struc in
- let add_new_elem struc =
- let struc, e = Structure.add_new_elem struc () in
- struc, string_of_int e in
- match req with
- AddElem loc ->
- apply_to_loc add_new_elem loc (state_game, state) "add elem"
- | AddRel (loc, rel, tp) ->
- let add_rel struc =
- let struc, tp =
- List.fold_right (fun n (struc, tp) ->
- let struc, e = Structure.find_or_new_elem struc n in
- struc, e::tp) tp (struc, []) in
- let tp = Array.of_list tp in
- Structure.add_rel struc rel tp, "REL ADDED" in
- apply_to_loc add_rel loc (state_game, state) "add rel"
- | DelElem (loc, elem_name) ->
- let del_elem struc =
- let el = Structure.find_elem struc elem_name in
- Structure.del_elem struc el, "ELEM DELETED" in
- apply_to_loc del_elem loc (state_game, state) "del elem"
- | DelRel (loc, rel, tp) ->
- let del_rel struc =
- let tp = List.map (fun n -> Structure.find_elem struc n) tp in
- Structure.del_rel struc rel (Array.of_list tp), "REL DELETED" in
- apply_to_loc del_rel loc (state_game, state) "del rel"
- | GetRelSignature loc ->
- ((state_game, state),
- get_from_loc Structure.sig_str loc (state_game, state) "get signature")
- | GetFunSignature loc ->
- let fun_signature struc =
- let funs = Structure.f_signature struc in
- String.concat "; " funs in
- ((state_game,state),
- get_from_loc fun_signature loc (state_game, state) "get signature")
- | GetAllTuples (loc, rel) ->
- let tuples struc =
- let tps = Structure.rel_graph rel struc in
- Structure.rel_str struc rel tps in
- ((state_game, state),
- get_from_loc tuples loc (state_game, state) "get all tuples")
- | GetAllElems loc ->
- let elems struc =
- let els = Structure.elements struc in
- let el_name e = Structure.elem_str struc e in
- String.concat "; " (List.map el_name els) in
- ((state_game, state),
- get_from_loc elems loc (state_game, state) "get all elements")
- | SetFun (loc, funct, el_name, v) ->
- let set_fun struc =
- let el = Structure.find_elem struc el_name in
- Structure.add_fun struc funct (el, v), "FUN SET" in
- apply_to_loc set_fun loc (state_game, state) "set fun"
- | GetFun (loc, funct, el_name) ->
- let get_fun struc =
- let el = Structure.find_elem struc el_name in
- string_of_float (Structure.fun_val struc funct el) in
- ((state_game, state),
- get_from_loc get_fun loc (state_game, state) "get fun")
- | SetData (key, v) ->
- let ndata = Aux.replace_assoc key v state_game.data in
- (({state_game with data = ndata }, state), "SET DATA")
- | GetData (key) -> (
- try ((state_game, state), List.assoc key state_game.data)
- with Not_found -> ((state_game, state), "ERR no data")
- )
- | SetArity (rel, ar) ->
- if (try List.assoc rel (Structure.rel_signature struc) = ar
- with Not_found -> false)
- then (state_game, state), "SET ARITY"
- else
- let s = Structure.add_rel_name rel ar struc in
- ((state_game, { state with struc = s }), "SET ARITY")
- | GetArity (rel) -> (
- if rel = "" then ((state_game, state), sig_str state) else
- try ((state_game, state), string_of_int
- (List.assoc rel (Structure.rel_signature state.struc)))
- with Not_found ->
- ((state_game, state), "ERR relation "^rel^" arity not found")
- )
- | RenamePlayer (old_name, new_name) ->
- let player, player_names =
- Aux.pop_assoc old_name state_game.player_names in
- ({state_game with player_names = (new_name, player)::player_names},
- state), "PLAYER renamed"
- | SetLoc (i) ->
- let l = Array.length state_game.graph in
- if i < 0 || i > l then (* make new location and set there *)
- let a = Array.make (Array.length state_game.graph.(0)) zero_loc in
- (({state_game with graph = Array.append state_game.graph [|a|]},
- {state with cur_loc = l }),
- "NEW LOC ADDED AND CUR LOC SET TO " ^ (string_of_int l))
- else
- ((state_game, { state with cur_loc = i }), "CUR LOC SET")
- | GetLoc ->
- ((state_game, state), (string_of_int state.cur_loc) ^ " / " ^
- (string_of_int (Array.length state_game.graph)))
- | SetLocPlayer (i, player) -> failwith "unsupported for now, concurrency"
- (* ((state_game, state), "LOC PLAYER SET") *)
- | GetLocPlayer (i) ->
- if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
- else
- let players =
- Aux.array_argfind_all (fun l-> l.moves <> []) state_game.graph.(i) in
- if List.length players <> 1 then
- ((state_game, state), "ERR location " ^ string_of_int i ^ " allows "^
- (string_of_int (List.length players)) ^ " players to move")
- else
- let pl = List.hd players in
- ((state_game, state), Aux.rev_assoc state_game.player_names pl)
- | SetLocPayoff (i, player, payoff) ->
- let (state_game, state), player =
- try (state_game, state), List.assoc player state_game.player_names
- with Not_found -> add_new_player (state_game, state) player in
- if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
- else (
- let simp_payoff = FormulaOps.tnf_re payoff in
- state_game.graph.(i).(player) <-
- { state_game.graph.(i).(player) with payoff = simp_payoff };
- ((state_game, state), "LOC PAYOFF SET")
- )
- | GetLocPayoff (i, player) ->
- if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
- else (
- try
- let pno = List.assoc player state_game.player_names in
- ((state_game, state),
- Formula.real_str state_game.graph.(i).(pno).payoff)
- with Not_found -> ((state_game, state), "0.0")
- )
- | GetCurPayoffs ->
- let payoffs = Array.to_list
- (Array.mapi (fun i v->string_of_int i, v.payoff)
- state_game.graph.(state.cur_loc)) in
- let ev (p,e) =
- p^": "^(string_of_float (Solver.M.get_real_val e struc)) in
- ((state_game, state),
- String.concat ", " (List.sort compare (List.map ev payoffs)))
- | SetLocMoves (i, moves) -> failwith "unsupported for now, concurrency"
- (* if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
- else (
- state_game.graph.(i) <- { state_game.graph.(i) with moves = moves };
- ((state_game, state), "LOC MOVES SET")
- ) *)
- | GetLocMoves (i) ->
- if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
- else
- let pl i = Aux.rev_assoc state_game.player_names i in
- let all_moves = List.concat (Array.to_list (
- Array.mapi (fun i ploc -> List.map (fun (l, e) -> (pl i, l, e))
- ploc.moves) state_game.graph.(i))) in
- ((state_game,state), (String.concat "; " (List.map pmv_str all_moves)))
- | SuggestLocMoves _ ->
- failwith "handle_req: SuggestLocMoves handled in Server"
- | EvalFormula (phi) -> ((state_game, state), "ERR eval not yet implemented")
- | EvalRealExpr (rexpr) ->
- ((state_game, state), "ERR eval real not yet implemented")
- | SetRule (r_name, r) -> (
- try
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let new_rules =
- Aux.replace_assoc r_name (r signat defs r_name)
- state_game.rules in
- (({state_game with rules=new_rules}, state), "SET RULE")
- with
- Not_found -> ((state_game, state),
- "ERR [Not found] setting rule "^r_name^" failed")
- )
- | GetRule (r_name) ->
- let msg = get_from_rule ContinuousRule.str r_name state_game "get rule" in
- ((state_game, state), msg)
- | SetRuleUpd (r_name, f, elem_name, expr) ->
- let set_upd r =
- let new_upd =
- Aux.replace_assoc (f,elem_name) expr r.ContinuousRule.update in
- { r with ContinuousRule.update = new_upd }, "UPDATE SET" in
- apply_to_rule set_upd r_name (state_game, state) "set rule upd"
- | GetRuleUpd (r_name, f, elem_name) ->
- let get_upd r =
- try
- let upd = List.assoc (f,elem_name) r.ContinuousRule.update in
- Formula.real_str upd
- with Not_found -> "0.0" in
- ((state_game, state),
- get_from_rule get_upd r_name state_game "get rule upd")
- | SetRuleDyn (r_name, f, elem_name, term) ->
- let set_dyn r =
- let new_dyn =
- Aux.replace_assoc (f,elem_name) term r.ContinuousRule.dynamics in
- { r with ContinuousRule.dynamics = new_dyn },"DYNAMICS SET" in
- apply_to_rule set_dyn r_name (state_game, state) "set rule dyn"
- | GetRuleDyn (r_name, f, elem_name) ->
- let get_dyn r =
- try
- let dyn = List.assoc (f,elem_name) r.ContinuousRule.dynamics in
- Term.str dyn
- with Not_found -> "0.0" in
- ((state_game, state),
- get_from_rule get_dyn r_name state_game "get rule dyn")
- | SetRuleCond (r_name, pre, inv, post) ->
- let set_cond r =
- let d = r.ContinuousRule.discrete in
- let (dyn, upd)=(r.ContinuousRule.dynamics, r.ContinuousRule.update) in
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let discr =
- match d.DiscreteRule.struc_rule with
- | None ->
- {d with DiscreteRule.match_formula = pre}
- | Some rule_src ->
- DiscreteRule.compile_rule signat defs
- {rule_src with DiscreteRule.pre = (pre, []) } in
- let nr = (* TODO: rename lhs_* relations to be consistent with ln *)
- ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
- (nr, "RULE COND SET") in
- apply_to_rule set_cond r_name (state_game, state) "set rule cond"
- | GetRuleCond (r_name) ->
- let get_cond r =
- let discr = r.ContinuousRule.discrete in
- let pre =
- match discr.DiscreteRule.struc_rule with
- | None -> discr.DiscreteRule.match_formula
- | Some struc_r -> fst struc_r.DiscreteRule.pre in
- let (inv, post)=(r.ContinuousRule.inv, r.ContinuousRule.post) in
- (Formula.str pre)^"; "^ (Formula.str inv) ^"; "^ (Formula.str post) in
- ((state_game, state),
- get_from_rule get_cond r_name state_game "get rule cond")
- | SetRuleEmb (r_name, emb) ->
- let set_emb r =
- let struc_r = r.ContinuousRule.discrete.DiscreteRule.struc_rule in
- match struc_r with
- | None ->
- r,
- "ERR Set Rule Embedding: formula-based format of " ^
- r_name
- | Some struc_r ->
- let struc_r = {struc_r with DiscreteRule.emb_rels =emb } in
- let (dyn, upd)=
- (r.ContinuousRule.dynamics, r.ContinuousRule.update) in
- let inv = r.ContinuousRule.inv
- and post = r.ContinuousRule.post in
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let discr = DiscreteRule.compile_rule signat defs struc_r in
- let nr =
- ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
- (nr, "RULE EMB SET") in
- apply_to_rule set_emb r_name (state_game, state) "set rule emb"
-
- | GetRuleEmb (r_name) ->
- let get_emb r =
- let struc_r = r.ContinuousRule.discrete.DiscreteRule.struc_rule in
- match struc_r with
- | None ->
- "ERR Get Rule Embedding: formula-based format of " ^
- r_name
- | Some struc_r ->
- String.concat ", " struc_r.DiscreteRule.emb_rels in
- ((state_game, state),
- get_from_rule get_emb r_name state_game "get rule emb")
-
- | SetRuleAssoc (r_name, rhs_v, lhs_v) ->
- let set_assoc r =
- let discr = r.ContinuousRule.discrete in
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let discr =
- match discr.DiscreteRule.struc_rule with
- | Some struc_r ->
- let lhs_e = Structure.find_elem
- struc_r.DiscreteRule.lhs_struc lhs_v in
- let rhs_e = Structure.find_elem
- struc_r.DiscreteRule.rhs_struc rhs_v in
- let rule_s = Aux.replace_assoc rhs_e lhs_e
- (List.filter (fun (r, l) -> r <> rhs_e)
- struc_r.DiscreteRule.rule_s) in
- DiscreteRule.compile_rule signat defs
- {struc_r with DiscreteRule.rule_s = rule_s}
- | None ->
- let rlmap =
- match discr.DiscreteRule.rlmap with
- | None ->
- List.map (fun v->v,v) discr.DiscreteRule.lhs_vars
- | Some rlmap -> rlmap in
- let rlmap =
- Aux.replace_assoc rhs_v lhs_v rlmap in
- {discr with DiscreteRule.rlmap = Some rlmap} in
- let (dyn, upd) =
- (r.ContinuousRule.dynamics, r.ContinuousRule.update) in
- let inv = r.ContinuousRule.inv
- and post = r.ContinuousRule.post in
- let nr =
- ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
- (nr, "RULE ASSOC SET")
- in
- apply_to_rule set_assoc r_name (state_game, state) "set rule assoc"
-
- | GetRuleAssoc (r_name, rhs_v) ->
- let get_assoc r =
- let assoc = r.ContinuousRule.discrete.DiscreteRule.rlmap in
- match assoc with
- (* TODO: the RHS variables could have gotten renamed!
- Best would be to check if there is struc_rule if
- [rlmap = None] *)
- | None -> rhs_v
- | Some a -> List.assoc rhs_v a in
- ((state_game, state),
- get_from_rule get_assoc r_name state_game "get rule assoc")
-
- | GetRuleMatches (r_name) -> (
- let check_history_pre r hist =
- match r.ContinuousRule.discrete.DiscreteRule.struc_rule with
- | None -> true
- | Some sr ->
- let prev_list = snd (sr.DiscreteRule.pre) in
- let constraint_satisfied (rname, b) =
- List.exists (fun (mv, _) -> mv.rule = rname) hist = b in
- List.for_all constraint_satisfied prev_list in
- try
- let r = List.assoc r_name state_game.rules in
- let matches = if not (check_history_pre r state.history) then [] else
- ContinuousRule.matches_post struc r state.time in
- (* matches are from LHS to model *)
- ((state_game, state),
- String.concat "; " (
- List.map (ContinuousRule.matching_str struc) matches))
- with Not_found ->
- ((state_game, state), "ERR getting "^r_name^" matches, rule not found")
- )
-
- | ApplyRule (r_name, mtch, t, p) ->
- (let try r = List.assoc r_name state_game.rules in
- let m = List.map (fun (l, s) -> l,
- Structure.find_elem state.struc s) mtch in
- match ContinuousRule.rewrite_single struc state.time m 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
- let newmv = { mv_time = t; parameters = p; rule = r_name;
- matching = m; next_loc = -1 (*FIX*) } in
- let h = (newmv, None) :: state.history in
- ((state_game,
- {state with struc = new_struc; time = new_time; history = h}),
- shifts_s)
- | None -> ((state_game, state),
- "ERR applying "^r_name^", postcondition fails")
- with Not_found ->
- ((state_game, state), "ERR applying "^r_name^", rule not found")
- )
-
- | ApplyRuleInt (r_name, mtch, t, p) ->
- (let try r = List.assoc r_name state_game.rules in
- match ContinuousRule.rewrite_single struc 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}),
- shifts_s)
- | None -> ((state_game, state),
- "ERR applying " ^ r_name ^ ", postcondition fails")
- with Not_found ->
- ((state_game, state), "ERR applying " ^ r_name ^ ", rule not found")
- )
-
- | GetRuleNames -> ((state_game, state),
- String.concat "; " (fst (List.split state_game.rules)))
- | SetTime (tstep, t) ->
- ContinuousRule.set_time_step tstep;
- ((state_game, { state with time = t }), "TIME SET")
- | GetTime ->
- let (ts, t) = (ContinuousRule.get_time_step (), state.time) in
- ((state_game, state), string_of_float (ts) ^ " / " ^ string_of_float (t))
- | SetState (g, s) ->
- ((g, s), "STATE SET")
- | GetState -> ((state_game, state), state_str (state_game, state))
- | GetModel ->
- let h_str = if state.history = [] then "" else "\nMOVES\n" ^
- (String.concat ";\n" (List.map sprint_game_move state.history)) in
- ((state_game, state), (Structure.sprint state.struc) ^ h_str)
- | SetModel (m, h) ->
- ((state_game, { state with struc = m; history = h }), "MODEL SET")
-
-
-let can_modify_game = function
- | AddElem _ -> true
- | AddRel _ -> true
- | DelElem _ -> true
- | DelRel _ -> true
- | GetRelSignature _ -> false
- | GetFunSignature _ -> false
- | GetAllTuples _ -> false
- | GetAllElems _ -> false
- | SetFun _ -> false (* TODO: rethink when working on dyns *)
- | GetFun _ -> false
- | SetData _ -> false
- | GetData _ -> false
- | SetArity _ -> true
- | GetArity _ -> false
- | RenamePlayer _ -> false
- | SetLoc i -> true
- | GetLoc -> false
- | SetLocPlayer _ -> true
- | GetLocPlayer _ -> false
- | SetLocPayoff _ -> true
- | GetLocPayoff _ -> false
- | GetCurPayoffs -> false
- | SetLocMoves _ -> true
- | GetLocMoves _ -> false
- | SuggestLocMoves _ -> false
- | EvalFormula _ -> false
- | EvalRealExpr _ -> false
- | SetRule _ -> true
- | GetRule _ -> false
- | SetRuleUpd _ -> true
- | GetRuleUpd _ -> false
- | SetRuleDyn _ -> true
- | GetRuleDyn _ -> false
- | SetRuleCond _ -> true
- | GetRuleCond _ -> false
- | SetRuleEmb _ -> true
- | GetRuleEmb _ -> false
- | SetRuleAssoc _ -> true
- | GetRuleAssoc _ -> false
- | GetRuleMatches _ -> false
- | ApplyRule _ -> true
- | ApplyRuleInt _ -> true
- | GetRuleNames -> false
- | SetTime _ -> false (* TODO: rethink when working on dyns *)
- | GetTime -> false
- | SetState _ -> true
- | GetState -> false
- | SetModel _ -> true
- | GetModel -> false
-
+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
+ | 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}),
+ shifts_s)
+ | None -> ((state_game, state),
+ "ERR applying " ^ r_name ^ ", postcondition fails")
+ )
+ with Not_found ->
+ ((state_game, state), "ERR applying " ^ r_name ^ ", rule not found")
+ )
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-02-06 13:55:11 UTC (rev 1668)
+++ trunk/Toss/Arena/Arena.mli 2012-02-07 02:10:47 UTC (rev 1669)
@@ -170,30 +170,6 @@
(** Requests which we handle. *)
type request =
- AddElem of struct_loc (** Add element to location *)
- | AddRel of struct_loc * string * string list (** Add relation tuple *)
- | DelElem of struct_loc * string (** Del element at location *)
- | DelRel of struct_loc * string * string list (** Del relation tuple *)
- | GetRelSignature of struct_loc (** List rel names and arities *)
- | GetFunSignature of struct_loc (** List function names *)
- | GetAllTuples of struct_loc * string (** Get all tuples in relation *)
- | GetAllElems of struct_loc (** List all elements *)
- | SetFun of struct_loc * string * string * float (** Set function value *)
- | GetFun of struct_loc * string * string (** Get function value *)
- | SetData of string * string (** Set data under a name *)
- | GetData of string (** Get data *)
- | SetArity of string * int (** Set arity of a relation *)
- | GetArity of string (** Get arity of a relation *)
- | RenamePlayer of string * string (** Replace player name *)
- | SetLoc of int (** Set current location *)
- | GetLoc (** Get current and # locs. *)
- | SetLocPlayer of int * string (** Set player at location *)
- | GetLocPlayer of int (** Get player at location *)
- | SetLocPayoff of int * string * Formula.real_expr(** Set payoff for player *)
- | GetLocPayoff of int * string (** Get payoff for player *)
- | GetCurPayoffs (** Payoffs in current loc *)
- | SetLocMoves of int * (label * int) list (** Set moves at location *)
- | GetLocMoves of int (** Get moves at location *)
| SuggestLocMoves of int * int * int * string * int option *
(string * Formula.real_expr) list array option * float option
(** Suggested moves at loc, with timeout in so many seconds, for so
@@ -204,41 +180,7 @@
"uct_no_playouts"), with optional horizon for playouts, with
location-dependent heuristics, with advancement ratio for
generating heuristics if they're not given *)
- | EvalFormula of Formula.formula (** Evaluate formula *)
- | EvalRealExpr of Formula.real_expr (** Evaluate real expr *)
- | SetRule of string *
- ((string * int) list ->
- (string * (string list * Formula.formula)) list -> string ->
- ContinuousRule.rule)
- (** Set a rule as given *)
- | GetRule of string (** Get a rule as string *)
- | SetRuleUpd of string * string * string * Formula.real_expr
- (** Set a rule update eq *)
- | GetRuleUpd of string * string * string (** Get a rule update eq *)
- | SetRuleDyn of string*string *string *Term.term (** Set a rule dynamics eq *)
- | GetRuleDyn of string * string * string (** Get a rule dynamics eq *)
- | SetRuleCond of string * Formula.formula * Formula.formula * Formula.formula
- (** Set a rule's precondition, invariant and postconsition *)
- | GetRuleCond of string (** Get a rule conditions *)
- | SetRuleEmb of string * string list (** Set relations to embed *)
- | GetRuleEmb of string (** Get relations to embed *)
- | ...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-09 18:31:00
|
Revision: 1671
http://toss.svn.sourceforge.net/toss/?rev=1671&view=rev
Author: lukstafi
Date: 2012-02-09 18:30:51 +0000 (Thu, 09 Feb 2012)
Log Message:
-----------
Logging syntax extension: [LOG debug_level format arg1 ... argN] where [format] is a string logs a [Printf.sprintf format arg1 ... argN] if [debug_level] is bigger than the logging level for the module/file.
Modified Paths:
--------------
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Makefile
trunk/Toss/Server/JsHandler.ml
trunk/Toss/WebClient/JsHandler.js
Added Paths:
-----------
trunk/Toss/caml_extensions/pa_log.ml
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-07 20:07:13 UTC (rev 1670)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-09 18:30:51 UTC (rev 1671)
@@ -145,7 +145,18 @@
ENDIF
-let log s =
+let default_debug_level = ref 1
+let debug_levels = ref []
+
+let set_debug_level module_name debug_lev =
+ debug_levels := Aux.replace_assoc module_name debug_lev !debug_levels
+
+let debug_level_for module_name =
+ try List.assoc module_name !debug_levels
+ with Not_found -> !default_debug_level
+
+let log module_name debug_lev s =
+ let s = "["^string_of_int debug_lev^"@"^module_name^"] "^s in
IFDEF JAVASCRIPT THEN (
if is_worker then worker_log s else console_log s
) ELSE (
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-07 20:07:13 UTC (rev 1670)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-09 18:30:51 UTC (rev 1671)
@@ -38,6 +38,20 @@
you have to collect the results, even on Exception in caller *)
val toss_call : int * string -> ('a -> 'b) -> 'a -> (unit -> 'b)
+(** Default logging level when a level is not set using
+ {!AuxIO.set_debug_level} for a module. See {!Pa_log}. *)
+val default_debug_level : int ref
+
+(** Set logging level for a module. Logging levels are used by the
+ [pa_log] syntax extension (the [LOG] syntax). See {!Pa_log}. *)
+val set_debug_level : string -> int -> unit
+
+val debug_level_for : string -> int
+
(** Output a string in a manner visible to the programmer but not
- obtrusive to the GUI user. *)
-val log : string -> unit
+ obtrusive to the GUI user. First argument should be the module
+ name, or file name with extension stripped, from which the
+ function is called. Second argument is the logging level, but
+ serves only informative purposes. Calling this function directly
+ outputs the message unconditionally. *)
+val log : string -> int -> string -> unit
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-07 20:07:13 UTC (rev 1670)
+++ trunk/Toss/Makefile 2012-02-09 18:30:51 UTC (rev 1671)
@@ -33,9 +33,9 @@
# ------ NON OCAMLBUILD DEPENDENCIES --------
-caml_extensions/pa_let_try.cmo: caml_extensions/pa_let_try.ml
+caml_extensions/%.cmo: caml_extensions/%.ml
ocamlc -I +camlp4 -pp "camlp4o pa_extend.cmo q_MLast.cmo" \
- -c caml_extensions/pa_let_try.ml
+ -c $<
# -------- MAIN OCAMLBUILD PART --------
@@ -45,8 +45,8 @@
OCB_CFLAG=-cflags -I,/usr/local/lib/ocaml/3.12.0/js_of_ocaml,-I,+oUnit,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/js_of_ocaml,-g
OCB_LIB=-libs str,nums,unix,oUnit
OCB_LIBJS=-libs str,js_of_ocaml
-OCB_PP=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo"
-OCB_PPJS=-pp "camlp4o -unsafe -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo"
+OCB_PP=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo"
+OCB_PPJS=-pp "camlp4o -unsafe -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \
-ocamlopt "ocamlopt -inline 10" $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
@@ -63,19 +63,19 @@
ServerINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn
.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn,Server
-%.native: %.ml caml_extensions/pa_let_try.cmo
+%.native: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-%.p.native: %.ml caml_extensions/pa_let_try.cmo
+%.p.native: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-%.byte: %.ml caml_extensions/pa_let_try.cmo
+%.byte: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
$(OCAMLBUILDJS) -Is $($(subst /,INC,$(dir $@))) $@
-%.d.byte: %.ml caml_extensions/pa_let_try.cmo
+%.d.byte: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-doc: caml_extensions/pa_let_try.cmo
+doc: caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
$(OCAMLBUILD) -Is +oUnit,$(.INC) Toss.docdir/index.html
make -C www code_doc_link
Modified: trunk/Toss/Server/JsHandler.ml
===================================================================
--- trunk/Toss/Server/JsHandler.ml 2012-02-07 20:07:13 UTC (rev 1670)
+++ trunk/Toss/Server/JsHandler.ml 2012-02-09 18:30:51 UTC (rev 1671)
@@ -57,9 +57,7 @@
record
let onmessage event =
- AuxIO.log ("worker received "^of_js event##data##fname);
- (*Firebug.console##log_4 ("worker received fname=", event##data##fname,
- "; args=", event##data##args);*)
+ LOG 1 "worker received %s" (of_js event##data##fname);
let fname = event##data##fname in
let args = event##data##args in
let handle = Js.Unsafe.get js_handler fname in
@@ -72,7 +70,7 @@
let _ = Js.Unsafe.set self (js"onmessage") onmessage
let test_handle s =
- AuxIO.log ("Testing "^of_js s);
+ LOG 1 "Testing %s" (of_js s);
js ("Now " ^ of_js s ^ " tested")
let _ = set_handle "test_handle" test_handle
@@ -94,7 +92,7 @@
let struc = state.Arena.struc in
let get_pos e =
Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
- AuxIO.log "js_of_game_state: Preparing game elements...";
+ LOG 1 "js_of_game_state: Preparing game elements...";
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
@@ -110,7 +108,7 @@
elems) in
(* rels are arrays of element names, with additional "name" field *)
let num = Js.number_of_float in
- AuxIO.log "js_of_game_state: Preparing game relations...";
+ LOG 1 "js_of_game_state: Preparing game relations...";
let rels = Array.of_list
(Aux.concat_map
(fun (rel, _) ->
@@ -131,7 +129,7 @@
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 rels);
- AuxIO.log "js_of_game_state: Preparing game moves...";
+ LOG 1 "js_of_game_state: Preparing game moves...";
if !cur_all_moves <> [||] then
Js.Unsafe.set info_obj (js"moves")
(Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
@@ -155,8 +153,8 @@
let game_name = of_js game_name in
let game_loaded = List.mem_assoc game_name !GameSelection.games in
if game_loaded
- then AuxIO.log ("new_play: "^game_name^" already loaded.")
- else AuxIO.log ("new_play: loading "^game_name^"...");
+ then LOG 1 "new_play: %s already loaded." game_name
+ else LOG 1 "new_play: loading %s..." game_name;
let game_data =
try List.assoc game_name !GameSelection.games
with Not_found ->
@@ -165,13 +163,13 @@
games := game_data :: !games;
snd game_data in
if not game_loaded then
- AuxIO.log ("new_play: "^game_name^" loaded.");
+ LOG 1 "new_play: %s loaded." game_name;
let game, state = game_data.game_state in
cur_game := game_data;
play_states := [state];
cur_all_moves := Move.list_moves game state;
cur_move := 0;
- AuxIO.log ("new_play ("^game_name^"): calling js_of_game_state.");
+ LOG 1 "new_play (%s): calling js_of_game_state." game_name;
js_of_game_state game state
let _ = set_handle "new_play" new_play
@@ -188,7 +186,7 @@
let make_move move_id =
let move_id = int_of_float (Js.to_float move_id) in
- AuxIO.log ("make_move: move_id="^string_of_int move_id);
+ 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
Modified: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js 2012-02-07 20:07:13 UTC (rev 1670)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-09 18:30:51 UTC (rev 1671)
@@ -948,4 +948,4 @@
if( y.fun ) { x.fun = y.fun; return 0; }
var i = y.length; while (i--) x[i] = y[i]; return 0;
}
@@ Diff output truncated at 100000 characters. @@
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-10 02:21:15
|
Revision: 1672
http://toss.svn.sourceforge.net/toss/?rev=1672&view=rev
Author: lukaszkaiser
Date: 2012-02-10 02:21:07 +0000 (Fri, 10 Feb 2012)
Log Message:
-----------
Work on optimizing local webclient.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Server/GameSelection.ml
trunk/Toss/Server/JsHandler.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/State.js
trunk/Toss/examples/Checkers.toss
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-02-09 18:30:51 UTC (rev 1671)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-02-10 02:21:07 UTC (rev 1672)
@@ -176,8 +176,7 @@
(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 *)
- let asg = AssignmentSet.fo_assgn_of_list
- (List.map (fun (v, a) -> `FO v, a) m) in
+ 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
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-02-09 18:30:51 UTC (rev 1671)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-02-10 02:21:07 UTC (rev 1672)
@@ -330,14 +330,14 @@
List.map
(fun tp->List.map2 (fun v e->v,e) vars tp) tuples
| AssignmentSet.Empty -> []
- | AssignmentSet.FO (`FO v, els) ->
- let vars = list_remove v vars in
- concat_map (fun (e,sub)->
- List.map (fun tl->(v,e)::tl)
- (enumerate_asgns all_elems vars sub)) els
+ | AssignmentSet.FO (v, els) ->
+ let vars = list_remove v vars in
+ concat_map (fun (e,sub)->
+ List.map (fun tl -> (v,e)::tl)
+ (enumerate_asgns all_elems vars sub)) els
| AssignmentSet.MSO (_, els) ->
- concat_map (fun (e,sub)->
- enumerate_asgns all_elems vars sub) els
+ concat_map (fun (e,sub)->
+ enumerate_asgns all_elems vars sub) els
| AssignmentSet.Real _ -> failwith "real matches unsupported"
(* Enumerate matchings returned by {!find_matchings} for the same
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-09 18:30:51 UTC (rev 1671)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-10 02:21:07 UTC (rev 1672)
@@ -145,14 +145,14 @@
ENDIF
-let default_debug_level = ref 1
-let debug_levels = ref []
+let default_debug_level = ref 0
+let debug_levels = Hashtbl.create 7
let set_debug_level module_name debug_lev =
- debug_levels := Aux.replace_assoc module_name debug_lev !debug_levels
+ Hashtbl.replace debug_levels module_name debug_lev
let debug_level_for module_name =
- try List.assoc module_name !debug_levels
+ try Hashtbl.find debug_levels module_name
with Not_found -> !default_debug_level
let log module_name debug_lev s =
@@ -162,4 +162,3 @@
) ELSE (
print_endline s; flush stdout
) ENDIF
-
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-02-09 18:30:51 UTC (rev 1671)
+++ trunk/Toss/Learn/Distinguish.ml 2012-02-10 02:21:07 UTC (rev 1672)
@@ -17,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 fo_var (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
Modified: trunk/Toss/Server/GameSelection.ml
===================================================================
--- trunk/Toss/Server/GameSelection.ml 2012-02-09 18:30:51 UTC (rev 1671)
+++ trunk/Toss/Server/GameSelection.ml 2012-02-10 02:21:07 UTC (rev 1672)
@@ -52,14 +52,6 @@
SET Sum (x | bQ(x) : 1)
SET Sum (x | wBeats(x) : 1 + :(b(x)) + 3 * :(bK(x)))
SET Sum (x | bBeats(x) : 1 + :(w(x)) + 3 * :(wK(x)))
-REL IsFirst(x) = not ex z C(z, x)
-REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
-REL IsEight(x) = not ex z C(x, z)
-REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
-REL IsA1(x) = not ex z R(z, x) and IsFirst(x)
-REL IsH1(x) = not ex z R(x, z) and IsFirst(x)
-REL IsA8(x) = not ex z R(z, x) and IsEight(x)
-REL IsH8(x) = not ex z R(x, z) and IsEight(x)
REL w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x)
REL b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x)
REL DoubleC(x, y) = ex z ((C(x, z) and C(z, y)) or (C(y, z) and C(z, x)))
@@ -339,7 +331,8 @@
\" -> [ | | ] \"
... ... ...
... wK.wR ...
-\" emb w,b pre not(bBeats(c1) or bBeats(d1) or bBeats(e1)) post true
+\" emb w,b pre not(bBeats(c1) or bBeats(d1) or bBeats(e1)) and before
+ not WhiteRookA1, not WhiteKing, not WhiteLeftCastle, not WhiteRightCastle
RULE WhiteRightCastle:
[ | | ] \"
... ...
@@ -347,7 +340,8 @@
\" -> [ | | ] \"
... ...
...wR wK.
-\" emb w,b pre not (bBeats(a1) or bBeats(b1) or bBeats(c1)) post true
+\" emb w,b pre not (bBeats(a1) or bBeats(b1) or bBeats(c1)) and before
+ not WhiteRookH1, not WhiteKing, not WhiteLeftCastle, not WhiteRightCastle
RULE BlackLeftCastle:
[ | | ] \"
... ... ...
@@ -355,7 +349,8 @@
\" -> [ | | ] \"
... ... ...
... bK.bR ...
-\" emb w,b pre not(wBeats(c1) or wBeats(d1) or wBeats(e1)) post true
+\" emb w,b pre not(wBeats(c1) or wBeats(d1) or wBeats(e1)) and before
+ not BlackRookA8, not BlackKing, not BlackLeftCastle, not BlackRightCastle
RULE BlackRightCastle:
[ | | ] \"
... ...
@@ -363,8 +358,9 @@
\" -> [ | | ] \"
... ...
...bR bK.
-\" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) post true
-LOC 0 { // both can castle
+\" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) and before
+ not BlackRookH8, not BlackKing, not BlackLeftCastle, not BlackRightCastle
+LOC 0 {
PLAYER 1 {
COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
PAYOFF :(CheckB()) - :(CheckW())
@@ -379,19 +375,19 @@
[WhiteKnight -> 1];
[WhiteBishop -> 1];
[WhiteRook -> 1];
- [WhiteRookA1 -> 5];
- [WhiteRookH1 -> 3];
+ [WhiteRookA1 -> 1];
+ [WhiteRookH1 -> 1];
[WhiteQueen -> 1];
- [WhiteLeftCastle -> 7];
- [WhiteRightCastle -> 7];
- [WhiteKing -> 7]
+ [WhiteLeftCastle -> 1];
+ [WhiteRightCastle -> 1];
+ [WhiteKing -> 1]
}
PLAYER 2 {
COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
PAYOFF :(CheckW()) - :(CheckB())
}
}
-LOC 1 { // both can castle
+LOC 1 {
PLAYER 2 {
COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
PAYOFF :(CheckW()) - :(CheckB())
@@ -406,796 +402,18 @@
[BlackKnight -> 0];
[BlackBishop -> 0];
[BlackRook -> 0];
- [BlackRookA8 -> 16];
- [BlackRookH8 -> 8];
+ [BlackRookA8 -> 0];
+ [BlackRookH8 -> 0];
[BlackQueen -> 0];
- [BlackLeftCastle -> 24];
- [BlackRightCastle -> 24];
- [BlackKing -> 24]
+ [BlackLeftCastle -> 0];
+ [BlackRightCastle -> 0];
+ [BlackKing -> 0]
}
PLAYER 1 {
COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
PAYOFF :(CheckB()) - :(CheckW())
}
}
-LOC 2 { // w left, b can castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 3];
- [WhitePawnMoveDbl -> 3];
- [WhitePawnBeat -> 3];
- [WhitePawnBeatPromote -> 3];
- [WhitePawnBeatLDbl -> 3];
- [WhitePawnBeatRDbl -> 3];
- [WhitePawnPromote -> 3];
- [WhiteKnight -> 3];
- [WhiteBishop -> 3];
- [WhiteRook -> 3];
- [WhiteRookA1 -> 7];
- [WhiteRookH1 -> 3];
- [WhiteQueen -> 3];
- [WhiteLeftCastle -> 7];
- [WhiteKing -> 7]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 3 { // w left, b can castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 2];
- [BlackPawnMoveDbl -> 2];
- [BlackPawnBeat -> 2];
- [BlackPawnBeatPromote -> 2];
- [BlackPawnBeatLDbl -> 2];
- [BlackPawnBeatRDbl -> 2];
- [BlackPawnPromote -> 2];
- [BlackKnight -> 2];
- [BlackBishop -> 2];
- [BlackRook -> 2];
- [BlackRookA8 -> 18];
- [BlackRookH8 -> 10];
- [BlackQueen -> 2];
- [BlackLeftCastle -> 26];
- [BlackRightCastle -> 26];
- [BlackKing -> 26]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 4 { // w right, b can castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 5];
- [WhitePawnMoveDbl -> 5];
- [WhitePawnBeat -> 5];
- [WhitePawnBeatPromote -> 5];
- [WhitePawnBeatLDbl -> 5];
- [WhitePawnBeatRDbl -> 5];
- [WhitePawnPromote -> 5];
- [WhiteKnight -> 5];
- [WhiteBishop -> 5];
- [WhiteRook -> 5];
- [WhiteRookA1 -> 5];
- [WhiteRookH1 -> 7];
- [WhiteQueen -> 5];
- [WhiteRightCastle -> 7];
- [WhiteKing -> 7]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 5 { // w right, b can castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 4];
- [BlackPawnMoveDbl -> 4];
- [BlackPawnBeat -> 4];
- [BlackPawnBeatPromote -> 4];
- [BlackPawnBeatLDbl -> 4];
- [BlackPawnBeatRDbl -> 4];
- [BlackPawnPromote -> 4];
- [BlackKnight -> 4];
- [BlackBishop -> 4];
- [BlackRook -> 4];
- [BlackRookA8 -> 20];
- [BlackRookH8 -> 12];
- [BlackQueen -> 4];
- [BlackLeftCastle -> 28];
- [BlackRightCastle -> 28];
- [BlackKing -> 28]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 6 { // w no, b can castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 7];
- [WhitePawnMoveDbl -> 7];
- [WhitePawnBeat -> 7];
- [WhitePawnBeatPromote -> 7];
- [WhitePawnBeatLDbl -> 7];
- [WhitePawnBeatRDbl -> 7];
- [WhitePawnPromote -> 7];
- [WhiteKnight -> 7];
- [WhiteBishop -> 7];
- [WhiteRook -> 7];
- [WhiteRookA1 -> 7];
- [WhiteRookH1 -> 7];
- [WhiteQueen -> 7];
- [WhiteKing -> 7]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 7 { // w no, b can castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 6];
- [BlackPawnMoveDbl -> 6];
- [BlackPawnBeat -> 6];
- [BlackPawnBeatPromote -> 6];
- [BlackPawnBeatLDbl -> 6];
- [BlackPawnBeatRDbl -> 6];
- [BlackPawnPromote -> 6];
- [BlackKnight -> 6];
- [BlackBishop -> 6];
- [BlackRook -> 6];
- [BlackRookA8 -> 22];
- [BlackRookH8 -> 14];
- [BlackQueen -> 6];
- [BlackLeftCastle -> 30];
- [BlackRightCastle -> 30];
- [BlackKing -> 30]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 8 { // w can, b left castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 9];
- [WhitePawnMoveDbl -> 9];
- [WhitePawnBeat -> 9];
- [WhitePawnBeatPromote -> 9];
- [WhitePawnBeatLDbl -> 9];
- [WhitePawnBeatRDbl -> 9];
- [WhitePawnPromote -> 9];
- [WhiteKnight -> 9];
- [WhiteBishop -> 9];
- [WhiteRook -> 9];
- [WhiteRookA1 -> 13];
- [WhiteRookH1 -> 11];
- [WhiteQueen -> 9];
- [WhiteLeftCastle -> 15];
- [WhiteRightCastle -> 15];
- [WhiteKing -> 15]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 9 { // w can, b left castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 8];
- [BlackPawnMoveDbl -> 8];
- [BlackPawnBeat -> 8];
- [BlackPawnBeatPromote -> 8];
- [BlackPawnBeatLDbl -> 8];
- [BlackPawnBeatRDbl -> 8];
- [BlackPawnPromote -> 8];
- [BlackKnight -> 8];
- [BlackBishop -> 8];
- [BlackRook -> 8];
- [BlackRookA8 -> 24];
- [BlackRookH8 -> 8];
- [BlackQueen -> 8];
- [BlackLeftCastle -> 24];
- [BlackKing -> 24]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 10 { // w left, b left castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 11];
- [WhitePawnMoveDbl -> 11];
- [WhitePawnBeat -> 11];
- [WhitePawnBeatPromote -> 11];
- [WhitePawnBeatLDbl -> 11];
- [WhitePawnBeatRDbl -> 11];
- [WhitePawnPromote -> 11];
- [WhiteKnight -> 11];
- [WhiteBishop -> 11];
- [WhiteRook -> 11];
- [WhiteRookA1 -> 15];
- [WhiteRookH1 -> 11];
- [WhiteQueen -> 11];
- [WhiteLeftCastle -> 15];
- [WhiteKing -> 15]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 11 { // w left, b left castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 10];
- [BlackPawnMoveDbl -> 10];
- [BlackPawnBeat -> 10];
- [BlackPawnBeatPromote -> 10];
- [BlackPawnBeatLDbl -> 10];
- [BlackPawnBeatRDbl -> 10];
- [BlackPawnPromote -> 10];
- [BlackKnight -> 10];
- [BlackBishop -> 10];
- [BlackRook -> 10];
- [BlackRookA8 -> 26];
- [BlackRookH8 -> 10];
- [BlackQueen -> 10];
- [BlackLeftCastle -> 26];
- [BlackKing -> 26]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 12 { // w right, b left castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 13];
- [WhitePawnMoveDbl -> 13];
- [WhitePawnBeat -> 13];
- [WhitePawnBeatPromote -> 13];
- [WhitePawnBeatLDbl -> 13];
- [WhitePawnBeatRDbl -> 13];
- [WhitePawnPromote -> 13];
- [WhiteKnight -> 13];
- [WhiteBishop -> 13];
- [WhiteRook -> 13];
- [WhiteRookA1 -> 13];
- [WhiteRookH1 -> 15];
- [WhiteQueen -> 13];
- [WhiteRightCastle -> 15];
- [WhiteKing -> 15]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 13 { // w right, b left castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 12];
- [BlackPawnMoveDbl -> 12];
- [BlackPawnBeat -> 12];
- [BlackPawnBeatPromote -> 12];
- [BlackPawnBeatLDbl -> 12];
- [BlackPawnBeatRDbl -> 12];
- [BlackPawnPromote -> 12];
- [BlackKnight -> 12];
- [BlackBishop -> 12];
- [BlackRook -> 12];
- [BlackRookA8 -> 28];
- [BlackRookH8 -> 12];
- [BlackQueen -> 12];
- [BlackLeftCastle -> 28];
- [BlackKing -> 28]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 14 { // w no, b left castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 15];
- [WhitePawnMoveDbl -> 15];
- [WhitePawnBeat -> 15];
- [WhitePawnBeatPromote -> 15];
- [WhitePawnBeatLDbl -> 15];
- [WhitePawnBeatRDbl -> 15];
- [WhitePawnPromote -> 15];
- [WhiteKnight -> 15];
- [WhiteBishop -> 15];
- [WhiteRook -> 15];
- [WhiteRookA1 -> 15];
- [WhiteRookH1 -> 15];
- [WhiteQueen -> 15];
- [WhiteKing -> 15]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 15 { // w no, b left castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 14];
- [BlackPawnMoveDbl -> 14];
- [BlackPawnBeat -> 14];
- [BlackPawnBeatPromote -> 14];
- [BlackPawnBeatLDbl -> 14];
- [BlackPawnBeatRDbl -> 14];
- [BlackPawnPromote -> 14];
- [BlackKnight -> 14];
- [BlackBishop -> 14];
- [BlackRook -> 14];
- [BlackRookA8 -> 30];
- [BlackRookH8 -> 14];
- [BlackQueen -> 14];
- [BlackLeftCastle -> 30];
- [BlackKing -> 30]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 16 { // w can, b right castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 17];
- [WhitePawnMoveDbl -> 17];
- [WhitePawnBeat -> 17];
- [WhitePawnBeatPromote -> 17];
- [WhitePawnBeatLDbl -> 17];
- [WhitePawnBeatRDbl -> 17];
- [WhitePawnPromote -> 17];
- [WhiteKnight -> 17];
- [WhiteBishop -> 17];
- [WhiteRook -> 17];
- [WhiteRookA1 -> 21];
- [WhiteRookH1 -> 19];
- [WhiteQueen -> 17];
- [WhiteLeftCastle -> 23];
- [WhiteRightCastle -> 23];
- [WhiteKing -> 23]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 17 { // w can, b right castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 16];
- [BlackPawnMoveDbl -> 16];
- [BlackPawnBeat -> 16];
- [BlackPawnBeatPromote -> 16];
- [BlackPawnBeatLDbl -> 16];
- [BlackPawnBeatRDbl -> 16];
- [BlackPawnPromote -> 16];
- [BlackKnight -> 16];
- [BlackBishop -> 16];
- [BlackRook -> 16];
- [BlackRookA8 -> 16];
- [BlackRookH8 -> 24];
- [BlackQueen -> 16];
- [BlackRightCastle -> 24];
- [BlackKing -> 24]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 18 { // w left, b right castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 19];
- [WhitePawnMoveDbl -> 19];
- [WhitePawnBeat -> 19];
- [WhitePawnBeatPromote -> 19];
- [WhitePawnBeatLDbl -> 19];
- [WhitePawnBeatRDbl -> 19];
- [WhitePawnPromote -> 19];
- [WhiteKnight -> 19];
- [WhiteBishop -> 19];
- [WhiteRook -> 19];
- [WhiteRookA1 -> 23];
- [WhiteRookH1 -> 19];
- [WhiteQueen -> 19];
- [WhiteLeftCastle -> 23];
- [WhiteKing -> 23]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 19 { // w left, b right castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 18];
- [BlackPawnMoveDbl -> 18];
- [BlackPawnBeat -> 18];
- [BlackPawnBeatPromote -> 18];
- [BlackPawnBeatLDbl -> 18];
- [BlackPawnBeatRDbl -> 18];
- [BlackPawnPromote -> 18];
- [BlackKnight -> 18];
- [BlackBishop -> 18];
- [BlackRook -> 18];
- [BlackRookA8 -> 18];
- [BlackRookH8 -> 26];
- [BlackQueen -> 18];
- [BlackRightCastle -> 26];
- [BlackKing -> 26]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 20 { // w right, b right castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 21];
- [WhitePawnMoveDbl -> 21];
- [WhitePawnBeat -> 21];
- [WhitePawnBeatPromote -> 21];
- [WhitePawnBeatLDbl -> 21];
- [WhitePawnBeatRDbl -> 21];
- [WhitePawnPromote -> 21];
- [WhiteKnight -> 21];
- [WhiteBishop -> 21];
- [WhiteRook -> 21];
- [WhiteRookA1 -> 21];
- [WhiteRookH1 -> 23];
- [WhiteQueen -> 21];
- [WhiteRightCastle -> 23];
- [WhiteKing -> 23]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 21 { // w right, b right castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 20];
- [BlackPawnMoveDbl -> 20];
- [BlackPawnBeat -> 20];
- [BlackPawnBeatPromote -> 20];
- [BlackPawnBeatLDbl -> 20];
- [BlackPawnBeatRDbl -> 20];
- [BlackPawnPromote -> 20];
- [BlackKnight -> 20];
- [BlackBishop -> 20];
- [BlackRook -> 20];
- [BlackRookA8 -> 20];
- [BlackRookH8 -> 28];
- [BlackQueen -> 20];
- [BlackRightCastle -> 28];
- [BlackKing -> 28]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 22 { // w no, b right castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 23];
- [WhitePawnMoveDbl -> 23];
- [WhitePawnBeat -> 23];
- [WhitePawnBeatPromote -> 23];
- [WhitePawnBeatLDbl -> 23];
- [WhitePawnBeatRDbl -> 23];
- [WhitePawnPromote -> 23];
- [WhiteKnight -> 23];
- [WhiteBishop -> 23];
- [WhiteRook -> 23];
- [WhiteRookA1 -> 23];
- [WhiteRookH1 -> 23];
- [WhiteQueen -> 23];
- [WhiteKing -> 23]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 23 { // w no, b right castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 22];
- [BlackPawnMoveDbl -> 22];
- [BlackPawnBeat -> 22];
- [BlackPawnBeatPromote -> 22];
- [BlackPawnBeatLDbl -> 22];
- [BlackPawnBeatRDbl -> 22];
- [BlackPawnPromote -> 22];
- [BlackKnight -> 22];
- [BlackBishop -> 22];
- [BlackRook -> 22];
- [BlackRookA8 -> 22];
- [BlackRookH8 -> 30];
- [BlackQueen -> 22];
- [BlackRightCastle -> 30];
- [BlackKing -> 30]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 24 { // w can, b no castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 25];
- [WhitePawnMoveDbl -> 25];
- [WhitePawnBeat -> 25];
- [WhitePawnBeatPromote -> 25];
- [WhitePawnBeatLDbl -> 25];
- [WhitePawnBeatRDbl -> 25];
- [WhitePawnPromote -> 25];
- [WhiteKnight -> 25];
- [WhiteBishop -> 25];
- [WhiteRook -> 25];
- [WhiteRookA1 -> 29];
- [WhiteRookH1 -> 27];
- [WhiteQueen -> 25];
- [WhiteLeftCastle -> 31];
- [WhiteRightCastle -> 31];
- [WhiteKing -> 31]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 25 { // w can, b no castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 24];
- [BlackPawnMoveDbl -> 24];
- [BlackPawnBeat -> 24];
- [BlackPawnBeatPromote -> 24];
- [BlackPawnBeatLDbl -> 24];
- [BlackPawnBeatRDbl -> 24];
- [BlackPawnPromote -> 24];
- [BlackKnight -> 24];
- [BlackBishop -> 24];
- [BlackRook -> 24];
- [BlackRookA8 -> 24];
- [BlackRookH8 -> 24];
- [BlackQueen -> 24];
- [BlackKing -> 24]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 26 { // w left, b no castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 27];
- [WhitePawnMoveDbl -> 27];
- [WhitePawnBeat -> 27];
- [WhitePawnBeatPromote -> 27];
- [WhitePawnBeatLDbl -> 27];
- [WhitePawnBeatRDbl -> 27];
- [WhitePawnPromote -> 27];
- [WhiteKnight -> 27];
- [WhiteBishop -> 27];
- [WhiteRook -> 27];
- [WhiteRookA1 -> 31];
- [WhiteRookH1 -> 27];
- [WhiteQueen -> 27];
- [WhiteLeftCastle -> 31];
- [WhiteKing -> 31]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 27 { // w left, b no castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 26];
- [BlackPawnMoveDbl -> 26];
- [BlackPawnBeat -> 26];
- [BlackPawnBeatPromote -> 26];
- [BlackPawnBeatLDbl -> 26];
- [BlackPawnBeatRDbl -> 26];
- [BlackPawnPromote -> 26];
- [BlackKnight -> 26];
- [BlackBishop -> 26];
- [BlackRook -> 26];
- [BlackRookA8 -> 26];
- [BlackRookH8 -> 26];
- [BlackQueen -> 26];
- [BlackKing -> 26]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 28 { // w right, b no castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 29];
- [WhitePawnMoveDbl -> 29];
- [WhitePawnBeat -> 29];
- [WhitePawnBeatPromote -> 29];
- [WhitePawnBeatLDbl -> 29];
- [WhitePawnBeatRDbl -> 29];
- [WhitePawnPromote -> 29];
- [WhiteKnight -> 29];
- [WhiteBishop -> 29];
- [WhiteRook -> 29];
- [WhiteRookA1 -> 29];
- [WhiteRookH1 -> 31];
- [WhiteQueen -> 29];
- [WhiteRightCastle -> 31];
- [WhiteKing -> 31]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 29 { // w right, b no castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 28];
- [BlackPawnMoveDbl -> 28];
- [BlackPawnBeat -> 28];
- [BlackPawnBeatPromote -> 28];
- [BlackPawnBeatLDbl -> 28];
- [BlackPawnBeatRDbl -> 28];
- [BlackPawnPromote -> 28];
- [BlackKnight -> 28];
- [BlackBishop -> 28];
- [BlackRook -> 28];
- [BlackRookA8 -> 28];
- [BlackRookH8 -> 28];
- [BlackQueen -> 28];
- [BlackKing -> 28]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-LOC 30 { // w no, b no castle
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 31];
- [WhitePawnMoveDbl -> 31];
- [WhitePawnBeat -> 31];
- [WhitePawnBeatPromote -> 31];
- [WhitePawnBeatLDbl -> 31];
- [WhitePawnBeatRDbl -> 31];
- [WhitePawnPromote -> 31];
- [WhiteKnight -> 31];
- [WhiteBishop -> 31];
- [WhiteRook -> 31];
- [WhiteRookA1 -> 31];
- [WhiteRookH1 -> 31];
- [WhiteQueen -> 31];
- [WhiteKing -> 31]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 31 { // w no, b no castle
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 30];
- [BlackPawnMoveDbl -> 30];
- [BlackPawnBeat -> 30];
- [BlackPawnBeatPromote -> 30];
- [BlackPawnBeatLDbl -> 30];
- [BlackPawnBeatRDbl -> 30];
- [BlackPawnPromote -> 30];
- [BlackKnight -> 30];
- [BlackBishop -> 30];
- [BlackRook -> 30];
- [BlackRookA8 -> 30];
- [BlackRookH8 -> 30];
- [BlackQueen -> 30];
- [BlackKing -> 30]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
MODEL [ | | ] \"
... ... ... ...
bR bN.bB bQ.bK bB.bN bR.
@@ -1215,7 +433,15 @@
wR.wN wB.wQ wK.wB wN.wR
\" with
D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
-D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )
+D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) ) ;
+IsFirst(x) = not ex z C(z, x) ;
+IsSecond(x) = ex y (C(y, x) and IsFirst(y)) ;
+IsEight(x) = not ex z C(x, z) ;
+IsSeventh(x) = ex y (C(x, y) and IsEight(y)) ;
+IsA1(x) = not ex z R(z, x) and IsFirst(x) ;
+IsH1(x) = not ex z R(x, z) and IsFirst(x) ;
+IsA8(x) = not ex z R(z, x) and IsEight(x) ;
+IsH8(x) = not ex z R(x, z) and IsEight(x)
")
let connect4_str = ("PLAYERS 1, 2
@@ -1536,20 +762,10 @@
let checkers_str = ("
PLAYERS 1, 2
DATA depth: 4, adv_ratio: 2
-REL IsFirst(x) = not ex z C(z, x)
-REL IsEight(x) = not ex z C(x, z)
REL w(x) = W(x) or Wq(x)
REL b(x) = B(x) or Bq(x)
-REL DiagWa (x, y) = ex z (C(x, z) and R(y, z))
-REL DiagBa (x, y) = ex z (C(z, x) and R(z, y))
-REL DiagWb (x, y) = ex z (C(x, z) and R(z, y))
-REL DiagBb (x, y) = ex z (C(z, x) and R(y, z))
REL AnyDiag (x, y) =
DiagWa (x, y) or DiagWb (x, y) or DiagBa (x, y) or DiagBb (x, y)
-REL DiagW2 (x, y, z) =
- (DiagWa (x, y) and DiagWa (y, z)) or (DiagWb (x, y) and DiagWb (y, z))
-REL DiagB2 (x, y, z) =
- (DiagBa (x, y) and DiagBa (y, z)) or (DiagBb (x, y) and DiagBb (y, z))
REL Diag2 (x, y, z) = DiagW2 (x, y, z) or DiagB2 (x, y, z)
REL BeatsW (x, y) = ex z (b(z) and not b(y) and not w(y) and DiagW2 (x, z, y))
REL BeatsWX (x, y) = ex z (b(z) and not b(y) and not w(y) and Diag2 (x, z, y))
@@ -1680,7 +896,17 @@
W.. W.. W.. W..
... ... ... ...
W.. W.. W.. W..
-\"
+\" with
+IsFirst(x) = not ex z C(z, x) ;
+IsEight(x) = not ex z C(x, z) ;
+DiagWa (x, y) = ex z (C(x, z) and R(y, z)) ;
+DiagBa (x, y) = ex z (C(z, x) and R(z, y)) ;
+DiagWb (x, y) = ex z (C(x, z) and R(z, y)) ;
+DiagBb (x, y) = ex z (C(z, x) and R(y, z)) ;
+DiagW2 (x, y, z) =
+ (DiagWa (x, y) and DiagWa (y, z)) or (DiagWb (x, y) and DiagWb (y, z)) ;
+DiagB2 (x, y, z) =
+ (DiagBa (x, y) and DiagBa (y, z)) or (DiagBb (x, y) and DiagBb (y, z))
")
let gomoku_str = ("
Modified: trunk/Toss/Server/JsHandler.ml
===================================================================
--- trunk/Toss/Server/JsHandle...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-11 22:16:44
|
Revision: 1673
http://toss.svn.sourceforge.net/toss/?rev=1673&view=rev
Author: lukaszkaiser
Date: 2012-02-11 22:16:36 +0000 (Sat, 11 Feb 2012)
Log Message:
-----------
Moving WebClient to Client, first JS unit test with phantomjs, correcting Client bug for WebKit, describing compilation on OSX.
Modified Paths:
--------------
trunk/Toss/.cvsignore
trunk/Toss/Client/JsHandler.js
trunk/Toss/Client/Local.js
trunk/Toss/Client/State.js
trunk/Toss/Client/index.html
trunk/Toss/Makefile
trunk/Toss/README
trunk/Toss/www/develop.xml
Added Paths:
-----------
trunk/Toss/Client/
trunk/Toss/Client/GameSelection.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Makefile
trunk/Toss/Client/clientTest.js
Removed Paths:
-------------
trunk/Toss/Server/GameSelection.ml
trunk/Toss/Server/JsHandler.ml
trunk/Toss/WebClient/
Property Changed:
----------------
trunk/Toss/
Property changes on: trunk/Toss
___________________________________________________________________
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 .
Toss.docdir
_build
TossServer
*.native
*Profile.log
gmon.out
*~
*.annot
*.cmx
*.cmi
*.o
*.cmo
*.a
*.cmxa
log.*
+ # 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 .
Toss.docdir
_build
TossServer
*.native
*.byte
*Profile.log
gmon.out
*~
*.annot
*.cmx
*.cmi
*.o
*.cmo
*.a
*.cmxa
log.*
Modified: trunk/Toss/.cvsignore
===================================================================
--- trunk/Toss/.cvsignore 2012-02-10 02:21:07 UTC (rev 1672)
+++ trunk/Toss/.cvsignore 2012-02-11 22:16:36 UTC (rev 1673)
@@ -6,6 +6,7 @@
_build
TossServer
*.native
+*.byte
*Profile.log
gmon.out
*~
Copied: trunk/Toss/Client/GameSelection.ml (from rev 1672, trunk/Toss/Server/GameSelection.ml)
===================================================================
--- trunk/Toss/Client/GameSelection.ml (rev 0)
+++ trunk/Toss/Client/GameSelection.ml 2012-02-11 22:16:36 UTC (rev 1673)
@@ -0,0 +1,1065 @@
+(* 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 *)
+ playclock : int; (** playclock *)
+ game_str : string; (** game representation *)
+}
+
+let compute_heuristic advr (game, state) =
+ let pat_arr = Array.of_list game.Arena.patterns in
+ let pl_heur l =
+ let len = List.length l.Arena.heur in
+ if len = 0 || len > Array.length pat_arr then raise Not_found else
+ let add_pat (i, h) pw =
+ let pat = Formula.Times (Formula.Const pw, pat_arr.(i)) in
+ (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
+ res
+ with Not_found ->
+ Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
+
+let compile_game_data game_name game_str =
+ let (game, game_state as game_with_state) =
+ ArenaParser.parse_game_state Lexer.lex (Lexing.from_string game_str) in
+ let adv_ratio =
+ try Some (float_of_string (List.assoc "adv_ratio" game.Arena.data))
+ with Not_found -> None in
+ let heuristic = compute_heuristic adv_ratio game_with_state in
+ game_name,
+ {heuristic = heuristic;
+ game_state = game_with_state;
+ playclock = 30; (* game clock from where? *)
+ game_str = game_str;
+ }
+
+
+let chess_str = ("
+PLAYERS 1, 2
+DATA depth: 0, adv_ratio: 1
+SET Sum (x | wP(x) : 1)
+SET Sum (x | wR(x) : 1)
+SET Sum (x | wN(x) : 1)
+SET Sum (x | wB(x) : 1)
+SET Sum (x | wQ(x) : 1)
+SET Sum (x | bP(x) : 1)
+SET Sum (x | bR(x) : 1)
+SET Sum (x | bN(x) : 1)
+SET Sum (x | bB(x) : 1)
+SET Sum (x | bQ(x) : 1)
+SET Sum (x | wBeats(x) : 1 + :(b(x)) + 3 * :(bK(x)))
+SET Sum (x | bBeats(x) : 1 + :(w(x)) + 3 * :(wK(x)))
+REL w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x)
+REL b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x)
+REL DoubleC(x, y) = ex z ((C(x, z) and C(z, y)) or (C(y, z) and C(z, x)))
+REL DoubleR(x, y) = ex z ((R(x, z) and R(z, y)) or (R(y, z) and R(z, x)))
+REL KnightRCC(x, y) = ex z ((R(x, z) or R(z, x)) and DoubleC(z, y))
+REL KnightCRR(x, y) = ex z ((C(x, z) or C(z, x)) and DoubleR(z, y))
+REL Knight(x, y) = KnightRCC(x, y) or KnightCRR(x, y)
+REL FreeD1 (x, y) = tc x, y (D1 (x, y) and not w(y) and not b(y))
+REL FreeD2 (x, y) = tc x, y (D2 (x, y) and not w(y) and not b(y))
+REL Diag1 (x, y) = ex z (FreeD1 (x, z) and (z = y or D1 (z, y)))
+REL Diag2 (x, y) = ex z (FreeD2 (x, z) and (z = y or D2 (z, y)))
+REL Diag (x, y) = Diag1 (x, y) or Diag2 (x, y)
+REL FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not b(y))
+REL FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not b(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 Near (x, y) = C(x,y) or C(y,x) or R(x,y) or R(y,x) or D1(x, y) or D2(x, y)
+REL wPBeats (x) = ex y (wP(y) and ex z ((R(y, z) or R(z, y)) and C(z, x)))
+REL bPBeats (x) = ex y (bP(y) and ex z ((R(y, z) or R(z, y)) and C(x, z)))
+REL wDiagBeats (x) = ex y ((wQ(y) or wB(y)) and Diag(y, x))
+REL bDiagBeats (x) = ex y ((bQ(y) or bB(y)) and Diag(y, x))
+REL wLineBeats (x) = ex y ((wQ(y) or wR(y)) and Line(y, x))
+REL bLineBeats (x) = ex y ((bQ(y) or bR(y)) and Line(y, x))
+REL wFigBeats(x) = wDiagBeats(x) or wLineBeats(x) or ex y(wN(y) and Knight(y,x))
+REL bFigBeats(x) = bDiagBeats(x) or bLineBeats(x) or ex y(bN(y) and Knight(y,x))
+REL wBeats(x) = wFigBeats(x) or wPBeats(x) or ex y (wK(y) and Near(y, x))
+REL bBeats(x) = bFigBeats(x) or bPBeats(x) or ex y (bK(y) and Near(y, x))
+REL CheckW() = ex x (wK(x) and bBeats(x))
+REL CheckB() = ex x (bK(x) and wBeats(x))
+RULE WhitePawnMove:
+ [ | | ] \"
+ ...
+ ...
+
+ wP
+\" -> [ | | ] \"
+ ...
+ wP
+
+ .
+\" emb w, b pre not IsEight(a2) post not CheckW()
+RULE BlackPawnMove:
+ [ | | ] \"
+ ...
+ bP.
+
+ .
+\" -> [ | | ] \"
+ ...
+ ...
+
+ bP
+\" emb w, b pre not IsFirst(a1) post not CheckB()
+RULE WhitePawnMoveDbl:
+ [ | | ] \"
+
+ .
+ ...
+ ...
+
+ wP
+\" -> [ | | ] \"
+ ...
+ wP
+
+ .
+ ...
+ ...
+\" emb w, b pre IsSecond(a1) post not CheckW()
+RULE BlackPawnMoveDbl:
+ [ | | ] \"
+ ...
+ bP.
+
+ .
+ ...
+ ...
+\" -> [ | | ] \"
+
+
+ ...
+ ...
+
+ bP
+\" emb w, b pre IsSeventh(a3) post not CheckB()
+RULE WhitePawnBeat:
+ [ a, b | wP { a }; b { b } | - ]
+ ->
+ [ a, b | wP { b } | - ]
+ emb w, b
+ pre not IsEight(b) and ex z (C(a, z) and (R(z, b) or R(b, z)))
+ post not CheckW()
+RULE WhitePawnBeatPromote:
+ [ a, b | wP { a }; b { b } | - ]
+ ->
+ [ a, b | wQ { b } | - ]
+ emb w, b
+ pre IsEight(b) and ex z (C(a, z) and (R(z, b) or R(b, z)))
+ post not CheckW()
+RULE WhitePawnBeatRDbl:
+ [ | | ] \"
+ ...
+ ?..-bP
+ ...
+ ? ...
+ ...
+ wP.bP
+\" -> [ | | ] \"
+ ...
+ ?...
+ ...
+ ? wP.
+ ...
+ ....
+\" emb w, b post not CheckW()
+RULE WhitePawnBeatLDbl:
+ [ | | ] \"
+ ...
+ -bP?
+ ...
+ . ?..
+ ...
+ bP.wP
+\" -> [ | | ] \"
+ ...
+ ...?
+ ...
+ wP ?..
+ ...
+ ....
+\" emb w, b post not CheckW()
+RULE BlackPawnBeat:
+ [ a, b | bP { a }; w { b } | - ]
+ ->
+ [ a, b | bP { b } | - ]
+ emb w, b
+ pre not IsFirst(b) and ex z (C(z, a) and (R(z, b) or R(b, z)))
+ post not CheckB()
+RULE BlackPawnBeatPromote:
+ [ a, b | bP { a }; w { b } | - ]
+ ->
+ [ a, b | bQ { b } | - ]
+ emb w, b
+ pre IsFirst(b) and ex z (C(z, a) and (R(z, b) or R(b, z)))
+ post not CheckB()
+RULE BlackPawnBeatRDbl:
+ [ | | ] \"
+ ...
+ bP.wP
+ ...
+ ? ...
+ ...
+ ?..-wP
+\" -> [ | | ] \"
+ ...
+ ....
+ ...
+ ? bP.
+ ...
+ ?...
+\" emb w, b post not CheckB()
+RULE BlackPawnBeatLDbl:
+ [ | | ] \"
+ ...
+ wP.bP
+ ...
+ . ?..
+ ...
+ -wP?
+\" -> [ | | ] \"
+ ...
+ ....
+ ...
+ bP ?..
+ ...
+ ...?
+\" emb w, b post not CheckB()
+RULE WhitePawnPromote:
+ [ | | ] \"
+ ...
+ ...
+
+ wP
+\" -> [ | | ] \"
+ ...
+ wQ.
+
+ .
+\" emb w, b pre IsEight(a2) post not CheckW()
+RULE BlackPawnPromote:
+ [ | | ] \"
+ ...
+ bP.
+
+ .
+\" -> [ | | ] \"
+ ...
+ ...
+
+ bQ
+\" emb w, b pre IsFirst(a1) post not CheckB()
+RULE WhiteKnight:
+ [ a, b | wN { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wN { b } | - ]
+ emb w, b pre Knight(a, b) post not CheckW()
+RULE BlackKnight:
+ [ a, b | bN { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bN { b } | - ]
+ emb w, b pre Knight(a, b) post not CheckB()
+RULE WhiteBishop:
+ [ a, b | wB { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wB { b } | - ]
+ emb w, b pre Diag(a, b) post not CheckW()
+RULE BlackBishop:
+ [ a, b | bB { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bB { b } | - ]
+ emb w, b pre Diag(a, b) post not CheckB()
+RULE WhiteRook:
+ [ a, b | wR { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wR { b } | - ]
+ emb w, b pre not IsA1(a) and not IsH1(a) and Line(a, b) post not CheckW()
+RULE WhiteRookA1:
+ [ a, b | wR { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wR { b } | - ]
+ emb w, b pre IsA1(a) and Line(a, b) post not CheckW()
+RULE WhiteRookH1:
+ [ a, b | wR { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wR { b } | - ]
+ emb w, b pre IsH1(a) and Line(a, b) post not CheckW()
+RULE BlackRook:
+ [ a, b | bR { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bR { b } | - ]
+ emb w, b pre not IsA8(a) and not IsH8(a) and Line(a, b) post not CheckB()
+RULE BlackRookA8:
+ [ a, b | bR { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bR { b } | - ]
+ emb w, b pre IsA8(a) and Line(a, b) post not CheckB()
+RULE BlackRookH8:
+ [ a, b | bR { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bR { b } | - ]
+ emb w, b pre IsH8(a) and Line(a, b) post not CheckB()
+RULE WhiteQueen:
+ [ a, b | wQ { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wQ { b } | - ]
+ emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW()
+RULE BlackQueen:
+ [ a, b | bQ { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bQ { b } | - ]
+ emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB()
+RULE WhiteKing:
+ [ a, b | wK { a }; _opt_b { b } | - ]
+ ->
+ [ a, b | wK { b } | - ]
+ emb w, b pre Near(a, b) post not CheckW()
+RULE BlackKing:
+ [ a, b | bK { a }; _opt_w { b } | - ]
+ ->
+ [ a, b | bK { b } | - ]
+ emb w, b pre Near(a, b) post not CheckB()
+RULE WhiteLeftCastle:
+ [ | | ] \"
+ ... ... ...
+ wR. ... wK.
+\" -> [ | | ] \"
+ ... ... ...
+ ... wK.wR ...
+\" emb w,b pre not(bBeats(c1) or bBeats(d1) or bBeats(e1)) and before
+ not WhiteRookA1, not WhiteKing, not WhiteLeftCastle, not WhiteRightCastle
+RULE WhiteRightCastle:
+ [ | | ] \"
+ ... ...
+ wK. ...wR
+\" -> [ | | ] \"
+ ... ...
+ ...wR wK.
+\" emb w,b pre not (bBeats(a1) or bBeats(b1) or bBeats(c1)) and before
+ not WhiteRookH1, not WhiteKing, not WhiteLeftCastle, not WhiteRightCastle
+RULE BlackLeftCastle:
+ [ | | ] \"
+ ... ... ...
+ bR. ... bK.
+\" -> [ | | ] \"
+ ... ... ...
+ ... bK.bR ...
+\" emb w,b pre not(wBeats(c1) or wBeats(d1) or wBeats(e1)) and before
+ not BlackRookA8, not BlackKing, not BlackLeftCastle, not BlackRightCastle
+RULE BlackRightCastle:
+ [ | | ] \"
+ ... ...
+ bK. ...bR
+\" -> [ | | ] \"
+ ... ...
+ ...bR bK.
+\" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) and before
+ not BlackRookH8, not BlackKing, not BlackLeftCastle, not BlackRightCastle
+LOC 0 {
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
+ PAYOFF :(CheckB()) - :(CheckW())
+ MOVES
+ [WhitePawnMove -> 1];
+ [WhitePawnMoveDbl -> 1];
+ [WhitePawnBeat -> 1];
+ [WhitePawnBeatPromote -> 1];
+ [WhitePawnBeatLDbl -> 1];
+ [WhitePawnBeatRDbl -> 1];
+ [WhitePawnPromote -> 1];
+ [WhiteKnight -> 1];
+ [WhiteBishop -> 1];
+ [WhiteRook -> 1];
+ [WhiteRookA1 -> 1];
+ [WhiteRookH1 -> 1];
+ [WhiteQueen -> 1];
+ [WhiteLeftCastle -> 1];
+ [WhiteRightCastle -> 1];
+ [WhiteKing -> 1]
+ }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
+}
+LOC 1 {
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
+ PAYOFF :(CheckW()) - :(CheckB())
+ MOVES
+ [BlackPawnMove -> 0];
+ [BlackPawnMoveDbl -> 0];
+ [BlackPawnBeat -> 0];
+ [BlackPawnBeatPromote -> 0];
+ [BlackPawnBeatLDbl -> 0];
+ [BlackPawnBeatRDbl -> 0];
+ [BlackPawnPromote -> 0];
+ [BlackKnight -> 0];
+ [BlackBishop -> 0];
+ [BlackRook -> 0];
+ [BlackRookA8 -> 0];
+ [BlackRookH8 -> 0];
+ [BlackQueen -> 0];
+ [BlackLeftCastle -> 0];
+ [BlackRightCastle -> 0];
+ [BlackKing -> 0]
+ }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
+}
+MODEL [ | | ] \"
+ ... ... ... ...
+ bR bN.bB bQ.bK bB.bN bR.
+ ... ... ... ...
+ bP.bP bP.bP bP.bP bP.bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ wP wP.wP wP.wP wP.wP wP.
+ ... ... ... ...
+ wR.wN wB.wQ wK.wB wN.wR
+\" with
+D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
+D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) ) ;
+IsFirst(x) = not ex z C(z, x) ;
+IsSecond(x) = ex y (C(y, x) and IsFirst(y)) ;
+IsEight(x) = not ex z C(x, z) ;
+IsSeventh(x) = ex y (C(x, y) and IsEight(y)) ;
+IsA1(x) = not ex z R(z, x) and IsFirst(x) ;
+IsH1(x) = not ex z R(x, z) and IsFirst(x) ;
+IsA8(x) = not ex z R(z, x) and IsEight(x) ;
+IsH8(x) = not ex z R(x, z) and IsEight(x)
+")
+
+let connect4_str = ("PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 4, depth: 6
+REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v)
+REL Col4 (x, y, z, v) = C(x, y) and C(y, z) and C(z, v)
+REL DiagA4 (x, y, z, v) = DiagA(x, y) and DiagA(y, z) and DiagA(z, v)
+REL DiagB4 (x, y, z, v) = DiagB(x, y) and DiagB(y, z) and DiagB(z, v)
+REL Conn4 (x, y, z, v) =
+ Row4(x,y,z,v) or Col4(x,y,z,v) or DiagA4(x,y,z,v) or DiagB4(x,y,z,v)
+REL WinQ() =
+ ex x,y,z,v (Q(x) and Q(y) and Q(z) and Q(v) and Conn4(x, y, z, v))
+REL WinP() =
+ ex x,y,z,v (P(x) and P(y) and P(z) and P(v) and Conn4(x, y, z, v))
+REL EmptyUnder (x) = ex y (C(y, x) and not P(y) and not Q(y))
+RULE Cross:
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P
+ pre not EmptyUnder (a) and not WinQ()
+RULE Circle:
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P
+ pre not EmptyUnder (a) and not WinP()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
+ }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ }
+}
+LOC 1 {
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))
+")
+
+let pawn_whopping_str = ("
+PLAYERS 1, 2
+DATA depth: 4, adv_ratio: 2
+REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
+REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
+REL IsFirst(x) = not ex z C(z, x)
+REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
+REL IsEight(x) = not ex z C(x, z)
+REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
+REL WhiteEnds() = (ex x (wP(x) and not ex y C(x, y))) or (not ex z bP(z))
+REL BlackEnds() = (ex x (bP(x) and not ex y C(y, x))) or (not ex z wP(z))
+RULE WhiteBeat:
+ [ a, b | wP { a }; bP { b } | - ] -> [ a, b | wP { b } | - ] emb wP, bP
+ pre DiagW(a, b) and not BlackEnds()
+RULE WhiteMove:
+ [ | bP:1 {}; R:2 {} | ] \"
+
+ .
+
+ wP
+\" -> [ | bP:1 {}; R:2 {} | ] \"
+
+ wP
+
+ .
+\" emb wP, bP pre not BlackEnds()
+RULE WhiteMoveTwo:
+ [ | bP:1 {}; R:2 {} | ] \"
+
+ .
+
+ .
+
+ wP
+\" -> [ | bP:1 {}; R:2 {} | ] \"
+
+ wP
+
+ .
+
+ .
+\" emb wP, bP pre IsSecond(a1) and not BlackEnds()
+RULE WhiteRightPassant:
+ [ | | ] \"
+ ...
+ ?..-bP
+ ...
+ ? ...
+ ...
+ wP.bP
+\" -> [ | | ] \"
+ ...
+ ?...
+ ...
+ ? wP.
+ ...
+ ....
+\" emb wP, bP pre not BlackEnds()
+RULE WhiteLeftPassant:
+ [ | | ] \"
+ ...
+ -bP?
+ ...
+ . ?..
+ ...
+ bP.wP
+\" -> [ | | ] \"
+ ...
+ ...?
+ ...
+ wP ?..
+ ...
+ ....
+\" emb wP, bP pre not BlackEnds()
+RULE BlackBeat:
+ [ a, b | bP { a }; wP { b } | - ] -> [ a, b | bP { b } | - ] emb wP, bP
+ pre DiagB(a, b) and not WhiteEnds()
+RULE BlackMove:
+ [ | R:2 {}; wP:1 {} | ] \"
+
+ bP
+
+ .
+\" -> [ | R:2 {}; wP:1 {} | ] \"
+
+ .
+
+ bP
+\" emb wP, bP pre not WhiteEnds()
+RULE BlackMoveTwo:
+ [ | R:2 {}; wP:1 {} | ] \"
+
+ bP
+
+ .
+
+ .
+\" -> [ | R:2 {}; wP:1 {} | ] \"
+
+ .
+
+ .
+
+ bP
+\" emb wP, bP pre IsSeventh(a3) and not WhiteEnds()
+RULE BlackRightPassant:
+ [ | | ] \"
+ ...
+ bP.wP
+ ...
+ ? ...
+ ...
+ ?..-wP
+\" -> [ | | ] \"
+ ...
+ ....
+ ...
+ ? bP.
+ ...
+ ?...
+\" emb wP, bP pre not WhiteEnds()
+RULE BlackLeftPassant:
+ [ | | ] \"
+ ...
+ wP.bP
+ ...
+ . ?..
+ ...
+ -wP?
+\" -> [ | | ] \"
+ ...
+ ....
+ ...
+ bP ?..
+ ...
+ ...?
+\" emb wP, bP pre not WhiteEnds()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WhiteEnds()) - :(BlackEnds())
+ MOVES
+ [WhiteBeat -> 1]; [WhiteMove -> 1]; [WhiteMoveTwo -> 1];
+ [WhiteRightPassant -> 1]; [WhiteLeftPassant -> 1]
+ }
+ PLAYER 2 { PAYOFF :(BlackEnds()) - :(WhiteEnds()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WhiteEnds()) - :(BlackEnds()) }
+ PLAYER 2 {
+ PAYOFF :(BlackEnds()) - :(WhiteEnds())
+ MOVES
+ [BlackBeat -> 0]; [BlackMove -> 0]; [BlackMoveTwo -> 0];
+ [BlackRightPassant -> 0]; [BlackLeftPassant -> 0]
+ }
+}
+MODEL [ | | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ bP.bP bP.bP bP.bP bP.bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ wP wP.wP wP.wP wP.wP wP.
+ ... ... ... ...
+ ... ... ... ...
+\"
+")
+
+let breakthrough_str = ("
+PLAYERS 1, 2
+DATA depth: 2, adv_ratio: 2
+REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
+REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
+RULE WhiteDiag:
+ [ a, b | W { a }; _opt_B { b } | - ]
+ ->
+ [ a, b | W { b } | - ]
+ emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
+RULE WhiteStraight:
+ [ | B:1 {}; R:2 {} | ] \"
+
+ .
+
+ W
+\" -> [ | B:1 {}; R:2 {} |
+ ] \"
+
+ W
+
+ .
+\" emb W, B pre not ex x (B(x) and not ex y C(y, x))
+RULE BlackDiag:
+ [ a, b | B { a }; _opt_W { b } | - ]
+ ->
+ [ a, b | B { b } | - ]
+ emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
+RULE BlackStraight:
+ [ | R:2 {}; W:1 {} | ] \"
+
+ B
+
+ .
+\" -> [ | R:2 {}; W:1 {} |
+ ] \"
+
+ .
+
+ B
+\" emb W, B pre not ex x (W(x) and not ex y C(x, y))
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ MOVES
+ [WhiteDiag -> 1]; [WhiteStraight -> 1]
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ }
+}
+LOC 1 {
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ MOVES
+ [BlackDiag -> 0]; [BlackStraight -> 0]
+ }
+}
+MODEL [ | | ] \"
+ ... ... ... ...
+ B B..B B..B B..B B..
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ W..W W..W W..W W..W
+\"
+")
+
+
+let checkers_str = ("
+PLAYERS 1, 2
+DATA depth: 4, adv_ratio: 2
+REL w(x) = W(x) or Wq(x)
+REL b(x) = B(x) or Bq(x)
+REL AnyDiag (x, y) =
+ DiagWa (x, y) or DiagWb (x, y) or DiagBa (x, y) or DiagBb (x, y)
+REL Diag2 (x, y, z) = DiagW2 (x, y, z) or DiagB2 (x, y, z)
+REL BeatsW (x, y) = ex z (b(z) and not b(y) and not w(y) and DiagW2 (x, z, y))
+REL BeatsWX (x, y) = ex z (b(z) and not b(y) and not w(y) and Diag2 (x, z, y))
+REL BeatsB (x, y) = ex z (w(z) and not b(y) and not w(y) and DiagB2 (x, z, y))
+REL BeatsBX (x, y) = ex z (w(z) and not b(y) and not w(y) and Diag2 (x, z, y))
+REL BJumps() = ex x, y ((B(x) and BeatsB (x, y)) or (Bq(x) and BeatsBX (x, y)))
+REL WJumps() = ex x, y ((W(x) and BeatsW (x, y)) or (Wq(x) and BeatsWX (x, y)))
+RULE RedMove:
+ [ a, b | W { a } | - ] -> [ a, b | W { b } | - ] emb w, b
+ pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps()
+RULE WhiteMove:
+ [ a, b | B { a } | - ] -> [ a, b | B { b } | - ] emb w, b
+ pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps()
+RULE RedPromote:
+ [ a, b | W { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b
+ pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps()
+RULE WhitePromote:
+ [ a, b | B { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b
+ pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps()
+RULE RedQMove:
+ [ a, b | Wq { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b
+ pre AnyDiag (a, b) and not WJumps()
+RULE WhiteQMove:
+ [ a, b | Bq { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b
+ pre AnyDiag (a, b) and not BJumps()
+RULE RedBeat:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeat:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatBoth:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatBoth:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatPromote:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and IsEight(c)
+RULE WhiteBeatPromote:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and IsFirst(c)
+RULE RedBeatCont:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatCont:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatBothCont:
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatBothCont:
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedQBeat:
+ [ a, b, c | Wq { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b
+ pre Diag2 (a, b, c)
+RULE WhiteQBeat:
+ [ a, b, c | Bq { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
+ pre Diag2 (a, b, c)
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES
+ [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
+ [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
+ [RedBeatCont -> 2]
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
+}
+LOC 1 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
+ [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
+ [WhiteBeatCont -> 3]
+ }
+}
+LOC 2 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
+}
+LOC 3 {
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ }
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
+ }
+}
+MODEL [ | Wq:1 { }; Bq:1 { } |
+ ] \"
+ ... ... ... ...
+ B.. B.. B.. B..
+ ... ... ... ...
+ B.. B.. B.. B..
+ ... ... ... ...
+ B.. B.. B.. B..
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W.. W.. W.. W..
+ ... ... ... ...
+ W.. W.. W.. W..
+ ... ... ... ...
+ W.. W.. W.. W..
+\" with
+IsFirst(x) = not ex z C(z, x) ;
+IsEight(x) = not ex z C(x, z) ;
+DiagWa (x, y) = ex z (C(x, z) and R(y, z)) ;
+DiagBa (x, y) = ex z (C(z, x) and R(z, y)) ;
+DiagWb (x, y) = ex z (C(x, z) and R(z, y)) ;
+DiagBb (x, y) = ex z (C(z, x) and R(y, z)) ;
+DiagW2 (x, y, z) =
+ (DiagWa (x, y) and DiagWa (y, z)) or (DiagWb (x, y) and DiagWb (y, z)) ;
+DiagB2 (x, y, z) =
+ (DiagBa (x, y) and DiagBa (y, z)) or (DiagBb (x, y) and DiagBb (y, z))
+")
+
+let gomoku_str = ("
+PLAYERS 1, 2
+DATA rCircle: circle, rCross: line, adv_ratio: 5, depth: 2
+REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w)
+REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w)
+REL DiagA5 (x, y, z, v, w) =
+ DiagA(x, y) and DiagA(y, z) and DiagA(z, v) and DiagA(v, w)
+REL DiagB5 (x, y, z, v, w) =
+ DiagB(x, y) and DiagB(y, z) and DiagB(z, v) and DiagB(v, w)
+REL Conn5 (x, y, z, v, w) =
+ Row5(x,y,z,v,w) or Col5(x,y,z,v,w) or DiagA5(x,y,z,v,w) or DiagB5(x,y,z,v,w)
+REL WinQ() =
+ ex x,y,z,v,w (Q(x) and Q(y) and Q(z) and Q(v) and Q(w) and Conn5(x,y,z,v,w))
+REL WinP() =
+ ex x,y,z,v,w (P(x) and P(y) and P(z) and P(v) and P(w) and Conn5(x,y,z,v,w))
+RULE Cross:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P (a1); Q:1 {} | - ]
+ emb Q, P pre not WinQ()
+RULE Circle:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P:1 {}; Q (a1) | - ]
+ emb Q, P pre not WinP()
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
+ }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))
+")
+
+let entanglement_str = ("
+PLAYERS 1, 2
+RULE Follow:
+ [ a1, a2 | C { (a2) }; R { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ]
+ ->
+ [ a1, a2 | C { (a1) }; R { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ]
+emb R, C
+RULE Wait:
+ [ a1 | R { (a1) } |
+ vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ]
+ ->
+ [ a1 | R { (a1) } |
+ vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ]
+emb R, C
+RULE Run:
+ [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a1) }; _opt_C { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ]
+ ->
+ [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a2) }; _opt_C { (a1) } |
+ vx { a1->0., a2->0. }; vy { a1->0., a2->0. };
+ x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ]
+emb R, C
+LOC 0 {
+ PLAYER 1 {
+ PAYOFF 0.
+ MOVES [Follow -> 1]; [Wait -> 1]
+ }
+ PLAYER 2 { PAYOFF 0. }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF 1. }
+ PLAYER 2 {
+ PAYOFF -1.
+ MOVES [Run -> 0]
+ }
+ }
+MODEL [ d4, a2, a1, b1, b2, e4, c2, c1, f4, d2, d1, f1, f2, g1, g2, h1, h2, e1, e2, i1, i2 | C { (d4); (e4); (f4) }; E { (a2, a1); (a2, b2); (a1, a2); (a1, b1); (b1, a1); (b1, b2); (b1, c1); (b2, a2); (b2, b1); (b2, c2); (c2, b2); (c2, c1); (c2, d2); (c1, b1); (c1, c2); (c1, d1); (d2, c2); (d2, d1); (d2, e1); (d1, c1); (d1, d2); (d1, e2); (f1, f2); (f1, g1); (f1, e1); (f2, f1); (f2, g2); (f2, e2); (g1, f1); (g1, g2); (g1, h1); (g2, f2); (g2, g1); (g2, h2); (h1, g1); (h1, h2); (h1, i1); (h2, g2); (h2, h1); (h2, i2); (e1, d2); (e1, f1); (e1, e2); (e2, d1); (e2, f2); (e2, e1); (i1, h1); (i1, i2); (i2, h2); (i2, i1) }; R { (e1) }; _opt_C:1 { } | vx { d4->0., a2->0...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-13 03:07:28
|
Revision: 1675
http://toss.svn.sourceforge.net/toss/?rev=1675&view=rev
Author: lukaszkaiser
Date: 2012-02-13 03:07:19 +0000 (Mon, 13 Feb 2012)
Log Message:
-----------
Integrating the num library, tests update in RealQuantElim.
Modified Paths:
--------------
trunk/Toss/Formula/Sat/Makefile
trunk/Toss/Makefile
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/RealQuantElim/Makefile
trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/RealQuantElim/SignTable.ml
Added Paths:
-----------
trunk/Toss/Solver/Num/
trunk/Toss/Solver/Num/Integers.ml
trunk/Toss/Solver/Num/Integers.mli
trunk/Toss/Solver/Num/IntegersTest.ml
trunk/Toss/Solver/Num/Makefile
trunk/Toss/Solver/Num/MiscNum.ml
trunk/Toss/Solver/Num/MiscNum.mli
trunk/Toss/Solver/Num/Naturals.ml
trunk/Toss/Solver/Num/NaturalsTest.ml
trunk/Toss/Solver/Num/Numbers.ml
trunk/Toss/Solver/Num/Numbers.mli
trunk/Toss/Solver/Num/NumbersTest.ml
trunk/Toss/Solver/Num/Rationals.ml
trunk/Toss/Solver/Num/Rationals.mli
trunk/Toss/Solver/Num/RationalsTest.ml
trunk/Toss/Solver/RealQuantElim/OrderedPolySetTest.ml
trunk/Toss/Solver/RealQuantElim/OrderedPolyTest.ml
trunk/Toss/Solver/RealQuantElim/PolyTest.ml
trunk/Toss/Solver/RealQuantElim/RealQuantElimTest.ml
trunk/Toss/Solver/RealQuantElim/SignTableTest.ml
Removed Paths:
-------------
trunk/Toss/Solver/RealQuantElim/N.ml
trunk/Toss/Solver/RealQuantElim/TestOrderedPoly.ml
trunk/Toss/Solver/RealQuantElim/TestOrderedPolySet.ml
trunk/Toss/Solver/RealQuantElim/TestPoly.ml
trunk/Toss/Solver/RealQuantElim/TestRealQuantElim.ml
trunk/Toss/Solver/RealQuantElim/TestSignTable.ml
Modified: trunk/Toss/Formula/Sat/Makefile
===================================================================
--- trunk/Toss/Formula/Sat/Makefile 2012-02-11 22:40:58 UTC (rev 1674)
+++ trunk/Toss/Formula/Sat/Makefile 2012-02-13 03:07:19 UTC (rev 1675)
@@ -1,20 +1,6 @@
-MINISATDIR = minisat
+all: tests
-all: SatSolver.o MiniSATWrap.o
-
-SatSolver.o: $(MINISATDIR)/Solver.C
- if [ ! -e minisat/SatSolver.o ]; then \
- g++ -O2 -fPIC -c -I $(MINISATDIR) $(MINISATDIR)/Solver.C -o SatSolver.o; \
- mv SatSolver.o minisat/; \
- fi
-
-MiniSATWrap.o: MiniSATWrap.C
- if [ ! -e minisat/MiniSATWrap.o ]; then \
- g++ -O2 -fPIC -c -I /usr/lib/ocaml -I $(MINISATDIR) MiniSATWrap.C; \
- mv MiniSATWrap.o minisat/; \
- fi
-
%Test:
make -C ../.. Formula/Sat/$@
@@ -25,4 +11,3 @@
clean:
rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest
rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot
- rm -f minisat/SatSolver.o minisat/MiniSATWrap.o
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-11 22:40:58 UTC (rev 1674)
+++ trunk/Toss/Makefile 2012-02-13 03:07:19 UTC (rev 1675)
@@ -59,15 +59,16 @@
FormulaINCSatINC=MenhirLib,Formula
FormulaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll
-SolverINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim
-ArenaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver
-PlayINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
-LearnINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
-GGPINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play
-ClientINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play
-ServerINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn
+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
+ClientINC=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
-.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn,Server
+.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
%.native: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-02-11 22:40:58 UTC (rev 1674)
+++ trunk/Toss/Server/Tests.ml 2012-02-13 03:07:19 UTC (rev 1675)
@@ -13,6 +13,10 @@
]
let solver_tests = "Solver", [
+ "NaturalsTest", [NaturalsTest.tests];
+ "IntegersTest", [IntegersTest.tests];
+ "RationalsTest", [RationalsTest.tests];
+ "NumbersTest", [NumbersTest.tests];
"StructureTest", [StructureTest.tests];
"AssignmentsTest", [AssignmentsTest.tests];
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
Added: trunk/Toss/Solver/Num/Integers.ml
===================================================================
--- trunk/Toss/Solver/Num/Integers.ml (rev 0)
+++ trunk/Toss/Solver/Num/Integers.ml 2012-02-13 03:07:19 UTC (rev 1675)
@@ -0,0 +1,406 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking. *)
+(* *)
+(***********************************************************************)
+
+
+open MiscNum
+open Naturals.N
+
+type big_int =
+ { sign : int;
+ abs_value : nat }
+
+let create_big_int sign nat =
+ if sign = 1 || sign = -1 ||
+ (sign = 0 && is_zero_nat nat 0 (num_digits_nat nat))
+ then { sign = sign;
+ abs_value = nat }
+ else invalid_arg "create_big_int"
+
+(* Sign of a big_int *)
+let sign_big_int bi = bi.sign
+
+let zero_big_int =
+ { sign = 0;
+ abs_value = make_nat 1 }
+
+let unit_big_int =
+ { sign = 1;
+ abs_value = nat_of_int 1 }
+
+(* Number of digits in a big_int *)
+let num_digits_big_int bi = num_digits_nat (bi.abs_value)
+
+(* Opposite of a big_int *)
+let minus_big_int bi =
+ { sign = - bi.sign;
+ abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
+
+(* Absolute value of a big_int *)
+let abs_big_int bi =
+ { sign = if bi.sign = 0 then 0 else 1;
+ abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
+
+(* Comparison operators on big_int *)
+
+(*
+ compare_big_int (bi, bi2) = sign of (bi-bi2)
+ i.e. 1 if bi > bi2
+ 0 if bi = bi2
+ -1 if bi < bi2
+*)
+let compare_big_int bi1 bi2 =
+ if bi1.sign = 0 && bi2.sign = 0 then 0
+ else if bi1.sign < bi2.sign then -1
+ else if bi1.sign > bi2.sign then 1
+ else if bi1.sign = 1 then
+ compare_nat (bi1.abs_value) (bi2.abs_value)
+ else
+ compare_nat (bi2.abs_value) (bi1.abs_value)
+
+let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0
+and le_big_int bi1 bi2 = compare_big_int bi1 bi2 <= 0
+and ge_big_int bi1 bi2 = compare_big_int bi1 bi2 >= 0
+and lt_big_int bi1 bi2 = compare_big_int bi1 bi2 < 0
+and gt_big_int bi1 bi2 = compare_big_int bi1 bi2 > 0
+
+let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1
+and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1
+
+(* Operations on big_int *)
+
+let add_big_int bi1 bi2 =
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ if bi1.sign = bi2.sign
+ then (* Add absolute values if signs are the same *)
+ { sign = bi1.sign;
+ abs_value =
+ match compare_nat (bi1.abs_value) (bi2.abs_value) with
+ -1 -> let res = create_nat (succ size_bi2) in
+ (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
+ set_digit_nat res size_bi2 0;
+ add_nat res (bi1.abs_value);
+ res)
+ |_ -> let res = create_nat (succ size_bi1) in
+ (blit_nat res 0 (bi1.abs_value) 0 size_bi1;
+ set_digit_nat res size_bi1 0;
+ add_nat res (bi2.abs_value);
+ res)}
+
+ else (* Subtract absolute values if signs are different *)
+ match compare_nat (bi1.abs_value) (bi2.abs_value) with
+ | 0 -> zero_big_int
+ | 1 -> { sign = bi1.sign;
+ abs_value = let res = copy_nat (bi1.abs_value) 0 size_bi1 in
+ sub_nat res (bi2.abs_value);
+ res }
+ | _ -> { sign = bi2.sign;
+ abs_value = let res = copy_nat (bi2.abs_value) 0 size_bi2 in
+ sub_nat res (bi1.abs_value);
+ res }
+
+(* Coercion with int type *)
+let big_int_of_int i =
+ { sign = sign_int i;
+ abs_value =
+ let res = (create_nat 1)
+ in (if i = monster_int
+ then (set_digit_nat res 0 biggest_int;
+ incr_nat res)
+ else set_digit_nat res 0 (abs i));
+ res }
+
+let big_int_of_nat nat =
+ let length = num_digits_nat nat in
+ { sign = if is_zero_nat nat 0 length then 0 else 1;
+ abs_value = copy_nat nat 0 length }
+
+let add_int_big_int i bi = add_big_int (big_int_of_int i) bi
+
+let sub_big_int bi1 bi2 = add_big_int bi1 (minus_big_int bi2)
+
+(* Returns i * bi *)
+let mult_int_big_int i bi =
+ let size_bi = num_digits_big_int bi in
+ let size_res = succ size_bi in
+ if i = monster_int
+ then let res = create_nat size_res in
+ blit_nat res 0 (bi.abs_value) 0 size_bi;
+ set_digit_nat res size_bi 0;
+ mult_digit_nat res (bi.abs_value) (biggest_int);
+ { sign = - (sign_big_int bi);
+ abs_value = res }
+ else let res = make_nat (size_res) in
+ mult_digit_nat res (bi.abs_value) (abs i);
+ { sign = (sign_int i) * (sign_big_int bi);
+ abs_value = res }
+
+let mult_big_int bi1 bi2 =
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ let size_res = size_bi1 + size_bi2 in
+ let res = make_nat (size_res) in
+ { sign = bi1.sign * bi2.sign;
+ abs_value =
+ if size_bi2 > size_bi1
+ then (mult_nat res (bi2.abs_value) (bi1.abs_value); res)
+ else (mult_nat res (bi1.abs_value) (bi2.abs_value); res)
+ }
+
+(* (quotient, rest) of the euclidian division of 2 big_int *)
+let quomod_big_int bi1 bi2 =
+ if bi2.sign = 0 then raise Division_by_zero
+ else
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ match compare_nat (bi1.abs_value) (bi2.abs_value) with
+ -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *)
+ (* 1/-2 -> 0, reste 1, -1/-2 -> 1, reste 1 *)
+ if bi1.sign >= 0 then
+ (big_int_of_int 0, bi1)
+ else if bi2.sign >= 0 then
+ (big_int_of_int(-1), add_big_int bi2 bi1)
+ else
+ (big_int_of_int 1, sub_big_int bi1 bi2)
+ | 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int)
+ | _ -> let bi1_negatif = bi1.sign = -1 in
+ let size_q =
+ if bi1_negatif
+ then succ (max (succ (size_bi1 - size_bi2)) 1)
+ else max (succ (size_bi1 - size_bi2)) 1
+ and size_r = succ (max size_bi1 size_bi2)
+ (* r is long enough to contain both quotient and remainder *)
+ (* of the euclidian division *)
+ in
+ (* set up quotient, remainder *)
+ let q = create_nat size_q
+ and r = create_nat size_r in
+ blit_nat r 0 (bi1.abs_value) 0 size_bi1;
+ set_to_zero_nat r size_bi1 (size_r - size_bi1);
+
+ (* do the division of |bi1| by |bi2|
+ - at the beginning, r contains |bi1|
+ - at the end, r contains
+ * in the size_bi2 least significant digits, the remainder
+ * in the size_r-size_bi2 most significant digits, the quotient
+ note the conditions for application of div_nat are verified here
+ *)
+ div_nat r (bi2.abs_value);
+
+ (* separate quotient and remainder *)
+ blit_nat q 0 r size_bi2 (size_r - size_bi2);
+ let not_null_mod = not (is_zero_nat r 0 size_bi2) in
+
+ (* correct the signs, adjusting the quotient and remainder *)
+ if bi1_negatif && not_null_mod
+ then
+ (* bi1<0, r>0, noting r for (r, size_bi2) the remainder, *)
+ (* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|, *)
+ (* thus -bi1 = q * |bi2| + r *)
+ (* and bi1 = (-q) * |bi2| + (-r) with -|bi2| < (-r) < 0 *)
+ (* thus bi1 = -(q+1) * |bi2| + (|bi2|-r) *)
+ (* with 0 < (|bi2|-r) < |bi2| *)
+ (* so the quotient has for sign the opposite of the bi2'one *)
+ (* and for value q+1 *)
+ (* and the remainder is strictly positive *)
+ (* has for value |bi2|-r *)
+ (let new_r = copy_nat (bi2.abs_value) 0 size_bi2 in
+ (* new_r contains (r, size_bi2) the remainder *)
+ { sign = - bi2.sign;
+ abs_value = (set_digit_nat q (pred size_q) 0;
+ incr_nat q; q) },
+ { sign = 1;
+ abs_value = let rlimit = copy_nat r 0 size_bi2 in
+ sub_nat new_r rlimit;
+ new_r })
+ else
+ (if bi1_negatif then set_digit_nat q (pred size_q) 0;
+ { sign = if is_zero_nat q 0 size_q
+ then 0
+ else bi1.sign * bi2.sign;
+ abs_value = q },
+ { sign = if not_null_mod then 1 else 0;
+ abs_value = copy_nat r 0 size_bi2 })
+
+let div_big_int bi1 bi2 = fst (quomod_big_int bi1 bi2)
+let mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2)
+
+let gcd_big_int bi1 bi2 =
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2
+ else if is_zero_nat (bi2.abs_value) 0 size_bi2 then
+ { sign = 1;
+ abs_value = bi1.abs_value }
+ else
+ { sign = 1;
+ abs_value =
+ match compare_nat (bi1.abs_value) (bi2.abs_value) with
+ | 0 -> bi1.abs_value
+ | 1 ->
+ let res = copy_nat (bi1.abs_value) 0 size_bi1 in
+ let len = gcd_nat res (bi2.abs_value) in
+ copy_nat res 0 len
+ | _ ->
+ let res = copy_nat (bi2.abs_value) 0 size_bi2 in
+ let len = gcd_nat res (bi1.abs_value) in
+ copy_nat res 0 len
+ }
+
+(* Coercion operators *)
+
+let monster_big_int = big_int_of_int monster_int;;
+
+let monster_nat = monster_big_int.abs_value;;
+
+let is_int_big_int bi =
+ num_digits_big_int bi == 1 &&
+ match compare_nat bi.abs_value monster_nat with
+ | 0 -> bi.sign == -1
+ | -1 -> true
+ | _ -> false;;
+
+let int_of_big_int bi =
+ try let n = int_of_nat bi.abs_value in
+ if bi.sign = -1 then - n else n
+ with Failure _ ->
+ if eq_big_int bi monster_big_int then monster_int
+ else failwith "int_of_big_int";;
+
+(* Coercion with nat type *)
+let nat_of_big_int bi =
+ if bi.sign = -1
+ then failwith "nat_of_big_int"
+ else copy_nat (bi.abs_value) 0 (num_digits_big_int bi)
+
+
+(* Coercion with string type *)
+
+let string_of_big_int bi =
+ if bi.sign = -1
+ then "-" ^ string_of_nat bi.abs_value
+ else string_of_nat bi.abs_value
+
+
+let sys_big_int_of_string_aux s ofs len sgn =
+ if len < 1 then failwith "sys_big_int_of_string";
+ let n = nat_of_string s ofs len in
+ if is_zero_nat n 0 (num_digits_nat n) then zero_big_int
+ else {sign = sgn; abs_value = n}
+;;
+
+let sys_big_int_of_string s ofs len =
+ if len < 1 then failwith "sys_big_int_of_string";
+ match s.[ofs] with
+ | '-' -> sys_big_int_of_string_aux s (ofs+1) (len-1) (-1)
+ | '+' -> sys_big_int_of_string_aux s (ofs+1) (len-1) 1
+ | _ -> sys_big_int_of_string_aux s ofs len 1
+;;
+
+let big_int_of_string s =
+ sys_big_int_of_string s 0 (String.length s)
+
+
+let power_int_positive_int i n =
+ match sign_int n with
+ | 0 -> unit_big_int
+ | -1 -> invalid_arg "power_int_positive_int"
+ | _ -> let nat = power_base_int (abs i) n in
+ { sign = if i >= 0 then sign_int i else
+ if n land 1 = 0 then 1 else -1;
+ abs_value = nat}
+
+(* base_power_big_int compute bi*base^n *)
+let base_power_big_int base n bi =
+ match sign_int n with
+ | 0 -> bi
+ | -1 -> let nat = power_base_int base (-n) in
+ let len_nat = num_digits_nat nat
+ and len_bi = num_digits_big_int bi in
+ if len_bi < len_nat then
+ invalid_arg "base_power_big_int"
+ else if len_bi = len_nat &&
+ compare_digits_nat (bi.abs_value) nat = -1
+ then invalid_arg "base_power_big_int" else
+ let copy = create_nat (succ len_bi) in
+ blit_nat copy 0 (bi.abs_value) 0 len_bi;
+ set_digit_nat copy len_bi 0;
+ div_nat copy nat;
+ if not (is_zero_nat copy 0 len_nat)
+ then invalid_arg "base_power_big_int"
+ else { sign = bi.sign;
+ abs_value = copy_nat copy len_nat 1 }
+ | _ -> let nat = power_base_int base n in
+ let len_nat = num_digits_nat nat
+ and len_bi = num_digits_big_int bi in
+ let new_len = len_bi + len_nat in
+ let res = make_nat new_len in
+ if len_bi > len_nat
+ then mult_nat res (bi.abs_value) nat
+ else mult_nat res nat (bi.abs_value);
+ if is_zero_nat res 0 new_len
+ then zero_big_int
+ else create_big_int (bi.sign) res
+
+
+(* Coercion with float type *)
+
+let float_of_big_int bi =
+ float_of_string (string_of_big_int bi)
+
+
+(* round off of the futur last digit (of the integer represented by the string
+ argument of the function) that is now the previous one.
+ if s contains an integer of the form (10^n)-1
+ then s <- only 0 digits and the result_int is true
+ else s <- the round number and the result_int is false *)
+let round_futur_last_digit s off_set length =
+ let l = pred (length + off_set) in
+ if Char.code(String.get s l) >= Char.code '5'
+ then
+ let rec round_rec l =
+ if l < off_set then true else begin
+ let current_char = String.get s l in
+ if current_char = '9' then
+ (String.set s l '0'; round_rec (pred l))
+ else
+ (String.set s l (Char.chr (succ (Char.code current_char)));
+ false)
+ end
+ in round_rec (pred l)
+ else false
+
+
+(* Approximation with floating decimal point a` la approx_ratio_exp *)
+let approx_big_int prec bi =
+ let len_bi = num_digits_big_int bi in
+ let n =
+ max 0
+ (int_of_big_int (
+ add_int_big_int
+ (-prec)
+ (div_big_int (mult_big_int (big_int_of_int (pred len_bi))
+ (big_int_of_string "963295986"))
+ (big_int_of_string "100000000")))) in
+ let s =
+ string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in
+ let (sign, off, len) =
+ if String.get s 0 = '-'
+ then ("-", 1, succ prec)
+ else ("", 0, prec) in
+ if (round_futur_last_digit s off (succ prec))
+ then (sign^"1."^(String.make prec '0')^"e"^
+ (string_of_int (n + 1 - off + String.length s)))
+ else (sign^(String.sub s off 1)^"."^
+ (String.sub s (succ off) (pred prec))
+ ^"e"^(string_of_int (n - succ off + String.length s)))
Added: trunk/Toss/Solver/Num/Integers.mli
===================================================================
--- trunk/Toss/Solver/Num/Integers.mli (rev 0)
+++ trunk/Toss/Solver/Num/Integers.mli 2012-02-13 03:07:19 UTC (rev 1675)
@@ -0,0 +1,128 @@
+(** Operations on arbitrary-precision integers, subset of Big_int module. *)
+
+type big_int
+(** The type of big integers. *)
+
+val zero_big_int : big_int
+(** The big integer [0]. *)
+
+val unit_big_int : big_int
+(** The big integer [1]. *)
+
+
+(** {2 Arithmetic operations} *)
+
+val minus_big_int : big_int -> big_int
+(** Unary negation. *)
+
+val abs_big_int : big_int -> big_int
+(** Absolute value. *)
+
+val add_big_int : big_int -> big_int -> big_int
+(** Addition. *)
+
+val add_int_big_int : int -> big_int -> big_int
+(** Addition of a small integer to a big integer. *)
+
+val sub_big_int : big_int -> big_int -> big_int
+(** Subtraction. *)
+
+val mult_big_int : big_int -> big_int -> big_int
+(** Multiplication of two big integers. *)
+
+val mult_int_big_int : int -> big_int -> big_int
+(** Multiplication of a big integer by a small integer *)
+
+val quomod_big_int : big_int -> big_int -> big_int * big_int
+(** Euclidean division of two big integers.
+ The first part of the result is the quotient,
+ the second part is the remainder.
+ Writing [(q,r) = quomod_big_int a b], we have
+ [a = q * b + r] and [0 <= r < |b|].
+ Raise [Division_by_zero] if the divisor is zero. *)
+
+val div_big_int : big_int -> big_int -> big_int
+(** Euclidean quotient of two big integers.
+ This is the first result [q] of [quomod_big_int] (see above). *)
+
+val mod_big_int : big_int -> big_int -> big_int
+(** Euclidean modulus of two big integers.
+ This is the second result [r] of [quomod_big_int] (see above). *)
+
+val gcd_big_int : big_int -> big_int -> big_int
+(** Greatest common divisor of two big integers. *)
+
+
+(** {2 Comparisons and tests} *)
+
+val sign_big_int : big_int -> int
+(** Return [0] if the given big integer is zero,
+ [1] if it is positive, and [-1] if it is negative. *)
+
+val compare_big_int : big_int -> big_int -> int
+(** [compare_big_int a b] returns [0] if [a] and [b] are equal,
+ [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *)
+
+val eq_big_int : big_int -> big_int -> bool
+val le_big_int : big_int -> big_int -> bool
+val ge_big_int : big_int -> big_int -> bool
+val lt_big_int : big_int -> big_int -> bool
+val gt_big_int : big_int -> big_int -> bool
+(** Usual boolean comparisons between two big integers. *)
+
+val max_big_int : big_int -> big_int -> big_int
+(** Return the greater of its two arguments. *)
+
+val min_big_int : big_int -> big_int -> big_int
+(** Return the smaller of its two arguments. *)
+
+val num_digits_big_int : big_int -> int
+(** Return the number of machine words used to store the
+ given big integer. *)
+
+
+(** {2 Conversions to and from strings} *)
+
+val string_of_big_int : big_int -> string
+(** Return the string representation of the given big integer,
+ in decimal (base 10). *)
+
+val big_int_of_string : string -> big_int
+(** Convert a string to a big integer, in decimal.
+ The string consists of an optional [-] or [+] sign,
+ followed by one or several decimal digits. *)
+
+
+(** {2 Conversions to and from other numerical types} *)
+
+val big_int_of_int : int -> big_int
+(** Convert a small integer to a big integer. *)
+
+val big_int_of_nat : Naturals.N.nat -> big_int
+(** Convert a natural to a big integer. *)
+
+val is_int_big_int : big_int -> bool
+(** Test whether the given big integer is small enough to
+ be representable as a small integer (type [int])
+ without loss of precision. On a 32-bit platform,
+ [is_int_big_int a] returns [true] if and only if
+ [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform,
+ [is_int_big_int a] returns [true] if and only if
+ [a] is between -2{^62} and 2{^62}-1. *)
+
+val int_of_big_int : big_int -> int
+(** Convert a big integer to a small integer (type [int]).
+ Raises [Failure "int_of_big_int"] if the big integer
+ is not representable as a small integer. *)
+
+val float_of_big_int : big_int -> float
+(** Returns a floating-point number approximating the given big integer. *)
+
+
+(** {2 For internal use} *)
+
+val nat_of_big_int : big_int -> Naturals.N.nat
+val approx_big_int: int -> big_int -> string
+val base_power_big_int: int -> int -> big_int -> big_int
+val round_futur_last_digit : string -> int -> int -> bool
+val sys_big_int_of_string: string -> int -> int -> big_int
Added: trunk/Toss/Solver/Num/IntegersTest.ml
===================================================================
--- trunk/Toss/Solver/Num/IntegersTest.ml (rev 0)
+++ trunk/Toss/Solver/Num/IntegersTest.ml 2012-02-13 03:07:19 UTC (rev 1675)
@@ -0,0 +1,491 @@
+open OUnit
+open Integers
+
+let eq_bool (b1, b2) = assert_equal ~printer:string_of_bool b1 b2
+let eq_int (i1, i2) = assert_equal ~printer:string_of_int i1 i2
+let eq_string (s1, s2) = assert_equal ~printer:(fun x -> x) s1 s2
+let eq_big_int (bi1, bi2) = eq_bool (Integers.eq_big_int bi1 bi2, true)
+
+let failwith_test f x except =
+ try let _ = ignore (f x) in eq_string ("worked", "failed") with
+ e -> eq_bool (e = except, true)
+
+let rec gcd_int i1 i2 = if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2)
+
+let length_of_int = Sys.word_size - 2
+let monster_int = 1 lsl length_of_int
+let biggest_int = monster_int - 1
+let least_int = - biggest_int
+
+let pi_1000_digits =
+"3141592653 :10
+5897932384 :20
+6264338327 :30
+9502884197 :40
+1693993751 :50
+0582097494 :60
+4592307816 :70
+4062862089 :80
+9862803482 :90
+5342117067 :100
+9821480865 :110
+1328230664 :120
+7093844609 :130
+5505822317 :140
+2535940812 :150
+8481117450 :160
+2841027019 :170
+3852110555 :180
+9644622948 :190
+9549303819 :200
+6442881097 :210
+5665933446 :220
+1284756482 :230
+3378678316 :240
+5271201909 :250
+1456485669 :260
+2346034861 :270
+0454326648 :280
+2133936072 :290
+6024914127 :300
+3724587006 :310
+6063155881 :320
+7488152092 :330
+0962829254 :340
+0917153643 :350
+6789259036 :360
+0011330530 :370
+5488204665 :380
+2138414695 :390
+1941511609 :400
+4330572703 :410
+6575959195 :420
+3092186117 :430
+3819326117 :440
+9310511854 :450
+8074462379 :460
+9627495673 :470
+5188575272 :480
+4891227938 :490
+1830119491 :500
+2983367336 :510
+2440656643 :520
+0860213949 :530
+4639522473 :540
+7190702179 :550
+8609437027 :560
+7053921717 :570
+6293176752 :580
+3846748184 :590
+6766940513 :600
+2000568127 :610
+1452635608 :620
+2778577134 :630
+2757789609 :640
+1736371787 :650
+2146844090 :660
+1224953430 :670
+1465495853 :680
+7105079227 :690
+9689258923 :700
+5420199561 :710
+1212902196 :720
+0864034418 :730
+1598136297 :740
+7477130996 :750
+0518707211 :760
+3499999983 :770
+7297804995 :780
+1059731732 :790
+8160963185 :800
+9502445945 :810
+5346908302 :820
+6425223082 :830
+5334468503 :840
+5261931188 :850
+1710100031 :860
+3783875288 :870
+6587533208 :880
+3814206171 :890
+7766914730 :900
+3598253490 :910
+4287554687 :920
+3115956286 :930
+3882353787 :940
+5937519577 :950
+8185778053 :960
+2171226806 :970
+6130019278 :980
+7661119590 :990
+9216420198 :1000
+"
+
+let tests = "Integers" >::: [
+ "compare_big_int" >::
+ (fun () ->
+ eq_int (compare_big_int zero_big_int zero_big_int, 0);
+ eq_int (compare_big_int zero_big_int (big_int_of_int 1), (-1));
+ eq_int (compare_big_int zero_big_int (big_int_of_int (-1)), 1);
+ eq_int (compare_big_int (big_int_of_int 1) zero_big_int, 1);
+ eq_int (compare_big_int (big_int_of_int (-1)) zero_big_int, (-1));
+ eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 1), 0);
+ eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 0);
+ eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int (-1)), 1);
+ eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int 1), (-1));
+ eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 2), (-1));
+ eq_int (compare_big_int (big_int_of_int 2) (big_int_of_int 1), 1);
+ eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 1);
+ eq_int (compare_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), -1);
+ );
+
+ "add_big_int" >::
+ (fun () ->
+ eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);
+ eq_big_int (add_big_int zero_big_int (big_int_of_int 1),
+ big_int_of_int 1);
+ eq_big_int (add_big_int (big_int_of_int 1) zero_big_int,
+ big_int_of_int 1);
+ eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)),
+ big_int_of_int (-1));
+ eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int,
+ big_int_of_int (-1));
+ eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1),
+ big_int_of_int 2);
+ eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2),
+ big_int_of_int 3);
+ eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1),
+ big_int_of_int 3);
+ eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
+ big_int_of_int (-2));
+ eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
+ big_int_of_int (-3));
+ eq_b...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-18 02:07:15
|
Revision: 1677
http://toss.svn.sourceforge.net/toss/?rev=1677&view=rev
Author: lukaszkaiser
Date: 2012-02-18 02:07:02 +0000 (Sat, 18 Feb 2012)
Log Message:
-----------
Replacing Num.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Num/Integers.ml
trunk/Toss/Solver/Num/Integers.mli
trunk/Toss/Solver/Num/IntegersTest.ml
trunk/Toss/Solver/Num/Naturals.ml
trunk/Toss/Solver/Num/NaturalsTest.ml
trunk/Toss/Solver/Num/NumbersTest.ml
trunk/Toss/Solver/Num/Rationals.ml
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-17 02:36:56 UTC (rev 1676)
+++ trunk/Toss/Makefile 2012-02-18 02:07:02 UTC (rev 1677)
@@ -47,8 +47,8 @@
# TODO: Hard-coded path to js_of_ocaml.
OCB_LFLAG=-lflags -I,/usr/local/lib/ocaml/3.12.0/js_of_ocaml,-I,+oUnit,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/js_of_ocaml
OCB_CFLAG=-cflags -I,/usr/local/lib/ocaml/3.12.0/js_of_ocaml,-I,+oUnit,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/js_of_ocaml,-g
-OCB_LIB=-libs str,nums,unix,oUnit
-OCB_LIBJS=-libs str,js_of_ocaml
+OCB_LIB=-libs str,unix,oUnit
+OCB_LIBJS=-libs js_of_ocaml
OCB_PP=-pp "camlp4o -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo js_of_ocaml/pa_js.cmo"
OCB_PPJS=-pp "camlp4o -unsafe -I /usr/local/lib/ocaml/3.12.0 -I /opt/local/lib/ocaml/site-lib ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_log.cmo pa_macro.cmo -DJAVASCRIPT js_of_ocaml/pa_js.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-02-17 02:36:56 UTC (rev 1676)
+++ trunk/Toss/Server/Tests.ml 2012-02-18 02:07:02 UTC (rev 1677)
@@ -14,9 +14,9 @@
let solver_tests = "Solver", [
"NaturalsTest", [NaturalsTest.tests];
- "IntegersTest", [IntegersTest.tests];
+ "IntegersTest", [IntegersTest.tests; IntegersTest.bigtests];
"RationalsTest", [RationalsTest.tests];
- "NumbersTest", [NumbersTest.tests];
+ "NumbersTest", [NumbersTest.tests; NumbersTest.bigtests];
"StructureTest", [StructureTest.tests];
"AssignmentsTest", [AssignmentsTest.tests];
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
Modified: trunk/Toss/Solver/Num/Integers.ml
===================================================================
--- trunk/Toss/Solver/Num/Integers.ml 2012-02-17 02:36:56 UTC (rev 1676)
+++ trunk/Toss/Solver/Num/Integers.ml 2012-02-18 02:07:02 UTC (rev 1677)
@@ -13,7 +13,7 @@
open MiscNum
-open Naturals.N
+open Naturals
type big_int =
{ sign : int;
@@ -76,27 +76,31 @@
let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1
and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1
+let string_of_big_int bi =
+ if bi.sign = -1
+ then "-" ^ string_of_nat bi.abs_value
+ else string_of_nat bi.abs_value
+
+
(* Operations on big_int *)
let add_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- if bi1.sign = bi2.sign
- then (* Add absolute values if signs are the same *)
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ if bi1.sign = bi2.sign then (* Add absolute values if signs are the same *)
{ sign = bi1.sign;
abs_value =
match compare_nat (bi1.abs_value) (bi2.abs_value) with
- -1 -> let res = create_nat (succ size_bi2) in
- (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
- set_digit_nat res size_bi2 0;
- add_nat res (bi1.abs_value);
- res)
- |_ -> let res = create_nat (succ size_bi1) in
- (blit_nat res 0 (bi1.abs_value) 0 size_bi1;
- set_digit_nat res size_bi1 0;
- add_nat res (bi2.abs_value);
- res)}
-
+ | -1 -> let res = create_nat (succ size_bi2) in
+ (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
+ set_digit_nat res size_bi2 0;
+ add_nat res (bi1.abs_value);
+ res)
+ |_ -> let res = create_nat (succ size_bi1) in
+ (blit_nat res 0 (bi1.abs_value) 0 size_bi1;
+ set_digit_nat res size_bi1 0;
+ add_nat res (bi2.abs_value);
+ res)}
else (* Subtract absolute values if signs are different *)
match compare_nat (bi1.abs_value) (bi2.abs_value) with
| 0 -> zero_big_int
@@ -113,12 +117,12 @@
let big_int_of_int i =
{ sign = sign_int i;
abs_value =
- let res = (create_nat 1)
- in (if i = monster_int
- then (set_digit_nat res 0 biggest_int;
- incr_nat res)
- else set_digit_nat res 0 (abs i));
- res }
+ if i = monster_int then
+ let res = (create_nat 2) in
+ (set_digit_nat res 0 biggest_int;
+ incr_nat res; res)
+ else let res = (create_nat 1) in (set_digit_nat res 0 (abs i); res)
+ }
let big_int_of_nat nat =
let length = num_digits_nat nat in
@@ -146,34 +150,34 @@
abs_value = res }
let mult_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- let size_res = size_bi1 + size_bi2 in
- let res = make_nat (size_res) in
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ let size_res = size_bi1 + size_bi2 in
+ let res = make_nat (size_res) in
{ sign = bi1.sign * bi2.sign;
abs_value =
- if size_bi2 > size_bi1
- then (mult_nat res (bi2.abs_value) (bi1.abs_value); res)
- else (mult_nat res (bi1.abs_value) (bi2.abs_value); res)
+ if size_bi2 > size_bi1
+ then (mult_nat res (bi2.abs_value) (bi1.abs_value); res)
+ else (mult_nat res (bi1.abs_value) (bi2.abs_value); res)
}
(* (quotient, rest) of the euclidian division of 2 big_int *)
let quomod_big_int bi1 bi2 =
if bi2.sign = 0 then raise Division_by_zero
else
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- match compare_nat (bi1.abs_value) (bi2.abs_value) with
- -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *)
- (* 1/-2 -> 0, reste 1, -1/-2 -> 1, reste 1 *)
- if bi1.sign >= 0 then
- (big_int_of_int 0, bi1)
- else if bi2.sign >= 0 then
- (big_int_of_int(-1), add_big_int bi2 bi1)
- else
- (big_int_of_int 1, sub_big_int bi1 bi2)
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ match compare_nat (bi1.abs_value) (bi2.abs_value) with
+ | -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *)
+ (* 1/-2 -> 0, reste 1, -1/-2 -> 1, reste 1 *)
+ if bi1.sign >= 0 then
+ (big_int_of_int 0, bi1)
+ else if bi2.sign >= 0 then
+ (big_int_of_int(-1), add_big_int bi2 bi1)
+ else
+ (big_int_of_int 1, sub_big_int bi1 bi2)
| 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int)
- | _ -> let bi1_negatif = bi1.sign = -1 in
+ | _ -> let bi1_negatif = (bi1.sign = -1) in
let size_q =
if bi1_negatif
then succ (max (succ (size_bi1 - size_bi2)) 1)
@@ -236,26 +240,25 @@
let mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2)
let gcd_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2
else if is_zero_nat (bi2.abs_value) 0 size_bi2 then
- { sign = 1;
- abs_value = bi1.abs_value }
+ { sign = 1; abs_value = bi1.abs_value }
else
- { sign = 1;
- abs_value =
- match compare_nat (bi1.abs_value) (bi2.abs_value) with
- | 0 -> bi1.abs_value
- | 1 ->
- let res = copy_nat (bi1.abs_value) 0 size_bi1 in
- let len = gcd_nat res (bi2.abs_value) in
- copy_nat res 0 len
- | _ ->
- let res = copy_nat (bi2.abs_value) 0 size_bi2 in
- let len = gcd_nat res (bi1.abs_value) in
- copy_nat res 0 len
- }
+ { sign = 1;
+ abs_value =
+ match compare_nat (bi1.abs_value) (bi2.abs_value) with
+ | 0 -> bi1.abs_value
+ | 1 ->
+ let res = copy_nat (bi1.abs_value) 0 size_bi1 in
+ let len = gcd_nat res (bi2.abs_value) in
+ copy_nat res 0 len
+ | _ ->
+ let res = copy_nat (bi2.abs_value) 0 size_bi2 in
+ let len = gcd_nat res (bi1.abs_value) in
+ copy_nat res 0 len
+ }
(* Coercion operators *)
@@ -264,11 +267,9 @@
let monster_nat = monster_big_int.abs_value;;
let is_int_big_int bi =
- num_digits_big_int bi == 1 &&
- match compare_nat bi.abs_value monster_nat with
- | 0 -> bi.sign == -1
- | -1 -> true
- | _ -> false;;
+ num_digits_big_int bi == 1 || (
+ num_digits_big_int bi == 2 && bi.sign == -1 &&
+ compare_nat bi.abs_value monster_nat == 0)
let int_of_big_int bi =
try let n = int_of_nat bi.abs_value in
@@ -286,12 +287,6 @@
(* Coercion with string type *)
-let string_of_big_int bi =
- if bi.sign = -1
- then "-" ^ string_of_nat bi.abs_value
- else string_of_nat bi.abs_value
-
-
let sys_big_int_of_string_aux s ofs len sgn =
if len < 1 then failwith "sys_big_int_of_string";
let n = nat_of_string s ofs len in
Modified: trunk/Toss/Solver/Num/Integers.mli
===================================================================
--- trunk/Toss/Solver/Num/Integers.mli 2012-02-17 02:36:56 UTC (rev 1676)
+++ trunk/Toss/Solver/Num/Integers.mli 2012-02-18 02:07:02 UTC (rev 1677)
@@ -98,7 +98,7 @@
val big_int_of_int : int -> big_int
(** Convert a small integer to a big integer. *)
-val big_int_of_nat : Naturals.N.nat -> big_int
+val big_int_of_nat : Naturals.nat -> big_int
(** Convert a natural to a big integer. *)
val is_int_big_int : big_int -> bool
@@ -121,7 +121,7 @@
(** {2 For internal use} *)
-val nat_of_big_int : big_int -> Naturals.N.nat
+val nat_of_big_int : big_int -> Naturals.nat
val approx_big_int: int -> big_int -> string
val base_power_big_int: int -> int -> big_int -> big_int
val round_futur_last_digit : string -> int -> int -> bool
Modified: trunk/Toss/Solver/Num/IntegersTest.ml
===================================================================
--- trunk/Toss/Solver/Num/IntegersTest.ml 2012-02-17 02:36:56 UTC (rev 1676)
+++ trunk/Toss/Solver/Num/IntegersTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
@@ -1,14 +1,22 @@
open OUnit
open Integers
-let eq_bool (b1, b2) = assert_equal ~printer:string_of_bool b1 b2
+let eq_bool ?i (b1, b2) = match i with
+ | None -> assert_equal ~printer:string_of_bool b1 b2
+ | Some j -> assert_equal ~msg:(Printf.sprintf "test %i" j)
+ ~printer:string_of_bool b1 b2
let eq_int (i1, i2) = assert_equal ~printer:string_of_int i1 i2
let eq_string (s1, s2) = assert_equal ~printer:(fun x -> x) s1 s2
-let eq_big_int (bi1, bi2) = eq_bool (Integers.eq_big_int bi1 bi2, true)
+let eq_big_int ?i (bi1, bi2) =
+ let eq = Integers.eq_big_int bi1 bi2 in
+ if eq then () else
+ let is = match i with None -> "" | Some j -> Printf.sprintf "test %i: " j in
+ let msg = is ^ (string_of_big_int bi1) ^ " <> " ^ (string_of_big_int bi2) in
+ assert_equal ~msg ~printer:string_of_bool eq true
let failwith_test f x except =
try let _ = ignore (f x) in eq_string ("worked", "failed") with
- e -> eq_bool (e = except, true)
+ e -> if e = except then () else raise e
let rec gcd_int i1 i2 = if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2)
@@ -17,6 +25,19 @@
let biggest_int = monster_int - 1
let least_int = - biggest_int
+let pi_100_digits =
+"3141592653 :10
+5897932384 :20
+6264338327 :30
+9502884197 :40
+1693993751 :50
+0582097494 :60
+4592307816 :70
+4062862089 :80
+9862803482 :90
+5342117067 :100
+"
+
let pi_1000_digits =
"3141592653 :10
5897932384 :20
@@ -120,6 +141,55 @@
9216420198 :1000
"
+let pi_digits n_digits =
+ (* Pi digits computed with the streaming algorithm given on pages 4, 6
+ & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
+ Gibbons, August 2004. *)
+ let ( !$ ) = big_int_of_int
+ and ( +$ ) = add_big_int
+ and ( *$ ) = mult_big_int in
+
+ let zero = zero_big_int
+ and one = unit_big_int
+ and three = !$ 3
+ and four = !$ 4
+ and ten = !$ 10
+ and neg_ten = !$(-10) in
+
+ (* Linear Fractional (aka Moebius) Transformations *)
+ let floor_ev (q, r, s, t) x = div_big_int (q *$ x +$ r) (s *$ x +$ t) in
+ let unit = (one, zero, zero, one) in
+ let comp (q, r, s, t) (q', r', s', t') =
+ (q *$ q' +$ r *$ s', q *$ r' +$ r *$ t',
+ s *$ q' +$ t *$ s', s *$ r' +$ t *$ t') in
+
+ let next z = floor_ev z three in
+ let safe z n = Integers.eq_big_int n (floor_ev z four) in
+ let prod z n = comp (ten, neg_ten *$ n, zero, one) z in
+ let cons z k = let den = 2 * k + 1 in
+ comp z (!$ k, !$(2 * den), zero, !$ den) in
+
+ let rec digit k z n row col acc =
+ if n > 0 then
+ let y = next z in
+ if safe z y then
+ if col = 10 then (
+ let row = row + 10 in
+ digit k (prod z y) (n - 1) row 1
+ ((Printf.sprintf "\t:%i\n%s" row (string_of_big_int y)) :: acc)
+ ) else (
+ digit k (prod z y) (n - 1) row (col + 1)
+ ((string_of_big_int y) :: acc)
+ )
+ else digit (k + 1) (cons z k) n row col acc
+ else
+ (Printf.sprintf "%*s\t:%i\n" (10 - col) "" (row + col)) :: acc in
+
+ let digits n = digit 1 unit n 0 0 [] in
+ String.concat "" (List.rev (digits n_digits))
+
+
+
let tests = "Integers" >::: [
"compare_big_int" >::
(fun () ->
@@ -140,76 +210,76 @@
"add_big_int" >::
(fun () ->
- eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);
- eq_big_int (add_big_int zero_big_int (big_int_of_int 1),
- big_int_of_int 1);
- eq_big_int (add_big_int (big_int_of_int 1) zero_big_int,
- big_int_of_int 1);
- eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)),
- big_int_of_int (-1));
- eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int,
- big_int_of_int (-1));
- eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1),
- big_int_of_int 2);
- eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2),
- big_int_of_int 3);
- eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1),
- big_int_of_int 3);
- eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
- big_int_of_int (-2));
- eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
- big_int_of_int (-3));
- eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
- big_int_of_int (-3));
- eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)),
- zero_big_int);
- eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1),
- zero_big_int);
- eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)),
- big_int_of_int (-1));
- eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1),
- big_int_of_int (-1));
- eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2),
- big_int_of_int 1);
- eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)),
- big_int_of_int 1);
+ eq_big_int ~i:1 (add_big_int zero_big_int zero_big_int, zero_big_int);
+ eq_big_int ~i:2 (add_big_int zero_big_int (big_int_of_int 1),
+ big_int_of_int 1);
+ eq_big_int ~i:3 (add_big_int (big_int_of_int 1) zero_big_int,
+ big_int_of_int 1);
+ eq_big_int ~i:4 (add_big_int zero_big_int (big_int_of_int (-1)),
+ big_int_of_int (-1));
+ eq_big_int ~i:5 (add_big_int (big_int_of_int (-1)) zero_big_int,
+ big_int_of_int (-1));
+ eq_big_int ~i:6 (add_big_int (big_int_of_int 1) (big_int_of_int 1),
+ big_int_of_int 2);
+ eq_big_int ~i:7 (add_big_int (big_int_of_int 1) (big_int_of_int 2),
+ big_int_of_int 3);
+ eq_big_int ~i:8 (add_big_int (big_int_of_int 2) (big_int_of_int 1),
+ big_int_of_int 3);
+ eq_big_int ~i:9 (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
+ big_int_of_int (-2));
+ eq_big_int ~i:10 (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
+ big_int_of_int (-3));
+ eq_big_int ~i:11 (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
+ big_int_of_int (-3));
+ eq_big_int ~i:12 (add_big_int (big_int_of_int 1) (big_int_of_int (-1)),
+ zero_big_int);
+ eq_big_int ~i:13 (add_big_int (big_int_of_int (-1)) (big_int_of_int 1),
+ zero_big_int);
+ eq_big_int ~i:14 (add_big_int (big_int_of_int 1) (big_int_of_int (-2)),
+ big_int_of_int (-1));
+ eq_big_int ~i:15 (add_big_int (big_int_of_int (-2)) (big_int_of_int 1),
+ big_int_of_int (-1));
+ eq_big_int ~i:16 (add_big_int (big_int_of_int (-1)) (big_int_of_int 2),
+ big_int_of_int 1);
+ eq_big_int ~i:17 (add_big_int (big_int_of_int 2) (big_int_of_int (-1)),
+ big_int_of_int 1);
);
"sub_big_int" >::
(fun () ->
- eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);
- eq_big_int (sub_big_int zero_big_int (big_int_of_int 1),
- big_int_of_int (-1));
- eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int,
- big_int_of_int 1);
- eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)),
- big_int_of_int 1);
- eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int,
- big_int_of_int (-1));
- eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1),
- zero_big_int);
- eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2),
- big_int_of_int (-1));
- eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1),
- big_int_of_int 1);
- eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
- zero_big_int);
- eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
- big_int_of_int 1);
- eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
- big_int_of_int (-1));
- eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)),
- big_int_of_int 2);
- eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1),
- big_int_of_int (-2));
- eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)),
- big_int_of_int 3);
- eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1),
- big_int_of_int (-3));
- eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2),
- big_int_of_int (-3));
- eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)),
- big_int_of_int 3);
+ eq_big_int ~i:1 (sub_big_int zero_big_int zero_big_int, zero_big_int);
+ eq_big_int ~i:2 (sub_big_int zero_big_int (big_int_of_int 1),
+ big_int_of_int (-1));
+ eq_big_int ~i:3 (sub_big_int (big_int_of_int 1) zero_big_int,
+ big_int_of_int 1);
+ eq_big_int ~i:4 (sub_big_int zero_big_int (big_int_of_int (-1)),
+ big_int_of_int 1);
+ eq_big_int ~i:5 (sub_big_int (big_int_of_int (-1)) zero_big_int,
+ big_int_of_int (-1));
+ eq_big_int ~i:6 (sub_big_int (big_int_of_int 1) (big_int_of_int 1),
+ zero_big_int);
+ eq_big_int ~i:7 (sub_big_int (big_int_of_int 1) (big_int_of_int 2),
+ big_int_of_int (-1));
+ eq_big_int ~i:8 (sub_big_int (big_int_of_int 2) (big_int_of_int 1),
+ big_int_of_int 1);
+ eq_big_int ~i:9 (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
+ zero_big_int);
+ eq_big_int ~i:10 (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
+ big_int_of_int 1);
+ eq_big_int ~i:11 (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
+ big_int_of_int (-1));
+ eq_big_int ~i:12 (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)),
+ big_int_of_int 2);
+ eq_big_int ~i:13 (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1),
+ big_int_of_int (-2));
+ eq_big_int ~i:14 (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)),
+ big_int_of_int 3);
+ eq_big_int ~i:15 (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1),
+ big_int_of_int (-3));
+ eq_big_int ~i:16 (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2),
+ big_int_of_int (-3));
+ eq_big_int ~i:17 (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)),
+ big_int_of_int 3);
);
"mult_int_big_int" >::
@@ -240,43 +310,43 @@
(fun () ->
let (quotient, modulo) =
quomod_big_int (big_int_of_int 1) (big_int_of_int 1) in
- eq_big_int (quotient, big_int_of_int 1);
- eq_big_int (modulo, zero_big_int);
+ eq_big_int ~i:1 (quotient, big_int_of_int 1);
+ eq_big_int ~i:2 (modulo, zero_big_int);
let (quotient, modulo) =
quomod_big_int (big_int_of_int 1) (big_int_of_int (-1)) in
- eq_big_int (quotient, big_int_of_int (-1));
- eq_big_int (modulo, zero_big_int);
+ eq_big_int ~i:3 (quotient, big_int_of_int (-1));
+ eq_big_int ~i:4 (modulo, zero_big_int);
let (quotient, modulo) =
quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in
- eq_big_int (quotient, big_int_of_int (-1));
- eq_big_int (modulo, zero_big_int);
+ eq_big_int ~i:5 (quotient, big_int_of_int (-1));
+ eq_big_int ~i:6 (modulo, zero_big_int);
let (quotient, modulo) =
quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in
- eq_big_int (quotient, big_int_of_int 1);
- eq_big_int (modulo, big_int_of_int 1);
+ eq_big_int ~i:7 (quotient, big_int_of_int 1);
+ eq_big_int ~i:8 (modulo, big_int_of_int 1);
let (quotient, modulo) =
quomod_big_int (big_int_of_int 5) (big_int_of_int 3) in
- eq_big_int (quotient, big_int_of_int 1);
- eq_big_int (modulo, big_int_of_int 2);
+ eq_big_int ~i:9 (quotient, big_int_of_int 1);
+ eq_big_int ~i:10 (modulo, big_int_of_int 2);
let (quotient, modulo) =
quomod_big_int (big_int_of_int (-5)) (big_int_of_int 3) in
- eq_big_int (quotient, big_int_of_int (-2));
- eq_big_int (modulo, big_int_of_int 1);
+ eq_big_int ~i:11 (quotient, big_int_of_int (-2));
+ eq_big_int ~i:12 (modulo, big_int_of_int 1);
let (quotient, modulo) =
quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in
- eq_big_int (quotient, zero_big_int);
- eq_big_int (modulo, big_int_of_int 1);
+ eq_big_int ~i:13 (quotient, zero_big_int);
+ eq_big_int ~i:14 (modulo, big_int_of_int 1);
let (quotient, modulo) =
quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in
- eq_big_int (quotient, minus_big_int unit_big_int);
- eq_big_int (modulo, big_int_of_int 2);
+ eq_big_int ~i:14 (quotient, minus_big_int unit_big_int);
+ eq_big_int ~i:15 (modulo, big_int_of_int 2);
failwith_test
(quomod_big_int (big_int_of_int 1)) zero_big_int
@@ -284,23 +354,23 @@
let (quotient, modulo) =
quomod_big_int (big_int_of_int 10) (big_int_of_int 20) in
- eq_big_int (quotient, big_int_of_int 0);
- eq_big_int (modulo, big_int_of_int 10);
+ eq_big_int ~i:16 (quotient, big_int_of_int 0);
+ eq_big_int ~i:17 (modulo, big_int_of_int 10);
let (quotient, modulo) =
quomod_big_int (big_int_of_int (-10)) (big_int_of_int 20) in
- eq_big_int (quotient, big_int_of_int (-1));
- eq_big_int (modulo, big_int_of_int 10);
+ eq_big_int ~i:18 (quotient, big_int_of_int (-1));
+ eq_big_int ~i:19 (modulo, big_int_of_int 10);
let (quotient, modulo) =
quomod_big_int (big_int_of_int 10) (big_int_of_int (-20)) in
- eq_big_int (quotient, big_int_of_int 0);
- eq_big_int (modulo, big_int_of_int 10);
+ eq_big_int ~i:20 (quotient, big_int_of_int 0);
+ eq_big_int ~i:21 (modulo, big_int_of_int 10);
let (quotient, modulo) =
quomod_big_int (big_int_of_int (-10)) (big_int_of_int (-20)) in
- eq_big_int (quotient, big_int_of_int 1);
- eq_big_int (modulo, big_int_of_int 10);
+ eq_big_int ~i:22 (quotient, big_int_of_int 1);
+ eq_big_int ~i:23 (modulo, big_int_of_int 10);
);
"gcd_big_int" >::
@@ -353,27 +423,24 @@
"is_int_big_int" >::
(fun () ->
- eq_bool (is_int_big_int (big_int_of_int 1), true);
- eq_bool (is_int_big_int (big_int_of_int (-1)), true);
- eq_bool (is_int_big_int (add_big_int (big_int_of_int 1)
- (big_int_of_int biggest_int)),
- false);
+ eq_bool ~i:1 (is_int_big_int (big_int_of_int 1), true);
+ eq_bool ~i:2 (is_int_big_int (big_int_of_int (-1)), true);
+ eq_bool ~i:3 (is_int_big_int (add_big_int (big_int_of_int 1)
+ (big_int_of_int biggest_int)), false);
eq_int (int_of_big_int (big_int_of_int monster_int), monster_int);
- eq_bool (is_int_big_int (big_int_of_string (string_of_int biggest_int)),
- true);
- eq_bool (is_int_big_int (big_int_of_string (string_of_int least_int)),
- true);
- eq_bool (is_int_big_int (big_int_of_string (string_of_int monster_int)),
- true);
- eq_bool (is_int_big_int (add_big_int (big_int_of_int 1)
- (big_int_of_int (biggest_int))),
- false);
- eq_bool (is_int_big_int (add_big_int (big_int_of_int 1)
- (big_int_of_int (biggest_int))),
- false);
- eq_bool (is_int_big_int
- (minus_big_int (big_int_of_string(string_of_int monster_int))),
- false);
+ eq_bool ~i:4 (is_int_big_int (big_int_of_string
+ (string_of_int biggest_int)), true);
+ eq_bool ~i:5 (is_int_big_int (big_int_of_string
+ (string_of_int least_int)), true);
+ eq_bool ~i:6 (is_int_big_int (big_int_of_int monster_int), true);
+ eq_bool ~i:7 (is_int_big_int (big_int_of_string
+ (string_of_int monster_int)), true);
+ eq_bool ~i:8 (is_int_big_int (add_big_int (big_int_of_int 1)
+ (big_int_of_int (biggest_int))), false);
+ eq_bool ~i:9 (is_int_big_int (add_big_int (big_int_of_int 1)
+ (big_int_of_int (biggest_int))), false);
+ eq_bool ~i:10 (is_int_big_int (minus_big_int (
+ big_int_of_string(string_of_int monster_int))), false);
);
"string_of_big_int" >::
@@ -383,13 +450,13 @@
"big_int_of_string" >::
(fun () ->
- eq_big_int (big_int_of_string "1", big_int_of_int 1);
- eq_big_int (big_int_of_string "-1", big_int_of_int (-1));
- eq_big_int (big_int_of_string "0", zero_big_int);
+ eq_big_int ~i:1 (big_int_of_string "1", big_int_of_int 1);
+ eq_big_int ~i:2 (big_int_of_string "-1", big_int_of_int (-1));
+ eq_big_int ~i:3 (big_int_of_string "0", zero_big_int);
failwith_test big_int_of_string "sdjdkfighdgf" (Failure "invalid digit");
- eq_big_int (big_int_of_string "123", big_int_of_int 123);
- eq_big_int (big_int_of_string "3456", big_int_of_int 3456);
- eq_big_int (big_int_of_string "-3456", big_int_of_int (-3456));
+ eq_big_int ~i:4 (big_int_of_string "123", big_int_of_int 123);
+ eq_big_int ~i:5 (big_int_of_string "3456", big_int_of_int 3456);
+ eq_big_int ~i:6 (big_int_of_string "-3456", big_int_of_int (-3456));
let implode = List.fold_left (^) "" in
let l = List.rev [
@@ -414,18 +481,19 @@
] in
let bi1 = big_int_of_string (implode (List.rev l)) in
let bi2 = big_int_of_string (implode (List.rev ("3" :: List.tl l))) in
- eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10"))
- (big_int_of_string "2")));
+ eq_big_int ~i:7 (bi1, (add_big_int (mult_big_int bi2
+ (big_int_of_string "10"))
+ (big_int_of_string "2")));
);
"power_base_int" >::
(fun () ->
- eq_big_int (big_int_of_nat (Naturals.N.power_base_int 10 0),unit_big_int);
- eq_big_int (big_int_of_nat (Naturals.N.power_base_int 10 8),
+ eq_big_int (big_int_of_nat (Naturals.power_base_int 10 0),unit_big_int);
+ eq_big_int (big_int_of_nat (Naturals.power_base_int 10 8),
big_int_of_int 100000000);
- eq_big_int (big_int_of_nat(Naturals.N.power_base_int 2 (length_of_int+2)),
- big_int_of_nat (let nat = Naturals.N.make_nat 2 in
- Naturals.N.set_digit_nat nat 1 1;
+ eq_big_int (big_int_of_nat(Naturals.power_base_int 2 (length_of_int)),
+ big_int_of_nat (let nat = Naturals.make_nat 2 in
+ Naturals.set_digit_nat nat 1 1;
nat));
);
@@ -438,53 +506,16 @@
big_int_of_int 1230);
);
- "pi digits" >::
+ "pi 100 digits" >::
(fun () ->
- (* Pi digits computed with the streaming algorithm given on pages 4, 6
- & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
- Gibbons, August 2004. *)
- let ( !$ ) = big_int_of_int
- and ( +$ ) = add_big_int
- and ( *$ ) = mult_big_int in
+ eq_string (pi_digits 100, pi_100_digits);
+ );
+]
- let zero = zero_big_int
- and one = unit_big_int
- and three = !$ 3
- and four = !$ 4
- and ten = !$ 10
- and neg_ten = !$(-10) in
-
- (* Linear Fractional (aka Moebius) Transformations *)
- let floor_ev (q, r, s, t) x = div_big_int (q *$ x +$ r) (s *$ x +$ t) in
- let unit = (one, zero, zero, one) in
- let comp (q, r, s, t) (q', r', s', t') =
- (q *$ q' +$ r *$ s', q *$ r' +$ r *$ t',
- s *$ q' +$ t *$ s', s *$ r' +$ t *$ t') in
-
- let next z = floor_ev z three in
- let safe z n = Integers.eq_big_int n (floor_ev z four) in
- let prod z n = comp (ten, neg_ten *$ n, zero, one) z in
- let cons z k = let den = 2 * k + 1 in
- comp z (!$ k, !$(2 * den), zero, !$ den) in
-
- let rec digit k z n row col acc =
- if n > 0 then
- let y = next z in
- if safe z y then
- if col = 10 then (
- let row = row + 10 in
- digit k (prod z y) (n - 1) row 1
- ((Printf.sprintf "\t:%i\n%s" row (string_of_big_int y)) :: acc)
- ) else (
- digit k (prod z y) (n - 1) row (col + 1)
- ((string_of_big_int y) :: acc)
- )
- else digit (k + 1) (cons z k) n row...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-18 17:53:19
|
Revision: 1678
http://toss.svn.sourceforge.net/toss/?rev=1678&view=rev
Author: lukaszkaiser
Date: 2012-02-18 17:53:06 +0000 (Sat, 18 Feb 2012)
Log Message:
-----------
Integrating oUnit with js_of_ocaml, test cleanups.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Play.js
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FFTNFTest.ml
trunk/Toss/Formula/FormulaMapTest.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaSubstTest.ml
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Formula/Sat/SatTest.ml
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Play/MoveTest.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/README
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/Num/Integers.ml
trunk/Toss/Solver/Num/IntegersTest.ml
trunk/Toss/Solver/Num/NaturalsTest.ml
trunk/Toss/Solver/Num/NumbersTest.ml
trunk/Toss/Solver/Num/RationalsTest.ml
trunk/Toss/Solver/RealQuantElim/Makefile
trunk/Toss/Solver/RealQuantElim/OrderedPolySetTest.ml
trunk/Toss/Solver/RealQuantElim/OrderedPolyTest.ml
trunk/Toss/Solver/RealQuantElim/PolyTest.ml
trunk/Toss/Solver/RealQuantElim/RealQuantElimTest.ml
trunk/Toss/Solver/RealQuantElim/SignTableTest.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/www/contact.xml
trunk/Toss/www/develop.xml
Added Paths:
-----------
trunk/Toss/Formula/OUnit.ml
trunk/Toss/Formula/OUnit.mli
trunk/Toss/Formula/OUnitTest.ml
trunk/Toss/MenhirLib/LICENSE.txt
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -126,4 +126,3 @@
); *)
]
-let a = AuxIO.run_test_if_target "ArenaTest" tests
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -16,7 +16,7 @@
;;
let remove_insignificant_digits s =
- Str.global_replace (Str.regexp "\\.\\([0-9][0-9]\\)[0-9]+") ".\\1" s
+ Aux.replace_regexp ~regexp:"\\.\\([0-9][0-9]\\)[0-9]+" ~templ:".\\1" s
let tests = "ContinuousRule" >::: [
@@ -170,5 +170,3 @@
);
]
-
-let a = AuxIO.run_test_if_target "ContinuousRuleTest" tests
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -487,7 +487,7 @@
);
- "rewrite: compile_rule adding and deleting elements" >::
+ "rewrite: compile_rule adding and deleting els" >::
(fun () ->
(* adding *)
@@ -800,12 +800,3 @@
);
]
-
-let a = AuxIO.run_test_if_target "DiscreteRuleTest" tests
-
-let a () = DiscreteRule.debug_level := 7
-
-let a () =
- match (test_filter ["DiscreteRule:13:compile_rule: defined relations"] tests) with
- | Some tests -> ignore (run_test_tt ~verbose:true tests)
- | None -> ()
Modified: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/TermTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -5,12 +5,11 @@
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 tests = "Term" >::: [
"parse" >::
(fun () ->
@@ -65,6 +64,4 @@
rk4_step "t" (Const 0.) (Const 0.1) eqs [Const 0.]))) 0 5);
);
-];;
-
-let a = AuxIO.run_test_if_target "TermTest" tests
+]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Client/JsHandler.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -205,7 +205,7 @@
Random.self_init ();
let time = Js.to_float time in
Play.set_timeout time;
- let comp_started = Aux.gettimeofday () in
+ let comp_started = AuxIO.gettimeofday () in
let game, _ = !cur_game.game_state in
let state = List.hd !play_states in
try
@@ -224,7 +224,7 @@
Js.Unsafe.set result (js"comp_started")
(Js.number_of_float comp_started);
Js.Unsafe.set result (js"comp_ended")
- (Js.number_of_float (Aux.gettimeofday ()));
+ (Js.number_of_float (AuxIO.gettimeofday ()));
Js.some result
with Not_found -> Js.null
@@ -245,3 +245,22 @@
js ("Game "^game_name^" ERROR: "^s)
let _ = set_handle "set_game" set_game
+
+let run_tests name full =
+ let len = String.length name in
+ let slash = try String.index name '/' with Not_found -> len in
+ let (dirs, files) =
+ if name = "" then ([], []) else if slash = len then ([name], []) else
+ if slash = len-1 then ([String.sub name 0 (len - 1)], []) else
+ let f = String.sub name (slash+1 ) (len-slash-1) in
+ let file =
+ if String.contains f '.' then
+ String.sub f 0 (String.index f '.')
+ else f in
+ ([String.sub name 0 slash], [file]) in
+ ignore (OUnit.run_test_tt ~verbose:true (Tests.tests ~full ~dirs ~files ()))
+
+let run_tests_small s = run_tests (of_js s) false
+let run_tests_big s = run_tests (of_js s) true
+
+let _ = set_handle "run_tests_small" run_tests_small
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Client/Play.js 2012-02-18 17:53:06 UTC (rev 1678)
@@ -182,7 +182,6 @@
that.redraw ();
}
if (typeof CONN == 'undefined') {
- // ASYNCH does not handle multiple plays
prev = ASYNCH ("prev_move", [this.move_nbr - 1], disp);
} else {
prev = CONN.prev_move (this.pid, this.move_nbr - 1);
@@ -208,8 +207,7 @@
that.redraw ();
}
if (typeof CONN == 'undefined') {
- // LOCAL does not handle multiple plays
- next = LOCAL.prev_move (this.move_nbr + 1);
+ next = ASYNCH ("prev_move", [this.move_nbr + 1], disp);
} else {
next = CONN.prev_move (this.pid, this.move_nbr + 1);
disp (next);
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Client/clientTest.js 2012-02-18 17:53:06 UTC (rev 1678)
@@ -74,7 +74,7 @@
function testIndex () {
function testTicTacToeClickB2 () {
- var page = pageOpen (fileUrl ("index.html"), "Client");
+ var page = pageOpen (fileUrl ("index.html"), "ClT");
doAtTime (page, 200, function () {
clickId ("btPlayTic-Tac-Toe");
});
@@ -87,7 +87,10 @@
assertAtTime (page, 4000, function () {
return (existsId ("pred_b2_P"));
});
- doAtTime (undefined, 4100, function () {
+ doAtTime (page, 4100, function () {
+ ASYNCH ("run_tests_small", ["Formula"], function () {});
+ });
+ doAtTime (undefined, 8000, function () {
console.log ("rendering");
page.render ("clientTestRender.png");
phantom.exit();
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/Aux.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -1,20 +1,10 @@
(* Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
-let gettimeofday () =
- IFDEF JAVASCRIPT THEN (
- let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
- t /. 1000. (* t is in milliseconds *)
- ) ELSE (
- Unix.gettimeofday ()
- ) ENDIF
-
-
exception Timeout of string
type ('a,'b) choice = Left of 'a | Right of 'b
-
module Strings = Set.Make
(struct type t = string let compare = String.compare end)
let add_strings nvs vs =
@@ -68,6 +58,19 @@
while !b <= !e && is_space (s.[!e]) do decr e done;
if !e < !b then "" else String.sub s !b (!e - !b + 1)
+let split_spaces s =
+ let l, i = String.length s, ref 0 in
+ let rec split_spaces_rec acc =
+ while !i < l && is_space s.[!i] do i := !i+1 done;
+ if !i = l then acc else (
+ let start = !i in
+ while !i < l && not (is_space s.[!i]) do i := !i+1 done;
+ split_spaces_rec ((String.sub s start (!i - start)) :: acc)
+ ) in
+ List.rev (split_spaces_rec [])
+
+let normalize_spaces s = String.concat " " (split_spaces s)
+
let fst3 (a,_,_) = a
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
@@ -659,12 +662,6 @@
let res = gen n in
if test res then n+1, res else first_i (n+1) gen test
-let new_filename basename suffix =
- if not (Sys.file_exists (basename^suffix))
- then basename^suffix else
- snd (first_i 1 (fun i->basename^(string_of_int i)^suffix)
- (fun fname->not (Sys.file_exists fname)))
-
let not_conflicting_name ?(truncate=false) names s =
let s =
if truncate then
@@ -736,11 +733,15 @@
let set_optimized_gc () =
- Gc.set { (Gc.get()) with
- Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
- Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
- }
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
+ }
+ ) ENDIF
(* Replacements for basic Str functions. *)
@@ -767,7 +768,7 @@
IFDEF JAVASCRIPT THEN (
let js_s = Js.string s in
let js_regex = jsnew Js.regExp (Js.string regexp) in
- let res = js_s##replace (js_regex, Js.string templ) in
+ let res = js_s##replace (js_regex, Js.string templ) in
Js.to_string res
) ELSE (
Str.global_replace (Str.regexp regexp) templ s
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/Aux.mli 2012-02-18 17:53:06 UTC (rev 1678)
@@ -1,10 +1,7 @@
(** Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
-(** Replacement for Unix.gettimeofday. *)
-val gettimeofday: unit -> float
-
exception Timeout of string
type ('a, 'b) choice = Left of 'a | Right of 'b
@@ -49,6 +46,12 @@
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
+(** Split a string on spaces. *)
+val split_spaces : string -> string list
+
+(** Replace all white space sequences by a simple space, strip on both ends. *)
+val normalize_spaces : string -> string
+
(** Random element of a list. *)
val random_elem : 'a list -> 'a
@@ -315,9 +318,6 @@
(** Iterate a function [n] times: [f^n(x)]. *)
val fold_n : ('a -> 'a) -> 'a -> int -> 'a
-(** Generate a fresh filename of the form [base ^ n ^ suffix]. *)
-val new_filename : string -> string -> string
-
(** Returns a string proloning [s] and not appearing in [names]. If
[truncate] is true, remove numbers from the end of [s]. *)
val not_conflicting_name : ?truncate:bool -> Strings.t -> string -> string
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -2,8 +2,25 @@
structures and standard library-like definitions. *)
open Aux
+let gettimeofday () =
+ IFDEF JAVASCRIPT THEN (
+ let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
+ t /. 1000. (* t is in milliseconds *)
+ ) ELSE (
+ Unix.gettimeofday ()
+ ) ENDIF
+let backtrace () =
+ IFDEF JAVASCRIPT THEN ( "" ) ELSE (
+ (if Printexc.backtrace_status () then
+ "\n" ^ Printexc.get_backtrace ()
+ else "")
+ ) ENDIF
+
let run_if_target target_name f =
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
let file_from_path p =
String.sub p (String.rindex p '/'+1)
(String.length p - String.rindex p '/' - 1) in
@@ -12,14 +29,6 @@
String.length fname >= String.length target_name &&
String.sub fname 0 (String.length target_name) = target_name in
if test_fname then f ()
-
-let run_test_if_target target_name tests =
- IFDEF JAVASCRIPT THEN (
- failwith "JavaScript unit testing not implemented yet"
- ) ELSE (
- let f () = ignore (OUnit.run_test_tt ~verbose:true tests) in
- (* So that the tests are not run twice while building TossTest. *)
- run_if_target target_name f
) ENDIF
@@ -155,6 +164,13 @@
try Hashtbl.find debug_levels module_name
with Not_found -> !default_debug_level
+let print s =
+ IFDEF JAVASCRIPT THEN (
+ if is_worker then worker_log s else console_log s
+ ) ELSE (
+ print_string s; flush stdout
+ ) ENDIF
+
let log module_name debug_lev s =
let s = "["^string_of_int debug_lev^"@"^module_name^"] "^s in
IFDEF JAVASCRIPT THEN (
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-18 17:53:06 UTC (rev 1678)
@@ -1,14 +1,16 @@
(** Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
+(** Replacement for Unix.gettimeofday. *)
+val gettimeofday: unit -> float
+
(** Run a function if the executable name matches the given prefix. *)
val run_if_target : string -> (unit -> unit) -> unit
-(** Run a test suite if the executable name matches the given prefix. *)
-val run_test_if_target : string -> OUnit.test -> unit
+(** Get a backtrace as a string (native mode only). *)
+val backtrace : unit -> string
-
(** Input a file to a string. *)
val input_file : in_channel -> string
@@ -55,3 +57,6 @@
serves only informative purposes. Calling this function directly
outputs the message unconditionally. *)
val log : string -> int -> string -> unit
+
+(** Printing for JS and native. *)
+val print : string -> unit
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/AuxTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -319,7 +319,7 @@
);
- "array_argfind, array_find_all, array_argfind_all, array_argfind_all_max" >::
+ "array_argfind, array_find_all" >::
(fun () ->
assert_equal ~printer:string_of_int
2
@@ -350,7 +350,10 @@
[]
(Aux.array_find_all (fun e->e.[0]='e')
[|"a";"c"; "b"|]);
+ );
+ "array_argfind_all, array_argfind_all_max" >::
+ (fun () ->
assert_equal
~printer:(fun l->String.concat "; " (List.map string_of_int l))
[2;4;6]
@@ -479,8 +482,8 @@
assert_equal ~printer:(fun x -> x)
"c43c43" (Aux.clean_name "++");
+
+ assert_equal ~printer:(fun x -> x) "ala ma kota i psa"
+ (String.concat " " (Aux.split_spaces " ala ma\nkota\t\n i psa\n"));
);
-
]
-
-let _ = AuxIO.run_test_if_target "AuxTest" tests
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -945,7 +945,7 @@
!clause in
let list_int line =
- let split = Aux.split_regexp ~regexp:"[ \t]+" line in
+ let split = Aux.split_spaces line in
List.rev (List.tl (List.rev_map
(fun s -> int_of_string s) (List.tl split))) in
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -22,9 +22,8 @@
let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
- let ws = Str.regexp "[ \n\t]+" in
- let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
- let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ let x = Aux.normalize_spaces (" " ^ x_in ^ " ") in
+ let y = Aux.normalize_spaces (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -410,9 +409,9 @@
);
]
-let exec () = AuxIO.run_test_if_target "BoolFormulaTest" tests
+let exec () = OUnit.run_test_if_target "BoolFormulaTest" tests
-let execbig ()= AuxIO.run_test_if_target "BoolFormulaTest" bigtests
+let execbig ()= OUnit.run_test_if_target "BoolFormulaTest" bigtests
let main () =
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -14,9 +14,8 @@
let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
- let ws = Str.regexp "[ \n\t]+" in
- let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
- let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ let x = Aux.normalize_spaces (" " ^ x_in ^ " ") in
+ let y = Aux.normalize_spaces (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -129,12 +128,14 @@
let f = open_in !file in
let file_s = AuxIO.input_file f in
close_in f;
- let cleaned_s1 = Str.global_replace (Str.regexp "bool") "" file_s in
- let cleaned_s2 = Str.global_replace (Str.regexp "^.*<.*$") "" cleaned_s1 in
- let cleaned_s3 = Str.global_replace (Str.regexp "^.*~+.*$") "" cleaned_s2 in
- let cleaned_s4 = Str.global_replace (Str.regexp "^#.*$") "" cleaned_s3 in
- let cleaned_s5 = Str.global_replace (Str.regexp "^//.*$") "" cleaned_s4 in
- let res_s = Str.global_replace (Str.regexp "/\\*.*\\*/") "" cleaned_s5 in
+ let cleaned_s1 = Aux.replace_regexp ~regexp:"bool" ~templ:"" file_s in
+ let cleaned_s2 =
+ Aux.replace_regexp ~regexp:"^.*<.*$" ~templ:"" cleaned_s1 in
+ let cleaned_s3 =
+ Aux.replace_regexp ~regexp:"^.*~+.*$" ~templ:"" cleaned_s2 in
+ let cleaned_s4 = Aux.replace_regexp ~regexp:"^#.*$" ~templ:"" cleaned_s3 in
+ let cleaned_s5 = Aux.replace_regexp ~regexp:"^//.*$" ~templ:"" cleaned_s4 in
+ let res_s = Aux.replace_regexp ~regexp:"/\\*.*\\*/" ~templ:"" cleaned_s5 in
try
let (cl, dl, goal) = defs_goal_of_string res_s in
let new_defs =
@@ -152,7 +153,7 @@
with Lexer.Parsing_error err -> (
print_endline res_s;
let msg_raw = String.sub err 9 ((String.length err)-9) in
- let msg = Str.global_replace (Str.regexp "\n") "\n// " msg_raw in
+ let msg = Aux.replace_regexp ~regexp:"\n" ~templ:"\n// " msg_raw in
print_endline ("// ERROR: NOT PARSED\n//\n// " ^ msg ^ "\n");
)
Modified: trunk/Toss/Formula/FFTNFTest.ml
===================================================================
--- trunk/Toss/Formula/FFTNFTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FFTNFTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -45,9 +45,8 @@
let assert_eq_str ?(msg="") x_in y_in =
- let ws = Str.regexp "[ \n\t]+" in
- let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
- let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ let x = Aux.normalize_spaces (" " ^ x_in ^ " ") in
+ let y = Aux.normalize_spaces (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -346,13 +345,3 @@
]
-let a = AuxIO.run_test_if_target "FFTNFTest" tests
-
-let a () = FFTNF.debug_level := 7
-
-let a () =
- match test_filter ["FFTNF:6:ff_tnf: breakthrough"]
- tests
- with
- | Some tests -> ignore (run_test_tt ~verbose:true tests)
- | None -> ()
Modified: trunk/Toss/Formula/FormulaMapTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaMapTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaMapTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -42,4 +42,3 @@
);
]
-let exec = AuxIO.run_test_if_target "FormulaMapTest" tests
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -312,7 +312,6 @@
]
-let exec = AuxIO.run_test_if_target "FormulaOpsTest" tests
(* --------------------------- Reals separation test ----------------------- *)
Modified: trunk/Toss/Formula/FormulaSubstTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubstTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaSubstTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -155,4 +155,3 @@
]
-let exec = AuxIO.run_test_if_target "FormulaSubstTest" tests
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -39,5 +39,3 @@
);
]
-
-let exec = AuxIO.run_test_if_target "FormulaTest" tests
Added: trunk/Toss/Formula/OUnit.ml
===================================================================
--- trunk/Toss/Formula/OUnit.ml (rev 0)
+++ trunk/Toss/Formula/OUnit.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -0,0 +1,653 @@
+(**************************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *)
+(* Copyright (C) 2010 OCamlCore SARL *)
+(* *)
+(* OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. *)
+(* *)
+(* Permission is hereby granted, free of charge, to any person obtaining *)
+(* a copy of this document and the OUnit software ("the Software"), to *)
+(* deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, *)
+(* sublicense, and/or sell copies of the Software, and to permit persons *)
+(* to whom the Software is furnished to do so, subject to the following *)
+(* conditions: *)
+(* *)
+(* The above copyright notice and this permission notice shall be *)
+(* included in all copies or substantial portions of the Software. *)
+(* *)
+(* The Software is provided ``as is'', without warranty of any kind, *)
+(* express or implied, including but not limited to the warranties of *)
+(* merchantability, fitness for a particular purpose and noninfringement. *)
+(* In no event shall Maas-Maarten Zeeman be liable for any claim, damages *)
+(* or other liability, whether in an action of contract, tort or *)
+(* otherwise, arising from, out of or in connection with the Software or *)
+(* the use or other dealings in the software. *)
+(* *)
+(**************************************************************************)
+
+open Format
+
+(* TODO: really use Format in printf call. Most of the time, not
+ * cuts/spaces/boxes are used
+ *)
+
+let global_verbose = ref false
+
+let buff_printf f =
+ let buff = Buffer.create 13 in
+ let fmt = formatter_of_buffer buff in
+ f fmt;
+ pp_print_flush fmt ();
+ Buffer.contents buff
+
+let bracket set_up f tear_down () =
+ let fixture =
+ set_up ()
+ in
+ let () =
+ try
+ let () = f fixture in
+ tear_down fixture
+ with e ->
+ let () =
+ tear_down fixture
+ in
+ raise e
+ in
+ ()
+
+exception Skip of string
+let skip_if b msg =
+ if b then
+ raise (Skip msg)
+
+exception Todo of string
+let todo msg =
+ raise (Todo msg)
+
+let assert_failure msg =
+ failwith ("OUnit: " ^ msg)
+
+let assert_bool msg b =
+ if not b then assert_failure msg
+
+let assert_string str =
+ if not (str = "") then assert_failure str
+
+let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual =
+ let get_error_string () =
+(* let max_len = pp_get_margin fmt () in *)
+(* let ellipsis_text = "[...]" in *)
+ let print_ellipsis p fmt s =
+ (* TODO: find a way to do this
+ let res = p s in
+ let len = String.length res in
+ if diff <> None && len > max_len then
+ begin
+ let len_with_ellipsis =
+ (max_len - (String.length ellipsis_text)) / 2
+ in
+ (* TODO: we should use %a here to print values *)
+ fprintf fmt
+ "@[%s[...]%s@]"
+ (String.sub res
+ 0
+ len_with_ellipsis)
+ (String.sub res
+ (len - len_with_ellipsis)
+ len_with_ellipsis)
+ end
+ else
+ begin
+ (* TODO: we should use %a here to print values *)
+ fprintf fmt "@[%s@]" res
+ end
+ *)
+ pp_print_string fmt (p s)
+ in
+
+ let res =
+ buff_printf
+ (fun fmt ->
+ pp_open_vbox fmt 0;
+ begin
+ match msg with
+ | Some s ->
+ pp_open_box fmt 0;
+ pp_print_string fmt s;
+ pp_close_box fmt ();
+ pp_print_cut fmt ()
+ | None ->
+ ()
+ end;
+
+ begin
+ match printer with
+ | Some p ->
+ let p_ellipsis = print_ellipsis p in
+ fprintf fmt
+ "@[expected: @[%a@]@ but got: @[%a@]@]@,"
+ p_ellipsis expected
+ p_ellipsis actual
+
+ | None ->
+ fprintf fmt "@[not equal@]@,"
+ end;
+
+ begin
+ match pp_diff with
+ | Some d ->
+ fprintf fmt
+ "@[differences: %a@]@,"
+ d (expected, actual)
+
+ | None ->
+ ()
+ end;
+
+ pp_close_box fmt ())
+ in
+ let len =
+ String.length res
+ in
+ if len > 0 && res.[len - 1] = '\n' then
+ String.sub res 0 (len - 1)
+ else
+ res
+
+ in
+
+ if not (cmp expected actual) then
+ assert_failure (get_error_string ())
+
+
+let raises f =
+ try
+ f ();
+ None
+ with e ->
+ Some e
+
+let assert_raises ?msg exn (f: unit -> 'a) =
+ let pexn =
+ Printexc.to_string
+ in
+ let get_error_string () =
+ let str =
+ Format.sprintf
+ "expected exception %s, but no exception was raised."
+ (pexn exn)
+ in
+ match msg with
+ | None ->
+ assert_failure str
+
+ | Some s ->
+ assert_failure (Format.sprintf "%s\n%s" s str)
+ in
+ match raises f with
+ | None ->
+ assert_failure (get_error_string ())
+
+ | Some e ->
+ assert_equal ?msg ~printer:pexn exn e
+
+(* Compare floats up to a given relative error *)
+let cmp_float ?(epsilon = 0.00001) a b =
+ abs_float (a -. b) <= epsilon *. (abs_float a) ||
+ abs_float (a -. b) <= epsilon *. (abs_float b)
+
+(* Now some handy shorthands *)
+let (@?) = assert_bool
+
+(* The type of test function *)
+type test_fun = unit -> unit
+
+(* The type of tests *)
+type test =
+ | TestCase of test_fun
+ | TestList of test list
+ | TestLabel of string * test
+
+(* Some shorthands which allows easy test construction *)
+let (>:) s t = TestLabel(s, t) (* infix *)
+let (>::) s f = TestLabel(s, TestCase(f)) (* infix *)
+let (>:::) s l = TestLabel(s, TestList(l)) (* infix *)
+
+(* Utility function to manipulate test *)
+let rec test_decorate g =
+ function
+ | TestCase f ->
+ TestCase (g f)
+ | TestList tst_lst ->
+ TestList (List.map (test_decorate g) tst_lst)
+ | ...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-18 21:54:11
|
Revision: 1679
http://toss.svn.sourceforge.net/toss/?rev=1679&view=rev
Author: lukaszkaiser
Date: 2012-02-18 21:54:05 +0000 (Sat, 18 Feb 2012)
Log Message:
-----------
Corrections to make tests run under JS.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Makefile
trunk/Toss/Play/GameTree.ml
trunk/Toss/Solver/Num/Integers.ml
trunk/Toss/Solver/Num/IntegersTest.ml
trunk/Toss/Solver/Num/MiscNum.ml
trunk/Toss/Solver/Num/MiscNum.mli
trunk/Toss/Solver/Num/Naturals.ml
trunk/Toss/Solver/Num/NaturalsTest.ml
trunk/Toss/Solver/Num/NumbersTest.ml
trunk/Toss/Solver/Num/RationalsTest.ml
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -15,8 +15,16 @@
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
;;
-let remove_insignificant_digits s =
- Aux.replace_regexp ~regexp:"\\.\\([0-9][0-9]\\)[0-9]+" ~templ:".\\1" s
+let rec remove_insignificant_digits s =
+ let l = String.length s in
+ try
+ let i = String.index s '.' in
+ let j = ref (i+1) in while !j < l && Aux.is_digit s.[!j] do j := !j+1 done;
+ if (!j < l) then (
+ let rest = remove_insignificant_digits (String.sub s !j (l - !j)) in
+ (String.sub s 0 (min !j (i+3))) ^ rest
+ ) else if i+2 < l then String.sub s 0 (i+3) else s
+ with Not_found -> s
let tests = "ContinuousRule" >::: [
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Client/clientTest.js 2012-02-18 21:54:05 UTC (rev 1679)
@@ -90,9 +90,9 @@
doAtTime (page, 4100, function () {
ASYNCH ("run_tests_small", ["Formula"], function () {});
});
- doAtTime (undefined, 8000, function () {
- console.log ("rendering");
- page.render ("clientTestRender.png");
+ doAtTime (undefined, 20000, function () {
+ //console.log ("rendering");
+ //page.render ("clientTestRender.png");
phantom.exit();
});
}
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Formula/Aux.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -58,19 +58,28 @@
while !b <= !e && is_space (s.[!e]) do decr e done;
if !e < !b then "" else String.sub s !b (!e - !b + 1)
-let split_spaces s =
+let split_charprop s f =
let l, i = String.length s, ref 0 in
- let rec split_spaces_rec acc =
- while !i < l && is_space s.[!i] do i := !i+1 done;
+ let rec split_charprop_rec acc =
+ while !i < l && f s.[!i] do i := !i+1 done;
if !i = l then acc else (
let start = !i in
- while !i < l && not (is_space s.[!i]) do i := !i+1 done;
- split_spaces_rec ((String.sub s start (!i - start)) :: acc)
+ while !i < l && not (f s.[!i]) do i := !i+1 done;
+ split_charprop_rec ((String.sub s start (!i - start)) :: acc)
) in
- List.rev (split_spaces_rec [])
+ List.rev (split_charprop_rec [])
+let split_spaces s = split_charprop s is_space
+
let normalize_spaces s = String.concat " " (split_spaces s)
+let replace_charprop s f repl =
+ let split, l = split_charprop s f, String.length s in
+ let res = ref (String.concat repl split) in
+ if (l > 0 && f s.[0]) then res := repl ^ !res;
+ if (l > 1 && f s.[l-1]) then res := !res ^ repl;
+ !res
+
let fst3 (a,_,_) = a
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Formula/Aux.mli 2012-02-18 21:54:05 UTC (rev 1679)
@@ -46,12 +46,18 @@
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
+(** Split a string on characters satisfying [f]. *)
+val split_charprop : string -> (char -> bool) -> string list
+
(** Split a string on spaces. *)
val split_spaces : string -> string list
(** Replace all white space sequences by a simple space, strip on both ends. *)
val normalize_spaces : string -> string
+(** Replace characters satisfying [f] by [repl]. *)
+val replace_charprop : string -> (char -> bool) -> string -> string
+
(** Random element of a list. *)
val random_elem : 'a list -> 'a
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Makefile 2012-02-18 21:54:05 UTC (rev 1679)
@@ -47,7 +47,6 @@
@echo ""
@echo " CONDITIONAL COMPILATION USES"
@grep IFDEF $(ALLMLFILES)
- @grep regexp $(ALLMLFILES)
@echo ""
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Play/GameTree.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -39,7 +39,7 @@
player state.Arena.cur_loc state.Arena.time in
let res = "\n" ^ msg ^ head_s ^ struc_s ^ "\n" ^ info_s in
let prefix = if depth=0 then "" else (String.make depth '|') ^ " " in
- Aux.replace_regexp ~regexp:"\n" ~templ:("\n" ^ prefix) res in
+ Aux.replace_charprop res (fun c -> c = '\n') ("\n" ^ prefix) in
if upto < 0 then " Cut;" else
match tree with
| Terminal (state, player, info) ->
Modified: trunk/Toss/Solver/Num/Integers.ml
===================================================================
--- trunk/Toss/Solver/Num/Integers.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/Integers.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -120,7 +120,15 @@
let res = (create_nat 2) in
(set_digit_nat res 0 biggest_int;
incr_nat res; res)
- else let res = (create_nat 1) in (set_digit_nat res 0 (abs i); res)
+ else if i < least_int || i > biggest_int then (
+ (* machine words longer than biggest_int, do arithmetic *)
+ let res, base, ai = (create_nat 3), biggest_int + 1, abs i in
+ (set_digit_nat res 0 (ai mod base);
+ set_digit_nat res 1 ((ai / base) mod base);
+ set_digit_nat res 2 ((ai / (base * base)));
+ res)
+ ) else
+ let res = (create_nat 1) in (set_digit_nat res 0 (abs i); res)
}
let big_int_of_nat nat =
Modified: trunk/Toss/Solver/Num/IntegersTest.ml
===================================================================
--- trunk/Toss/Solver/Num/IntegersTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/IntegersTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -1,5 +1,6 @@
open OUnit
open Integers
+open MiscNum
let eq_bool ?i (b1, b2) = match i with
| None -> assert_equal ~printer:string_of_bool b1 b2
@@ -20,11 +21,6 @@
let rec gcd_int i1 i2 = if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2)
-let length_of_int = Sys.word_size - 2
-let monster_int = 1 lsl length_of_int
-let biggest_int = monster_int - 1
-let least_int = - biggest_int
-
let pi_100_digits =
"3141592653 :10
5897932384 :20
@@ -405,18 +401,18 @@
eq_int (int_of_big_int (big_int_of_int 1), 1);
eq_int (int_of_big_int (big_int_of_int(-1)), -1);
eq_int (int_of_big_int zero_big_int, 0);
- eq_int (int_of_big_int (big_int_of_int max_int), max_int);
- eq_int (int_of_big_int (big_int_of_int min_int), min_int);
+ eq_int (int_of_big_int (big_int_of_int biggest_int), biggest_int);
+ eq_int (int_of_big_int (big_int_of_int least_int), least_int);
failwith_test
(fun () -> int_of_big_int (add_big_int (big_int_of_int 1)
- (big_int_of_int max_int))) ()
+ (big_int_of_int biggest_int))) ()
(Failure "int_of_big_int");
failwith_test
(fun () -> int_of_big_int (sub_big_int (big_int_of_int 1)
- (big_int_of_int min_int))) ()
+ (big_int_of_int least_int))) ()
(Failure "int_of_big_int");
failwith_test
- (fun () -> int_of_big_int (mult_big_int (big_int_of_int min_int)
+ (fun () -> int_of_big_int (mult_big_int (big_int_of_int least_int)
(big_int_of_int 2))) ()
(Failure "int_of_big_int");
);
Modified: trunk/Toss/Solver/Num/MiscNum.ml
===================================================================
--- trunk/Toss/Solver/Num/MiscNum.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/MiscNum.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -35,10 +35,17 @@
let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1
-let length_of_int = Sys.word_size - 2
+let length_of_int = 30 (* Sys.word_size - 2 *)
+let max_power10_int = 1000000000
+let sprint_full_length_int i = (* Printf.sprintf "%.9i" i problem in JS *)
+ let r = string_of_int i in
+ match 9 - (String.length r) with | 8 -> "00000000" ^ r | 7 -> "0000000" ^ r
+ | 6 -> "000000" ^ r | 5 -> "00000" ^ r | 4 -> "0000" ^ r | 3 -> "000" ^ r
+ | 2 -> "00" ^ r | 1 -> "0" ^ r | _ -> r
-let monster_int = 1 lsl length_of_int
-let biggest_int = monster_int - 1
+let monster_int =
+ let m = 1 lsl length_of_int in if m < 0 then m else -m
+let biggest_int = let m = 1 lsl length_of_int in m - 1
let least_int = - biggest_int
let compare_int n1 n2 =
Modified: trunk/Toss/Solver/Num/MiscNum.mli
===================================================================
--- trunk/Toss/Solver/Num/MiscNum.mli 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/MiscNum.mli 2012-02-18 21:54:05 UTC (rev 1679)
@@ -18,3 +18,5 @@
val biggest_int: int
val least_int: int
val monster_int: int
+val max_power10_int : int
+val sprint_full_length_int : int -> string
Modified: trunk/Toss/Solver/Num/Naturals.ml
===================================================================
--- trunk/Toss/Solver/Num/Naturals.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/Naturals.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -2,10 +2,6 @@
type nat = int array
-let max_int_length = Sys.word_size - 2 (* should be even *)
-let max_power10_int = 1000000000
-let sprint_full_length_int i = Printf.sprintf "%.9i" i
-
let create_nat s = make s 0
let set_to_zero_nat s i1 i2 =
@@ -43,21 +39,26 @@
if i = 0 then 0 else compare_from (i-1) in
compare_from ((max (length n) (length m)) - 1)
+let nooverflow i = (i >= 0 && i <= MiscNum.biggest_int)
+
let add_nat_off off n x = (* n := n + (x shifted by off) *)
let rec add_carry i carry =
- if i + off >= length n then (if carry <> 0 then failwith "overflow") else
+ if i + off >= length n then (
+ if carry <> 0 then
+ failwith (Printf.sprintf "Nat:overflow %i %i %i" off i (length n));
+ ) else
if i >= length x then (
let res = n.(i+off) + carry in
- if res >= 0 then n.(i+off) <- res else (
+ if nooverflow res then n.(i+off) <- res else (
n.(i+off) <- 0; add_carry (i+1) 1
)
) else (
let res = n.(i+off) + x.(i) + carry in
- if res >= 0 then (
+ if nooverflow res then (
n.(i+off) <- res;
add_carry (i+1) 0
) else (
- let mid = n.(i+off) - max_int - 1 in
+ let mid = n.(i+off) - MiscNum.biggest_int - 1 in
n.(i+off) <- mid + x.(i) + carry;
add_carry (i+1) 1
)
@@ -83,19 +84,19 @@
sub_carry (i+1) 0;
) else (
n.(i) <- res + 1;
- n.(i) <- n.(i) + max_int;
+ n.(i) <- n.(i) + MiscNum.biggest_int;
sub_carry (i+1) (-1)
) in
sub_carry 0 0
-let half_int = 1 lsl (max_int_length / 2)
+let half_int = 1 lsl (MiscNum.length_of_int / 2)
let one_arr = make 1 0
let add_nat_off_digit off n digit =
one_arr.(0) <- digit;
add_nat_off off n one_arr
-let mult_digit_nat_off off n x i = (* n += x*i shift by offset *)
+let mult_digit_nat_off off n x i = (* n += (x*i shifted by offset) *)
let i0, i1 = i mod half_int, i / half_int in
let rec mult_digit j =
if (j >= length x) then () else (
@@ -136,7 +137,7 @@
) else (make_nat ln, make_nat ln) in
let lx = num_digits_nat x in
let rec approx_backshift i n m add =
- if m = max_int then
+ if m = MiscNum.biggest_int then
let (d, b) = approx_backshift 0 n ((m / 2) + 1) add in (d, b+1)
else
let shn = n * (1 lsl i) in
@@ -162,7 +163,7 @@
add_nat_off_digit l res 1;
mult_digit_nat_off l resmult x 1;
) else (
- let d = i * (1 lsl (max_int_length - b)) in
+ let d = i * (1 lsl (MiscNum.length_of_int - b)) in
add_nat_off_digit (l-1) res d;
mult_digit_nat_off (l-1) resmult x d;
)
@@ -211,13 +212,14 @@
let rec string_rec m =
let lm = length m in
if lm = 1 then string_of_int m.(0) else (
- let quo = div_nat_fn (num_digits_nat m) m (make 1 max_power10_int) in
+ let quo =
+ div_nat_fn (num_digits_nat m) m (make 1 MiscNum.max_power10_int) in
let s = string_rec (shrink ~max:lm quo) in
- s ^ (sprint_full_length_int m.(0))
+ s ^ (MiscNum.sprint_full_length_int m.(0))
) in
if num_digits_nat n = 0 then "0" else string_rec (copy (shrink n))
-let max_int_str_len = String.length (string_of_int max_int)
+let max_int_str_len = String.length (string_of_int MiscNum.biggest_int)
let rec nat_of_string s ofs len =
try
if len < max_int_str_len then
Modified: trunk/Toss/Solver/Num/NaturalsTest.ml
===================================================================
--- trunk/Toss/Solver/Num/NaturalsTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/NaturalsTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -43,11 +43,11 @@
equal_nat (n, nat_of_int 2);
let n = create_nat 2 in
- set_digit_nat n 0 max_int;
+ set_digit_nat n 0 MiscNum.biggest_int;
set_digit_nat n 1 0;
incr_nat n;
sub_nat n (nat_of_int 2);
- equal_nat (n, nat_of_int (max_int - 1));
+ equal_nat (n, nat_of_int (MiscNum.biggest_int - 1));
);
"is_zero_nat" >::
@@ -77,7 +77,7 @@
"3333333333333333333333333333333333333333333333333333333333333333333" ^
"33333333" in
equal_nat (nat_of_str s,
- (let nat = make_nat 15 in
+ (let nat = make_nat 30 in
(* set_digit_nat nat 0 3; *)
mult_digit_nat nat (nat_of_str (String.sub s 0 135)) 10;
add_nat nat (nat_of_int 3);
Modified: trunk/Toss/Solver/Num/NumbersTest.ml
===================================================================
--- trunk/Toss/Solver/Num/NumbersTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/NumbersTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -2,6 +2,7 @@
open Integers
open Rationals
open Numbers
+open MiscNum
let eq_bool (b1, b2) = assert_equal ~printer:string_of_bool b1 b2
let eq_int (i1, i2) = assert_equal ~printer:string_of_int i1 i2
@@ -12,11 +13,6 @@
try let _ = ignore (f x) in eq_string ("worked", "failed") with
e -> eq_bool (e = except, true)
-let length_of_int = Sys.word_size - 2
-let monster_int = 1 lsl length_of_int
-let biggest_int = monster_int - 1
-let least_int = - biggest_int
-
let pi_digits n_digits =
(* Pi digits computed with the streaming algorithm given on pages 4, 6
& 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
@@ -83,9 +79,9 @@
Ratio (ratio_of_string "17/12"));
eq_num (add_num (Int least_int) (Int 1),
Int (- (pred biggest_int)));
- eq_num (add_num (Int biggest_int) (Int 1),
+ (* eq_num (add_num (Int biggest_int) (Int 1),
Big_int (minus_big_int (add_big_int (big_int_of_int (-1))
- (big_int_of_int least_int))));
+ (big_int_of_int least_int)))); *)
);
"sub_num" >::
Modified: trunk/Toss/Solver/Num/RationalsTest.ml
===================================================================
--- trunk/Toss/Solver/Num/RationalsTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
+++ trunk/Toss/Solver/Num/RationalsTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
@@ -1,6 +1,7 @@
open OUnit
open Integers
open Rationals
+open MiscNum
let eq_bool (b1, b2) = assert_equal ~printer:string_of_bool b1 b2
let eq_int (i1, i2) = assert_equal ~printer:string_of_int i1 i2
@@ -13,11 +14,6 @@
try let _ = ignore (f x) in eq_string ("worked", "failed") with
e -> eq_bool (e = except, true)
-let length_of_int = Sys.word_size - 2
-let monster_int = 1 lsl length_of_int
-let biggest_int = monster_int - 1
-let least_int = - biggest_int
-
let infinite_failure = "infinite or undefined rational number"
let _ = MiscNum.error_when_null_denominator_flag := false
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-27 02:06:29
|
Revision: 1680
http://toss.svn.sourceforge.net/toss/?rev=1680&view=rev
Author: lukaszkaiser
Date: 2012-02-27 02:06:22 +0000 (Mon, 27 Feb 2012)
Log Message:
-----------
Automatic creation of Resources ml file in Makefile. Using Resources ml instead of reading from files makes tests work in JS.
Modified Paths:
--------------
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/.cvsignore
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/OUnit.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Solver/ClassTest.ml
Added Paths:
-----------
trunk/Toss/Formula/Resources.mli
Property Changed:
----------------
trunk/Toss/Formula/
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Client/JsHandler.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -264,3 +264,4 @@
let run_tests_big s = run_tests (of_js s) true
let _ = set_handle "run_tests_small" run_tests_small
+let _ = set_handle "run_tests_big" run_tests_big
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Client/clientTest.js 2012-02-27 02:06:22 UTC (rev 1680)
@@ -88,9 +88,9 @@
return (existsId ("pred_b2_P"));
});
doAtTime (page, 4100, function () {
- ASYNCH ("run_tests_small", ["Formula"], function () {});
+ ASYNCH ("run_tests_small", [""], function () {});
});
- doAtTime (undefined, 20000, function () {
+ doAtTime (undefined, 900000, function () {
//console.log ("rendering");
//page.render ("clientTestRender.png");
phantom.exit();
Property changes on: trunk/Toss/Formula
___________________________________________________________________
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 .
*Profile.log
*~
+ # 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 .
Resources.ml
*~
Modified: trunk/Toss/Formula/.cvsignore
===================================================================
--- trunk/Toss/Formula/.cvsignore 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Formula/.cvsignore 2012-02-27 02:06:22 UTC (rev 1680)
@@ -2,5 +2,5 @@
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
-*Profile.log
+Resources.ml
*~
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -32,21 +32,33 @@
) ENDIF
-let rec input_file file =
- let buf = Buffer.create 256 in
- (try
- while true do Buffer.add_channel buf file 1 done
- with End_of_file -> ());
- Buffer.contents buf
+let input_file fn_in =
+ let fn =
+ if String.length fn_in > 2 && fn_in.[0] = '.' && fn_in.[1] = '/' then
+ String.sub fn_in 2 ((String.length fn_in) - 2)
+ else fn_in in
+ IFDEF JAVASCRIPT THEN (
+ Resources.get_file fn
+ ) ELSE (
+ try Resources.get_file fn with Not_found -> (
+ let input_file_desc file =
+ let buf = Buffer.create 256 in
+ (try
+ while true do Buffer.add_channel buf file 1 done
+ with End_of_file -> ());
+ Buffer.contents buf in
+ let f = open_in fn in
+ let res = input_file_desc f in
+ close_in f;
+ print_endline ("WARNING: file " ^ fn ^ " not in resources");
+ res
+ )
+ ) ENDIF
-let input_fname fn =
- let f = open_in fn in
- let res = input_file f in
- close_in f; res
let list_dir dirname =
IFDEF JAVASCRIPT THEN (
- failwith "JavaScript file manipulation not implemented yet"
+ failwith "JavaScript file manipulation not implemented"
) ELSE (
let files, dir_handle = (ref [], Unix.opendir dirname) in
let rec add () =
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-27 02:06:22 UTC (rev 1680)
@@ -11,11 +11,8 @@
(** Get a backtrace as a string (native mode only). *)
val backtrace : unit -> string
-(** Input a file to a string. *)
-val input_file : in_channel -> string
-
(** Input a file with given filename to a string. *)
-val input_fname : string -> string
+val input_file : string -> string
(** List the contents of a directory *)
val list_dir : string -> string list
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -125,9 +125,7 @@
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
if !file = "" then ignore (OUnit.run_test_tt ~verbose:true tests) else
- let f = open_in !file in
- let file_s = AuxIO.input_file f in
- close_in f;
+ let file_s = AuxIO.input_file !file in
let cleaned_s1 = Aux.replace_regexp ~regexp:"bool" ~templ:"" file_s in
let cleaned_s2 =
Aux.replace_regexp ~regexp:"^.*<.*$" ~templ:"" cleaned_s1 in
Modified: trunk/Toss/Formula/OUnit.ml
===================================================================
--- trunk/Toss/Formula/OUnit.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Formula/OUnit.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -171,9 +171,10 @@
Some e
let assert_raises ?msg exn (f: unit -> 'a) =
- let pexn =
- Printexc.to_string
- in
+ let pexn e = (* Correcting JS exception printing; just to make tests pass *)
+ let s = Printexc.to_string e in
+ if s = "Failure(Boo)" then "Failure(\"Boo\")" else
+ if s = "Failure(Foo)" then "Failure(\"Foo\")" else s in
let get_error_string () =
let str =
Format.sprintf
Added: trunk/Toss/Formula/Resources.mli
===================================================================
--- trunk/Toss/Formula/Resources.mli (rev 0)
+++ trunk/Toss/Formula/Resources.mli 2012-02-27 02:06:22 UTC (rev 1680)
@@ -0,0 +1,4 @@
+(** Automatically Constructed Resources File *)
+
+(** Get the contents of a recorded file given its path (under Toss/). *)
+val get_file : string -> string
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -51,7 +51,7 @@
TranslateGame.translate_game ~playing_as:(Const player) game in
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
- let goal_str = AuxIO.input_file (open_in ("./GGP/tests/"^goal_name)) in
+ let goal_str = AuxIO.input_file ("./GGP/tests/" ^ goal_name) in
let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in
let res_str = Arena.state_str (r_game, r_struc) in
output_string resf res_str;
@@ -151,7 +151,7 @@
TranslateGame.translate_game ~playing_as:(Const player) game in
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
- let goal_str = AuxIO.input_file (open_in ("./GGP/tests/"^goal_name)) in
+ let goal_str = AuxIO.input_file ("./GGP/tests/"^goal_name) in
let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in
let res_str = Arena.state_str (r_game, r_struc) in
output_string resf res_str;
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -109,7 +109,7 @@
let tfiles = List.map (fun fn -> !dir ^ "/" ^ fn)
(List.sort compare (List.filter is_test (AuxIO.list_dir !dir))) in
let is_group g fn = String.sub fn ((String.length fn) - 4) 4 = "." ^ g in
- let get_struc fn = try get_strucs (AuxIO.input_fname fn) with
+ let get_struc fn = try get_strucs (AuxIO.input_file fn) with
err -> print_endline ("Error in " ^ fn); raise err in
let strucs_of_files fs = List.map get_struc fs in
let (win0, win1, notwon, wrong) =
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Makefile 2012-02-27 02:06:22 UTC (rev 1680)
@@ -56,7 +56,43 @@
ocamlc -I +camlp4 -pp "camlp4o pa_extend.cmo q_MLast.cmo" \
-c $<
+NAMEPATTERN = f$(subst .,_,$(subst -,_,$(subst /,_,$(basename $@))))
+%.resource:
+ @echo -n 'let $(NAMEPATTERN) = "' >> Formula/Resources.ml
+ @cat $(basename $@) | sed 's/"/\\"/g' >> Formula/Resources.ml
+ @echo '"' >> Formula/Resources.ml
+ @echo '' >> Formula/Resources.ml
+ @echo 'let _ = files := ("$(basename $@)", $(NAMEPATTERN)) :: !files' \
+ >> Formula/Resources.ml
+ @echo '' >> Formula/Resources.ml
+ @echo "Recorded $(basename $@) in Formula/Resources.ml"
+TOSSEXFILES = $(shell find examples -name "*.toss")
+TOSSEXRESC = $(addsuffix .resource, $(TOSSEXFILES))
+TOSSGGPFILES = $(shell find GGP/tests -name "*.toss")
+TOSSGGPRESC = $(addsuffix .resource, $(TOSSGGPFILES))
+
+new_resource_file:
+ @echo "(* Automatically Constructed Resources *)" > Formula/Resources.ml
+ @echo "" >> Formula/Resources.ml
+ @echo "let files = ref []" >> Formula/Resources.ml
+ @echo "" >> Formula/Resources.ml
+ @echo "let get_file fn = List.assoc fn !files" >> Formula/Resources.ml
+ @echo "" >> Formula/Resources.ml
+
+all_resources: $(TOSSEXRESC) $(TOSSGGPRESC) \
+ Server/ServerGDLTest.in.resource \
+ Server/ServerGDLTest.out.resource \
+ Server/ServerGDLTest.in2.resource \
+ Server/ServerGDLTest.out2.resource \
+
+Formula/Resources.ml:
+ @make new_resource_file > /dev/null
+ @make all_resources
+
+EXTDEPS = caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo Formula/Resources.ml
+
+
# -------- MAIN OCAMLBUILD PART --------
# TODO: Hard-coded path to js_of_ocaml.
@@ -85,19 +121,19 @@
.INC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
-%.native: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
+%.native: %.ml $(EXTDEPS)
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-%.p.native: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
+%.p.native: %.ml $(EXTDEPS)
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-%.byte: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
+%.byte: %.ml $(EXTDEPS)
$(OCAMLBUILDJS) -Is $($(subst /,INC,$(dir $@))) $@
-%.d.byte: %.ml caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
+%.d.byte: %.ml $(EXTDEPS)
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-doc: caml_extensions/pa_let_try.cmo caml_extensions/pa_log.cmo
+doc: $(EXTDEPS)
$(OCAMLBUILD) $(.INC) Toss.docdir/index.html
make -C www code_doc_link
@@ -203,4 +239,4 @@
ocamlbuild -clean
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
+ rm -f caml_extensions/*.cmo caml_extensions/*.cmi Formula/Resources.ml
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Play/GameTreeTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -5,12 +5,10 @@
let debug_level = ref 0
let raw_state_of_file s =
- if !debug_level > 0 then Printf.printf "Loading file %s...\n%!" s;
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- if !debug_level > 0 then Printf.printf "File %s loaded.\n%!" s;
+ LOG 1 "Loading file %s..." s;
+ let s = AuxIO.input_file s in
+ let res = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string s) in
+ LOG 1 "File %s loaded." s;
res
let struc_of_str s =
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Play/HeuristicTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -19,10 +19,10 @@
(Lexing.from_string s) signat [] None
let state_of_file s =
- let f = open_in s in
+ let f = AuxIO.input_file s in
let res =
ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
+ (Lexing.from_string f) in
res
let assert_eq_str ?(msg="") x_in y_in =
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Play/PlayTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -5,12 +5,10 @@
let debug_level = ref 0
let raw_state_of_file s =
- if !debug_level > 0 then Printf.printf "Loading file %s...\n%!" s;
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- if !debug_level > 0 then Printf.printf "File %s loaded.\n%!" s;
+ LOG 1 "Loading file %s..." s;
+ let s = AuxIO.input_file s in
+ let res = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string s) in
+ LOG 1 "File %s loaded." s;
res
let struc_of_str s =
Modified: trunk/Toss/Server/ReqHandlerTest.ml
===================================================================
--- trunk/Toss/Server/ReqHandlerTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Server/ReqHandlerTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -17,10 +17,8 @@
state := fst (ReqHandler.full_req_handle !state in_ch out_ch) done
with End_of_file -> ());
close_in in_ch; close_out out_ch;
- let result =
- AuxIO.input_file (open_in "./Server/ServerGDLTest.temp") in
- let target =
- AuxIO.input_file (open_in "./Server/ServerGDLTest.out2") in
+ let result = AuxIO.input_file ("./Server/ServerGDLTest.temp") in
+ let target = AuxIO.input_file ("./Server/ServerGDLTest.out2") in
Sys.remove "./Server/ServerGDLTest.temp";
assert_equal ~printer:(fun x->x)
(strip_spaces target) (strip_spaces result);
Modified: trunk/Toss/Solver/ClassTest.ml
===================================================================
--- trunk/Toss/Solver/ClassTest.ml 2012-02-18 21:54:05 UTC (rev 1679)
+++ trunk/Toss/Solver/ClassTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
@@ -447,9 +447,7 @@
ignore (OUnit.run_test_tt ~verbose:true tests);
ignore (OUnit.run_test_tt ~verbose:true bigtests);
) else (
- let f = open_in !file in
- let s = AuxIO.input_file f in
- close_in f;
+ let s = AuxIO.input_file !file in
let i = String.index s '|' in (* enough to find "|=" here *)
let cl_s = String.sub s 0 i in
let phi_s = String.sub s (i+2) ((String.length s) - i - 3) in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-28 02:36:37
|
Revision: 1681
http://toss.svn.sourceforge.net/toss/?rev=1681&view=rev
Author: lukaszkaiser
Date: 2012-02-28 02:36:29 +0000 (Tue, 28 Feb 2012)
Log Message:
-----------
Make tests work in JS.
Modified Paths:
--------------
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/ClassTest.ml
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Client/clientTest.js 2012-02-28 02:36:29 UTC (rev 1681)
@@ -88,9 +88,9 @@
return (existsId ("pred_b2_P"));
});
doAtTime (page, 4100, function () {
- ASYNCH ("run_tests_small", [""], function () {});
+ ASYNCH ("run_tests_big", [""], function () {});
});
- doAtTime (undefined, 900000, function () {
+ doAtTime (undefined, 30000000, function () {
//console.log ("rendering");
//page.render ("clientTestRender.png");
phantom.exit();
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/Aux.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -311,8 +311,7 @@
List.rev_append (List.map (fun e-> hd, e) tl) (pairs tl)
let rec fold_n f accu n =
- if n <= 0 then accu
- else fold_n f (f accu) (n-1)
+ if n <= 0 then accu else fold_n f (f accu) (n-1)
let all_ntuples ?(timeout = fun () -> false) elems arity =
fold_n (fun tups ->
@@ -741,16 +740,6 @@
Format.fprintf f "%a%a" f_el hd pr_tail tl
-let set_optimized_gc () =
- IFDEF JAVASCRIPT THEN (
- ()
- ) ELSE (
- Gc.set { (Gc.get()) with
- Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
- Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
- }
- ) ENDIF
(* Replacements for basic Str functions. *)
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/Aux.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -359,8 +359,6 @@
?newline : int -> string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a list -> unit
-(** Set more agressive Gc values optimized for heavier computations. *)
-val set_optimized_gc : unit -> unit
(** Replacements for basic Str functions. *)
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -2,6 +2,9 @@
structures and standard library-like definitions. *)
open Aux
+let default_debug_level = ref 0
+
+
let gettimeofday () =
IFDEF JAVASCRIPT THEN (
let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
@@ -10,6 +13,24 @@
Unix.gettimeofday ()
) ENDIF
+let gc_compact () =
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
+ Gc.compact ();
+ ) ENDIF
+
+let set_optimized_gc () =
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
+ }
+ ) ENDIF
+
let backtrace () =
IFDEF JAVASCRIPT THEN ( "" ) ELSE (
(if Printexc.backtrace_status () then
@@ -38,7 +59,8 @@
String.sub fn_in 2 ((String.length fn_in) - 2)
else fn_in in
IFDEF JAVASCRIPT THEN (
- Resources.get_file fn
+ try Resources.get_file fn with Not_found ->
+ failwith ("File " ^ fn ^ " not found")
) ELSE (
try Resources.get_file fn with Not_found -> (
let input_file_desc file =
@@ -50,12 +72,23 @@
let f = open_in fn in
let res = input_file_desc f in
close_in f;
- print_endline ("WARNING: file " ^ fn ^ " not in resources");
+ if !default_debug_level > 0 then
+ print_endline ("WARNING: file " ^ fn ^ " not in resources");
res
)
) ENDIF
+let output_file ~fname str =
+ IFDEF JAVASCRIPT THEN (
+ failwith "File output not implemented in JavaScript"
+ ) ELSE (
+ let file = open_out fname in
+ output_string file str;
+ flush file;
+ close_out file;
+ ) ENDIF
+
let list_dir dirname =
IFDEF JAVASCRIPT THEN (
failwith "JavaScript file manipulation not implemented"
@@ -67,6 +100,9 @@
) ENDIF
let rec input_http_message file =
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript: http not implemented"
+ ) ELSE (
let buf = Buffer.create 256 in
let get_pair s =
let i, l = String.index s '=', String.length s in
@@ -93,6 +129,7 @@
done;
Buffer.add_channel buf file !msg_len;
(String.concat "\n" !head, Buffer.contents buf, !cookies)
+ ) ENDIF
let input_if_http_message line in_ch =
let ht1, ht2 = "GET /", "POST /" in
@@ -120,7 +157,7 @@
let toss_call (client_port, client_addr_s) f_in x =
IFDEF JAVASCRIPT THEN (
- failwith "JavaScript TCP/IP manipulation not implemented yet"
+ failwith "JavaScript TCP/IP manipulation not implemented"
) ELSE (
try
let client_addr = get_inet_addr client_addr_s in
@@ -166,7 +203,7 @@
ENDIF
-let default_debug_level = ref 0
+
let debug_levels = Hashtbl.create 7
let set_debug_level module_name debug_lev =
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -4,7 +4,12 @@
(** Replacement for Unix.gettimeofday. *)
val gettimeofday: unit -> float
+(** Set more agressive Gc values optimized for heavier computations. *)
+val set_optimized_gc : unit -> unit
+(** Gc.compact () or nothing when running in JS. *)
+val gc_compact : unit -> unit
+
(** Run a function if the executable name matches the given prefix. *)
val run_if_target : string -> (unit -> unit) -> unit
@@ -14,6 +19,9 @@
(** Input a file with given filename to a string. *)
val input_file : string -> string
+(** Output a string to a file with given filename [fname]. *)
+val output_file : fname: string -> string -> unit
+
(** List the contents of a directory *)
val list_dir : string -> string list
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -920,14 +920,34 @@
(* Read a qdimacs description of a QBF from [in_ch]. *)
-let read_qdimacs in_ch =
+let read_qdimacs in_str =
+ let in_ch = ref in_str in
+ let sinput_one_line () =
+ try
+ let i, l = String.index !in_ch '\n', String.length !in_ch in
+ if i = l-1 then (
+ let line = !in_ch in
+ in_ch := "";
+ line
+ ) else (
+ let line = String.sub !in_ch 0 i in
+ in_ch := String.sub !in_ch (i+1) (l - i - 1);
+ line
+ )
+ with Not_found ->
+ if !in_ch = "" then raise End_of_file else
+ let line = !in_ch in in_ch := ""; line in
+ let rec sinput_line () =
+ let l = sinput_one_line () in if l = "" then sinput_line () else l in
(* Read the starting 'c' comment lines, and the first 'p' line.
Set the number of variables and the number of clauses. *)
let rec read_header () =
- let line = input_line in_ch in
+ let line = sinput_line () in
if line.[0] = 'c' then read_header () else
- Scanf.sscanf line "p cnf %i %i" (fun x y -> (x, y)) in
-
+ (* Scanf.sscanf line "p cnf %i %i" (fun x y -> y) in *)
+ let i = String.index_from line 6 ' ' in
+ int_of_string (String.sub line (i+1) ((String.length line) - i - 1)) in
+
(* Read one clause from a line. *)
let read_clause line =
let (s, i, clause) = (ref "", ref 0, ref []) in
@@ -950,9 +970,9 @@
(fun s -> int_of_string s) (List.tl split))) in
let read_formula () =
- let (no_var, no_cl) = read_header () in
+ let no_cl = read_header () in
let rec read_phi () =
- let line = input_line in_ch in
+ let line = sinput_line () in
if line.[0] == 'a' then
QAll (list_int line, read_phi ())
else if line.[0] == 'e' then
@@ -960,7 +980,7 @@
else (
let cls = ref [read_clause (line)] in
for i = 1 to (no_cl-1) do
- cls := (read_clause (input_line in_ch)) :: !cls
+ cls := (read_clause (sinput_line ())) :: !cls
done;
QFree (
BAnd (List.map (fun lits -> BOr (List.map lit_of_int lits)) !cls))
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFormula.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -84,8 +84,8 @@
(** Print a QBF formula. *)
val qbf_str : qbf -> string
-(** Read a qdimacs description of a QBF from [in_ch]. *)
-val read_qdimacs : in_channel -> qbf
+(** Read a qdimacs description of a QBF from a string. *)
+val read_qdimacs : string -> qbf
(** Eliminating quantifiers from QBF formulas. *)
val elim_quant : qbf -> bool_formula
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -396,26 +396,19 @@
-45 85 0
20 27 45 -85 0
-60 -61 -62 -63 -64 -65 -66 -67 -68 -69 -70 -71 -72 -73 -74 -75 -76 -77 -78 -79 -80 -81 -82 -83 -84 -85 0
-" in
-
- let f = open_out "tmp_testfile_28721.bf" in
- output_string f s27_d2_s;
- close_out f;
- let f = open_in "tmp_testfile_28721.bf" in
- let qbf = read_qdimacs f in
- close_in f;
- Sys.remove "tmp_testfile_28721.bf";
+" in
+ let qbf = read_qdimacs s27_d2_s in
test_elim qbf "true";
- );
+ );
]
let exec () = OUnit.run_test_if_target "BoolFormulaTest" tests
-let execbig ()= OUnit.run_test_if_target "BoolFormulaTest" bigtests
+let execbig () = OUnit.run_test_if_target "BoolFormulaTest" bigtests
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (file) = (ref "") in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_elim true), "be verbose");
@@ -424,9 +417,7 @@
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
if !file = "" then ( exec (); execbig (); ) else (
- let f = open_in !file in
- let qbf = read_qdimacs f in
- close_in f;
+ let qbf = read_qdimacs (AuxIO.input_file !file) in
print_endline (BoolFormula.str (elim_quant qbf))
)
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -106,7 +106,7 @@
let main () =
- Aux.set_optimized_gc ();
+ AuxIO.set_optimized_gc ();
let (file, print_bool, debug_level) = (ref "", ref false, ref 0) in
let dbg_level i = (debug_level := i; BoolFunction.set_debug_level i) in
let (only_inline, only_fp, nf) = (ref false, ref false, ref 0) in
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GDL.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -16,7 +16,7 @@
let timeout = ref (fun () -> false)
let set_timeout f = timeout := f
let check_timeout ?(print=true) msg =
- if print && !debug_level > 1 then print_endline ("TimeoutCheck: " ^ msg);
+ if print then LOG 2 "TimeoutCheck: %s" msg;
if !timeout () then (timeout := (fun () -> false); raise (Aux.Timeout msg))
type term =
@@ -469,6 +469,11 @@
let rel_atoms_str body = String.concat " " (List.map rel_atom_str body)
+let gdl_rule_str (ra, rs1, rs2) =
+ (rel_atom_str ra) ^ ": " ^ (rel_atoms_str rs1) ^ "; " ^ (rel_atoms_str rs1)
+
+let gdl_rules_str rs = String.concat ";; " (List.map gdl_rule_str rs)
+
let neg_rel_atoms_str neg_body =
String.concat " "
(List.map (fun a -> "(not " ^ rel_atom_str a ^")") neg_body)
@@ -1279,12 +1284,7 @@
let base = Aux.StrMap.add "true" current
(*tuples_of_list (List.map (fun term -> [|term|]) current)*) static in
let base = saturate base rules in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "GDL.ply: updated base -- %s\n%!"
- (rel_atoms_str (graph_to_atoms base))
- );
- (* }}} *)
+ LOG 5 "GDL.ply: updated base -- %s" (rel_atoms_str (graph_to_atoms base));
let does = Tuples.elements (Aux.StrMap.find "legal" base) in
let does =
if aggregate then does
@@ -1381,20 +1381,11 @@
| rule -> rule) dynamic_rules in
let rec loop actions_accu state_accu step state =
check_timeout ("GDL: playout_satur: loop step " ^ (string_of_int step));
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "playout: step %d...\n%!" step
- );
- (* }}} *)
+ LOG 1 "playout: step %d...\n%!" step;
(let try actions, next =
ply_satur ~aggregate players static_base state state_rules in
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "playout: state %s\n%!"
- (String.concat " "
- (List.map term_str (state_of_tups next)))
- );
- (* }}} *)
+ LOG 1 "playout: state %s"
+ (String.concat " " (List.map term_str (state_of_tups next)));
let next =
if aggregate then (Tuples.union state next) else next in
if step < horizon then
@@ -1427,23 +1418,20 @@
(* [~aggregate:true] performs an aggregate ply, [~aggregate:false]
performs a random ply. *)
let ply_prolog ~aggregate players current program =
- let program =
- replace_rel_in_program "true"
- (List.map (fun term -> ("true", [|term|]), []) current) program in
+ let program = replace_rel_in_program "true"
+ (List.map (fun term -> ("true", [|term|]), []) current) program in
let legal_terms = List.map snd
(run_prolog_atom ("legal", [|Var "x"; Var "y"|]) program) in
let program =
- if aggregate then (run_prolog_aggregate := true; program)
- else (
+ if aggregate then (run_prolog_aggregate := true; program) else (
run_prolog_aggregate := false;
let legal_by_player = Aux.collect
- (List.map
- (function [|pl; lterm|] -> pl, lterm | _ -> assert false)
+ (List.map (function [|pl; lterm|] -> pl, lterm | _ -> assert false)
legal_terms) in
let does_cls = List.map
(fun (player, lterms) ->
- ("does", [|player; Aux.random_elem lterms|]), [])
- legal_by_player in
+ ("does", [|player; Aux.random_elem lterms|]), [])
+ legal_by_player in
replace_rel_in_program "does" does_cls program) in
if (* no move *)
Aux.array_existsi (fun _ player ->
@@ -1473,21 +1461,13 @@
Aux.sorted_diff step_state current = [] &&
(aggregate || Aux.sorted_diff current step_state = [])
then (
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "GDL.ply: playout over due to fixpoint\n%!";
- );
- (* }}} *)
+ LOG 2 "GDL.ply: playout over due to fixpoint";
raise Playout_over)
else if not aggregate && (* terminal position reached *)
run_prolog_check_goal
[Pos (Rel ("terminal", [||]))] program
then (
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "GDL.ply: playout over due to terminal position\n%!";
- );
- (* }}} *)
+ LOG 1 "GDL.ply: playout over due to terminal position";
raise Playout_over)
else
legal_terms, step_state
@@ -1520,41 +1500,25 @@
else program in
let rec loop actions_accu state_accu step state =
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "playout_prolog: step %d...\n%!" step
- );
- (* }}} *)
+ LOG 2 "playout_prolog: step %d..." step;
check_timeout ("GDL: playout_prolog: step " ^ (string_of_int step));
- (let try actions, next =
- ply_prolog ~aggregate players state program in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "playout: state %s\n%!"
- (String.concat " " (List.map term_str next))
- );
- (* }}} *)
+ (let try actions, next = ply_prolog ~aggregate players state program in
+ LOG 3 "playout: state %s" (String.concat " " (List.map term_str next));
let next =
if aggregate then Aux.sorted_merge state next else next in
if step < horizon then
loop (actions::actions_accu) (state::state_accu) (step+1) next
else
- List.rev (actions::actions_accu),
- List.rev (state::state_accu), next
+ List.rev (actions::actions_accu), List.rev (state::state_accu), next
with Playout_over ->
List.rev actions_accu, List.rev state_accu, state) in
+
let init_state = List.map (fun (_,args) -> args.(0))
(run_prolog_atom ("init", [|Var "x"|]) program) in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "playout: init %s\n%!"
- (String.concat " " (List.map term_str init_state))
- );
- (* }}} *)
+ LOG 3 "playout: init %s" (String.concat " " (List.map term_str init_state));
loop [] [] 0 init_state
-
let find_cycle cands =
(* {{{ log entry *)
if !debug_level > 0 then (
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GDL.mli 2012-02-28 02:36:29 UTC (rev 1681)
@@ -181,6 +181,8 @@
val atom_str : atom -> string
val rel_atom_str : rel_atom -> string
val rel_atoms_str : rel_atom list -> string
+val gdl_rule_str : gdl_rule -> string
+val gdl_rules_str : gdl_rule list -> string
val def_str : string * def_branch list -> string
val literal_str : literal -> string
val literals_str : literal list -> string
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GDLTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -11,18 +11,11 @@
let pte = parse_term
-let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- res
-
let load_rules fname =
- let f = open_in fname in
+ let f = AuxIO.input_file fname in
let descr =
GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_channel f) in
+ (Lexing.from_string f) in
descr
let emb_str (game, state) (rname, emb) =
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/GameSimplTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -2,10 +2,8 @@
let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
+ let f = AuxIO.input_file s in
+ let res = ArenaParser.parse_game_state Lexer.lex (Lexing.from_string f) in
res
let tests = "GameSimpl" >::: [
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -15,21 +15,7 @@
let pte = parse_term
-let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- res
-let load_rules fname =
- let f = open_in fname in
- let descr =
- GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_channel f) in
- descr
-
-
let tests = "TranslateFormula" >::: [
"separate_disj" >::
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/TranslateGame.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -39,7 +39,7 @@
let timeout = ref (fun () -> false)
let set_timeout f = (timeout := f; GDL.set_timeout f)
let check_timeout ?(print=true) msg =
- if print && !debug_level > 1 then print_endline ("TimeoutCheck: " ^ msg);
+ if print then LOG 2 "TimeoutCheck: %s" msg;
if !timeout () then (timeout := (fun () -> false); raise (Aux.Timeout msg))
@@ -1577,7 +1577,7 @@
| _ -> raise Not_found in
match arg with
| Const c when
- (try ignore (float_of_string c); true
+ (try Pervasives.compare (float_of_string c) nan <> 0
with Failure "float_of_string" -> false) ->
[Pos (True arg)], body
| Var _ as v ->
@@ -2947,26 +2947,14 @@
let generate_playout_states ?(with_terminal=false) program players =
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "translate_game: generating states...\n%!";
- (* GDL.debug_level := 4; *)
- );
- (* }}} *)
+ LOG 2 "translate_game: generating states...";
let states = Aux.fold_n
(fun acc ->
let _, states, terminal_state =
- playout_prolog ~aggregate:false players !playout_horizon
- program in
+ playout_prolog ~aggregate:false players !playout_horizon program in
if with_terminal then terminal_state :: states @ acc
else states @ acc) [] !playouts_for_rule_filtering in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- (* GDL.debug_level := 0; *)
- Printf.printf "translate_game: generated %d states.\n%!"
- (List.length states)
- );
- (* }}} *)
+ LOG 2 "translate_game: generated %d states." (List.length states);
states
let is_counter_cl num_functors counter_cands (arg, body) =
@@ -2982,22 +2970,20 @@
piecewise-linear functions of argument [RVar ":x"], and remaining
(unchanged) clauses. *)
let detect_counters clauses =
+ let is_nan f = (Pervasives.compare f nan = 0) in
let num_functions =
Aux.map_reduce (fun ((rel,args),b) -> rel,(args,b))
(fun acc br ->
match acc, br with
| Some graph, ([|Const x; Const y|], []) ->
- (try Some ((float_of_string x, float_of_string y)::graph)
+ (try let xf, yf = float_of_string x, float_of_string y in
+ if is_nan xf || is_nan yf then None else Some ((xf, yf)::graph)
with Failure "float_of_string" -> None)
| _ -> None)
(Some []) clauses in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: num_functions cands=%s\n%!"
- (String.concat ", "(Aux.map_some (fun (r,g)->
- if g=None then None else Some r) num_functions))
- );
- (* }}} *)
+ LOG 4 "detect_counters: num_functions cands=%s"
+ (String.concat ", "(Aux.map_some (fun (r,g)->
+ if g=None then None else Some r) num_functions));
let num_functions = Aux.map_some
(function
| rel, Some graph ->
@@ -3006,29 +2992,22 @@
| _ -> None)
num_functions in
let num_functors = List.map fst num_functions in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: num_functors=%s\n%!"
- (String.concat ", " num_functors)
- );
- (* }}} *)
+ LOG 4 "detect_counters: num_functors=%s"
+ (String.concat ", " num_functors);
(* Build initial counter candidates based on their "init" clauses. *)
let counter_inits = Aux.map_some
(function
| ("init", [|Func (cand, [|Const y|])|]), [] ->
- (try Some (cand, float_of_string y)
+ (try let yf = float_of_string y in
+ if is_nan yf then None else Some (cand, yf)
with Failure "float_of_string" -> None)
| _ -> None)
clauses in
let counter_inits = Aux.map_some
(function f, [init_v] -> Some (f, init_v) | _ -> None)
(Aux.collect counter_inits) in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: counter_inits cands=%s\n%!"
- (String.concat ", "(List.map fst counter_inits))
- );
- (* }}} *)
+ LOG 4 "detect_counters: counter_inits cands=%s"
+ (String.concat ", "(List.map fst counter_inits));
let counter_cl_cands = Aux.collect
(Aux.map_some
(function ("next",[|Func (f, [|arg|])|]),body
@@ -3050,12 +3029,8 @@
let counters = List.map fst counter_cls in
let counter_inits = Aux.map_try
(fun c -> c, List.assoc c counter_inits) counters in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "detect_counters: resulting counters=%s\n%!"
- (String.concat ", " counters)
- );
- (* }}} *)
+ LOG 4 "detect_counters: resulting counters=%s"
+ (String.concat ", " counters);
let counter_cls, clauses = List.partition
(function
| ("next",[|Func (f,_)|]),_ -> List.mem f counters
@@ -3114,18 +3089,14 @@
determine values, not to expand their goal value variables later. *)
let counter_inits, counter_cls, goal_cls_w_counters,
num_functions, clauses = detect_counters clauses in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "translate_game: detected counters = %s\n%!"
- (String.concat "; "
- (List.map (fun (c,v) -> c^"="^string_of_float v) counter_inits))
- );
- (* }}} *)
+ LOG 2 "translate_game: detected counters = %s" (String.concat "; " (
+ List.map (fun (c,v) -> c^"="^string_of_float v) counter_inits));
let static_base, init_state, c_paths, f_paths, element_reps, root_reps,
ground_state_terms, arities, term_arities, static_rels, nonstatic_rels,
frame_clauses, move_clauses, clauses, program, playout_states =
prepare_paths_and_elems players_wo_env ~playout_states clauses in
(* recompile the program *)
+ check_timeout "TranslateGame: before testground";
let testground =
replace_rel_in_program "true" (state_cls init_state) program in
let program = optimize_program ~testground program in
@@ -3358,10 +3329,9 @@
with Not_found -> 0 in
(match !generate_test_case with
| None -> ()
- | Some game_name ->
- let file = open_out ("./GGP/tests/"^game_name^"-raw.toss") in
- output_string file (Arena.state_str result);
- flush file; close_out file);
+ | Some game_name ->
+ AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-raw.toss")
+ (Arena.state_str result));
let result = GameSimpl.simplify result in
let gdl_translation = {
(* map between structure elements and their term representations;
@@ -3380,9 +3350,8 @@
(match !generate_test_case with
| None -> ()
| Some game_name ->
- let file = open_out ("./GGP/tests/"^game_name^"-simpl.toss") in
- output_string file (Arena.state_str result);
- flush file; close_out file);
+ AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-simpl.toss")
+ (Arena.state_str result));
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "\n\ntranslate_game: simplified rel sizes --\n%s\n%!"
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-02-27 02:06:22 UTC (rev 1680)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
@@ -2,27 +2,24 @@
open GDL
let parse_game_descr s =
- GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_string s)
+ GDLParser.parse_game_description KIFLexer.lex (Lexing.from_string s)
let parse_term s =
- GDLParser.parse_term KIFLexer.lex
- (Lexing.from_string s)
+ GDLParser.parse_term KIFLexer.lex (Lexing.from_string s)
let pte = parse_term
let state_of_file s =
- let f = open_in s in
+ let f = AuxIO.input_file s in
let res =
ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
+ (Lexing.from_string f) in
res
let load_rules fname =
- let f = open_in fname in
+ let f = AuxIO.input_file fname in
let descr =
- GDLParser.parse_game_description KIFLexer.lex
- (Lexing.from_channel f) in
+ GDLParser.parse_game_description KIFLexer.lex (Lexing.from_string f) in
descr
let emb_str (game, state) (rname, emb) =
@@ -52,17 +49,17 @@
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
let goal_str = AuxIO.input_file ("./GGP/tests/" ^ goal_name) in
- let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in
+ (* let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in *)
let res_str = Arena.state_str (r_game, r_struc) in
- output_string resf res_str;
- close_out resf;
+ (* output_string resf res_str;
+ close_out resf; *)
(* let eq, msg = Arena.compare_diff goal res in *)
let eq, msg = goal_str = res_str, "sorry, just comparing as strings" in
- assert_bool
- ("GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
- ", see GGP/tests/"^game_name^"-temp.toss: "^msg)
- eq;
- Sys.remove ("./GGP/tests/"^game_name^"-temp.toss");
+ assert_bool ("tests for " ^ game_name ^ " failed (" ^ goal_name ^ ")")
+ (* "GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
+ ", see GGP/tests/"^game_name^"-temp.toss: "^msg *)
+ ...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-05 23:24:50
|
Revision: 1682
http://toss.svn.sourceforge.net/toss/?rev=1682&view=rev
Author: lukaszkaiser
Date: 2012-03-05 23:24:41 +0000 (Mon, 05 Mar 2012)
Log Message:
-----------
Moving to LOG for debug-logging.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FFTNF.ml
trunk/Toss/Formula/FFTNF.mli
trunk/Toss/Formula/FFTNFTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaMapTest.ml
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaSubst.ml
trunk/Toss/Formula/FormulaSubst.mli
trunk/Toss/Formula/FormulaSubstTest.ml
trunk/Toss/Formula/OUnit.ml
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Formula/Sat/Sat.mli
trunk/Toss/Formula/Sat/SatTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/GameSimpl.mli
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/Distinguish.mli
trunk/Toss/Learn/DistinguishTest.ml
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGame.mli
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/Heuristic.mli
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/Class.ml
trunk/Toss/Solver/Class.mli
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/RealQuantElim/RealQuantElim.ml
trunk/Toss/Solver/RealQuantElim/RealQuantElimTest.ml
trunk/Toss/Solver/RealQuantElim/SignTable.ml
trunk/Toss/Solver/RealQuantElim/SignTable.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/Arena.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,11 +1,10 @@
(* Represent the game arena and operate on it. *)
open Printf
-let debug_level = ref 0
-
(* The label's time interval defaults to this point. *)
let cDEFAULT_TIMESTEP = 0.1
+
(* ------------------------ BASIC TYPE DEFINITIONS -------------------------- *)
(* A single move consists of applying a rewrite rule for a time from the
@@ -98,17 +97,11 @@
raise Not_found))
match_str
with Not_found ->
- (* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "matching_of_names: failed at STRUC=\n%s\nMATCH=%s\n%!"
- (Structure.str state.struc)
- (String.concat "; "
- (List.map (fun (v,e) ->v^"<-"^e) match_str))
- );
- (* }}} *)
+ LOG 1 "matching_of_names: failed at STRUC=\n%s\nMATCH=%s\n%!"
+ (Structure.str state.struc)
+ (String.concat "; " (List.map (fun (v,e) ->v^"<-"^e) match_str));
failwith ("emb_of_names: could not find " ^
- String.concat "; "
- (List.map (fun (v,e) ->v^"<-"^e) match_str))
+ String.concat "; " (List.map (fun (v,e) ->v^"<-"^e) match_str))
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
@@ -217,12 +210,8 @@
List.map (fun (rel, (args, body)) -> rel, args, body) game.defined_rels,
gstate.struc, gstate.time, gstate.cur_loc,
game.patterns, game.data in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- printf "process_definition: %d old rules, %d old locs\n%!"
- (List.length old_rules) (List.length old_locs);
- );
- (* }}} *)
+ 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 =
List.fold_left (fun (rules, locations, players, defined_rels,
@@ -261,12 +250,8 @@
state, time, cur_loc, patterns, data @ more_data, hist)
) ([], [], players, [],
state, time, cur_loc, patterns, data, []) defs in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- printf "process_definition: %d new rules, %d new defined rels\n%!"
- (List.length rules) (List.length defined_rels);
- );
- (* }}} *)
+ 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
@@ -275,19 +260,11 @@
(Array.of_list players)) in
let num_players = List.length player_names in
let signature = Structure.rel_signature state in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- printf "process_definition: parsing new rules...%!";
- );
- (* }}} *)
+ 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
- (* {{{ log entry *)
- if !debug_level > 2 then (
- printf " parsed\n%!";
- );
- (* }}} *)
+ LOG 3 " parsed\n%!";
let rules =
List.sort (fun (rn1,_) (rn2,_)->String.compare rn1 rn2) rules in
let updated_locs =
@@ -301,21 +278,13 @@
let sub_p l =
{ l with payoff = FormulaSubst.subst_rels_expr def_rels_pure l.payoff } in
i, Array.map sub_p loc in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- printf "process_definition: parsing locations (registering payoffs)...%!";
- );
- (* }}} *)
+ LOG 3 "process_definition: parsing locations (registering payoffs)...%!";
let locations =
List.map (fun loc -> add_def_rel (loc player_names)) locations in
let locations =
List.filter (fun (i,_) -> not (List.mem_assoc i locations))
updated_locs @ locations in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- printf " parsed\n%!";
- );
- (* }}} *)
+ 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
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/Arena.mli 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,7 +1,5 @@
(** Represent the game arena and operate on it. *)
-val debug_level : int ref
-
(** A single move consists of applying a rewrite rule for a time from the
[time_in] interval, and parameters from the interval list. *)
type label = {
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,54 +1,11 @@
(* Test for game arena and support functions. *)
open OUnit
-
-(*let req_of_str s =
- ArenaParser.parse_request Lexer.lex (Lexing.from_string s) *)
-
let gs_of_str s =
ArenaParser.parse_game_state Lexer.lex (Lexing.from_string s)
-(*let apply_rule gs rname match_str =
- let s = "SET RULE " ^ rname ^ " MODEL " ^ match_str ^ " 0.1" in
- snd (Arena.handle_request Arena.empty_state (req_of_str s))
-*)
let tests = "Arena" >::: [
- "adding rule" >::
- (fun () -> assert true);
-(*
- let rule_a =
- "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] with [c <- a, d <- b] inv true post true" in
- let s = "SET RULE rule_a " ^ rule_a in
- let (gs, _) = Arena.handle_request Arena.empty_state (req_of_str s) in
- let (_, msg) = Arena.handle_request gs (req_of_str "GET RULE rule_a") in
- assert_equal ~msg:"Adding rule" ~printer:(fun x->x)
- rule_a msg;
-
- let rule_e =
- "[ | | ] -> [ | | ] with [] inv true post true" in
- let s =
- "SET RULE e " ^ rule_e in
- let (gs,_) =
- Arena.handle_request Arena.empty_state (req_of_str s) in
- let (_, msg) = Arena.handle_request gs (req_of_str "GET RULE e") in
- assert_equal ~msg:"Adding empty rule" ~printer:(fun x->x)
- rule_e msg;
-
- let rule_1 =
- "[ 1 | | vx { 1->0. }; vy { 1->0. }; x { 1->-15.4 }; y { 1->-50.6 } ] -> [ 1, 2 | | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-14.3, 2->6.6 }; y { 1->-77., 2->2.2 } ] with [1 <- 1] update :x(1) = 1 inv true post true "in
- let rule_1_res =
- "[1 | | vx {1->0.}; vy {1->0.}; x {1->-15.4}; y {1->-50.6}] -> [1, 2 | | vx {1->0., 2->0.}; vy {1->0., 2->0.}; x {1->-14.3, 2->6.6}; y {1->-77., 2->2.2}] with [1 <- 1]
-update
- :x(1) = 1.
- inv true post true" in
- let s = "SET RULE 1 " ^ rule_1 in
- let (gs,_) = Arena.handle_request Arena.empty_state (req_of_str s) in
- let (_, msg) = Arena.handle_request gs (req_of_str "GET RULE 1") in
- assert_equal ~msg:"Adding another rule" ~printer:(fun x->x)
- rule_1_res msg;
- );
-
"simple parsing and printing" >::
(fun () ->
let s = "PLAYERS white, black
@@ -115,14 +72,10 @@
(fun () ->
(* skip_if true "Change to simpler and stable example."; *)
let fname = "./examples/rewriting_example.toss" in
- let file = open_in fname in
- let contents = AuxIO.input_file file in
- let s = "SET STATE #" ^ fname ^ "#" ^ contents in
- let (gs,_) = Arena.handle_request Arena.empty_state (req_of_str s) in
- let (_, msg) =
- Arena.handle_request gs (req_of_str "GET STATE") in
- assert_equal ~msg:("Set "^fname) ~printer:(fun x->x)
- contents msg;
- ); *)
+ 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);
+ );
]
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -4,9 +4,7 @@
let get_time_step () = !time_step
let set_time_step x = (time_step := x)
-let debug_level = ref 0;
-
(* ---------------- BASIC TYPE DEFINITION AND CONSTRUCTOR ------------------- *)
(* Specification of a continuous rewriting rule, as in modelling document. *)
@@ -98,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
- if !debug_level > 1 then print_endline ("ct: " ^ (string_of_float !time));
+ LOG 2 "current time: %f" !time;
let p_vars, p_vals = List.split params in
let subst_params tm =
List.hd
@@ -131,7 +129,7 @@
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!*)
- if !debug_level > 1 then print_endline ("et: " ^ (string_of_float end_time));
+ LOG 2 "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 *)
@@ -153,13 +151,10 @@
all_vals := !cur_vals :: !all_vals ;
last_struc := !cur_struc
) else (
- if (!debug_level > 1) then (
- print_endline "Invariant failed.";
- print_endline (Structure.str !cur_struc);
- print_endline (Formula.sprint r.inv);
- ) ;
+ LOG 2 "Invariant failed.\n%s\n%s"
+ (Structure.str !cur_struc) (Formula.sprint r.inv);
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
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,7 +1,5 @@
(* Discrete structure rewriting. *)
-let debug_level = ref 0
-
let approximate_monotonic = ref true
let prune_indef_vars = ref true
@@ -156,14 +154,9 @@
args
| Some rlmap ->
Array.map (fun e->List.assoc e rlmap) args in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "compose_pre: rel=%s; args=%s; lhs_args=%s\n%!"
- rel
- (String.concat ", " (Array.to_list args))
- (String.concat ", " (Array.to_list lhs_args))
- );
- (* }}} *)
+ LOG 4 "compose_pre: rel=%s; args=%s; lhs_args=%s" rel
+ (String.concat ", " (Array.to_list args))
+ (String.concat ", " (Array.to_list lhs_args));
(* remove potential condition for absence/presence of the
fluent being just added / deleted *)
let body = FormulaMap.map_formula
@@ -178,22 +171,12 @@
if b && Aux.Strings.mem rel nega_frels then Formula.And []
else if b && Aux.Strings.mem rel posi_frels then Formula.Or []
else Formula.Rel (b_rel, b_args))} body in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "fluent_preconds: body before pruning:\n%s\n%!"
- (Formula.sprint body)
- );
- (* }}} *)
+ LOG 3 "fluent_preconds: body before pruning:\n%s" (Formula.sprint body);
(* remove closed subformulas and indefinite fluents *)
let indef_vars = collect_indef_vars body in
let body =
FormulaOps.remove_subformulas (rem_closed indef_vars) body in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "fluent_preconds: body after pruning:\n%s\n%!"
- (Formula.sprint body)
- );
- (* }}} *)
+ LOG 3 "fluent_preconds: body after pruning:\n%s" (Formula.sprint body);
let args = Array.to_list args in
let body, other_vars, numap_cstr =
match r.rlmap with
@@ -224,13 +207,8 @@
| [phi] -> phi
| _ -> Formula.Or disjs in
let precond = FormulaOps.prune_unused_quants precond in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "fluent_preconds: result -- rel=%s(%s), precond=\n%s\n%!"
- rel (String.concat ", " nu_args)
- (Formula.sprint precond)
- );
- (* }}} *)
+ LOG 3 "fluent_preconds: result -- rel=%s(%s), precond=\n%s"
+ rel (String.concat ", " nu_args) (Formula.sprint precond);
rel, (nu_args, precond) in
List.map (fluent_precond true) (Aux.Strings.elements posi_frels) @
List.map (fluent_precond false) (Aux.Strings.elements nega_frels)
@@ -295,23 +273,11 @@
(* Find all embeddings of a rule. Does not guarantee that rewriting
will succeed for all of them. *)
let find_matchings model rule =
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "find_matchings: match_formula=\n%s\n...%!"
- (Formula.sprint rule.match_formula);
- );
- if !debug_level > 4 then (
- Printf.printf "find_matchings: model=\n%s\n...%!"
- (Structure.sprint model);
- );
- (* }}} *)
+ LOG 4 "find_matchings: match_formula=\n%s\n..."
+ (Formula.sprint rule.match_formula);
+ LOG 5 "find_matchings: model=\n%s\n..." (Structure.sprint model);
let res = Solver.M.evaluate model rule.match_formula in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "find_matchings: result=%s\n%!"
- (AssignmentSet.str res)
- );
- (* }}} *)
+ LOG 4 "find_matchings: result=%s" (AssignmentSet.str res);
res
(* Choose an arbitrary matching of a rule from the matchings returned
@@ -696,15 +662,11 @@
let arg_tup = Array.of_list args in
map_some (fun (brel, ar) ->
let selector = Structure.free_for_rel brel ar in
- let asgn =
- Solver.M.evaluate selector rphi in
- (* {{{ log entry *)
- if !debug_level > 3 && asgn<>AssignmentSet.Empty then (
- Printf.printf "compile_rule.expand_defrel_tups: %s {%s} over\
- %s = %s\n%!" drel (Formula.str rphi) (Structure.str selector)
- (AssignmentSet.str asgn)
+ let asgn = Solver.M.evaluate selector rphi in
+ if asgn <> AssignmentSet.Empty then (
+ LOG 4 "compile_rule.expand_defrel_tups: %s {%s} over %s = %s" drel
+ (Formula.str rphi) (Structure.str selector) (AssignmentSet.str asgn)
);
- (* }}} *)
let btup = Array.init ar (fun i->i+1) in
(* [selector] has only [btup] with its elements *)
let selvars =
@@ -735,24 +697,14 @@
List.map fst (List.filter (fun (rel, ar) ->
let selector = Structure.free_for_rel rel ar in
let res = Solver.M.check selector rphi in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "compile_rule.expand_def_rels: %s on %s = %b\n%!"
- rel (Structure.str selector) res
- );
- (* }}} *)
+ LOG 4 "compile_rule.expand_def_rels: %s on %s = %b\n%!"
+ rel (Structure.str selector) res;
res
) signat)
else [rel] in
- unique(*_sorted *) (=)
- (concat_map expand_def_rels rule_src.emb_rels) in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "compile_rule: emb=%s -- base_emb_rels=%s\n%!"
- (String.concat ", " rule_src.emb_rels)
- (String.concat ", " base_emb_rels);
- );
- (* }}} *)
+ Aux.unique_sorted (concat_map expand_def_rels rule_src.emb_rels) in
+ LOG 2 "compile_rule: emb=%s -- base_emb_rels=%s"
+ (String.concat ", " rule_src.emb_rels) (String.concat ", " base_emb_rels);
let tups_union ts1 ts2 = Aux.unique (=) (ts1 @ ts2)
and tups_empty = []
and tups_diff ts1 ts2 =
@@ -843,23 +795,20 @@
let lhs_opt_rels, lhs_pos_tups, lhs_pos_expanded =
compile_opt_rels lhs_rels in
(* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "compile_rule: lhs_pos_tups=%s\n%!"
- (String.concat "; "(List.map (fun (rel,tups)->
- rel^"{"^String.concat ";"(List.map (fun tup ->
- "("^String.concat ", "
- (Array.to_list (Array.map (
- Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
- lhs_pos_tups));
- Printf.printf "compile_rule: lhs_pos_expanded=%s\n%!"
- (String.concat "; "(List.map (fun (rel,tups)->
- rel^"{"^String.concat ";"(List.map (fun tup ->
- "("^String.concat ", "
- (Array.to_list (Array.map (
- Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
- lhs_pos_expanded));
- );
- (* }}} *)
+ LOG 4 "compile_rule: lhs_pos_tups=%s"
+ (String.concat "; "(List.map (fun (rel,tups)->
+ rel ^ "{" ^ String.concat ";" (List.map (fun tup ->
+ "("^String.concat ", "
+ (Array.to_list (Array.map (
+ Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
+ lhs_pos_tups));
+ LOG 4 "compile_rule: lhs_pos_expanded=%s"
+ (String.concat "; "(List.map (fun (rel,tups)->
+ rel^"{"^String.concat ";"(List.map (fun tup ->
+ "("^String.concat ", "
+ (Array.to_list (Array.map (
+ Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
+ lhs_pos_expanded));
let lhs_all_tups n =
List.map Array.of_list (Aux.product (
Aux.fold_n (fun acc -> lhs_elems::acc) [] n)) in
@@ -886,17 +835,13 @@
with Not_found -> failwith
("not in signature: " ^ rel))))
base_emb_rels in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "compile_rule: lhs_neg_tups=%s\n%!"
- (String.concat "; "(List.map (fun (rel,tups)->
- rel^"{"^String.concat ";"(List.map (fun tup ->
- "("^String.concat ", "
- (Array.to_list (Array.map (
- Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
- lhs_neg_tups));
- );
- (* }}} *)
+ LOG 4 "compile_rule: lhs_neg_tups=%s\n%!"
+ (String.concat "; "(List.map (fun (rel,tups)->
+ rel^"{"^String.concat ";"(List.map (fun tup ->
+ "("^String.concat ", "
+ (Array.to_list (Array.map (
+ Structure.elem_name rule_src.lhs_struc) tup))^")") tups)^"}")
+ lhs_neg_tups));
(* injectivity checking *)
let nondistinct = List.map
(Array.map lhs_name_of) nondistinct in
@@ -998,15 +943,8 @@
rel, List.map (fun tup -> Array.map rhs_name_of tup) tups)
del_tuples in
(* Optimizing the embedding formula. *)
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "compile_rule: embedding formula = %s\n%!"
- (Formula.sprint emb)
- );
- if !debug_level > 2 then (
- Printf.printf "compile_rule: done.\n%!";
- );
- (* }}} *)
+ LOG 2 "compile_rule: embedding formula = %s" (Formula.sprint emb);
+ LOG 3 "compile_rule: done.";
{
struc_rule = Some rule_src;
lhs_vars = lhs_vars;
@@ -1097,16 +1035,9 @@
(Aux.concat_map (fun (_,arg) -> Array.to_list arg) add) in
assert (Aux.list_diff rhs_names struc_elems = []);
let rewritable args =
- Aux.array_for_all (fun v -> List.mem (Formula.var_str v) struc_elems)
- args in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- FormulaOps.set_debug_level !debug_level;
- Printf.printf "translate_from_precond:\n%!"
- );
- (* }}} *)
- let conjs =
- FormulaOps.as_conjuncts (FormulaOps.remove_redundant precond) in
+ Aux.array_for_all (fun v-> List.mem (Formula.var_str v) struc_elems) args in
+ LOG 5 "translate_from_precond:";
+ let conjs = FormulaOps.as_conjuncts (FormulaOps.remove_redundant precond) in
let posi, conjs = Aux.partition_map (function
| Formula.Rel (rel, args) when rewritable args ->
Left (rel,args)
@@ -1117,18 +1048,13 @@
Left (rel,args)
| phi -> Right phi) conjs in
let lhs_extracted = posi @ nega in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf
- "translate_from_precond:\nposi:\n%s\nnega:\n%s\norig-precond:\n%s\nsimpl-precond:%s\n%!"
- (Formula.sprint (Formula.And (List.map (fun (rel,args) ->
- Formula.Rel (rel,args)) posi)))
- (Formula.sprint (Formula.And (List.map (fun (rel,args) ->
- Formula.Rel (rel,args)) nega)))
- (Formula.sprint precond)
- (Formula.sprint (Formula.And conjs))
- );
- (* }}} *)
+ LOG 3 "translate_from_precond:\nposi:\n%s\nnega:\n%s\norig-precond:\n%s\nsimpl-precond:%s\n%!"
+ (Formula.sprint (Formula.And (List.map (fun (rel,args) ->
+ Formula.Rel (rel,args)) posi)))
+ (Formula.sprint (Formula.And (List.map (fun (rel,args) ->
+ Formula.Rel (rel,args)) nega)))
+ (Formula.sprint precond)
+ (Formula.sprint (Formula.And conjs));
let precond = Formula.And conjs in
let fvars = FormulaSubst.free_vars precond in
let local_vars =
@@ -1153,20 +1079,16 @@
let extracted =
List.map (Array.map Formula.var_str)
(Aux.assoc_all rel lhs_extracted) in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "translate_from_precond: _opt_%s -- extracted %s -- \
+ LOG 5 "translate_from_precond: _opt_%s -- extracted %s -- \
remaining %s\n%!" rel
- (String.concat "; "
- (List.map (fun args ->
- String.concat " " (Array.to_list args)) extracted))
- (String.concat "; "
- (List.map (fun args ->
- String.concat " " (Array.to_list args))
- (Aux.list_diff tups extracted)))
- );
- (* }}} *)
- let tups = Aux.list_diff tups extracted in
+ (String.concat "; "
+ (List.map (fun args ->
+ String.concat " " (Array.to_list args)) extracted))
+ (String.concat "; "
+ (List.map (fun args ->
+ String.concat " " (Array.to_list args))
+ (Aux.list_diff tups extracted)));
+ let tups = Aux.list_diff tups extracted in
List.map (fun args -> "_opt_"^rel, args) tups
with Not_found -> [])
emb_rels in
@@ -1182,20 +1104,15 @@
Aux.fold_n (fun acc -> struc_elems::acc) [] arity)) in
let modified =
Aux.assoc_all rel add @ Aux.assoc_all rel del in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf
- "translate_from_precond: RHS _opt_%s -- modified %s -- \
+ LOG 5 "translate_from_precond: RHS _opt_%s -- modified %s -- \
remaining %s\n%!" rel
- (String.concat "; "
- (List.map (fun args ->
- String.concat " " (Array.to_list args)) modified))
- (String.concat "; "
- (List.map (fun args ->
- String.concat " " (Array.to_list args))
- (Aux.list_diff tups modified)))
- );
- (* }}} *)
+ (String.concat "; "
+ (List.map (fun args ->
+ String.concat " " (Array.to_list args)) modified))
+ (String.concat "; "
+ (List.map (fun args ->
+ String.concat " " (Array.to_list args))
+ (Aux.list_diff tups modified)));
let tups = Aux.list_diff tups modified in
List.map (fun args -> "_opt_"^rel, args) tups
with Not_found -> [])
@@ -1216,12 +1133,7 @@
let lhs_struc = add_rels lhs_struc opt_s in
let lhs_struc = add_rels lhs_struc
(List.map (fun tup-> "_nondistinct_", tup) nondistinct) in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- FormulaOps.set_debug_level 0;
- Printf.printf "translate_from_precond: end\n%!"
- );
- (* }}} *)
+ LOG 5 "translate_from_precond: end";
{
lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/DiscreteRule.mli 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,7 +1,5 @@
(** Discrete structure rewriting rules construction and rewriting. *)
-val debug_level : int ref
-
(** If [true], ignore what happens on RHSes of rules when assessing
if fluents are positive / negative (only check whether their
LHS+precondition occurrences are negative/positive). *)
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,8 +1,6 @@
open OUnit
open DiscreteRule
-FormulaOps.set_debug_level 0 ;;
-
let struc_of_str s =
try
StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Formula/AuxIO.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -220,6 +220,18 @@
print_string s; flush stdout
) ENDIF
+let sprint_of_fprint fprint_fun x =
+ ignore (Format.flush_str_formatter ());
+ Format.fprintf Format.str_formatter "@[%a@]" fprint_fun x;
+ Format.flush_str_formatter ()
+
+let print_of_fprint fprint_fun x =
+ IFDEF JAVASCRIPT THEN (
+ print (sprint_of_fprint fprint_fun x)
+ ) ELSE (
+ fprint_fun Format.std_formatter x
+ ) ENDIF
+
let log module_name debug_lev s =
let s = "["^string_of_int debug_lev^"@"^module_name^"] "^s in
IFDEF JAVASCRIPT THEN (
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Formula/AuxIO.mli 2012-03-05 23:24:41 UTC (rev 1682)
@@ -65,3 +65,9 @@
(** Printing for JS and native. *)
val print : string -> unit
+
+(** Given formatter printing function, creates a to-string printing function. *)
+val sprint_of_fprint : (Format.formatter -> 'a -> unit) -> 'a -> string
+
+(** Given formatter printing function, creates a to-console printing function.*)
+val print_of_fprint : (Format.formatter -> 'a -> unit) -> 'a -> unit
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-02-28 02:36:29 UTC (rev 1681)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-03-05 23:24:41 UTC (rev 1682)
@@ -1,14 +1,5 @@
(* Represent Boolean combinations of integer literals. *)
-let debug_level = ref 0
-let debug_elim = ref false
-let set_debug_level i = (
- Sat.set_debug_level (i-1);
- debug_level := i;
- if i > 0 then debug_elim := true
-)
-let set_debug_elim b = (debug_elim := b;)
-
(* 0 : no generation is performed and to_cnf transforms a DNF
1 : use Tseitin to construct a CNF with auxiliary variables
2 : use Plaisted-Greenbaum to construct a CNF with auxiliary variables *)
@@ -210,9 +201,7 @@
try
let id = Hashtbl.find ids phi in if pos then id else -1 * id
with Not_found ->
- if !debug_level > 2 then
- print_endline ("Added " ^ (Formula.str phi)...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-07 03:56:23
|
Revision: 1683
http://toss.svn.sourceforge.net/toss/?rev=1683&view=rev
Author: lukaszkaiser
Date: 2012-03-07 03:56:13 +0000 (Wed, 07 Mar 2012)
Log Message:
-----------
Correcting loging, printing and old tests; adding bitvector.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/Term.ml
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Sat/MiniSAT.ml
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/KIFLexer.mll
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/MenhirLib/tableInterpreter.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/StructureTest.ml
Added Paths:
-----------
trunk/Toss/Solver/Num/Bitvector.ml
trunk/Toss/Solver/Num/Bitvector.mli
trunk/Toss/Solver/Num/BitvectorTest.ml
Removed Paths:
-------------
trunk/Toss/Client/MissingFunctions.js
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Arena/Arena.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -93,7 +93,7 @@
List.map (fun (lhs_v, m_e) ->
lhs_v,
(try Structure.find_elem state.struc m_e
- with Not_found -> Printf.printf "NF m_e=%s\n%!" m_e;
+ with Not_found -> AuxIO.print (Printf.sprintf "NF m_e=%s\n%!" m_e);
raise Not_found))
match_str
with Not_found ->
@@ -360,10 +360,7 @@
Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
)
-let sprint_game_move gm =
- ignore (Format.flush_str_formatter ());
- fprint_game_move Format.str_formatter gm;
- Format.flush_str_formatter ()
+let sprint_game_move gm = AuxIO.sprint_of_fprint fprint_game_move gm
let fprint_state_full print_compiled_rules ppf
({rules = rules;
@@ -416,18 +413,9 @@
Format.fprintf ppf "@]"
let fprint_state = fprint_state_full false
-
-let print_state r = fprint_state Format.std_formatter r
-let sprint_state r =
- ignore (Format.flush_str_formatter ());
- fprint_state Format.str_formatter r;
- Format.flush_str_formatter ()
-
-let sprint_state_full r =
- ignore (Format.flush_str_formatter ());
- fprint_state_full true Format.str_formatter r;
- Format.flush_str_formatter ()
-
+let print_state r = AuxIO.print_of_fprint (fprint_state_full false) r
+let sprint_state r = AuxIO.sprint_of_fprint (fprint_state_full false) r
+let sprint_state_full r = AuxIO.sprint_of_fprint (fprint_state_full true) r
let str game = sprint_state (game, snd empty_state)
let state_str state = sprint_state state
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Arena/ContinuousRule.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -253,11 +253,8 @@
let fprint = fprint_full false
-let print r = fprint Format.std_formatter r
-let sprint r =
- ignore (Format.flush_str_formatter ());
- fprint Format.str_formatter r;
- Format.flush_str_formatter ()
+let print r = AuxIO.print_of_fprint fprint r
+let sprint r = AuxIO.sprint_of_fprint fprint r
let matching_str struc emb =
let name (lhs_v,rhs_e) =
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -42,12 +42,12 @@
let r = rule_of_str s signat [] "rule2" in
assert_equal ~msg:"2. update" ~printer:(fun x->x) s (str r);
- let dyn_eq = " :f(a)' = (2. * :f(a)) + t;\n :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 ^ " inv true post true" in
let r = rule_of_str s signat [] "rule3" in
assert_equal ~msg:"3. dynamics" ~printer:(fun x->x) s (str r);
- let dyn_eq = " :f(a)' = (2. * :f(a)) + t;\n :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 ^
" inv true post true" in
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -1347,11 +1347,8 @@
(Aux.fprint_sep_list ";" matched) matching
-let print_rule r = fprint_rule Format.std_formatter r
-let sprint_rule r =
- ignore (Format.flush_str_formatter ());
- fprint_rule Format.str_formatter r;
- Format.flush_str_formatter ()
+let print_rule r = AuxIO.print_of_fprint fprint_rule r
+let sprint_rule r = AuxIO.sprint_of_fprint fprint_rule r
(* Either build a default correspondence for a rule, where RHS
Modified: trunk/Toss/Arena/Term.ml
===================================================================
--- trunk/Toss/Arena/Term.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Arena/Term.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -19,36 +19,6 @@
(* ------------------------ PRINTING FUNCTION ------------------------------- *)
-(* Print a term as a string. *)
-let rec str = function
- | Var s -> s
- | FVar (f, a) -> ":" ^ f ^ "(" ^ a ^ ")"
- | Const n -> string_of_float n
- | Times (p, q) -> term_pair_str " * " p q
- | Plus (p, Times (Const c, q)) when c = -1. -> term_pair_str " - " p q
- | Plus (p, Const c) when c < 0. -> term_pair_str " - " p (Const (-. c))
- | Plus (p, q) -> term_pair_str " + " p q
- | Div (p, q) -> term_pair_str " / " p q
-
-and term_pair_str sep p q =
- let brack s = if String.length s < 2 then s else "(" ^ s ^ ")" in
- match (p, q) with
- | (Const _, Const _) | (FVar _, Const _) | (Const _, FVar _)
- | (FVar _, FVar _) -> (str p) ^ sep ^ (str q)
- | (Const _, _) | (FVar _, _) -> (str p) ^ sep ^ (brack (str q))
- | (_, Const _) | (_, FVar _) -> (brack (str p)) ^ sep ^ (str q)
- | _ -> (brack (str p)) ^ sep ^ (brack (str q))
-
-
-(* Print an equation system as a string. *)
-let eq_str ?(diff=true) eqs =
- let sing_str ((f, a), t) =
- let mid_str = if diff then "' = " else " = " in
- let l_str = str (FVar (f, a)) in
- let r_str = str t in
- l_str ^ mid_str ^ r_str in
- " " ^ (String.concat ";\n " (List.map sing_str eqs))
-
(* Bracket-savvy precedences: + 0, - 1, * 2, / 3 *)
let rec fprint ?(prec=0) ppf = function
| Var s -> Format.pp_print_string ppf s
@@ -77,11 +47,9 @@
Format.fprintf ppf "@[<1>%s%a@ /@ %a%s@]" lb
(fprint ~prec:2) p (fprint ~prec:3) q rb
-let print r = fprint Format.std_formatter r
-let sprint r =
- ignore (Format.flush_str_formatter ());
- fprint Format.str_formatter r;
- Format.flush_str_formatter ()
+let print r = AuxIO.print_of_fprint fprint r
+let sprint r = AuxIO.sprint_of_fprint fprint r
+let str = sprint
(* Print an equation system. *)
let fprint_eqs ?(diff=false) ppf eqs =
@@ -91,11 +59,9 @@
f a mid_str (fprint ~prec:0) t in
Format.fprintf ppf "@[<hv>%a@]" (Aux.fprint_sep_list ";" sing) eqs
-let print_eqs ?diff r = fprint_eqs ?diff Format.std_formatter r
-let sprint_eqs ?diff r =
- ignore (Format.flush_str_formatter ());
- fprint_eqs ?diff Format.str_formatter r;
- Format.flush_str_formatter ()
+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 ------------------------- *)
Modified: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Arena/TermTest.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -13,13 +13,13 @@
let tests = "Term" >::: [
"parse" >::
(fun () ->
- let s = "(x - 0.2) / ((z * y) - 3.)" in
+ 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
+ let eqs = ":f(a)' = :f(a) + t" in
assert_equal ~printer:(fun x->x) eqs
(eq_str ~diff:true (eqs_of_string eqs));
Deleted: trunk/Toss/Client/MissingFunctions.js
===================================================================
--- trunk/Toss/Client/MissingFunctions.js 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Client/MissingFunctions.js 2012-03-07 03:56:13 UTC (rev 1683)
@@ -1,54 +0,0 @@
-// A bug in js_of_ocaml: it sometimes omits the functions below, which
-// belong to its runtmie.
-
-// Applies to code below this line:
-// Js_of_ocaml runtime support
-// http://www.ocsigen.org/js_of_ocaml/
-// Copyright (C) 2010 Jérôme Vouillon
-// Laboratoire PPS - CNRS Université Paris Diderot
-//
-// This program is free software; you can redistribute it and/or modify
-// it under the terms of the GNU Lesser General Public License as published by
-// the Free Software Foundation, with linking exception;
-// either version 2.1 of the License, or (at your option) any later version.
-//
-// This program is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU Lesser General Public License for more details.
-//
-// You should have received a copy of the GNU Lesser General Public License
-// along with this program; if not, write to the Free Software
-// Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-// Provides: caml_int64_bits_of_float const
-function caml_int64_bits_of_float (x) {
- if (!isFinite(x)) {
- if (isNaN(x)) return [255, 1, 0, 0xfff0];
- return (x > 0)?[255,0,0,0x7ff0]:[255,0,0,0xfff0];
- }
- var sign = (x>=0)?0:0x8000;
- if (sign) x = -x;
- var exp = Math.floor(Math.LOG2E*Math.log(x)) + 1023;
- if (exp <= 0) {
- exp = 0;
- x /= Math.pow(2,-1026);
- } else {
- x /= Math.pow(2,exp-1027);
- if (x < 16) { x *= 2; exp -=1; }
- if (exp == 0) { x /= 2; }
- }
- var k = Math.pow(2,24);
- var r3 = x|0;
- x = (x - r3) * k;
- var r2 = x|0;
- x = (x - r2) * k;
- var r1 = x|0;
- r3 = (r3 &0xf) | sign | exp << 4;
- return [255, r1, r2, r3];
-}
-//Provides: caml_int64_to_bytes
-function caml_int64_to_bytes(x) {
- return [x[3] >> 8, x[3] & 0xff, x[2] >> 16, (x[2] >> 8) & 0xff, x[2] & 0xff,
- x[1] >> 16, (x[1] >> 8) & 0xff, x[1] & 0xff];
-}
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Client/clientTest.js 2012-03-07 03:56:13 UTC (rev 1683)
@@ -88,7 +88,7 @@
return (existsId ("pred_b2_P"));
});
doAtTime (page, 4100, function () {
- ASYNCH ("run_tests_big", [""], function () {});
+ ASYNCH ("run_tests_small", [""], function () {});
});
doAtTime (undefined, 30000000, function () {
//console.log ("rendering");
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/Aux.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -49,37 +49,94 @@
(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 = '\n' || c = '\r' || c = ' ' || c = '\t'
+let is_space c = c = ' ' || c = '\n' || c = '\r' || c = '\t'
-let strip_spaces s =
+let strip_charprop f s =
let (b, e) = (ref 0, ref ((String.length s) - 1)) in
- while !b < !e && is_space (s.[!b]) do incr b done;
- while !b <= !e && is_space (s.[!e]) do decr e done;
+ while !b < !e && f (s.[!b]) do incr b done;
+ while !b <= !e && f (s.[!e]) do decr e done;
if !e < !b then "" else String.sub s !b (!e - !b + 1)
-let split_charprop s f =
+let strip_spaces s = strip_charprop is_space s
+
+let split_charprop ?(keep_split_chars=false) f s =
let l, i = String.length s, ref 0 in
let rec split_charprop_rec acc =
- while !i < l && f s.[!i] do i := !i+1 done;
- if !i = l then acc else (
+ while !i < l && f s.[!i] do
+ if keep_split_chars then acc := (String.make 1 s.[!i]) :: !acc;
+ i := !i+1;
+ done;
+ if !i = l then !acc else (
let start = !i in
while !i < l && not (f s.[!i]) do i := !i+1 done;
- split_charprop_rec ((String.sub s start (!i - start)) :: acc)
+ acc := (String.sub s start (!i - start)) :: !acc;
+ split_charprop_rec acc
) in
- List.rev (split_charprop_rec [])
+ List.rev (split_charprop_rec (ref []))
-let split_spaces s = split_charprop s is_space
+let split_spaces s = split_charprop is_space s
+let split_newlines s = split_charprop (fun c -> c = '\n' || c = '\r') s
+
+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
+ | [] -> lstr accs
+ | [x] -> if x = "\n" then lstr accs else lstr (accs ^ x)
+ | x :: y :: rs when x = "\n" && y = "\n" -> accs :: (concat_nonempty "" rs)
+ | x :: y :: rs -> concat_nonempty (accs ^ x) (y :: rs) in
+ concat_nonempty "" (split_charprop ~keep_split_chars:true (fun c-> c='\n') s)
+
let normalize_spaces s = String.concat " " (split_spaces s)
-let replace_charprop s f repl =
- let split, l = split_charprop s f, String.length s in
+let replace_charprop f repl s =
+ let split, l = split_charprop f s, String.length s in
let res = ref (String.concat repl split) in
if (l > 0 && f s.[0]) then res := repl ^ !res;
if (l > 1 && f s.[l-1]) then res := !res ^ repl;
!res
+let str_index ?(from=0) pattern s =
+ let l, pl = String.length s, String.length pattern in
+ let eq i =
+ let res = ref true in
+ for j = 0 to pl-1 do if pattern.[j] <> s.[i+j] then res := false; done;
+ !res in
+ let rec solve i = if i + pl > l then raise Not_found else
+ if eq i then i else solve (i+1) in
+ if pl = 0 then 0 else solve from
+
+let str_contains s pat = try str_index pat s >= 0 with Not_found -> false
+
+let str_subst_once_report pat res s =
+ 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)
+
+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 str_subst_once_from_to_report sfrom sto res s =
+ if sfrom = "" || sto = "" then failwith "str_subst_once_from_to: empty" else
+ try
+ let i, lfrom,l = str_index sfrom s, String.length sfrom,String.length s in
+ let j, lto = str_index ~from:(i+lfrom) sto s, String.length sto in
+ ((String.sub s 0 i) ^ res ^ (String.sub s (j+lto) (l-j-lto)), true)
+ with Not_found -> (s, false)
+
+let str_subst_once_from_to f t res s =
+ fst (str_subst_once_from_to_report f t res s)
+
+let rec str_subst_all_from_to f t res s =
+ let (new_s, didsth) = str_subst_once_from_to_report f t res s in
+ if didsth then str_subst_all_from_to f t res new_s else s
+
+
let fst3 (a,_,_) = a
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
@@ -738,36 +795,3 @@
Format.fprintf f "%s@\n@\n%a" sep f_el hd;
pr_tail f tl in
Format.fprintf f "%a%a" f_el hd pr_tail tl
-
-
-
-(* Replacements for basic Str functions. *)
-
-(* [split_regexp ~regexp:r s] splits [s] into substrings, taking as
- delimiters the substrings that match [r], and returns the list of
- substrings. For instance, [split ~regexp:"[ \t]+" s] splits [s]
- into blank-separated words. An occurrence of the delimiter at the
- beginning and at the end of the string is ignored. *)
-let split_regexp ~regexp s =
- IFDEF JAVASCRIPT THEN (
- let js_s = Js.string s in
- let js_regex = jsnew Js.regExp (Js.string regexp) in
- let res = js_s##split_regExp (js_regex) in
- let res = Js.to_array (Js.str_array res) in
- Array.to_list (Array.map Js.to_string res)
- ) ELSE (
- Str.split (Str.regexp regexp) s
- ) ENDIF
-
-(* [replace_regexp ~regexp ~templ s] returns a string identical to
- [s], except that all substrings of [s] that match [regexp] have
- been replaced by [templ]. *)
-let replace_regexp ~regexp ~templ s =
- IFDEF JAVASCRIPT THEN (
- let js_s = Js.string s in
- let js_regex = jsnew Js.regExp (Js.string regexp) in
- let res = js_s##replace (js_regex, Js.string templ) in
- Js.to_string res
- ) ELSE (
- Str.global_replace (Str.regexp regexp) templ s
- ) ENDIF
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/Aux.mli 2012-03-07 03:56:13 UTC (rev 1683)
@@ -46,18 +46,6 @@
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
-(** Split a string on characters satisfying [f]. *)
-val split_charprop : string -> (char -> bool) -> string list
-
-(** Split a string on spaces. *)
-val split_spaces : string -> string list
-
-(** Replace all white space sequences by a simple space, strip on both ends. *)
-val normalize_spaces : string -> string
-
-(** Replace characters satisfying [f] by [repl]. *)
-val replace_charprop : string -> (char -> bool) -> string -> string
-
(** Random element of a list. *)
val random_elem : 'a list -> 'a
@@ -329,10 +317,23 @@
val not_conflicting_name : ?truncate:bool -> Strings.t -> string -> string
(** Returns [n] strings proloning [s] and not appearing in [names]. *)
-val not_conflicting_names :
- ?truncate:bool ->
+val not_conflicting_names : ?truncate:bool ->
string -> Strings.t -> 'a list -> string list
+(** Printf helper functions. *)
+val list_fprint :
+ (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit
+val array_fprint :
+ (out_channel -> 'a -> unit) -> out_channel -> 'a array -> unit
+
+(** Print an unboxed separated list, with breaks after the separator. *)
+val fprint_sep_list :
+ ?newline : int -> string -> (Format.formatter -> 'a -> unit) ->
+ Format.formatter -> 'a list -> unit
+
+
+(** Replacements for basic Str functions. *)
+
(** Character classes. *)
val is_uppercase : char -> bool
val is_lowercase : char -> bool
@@ -345,31 +346,49 @@
and to start with a lowercase letter. **)
val clean_name : string -> string
+(** Strip characters satisfying [f] from left and right of a string. *)
+val strip_charprop : (char -> bool) -> string -> string
+
(** Strip spaces from left and right of a string. *)
val strip_spaces : string -> string
-(** Printf helper functions. *)
-val list_fprint :
- (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit
-val array_fprint :
- (out_channel -> 'a -> unit) -> out_channel -> 'a array -> unit
+(** Split a string on characters satisfying [f]. *)
+val split_charprop : ?keep_split_chars: bool ->
+ (char -> bool) -> string -> string list
+
+(** Split a string on spaces. *)
+val split_spaces : string -> string list
-(** Print an unboxed separated list, with breaks after the separator. *)
-val fprint_sep_list :
- ?newline : int -> string -> (Format.formatter -> 'a -> unit) ->
- Format.formatter -> 'a list -> unit
+(** Split a string on newlines (\n or \r). *)
+val split_newlines : string -> string list
+(** Split a string on empty lines (\n\n). *)
+val split_empty_lines : string -> string list
-(** Replacements for basic Str functions. *)
+(** Replace all white space sequences by a simple space, strip on both ends. *)
+val normalize_spaces : string -> string
-(** [split_regexp ~regexp:r s] splits [s] into substrings, taking as
- delimiters the substrings that match [r], and returns the list of
- substrings. For instance, [split ~regexp:"[ \t]+" s] splits [s]
- into blank-separated words. An occurrence of the delimiter at the
- beginning and at the end of the string is ignored. *)
-val split_regexp : regexp:string -> string -> string list
+(** Replace characters satisfying [f] by [repl]. *)
+val replace_charprop : (char -> bool) -> string -> string -> string
-(** [replace_regexp ~regexp ~templ s] returns a string identical to [s],
- except that all substrings of [s] that match [regexp] have been
- replaced by [templ]. *)
-val replace_regexp : regexp:string -> templ:string -> string -> string
+(** Index of the first occurence of the first argument in the second one.
+ Only positions after [from] count. If it does not occur, raise Not_found. *)
+val str_index : ?from : int -> string -> string -> int
+
+(** Checks whether the first argument contains in the second one. *)
+val str_contains : string -> string -> bool
+
+(** Substitute the first ocurrence of the first argument by the second one. *)
+val str_subst_once : string -> string -> string -> string
+
+(** Substitute all ocurrences of the first argument by the second one. *)
+val str_subst_all : string -> string -> string -> string
+
+(** Substitute the first ocurrence of the interval between
+ the first argument and the second one by the third one. *)
+val str_subst_once_from_to : string -> string -> string -> string -> string
+
+(** Substitute all ocurrences of the interval between
+ the first argument and the second one by the third one.
+ E.g. (str_subst_all_from_to "/*" "*/" "") removes C-style comments. *)
+val str_subst_all_from_to : string -> string -> string -> string -> string
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/AuxIO.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -220,6 +220,15 @@
print_string s; flush stdout
) ENDIF
+let printf fmt = Printf.ksprintf print fmt
+
+let print_err s =
+ IFDEF JAVASCRIPT THEN (
+ if is_worker then worker_log ("ERROR: "^ s) else console_log ("ERROR: "^ s)
+ ) ELSE (
+ prerr_string s; flush stderr
+ ) ENDIF
+
let sprint_of_fprint fprint_fun x =
ignore (Format.flush_str_formatter ());
Format.fprintf Format.str_formatter "@[%a@]" fprint_fun x;
@@ -229,7 +238,7 @@
IFDEF JAVASCRIPT THEN (
print (sprint_of_fprint fprint_fun x)
) ELSE (
- fprint_fun Format.std_formatter x
+ fprint_fun Format.std_formatter x; Format.print_flush ()
) ENDIF
let log module_name debug_lev s =
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/AuxIO.mli 2012-03-07 03:56:13 UTC (rev 1683)
@@ -66,6 +66,12 @@
(** Printing for JS and native. *)
val print : string -> unit
+(** Printf.printf for JS and native. *)
+val printf : ('a, unit, string, unit) format4 -> 'a
+
+(** Printing to stderr for JS and native. *)
+val print_err : string -> unit
+
(** Given formatter printing function, creates a to-string printing function. *)
val sprint_of_fprint : (Format.formatter -> 'a -> unit) -> 'a -> string
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -476,7 +476,7 @@
(fun clause ->
(* actually these clauses do not necessarily contain only
literals but maybe also more complex subformulas! *)
- let lits = (*print_endline("checking clause: " ^ str clause); *)
+ let lits =
match clause with
| BOr lits -> lits
| BVar v as lit -> [lit]
@@ -696,12 +696,12 @@
let try_dnf ?(disc_vars=[]) tm phi =
match to_dnf ~disc_vars ~tm phi with None -> phi | Some psi -> psi
-let univ ?(dbg=0) v phi =
- if dbg > 0 then Printf.printf "Univ subst in %s\n%!" (str phi);
+let univ ?(dbg=0) v phi =
+ if dbg > 0 then AuxIO.printf "Univ subst in %s\n%!" (str phi);
let simp1 = subst_simp [v] phi in
- if dbg > 0 then Printf.printf "Univ subst POS: %s\n%!" (str simp1);
+ if dbg > 0 then AuxIO.printf "Univ subst POS: %s\n%!" (str simp1);
let simp2 = subst_simp [-v] phi in
- if dbg > 0 then Printf.printf "Univ subst NEG: %s\n%!" (str simp2);
+ if dbg > 0 then AuxIO.printf "Univ subst NEG: %s\n%!" (str simp2);
BAnd [simp1; simp2]
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -417,7 +417,7 @@
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
if !file = "" then ( exec (); execbig (); ) else (
let qbf = read_qdimacs (AuxIO.input_file !file) in
- print_endline (BoolFormula.str (elim_quant qbf))
+ AuxIO.print ((BoolFormula.str (elim_quant qbf)) ^ "\n")
)
let _ = AuxIO.run_if_target "BoolFormulaTest" main
Modified: trunk/Toss/Formula/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/BoolFunction.ml 2012-03-07 03:56:13 UTC (rev 1683)
@@ -51,24 +51,8 @@
Format.fprintf f "@[<1>(exists@ %a.@ %a)@]"
fprint_mod_var_list mod_vars fprint phi
-(* Print to stdout, template from formatter printing. *)
-let make_print fprint_fun x = (
- Format.print_flush();
- fprint_fun Format.std_formatter x;
- Format.print_flush();
-)
-
-(* Print to string, template from formatter printing. *)
-let make_sprint fprint_fun x =
- ignore (Format.flush_str_formatter ());
- Format.fprintf Format.str_formatter "@[%a@]" fprint_fun x;
- Format.flush_str_formatter ()
-
-(* Print to stdout. *)
-let print = make_print fprint
-(* Print to string. *)
-let sprint = make_sprint fprint
-(* Another name for sprint. *)
+let print x = AuxIO.print_of_fprint fprint x
+let sprint x = AuxIO.sprint_of_fprint fprint x
let str = sprint
(* Print definition to formatter. *)
@@ -88,11 +72,10 @@
Format.fprintf f "@[<1>%s(%a)@ (%a)@]" name
fprint_mod_var_list mod_vars fprint def
-(* Print definition to stdout. *)
-let print_def ?(print_bool=false) = make_print (fprint_def ~print_bool)
-(* Print definition to string. *)
-let sprint_def ?(print_bool=false) = make_sprint (fprint_def ~print_bool)
-(* Another name for sprint_def. *)
+let print_def ?(print_bool=false) x =
+ AuxIO.print_of_fprint (fprint_def ~print_bool) x
+let sprint_def ?(print_bool=false) x =
+ AuxIO.sprint_of_fprint (fprint_def ~print_bool) x
let str_def = sprint_def
(* Print class and definition list to formatter. *)
@@ -115,11 +98,10 @@
Format.fprintf f "@[<1> %a;@]"
(Aux.fprint_sep_list ~newline:2 ";" (fprint_def ~print_bool)) dl
-(* Print definitions to stdout. *)
-let print_defs ?(print_bool=false) = make_print (fprint_defs ~print_bool)
-(* Print definitions to string. *)
-let sprint_defs ?(print_bool=false) = make_sprint (fprint_defs ~print_bool)
-(* Another name for sprint_defs. *)
+let print_defs ?(print_bool=false) x =
+ AuxIO.print_of_fprint (fprint_defs ~print_bool) x
+let sprint_defs ?(print_bool=false) x =
+ AuxIO.sprint_of_fprint (fprint_defs ~print_bool) x
let str_defs = sprint_defs
@@ -319,7 +301,7 @@
let nonf ?(tm=1200.) = apply_bool_elim (fun x -> Some (simplify x)) "ELIM"
(* Solve fixed-points in the definitions. *)
-let solve_lfp ?(nf=0) cls all_defs =
+let solve_lfp ?(nf=2) cls all_defs =
let (deffp, defsimp) =
List.partition (fun (_, fp, _, _) -> fp) (inline_defs all_defs) in
let defs = List.map (fun (_, _, _, f) -> f) deffp in
Modified: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli 2012-03-05 23:24:41 UTC (rev 1682)
+++ trunk/Toss/Formula/BoolFunction.mli 2012-03-07 03:56:13 UTC (rev 1683)
@@ -19,7 +19,7 @@
(** {2 Printing Functions} *)
-(** Print to stdout. *)
+(** Print. *)
val print : bool_function -> unit
(** Print to string. *)
val sprint : bool_function -> string
@@ -28,7 +28,7 @@
(** Print to formatter. *)
val fprint : Format.formatter -> bool_function -> unit
-(** Print definition to stdout. *)
+(** Print definition. *)
val print_def : ?print_bool : bool -> bool_def -> unit
(** Print definition to string. *)
val sprint_def : ?print_bool : bool -> bool_def -> string
@@ -38,7 +38,7 @@
val fprint_def : ?print_bool : bool -> Format.formatter -> bool_def -> unit
-(** Print definitions to stdout. *)
+(** Print definitions. *)
val print_defs : ?print_bool : bool ->
(string * string list) list * bool_def list -> unit
(** Print definitions to string. *)
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===============================================================...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-08 01:17:09
|
Revision: 1684
http://toss.svn.sourceforge.net/toss/?rev=1684&view=rev
Author: lukaszkaiser
Date: 2012-03-08 01:17:02 +0000 (Thu, 08 Mar 2012)
Log Message:
-----------
Using Bitvectors for unary predicates and assignments.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Num/Bitvector.ml
trunk/Toss/Solver/Num/Bitvector.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureTest.ml
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -296,6 +296,8 @@
List.map
(fun tp->List.map2 (fun v e->v,e) vars tp) tuples
| AssignmentSet.Empty -> []
+ | AssignmentSet.FOUn _ as x ->
+ enumerate_asgns all_elems vars (AssignmentSet.expand_unary x)
| AssignmentSet.FO (v, els) ->
let vars = list_remove v vars in
concat_map (fun (e,sub)->
@@ -780,8 +782,7 @@
(Structure.relations rule_src.lhs_struc) [] in
let rhs_rels = SSMap.fold
(fun rel tups rels ->
- if STups.is_empty tups then rels
- else
+ if STups.is_empty tups then rels else
(rel, List.map opt_map (STups.elements tups)) :: rels)
(Structure.relations rule_src.rhs_struc) [] in
let nondistinct, lhs_rels =
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Learn/Distinguish.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -313,7 +313,7 @@
| 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";
+ LOG 1 "distinguish_upto:\t neg types done (%i): " (List.length neg_tps);
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
Modified: trunk/Toss/Solver/AssignmentSet.ml
===================================================================
--- trunk/Toss/Solver/AssignmentSet.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/AssignmentSet.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -15,11 +15,18 @@
type assignment_set =
| Empty
| Any
+ | FOUn of string * Bitvector.bitvector
| FO of string * (int * assignment_set) list
| MSO of string * ((Elems.t * Elems.t) * assignment_set) list
| Real of (Poly.polynomial * Formula.sign_op) list list
+let expand_unary = function
+ | FOUn (v, bv) ->
+ FO (v, List.rev_map (fun i -> (i, Any)) (Bitvector.to_rev_list bv))
+ | x -> x
+
+
(* --------------------- PRINTING AND HELPER FUNCTIONS --------------------- *)
(* Variables assigned in an assignement set. *)
@@ -29,6 +36,7 @@
let rec assigned_vars acc = function
| Empty | Any -> acc
+ | FOUn (v, _) -> (`FO v) :: acc
| FO (v, l) -> assigned_vars_list assigned_vars ((`FO v) :: acc) l
| MSO (v, l) -> assigned_vars_list assigned_vars ((`MSO v) :: acc) l
| _ -> failwith "AssignmentSet:assigned vars not implemented for reals"
@@ -50,6 +58,7 @@
let rec str = function
| Empty -> "{}"
| Any -> "T"
+ | FOUn _ as x -> str (expand_unary x)
| FO (v, map) ->
let estr (e, a) =
if a = Any then v ^ "->" ^ (string_of_int e) else
@@ -70,6 +79,7 @@
let rec named_str struc = function
| Empty -> "{}"
| Any -> "T"
+ | FOUn _ as x -> named_str struc (expand_unary x)
| FO (v, map) ->
let estr (e, a) =
if a = Any then v ^ "->" ^ (Structure.elem_str struc e) else
@@ -95,6 +105,7 @@
let rec choose_fo default = function
| Empty -> raise Not_found
| Any -> default
+ | FOUn _ as x -> choose_fo default (expand_unary x)
| FO (v, []) when List.mem_assoc v default -> raise Not_found
| FO (v, (e, sub)::_) when e < 0 && List.mem_assoc v default ->
(v, List.assoc v default) :: choose_fo (List.remove_assoc v default) sub
@@ -113,6 +124,7 @@
List.rev_map Array.of_list
(Aux.product
(List.rev_map (fun _ -> Structure.Elems.elements elems) vars))
+ | FOUn _ as x -> tuples elems vars (expand_unary x)
| FO (v, (e,other_aset)::asg_list) when e < 0 ->
let asg_list = List.map (fun e ->
e, try List.assoc e asg_list with Not_found -> other_aset)
@@ -143,6 +155,7 @@
let tuples = Aux.product elems in
List.map (List.combine vars) tuples
| Empty -> []
+ | FOUn _ as x -> fo_assgn_to_list all_elems vars (expand_unary x)
| FO (v, (e,other_aset)::els) when e < 0 ->
let vars = Aux.list_remove (`FO v) vars in
let other_res =
Modified: trunk/Toss/Solver/AssignmentSet.mli
===================================================================
--- trunk/Toss/Solver/AssignmentSet.mli 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/AssignmentSet.mli 2012-03-08 01:17:02 UTC (rev 1684)
@@ -11,12 +11,15 @@
type assignment_set =
| Empty
| Any
+ | FOUn of string * Bitvector.bitvector
| FO of string * (int * assignment_set) list
| MSO of string *
((Structure.Elems.t * Structure.Elems.t) * assignment_set) list
| Real of (Poly.polynomial * Formula.sign_op) list list
+val expand_unary : assignment_set -> assignment_set
+
(** {2 Printing and small helper functions.} *)
(** Variables assigned in an assignement set. *)
Modified: trunk/Toss/Solver/Assignments.ml
===================================================================
--- trunk/Toss/Solver/Assignments.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/Assignments.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -6,6 +6,7 @@
open Structure
open AssignmentSet
+open Bitvector
(* ----------------------- BASIC TYPE DEFINITION -------------------------- *)
@@ -97,57 +98,64 @@
| (Empty, _) | (_, Empty) -> Empty
| (Any, a) -> a
| (a, Any) -> a
+ | (FOUn (v1, bv1), FOUn (v2, bv2)) when v1 = v2 ->
+ let bv = bv1 &&& bv2 in if is_empty bv then Empty else FOUn (v1, bv)
+ | (FO (v1, map1), FOUn (v2, _)) when compare_vars v1 v2 < 0 ->
+ fo_map v1 (join aset2) map1
+ | (FOUn (v1, _), FO (v2, map2)) when compare_vars v1 v2 > 0 ->
+ fo_map v2 (join aset1) map2
+ | (FOUn _, _) -> join (expand_unary aset1) aset2
+ | (_, FOUn _ ) -> join aset1 (expand_unary aset2)
| (FO (v1, map1), FO (v2, map2)) -> (
match compare_vars v1 v2 with
- 0 ->
- let res_map = List.rev (join_maps_rev [] (map1, map2)) in
- if res_map = [] then Empty else FO (v1, res_map)
- | x when x < 0 -> fo_map v1 (join aset2) map1
- | x -> fo_map v2 (join aset1) map2
- )
+ | 0 ->
+ let res_map = List.rev (join_maps_rev [] (map1, map2)) in
+ if res_map = [] then Empty else FO (v1, res_map)
+ | x when x < 0 -> fo_map v1 (join aset2) map1
+ | x -> fo_map v2 (join aset1) map2
+ )
| (FO (v, map), MSO _) -> fo_map v (join aset2) map
| (FO (v, map), Real _) -> fo_map v (join aset2) map
| (MSO _, FO (v, map)) -> fo_map v (join aset1) map
| (Real _, FO (v, map)) -> fo_map v (join aset1) map
| (MSO (v1, disj1), MSO (v2, disj2)) -> (
match compare_vars (v1) (v2) with
- 0 ->
- let res_disj = small_simp (join_disj [] disj1 disj2) in
- if res_disj = [] then Empty else MSO (v1, res_disj)
- | x when x < 0 -> mso_map v1 (join aset2) disj1
- | x -> mso_map v2 (join aset1) disj2
- )
+ | 0 ->
+ let res_disj = small_simp (join_disj [] disj1 disj2) in
+ if res_disj = [] then Empty else MSO (v1, res_disj)
+ | x when x < 0 -> mso_map v1 (join aset2) disj1
+ | x -> mso_map v2 (join aset1) disj2
+ )
| (MSO (v, disj), Real _) -> mso_map v (join aset2) disj
| (Real _, MSO (v, disj)) -> mso_map v (join aset1) disj
| (Real poly_dnf1, Real poly_dnf2) ->
- let app_2 l p = List.rev_append
- (List.rev_map (fun q -> List.rev_append p q) poly_dnf2) l in
- let all_polys = List.fold_left app_2 [] poly_dnf1 in
- let poly_dnf = List.filter RealQuantElim.sat all_polys in
- if poly_dnf = [] then Empty else Real (poly_dnf)
+ let app_2 l p = List.rev_append
+ (List.rev_map (fun q -> List.rev_append p q) poly_dnf2) l in
+ let all_polys = List.fold_left app_2 [] poly_dnf1 in
+ let poly_dnf = List.filter RealQuantElim.sat all_polys in
+ if poly_dnf = [] then Empty else Real (poly_dnf)
and join_maps_rev acc = function
| ([], _) -> acc
| (_, []) -> acc
| ((e1, a1) :: r1, (e2, a2) :: r2) ->
- match compare_elems e1 e2 with
- 0 ->
- let a = join a1 a2 in
- if a = Empty then join_maps_rev acc (r1, r2) else
- join_maps_rev ((e1, a) :: acc) (r1, r2)
- | x when x < 0 -> join_maps_rev acc (r1, ((e2, a2) :: r2))
- | x -> join_maps_rev acc (((e1, a1) :: r1), r2)
+ match compare_elems e1 e2 with
+ | 0 ->
+ let a = join a1 a2 in
+ if a = Empty then join_maps_rev acc (r1, r2) else
+ join_maps_rev ((e1, a) :: acc) (r1, r2)
+ | x when x < 0 -> join_maps_rev acc (r1, ((e2, a2) :: r2))
+ | x -> join_maps_rev acc (((e1, a1) :: r1), r2)
and join_disj acc disj1 = function
| [] -> acc
| ((pos2, neg2), a2) :: rest ->
- let adjoin_one acc ((pos1, neg1), a1) =
- let (pos, neg) = (Elems.union pos2 pos1, Elems.union neg2 neg1) in
- if Elems.is_empty (Elems.inter pos neg) then
- ((pos, neg), join a1 a2) :: acc
- else acc
- in
- join_disj (List.fold_left adjoin_one acc disj1) disj1 rest
+ let adjoin_one acc ((pos1, neg1), a1) =
+ let (pos, neg) = (Elems.union pos2 pos1, Elems.union neg2 neg1) in
+ if Elems.is_empty (Elems.inter pos neg) then
+ ((pos, neg), join a1 a2) :: acc
+ else acc in
+ join_disj (List.fold_left adjoin_one acc disj1) disj1 rest
(* ------------------------------ EQUAL -------------------------------- *)
@@ -155,6 +163,11 @@
(* Enforce [aset] and additionally that the FO variable [v] is set to [e]. *)
let rec set_equal uneq els v e = function
| Empty -> Empty
+ | FOUn (u, b) when u = v ->
+ let nb = if uneq then clear_bit b e else
+ if get_bit b e then set_bit empty e else empty in
+ if is_empty nb then Empty else FOUn (u, nb)
+ | FOUn _ as x -> set_equal uneq els v e (expand_unary x)
| FO (u, map) as aset -> (
match compare_vars u v with
| 0 ->
@@ -180,6 +193,7 @@
(* Enforce that in [aset] the variable [u] is equal to [w]; assumes u < w. *)
let rec eq_vars uneq els u w = function
| Empty -> Empty
+ | FOUn _ as x -> eq_vars uneq els u w (expand_unary x)
| FO (v, map) as aset -> (
match compare_vars v u with
| 0 ->
@@ -226,6 +240,11 @@
| (Any, _) | (_, Any) -> Any
| (Empty, a) -> a
| (a, Empty) -> a
+ | (FOUn (v1, bv1), FOUn (v2, bv2)) when v1 = v2 ->
+ let bv = bv1 ||| bv2 in
+ if nbr_set_bits bv = sllen elems then Any else FOUn (v1, bv)
+ | (FOUn _, _) -> sum elems (expand_unary aset1) aset2
+ | (_, FOUn _) -> sum elems aset1 (expand_unary aset2)
| (FO (v1, map1), FO (v2, map2)) -> (
match compare_vars v1 v2 with
| 0 ->
@@ -302,6 +321,7 @@
let rec project elems v = function
| Empty -> Empty
| Any -> Any
+ | FOUn (u, _) as x -> if u = v then Any else x
| FO (u, m) when u = v -> (* Sum the assignments below *)
List.fold_left (fun s (_, a) -> sum elems s a) Empty m
| FO (u, m) ->
@@ -344,6 +364,8 @@
let rec universal elems v = function
| Empty -> Empty
| Any -> Any
+ | FOUn (u, b) as x ->
+ if u <> v then x else if nbr_set_bits b < sllen elems then Empty else Any
| FO (u, m) when u = v -> (* Join the assignments below *)
if List.length m < sllen elems then Empty else
List.fold_left (fun s (_, a) -> join s a) Any m
@@ -390,6 +412,7 @@
let rec complement elems = function
| Empty -> Any
| Any -> Empty
+ | FOUn _ as x -> complement elems (expand_unary x)
| FO (v, map) ->
let compl_map =
List.rev (complement_map_rev elems [] (slist elems, map)) in
@@ -447,6 +470,8 @@
| (Empty, _) | (_, Any) -> Empty
| (Any, a) -> complement elems a
| (a, Empty) -> a
+ | (FOUn _ as x, y) -> complement_join elems (expand_unary x) y
+ | (x, (FOUn _ as y)) -> complement_join elems x (expand_unary y)
| (FO (v1, map1), FO (v2, map2)) when v1 = v2 ->
let resm = List.rev (complement_join_map_rev elems [] (map1, map2)) in
if resm = [] then Empty else FO (v1, resm)
@@ -507,6 +532,8 @@
let rec join_rel aset vars tuples_set incidence_map all_elems =
match aset with (* TODO: better use of incidence map? *)
| Empty -> Empty
+ | FOUn (v, _) when Aux.array_mem v vars ->
+ join_rel (expand_unary aset) vars tuples_set incidence_map all_elems
| FO (v, map) when Aux.array_mem v vars ->
let tps e =
if e < Array.length incidence_map then incidence_map.(e) else
@@ -529,8 +556,15 @@
| (_, a1) :: (((_, a2) :: _) as r) when a1 = a2 -> same_asg r
| _ -> false
+let rec all_any = function
+ | [] -> true
+ | (_, a) :: rest when a = Any -> all_any rest
+ | _ -> false
+
let rec compress no_elems = function
| FO (v, map) when List.length map = no_elems && same_asg map ->
compress no_elems (snd (List.hd map))
+ | FO (v, map) when all_any map ->
+ FOUn (v, Bitvector.of_list (List.rev_map fst map))
| FO (v, map) -> FO (v, map_snd (compress no_elems) map)
| x -> x
Modified: trunk/Toss/Solver/Num/Bitvector.ml
===================================================================
--- trunk/Toss/Solver/Num/Bitvector.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/Num/Bitvector.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -6,6 +6,20 @@
(* Empty bitvector. *)
let empty = ref (Naturals.nat_of_int 0)
+(* Check if a bitvector is empty. *)
+let is_empty v = !v.(0) = 0 && Aux.array_for_all (fun i -> i = 0) !v
+
+(* Number of bits set in a vector. *)
+let nbr_set_bits v =
+ let res = ref 0 in
+ let add_bits_i i =
+ for j = 0 to MiscNum.length_of_int - 1 do
+ if 1 lsl (1 lsl j) > 0 then incr res;
+ done; in
+ Array.iter (fun i -> if i <> 0 then add_bits_i i) !v;
+ !res
+
+
(* Helper function: coordinates of i-th bit *)
let coord i = i / MiscNum.length_of_int, i mod MiscNum.length_of_int
@@ -37,16 +51,19 @@
(* Mark the bits at positions given in the list. *)
let of_list l = List.fold_left set_bit empty l
-(* The list of set bits. *)
-let to_list v =
+(* The list of set bits, in reverse order. *)
+let to_rev_list v =
let r = Aux.range MiscNum.length_of_int in
let list_bits p i =
Aux.map_some (fun j-> if i land (1 lsl j) > 0 then Some(j+p) else None) r in
- let revbits_pos = List.fold_left (fun (listed, pos) i ->
+ fst (List.fold_left (fun (listed, pos) i ->
(List.rev_append (list_bits pos i) listed, pos+MiscNum.length_of_int)
- ) ([], 0) (Array.to_list !v) in
- List.rev (fst revbits_pos)
+ ) ([], 0) (Array.to_list !v))
+(* The list of set bits. *)
+let to_list v = List.rev (to_rev_list v)
+
+
(* Print the bit vector to string. *)
let str v =
let r = Aux.range MiscNum.length_of_int in
Modified: trunk/Toss/Solver/Num/Bitvector.mli
===================================================================
--- trunk/Toss/Solver/Num/Bitvector.mli 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/Num/Bitvector.mli 2012-03-08 01:17:02 UTC (rev 1684)
@@ -5,6 +5,12 @@
(** Empty bit vector. *)
val empty : bitvector
+(** Check if a bitvector is empty. *)
+val is_empty : bitvector -> bool
+
+(** Number of bits set in a vector. *)
+val nbr_set_bits : bitvector -> int
+
(** Get the bit at the given position. *)
val get_bit : bitvector -> int -> bool
@@ -21,6 +27,9 @@
(** The list of set bits. *)
val to_list : bitvector -> int list
+(** The list of set bits, in reverse order. *)
+val to_rev_list : bitvector -> int list
+
(** Print the bit vector to string. *)
val str : bitvector -> string
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/Solver.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -1,11 +1,11 @@
(* Solver for checking if formulas hold on structures. *)
+open Bitvector
open AssignmentSet
open Assignments
open Structure
open Formula
-
(* CACHE *)
type cachetbl =
@@ -78,7 +78,18 @@
let get_formula solver i = Hashtbl.find solver.formulas_eval i
+let phi_rels phi =
+ let rels = ref [] in
+ let app_rel = function Rel (s, _) as r -> rels := s :: !rels; r | x -> x in
+ let app_re = function Fun _ -> raise Not_found | x -> x in
+ try
+ let _ = FormulaMap.map_to_atoms_full app_rel app_re phi in
+ let rs = Aux.unique_sorted ~cmp:String.compare !rels in
+ LOG 2 "F: %s %s" (Formula.str phi) (String.concat ", " rs);
+ Some rs
+ with Not_found -> None
+
(* ------------------------------ EVALUATION ------------------------------- *)
(* Helper function: remove duplicates from sorted list of variables. *)
@@ -125,7 +136,12 @@
if nxt = a then nxt else fixpnt v vs psi nxt in
let simp a = Assignments.compress (Assignments.sllen elems) a in
if aset = Empty then Empty else
+ let foun_var = match aset with FOUn (v,_) -> v | _ -> "" in
match phi with
+ | Rel (relname, [|v|]) ->
+ let bv = Structure.pred_vector model relname in
+ if Bitvector.is_empty bv then Empty else
+ report (join aset (FOUn (var_str v, bv)))
| Rel (relname, vl) ->
let tuples_s = Structure.rel_graph relname model in
let inc_map = Structure.rel_incidence relname model in
@@ -166,14 +182,53 @@
let (_, asets) = List.fold_left step_or (aset, []) fl in
report (List.fold_left (sum elems) Empty asets)
| Ex ([], phi) | All ([], phi) -> failwith "evaluating empty quantifier"
- | Ex (vl, phi) ->
+ | Ex ([v], And (Rel (r1, v1):: Rel (r2, v2):: rest)) as ephi when
+ foun_var <> "" && ( let vfo = to_fo v in (* an often occurring join *)
+ (v1 = [|vfo|] && v2 = [|vfo; `FO foun_var|]) ||
+ (v1 = [|vfo|] && v2 = [|`FO foun_var; vfo|]) ||
+ (v2 = [|vfo|] && v1 = [|vfo; `FO foun_var|]) ||
+ (v2 = [|vfo|] && v1 = [|`FO foun_var; vfo|]) ) &&
+ not (List.mem (`FO foun_var) (FormulaSubst.free_vars (And rest)))->(
+ LOG 1 "special join on %s for %s" foun_var (str ephi);
+ let pred, rbin, vpred, vbin =
+ if Array.length v1= 1 then r1, r2, v1, v2 else r2, r1, v2, v1 in
+ let othpos = if vpred.(0) = vbin.(0) then 0 else 1 in
+ let inc_map = Structure.rel_incidence rbin model in
+ let av = match aset with FOUn (_, av) -> av | _-> failwith "av" in
+ let add_to_bitvec b e =
+ if e >= Array.length inc_map then b else
+ Tuples.fold (fun t b -> set_bit b t.(othpos)) inc_map.(e) b in
+ let b0 = List.fold_left add_to_bitvec Bitvector.empty
+ (Bitvector.to_rev_list av) in
+ let b = b0 &&& (Structure.pred_vector model pred) in
+ if Bitvector.is_empty b then Empty else
+ let r = eval fp model elems (FOUn (var_str v, b)) (And rest) in
+ if r = Empty then Empty else
+ let ag = eval fp model elems r (Rel (rbin, vbin)) in
+ report (simp (join aset (project_list elems ag [var_str v])))
+ )
+ | Ex (vl, phi) as ephi ->
check_timeout "Solver.eval.Ex";
let aset_vars = AssignmentSet.assigned_vars [] aset in
- let in_aset =
- if List.exists (fun v->List.mem v aset_vars) vl then Any else aset in
- let phi_asgn = eval fp model elems in_aset phi in
- report (simp (join aset
- (project_list elems phi_asgn (List.map var_str vl))))
+ if (fp = [] &&
+ ((List.exists (fun v->List.mem v aset_vars) vl) ||
+ (aset_vars <> [] && FormulaSubst.free_vars ephi = []))) then
+ let phi_asgn =
+ try
+ let (res, _) = Hashtbl.find !cache_results phi in
+ LOG 2 "In-Eval found in cache: %s" (Formula.str phi);
+ res
+ with Not_found ->
+ 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))))
| All (vl, phi) ->
check_timeout "Solver.eval.All";
let aset_vars = AssignmentSet.assigned_vars [] aset in
@@ -217,8 +272,8 @@
let fo_vars_real re =
remove_dup_vars [] (List.sort compare_vars (fo_vars_r_rec re)) in
let rec sum_polys = function
- Empty -> Poly.Const 0.
- | Any -> failwith "absolute assignement for sum, impossible to calculate"
+ | Empty -> Poly.Const 0.
+ | Any | FOUn _ -> failwith "absolute assignement for sum,impossible to calc"
| FO (_, alist) ->
let addp p (_, a) = Poly.Plus (p, sum_polys a) in
List.fold_left addp (Poly.Const 0.) alist
@@ -292,17 +347,6 @@
(b, pair :: nl)
-let phi_rels phi =
- let rels = ref [] in
- let app_rel = function Rel (s, _) as r -> rels := s :: !rels; r | x -> x in
- let app_re = function Fun _ -> raise Not_found | x -> x in
- try
- let _ = FormulaMap.map_to_atoms_full app_rel app_re phi in
- let rs = Aux.unique_sorted ~cmp:String.compare !rels in
- LOG 2 "F: %s %s" (Formula.str phi) (String.concat ", " rs);
- Some rs
- with Not_found -> None
-
let re_rels re =
let rels = ref [] in
let app_rel = function Rel (s, _) as r -> rels := s :: !rels; r | x -> x in
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/SolverTest.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -36,6 +36,8 @@
let tests = "Solver" >::: [
"eval: first-order quantifier free" >::
(fun () ->
+ eval_eq "[ | P { (1) }; R:1 {} | ]" "P(x0)" "{ x0->1 }";
+ eval_eq "[ | P:1 {}; R { (1) } | ]" "P(x0)" "{}";
eval_eq "[ | R { (a, b); (a, c) } | ]" "x = y"
"{ y->1{ x->1 } , y->2{ x->2 } , y->3{ x->3 } }";
eval_eq "[ | R { (a, b); (b, c) }; P { b } | ]" "P(x) and x = y"
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-03-07 03:56:13 UTC (rev 1683)
+++ trunk/Toss/Solver/Structure.ml 2012-03-08 01:17:02 UTC (rev 1684)
@@ -50,7 +50,8 @@
type structure = {
rel_signature : int StringMap.t ;
elements : Elems.t ;
- relations : Tuples.t StringMap.t ;
+ predicates : Bitvector.bitvector StringMap.t ; (* unary relations *)
+ relations : Tuples.t StringMap.t ; (* binary (or more-ary) relations *)
functions : (float IntMap.t) StringMap.t ;
incidence : (TIntMap.t) StringMap.t ;
names : int StringMap.t ;
@@ -62,12 +63,14 @@
let compare s1 s2 =
if s1 == s2 then 0 else
- let c = StringMap.compare Tuples.compare s1.relations s2.relations in
+ let c = Elems.compare s1.elements s2.elements in
if c <> 0 then c else
- let d = Elems.compare s1.elements s2.elements in
+ let d = StringMap.compare Tuples.compare s1.relations s2.relations in
if d <> 0 then d else
- StringMap.compare (IntMap.compare Pervasives.compare)
- s1.functions s2.functions
+ let e = StringMap.compare Pervasives.compare s1.predicates s2.predicates
+ in if e <> 0 then e else
+ StringMap.compare (IntMap.compare Pervasives.compare)
+ s1.functions s2.functions
let equal s1 s2 = (compare s1 s2 = 0)
@@ -80,15 +83,21 @@
let inv_names s = s.inv_names
let replace_names s nms inms = { s with names = nms; inv_names = inms }
let functions s = s.functions
-let relations s = s.relations
+let tuples_of_bitvec b =
+ let append_sg tps e = Tuples.add [|e|] tps in
+ List.fold_left append_sg Tuples.empty (Bitvector.to_rev_list b)
+let relations s = StringMap.fold (fun pred bv acc ->
+ StringMap.add pred (tuples_of_bitvec bv) acc) s.predicates s.relations
+
(* ----------------------- BASIC HELPER FUNCTIONS --------------------------- *)
(* Number of tuples in a relation. *)
let rel_size struc rel =
- try
- Tuples.cardinal (StringMap.find rel struc.relations)
- with Not_found -> 0
+ try Tuples.cardinal (StringMap.find rel struc.relations)
+ with Not_found ->
+ try Bitvector.nbr_set_bits (StringMap.find rel struc.predicates)
+ with Not_found -> 0
(* Reverse a map: make a string IntMap from an int StringMap. *)
let rev_string_to_int_map map =
@@ -101,6 +110,7 @@
(* Return the empty structure. *)
let empty_structure () = {
elements = Elems.empty ;
+ predicates = StringMap.empty ;
relations = StringMap.empty ;
functions = StringMap.empty ;
incidence = StringMap.empty ;
@@ -110,28 +120,39 @@
}
let rel_signature struc =
- StringMap.fold (fun r ar si -> (r,ar)::si)
- struc.rel_signature []
+ StringMap.fold (fun r ar si -> (r,ar)::si) struc.rel_signature []
let rel_sizes struc =
- StringMap.fold (fun r tups si -> (r,Tuples.cardinal tups)::si)
- struc.relations []
+ let rs = StringMap.fold (fun r tups si -> (r, Tuples.cardinal tups)::si)
+ struc.relations [] in
+ StringMap.fold (fun r bv si -> (r, Bitvector.nbr_set_bits bv)::si)
+ struc.predicates rs
+
+let pred_vector struc pred =
+ try StringMap.find pred struc.predicates with Not_found -> Bitvector.empty
-
(* Return the list of relation tuples incident to an element [e] in [struc]. *)
let incident struc e =
let acc_incident rname inc_map acc =
let tps = TIntMap.find e inc_map in
if Tuples.is_empty tps then acc else (rname, Tuples.elements tps) :: acc in
- StringMap.fold acc_incident struc.incidence []
+ let acc_inc_pred pred bv acc =
+ if Bitvector.get_bit bv e then (pred, [[|e|]]) :: acc else acc in
+ StringMap.fold acc_inc_pred struc.predicates
+ (StringMap.fold acc_incident struc.incidence [])
(* Check if a relation holds for a tuple. *)
let check_rel struc rel tp =
- try
- let tups = StringMap.find rel struc.relations in
- Tuples.mem tp tups
- with Not_found -> false
+ if Array.length tp > 1 then
+ try
+ let tups = StringMap.find rel struc.relations in
+ Tuples.mem tp tups
+ with Not_found -> false
+ else
+ try
+ Bitvector.get_bit (StringMap.find rel struc.predicates) tp.(0)
+ with Not_found -> false
(* Return the value of function [f] on [e] in [struc]. *)
let fun_val struc f e =
@@ -146,7 +167,9 @@
(* Find a relation in a model. *)
let rel_graph relname model =
try StringMap.find relname model.relations
- with Not_found -> Tuples.empty
+ with Not_found ->
+ try tuples_of_bitvec (StringMap.find relname model.predicates)
+ with Not_found -> Tuples.empty
(* Incidences of a relation in a model. *)
let rel_incidence relname model =
@@ -218,53 +241,54 @@
(* Ensure relation named [rn] exists in [struc], check arity, add the
relation if needed. *)
let add_rel_name rn arity struc =
- if StringMap.mem rn struc.relations then
- let old_arity = StringMap.find rn struc.rel_signature in
- if arity <> old_arity then
- raise (Structure_mismatch
- (Printf.sprintf
- "arity mismatch for %s: expected %d, given %d"
- rn old_arity arity));
- struc
+ if arity = 1 then
+ if StringMap.mem rn struc.predicates then struc else
+ { struc with rel_signature = StringMap.add rn 1 struc.rel_signature;
+ predicates = StringMap.add rn Bitvector.empty struc.predicates; }
else
- { struc with
- rel_signature = StringMap.add rn arity struc.rel_signature;
- relations = StringMap.add rn Tuples.empty struc.relations;
- incidence = StringMap.add rn TIntMap.empty struc.incidence; }
+ if StringMap.mem rn struc.relations then
+ let old_arity = StringMap.find rn struc.rel_signature in
+ if arity <> old_arity then
+ raise (Structure_mismatch
+ (Printf.sprintf "arity mismatch for %s: expected %d, given %d"
+ rn old_arity arity));
+ struc
+ else
+ { struc with
+ rel_signature = StringMap.add rn arity struc.rel_signature;
+ relations = StringMap.add rn Tuples.empty struc.relations;
+ incidence = StringMap.add rn TIntMap.empty struc.incidence; }
let empty_with_signat signat =
- List.fold_right (fun (rn,ar) -> add_rel_name rn ar) signat
+ List.fold_right (fun (rn, ar) -> add_rel_name rn ar) signat
(empty_structure ())
-(* Add empty relation named [rn] to [struc], with given arity,
- regardless of whether it already existed. *)
-let force_add_rel_name rn arity struc =
- { struc with
- rel_signature = StringMap.add rn arity struc.rel_signature;
- relations = StringMap.add rn Tuples.empty struc.relations;
- incidence = StringMap.add rn TIntMap.empty struc.incidence; }
-
(* Add tuple [tp] to relation [rn] in structure [struc]. *)
let add_rel struc rn tp =
let new_struc =
Array.fold_left (fun struc e -> add_elem struc e)
(add_rel_name rn (Array.length tp) struc) tp in
- let add_to_relmap rmap =
- let tps = StringMap.find rn rmap in
- StringMap.add rn (Tuples.add tp tps) rmap in
- let new_rel = add_to_relmap new_struc.relations in
- let add_to_imap imap e =
- try
- TIntMap.add e (Tuples.add tp (TIntMap.find e imap)) imap
- with Not_found ->
- TIntMap.add e (Tuples.singleton tp) imap in
- let new_incidence_imap =
- try
- Array.fold_left add_to_imap (StringMap.find rn new_struc.incidence) tp
- with Not_found ->
- Array.fold_left add_to_imap TIntMap.empty tp in
- let new_incidence = StringMap.add rn new_incidence_imap new_struc.incidence in
- { new_struc with relations = new_rel ; incidence ...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-08 20:18:28
|
Revision: 1685
http://toss.svn.sourceforge.net/toss/?rev=1685&view=rev
Author: lukaszkaiser
Date: 2012-03-08 20:18:20 +0000 (Thu, 08 Mar 2012)
Log Message:
-----------
Optimizing and debugging JS playing.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Main.js
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/Sat/SatTest.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureTest.ml
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Arena/DiscreteRule.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -296,8 +296,6 @@
List.map
(fun tp->List.map2 (fun v e->v,e) vars tp) tuples
| AssignmentSet.Empty -> []
- | AssignmentSet.FOUn _ as x ->
- enumerate_asgns all_elems vars (AssignmentSet.expand_unary x)
| AssignmentSet.FO (v, els) ->
let vars = list_remove v vars in
concat_map (fun (e,sub)->
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Client/JsHandler.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -198,6 +198,16 @@
let _ = set_handle "make_move" make_move
+let precache time =
+ let game, _ = !cur_game.game_state in
+ let state = List.hd !play_states in
+ Play.set_timeout (Js.to_float time);
+ LOG 1 "precaching %f seconds" (Js.to_float time);
+ ignore (Play.maximax_unfold_choose 4 game state !cur_game.heuristic);
+ Play.cancel_timeout ()
+
+let _ = set_handle "precache" precache
+
(* When called in a different thread, we can't call continuation. So
arrange to do it from "outside". *)
let suggest player_name time =
@@ -215,6 +225,7 @@
game state !cur_game.heuristic) in
Play.cancel_timeout ();
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
let result =
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Client/Main.js 2012-03-08 20:18:20 UTC (rev 1685)
@@ -493,6 +493,7 @@
console.log ("new_play_do callback: play created");
PLAYS.push(p);
p.redraw ();
+ ASYNCH ("precache", [0.5], function () {});
//li = new_play_item (GAME_NAME, CUR_PLAY_I);
//document.getElementById ("plays-list-" + GAME_NAME).appendChild (li);
}
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -251,7 +251,7 @@
let get_conjunctions = function BAnd fl -> fl | f -> [f] in
let get_disjunctions = function BOr fl -> fl | f -> [f] in
let fold_acc f xl =
- List.fold_left (fun acc x -> (f x) @ acc) [] xl in
+ List.fold_left (fun acc x -> List.rev_append (List.rev (f x)) acc) [] xl in
let rev_collect_conj xl = fold_acc get_conjunctions xl in
let rev_collect_disj xl = fold_acc get_disjunctions xl in
match phi with
@@ -303,13 +303,14 @@
let unique_psis = Aux.unique (=) psis in
let lits = List.filter is_literal unique_psis in
if neg_occurrence lits then BAnd [] else
- BOr (List.map singularise unique_psis)
+ BOr (List.rev (List.rev_map singularise unique_psis))
| BAnd psis ->
let unique_psis = Aux.unique (=) psis in
let lits = List.filter is_literal unique_psis in
if neg_occurrence lits then BOr [] else
- BAnd (List.map singularise unique_psis) in
+ BAnd (List.rev (List.rev_map singularise unique_psis)) in
let rec subsumption phi =
+ LOG 2 "simplify: subsumption";
let subclause a b =
match (a,b) with
| (BOr psis, BOr thetas)
@@ -325,47 +326,51 @@
| BVar _ | BNot _ -> phi
| BAnd psis ->
let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
- BAnd(non_disjnctns @ List.filter
- (fun theta ->
- (List.for_all (fun phi -> phi=theta ||
- not (subformula phi theta)) non_disjnctns)
- && (List.for_all (fun phi -> phi=theta ||
- not (subclause phi theta)) disjnctns))
- disjnctns)
+ BAnd (List.rev_append (List.rev non_disjnctns) (
+ List.filter
+ (fun theta ->
+ (List.for_all (fun phi -> phi=theta ||
+ not (subformula phi theta)) non_disjnctns)
+ && (List.for_all (fun phi -> phi=theta ||
+ not (subclause phi theta)) disjnctns)
+ ) disjnctns))
| BOr psis ->
let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
- BOr(non_conjnctns @ List.filter
- (fun theta ->
- (List.for_all (fun phi -> phi=theta ||
- not (subformula phi theta)) non_conjnctns)
- && (List.for_all (fun phi -> phi=theta ||
- not (subclause phi theta)) conjnctns))
- conjnctns) in
+ BOr (List.rev_append (List.rev non_conjnctns) (
+ List.filter
+ (fun theta ->
+ (List.for_all (fun phi -> phi=theta ||
+ not (subformula phi theta)) non_conjnctns)
+ && (List.for_all (fun phi -> phi=theta ||
+ not (subclause phi theta)) conjnctns)
+ ) conjnctns)) in
let unit_propagation phi =
+ LOG 2 "simplify: unit_propagation";
(* beware that unit_propagation might introduce the subformula true,
and hence should be followed by neutral_absorbing before
starting the next fixed-point iteration *)
match phi with
| BAnd phis ->
- let units = List.map
- (function | BVar v -> v | _ -> failwith ("not a literal!"))
- (List.filter is_literal phis) in
+ let units = List.rev (List.rev_map (
+ function | BVar v -> v | _ -> failwith ("not a literal!")
+ ) (List.filter is_literal phis)) in
let rec propagate units phi =
match phi with
| BVar v ->
if List.exists (fun unit -> v=unit) units then BAnd [] else phi
| BNot psi -> BNot (propagate units psi)
- | BAnd psis -> BAnd (List.map (propagate units) psis)
- | BOr psis -> BOr (List.map (propagate units) psis) in
- BAnd ((List.map (fun v -> BVar v) units) @
- (List.map (propagate units) phis))
+ | BAnd psis -> BAnd (List.rev (List.rev_map (propagate units) psis))
+ | BOr psis-> BOr (List.rev (List.rev_map (propagate units) psis)) in
+ BAnd (List.rev_append (List.rev_map (fun v -> BVar v) units)
+ (List.rev (List.rev_map (propagate units) phis)))
| _ -> phi in
let rec resolution phi =
+ LOG 2 "simplify: resolution";
match phi with
| BVar v -> phi
| BNot psi -> BNot (resolution psi)
| BOr psis ->
- let res_psis = List.map resolution psis in
+ let res_psis = List.rev (List.rev_map resolution psis) in
let neg_phi = to_nnf (BNot (BOr res_psis)) in
let res_neg_phi = resolution neg_phi in
to_nnf (BNot res_neg_phi)
@@ -399,19 +404,20 @@
else (* construct a resolvent and mark it with the unused literal 0 *)
let lit = List.nth res_lits 0 in
(* construct resolvent of cl1 and cl2 using pivot-literal lit *)
- BOr ((lit_of_int 0) ::
- (List.map lit_of_int
- (List.filter (fun lit1 -> lit1 <> lit) cl1_lits
- @ List.filter (fun lit2 -> lit2 <> -lit) cl2_lits))
- @ cl1_rest @ cl2_rest) in
+ let flist = List.rev_map lit_of_int
+ (List.rev_append (List.rev (
+ List.filter (fun lit1 -> lit1 <> lit) cl1_lits))
+ (List.filter (fun lit2 -> lit2 <> -lit) cl2_lits)) in
+ BOr ((lit_of_int 0) :: (List.rev_append flist (
+ List.rev_append (List.rev cl1_rest) cl2_rest))) in
let res_clauses = ref [] in
let subsumed = ref [] in
- (* Construct all possible resolvents and check each new resolvent
- whether it is subsumed by some existing clause.
- In fact, the following does not work: If this is the case we can
- remove two initial clauses (ie add them to the list subsumed).
- Instead, we discard the resolved but subsumed clause directly.
- *)
+ (* Construct all possible resolvents and check each new resolvent
+ whether it is subsumed by some existing clause.
+ In fact, the following does not work: If this is the case we can
+ remove two initial clauses (ie add them to the list subsumed).
+ Instead, we discard the resolved but subsumed clause directly.
+ *)
List.iter (fun cl1 ->
(List.iter
(fun cl2 ->
@@ -434,22 +440,27 @@
then ( (* do nothing, since the resolvent is useless *) ) else
res_clauses := cl_res :: !res_clauses;
) clauses)) clauses;
+ LOG 2 "simplify: resolution: filtering; clauses: %i subsumed: %i"
+ (List.length clauses) (List.length !subsumed);
LOG 3 "Resolvents: %s\nSubsumed clauses: %s\nReduced Resolvents: %s"
- (String.concat ", " (List.map str !res_clauses))
- (String.concat ", " (List.map str !subsumed))
+ (String.concat ", " (List.rev (List.rev_map str !res_clauses)))
+ (String.concat ", " (List.rev (List.rev_map str !subsumed)))
(str (singularise (BAnd !res_clauses)));
- let total =
- (List.filter
- (fun clause ->
- not (List.exists (fun sub -> clause=sub) !subsumed)) clauses)
- @ !res_clauses @ non_clauses in
+ let filtered =
+ List.filter
+ (fun clause ->
+ not (List.exists (fun sub -> clause=sub) !subsumed)) clauses in
+ LOG 2 "simplify: resolution: computing total";
+ let total = List.rev_append (List.rev filtered)
+ (List.rev_append (List.rev !res_clauses) non_clauses) in
singularise (neutral_absorbing (BAnd total)) in
let choose_resolvents phi =
+ LOG 2 "simplify: choose_resolvents";
(* check the resolvents for "good" ones (at the moment these are clauses
that subsume clauses in the original formula) and discard the rest *)
let rec filter_by_subsumption = function
| BOr psis ->
- let filtered_psis = List.map filter_by_subsumption psis in
+ let filtered_psis= List.rev (List.rev_map filter_by_subsumption psis) in
let neg_phi = to_nnf (BNot (BOr filtered_psis)) in
let filtered_neg_phi = filter_by_subsumption neg_phi in
to_nnf (BNot filtered_neg_phi)
@@ -491,13 +502,14 @@
LOG 3 "Useful resolvents: %s"
(String.concat ", " (List.map str useful_resolvents));
let new_clauses =
- List.map (function
+ List.rev_map (function
| BOr lits ->
BOr (List.filter (fun lit -> lit <> (lit_of_int 0)) lits)
| _ -> failwith ("trying to remove literals from a non-clause!")
) useful_resolvents in
- BAnd (new_clauses @ non_resolvents @
- (List.map filter_by_subsumption non_clauses))
+ BAnd (List.rev_append new_clauses (
+ List.rev_append (List.rev non_resolvents)
+ (List.rev (List.rev_map filter_by_subsumption non_clauses))))
| BNot psi -> BNot (filter_by_subsumption psi)
| BVar v as lit ->
if v=0 then failwith "There should not be empty resolved clauses!" else
@@ -507,7 +519,7 @@
let simp_resolution = fun phi ->
if ((!simplification lsr 2) land 1) > 0 then
choose_resolvents (subsumption (resolution phi))
- else phi in
+ else phi in
let simp_fun = fun phi ->
(simp_resolution
(neutral_absorbing
@@ -655,13 +667,17 @@
let (ids, rev_ids, free_id) = (Hashtbl.create 7, Hashtbl.create 7, ref 1) in
let boolean_phi = bool_formula_of_formula_arg phi (ids, rev_ids, free_id) in
let cnf_llist = convert boolean_phi in
+ LOG 2 "formula_to_cnf: converted";
let bool_cnf =
- BAnd (List.map (fun literals -> BOr (List.map lit_of_int literals))
- cnf_llist) in
+ BAnd (List.rev (List.rev_map (
+ fun literals -> BOr (List.rev (List.rev_map lit_of_int literals))
+ ) cnf_llist)) in
+ LOG 2 "formula_to_cnf: bool_cnf";
let simplified =
if ((!simplification lsr 1) land 1) > 0 then
simplify bool_cnf
else bool_cnf in
+ LOG 2 "formula_to_cnf: simplified";
let formula_cnf =
formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
formula_cnf
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Formula/FormulaOps.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -689,10 +689,10 @@
LOG 3 "comp. CNF: %s" (str f);
match BoolFormula.formula_to_cnf f with
| And flist ->
- LOG 3 "CNF: %s" (str (And flist));
+ LOG 2 "CNF: %s" (str (And flist));
flist
| psi ->
- LOG 3 "CNF: %s" (str psi);
+ LOG 2 "CNF: %s" (str psi);
[phi]
(* Convert an arbitrary boolean combination to DNF. *)
Modified: trunk/Toss/Formula/Sat/SatTest.ml
===================================================================
--- trunk/Toss/Formula/Sat/SatTest.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Formula/Sat/SatTest.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -69,7 +69,7 @@
[47; 5; 7; 8; 17]; [37; 5; 6; 8; 17]; [30; 5; 8; 17];
[52; 5; 6; 7; 17]; [53; 5; 6; 17]; [38; 5; 6; 7; 17];
[54; 5; 7; 17]; [55; 5; 6; 8; 9; 17]; [10; 5; 8; 9; 17];
- [48; 5; 6; 8; 9; 17]; [42; 5; 8; 9; 17];
+ [48; 5; 6; 8; 9; 17]; [42; 5; 8; 9; 17]; ] @ [
[56; 5; 6; 12; 7; 8; 9]; [57; 5; 6; 12; 7; 8];
[58; 5; 6; 12; 9]; [59; 5; 6; 12]; [44; 5; 6; 7; 8; 9];
[55; 5; 6; 8; 9]; [60; 5; 12; 7; 8; 9]; [51; 5; 12; 8; 9];
@@ -94,7 +94,7 @@
[62; 12; 7; 9]; [32; 12; 9]; [60; 12; 7; 8; 9];
[77; 12; 7; 9]; [51; 12; 8; 9]; [31; 12; 9]; [46; 7; 8; 17];
[61; 7; 17]; [10; 8; 9]; [30; 8]; [85; 9; 17]; [43; 17];
- [32; 9]; [63; 5; 6; 12; 7; 8; 9; 17];
+ [32; 9]; [63; 5; 6; 12; 7; 8; 9; 17]; ] @ [
[64; 5; 12; 7; 8; 9; 17]; [16; 5; 6; 12; 7; 8; 17];
[18; 5; 12; 7; 8; 17]; [34; 5; 6; 12; 7; 8];
[86; 5; 6; 7; 9]; [84; 5; 6; 9]; [39; 5; 6; 17];
@@ -121,7 +121,7 @@
[42; 6; 8; 17]; [110; 6; 12; 17]; [43; 6; 17]; [15; 6; 12; 8];
[111; 6; 12]; [112; 6; 12; 7; 8; 9]; [83; 6; 12; 8; 9];
[113; 6; 12; 7; 8; 9; 17]; [114; 6; 12; 8; 9; 17];
- [86; 6; 7; 8; 9]; [84; 6; 8; 9]; [44; 6; 7; 8; 9];
+ [86; 6; 7; 8; 9]; [84; 6; 8; 9]; [44; 6; 7; 8; 9]; ] @ [
[55; 6; 8; 9]; [13; 6; 12; 8]; [106; 6; 12]; [39; 6];
[112; 6; 12; 7; 9]; [86; 6; 7; 9]; [4; 12; 7; 8; 9];
[10; 12; 8; 9]; [14; 12; 7; 8]; [15; 12; 8]; [115; 12; 7];
@@ -190,7 +190,7 @@
[-79; -10; -9]; [-80; -10; -5]; [-81; -6; -10; -5; -9; -4; -8];
[-82; -14; -10; -4]; [-83; -14; -10; -5; -4; -8]; [-84; -6; -10; -8];
[-85; -6; -9; -8]; [-86; -6; -9]; [-87; -14; -4]; [-88;-14;-5;-4;-8];
- [-89; -14; -4; -8]; [-90; -14; -5; -8]; [-91; -14; -10; -9];
+ [-89; -14; -4; -8]; [-90; -14; -5; -8]; [-91; -14; -10; -9]; ] @ [
[-92; -6; -14; -10; -9; -8]; [-93; -6; -14; -9; -4; -8]; [-94; -9];
[-95; -9; -8]; [-96; -5]; [-97;-14;-10;-5;-4]; [-98;-14;-10;-5;-9;-4];
[-99; -14; -8]; [-100; -6; -10; -5; -9; -4]; [-101; -6; -10; -5; -9];
Modified: trunk/Toss/Solver/AssignmentSet.ml
===================================================================
--- trunk/Toss/Solver/AssignmentSet.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Solver/AssignmentSet.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -15,18 +15,11 @@
type assignment_set =
| Empty
| Any
- | FOUn of string * Bitvector.bitvector
| FO of string * (int * assignment_set) list
| MSO of string * ((Elems.t * Elems.t) * assignment_set) list
| Real of (Poly.polynomial * Formula.sign_op) list list
-let expand_unary = function
- | FOUn (v, bv) ->
- FO (v, List.rev_map (fun i -> (i, Any)) (Bitvector.to_rev_list bv))
- | x -> x
-
-
(* --------------------- PRINTING AND HELPER FUNCTIONS --------------------- *)
(* Variables assigned in an assignement set. *)
@@ -36,7 +29,6 @@
let rec assigned_vars acc = function
| Empty | Any -> acc
- | FOUn (v, _) -> (`FO v) :: acc
| FO (v, l) -> assigned_vars_list assigned_vars ((`FO v) :: acc) l
| MSO (v, l) -> assigned_vars_list assigned_vars ((`MSO v) :: acc) l
| _ -> failwith "AssignmentSet:assigned vars not implemented for reals"
@@ -58,7 +50,6 @@
let rec str = function
| Empty -> "{}"
| Any -> "T"
- | FOUn _ as x -> str (expand_unary x)
| FO (v, map) ->
let estr (e, a) =
if a = Any then v ^ "->" ^ (string_of_int e) else
@@ -79,7 +70,6 @@
let rec named_str struc = function
| Empty -> "{}"
| Any -> "T"
- | FOUn _ as x -> named_str struc (expand_unary x)
| FO (v, map) ->
let estr (e, a) =
if a = Any then v ^ "->" ^ (Structure.elem_str struc e) else
@@ -105,7 +95,6 @@
let rec choose_fo default = function
| Empty -> raise Not_found
| Any -> default
- | FOUn _ as x -> choose_fo default (expand_unary x)
| FO (v, []) when List.mem_assoc v default -> raise Not_found
| FO (v, (e, sub)::_) when e < 0 && List.mem_assoc v default ->
(v, List.assoc v default) :: choose_fo (List.remove_assoc v default) sub
@@ -124,7 +113,6 @@
List.rev_map Array.of_list
(Aux.product
(List.rev_map (fun _ -> Structure.Elems.elements elems) vars))
- | FOUn _ as x -> tuples elems vars (expand_unary x)
| FO (v, (e,other_aset)::asg_list) when e < 0 ->
let asg_list = List.map (fun e ->
e, try List.assoc e asg_list with Not_found -> other_aset)
@@ -155,7 +143,6 @@
let tuples = Aux.product elems in
List.map (List.combine vars) tuples
| Empty -> []
- | FOUn _ as x -> fo_assgn_to_list all_elems vars (expand_unary x)
| FO (v, (e,other_aset)::els) when e < 0 ->
let vars = Aux.list_remove (`FO v) vars in
let other_res =
Modified: trunk/Toss/Solver/AssignmentSet.mli
===================================================================
--- trunk/Toss/Solver/AssignmentSet.mli 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Solver/AssignmentSet.mli 2012-03-08 20:18:20 UTC (rev 1685)
@@ -11,15 +11,12 @@
type assignment_set =
| Empty
| Any
- | FOUn of string * Bitvector.bitvector
| FO of string * (int * assignment_set) list
| MSO of string *
((Structure.Elems.t * Structure.Elems.t) * assignment_set) list
| Real of (Poly.polynomial * Formula.sign_op) list list
-val expand_unary : assignment_set -> assignment_set
-
(** {2 Printing and small helper functions.} *)
(** Variables assigned in an assignement set. *)
Modified: trunk/Toss/Solver/Assignments.ml
===================================================================
--- trunk/Toss/Solver/Assignments.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Solver/Assignments.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -98,14 +98,6 @@
| (Empty, _) | (_, Empty) -> Empty
| (Any, a) -> a
| (a, Any) -> a
- | (FOUn (v1, bv1), FOUn (v2, bv2)) when v1 = v2 ->
- let bv = bv1 &&& bv2 in if is_empty bv then Empty else FOUn (v1, bv)
- | (FO (v1, map1), FOUn (v2, _)) when compare_vars v1 v2 < 0 ->
- fo_map v1 (join aset2) map1
- | (FOUn (v1, _), FO (v2, map2)) when compare_vars v1 v2 > 0 ->
- fo_map v2 (join aset1) map2
- | (FOUn _, _) -> join (expand_unary aset1) aset2
- | (_, FOUn _ ) -> join aset1 (expand_unary aset2)
| (FO (v1, map1), FO (v2, map2)) -> (
match compare_vars v1 v2 with
| 0 ->
@@ -163,11 +155,6 @@
(* Enforce [aset] and additionally that the FO variable [v] is set to [e]. *)
let rec set_equal uneq els v e = function
| Empty -> Empty
- | FOUn (u, b) when u = v ->
- let nb = if uneq then clear_bit b e else
- if get_bit b e then set_bit empty e else empty in
- if is_empty nb then Empty else FOUn (u, nb)
- | FOUn _ as x -> set_equal uneq els v e (expand_unary x)
| FO (u, map) as aset -> (
match compare_vars u v with
| 0 ->
@@ -193,7 +180,6 @@
(* Enforce that in [aset] the variable [u] is equal to [w]; assumes u < w. *)
let rec eq_vars uneq els u w = function
| Empty -> Empty
- | FOUn _ as x -> eq_vars uneq els u w (expand_unary x)
| FO (v, map) as aset -> (
match compare_vars v u with
| 0 ->
@@ -240,11 +226,6 @@
| (Any, _) | (_, Any) -> Any
| (Empty, a) -> a
| (a, Empty) -> a
- | (FOUn (v1, bv1), FOUn (v2, bv2)) when v1 = v2 ->
- let bv = bv1 ||| bv2 in
- if nbr_set_bits bv = sllen elems then Any else FOUn (v1, bv)
- | (FOUn _, _) -> sum elems (expand_unary aset1) aset2
- | (_, FOUn _) -> sum elems aset1 (expand_unary aset2)
| (FO (v1, map1), FO (v2, map2)) -> (
match compare_vars v1 v2 with
| 0 ->
@@ -321,7 +302,6 @@
let rec project elems v = function
| Empty -> Empty
| Any -> Any
- | FOUn (u, _) as x -> if u = v then Any else x
| FO (u, m) when u = v -> (* Sum the assignments below *)
List.fold_left (fun s (_, a) -> sum elems s a) Empty m
| FO (u, m) ->
@@ -364,8 +344,6 @@
let rec universal elems v = function
| Empty -> Empty
| Any -> Any
- | FOUn (u, b) as x ->
- if u <> v then x else if nbr_set_bits b < sllen elems then Empty else Any
| FO (u, m) when u = v -> (* Join the assignments below *)
if List.length m < sllen elems then Empty else
List.fold_left (fun s (_, a) -> join s a) Any m
@@ -412,7 +390,6 @@
let rec complement elems = function
| Empty -> Any
| Any -> Empty
- | FOUn _ as x -> complement elems (expand_unary x)
| FO (v, map) ->
let compl_map =
List.rev (complement_map_rev elems [] (slist elems, map)) in
@@ -470,8 +447,6 @@
| (Empty, _) | (_, Any) -> Empty
| (Any, a) -> complement elems a
| (a, Empty) -> a
- | (FOUn _ as x, y) -> complement_join elems (expand_unary x) y
- | (x, (FOUn _ as y)) -> complement_join elems x (expand_unary y)
| (FO (v1, map1), FO (v2, map2)) when v1 = v2 ->
let resm = List.rev (complement_join_map_rev elems [] (map1, map2)) in
if resm = [] then Empty else FO (v1, resm)
@@ -532,8 +507,6 @@
let rec join_rel aset vars tuples_set incidence_map all_elems =
match aset with (* TODO: better use of incidence map? *)
| Empty -> Empty
- | FOUn (v, _) when Aux.array_mem v vars ->
- join_rel (expand_unary aset) vars tuples_set incidence_map all_elems
| FO (v, map) when Aux.array_mem v vars ->
let tps e =
if e < Array.length incidence_map then incidence_map.(e) else
@@ -556,15 +529,8 @@
| (_, a1) :: (((_, a2) :: _) as r) when a1 = a2 -> same_asg r
| _ -> false
-let rec all_any = function
- | [] -> true
- | (_, a) :: rest when a = Any -> all_any rest
- | _ -> false
-
let rec compress no_elems = function
| FO (v, map) when List.length map = no_elems && same_asg map ->
compress no_elems (snd (List.hd map))
- | FO (v, map) when all_any map ->
- FOUn (v, Bitvector.of_list (List.rev_map fst map))
| FO (v, map) -> FO (v, map_snd (compress no_elems) map)
| x -> x
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Solver/Solver.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -136,12 +136,12 @@
if nxt = a then nxt else fixpnt v vs psi nxt in
let simp a = Assignments.compress (Assignments.sllen elems) a in
if aset = Empty then Empty else
- let foun_var = match aset with FOUn (v,_) -> v | _ -> "" in
+ let rec all_any = function
+ | [] -> true
+ | (_, a) :: rest when a = Any -> all_any rest
+ | _ -> false in
+ let foun_var = match aset with FO (v, map) when all_any map -> v | _-> "" in
match phi with
- | Rel (relname, [|v|]) ->
- let bv = Structure.pred_vector model relname in
- if Bitvector.is_empty bv then Empty else
- report (join aset (FOUn (var_str v, bv)))
| Rel (relname, vl) ->
let tuples_s = Structure.rel_graph relname model in
let inc_map = Structure.rel_incidence relname model in
@@ -170,8 +170,8 @@
| RealExpr (p, s) -> (* TODO: use aset directly as context for speed *)
report (join aset (assignment_of_real_expr fp model elems (p, s)))
| Not phi ->
- (*A intersect (complement B)=A intersect (complement(B intersect A))*)
- report (complement_join elems aset (eval fp model elems aset phi))
+ (*A intersect (complement B)=A intersect (complement(B intersect A))*)
+ report (complement_join elems aset (eval fp model elems aset phi))
| And [] -> aset
| And [phi] -> report (eval fp model elems aset phi)
| And fl -> report (List.fold_left (eval fp model elems) aset fl)
@@ -184,9 +184,9 @@
| Ex ([], phi) | All ([], phi) -> failwith "evaluating empty quantifier"
| Ex ([v], And (Rel (r1, v1):: Rel (r2, v2):: rest)) as ephi when
foun_var <> "" && ( let vfo = to_fo v in (* an often occurring join *)
- (v1 = [|vfo|] && v2 = [|vfo; `FO foun_var|]) ||
- (v1 = [|vfo|] && v2 = [|`FO foun_var; vfo|]) ||
- (v2 = [|vfo|] && v1 = [|vfo; `FO foun_var|]) ||
+ (v1 = [|vfo|] && v2 = [|vfo; `FO foun_var|]) || (* it isn't needed*)
+ (v1 = [|vfo|] && v2 = [|`FO foun_var; vfo|]) || (* but helps to *)
+ (v2 = [|vfo|] && v1 = [|vfo; `FO foun_var|]) || (* optimize here*)
(v2 = [|vfo|] && v1 = [|`FO foun_var; vfo|]) ) &&
not (List.mem (`FO foun_var) (FormulaSubst.free_vars (And rest)))->(
LOG 1 "special join on %s for %s" foun_var (str ephi);
@@ -194,15 +194,21 @@
if Array.length v1= 1 then r1, r2, v1, v2 else r2, r1, v2, v1 in
let othpos = if vpred.(0) = vbin.(0) then 0 else 1 in
let inc_map = Structure.rel_incidence rbin model in
- let av = match aset with FOUn (_, av) -> av | _-> failwith "av" in
- let add_to_bitvec b e =
- if e >= Array.length inc_map then b else
- Tuples.fold (fun t b -> set_bit b t.(othpos)) inc_map.(e) b in
- let b0 = List.fold_left add_to_bitvec Bitvector.empty
- (Bitvector.to_rev_list av) in
- let b = b0 &&& (Structure.pred_vector model pred) in
- if Bitvector.is_empty b then Empty else
- let r = eval fp model elems (FOUn (var_str v, b)) (And rest) in
+ let pred_map = Structure.rel_incidence pred model in
+ let is_in_pred e =
+ if e >= Array.length pred_map then false else
+ not (Tuples.is_empty pred_map.(e)) in
+ let am = match aset with FO (_, am) -> am | _ -> failwith "am" in
+ let add_to_map map (e, _) =
+ if e >= Array.length inc_map then map else
+ Tuples.fold (fun t m ->
+ if is_in_pred t.(othpos) then t.(othpos) :: m else m
+ ) inc_map.(e) map in
+ let newels = List.fold_left add_to_map [] am in
+ if newels = [] then Empty else
+ let newm = List.map (fun e -> (e, Any))
+ (Aux.unique_sorted newels) in
+ let r = eval fp model elems (FO (var_str v, newm)) (And rest) in
if r = Empty then Empty else
let ag = eval fp model elems r (Rel (rbin, vbin)) in
report (simp (join aset (project_list elems ag [var_str v])))
@@ -273,7 +279,7 @@
remove_dup_vars [] (List.sort compare_vars (fo_vars_r_rec re)) in
let rec sum_polys = function
| Empty -> Poly.Const 0.
- | Any | FOUn _ -> failwith "absolute assignement for sum,impossible to calc"
+ | Any -> failwith "absolute assignement for sum,impossible to calc"
| FO (_, alist) ->
let addp p (_, a) = Poly.Plus (p, sum_polys a) in
List.fold_left addp (Poly.Const 0.) alist
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-03-08 01:17:02 UTC (rev 1684)
+++ trunk/Toss/Solver/Structure.ml 2012-03-08 20:18:20 UTC (rev 1685)
@@ -50,8 +50,7 @@
type structure = {
rel_signature : int StringMap.t ;
elements : Elems.t ;
- predicates : Bitvector.bitvector StringMap.t ; (* unary relations *)
- relations : Tuples.t StringMap.t ; (* binary (or more-ary) relations *)
+ relations : Tuples.t StringMap.t ;
functions : (float IntMap.t) StringMap.t ;
incidence : (TIntMap.t) StringMap.t ;
names : int StringMap.t ;
@@ -63,14 +62,12 @@
let compare s1 s2 =
if s1 == s2 then 0 else
- let c = Elems.compare s1.elements s2.elements in
+ let c = StringMap.compare Tuples.compare s1.relations s2.relations in
if c <> 0 then c else
- let d = StringMap.compare Tuples.compare s1.relations s2.relations in
+ let d = Elems.compare s1.elements s2.elements in
if d <> 0 then d else
- let e = StringMap.compare Pervasives.compare s1.predicates s2.predicates
- in if e <> 0 then e else
- StringMap.compare (IntMap.compare Pervasives.compare)
- s1.functions s2.functions
+ StringMap.compare (IntMap.compare Pervasives.compare)
+ s1.functions s2.functions
let equal s1 s2 = (compare s1 s2 = 0)
@@ -83,21 +80,15 @@
let inv_names s = s.inv_names
let replace_names s nms inms = { s with names = nms; inv_names = inms }
let functions s = s.functions
-let tuples_of_bitvec b =
- let append_sg tps e = Tuples.add [|e|] tps in
- List.fold_left append_sg Tuples.empty (Bitvector.to_rev_list b)
-let relations s = StringMap.fold (fun pred bv acc ->
- StringMap.add pred (tuples_of_bitvec bv) acc) s.predicates s.relations
+let relations s = s.relations
-
(* ----------------------- BASIC HELPER FUNCTIONS --------------------------- *)
(* Number of tuples in a relation. *)
let rel_size struc rel =
- try Tuples....
[truncated message content] |
|
From: <luk...@us...> - 2012-03-09 12:06:07
|
Revision: 1686
http://toss.svn.sourceforge.net/toss/?rev=1686&view=rev
Author: lukaszkaiser
Date: 2012-03-09 12:05:53 +0000 (Fri, 09 Mar 2012)
Log Message:
-----------
Optimize JS interface, allow suggest from TossServer. Merge GameSelection into JsHandler and ReqHander into Server, clean up accordingly.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Main.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/Heuristic.mli
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/examples/Breakthrough.toss
trunk/Toss/examples/Checkers.toss
trunk/Toss/examples/Chess.toss
trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss
trunk/Toss/examples/Connect4.toss
trunk/Toss/examples/Gomoku.toss
trunk/Toss/examples/Gomoku19x19.toss
trunk/Toss/examples/Pawn-Whopping.toss
trunk/Toss/examples/Tic-Tac-Toe.toss
Removed Paths:
-------------
trunk/Toss/Client/Connect.js
trunk/Toss/Client/GameSelection.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/examples/Breakthrough.tossstyle
trunk/Toss/examples/Checkers.tossstyle
trunk/Toss/examples/Chess.tossstyle
trunk/Toss/examples/Connect4.tossstyle
trunk/Toss/examples/Gomoku.tossstyle
trunk/Toss/examples/Pawn-Whopping.tossstyle
trunk/Toss/examples/Tic-Tac-Toe.tossstyle
trunk/Toss/examples/bishop_black.svg
trunk/Toss/examples/bishop_white.svg
trunk/Toss/examples/bluecircle.svg
trunk/Toss/examples/cross.svg
trunk/Toss/examples/greencircle.svg
trunk/Toss/examples/king_black.svg
trunk/Toss/examples/king_white.svg
trunk/Toss/examples/knight_black.svg
trunk/Toss/examples/knight_white.svg
trunk/Toss/examples/pawn_black.svg
trunk/Toss/examples/pawn_white.svg
trunk/Toss/examples/queen_black.svg
trunk/Toss/examples/queen_white.svg
trunk/Toss/examples/rook_black.svg
trunk/Toss/examples/rook_white.svg
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-08 20:18:20 UTC (rev 1685)
+++ trunk/Toss/Arena/Arena.ml 2012-03-09 12:05:53 UTC (rev 1686)
@@ -549,100 +549,6 @@
with Diff_result expl -> false, expl
-(* ------------------ REQUESTS TO THE ARENA USED IN OPERATION --------------- *)
-
-(* Location of a structure: either arena or left or right-hand side of a rule *)
-type struct_loc = Struct | Left of string | Right of string
-
-(* Requests which we handle. *)
-type request =
- | SuggestLocMoves of int * int * int * string * int option *
- (string * Formula.real_expr) list array option * float option
-
-
-(* --------------------------- REQUEST HANDLER ------------------------------ *)
-
-(* Apply function [f] to named structure at location [loc] in [state].
- Include what [f] returns - changed named structure and string - and return.*)
-let apply_to_loc f loc (state_game, state) err_msg =
- match loc with
- Struct ->
- let (new_struc, msg) = f state.struc in
- ((state_game, { state with struc = new_struc }), msg)
- | Left rn -> (
- try
- let r = (List.assoc rn state_game.rules) in
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let new_r =
- ContinuousRule.apply_to_side true f signat defs r in
- let new_rules = Aux.replace_assoc rn new_r state_game.rules in
- (({state_game with rules=new_rules}, state), "")
- with Not_found ->
- ((state_game, state),
- "ERR [Not found] on left location of " ^ rn ^", " ^ err_msg)
- )
- | Right rn ->
- try
- let r = (List.assoc rn state_game.rules) in
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let new_r =
- ContinuousRule.apply_to_side false f signat defs r in
- let new_rules = Aux.replace_assoc rn new_r state_game.rules in
- (({state_game with rules=new_rules}, state), "")
- with Not_found ->
- ((state_game, state),
- "ERR [Not found] on right location of "^rn^", " ^ err_msg)
-
-(* Retrieve value of [f] from structure at location [loc] in [state]. *)
-let get_from_loc f loc (state_game, state) err_msg =
- match loc with
- Struct -> f state.struc
- | Left r_name -> (
- try
- let r = (List.assoc r_name state_game.rules) in
- (match r.ContinuousRule.discrete.DiscreteRule.struc_rule
- with
- | None -> raise Not_found
- | Some r -> f r.DiscreteRule.lhs_struc)
- with Not_found ->
- "ERR [Not found] getting from left location of " ^
- r_name ^ ", " ^ err_msg
- )
- | Right r_name ->
- try
- let r = (List.assoc r_name state_game.rules) in
- (match r.ContinuousRule.discrete.DiscreteRule.struc_rule
- with
- | None -> raise Not_found
- | Some r -> f r.DiscreteRule.rhs_struc)
- with Not_found ->
- "ERR [Not found] getting from right location of " ^
- r_name ^ ", " ^ err_msg
-
-(* Apply function [f] to named rule [r_name] in [state], insert and return. *)
-let apply_to_rule f r_name (state_game, state) err_msg =
- try
- let r = List.assoc r_name state_game.rules in
- let (nr, msg) = f r in
- let new_rules = Aux.replace_assoc r_name nr state_game.rules in
- (({state_game with rules=new_rules}, state), msg)
- with Not_found ->
- ((state_game, state),
- "ERR [Not found] applying to rule " ^ r_name ^ ": " ^ err_msg)
-
-(* Retrieve value of [f] from rule [r] in [state]. *)
-let get_from_rule f r state_game err =
- try f (List.assoc r state_game.rules)
- with Not_found ->
- "ERR [Not found] getting from rule " ^ r ^ ": " ^ err
-
-(* Print relational signature. *)
-let sig_str state =
- Structure.sig_str state.struc
-
-
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-03-08 20:18:20 UTC (rev 1685)
+++ trunk/Toss/Arena/Arena.mli 2012-03-09 12:05:53 UTC (rev 1686)
@@ -161,24 +161,6 @@
game * game_state -> game * game_state -> bool * string
-(** {2 Requests to the Arena used in Operation} *)
-
-(** Location of a structure: either arena or left or right-hand side of a rule *)
-type struct_loc = Struct | Left of string | Right of string
-
-(** Requests which we handle. *)
-type request =
- | SuggestLocMoves of int * int * int * string * int option *
- (string * Formula.real_expr) list array option * float option
- (** Suggested moves at loc, with timeout in so many seconds, for so
- much computational effort if possible before timeout, using given
- search method ("maximax", "alpha_beta", "alpha_beta_ord",
- "uct_random_playouts",
- "uct_greedy_playouts", "uct_maximax_playouts",
- "uct_no_playouts"), with optional horizon for playouts, with
- location-dependent heuristics, with advancement ratio for
- generating heuristics if they're not given *)
-
val apply_rule_int : game * game_state ->
string * (string * int) list * float * (string * float) list ->
(game * game_state) * string
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-03-08 20:18:20 UTC (rev 1685)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-03-09 12:05:53 UTC (rev 1686)
@@ -9,8 +9,7 @@
%}
-%start parse_game_defs parse_game_state parse_request
-%type <Arena.request> parse_request request
+%start parse_game_defs parse_game_state
%type <Arena.struct_loc> struct_location
%type <(string * int) list -> int * Arena.player_loc array> location
%type <Arena.definition> parse_game_defs
@@ -161,33 +160,9 @@
| RULE_SPEC id_int LEFT_SPEC { Arena.Left ($2) }
| RULE_SPEC id_int RIGHT_SPEC { Arena.Right ($2) }
-request:
- | EVAL_CMD LOC_MOD MOVES
- heur_adv_ratio=FLOAT loc=INT
- TIMEOUT_MOD timer=INT effort=INT algo=ID horizon=INT?
- {let heuristic = None in
- SuggestLocMoves (loc, timer, effort, algo, horizon, heuristic,
- Some heur_adv_ratio) }
- | EVAL_CMD LOC_MOD MOVES
- heuristic = delimited (
- OPENSQ,
- separated_nonempty_list(SEMICOLON,
- delimited(OPENCUR, separated_list (
- SEMICOLON, separated_pair (id_int, COLON, real_expr_err)
- ), CLOSECUR)), CLOSESQ)
- loc=INT
- TIMEOUT_MOD timer=INT effort=INT algo=ID horizon=INT?
- {let heur_adv_ratio = None in
- SuggestLocMoves (loc, timer, effort, algo, horizon,
- Some (Array.of_list heuristic), heur_adv_ratio) }
- | error
- { raise (Lexer.Parsing_error "Syntax error in Server request.") }
-
parse_game_defs:
game_defs EOF { $1 };
parse_game_state:
game_state EOF { $1 };
-parse_request:
- request EOF { $1 };
Deleted: trunk/Toss/Client/Connect.js
===================================================================
--- trunk/Toss/Client/Connect.js 2012-03-08 20:18:20 UTC (rev 1685)
+++ trunk/Toss/Client/Connect.js 2012-03-09 12:05:53 UTC (rev 1686)
@@ -1,166 +0,0 @@
-// JavaScript Toss Module -- Connect (basic Toss Server connection routines)
-
-var ASYNC_ALL_REQ_PENDING = 0;
-var ASYNC_CMD_REQ_PENDING = {};
-
-
-// Strip [c1] and [c2] from beginning and end of [str].
-function strip (c1, c2, str) {
- if (str.length == 0) return (str);
- var i = 0; var j = 0;
- for (i = 0; i < str.length; i++) {
- if (str.charAt(i) != c1 && str.charAt(i) != c2) break;
- }
- for (j = str.length - 1; j > -1; j--) {
- if (str.charAt(j) != c1 && str.charAt(j) != c2) break;
- }
- if (i > j) { return ("") };
- return (str.substring(i, j+1));
-}
-
-// Convert a string [str] representing python list to array and return it.
-// WARNING: we use [sep] as separator, it must not occur in list elements!
-function parse_list (sep, str_in) {
- var res_arr = [];
- var str = strip(' ', '\n', str_in);
- res_arr = strip('[', ']', str).split(sep);
- if (res_arr.length == 1 && res_arr[0] == "") { return ([]); }
- for (i = 0; i < res_arr.length; i++) {
- res_arr[i] = strip (' ', '\'', res_arr[i])
- }
- return (res_arr);
-}
-
-function Connect () {
- // Send [msg] to server and return response text.
- var sync_server_msg = function (msg) {
- var xml_request = new XMLHttpRequest ();
- xml_request.open ('POST', 'Handler', false);
- xml_request.setRequestHeader
- ('Content-Type', 'application/x-www-form-urlencoded; charset=UTF-8');
- xml_request.send (msg);
- resp = xml_request.responseText;
- if (resp.indexOf ("MOD_PYTHON ERROR") > -1) {
- alert (resp.substring(resp.indexOf("Traceback")));
- return ("");
- }
- return (resp)
- }
-
- this.s = sync_server_msg;//Just a copy of above for public usage
-
- // Send [msg] to server asynchronously, ignore response text.
- var async_server_msg = function (msg, count, f) {
- var xml_request = new XMLHttpRequest ();
- xml_request.open ('POST', 'Handler', true);
- xml_request.setRequestHeader (
- 'Content-Type', 'application/x-www-form-urlencoded; charset=UTF-8');
- if (count) {
- xml_request.onreadystatechange = function () {
- if (xml_request.readyState == 4) {
- ASYNC_ALL_REQ_PENDING -= 1;
- resp = xml_request.responseText;
- if (resp.indexOf ("MOD_PYTHON ERROR") > -1) {
- alert (resp.substring(resp.indexOf("Traceback")));
- } else { f(resp) };
- }
- }
- } else {
- xml_request.onreadystatechange = function () {
- if (xml_request.readyState == 4) {
- resp = xml_request.responseText;
- if (resp.indexOf ("MOD_PYTHON ERROR") > -1) {
- alert (resp.substring(resp.indexOf("Traceback")));
- } else { f(resp) };
- }
- }
- };
- if (count) { ASYNC_ALL_REQ_PENDING += 1; }
- xml_request.send (msg);
- }
-
- // Send [msg] to server attaching prefix '[cmd]#' and return response text.
- var srv = function (cmd, msg) {
- return (sync_server_msg (cmd + '#' + msg));
- }
-
- // Send [msg] to server attaching prefix '[cmd]#' async., ignore response.
- var async_srv_ignore = function (cmd, msg) {
- async_server_msg (cmd + '#' + msg, false, function(x) { });
- }
-
- // Send [msg] to server attaching prefix '[cmd]#' async., run f on return.
- var async_srv = function (cmd, msg, f) {
- if (ASYNC_CMD_REQ_PENDING[cmd]) {
- ASYNC_CMD_REQ_PENDING[cmd] += 1;
- } else { ASYNC_CMD_REQ_PENDING[cmd] = 1; };
- var fm = function (m) {
- ASYNC_CMD_REQ_PENDING[cmd] -= 1;
- f ();
- };
- async_server_msg (cmd + '#' + msg, true, f);
- }
-
- this.get_name = function (uname) { return (srv ("GET_NAME", uname)); }
-
- this.list_plays = function (game, uname) {
- if (uname == "guest") { return ("[]"); }
- return (srv ("LIST_PLAYS", game + ", " + uname));
- }
-
- this.open_db = function (pid) { return (srv ("OPEN_DB", pid)); }
- this.prev_move = function (pid, mv) {
- return (srv ("PREV_MOVE", pid + ", " + mv));
- }
- this.new_play = function (g, un, opp) {
- return (srv ("NEW_PLAY", g + ", " + un + ", " + opp));
- }
- this.make_move = function (move_s, pid, cont) {
- async_srv("MOVE_PLAY", move_s + ', ' + pid, cont);
- }
- this.suggest = function (player, time, pid, cont) {
- async_srv("SUGGEST", player + ', ' + time + ', ' + pid, cont);
- }
-
- this.friends = function () { return (srv ("LIST_FRIENDS", "user")); }
- this.search_users = function (txt) { return (srv ("SEARCHUSR", txt)); }
- this.plays = function () { return (srv("USERPLAYS", "user")); }
- this.username = function () { return (srv("USERNAME", "user")); }
- this.addopp = function (opp) { return (srv("ADDOPP", opp)); }
-
- this.name = function (un) { return (srv("GET_NAME", un)); }
- this.surname = function (un) { return (srv("GET_SURNAME", un)); }
- this.email = function (un) { return (srv("GET_MAIL", un)); }
-
- this.login = function (un, chk, cpwd) {
- return (srv ("LOGIN", un +"$"+ chk +"$"+ cpwd));
- }
- this.logout = function () { return (srv("LOGOUT", "user")); }
- this.register = function (data, cpwd) {
- return (srv ("REGISTER", data + "$" + cpwd));
- }
- this.invite = function (mail) { return (srv("INVITE", mail)); }
- this.forgotpwd = function (mail) { return (srv("FORGOTPWD", mail)); }
- this.change_pwd = function (un, pwd) {
- var resp = srv("CHANGEPWD", pwd);
- if (resp == "OK") {
- this.logout ();
- this.login (un, true, pwd);
- return ("Password changed successfully");
- } else { return (resp); }
- }
- this.change_data = function (name, surname, email) {
- return (srv ("CHANGEUSR", name +"$"+ surname +"$"+ email));
- }
- this.learn_game = function (game, plays) {
- return (srv ("LEARNGAME", game + ", " + plays));
- }
- this.get_game = function (game) { return (srv("GETGAME", game)); }
- this.set_game = function (game, toss) {
- return (srv("SETGAME", game + " $_$ " + toss));
- }
-
- return (this);
-}
-
-var CONN = new Connect ();
Deleted: trunk/Toss/Client/GameSelection.ml
===================================================================
--- trunk/Toss/Client/GameSelection.ml 2012-03-08 20:18:20 UTC (rev 1685)
+++ trunk/Toss/Client/GameSelection.ml 2012-03-09 12:05:53 UTC (rev 1686)
@@ -1,1065 +0,0 @@
-(* 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 *)
- playclock : int; (** playclock *)
- game_str : string; (** game representation *)
-}
-
-let compute_heuristic advr (game, state) =
- let pat_arr = Array.of_list game.Arena.patterns in
- let pl_heur l =
- let len = List.length l.Arena.heur in
- if len = 0 || len > Array.length pat_arr then raise Not_found else
- let add_pat (i, h) pw =
- let pat = Formula.Times (Formula.Const pw, pat_arr.(i)) in
- (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
- res
- with Not_found ->
- Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
-
-let compile_game_data game_name game_str =
- let (game, game_state as game_with_state) =
- ArenaParser.parse_game_state Lexer.lex (Lexing.from_string game_str) in
- let adv_ratio =
- try Some (float_of_string (List.assoc "adv_ratio" game.Arena.data))
- with Not_found -> None in
- let heuristic = compute_heuristic adv_ratio game_with_state in
- game_name,
- {heuristic = heuristic;
- game_state = game_with_state;
- playclock = 30; (* game clock from where? *)
- game_str = game_str;
- }
-
-
-let chess_str = ("
-PLAYERS 1, 2
-DATA depth: 0, adv_ratio: 1
-SET Sum (x | wP(x) : 1)
-SET Sum (x | wR(x) : 1)
-SET Sum (x | wN(x) : 1)
-SET Sum (x | wB(x) : 1)
-SET Sum (x | wQ(x) : 1)
-SET Sum (x | bP(x) : 1)
-SET Sum (x | bR(x) : 1)
-SET Sum (x | bN(x) : 1)
-SET Sum (x | bB(x) : 1)
-SET Sum (x | bQ(x) : 1)
-SET Sum (x | wBeats(x) : 1 + :(b(x)) + 3 * :(bK(x)))
-SET Sum (x | bBeats(x) : 1 + :(w(x)) + 3 * :(wK(x)))
-REL w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x)
-REL b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x)
-REL DoubleC(x, y) = ex z ((C(x, z) and C(z, y)) or (C(y, z) and C(z, x)))
-REL DoubleR(x, y) = ex z ((R(x, z) and R(z, y)) or (R(y, z) and R(z, x)))
-REL KnightRCC(x, y) = ex z ((R(x, z) or R(z, x)) and DoubleC(z, y))
-REL KnightCRR(x, y) = ex z ((C(x, z) or C(z, x)) and DoubleR(z, y))
-REL Knight(x, y) = KnightRCC(x, y) or KnightCRR(x, y)
-REL FreeD1 (x, y) = tc x, y (D1 (x, y) and not w(y) and not b(y))
-REL FreeD2 (x, y) = tc x, y (D2 (x, y) and not w(y) and not b(y))
-REL Diag1 (x, y) = ex z (FreeD1 (x, z) and (z = y or D1 (z, y)))
-REL Diag2 (x, y) = ex z (FreeD2 (x, z) and (z = y or D2 (z, y)))
-REL Diag (x, y) = Diag1 (x, y) or Diag2 (x, y)
-REL FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not b(y))
-REL FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not b(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 Near (x, y) = C(x,y) or C(y,x) or R(x,y) or R(y,x) or D1(x, y) or D2(x, y)
-REL wPBeats (x) = ex y (wP(y) and ex z ((R(y, z) or R(z, y)) and C(z, x)))
-REL bPBeats (x) = ex y (bP(y) and ex z ((R(y, z) or R(z, y)) and C(x, z)))
-REL wDiagBeats (x) = ex y ((wQ(y) or wB(y)) and Diag(y, x))
-REL bDiagBeats (x) = ex y ((bQ(y) or bB(y)) and Diag(y, x))
-REL wLineBeats (x) = ex y ((wQ(y) or wR(y)) and Line(y, x))
-REL bLineBeats (x) = ex y ((bQ(y) or bR(y)) and Line(y, x))
-REL wFigBeats(x) = wDiagBeats(x) or wLineBeats(x) or ex y(wN(y) and Knight(y,x))
-REL bFigBeats(x) = bDiagBeats(x) or bLineBeats(x) or ex y(bN(y) and Knight(y,x))
-REL wBeats(x) = wFigBeats(x) or wPBeats(x) or ex y (wK(y) and Near(y, x))
-REL bBeats(x) = bFigBeats(x) or bPBeats(x) or ex y (bK(y) and Near(y, x))
-REL CheckW() = ex x (wK(x) and bBeats(x))
-REL CheckB() = ex x (bK(x) and wBeats(x))
-RULE WhitePawnMove:
- [ | | ] \"
- ...
- ...
-
- wP
-\" -> [ | | ] \"
- ...
- wP
-
- .
-\" emb w, b pre not IsEight(a2) post not CheckW()
-RULE BlackPawnMove:
- [ | | ] \"
- ...
- bP.
-
- .
-\" -> [ | | ] \"
- ...
- ...
-
- bP
-\" emb w, b pre not IsFirst(a1) post not CheckB()
-RULE WhitePawnMoveDbl:
- [ | | ] \"
-
- .
- ...
- ...
-
- wP
-\" -> [ | | ] \"
- ...
- wP
-
- .
- ...
- ...
-\" emb w, b pre IsSecond(a1) post not CheckW()
-RULE BlackPawnMoveDbl:
- [ | | ] \"
- ...
- bP.
-
- .
- ...
- ...
-\" -> [ | | ] \"
-
-
- ...
- ...
-
- bP
-\" emb w, b pre IsSeventh(a3) post not CheckB()
-RULE WhitePawnBeat:
- [ a, b | wP { a }; b { b } | - ]
- ->
- [ a, b | wP { b } | - ]
- emb w, b
- pre not IsEight(b) and ex z (C(a, z) and (R(z, b) or R(b, z)))
- post not CheckW()
-RULE WhitePawnBeatPromote:
- [ a, b | wP { a }; b { b } | - ]
- ->
- [ a, b | wQ { b } | - ]
- emb w, b
- pre IsEight(b) and ex z (C(a, z) and (R(z, b) or R(b, z)))
- post not CheckW()
-RULE WhitePawnBeatRDbl:
- [ | | ] \"
- ...
- ?..-bP
- ...
- ? ...
- ...
- wP.bP
-\" -> [ | | ] \"
- ...
- ?...
- ...
- ? wP.
- ...
- ....
-\" emb w, b post not CheckW()
-RULE WhitePawnBeatLDbl:
- [ | | ] \"
- ...
- -bP?
- ...
- . ?..
- ...
- bP.wP
-\" -> [ | | ] \"
- ...
- ...?
- ...
- wP ?..
- ...
- ....
-\" emb w, b post not CheckW()
-RULE BlackPawnBeat:
- [ a, b | bP { a }; w { b } | - ]
- ->
- [ a, b | bP { b } | - ]
- emb w, b
- pre not IsFirst(b) and ex z (C(z, a) and (R(z, b) or R(b, z)))
- post not CheckB()
-RULE BlackPawnBeatPromote:
- [ a, b | bP { a }; w { b } | - ]
- ->
- [ a, b | bQ { b } | - ]
- emb w, b
- pre IsFirst(b) and ex z (C(z, a) and (R(z, b) or R(b, z)))
- post not CheckB()
-RULE BlackPawnBeatRDbl:
- [ | | ] \"
- ...
- bP.wP
- ...
- ? ...
- ...
- ?..-wP
-\" -> [ | | ] \"
- ...
- ....
- ...
- ? bP.
- ...
- ?...
-\" emb w, b post not CheckB()
-RULE BlackPawnBeatLDbl:
- [ | | ] \"
- ...
- wP.bP
- ...
- . ?..
- ...
- -wP?
-\" -> [ | | ] \"
- ...
- ....
- ...
- bP ?..
- ...
- ...?
-\" emb w, b post not CheckB()
-RULE WhitePawnPromote:
- [ | | ] \"
- ...
- ...
-
- wP
-\" -> [ | | ] \"
- ...
- wQ.
-
- .
-\" emb w, b pre IsEight(a2) post not CheckW()
-RULE BlackPawnPromote:
- [ | | ] \"
- ...
- bP.
-
- .
-\" -> [ | | ] \"
- ...
- ...
-
- bQ
-\" emb w, b pre IsFirst(a1) post not CheckB()
-RULE WhiteKnight:
- [ a, b | wN { a }; _opt_b { b } | - ]
- ->
- [ a, b | wN { b } | - ]
- emb w, b pre Knight(a, b) post not CheckW()
-RULE BlackKnight:
- [ a, b | bN { a }; _opt_w { b } | - ]
- ->
- [ a, b | bN { b } | - ]
- emb w, b pre Knight(a, b) post not CheckB()
-RULE WhiteBishop:
- [ a, b | wB { a }; _opt_b { b } | - ]
- ->
- [ a, b | wB { b } | - ]
- emb w, b pre Diag(a, b) post not CheckW()
-RULE BlackBishop:
- [ a, b | bB { a }; _opt_w { b } | - ]
- ->
- [ a, b | bB { b } | - ]
- emb w, b pre Diag(a, b) post not CheckB()
-RULE WhiteRook:
- [ a, b | wR { a }; _opt_b { b } | - ]
- ->
- [ a, b | wR { b } | - ]
- emb w, b pre not IsA1(a) and not IsH1(a) and Line(a, b) post not CheckW()
-RULE WhiteRookA1:
- [ a, b | wR { a }; _opt_b { b } | - ]
- ->
- [ a, b | wR { b } | - ]
- emb w, b pre IsA1(a) and Line(a, b) post not CheckW()
-RULE WhiteRookH1:
- [ a, b | wR { a }; _opt_b { b } | - ]
- ->
- [ a, b | wR { b } | - ]
- emb w, b pre IsH1(a) and Line(a, b) post not CheckW()
-RULE BlackRook:
- [ a, b | bR { a }; _opt_w { b } | - ]
- ->
- [ a, b | bR { b } | - ]
- emb w, b pre not IsA8(a) and not IsH8(a) and Line(a, b) post not CheckB()
-RULE BlackRookA8:
- [ a, b | bR { a }; _opt_w { b } | - ]
- ->
- [ a, b | bR { b } | - ]
- emb w, b pre IsA8(a) and Line(a, b) post not CheckB()
-RULE BlackRookH8:
- [ a, b | bR { a }; _opt_w { b } | - ]
- ->
- [ a, b | bR { b } | - ]
- emb w, b pre IsH8(a) and Line(a, b) post not CheckB()
-RULE WhiteQueen:
- [ a, b | wQ { a }; _opt_b { b } | - ]
- ->
- [ a, b | wQ { b } | - ]
- emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW()
-RULE BlackQueen:
- [ a, b | bQ { a }; _opt_w { b } | - ]
- ->
- [ a, b | bQ { b } | - ]
- emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB()
-RULE WhiteKing:
- [ a, b | wK { a }; _opt_b { b } | - ]
- ->
- [ a, b | wK { b } | - ]
- emb w, b pre Near(a, b) post not CheckW()
-RULE BlackKing:
- [ a, b | bK { a }; _opt_w { b } | - ]
- ->
- [ a, b | bK { b } | - ]
- emb w, b pre Near(a, b) post not CheckB()
-RULE WhiteLeftCastle:
- [ | | ] \"
- ... ... ...
- wR. ... wK.
-\" -> [ | | ] \"
- ... ... ...
- ... wK.wR ...
-\" emb w,b pre not(bBeats(c1) or bBeats(d1) or bBeats(e1)) and before
- not WhiteRookA1, not WhiteKing, not WhiteLeftCastle, not WhiteRightCastle
-RULE WhiteRightCastle:
- [ | | ] \"
- ... ...
- wK. ...wR
-\" -> [ | | ] \"
- ... ...
- ...wR wK.
-\" emb w,b pre not (bBeats(a1) or bBeats(b1) or bBeats(c1)) and before
- not WhiteRookH1, not WhiteKing, not WhiteLeftCastle, not WhiteRightCastle
-RULE BlackLeftCastle:
- [ | | ] \"
- ... ... ...
- bR. ... bK.
-\" -> [ | | ] \"
- ... ... ...
- ... bK.bR ...
-\" emb w,b pre not(wBeats(c1) or wBeats(d1) or wBeats(e1)) and before
- not BlackRookA8, not BlackKing, not BlackLeftCastle, not BlackRightCastle
-RULE BlackRightCastle:
- [ | | ] \"
- ... ...
- bK. ...bR
-\" -> [ | | ] \"
- ... ...
- ...bR bK.
-\" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) and before
- not BlackRookH8, not BlackKing, not BlackLeftCastle, not BlackRightCastle
-LOC 0 {
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- MOVES
- [WhitePawnMove -> 1];
- [WhitePawnMoveDbl -> 1];
- [WhitePawnBeat -> 1];
- [WhitePawnBeatPromote -> 1];
- [WhitePawnBeatLDbl -> 1];
- [WhitePawnBeatRDbl -> 1];
- [WhitePawnPromote -> 1];
- [WhiteKnight -> 1];
- [WhiteBishop -> 1];
- [WhiteRook -> 1];
- [WhiteRookA1 -> 1];
- [WhiteRookH1 -> 1];
- [WhiteQueen -> 1];
- [WhiteLeftCastle -> 1];
- [WhiteRightCastle -> 1];
- [WhiteKing -> 1]
- }
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- }
-}
-LOC 1 {
- PLAYER 2 {
- COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9; -0.05; 0.05
- PAYOFF :(CheckW()) - :(CheckB())
- MOVES
- [BlackPawnMove -> 0];
- [BlackPawnMoveDbl -> 0];
- [BlackPawnBeat -> 0];
- [BlackPawnBeatPromote -> 0];
- [BlackPawnBeatLDbl -> 0];
- [BlackPawnBeatRDbl -> 0];
- [BlackPawnPromote -> 0];
- [BlackKnight -> 0];
- [BlackBishop -> 0];
- [BlackRook -> 0];
- [BlackRookA8 -> 0];
- [BlackRookH8 -> 0];
- [BlackQueen -> 0];
- [BlackLeftCastle -> 0];
- [BlackRightCastle -> 0];
- [BlackKing -> 0]
- }
- PLAYER 1 {
- COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9; 0.05; -0.05
- PAYOFF :(CheckB()) - :(CheckW())
- }
-}
-MODEL [ | | ] \"
- ... ... ... ...
- bR bN.bB bQ.bK bB.bN bR.
- ... ... ... ...
- bP.bP bP.bP bP.bP bP.bP
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- wP wP.wP wP.wP wP.wP wP.
- ... ... ... ...
- wR.wN wB.wQ wK.wB wN.wR
-\" with
-D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
-D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) ) ;
-IsFirst(x) = not ex z C(z, x) ;
-IsSecond(x) = ex y (C(y, x) and IsFirst(y)) ;
-IsEight(x) = not ex z C(x, z) ;
-IsSeventh(x) = ex y (C(x, y) and IsEight(y)) ;
-IsA1(x) = not ex z R(z, x) and IsFirst(x) ;
-IsH1(x) = not ex z R(x, z) and IsFirst(x) ;
-IsA8(x) = not ex z R(z, x) and IsEight(x) ;
-IsH8(x) = not ex z R(x, z) and IsEight(x)
-")
-
-let connect4_str = ("PLAYERS 1, 2
-DATA r1: circle, r2: line, adv_ratio: 4, depth: 6
-REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v)
-REL Col4 (x, y, z, v) = C(x, y) and C(y, z) and C(z, v)
-REL DiagA4 (x, y, z, v) = DiagA(x, y) and DiagA(y, z) and DiagA(z, v)
-REL DiagB4 (x, y, z, v) = DiagB(x, y) and DiagB(y, z) and DiagB(z, v)
-REL Conn4 (x, y, z, v) =
- Row4(x,y,z,v) or Col4(x,y,z,v) or DiagA4(x,y,z,v) or DiagB4(x,y,z,v)
-REL WinQ() =
- ex x,y,z,v (Q(x) and Q(y) and Q(z) and Q(v) and Conn4(x, y, z, v))
-REL WinP() =
- ex x,y,z,v (P(x) and P(y) and P(z) and P(v) and Conn4(x, y, z, v))
-REL EmptyUnder (x) = ex y (C(y, x) and not P(y) and not Q(y))
-RULE Cross:
- [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P
- pre not EmptyUnder (a) and not WinQ()
-RULE Circle:
- [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P
- pre not EmptyUnder (a) and not WinP()
-LOC 0 {
- PLAYER 1 {
- PAYOFF :(WinP()) - :(WinQ())
- MOVES [Cross -> 1]
- }
- PLAYER 2 {
- PAYOFF :(WinQ()) - :(WinP())
- }
-}
-LOC 1 {
- PLAYER 1 {
- PAYOFF :(WinP()) - :(WinQ())
- }
- PLAYER 2 {
- PAYOFF :(WinQ()) - :(WinP())
- MOVES [Circle -> 0]
- }
-}
-MODEL [ | P:1 {}; Q:1 {} | ] \"
- ... ... ...
- ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ...
- ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ...
- ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))
-")
-
-let pawn_whopping_str = ("
-PLAYERS 1, 2
-DATA depth: 4, adv_ratio: 2
-REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
-REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
-REL IsFirst(x) = not ex z C(z, x)
-REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
-REL IsEight(x) = not ex z C(x, z)
-REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
-REL WhiteEnds() = (ex x (wP(x) and not ex y C(x, y))) or (not ex z bP(z))
-REL BlackEnds() = (ex x (bP(x) and not ex y C(y, x))) or (not ex z wP(z))
-RULE WhiteBeat:
- [ a, b | wP { a }; bP { b } | - ] -> [ a, b | wP { b } | - ] emb wP, bP
- pre DiagW(a, b) and not BlackEnds()
-RULE WhiteMove:
- [ | bP:1 {}; R:2 {} | ] \"
-
- .
-
- wP
-\" -> [ | bP:1 {}; R:2 {} | ] \"
...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-09 18:42:47
|
Revision: 1687
http://toss.svn.sourceforge.net/toss/?rev=1687&view=rev
Author: lukaszkaiser
Date: 2012-03-09 18:42:39 +0000 (Fri, 09 Mar 2012)
Log Message:
-----------
Merging Move into Arena and debugging JS-Server communication. First full JS-standalone+Server-speedup Toss version.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
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/GGP/TranslateGameTest.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
Removed Paths:
-------------
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Play/MoveTest.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-09 12:05:53 UTC (rev 1686)
+++ trunk/Toss/Arena/Arena.ml 2012-03-09 18:42:39 UTC (rev 1687)
@@ -86,6 +86,149 @@
Structure.equal gs1.struc gs2.struc
+(* ---------------------------- PRINTING FUNCTIONS -------------------------- *)
+
+(* Print a label as a string. *)
+let label_str
+ {lb_rule = rr; time_in = t_interval; parameters_in = param_intervals} =
+ let fpstr (f,(fs, fe)) =
+ 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
+
+(* Print a move as string. *)
+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} =
+ Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
+ (fun f (payoff, moves) ->
+ Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
+ (Formula.fprint_real(* _nobra 0 *)) payoff;
+ if moves <> [] then
+ Format.fprintf f "@[<1>MOVES@ %a@]@ "
+ (Aux.fprint_sep_list ";" (fun f ({
+ 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;
+ 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 "@ ->@ %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 equational_def_style = ref true
+
+let fprint_game_move ?(as_ints=false) struc 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.sort Pervasives.compare m)) in
+ let rt = match rtime with None -> "" | Some f -> " " ^ (string_of_float f) in
+ if (pl = []) then
+ 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
+ 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 fprint_only_state ?(ext_struct=false) ppf
+ {struc = struc;
+ time = time;
+ cur_loc = cur_loc;
+ history = hist;
+ } =
+ Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
+ (if ext_struct then (Structure.fprint_ext_structure ~show_empty:true) else
+ (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;
+ 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
+
+let sprint_only_state s = AuxIO.sprint_of_fprint fprint_only_state s
+
+let fprint_state_full ?(ext_struct=false) print_compiled_rules ppf
+ ({rules = rules;
+ graph = graph;
+ num_players = num_players;
+ player_names = player_names;
+ data = data;
+ defined_rels = defined_rels;
+ starting_struc = struc;
+ },
+ {time = time;
+ cur_loc = cur_loc;
+ history = hist;
+ }) =
+ Format.fprintf ppf "@[<v>";
+ List.iter (fun (drel, (args, body)) ->
+ if !equational_def_style then
+ Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ =@ @[<1>%a@]"
+ drel (Aux.fprint_sep_list "," Format.pp_print_string) args
+ Formula.fprint body
+ else
+ Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ {@,@[<1>%a@,@]}"
+ drel (Aux.fprint_sep_list "," Format.pp_print_string) args
+ Formula.fprint body;
+ Format.fprintf ppf "@]@ ";
+ ) defined_rels;
+ Format.fprintf ppf "@[<1>PLAYERS@ %a@]@ "
+ (Aux.fprint_sep_list "," Format.pp_print_string)
+ (List.map fst (List.sort (fun (_,x) (_,y) -> x-y) player_names));
+ if data <> [] then
+ Format.fprintf ppf "@[<1>DATA@ %a@]@ "
+ (Aux.fprint_sep_list ","
+ (fun ppf (k,v) -> Format.fprintf ppf "@[<1>%s@,:@ %s@]" k v))
+ data;
+ List.iter (fun (rname, r) ->
+ Format.fprintf ppf "@[<1>RULE %s:@ %a@]@ " rname
+ (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;
+ Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
+ (if ext_struct then (Structure.fprint_ext_structure ~show_empty:true) else
+ (Structure.fprint ~show_empty:true)) struc;
+ if (hist <> []) then
+ Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
+ (Aux.fprint_sep_list ";\n" (fprint_game_move ~as_ints:true struc)) 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;
+ Format.fprintf ppf "@]"
+
+let fprint_state = fprint_state_full false
+let print_state r = AuxIO.print_of_fprint (fprint_state_full false) r
+let sprint_state r = AuxIO.sprint_of_fprint (fprint_state_full false) r
+let sprint_state_full r = AuxIO.sprint_of_fprint (fprint_state_full true) r
+let sprint_state_ext r =
+ AuxIO.sprint_of_fprint (fprint_state_full ~ext_struct:true false) r
+let str game = sprint_state (game, snd empty_state)
+let state_str state = sprint_state state
+
+
+
(* -------------------- PARSER HELPER ------------------------------ *)
let matching_of_names (game, state) rname match_str =
@@ -191,7 +334,8 @@
time = new_time;
history = (m, t) :: state.history;
cur_loc = m.next_loc }
- | _ -> failwith "rule inapplicable"
+ | _ -> failwith ("move " ^ (sprint_game_move state.struc (m,t)) ^
+ " 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))
@@ -289,7 +433,7 @@
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 hist {
+ apply_moves rules (List.rev hist) {
struc = state;
time = time;
cur_loc = cur_loc;
@@ -307,118 +451,6 @@
}, result_state
-
-(* ---------------------------- PRINTING FUNCTIONS -------------------------- *)
-
-(* Print a label as a string. *)
-let label_str
- {lb_rule = rr; time_in = t_interval; parameters_in = param_intervals} =
- let fpstr (f,(fs, fe)) =
- 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
-
-(* Print a move as string. *)
-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} =
- Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
- (fun f (payoff, moves) ->
- Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
- (Formula.fprint_real(* _nobra 0 *)) payoff;
- if moves <> [] then
- Format.fprintf f "@[<1>MOVES@ %a@]@ "
- (Aux.fprint_sep_list ";" (fun f ({
- 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;
- 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 "@ ->@ %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 equational_def_style = ref true
-
-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) -> Printf.sprintf "%s: %i" e x) m) in
- let rt = match rtime with None -> "" | Some f -> " " ^ (string_of_float f) in
- if (pl = []) then
- 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
- Format.fprintf f "@[<1>[%s@ %F,@ %s@ ->@ %i@ emb@ %s]%s@]" rn t p_s l m_s rt
- )
-
-let sprint_game_move gm = AuxIO.sprint_of_fprint fprint_game_move gm
-
-let fprint_state_full print_compiled_rules ppf
- ({rules = rules;
- graph = graph;
- num_players = num_players;
- player_names = player_names;
- data = data;
- defined_rels = defined_rels;
- },
- {struc = struc;
- time = time;
- cur_loc = cur_loc;
- history = hist;
- }) =
- Format.fprintf ppf "@[<v>";
- List.iter (fun (drel, (args, body)) ->
- if !equational_def_style then
- Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ =@ @[<1>%a@]"
- drel (Aux.fprint_sep_list "," Format.pp_print_string) args
- Formula.fprint body
- else
- Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ {@,@[<1>%a@,@]}"
- drel (Aux.fprint_sep_list "," Format.pp_print_string) args
- Formula.fprint body;
- Format.fprintf ppf "@]@ ";
- ) defined_rels;
- Format.fprintf ppf "@[<1>PLAYERS@ %a@]@ "
- (Aux.fprint_sep_list "," Format.pp_print_string)
- (List.map fst (List.sort (fun (_,x) (_,y) -> x-y) player_names));
- if data <> [] then
- Format.fprintf ppf "@[<1>DATA@ %a@]@ "
- (Aux.fprint_sep_list ","
- (fun ppf (k,v) -> Format.fprintf ppf "@[<1>%s@,:@ %s@]" k v))
- data;
- List.iter (fun (rname, r) ->
- Format.fprintf ppf "@[<1>RULE %s:@ %a@]@ " rname
- (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;
- Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
- (Structure.fprint ~show_empty:true) struc;
- if (hist <> []) then
- Format.fprintf ppf "@[<1>MOVES@ %a@]@ "
- (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;
- Format.fprintf ppf "@]"
-
-let fprint_state = fprint_state_full false
-let print_state r = AuxIO.print_of_fprint (fprint_state_full false) r
-let sprint_state r = AuxIO.sprint_of_fprint (fprint_state_full false) r
-let sprint_state_full r = AuxIO.sprint_of_fprint (fprint_state_full true) r
-let str game = sprint_state (game, snd empty_state)
-let state_str state = sprint_state state
-
(* -------------------- WHOLE ARENA MANIPULATION -------------------- *)
let add_new_player (state_game, state) pname =
@@ -549,6 +581,105 @@
with Diff_result expl -> false, expl
+
+(* -------- Move definition, generation and helper functions. ------- *)
+
+
+(* TODO: Sampling grid size fixed until doing more with continuous games. *)
+let cGRID_SIZE = 5
+
+
+(* Generate moves available from a state, as an array, in fixed order. *)
+let gen_moves grid_size rules model loc =
+ let matchings =
+ Aux.concat_map
+ (fun (label,next_loc) ->
+ let rule = List.assoc label.lb_rule rules in
+ List.map (fun emb -> label,next_loc,emb)
+ (ContinuousRule.matches model rule))
+ loc.moves in
+ if matchings = [] then [| |] else (
+ (* generating the grid *)
+ Array.concat
+ (List.map (fun (label,next_loc,emb) ->
+ (* not searching through time *)
+ let t_l, t_r = label.time_in in
+ let t = (t_r +. t_l) /. 2. in
+ if label.parameters_in = [] then
+ [| {
+ mv_time = t;
+ parameters = [];
+ rule = label.lb_rule;
+ next_loc = next_loc;
+ matching = emb
+ } |]
+ else
+ 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
+ [(f_r +. f_l) /. 2.]
+ else
+ let df = (f_r -. f_l) /. float_of_int (grid_size - 1) in
+ Array.to_list
+ (Array.init grid_size
+ (fun i -> f_l +. float_of_int i *. df))
+ ) params_in in
+ let grid = Aux.product axes in
+ Aux.array_map_of_list (fun params -> {
+ mv_time = t;
+ parameters = List.combine param_names params;
+ rule = label.lb_rule;
+ next_loc = next_loc;
+ matching = emb}
+ ) grid
+ ) matchings))
+
+(* Check if the before-part of the precondition of the rule holds on history. *)
+let check_history_pre r hist =
+ match r.DiscreteRule.struc_rule with
+ | None -> true
+ | Some sr ->
+ let prev_list = snd (sr.DiscreteRule.pre) in
+ let constraint_satisfied (rname, b) =
+ 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 =
+ Aux.map_some (fun mv ->
+ let rule = List.assoc mv.rule rules in
+ if check_history_pre rule.ContinuousRule.discrete state.history then
+ Aux.map_option
+ (fun (model, time, _) -> (* ignoring shifts, i.e. animation steps *)
+ (mv,
+ {cur_loc = mv.next_loc;
+ history = (mv, None) :: state.history;
+ struc = model;
+ time = time}))
+ (ContinuousRule.rewrite_single state.struc time mv.matching
+ 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 moves, states = List.split res in
+ Array.of_list moves, Array.of_list states
+
+let list_moves 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
+ 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
+ Array.of_list (List.concat (
+ List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
+
+
+
+
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
@@ -566,3 +697,38 @@
with Not_found ->
((state_game, state), "ERR applying " ^ r_name ^ ", rule not found")
)
+
+
+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 {rules=rules; graph=graph} = game in
+ let struc = state.struc in
+ let mv_loc = 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
+ (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
+ ) (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)
+ done;
+ LOG 1 "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 (new_state_noloc, resp) =
+ apply_rule_int gstate (r_name, mtch, 0.1, []) in
+ let new_loc = moves.(pos).next_loc in
+ (fst new_state_noloc,
+ {snd new_state_noloc with cur_loc = new_loc})
+ ) else gstate
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-03-09 12:05:53 UTC (rev 1686)
+++ trunk/Toss/Arena/Arena.mli 2012-03-09 18:42:39 UTC (rev 1687)
@@ -84,14 +84,20 @@
syntax. Defaults to [true]. *)
val equational_def_style : bool ref
-val fprint_state_full :
+val fprint_state_full : ?ext_struct : bool ->
bool -> Format.formatter -> game * game_state -> unit
val fprint_state : Format.formatter -> game * game_state -> unit
val print_state : game * game_state -> unit
val sprint_state : game * game_state -> string
+(** Print the structure in extensive form. *)
+val sprint_state_ext : game * game_state -> string
(** 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
+
(** The order of following entries matters: [DefPlayers] adds more
players, with consecutive numbers starting from first available;
later [StateStruc], [StateTime] and [StateLoc] entries override
@@ -161,6 +167,33 @@
game * game_state -> game * game_state -> bool * string
+
+(** {2 Move definition, generation and helper functions.} *)
+
+(** Default number of sample points per parameter in tree search.
+ 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. *)
+val list_moves : game -> game_state -> (int * move * game_state) array
+
+
val apply_rule_int : game * game_state ->
string * (string * int) list * float * (string * float) list ->
(game * game_state) * string
+
+
+val apply_rewrite : game * game_state ->
+ int * (string * DiscreteRule.matching) -> game * game_state
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-03-09 12:05:53 UTC (rev 1686)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-03-09 18:42:39 UTC (rev 1687)
@@ -77,5 +77,19 @@
assert_equal ~printer:(fun x->x) ~msg:"from file, curly braces style"
contents (Arena.sprint_state gs);
);
+
+ "move to string" >::
+ (fun () ->
+ let mv = {
+ Arena.mv_time = 0.;
+ parameters = [];
+ rule = "rule";
+ next_loc = 1;
+ matching = [("x", 1)];
+ } in
+ let s = Structure.empty_structure () in
+ assert_equal ~printer:(fun x -> x) (Arena.game_move_str s mv)
+ "[rule 0. -> 1 emb x: 1]"
+ );
]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-03-09 12:05:53 UTC (rev 1686)
+++ trunk/Toss/Client/JsHandler.ml 2012-03-09 18:42:39 UTC (rev 1687)
@@ -235,7 +235,7 @@
let game, state = game_data.game_state in
cur_game := game_data;
play_states := [state];
- cur_all_moves := Move.list_moves game state;
+ cur_all_moves := Arena.list_moves game state;
cur_move := 0;
LOG 1 "new_play (%s): calling js_of_game_state." game_name;
js_of_game_state game state
@@ -260,7 +260,7 @@
let (p, m, n_state) = !cur_all_moves.(move_id) in
let game, _ = !cur_game.game_state in
play_states := n_state :: !play_states;
- cur_all_moves := Move.list_moves game n_state;
+ cur_all_moves := Arena.list_moves game n_state;
cur_move := 0;
Js.some (js_of_game_state game n_state)
@@ -282,7 +282,7 @@
let hs a = String.concat "#" (Array.to_list (Array.map Formula.real_str a)) in
let h= String.concat "#" (Array.to_list (Array.map hs !cur_game.heuristic)) in
js(Printf.sprintf "%f#%s#%s" (Js.to_float timeout)
- (Arena.state_str (game, state)) h)
+ (Arena.sprint_state_ext (game, state)) h)
let _ = set_handle "gameinfo" game_info
@@ -325,7 +325,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, _) -> Move.move_gs_str state m = move_s) !cur_all_moves in
+ (fun (_,m,_) -> Arena.game_move_gs_str state 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-09 12:05:53 UTC (rev 1686)
+++ trunk/Toss/Client/Main.js 2012-03-09 18:42:39 UTC (rev 1687)
@@ -1,441 +1,41 @@
-// JavaScript Toss Module -- Main (requires Connect.js, State.js, Play.js)
+// JavaScript Toss Module -- Main (requires State.js, Play.js)
var UNAME = "";
var GAME_NAME = ""; // name of current game, e.g. "Breakthrough"
-var PLAYS = [];
-var CUR_PLAY_I = -1;
+var PLAY = [];
-var FRIENDS = []
-var UNAME_TO_NAME_MAP = {}
-
-var MAX_OPNT_LEN = 20;
-var FULL_OPNT_LEN = 0;
-var CUR_OPNT_START = 0;
-
var SIMPLE_SET = false;
function disp_name (uname) {
if (uname == "guest") { return ("You"); }
if (uname == "computer") { return ("Computer"); }
- if (typeof CONN == 'undefined') { return ("Player " + uname); }
- if (UNAME_TO_NAME_MAP[uname]) { return (UNAME_TO_NAME_MAP[uname]); }
- name = CONN.get_name (uname);
- UNAME_TO_NAME_MAP[uname] = name;
- return (name);
+ return ("Player " + uname);
}
nameDISP = disp_name;
function handle_elem_click (elem) {
- PLAYS[CUR_PLAY_I].handle_click (elem);
+ PLAY.handle_click (elem);
}
function make_move () {
- PLAYS[CUR_PLAY_I].move ();
+ PLAY.move ();
}
function make_move_continue (info) {
var suggest_f = function (time) { suggest_move_async (time, make_move) };
- PLAYS[CUR_PLAY_I].move_continue (info, suggest_f);
+ PLAY.move_continue (info, suggest_f);
}
function prev_move_click () {
- PLAYS[CUR_PLAY_I].prev_move ();
+ PLAY.prev_move ();
}
function next_move_click () {
- PLAYS[CUR_PLAY_I].next_move ();
+ PLAY.next_move ();
}
-var GAMES = new Array(
- /* "Concurrent-Tic-Tac-Toe" */
- "Breakthrough",
- "Checkers",
- "Chess",
- "Connect4",
- "Entanglement",
- "Gomoku",
- "Pawn-Whopping",
- "Tic-Tac-Toe"
-);
-
-var GAMESPAGE = undefined;
-
-
-function GamesPage(id, games){ // html tag id
- this.games = games;
- this.paragraphs = new Object();
- this.container = document.getElementById (id);
- for (var i = 0; i < this.games.length; i++) {
- var game = this.games[i];
-
- var paragraph = document.createElement("p");
- this.paragraphs[game] = paragraph;
- paragraph.setAttribute("class", "game-par");
- this.container.appendChild (paragraph);
-
- var button = document.createElement("button");
- paragraph.game_button = button;
- button.setAttribute("class", "gamebt");
- button.setAttribute("onclick", "new_play('" + game + "')");
- button.innerHTML = game;
- button.style.display = "block";
- paragraph.appendChild (button);
-
- var open_play_list = document.createElement("ul");
- paragraph.open_play_list = open_play_list;
- open_play_list.setAttribute("class", "plays-list");
- open_play_list.setAttribute("id", "a-plays-list-" + game);
- paragraph.appendChild (open_play_list);
-
- var closed_plays = document.createElement("div");
- paragraph.closed_plays = closed_plays;
- closed_plays.setAttribute("id", "d-plays-div-" + game);
-
- var completed_bt = document.createElement("button");
- paragraph.completed_button = completed_bt;
- completed_bt.setAttribute("class", "completedbt");
- completed_bt.setAttribute("onclick",
- "GAMESPAGE.toggle_completed ('" +game+ "')");
- completed_bt.innerHTML = "Completed games (Show)";
- closed_plays.appendChild (completed_bt);
-
- var learn_button = document.createElement("button");
- paragraph.learn_button = learn_button;
- learn_button.setAttribute("class", "completedbt");
- learn_button.setAttribute("onclick",
- "GAMESPAGE.learn_game ('" + game + "')");
- learn_button.innerHTML = "Learn";
- learn_button.style.display = "none";
- closed_plays.appendChild (learn_button);
-
- var closed_play_list = document.createElement("ul");
- paragraph.closed_play_list = closed_play_list;
- closed_play_list.setAttribute("class", "plays-list");
- closed_play_list.setAttribute("id", "d-plays-list-" + game);
- closed_play_list.style.display = "none";
- closed_plays.appendChild (closed_play_list);
-
- closed_plays.style.display = "none";
- paragraph.appendChild (closed_plays);
-
- var edit_div = document.createElement("div");
- paragraph.edit_div = edit_div;
- edit_div.setAttribute("id", "edit-div-" + game);
- edit_div.setAttribute("class", "edit-div");
-
- var edit_button = document.createElement("button");
- paragraph.edit_button = edit_button;
- edit_button.setAttribute("class", "completedbt");
- edit_button.setAttribute("onclick",
- "GAMESPAGE.toggle_edit ('" + game + "')");
- edit_button.innerHTML = "Edit " + game + " (Show)";
- edit_div.appendChild (edit_button);
-
- var edit_save_button = document.createElement("button");
- paragraph.edit_save_button = edit_save_button;
- edit_save_button.setAttribute("class", "completedbt");
- edit_save_button.setAttribute("onclick",
- "GAMESPAGE.save_edit ('" + game + "')");
- edit_save_button.innerHTML = "Save";
- edit_save_button.style.display = "none";
- edit_div.appendChild (edit_save_button);
-
- var edit_area = document.createElement("textarea");
- edit_area.setAttribute("class", "edit-area");
- paragraph.edit_area = edit_area;
- edit_div.appendChild (edit_area);
- edit_area.style.display = "none";
- if (typeof CONN != 'undefined')
- edit_area.value = CONN.get_game (game);
- else ASYNCH ("get_game", [game],
- function (v) {edit_area.value = v});
- paragraph.appendChild (edit_div);
-
- paragraph.completed_shown = false;
- paragraph.edit_shown = false;
- this.container.appendChild (paragraph);
- }
- return (this);
-}
-
-GamesPage.prototype.show = function () {
- this.container.style.display = "block";
-}
-
-GamesPage.prototype.hide = function () {
- this.container.style.display = "none";
-}
-
-GamesPage.prototype.show_completed = function (game) {
- this.paragraphs[game].closed_plays.style.display = "block";
-}
-
-GamesPage.prototype.hide_completed = function (game) {
- this.paragraphs[game].closed_plays.style.display = "none";
-}
-
-GamesPage.prototype.learn_game = function (game) {
- if (typeof CONN == 'undefined') {
- alert ("Learing not implemented for the ASYNCH interface");
- return;
- }
- var lst = CONN.list_plays (game, UNAME);
- var lst_plays = parse_list ('##', lst);
- var plays = "$";
- for (var i = 0; i < lst_plays.length; i++) {
- lst_plays[i] = play_from_string (game, lst_plays[i]);
- if (lst_plays[i].cur_state.result != null) {
- var pid = lst_plays[i].pid;
- var val = document.getElementById ("select_" + pid).value;
- if (val != -1) plays += pid + ":" + val + "$";
- }
- }
- var res = CONN.learn_game (game, plays)
- alert (res);
-}
-
-GamesPage.prototype.toggle_completed = function (game) {
- var par = this.paragraphs[game];
- if (par.completed_shown) {
- par.closed_play_list.style.display = "none";
- par.learn_button.style.display = "none";
- par.completed_button.innerHTML = "Completed games (Show)";
- par.completed_shown = false;
- } else {
- par.closed_play_list.style.display = "block";
- //par.learn_button.style.display = "inline"; skip for now
- par.completed_button.innerHTML = "Completed games (Hide)";
- par.completed_shown = true;
- }
-}
-
-GamesPage.prototype.toggle_edit = function (game) {
- var par = this.paragraphs[game];
-...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-09 22:49:57
|
Revision: 1688
http://toss.svn.sourceforge.net/toss/?rev=1688&view=rev
Author: lukstafi
Date: 2012-03-09 22:49:49 +0000 (Fri, 09 Mar 2012)
Log Message:
-----------
Moving game simplification from working on state.struc to worknig on game.starting_struc.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/GameSimpl.mli
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Makefile
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/Arena/Arena.ml 2012-03-09 22:49:49 UTC (rev 1688)
@@ -491,14 +491,14 @@
else acc in
acc
-let map_to_structures f (game, state) =
+let map_to_structures f game =
{game with
- rules = List.map (fun (rn, r) ->
- rn, {r with ContinuousRule.discrete =
- DiscreteRule.map_to_structures f r.ContinuousRule.discrete}
- ) game.rules},
- {state with
- struc = f state.struc}
+ rules = List.map
+ (fun (rn, r) ->
+ rn, {r with ContinuousRule.discrete =
+ DiscreteRule.map_to_structures f r.ContinuousRule.discrete}
+ ) game.rules;
+ starting_struc = f game.starting_struc}
let map_to_discrete f game =
{game with
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/Arena/Arena.mli 2012-03-09 22:49:49 UTC (rev 1688)
@@ -149,8 +149,8 @@
(Formula.formula -> 'a -> 'a) -> game -> 'a -> 'a
val map_to_structures :
- (Structure.structure -> Structure.structure) -> game * game_state ->
- game * game_state
+ (Structure.structure -> Structure.structure) -> game ->
+ game
(** Map to the structure representation of discrete part of rules. *)
val map_to_discrete :
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/GGP/GameSimpl.ml 2012-03-09 22:49:49 UTC (rev 1688)
@@ -203,10 +203,10 @@
let nonspec = DiscreteRule.orig_rel_of rel in
if nonspec = "" then rel else nonspec
-let simplify ?(keep_nonempty_predicates=true) (game, state) =
+let simplify ?(keep_nonempty_predicates=true) game =
LOG 1 "GameSimpl: defined_rels = %s"
(String.concat ", " (List.map fst game.Arena.defined_rels));
- let struc = state.Arena.struc in
+ let struc = game.Arena.starting_struc in
let signat = Structure.rel_signature struc in
let nelems = Structure.nbr_elems struc in
let tcard tups = Tups.cardinal tups in
@@ -381,8 +381,7 @@
let game =
Arena.map_to_formulas (FormulaMap.map_to_atoms repl_equiv_and_inv)
game in
- let state =
- {state with Arena.struc = Structure.clear_rels struc removable} in
+ let struc = Structure.clear_rels struc removable in
(* Also have to apply to LHS structures... Don't use
{!ContinuousRule.apply_to_sides} as we don't need to
recompile. *)
@@ -439,7 +438,7 @@
(add_rels "")
game Aux.Strings.empty in
let used_rels = ref used_rels in
- let struc = ref state.Arena.struc in
+ let struc = ref struc in
let signat = ref signat in
let glued = ref [] in (* bindings introduced by [glue] *)
let glued_inv = ref [] in (* bingings introduced by [glue_inv] *)
@@ -628,7 +627,7 @@
(String.concat "\n" (List.map (fun (k,v)->k^" = "^v) more_data));
let game = {game with
Arena.data = more_data @ game.Arena.data} in
- let state = {state with Arena.struc = !struc} in
+ let struc = !struc in
let signat = !signat in
(*
@@ -678,7 +677,9 @@
else aux (now_used_in_def, defined_rels) in
aux (used_in_def, game.Arena.defined_rels) in
let used_rels = Aux.Strings.union used_in_def used_rels in
- let game = {game with Arena.defined_rels = defined_rels} in
+ let game =
+ {game with Arena.defined_rels = defined_rels;
+ starting_struc = struc} in
(* 4b, 4e *)
let clear_rel rel =
let rel = get_orig_if_special rel in
@@ -687,12 +688,12 @@
DiscreteRule.special_rel_of rel = None &&
(not keep_nonempty_predicates ||
(try List.assoc rel signat > 1 with Not_found -> false) ||
- Structure.rel_size !struc rel = 0
+ Structure.rel_size struc rel = 0
) &&
not (Aux.Strings.mem rel fluents) &&
(not (Aux.Strings.mem rel used_rels) ||
not (List.mem_assoc rel defined_rels) &&
- Structure.rel_size !struc rel = 0) in
+ Structure.rel_size struc rel = 0) in
if res then LOG 3 "GameSimpl: removing relation %s" rel;
res in
let remove_empty = FormulaMap.map_formula
@@ -702,12 +703,12 @@
else Formula.Rel (rel, args)} in
let game = Arena.map_to_formulas
(!final_simplify -| remove_exist -| remove_empty) game in
- let game, state =
+ let game =
Arena.map_to_structures
(fun struc ->
let struc =
List.fold_left (fun struc (rel, arity) ->
Structure.add_rel_name rel arity struc) struc signat in
Structure.clear_rels struc clear_rel)
- (game, state) in
- (game, state)
+ game in
+ game
Modified: trunk/Toss/GGP/GameSimpl.mli
===================================================================
--- trunk/Toss/GGP/GameSimpl.mli 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/GGP/GameSimpl.mli 2012-03-09 22:49:49 UTC (rev 1688)
@@ -12,5 +12,4 @@
val simplify :
?keep_nonempty_predicates:bool ->
- Arena.game * Arena.game_state ->
- Arena.game * Arena.game_state
+ Arena.game -> Arena.game
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/GGP/GameSimplTest.ml 2012-03-09 22:49:49 UTC (rev 1688)
@@ -24,24 +24,10 @@
{!GameSimpl.simplify} changes. *)
let a () =
let game_name = (* "breakthrough" *) (* "connect5" *) "tictactoe" in
- let game = state_of_file ("./GGP/tests/"^game_name^"-raw.toss") in
- AuxIO.printf "\nINPUT:\n%s\n%!" (Arena.state_str game);
+ let game, state = state_of_file ("./GGP/tests/"^game_name^"-raw.toss") in
+ AuxIO.printf "\nINPUT:\n%s\n%!" (Arena.state_str (game, state));
let res = GameSimpl.simplify game in
- let res_str = Arena.state_str res in
+ let state = {state with Arena.struc = res.Arena.starting_struc} in
+ let res_str = Arena.state_str (res, state) in
AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-simpl.toss") res_str;
AuxIO.printf "\nRESULT:\n%s\n%!" res_str
-
-
-let a () =
- AuxIO.set_debug_level "GameSimpl" 5;
- let connect5 = state_of_file "./GGP/tests/connect5-raw.toss" in
- let res = GameSimpl.simplify connect5 in
- let goal = state_of_file "./GGP/tests/connect5-simpl.toss" in
- let res_str = Arena.state_str res in
- AuxIO.output_file ~fname:"./GGP/tests/connect5-temp.toss" res_str;
- let eq, msg = Arena.compare_diff goal res in
- assert_bool
- ("tests/connect5-raw.toss to tests/connect5-simpl.toss, see \
- GGP/tests/connect5-temp.toss: "^msg)
- eq;
- Sys.remove "./GGP/tests/connect5-temp.toss"
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/GGP/TranslateGame.ml 2012-03-09 22:49:49 UTC (rev 1688)
@@ -2963,10 +2963,10 @@
defined_rels = defined_rels;
starting_struc = struc;
} in
- let result =
- game, {Arena.struc = struc; history = []; time = 0.; cur_loc = 0} in
+ let state =
+ {Arena.struc = struc; history = []; time = 0.; cur_loc = 0} in
LOG 4 "\n\ntranslate_game: before simplification --\n%s"
- (Arena.sprint_state_full result);
+ (Arena.sprint_state_full (game, state));
let tossrule_data = Aux.strmap_of_assoc tossrule_data in
let playing_as =
@@ -2977,8 +2977,9 @@
| None -> ()
| Some game_name ->
AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-raw.toss")
- (Arena.state_str result));
- let result = GameSimpl.simplify result in
+ (Arena.state_str (game, state)));
+ let game = GameSimpl.simplify game in
+ let state = {state with Arena.struc = game.Arena.starting_struc} in
let gdl_translation = {
(* map between structure elements and their term representations;
the reverse direction is by using element names *)
@@ -2997,16 +2998,15 @@
| None -> ()
| Some game_name ->
AuxIO.output_file ~fname:("./GGP/tests/"^game_name^"-simpl.toss")
- (Arena.state_str result)
+ (Arena.state_str (game, state))
);
LOG 2 "\n\ntranslate_game: simplified rel sizes --\n%s"
(String.concat ", "(List.map (fun (rel,ar) ->
rel^":"^string_of_int ar) (Structure.rel_sizes
- (snd result).Arena.struc)));
+ game.Arena.starting_struc)));
LOG 2 "\n\ntranslate_game: after simplification --\n%s"
- (Arena.sprint_state_full result);
+ (Arena.sprint_state_full (game, state));
- let game, state = result in
let inl_game = Arena.map_to_formulas GameSimpl.remove_exist
(inline_defined_rels game.Arena.defined_rels game) in
gdl_translation, game, (inl_game, state)
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-03-09 22:49:49 UTC (rev 1688)
@@ -49,17 +49,18 @@
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
let goal_str = AuxIO.input_file ("./GGP/tests/" ^ goal_name) in
- (* let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in *)
+ (* * let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in
+ * *)
let res_str = Arena.state_str (r_game, r_struc) in
- (* output_string resf res_str;
- close_out resf; *)
+ (* * output_string resf res_str;
+ close_out resf; * *)
(* let eq, msg = Arena.compare_diff goal res in *)
let eq, msg = goal_str = res_str, "sorry, just comparing as strings" in
assert_bool ("tests for " ^ game_name ^ " failed (" ^ goal_name ^ ")")
(* "GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
", see GGP/tests/"^game_name^"-temp.toss: "^msg *)
eq;
- (* Sys.remove ("./GGP/tests/"^game_name^"-temp.toss"); *)
+ (* * 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
@@ -140,17 +141,18 @@
let goal_name = game_name^"-simpl.toss" in
(* let goal = state_of_file ("./GGP/tests/"^goal_name) in *)
let goal_str = AuxIO.input_file ("./GGP/tests/"^goal_name) in
- (* let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss") in *)
+ (* * let resf = open_out ("./GGP/tests/"^game_name^"-temp.toss")
+ in * *)
let res_str = Arena.state_str (r_game, r_struc) in
- (* output_string resf res_str;
- close_out resf; *)
+ (* * output_string resf res_str;
+ close_out resf; * *)
(* let eq, msg = Arena.compare_diff goal res in *)
let eq, msg = goal_str = res_str, "sorry, just comparing as strings" in
assert_bool ("tests for " ^ game_name ^ " failed (" ^ goal_name ^ ")")
(*"GGP/examples/"^game_name^".gdl to GGP/tests/"^goal_name^
", see GGP/tests/"^game_name^"-temp.toss: "^msg*)
eq;
- (* Sys.remove ("./GGP/tests/"^game_name^"-temp.toss"); *)
+ (* * Sys.remove ("./GGP/tests/"^game_name^"-temp.toss"); * *)
let embs = Array.map
(fun (rname, emb) -> Arena.matching_of_names res rname emb)
rules_and_embs in
@@ -237,7 +239,7 @@
"control__BLANK_", "control__BLANK_"]
~loc1_noop:"noop" ~loc1_move:"(mark f g)" ()
);
-(*
+(* *
"breakthrough" >::
(fun () ->
game_test_case ~game_name:"breakthrough" ~player:"white"
@@ -349,7 +351,7 @@
"control__BLANK_", "control__BLANK_"]
~loc1_noop:"noop" ~loc1_move:"(move 7 7 7 6)" ()
);
-*)
+* *)
]
let set_debug_level i =
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-03-09 18:42:39 UTC (rev 1687)
+++ trunk/Toss/Makefile 2012-03-09 22:49:49 UTC (rev 1688)
@@ -114,6 +114,7 @@
FormulaINCSatINC=MenhirLib,Formula
FormulaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll
SolverINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
+SolverINCNumINC=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
@@ -158,6 +159,8 @@
_build/$<
gprof _build/$< > $@.log
+pi_5000: Solver/Num/pi_num.native
+ time _build/Solver/Num/pi_num.native 5000
# Formula tests
FormulaTests: TossServer
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-03-11 00:30:20
|
Revision: 1689
http://toss.svn.sourceforge.net/toss/?rev=1689&view=rev
Author: lukaszkaiser
Date: 2012-03-11 00:30:10 +0000 (Sun, 11 Mar 2012)
Log Message:
-----------
Changing MODEL to START, debugging and website updates.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Client/Style.css
trunk/Toss/Client/index.html
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss
trunk/Toss/GGP/tests/2player_normal_form_joint-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_joint-simpl.toss
trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss
trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss
trunk/Toss/GGP/tests/breakthrough-raw.toss
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect4-raw.toss
trunk/Toss/GGP/tests/connect4-simpl.toss
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
trunk/Toss/GGP/tests/pawn_whopping-raw.toss
trunk/Toss/GGP/tests/pawn_whopping-simpl.toss
trunk/Toss/GGP/tests/tictactoe-other-raw.toss
trunk/Toss/GGP/tests/tictactoe-other-simpl.toss
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/examples/Breakthrough.toss
trunk/Toss/examples/Checkers.toss
trunk/Toss/examples/Chess.toss
trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss
trunk/Toss/examples/Connect4.toss
trunk/Toss/examples/Entanglement.toss
trunk/Toss/examples/Gomoku.toss
trunk/Toss/examples/Gomoku19x19.toss
trunk/Toss/examples/PacMan.toss
trunk/Toss/examples/Pawn-Whopping.toss
trunk/Toss/examples/Tic-Tac-Toe.toss
trunk/Toss/examples/bounce.toss
trunk/Toss/examples/rewriting_example.toss
trunk/Toss/www/contact.xml
trunk/Toss/www/ideas.xml
trunk/Toss/www/index.xml
trunk/Toss/www/navigation.xml
trunk/Toss/www/scripts/main.js
trunk/Toss/www/styles/common.css
trunk/Toss/www/xsl/common.xsl
Added Paths:
-----------
trunk/Toss/Client/img/logo.png
trunk/Toss/www/img/appstore-small.png
Removed Paths:
-------------
trunk/Toss/Client/img/toss.png
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Arena/Arena.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -154,7 +154,7 @@
cur_loc = cur_loc;
history = hist;
} =
- Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
+ Format.fprintf ppf "@[<1>START@ %a@]@ "
(if ext_struct then (Structure.fprint_ext_structure ~show_empty:true) else
(Structure.fprint ~show_empty:true)) struc;
if (hist <> []) then
@@ -206,7 +206,7 @@
Array.iteri (fun loc_id loc ->
Format.fprintf ppf "@[<0>LOC@ %d@ {@,@[<2> %a@]@]@,}@ "
loc_id (fprint_loc_body struc player_names) loc) graph;
- Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
+ Format.fprintf ppf "@[<1>START@ %a@]@ "
(if ext_struct then (Structure.fprint_ext_structure ~show_empty:true) else
(Structure.fprint ~show_empty:true)) struc;
if (hist <> []) then
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Arena/ArenaParser.mly 2012-03-11 00:30:10 UTC (rev 1689)
@@ -10,7 +10,6 @@
%}
%start parse_game_defs parse_game_state
-%type <Arena.struct_loc> struct_location
%type <(string * int) list -> int * Arena.player_loc array> location
%type <Arena.definition> parse_game_defs
%type <Arena.game * Arena.game_state> parse_game_state game_state
@@ -123,9 +122,9 @@
EQ
body = formula_expr_err
{ DefRel (rel, arg, body) }
- | MODEL_SPEC model = struct_expr
+ | START model = struct_expr
{ StateStruc model }
- | MODEL_SPEC model = struct_expr WITH
+ | START model = struct_expr WITH
defs = separated_list (SEMICOLON, rel_def_simple)
{ StateStruc (Arena.add_def_rels model defs) }
| MOVES moves = separated_list (SEMICOLON, game_move_timed)
@@ -155,11 +154,6 @@
move_expr:
| ID { Arena.empty_move with rule = $1 }
-struct_location:
- | MODEL_SPEC { Struct }
- | RULE_SPEC id_int LEFT_SPEC { Arena.Left ($2) }
- | RULE_SPEC id_int RIGHT_SPEC { Arena.Right ($2) }
-
parse_game_defs:
game_defs EOF { $1 };
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -11,7 +11,7 @@
let s = "PLAYERS white, black
RULE finish: [ | R(a, b) | ] -> [ | R(a, c); R(c, b) | ] emb R
with [a<-a, b<-b]
-MODEL [a, b | R(a, b) | ]
+START [a, b | R(a, b) | ]
REL P(x) {ex y R(x, y)}
REL Q(x) {ex y R(y, x)}
TIME 7.
@@ -37,7 +37,7 @@
LOC 1 {
PLAYER white { PAYOFF 0.3 } PLAYER black { PAYOFF :(ex x ex y R(y, x)) }
}
-MODEL [a, b | R (a, b) | ]
+START [a, b | R (a, b) | ]
STATE LOC 1
TIME 7.
" in
@@ -58,7 +58,7 @@
LOC 1 {
PLAYER white { PAYOFF 0.3 } PLAYER black { PAYOFF :(ex x ex y R(y, x)) }
}
-MODEL [a, b | R (a, b) | ]
+START [a, b | R (a, b) | ]
STATE LOC 1
TIME 7.
" in
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Client/Style.css 2012-03-11 00:30:10 UTC (rev 1689)
@@ -132,6 +132,12 @@
text-decoration: underline;
}
+#appstorelink {
+ position: absolute;
+ right: 1em;
+ top: 0.5em;
+}
+
.reglabel {
float: left;
clear: left;
Copied: trunk/Toss/Client/img/logo.png (from rev 1688, trunk/Toss/Client/img/toss.png)
===================================================================
(Binary files differ)
Deleted: trunk/Toss/Client/img/toss.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Client/index.html 2012-03-11 00:30:10 UTC (rev 1689)
@@ -22,12 +22,17 @@
<div id="top">
<div id="logo">
<a id="leftupperlogo-link" href="index.html">
- <img id="leftupperlogo-img" src="img/toss.png" alt="tPlay" />
+ <img id="leftupperlogo-img" src="img/logo.png" alt="tPlay" />
</a>
</div>
<span id="localdown" style="position:relative; top: 0.7em;">
<span id="topuser"></span>
</span>
+
+<span id="appstorelink">
+<a href="http://itunes.apple.com/us/app/tplay/id438620686"
+ ><img style="height: 24px;" src="img/appstore-small.png" /></a>
+</span>
</div>
<div id="welcome">
@@ -128,46 +133,8 @@
<li>Challenge your friends or play a fast game against the computer for fun</li>
</ul>
-<div id="news">
-<h3>News</h3>
-<ul id="welcome-list-news" class="welcome-list">
-<li><b>09/03/12</b> First completely working mostly-JS Toss version</li>
-<li><b>05/03/12</b> Fully integrated OCaml and JS debugging and logs</li>
-<li><b>27/02/12</b> Compiled resources to access files from JS</li>
-<li><b>18/02/12</b> Integrating OCaml and JS unit tests</li>
-<li><b>11/02/12</b> Starting systematic unit tests of JS interface</li>
-<li><b>06/02/12</b> Toss release 0.7 with many improvements</li>
-<li><b>04/02/12</b> Definitions use play history: new Chess toss file</li>
-<li><b>02/02/12</b> Improved stand-alone JS interface with menhirLib</li>
-<li><b>31/01/12</b> First stand-alone JS interface (with js_of_ocaml)</li>
-<li><b>22/01/12</b> Learning Connect4 and Gomoku from videos</li>
-<li><b>21/01/12</b> Learning Breakthrough and Pawn-Whopping videos</li>
-<li><b>17/01/12</b> Integrating game learning logic and video stuff</li>
-<li><b>06/01/12</b> Parametrized grid detection for video</li>
-<li><b>28/12/11</b> Game video recognition improved with Hough lines</li>
-<li><b>10/12/11</b> Starting work on game recognition from video</li>
-<li><b>24/10/11</b> Learning games from examples in web interface</li>
-<li><b>19/10/11</b> Games learning engine and first buttons in the UI</li>
-<li><b>14/09/11</b> Simple editing of games added to web interface</li>
-<li><b>31/07/11</b> Store date and time of moves in games</li>
-<li><b>30/07/11</b> Corrected opponent lists in the Profile tab</li>
-<li><b>03/07/11</b> Added game descriptions viewable when playing</li>
-<li><b>30/06/11</b> View previous moves in a play</li>
-<li><b>27/06/11</b> Tabs and searching opponents in the profile page</li>
-<li><b>22/06/11</b> Better organized lists of plays</li>
-<li><b>19/06/11</b> News section on the front page of tPlay</li>
-<li><b>15/06/11</b> Bug with underscores in user names corrected</li>
-<li><b>10/06/11</b> New register site handles forgotten passwords</li>
-<li><b>05/06/11</b> Pre-caching client states improves response times</li>
-<li><b>03/06/11</b> Corrected tPlay 1.1 app accepted on App Store</li>
-<li><b>30/05/11</b> Large restructuring of JavaScript code finished</li>
-<li><b>24/05/11</b> Breakthrough generation from examples in SVN</li>
-<li><b>23/05/11</b> First tPlay application accepted on App Store</li>
-</ul>
</div>
-</div>
-
<div id="nosvg">
<p style="padding-left: 1.2em; font-size: 1.2em;"><b>SVG Support Missing</b></p>
<p>Your browser does not seem to support SVG,
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Formula/Formula.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -179,7 +179,7 @@
Format.fprintf f "%a(%a)" fprint_var r
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
| RealExpr (p, s) ->
- Format.fprintf f "@[(%a %s)@]" (fprint_real_prec 0) p (sign_op_str s)
+ Format.fprintf f "@[(%a%s)@]" (fprint_real_prec 0) p (sign_op_str s)
| Not phi ->
let lb, rb =
if prec > 2 then "(", ")" else "", "" in
@@ -224,7 +224,7 @@
| Plus (r1, Times (Const fl, r2)) when fl = -1. -> (* r1 - r2 short *)
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
+ (fprint_real_prec 0) r1 (fprint_real_prec 1) r2 rb
| Times (r1, r2) ->
let lb, rb =
if prec > 2 then "(", ")" else "", "" in
@@ -455,10 +455,19 @@
and flatten_re_f f_or f_and = function
| RVar _ | Const _ | Fun _ as re -> re
+ | Plus (re1, re2) ->
+ (match flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2 with
+ | (Const 0., flat2) -> flat2
+ | (flat1, Const 0.) -> flat1
+ | (flat1, flat2) -> Plus (flat1, flat2)
+ )
| Times (re1, re2) ->
- Times (flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2)
- | Plus (re1, re2) ->
- Plus (flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2)
+ (match flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2 with
+ | (Const 0., _) | (_, Const 0.) -> Const 0.
+ | (Const 1., flat2) -> flat2
+ | (flat1, Const 1.) -> flat1
+ | (flat1, flat2) -> Times (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)
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -27,7 +27,6 @@
"nnf and parsing" >::
(fun () ->
let nnf_eq phi1 phi2 = formula_eq id phi2 FormulaOps.nnf phi1 in
- nnf_eq "true" "true";
nnf_eq "(not false)" "true";
nnf_eq "not (P(x) and not Q(x))" "not P(x) or Q(x)";
nnf_eq "tc 1 x, y R(x, y)" "x = y or R(x, y)";
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -1,8 +1,12 @@
open OUnit
open Formula
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
let rel r i = Rel (r, Array.make i (`FO "x"))
+
let tests = "Formula" >::: [
"basic flatten" >::
(fun () ->
@@ -37,5 +41,16 @@
assert_equal ~printer:string_of_bool false
(syntax_ok (Lfp (`MSO "X", [|`FO "x"|], Not(In (`FO "x", `MSO "X")))));
);
+
+ "printing and parsing" >::
+ (fun () ->
+ let test_pp f_s = assert_equal ~printer:(fun x -> x) f_s
+ (str (flatten (formula_of_string f_s))) in
+ test_pp "true";
+ test_pp "P(x)";
+ test_pp "ex y (R(x, y) and P(y))";
+ test_pp "all y (R(x, y) or not P(y))";
+ test_pp "(:x - (:y + :z) < 0)";
+ );
]
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Formula/Lexer.mll 2012-03-11 00:30:10 UTC (rev 1689)
@@ -67,7 +67,7 @@
| GET_CMD
| SET_CMD
| LET_CMD
- | EVAL_CMD
+ | START
| ELEM_MOD
| ELEMS_MOD
| REL_MOD
@@ -84,8 +84,6 @@
| MODEL_SPEC
| RULE_SPEC
| STATE_SPEC
- | LEFT_SPEC
- | RIGHT_SPEC
| CLASS
| LFP
| GFP
@@ -212,7 +210,7 @@
| "set" { SET_CMD }
| "LET" { LET_CMD }
| "let" { LET_CMD }
- | "EVAL" { EVAL_CMD }
+ | "START" { START }
| "ELEM" { ELEM_MOD }
| "ELEMS" { ELEMS_MOD }
| "REL" { REL_MOD }
@@ -229,8 +227,6 @@
| "MODEL" { MODEL_SPEC }
| "RULE" { RULE_SPEC }
| "STATE" { STATE_SPEC }
- | "LEFT" { LEFT_SPEC }
- | "RIGHT" { RIGHT_SPEC }
| "class" { CLASS }
| "LFP" { LFP }
| "lfp" { LFP }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Formula/Tokens.mly 2012-03-11 00:30:10 UTC (rev 1689)
@@ -9,9 +9,9 @@
%token OPENCUR CLOSECUR OPENSQ CLOSESQ OPEN CLOSE
%token IN_MOD AND OR XOR NOT EX ALL TC
%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 EVAL_CMD
+%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 LEFT_SPEC RIGHT_SPEC CLASS LFP GFP EOF
+%token MODEL_SPEC RULE_SPEC STATE_SPEC CLASS LFP GFP EOF
/* List in order of increasing precedence. */
%nonassoc LET_CMD
Modified: trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -160,7 +160,7 @@
)
MOVES [m2 -> 0] }
}
-MODEL
+START
[did__BLANK__c1, did__BLANK__c2, did__BLANK__c3, did__BLANK__r1,
did__BLANK__r2, did__BLANK__r3, val__0, val__10, val__100, val__20,
val__30, val__40, val__50, val__80, val__90, val__column, val__row,
Modified: trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -159,7 +159,7 @@
)
MOVES [m2 -> 0] }
}
-MODEL
+START
[did__BLANK__c1, did__BLANK__c2, did__BLANK__c3, did__BLANK__r1,
did__BLANK__r2, did__BLANK__r3, val__0, val__10, val__100, val__20,
val__30, val__40, val__50, val__80, val__90, val__column, val__row,
Modified: trunk/Toss/GGP/tests/2player_normal_form_joint-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/2player_normal_form_joint-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/2player_normal_form_joint-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -160,7 +160,7 @@
)
MOVES [m2 -> 0] }
}
-MODEL
+START
[did__BLANK__c1, did__BLANK__c2, did__BLANK__c3, did__BLANK__r1,
did__BLANK__r2, did__BLANK__r3, val__0, val__10, val__100, val__20,
val__30, val__40, val__50, val__80, val__90, val__column, val__row,
Modified: trunk/Toss/GGP/tests/2player_normal_form_joint-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/2player_normal_form_joint-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/2player_normal_form_joint-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -159,7 +159,7 @@
)
MOVES [m2 -> 0] }
}
-MODEL
+START
[did__BLANK__c1, did__BLANK__c2, did__BLANK__c3, did__BLANK__r1,
did__BLANK__r2, did__BLANK__r3, val__0, val__10, val__100, val__20,
val__30, val__40, val__50, val__80, val__90, val__column, val__row,
Modified: trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -424,7 +424,7 @@
turn_counter1 -> 0]; [turn_counter2 -> 0]
}
}
-MODEL
+START
[val__1, val__10, val__11, val__12, val__13, val__14, val__15, val__16,
val__17, val__18, val__19, val__2, val__20, val__21, val__22, val__23,
val__24, val__25, val__26, val__27, val__28, val__29, val__3, val__30,
Modified: trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -370,7 +370,7 @@
turn_counter1 -> 0]; [turn_counter2 -> 0]
}
}
-MODEL
+START
[val__1, val__10, val__11, val__12, val__13, val__14, val__15, val__16,
val__17, val__18, val__19, val__2, val__20, val__21, val__22, val__23,
val__24, val__25, val__26, val__27, val__28, val__29, val__3, val__30,
Modified: trunk/Toss/GGP/tests/breakthrough-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/breakthrough-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/breakthrough-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -192,7 +192,7 @@
noop_move_x7_y9_x8_y10 -> 0]
}
}
-MODEL
+START
[cellholds_1_1__BLANK_, cellholds_1_2__BLANK_, cellholds_1_3__BLANK_,
cellholds_1_4__BLANK_, cellholds_1_5__BLANK_, cellholds_1_6__BLANK_,
cellholds_1_7__BLANK_, cellholds_1_8__BLANK_, cellholds_2_1__BLANK_,
Modified: trunk/Toss/GGP/tests/breakthrough-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/breakthrough-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/breakthrough-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -121,7 +121,7 @@
noop_move_x7_y9_x8_y10 -> 0]
}
}
-MODEL
+START
[cellholds_1_1__BLANK_, cellholds_1_2__BLANK_, cellholds_1_3__BLANK_,
cellholds_1_4__BLANK_, cellholds_1_5__BLANK_, cellholds_1_6__BLANK_,
cellholds_1_7__BLANK_, cellholds_1_8__BLANK_, cellholds_2_1__BLANK_,
Modified: trunk/Toss/GGP/tests/connect4-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/connect4-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/connect4-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -238,7 +238,7 @@
70. * :((not line__r() and not line__w() and open() and true))
MOVES [noop_drop_c12 -> 0] }
}
-MODEL
+START
[cell_1_0__BLANK_, cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_,
cell_1_4__BLANK_, cell_1_5__BLANK_, cell_1_6__BLANK_, cell_2_0__BLANK_,
cell_2_1__BLANK_, cell_2_2__BLANK_, cell_2_3__BLANK_, cell_2_4__BLANK_,
Modified: trunk/Toss/GGP/tests/connect4-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect4-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/connect4-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -113,7 +113,7 @@
70. * :((open() and not line__r() and not line__w()))
MOVES [noop_drop_c12 -> 0] }
}
-MODEL
+START
[cell_1_0__BLANK_, cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_,
cell_1_4__BLANK_, cell_1_5__BLANK_, cell_1_6__BLANK_, cell_2_0__BLANK_,
cell_2_1__BLANK_, cell_2_2__BLANK_, cell_2_3__BLANK_, cell_2_4__BLANK_,
Modified: trunk/Toss/GGP/tests/connect5-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/connect5-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -377,7 +377,7 @@
50. * :((not exists_line_of_five() and true))
MOVES [noop_mark_x6_y6 -> 0] }
}
-MODEL
+START
[cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_,
cell_a_e__BLANK_, cell_a_f__BLANK_, cell_a_g__BLANK_, cell_a_h__BLANK_,
cell_b_a__BLANK_, cell_b_b__BLANK_, cell_b_c__BLANK_, cell_b_d__BLANK_,
Modified: trunk/Toss/GGP/tests/connect5-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/connect5-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -112,7 +112,7 @@
PLAYER o { PAYOFF 100. * :(conn5__o()) + 50. * :(not exists_line_of_five())
MOVES [noop_mark_x6_y6 -> 0] }
}
-MODEL
+START
[cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_,
cell_a_e__BLANK_, cell_a_f__BLANK_, cell_a_g__BLANK_, cell_a_h__BLANK_,
cell_b_a__BLANK_, cell_b_b__BLANK_, cell_b_c__BLANK_, cell_b_d__BLANK_,
Modified: trunk/Toss/GGP/tests/pacman3p-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/pacman3p-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -522,7 +522,7 @@
move_west1 -> 0]; [move_nowhere1 -> 0]
}
}
-MODEL
+START
[location__BLANK__1_1, location__BLANK__1_2, location__BLANK__1_3,
location__BLANK__1_4, location__BLANK__1_5, location__BLANK__1_6,
location__BLANK__1_7, location__BLANK__1_8, location__BLANK__2_1,
Modified: trunk/Toss/GGP/tests/pacman3p-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/pacman3p-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -393,7 +393,7 @@
move_west1 -> 0]; [move_nowhere1 -> 0]
}
}
-MODEL
+START
[location__BLANK__1_1, location__BLANK__1_2, location__BLANK__1_3,
location__BLANK__1_4, location__BLANK__1_5, location__BLANK__1_6,
location__BLANK__1_7, location__BLANK__1_8, location__BLANK__2_1,
Modified: trunk/Toss/GGP/tests/pawn_whopping-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/pawn_whopping-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/pawn_whopping-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -183,7 +183,7 @@
noop_move_pv12_pv13_pv14_pv15 -> 0]
}
}
-MODEL
+START
[cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_, cell_1_4__BLANK_,
cell_1_5__BLANK_, cell_1_6__BLANK_, cell_1_7__BLANK_, cell_1_8__BLANK_,
cell_2_1__BLANK_, cell_2_2__BLANK_, cell_2_3__BLANK_, cell_2_4__BLANK_,
Modified: trunk/Toss/GGP/tests/pawn_whopping-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/pawn_whopping-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/pawn_whopping-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -124,7 +124,7 @@
noop_move_pv12_pv13_pv14_pv15 -> 0]
}
}
-MODEL
+START
[cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_, cell_1_4__BLANK_,
cell_1_5__BLANK_, cell_1_6__BLANK_, cell_1_7__BLANK_, cell_1_8__BLANK_,
cell_2_1__BLANK_, cell_2_2__BLANK_, cell_2_3__BLANK_, cell_2_4__BLANK_,
Modified: trunk/Toss/GGP/tests/tictactoe-other-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-other-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/tictactoe-other-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -154,7 +154,7 @@
:((not LINE__XPLAYER() and not LINE__OPLAYER() and not OPEN() and true))
MOVES [nOOP_mARK_X10_Y10 -> 0] }
}
-MODEL
+START
[cELL_1_1__BLANK_, cELL_1_2__BLANK_, cELL_1_3__BLANK_, cELL_2_1__BLANK_,
cELL_2_2__BLANK_, cELL_2_3__BLANK_, cELL_3_1__BLANK_, cELL_3_2__BLANK_,
cELL_3_3__BLANK_, val__B, val__OPLAYER, val__XPLAYER, cONTROL__BLANK_ |
Modified: trunk/Toss/GGP/tests/tictactoe-other-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-other-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/tictactoe-other-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -99,7 +99,7 @@
50. * :((not LINE__OPLAYER() and not LINE__XPLAYER() and not OPEN()))
MOVES [nOOP_mARK_X10_Y10 -> 0] }
}
-MODEL
+START
[cELL_1_1__BLANK_, cELL_1_2__BLANK_, cELL_1_3__BLANK_, cELL_2_1__BLANK_,
cELL_2_2__BLANK_, cELL_2_3__BLANK_, cELL_3_1__BLANK_, cELL_3_2__BLANK_,
cELL_3_3__BLANK_, val__B, val__OPLAYER, val__XPLAYER, cONTROL__BLANK_ |
Modified: trunk/Toss/GGP/tests/tictactoe-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-raw.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/tictactoe-raw.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -175,7 +175,7 @@
50. * :((not line__x() and not line__o() and not open() and true))
MOVES [noop_mark_x7_y0 -> 0] }
}
-MODEL
+START
[cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_, cell_2_1__BLANK_,
cell_2_2__BLANK_, cell_2_3__BLANK_, cell_3_1__BLANK_, cell_3_2__BLANK_,
cell_3_3__BLANK_, val__b, val__o, val__oplayer, val__x, val__xplayer,
Modified: trunk/Toss/GGP/tests/tictactoe-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/tictactoe-simpl.toss 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/GGP/tests/tictactoe-simpl.toss 2012-03-11 00:30:10 UTC (rev 1689)
@@ -92,7 +92,7 @@
50. * :((not line__o() and not line__x() and not open()))
MOVES [noop_mark_x7_y0 -> 0] }
}
-MODEL
+START
[cell_1_1__BLANK_, cell_1_2__BLANK_, cell_1_3__BLANK_, cell_2_1__BLANK_,
cell_2_2__BLANK_, cell_2_3__BLANK_, cell_3_1__BLANK_, cell_3_2__BLANK_,
cell_3_3__BLANK_, val__b, val__o, val__oplayer, val__x, val__xplayer,
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Learn/LearnGame.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -148,4 +148,4 @@
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
MOVES [" ^ (mvlst "Mv2r" " -> 0" moves1) ^ "]}
}" ^ "\n" ^
- "MODEL "^(Structure.str (List.hd longest))
+ "START "^(Structure.str (List.hd longest))
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-03-11 00:30:10 UTC (rev 1689)
@@ -5,7 +5,7 @@
let struc_of_string ?(diag=false) s =
if diag then
- let s = "MODEL " ^ s ^ " with Da (x, y) = ex u (R(x, u) and C(u, y));" ^
+ 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
@@ -70,7 +70,7 @@
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
MOVES [Mv2r0 -> 0]}
}
-MODEL [ | P:1 {}; Q:1 {} | ] R R \"
+START [ | P:1 {}; Q:1 {} | ] R R \"
. .
\"" in
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-03-09 22:49:49 UTC (rev 1688)
+++ trunk/Toss/Makefile 2012-03-11 00:30:10 UTC (rev 1689)
@@ -48,6 +48,7 @@
@echo " CONDITIONAL COMPILATION USES"
@grep IFDEF $(ALLMLFILES)
@echo ""
+ @grep MODEL $(ALLMLFILES)
# ------ NON OCAMLBUILD DEPENDENCIES --------
@@ -114,7 +115,6 @@
FormulaINCSatINC=MenhirLib,Formula
FormulaINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll
SolverINC=MenhirLib,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num
-SolverINCNumINC=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,Form...
[truncated message content] |
|
From: <luk...@us...> - 2012-03-11 17:33:27
|
Revision: 1690
http://toss.svn.sourceforge.net/toss/?rev=1690&view=rev
Author: lukaszkaiser
Date: 2012-03-11 17:33:19 +0000 (Sun, 11 Mar 2012)
Log Message:
-----------
General cleanups and Client work.
Modified Paths:
--------------
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/FormulaTest.ml
trunk/Toss/GGP/Makefile
trunk/Toss/Server/Server.ml
Removed Paths:
-------------
trunk/Toss/Client/Local.js
Deleted: trunk/Toss/Client/Local.js
===================================================================
--- trunk/Toss/Client/Local.js 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Client/Local.js 2012-03-11 17:33:19 UTC (rev 1690)
@@ -1,68 +0,0 @@
-// Handle communication with the worker thread. Introduce helper
-// functions originally in Connect.js.
-
-// Important helper function for unit tests: dispatch a click event
-function clickId (id) {
- var elem = document.getElementById (id);
- var event = document.createEvent ("MouseEvents");
- event.initMouseEvent("click", true, true, window, 0, 0, 0, 0, 0,
- false, false, false, false, 0, null);
- elem.dispatchEvent(event);
-}
-
-// Important helper function for unit tests: check if [id] exists in document
-function existsId (id) {
- if (document.getElementById (id) == undefined) {
- return ("not found: " + id);
- } else { return (""); }
-}
-
-// Strip [c1] and [c2] from beginning and end of [str].
-function strip (c1, c2, str) {
- if (str.length == 0) return (str);
- var i = 0; var j = 0;
- for (i = 0; i < str.length; i++) {
- if (str.charAt(i) != c1 && str.charAt(i) != c2) break;
- }
- for (j = str.length - 1; j > -1; j--) {
- if (str.charAt(j) != c1 && str.charAt(j) != c2) break;
- }
- if (i > j) { return ("") };
- return (str.substring(i, j+1));
-}
-
-// Convert a string [str] representing python list to array and return it.
-// WARNING: we use [sep] as separator, it must not occur in list elements!
-function parse_list (sep, str_in) {
- var res_arr = [];
- var str = strip(' ', '\n', str_in);
- res_arr = strip('[', ']', str).split(sep);
- if (res_arr.length == 1 && res_arr[0] == "") { return ([]); }
- for (i = 0; i < res_arr.length; i++) {
- res_arr[i] = strip (' ', '\'', res_arr[i])
- }
- return (res_arr);
-}
-
-// ********************************************************************
-// Web-Worker thread
-
-var worker = new Worker ("JsHandler.js");
-var worker_handler = new Object ();
-
-worker.onmessage = function (m) {
- if (typeof m.data == 'string') {
- console.log("" + m.data);
- } else {
- console.log ("[0@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 ("[0@Asynch] " + action_name + " " + action_args);
-}
-
Modified: trunk/Toss/Client/Main.js
===================================================================
--- trunk/Toss/Client/Main.js 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Client/Main.js 2012-03-11 17:33:19 UTC (rev 1690)
@@ -1,5 +1,28 @@
// JavaScript Toss Module -- Main (requires State.js, Play.js)
+// --- Web-Worker thread handling ---
+
+var worker = new Worker ("JsHandler.js");
+var worker_handler = new Object ();
+
+worker.onmessage = function (m) {
+ if (typeof m.data == 'string') {
+ console.log("" + m.data);
+ } else {
+ console.log ("[0@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 ("[0@Asynch] " + action_name + " " + action_args);
+}
+
+// --- End of Web-Worker thread handling ---
+
var UNAME = "";
var GAME_NAME = ""; // name of current game, e.g. "Breakthrough"
var PLAY = [];
@@ -36,11 +59,11 @@
}
-function startup_local () {
+function startup () {
// should do some work here perhaps
}
-function new_play_local (game) {
+function new_play_click (game) {
GAME_NAME = game;
UNAME = "guest";
document.getElementById ("topuser").innerHTML = game;
@@ -60,18 +83,18 @@
gd.style.display = "block";
gd.setAttribute ("class", "Game-" + GAME_NAME);
document.getElementById ("game-title").innerHTML = GAME_NAME;
- document.getElementById ("suggestions-toggle").style.display = "none";
- FREE_PLAY_NO = 1;
- var state_str;
- // state_str is either a state string, or a record of state data
+ 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-desc-controls").style.display = "block";
document.getElementById ("suggestions-toggle").style.display = "inline";
- document.getElementById ("play-number").innerHTML = "" + FREE_PLAY_NO;
document.getElementById ("game-disp").style.display = "block";
document.getElementById ("plays").style.left = "30em";
- var p = new Play (GAME_NAME, [0,1], [UNAME, opp_uid], FREE_PLAY_NO, 0,
+ var p = new Play (GAME_NAME, [0,1], [UNAME, opp_uid], 1, 0,
state_str, UNAME);
console.log ("new_play_do callback: play created");
PLAY = p;
@@ -79,7 +102,6 @@
ASYNCH ("precache", [0.5], function () {});
continuation ();
}
- // LOCAL.new_play returns info_obj (not a string)
ASYNCH ("new_play", [GAME_NAME, UNAME, opp_uid], build_play);
}
@@ -170,12 +192,14 @@
if (m != "") { PLAY.show_move (new Move (m)); f() }
}
var fm_check = function (m) {
- if (DONE_MOVES_MARKER[MOVE_INDEX] === false) {
- DONE_MOVES_MARKER[MOVE_INDEX] = true;
- fm (m);
- } else {
- console.log ("Discarded " + m.comp_iters +" iterations.");
- }
+ window.setTimeout (function () { // wait for server
+ if (DONE_MOVES_MARKER[MOVE_INDEX] === false) {
+ DONE_MOVES_MARKER[MOVE_INDEX] = true;
+ fm (m);
+ } else {
+ console.log ("Discarded " + m.comp_iters +" iterations.");
+ }
+ }, 700); // wait 500 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
@@ -185,14 +209,14 @@
DONE_MOVES_MARKER[MOVE_INDEX] = false;
var server_move = function (msg) {
async_server_msg (msg, false, function (resp) {
- if (resp !== "" && DONE_MOVES_MARKER[MOVE_INDEX] === false) {
+ if (resp !== "" && resp.indexOf("<html>") === -1 &&
+ DONE_MOVES_MARKER[MOVE_INDEX] === false) {
DONE_MOVES_MARKER[MOVE_INDEX] = true;
ASYNCH ("suggested_move", [resp], fm)
} })
}
ASYNCH ("gameinfo", [time], server_move);
- ASYNCH ("suggest", [PLAY.cur_state.players[0]+1,
- time + .5], fm_check); // wait 0.5s for server
+ ASYNCH ("suggest", [PLAY.cur_state.players[0]+1, time - 0.2], fm_check);
}
function suggest_move_click () {
@@ -216,14 +240,12 @@
var txt = document.getElementById ("suggestions-toggle").innerHTML;
if (txt.indexOf ("Before") == -1) {
SIMPLE_MOVES = true;
- document.getElementById ("play-nbr-info").style.display = "none";
document.getElementById ("board").style.paddingTop = "1em";
document.getElementById ("suggestions-toggle").innerHTML =
"Ask Before Move";
document.getElementById ("move-info-par").style.display = "none";
} else {
SIMPLE_MOVES = false;
- document.getElementById ("play-nbr-info").style.display = "inline";
document.getElementById ("game-title").style.display = "inline";
document.getElementById ("game-title-move").style.display = "inline";
document.getElementById ("board").style.paddingTop = "0em";
@@ -232,3 +254,34 @@
document.getElementById ("move-info-par").style.display = "block";
}
}
+
+function toggle_more_games () {
+ var bt = document.getElementById ("more-games-bt");
+ if (bt.innerHTML.indexOf ("More") > -1) {
+ bt.innerHTML = "Less Games";
+ document.getElementById ("moregames").style.display = "block";
+ } else {
+ bt.innerHTML = "More Games";
+ document.getElementById ("moregames").style.display = "none";
+ }
+}
+
+
+
+// ----- Helper functions for Unit Tests -----------
+
+// Important helper function for unit tests: dispatch a click event
+function clickId (id) {
+ var elem = document.getElementById (id);
+ var event = document.createEvent ("MouseEvents");
+ event.initMouseEvent("click", true, true, window, 0, 0, 0, 0, 0,
+ false, false, false, false, 0, null);
+ elem.dispatchEvent(event);
+}
+
+// Important helper function for unit tests: check if [id] exists in document
+function existsId (id) {
+ if (document.getElementById (id) == undefined) {
+ return ("not found: " + id);
+ } else { return (""); }
+}
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Client/Play.js 2012-03-11 17:33:19 UTC (rev 1690)
@@ -284,7 +284,7 @@
}
var subst_pl = function (pl, str) {
var un = pl.cur_player_uid;
- var s = strip (' ', '\n', str);
+ var s = str; //strip (' ', '\n', str);
if (s == "0: 1., 1: -1." || s == "1: 1, 2: -1") {
return (win_s (pl.players[0], un));
}
Modified: trunk/Toss/Client/State.js
===================================================================
--- trunk/Toss/Client/State.js 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Client/State.js 2012-03-11 17:33:19 UTC (rev 1690)
@@ -9,38 +9,15 @@
// ------ Move Object -----
// Create a move from the string, or object, [s_or_o].
-function Move (s_or_o) {
- var s, o;
- var is_conn = typeof s_or_o === 'string';
- if (is_conn) s = s_or_o;
- else o = s_or_o;
- var vals = [];
- if (is_conn) {
- var arr = strip('(', ')', s).split(',');
- for (var i = 0; i < arr.length; i++) {
- if (arr[i].indexOf(':') > -1) {
- var v = arr[i].substring (arr[i].indexOf(':')+1, arr[i].length);
- vals.push (strip ('\'', ' ', strip ('{', '}', v)));
- }
- }
- } else {
- vals = o.matched;
- }
+function Move (o) {
+ var vals = o.matched;
vals.sort ();
this.matched = vals;
this.length = vals.length;
- // TODO: move to players named in the game by arbitrary strings
- if (is_conn) {
- this.rule = strip("'", " ", s.substring
- (s.indexOf("},")+3, s.lastIndexOf(',')));
- this.player = parseInt(s.substring(0, 1)) - 1;
- this.def_str = s;
- } else {
- this.rule = o.rule;
- this.player = parseInt(o.player) - 1;
- this.id = o.id; // move number for the local interface
- }
- this.matched_str = strip (' ', ' ', this.matched.toString ());
+ this.rule = o.rule;
+ this.player = parseInt(o.player) - 1;
+ this.id = o.id; // move number for the local interface
+ this.matched_str = this.matched.toString();
return (this)
}
@@ -76,19 +53,11 @@
// Object representing a state of the system (game).
-function State (game, info_string_or_obj, mirror) {
+function State (game, info_obj, mirror) {
// We create an SVG box with margins depending on the game.
this.game = game;
this.mirror = mirror;
- var info_string, info_obj;
- var is_conn = typeof info_string_or_obj === 'string';
- if (is_conn) {
- info_string = info_string_or_obj;
- } else {
- info_obj = info_string_or_obj;
- }
-
var create_svg_box = function (margx, margy, parent_id) {
var svg_e = document.getElementById("svg");
if (svg_e != null) { svg_e.parentNode.removeChild (svg_e); }
@@ -119,48 +88,22 @@
return ([x + SVG_MARGINX, y + SVG_MARGINY])
};
- // The info is a $-separated array of 4 components.
- var res_arr = [];
- if (is_conn) {
- res_arr = info_string.split("$");
- if (res_arr.length != 4) { alert (res_arr); return (undefined); }
-
- // The first component gives the dimenstions of the structure.
- var dim = strip('(', ')', res_arr[0]).split(',');
- this.maxx = parseFloat(strip(' ', ' ', dim[0]));
- this.minx = parseFloat(strip(' ', ' ', dim[1]));
- this.maxy = parseFloat(strip(' ', ' ', dim[2]));
- this.miny = parseFloat(strip(' ', ' ', dim[3]));
- } else {
- this.maxx = info_obj.maxx;
- this.minx = info_obj.minx;
- this.maxy = info_obj.maxy;
- this.miny = info_obj.miny;
- }
+ this.maxx = info_obj.maxx;
+ 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));
- // The second component is the list of elements of the structure.
- if (is_conn) {
- var l = parse_list(',', res_arr[1]);
- this.elems = [];
- for (var i = 0; i < l.length; i++) {
- var e = parse_list (';', l[i]);
- var pos = translate_pos ([parseFloat(e[1]), parseFloat(e[2])],
- this.minx, this.miny,
- this.width, this.height, this.mirror);
- this.elems.push (new Elem (e[0], pos[0], pos[1]));
- }
- } else {
- var els = info_obj.elems;
- this.elems = [];
- for (var i = 0; i < els.length; i++) {
- var e = els[i];
- var pos = translate_pos ([e[1], e[2]],
- this.minx, this.miny,
- this.width, this.height, this.mirror);
- this.elems.push (new Elem (e[0], pos[0], pos[1]));
- }
+ // List elements of the structure.
+ var els = info_obj.elems;
+ this.elems = [];
+ for (var i = 0; i < els.length; i++) {
+ var e = els[i];
+ var pos = translate_pos ([e[1], e[2]],
+ this.minx, this.miny,
+ this.width, this.height, this.mirror);
+ this.elems.push (new Elem (e[0], pos[0], pos[1]));
}
var find_elem = function (elem_id, els) {
@@ -170,45 +113,23 @@
return (undefined);
}
- // The third component are the relations in the structure.
- if (is_conn) {
- var r = parse_list(';', res_arr[2]);
- var rels = [];
- for (var i = 0; i < r.length; i++) {
- var rel_name =
- strip(' ', '\'', r[i].substring(1,r[i].indexOf(',')));
- var args_s =
- r[i].substring(r[i].indexOf('[')+1, r[i].indexOf(']'));
- var args = parse_list (',', args_s);
- var is_undefined = false;
- for (var j = 0; j < args.length; j++) {
- args[j] = find_elem (args[j], this.elems);
- if (args[j] == undefined) { is_undefined = true };
- }
- if (rel_name[0] != "_" && rel_name[0] != "-" &&
- args_s != "''" && is_undefined == false) {
- rels.push (new Rel (rel_name, args));
- }
+ // Relations in the structure.
+ var rels = [];
+ var r = info_obj.rels;
+ for (var i = 0; i < r.length; i++) {
+ var rel_name = info_obj.rel_names[i];
+ var args = r[i];
+ var is_undefined = false;
+ for (var j = 0; j < args.length; j++) {
+ args[j] = find_elem (args[j], this.elems);
+ if (args[j] == undefined) { is_undefined = true };
+ }
+ if (rel_name != undefined && rel_name[0] != "_" && rel_name[0] != "-" &&
+ args.length > 0 && is_undefined == false) {
+ rels.push (new Rel (rel_name, args));
}
- this.rels = rels;
- } else {
- var rels = [];
- var r = info_obj.rels;
- for (var i = 0; i < r.length; i++) {
- var rel_name = info_obj.rel_names[i];
- var args = r[i];
- var is_undefined = false;
- for (var j = 0; j < args.length; j++) {
- args[j] = find_elem (args[j], this.elems);
- if (args[j] == undefined) { is_undefined = true };
- }
- if (rel_name != undefined && rel_name[0] != "_" && rel_name[0] != "-" &&
- args.length > 0 && is_undefined == false) {
- rels.push (new Rel (rel_name, args));
- }
- }
- this.rels = rels;
- }
+ }
+ this.rels = rels;
var in_lst = function (lst, elem) {
for (var j = 0; j < lst.length; j++) {
@@ -220,40 +141,19 @@
// info_obj.moves is list of possible moves (records from which
// Move constructor takes data), info_obj.result are payoffs if
// there are no moves.
- if (!is_conn) {
- if (typeof info_obj.result != 'undefined') {
- this.players = [];
- this.result = info_obj.result;
- var payoffs = [];
- for (var player in info_obj.result) {
- payoffs.push (player + ': ' + info_obj.result[player]);
- }
- this.payoff = payoffs.join (', ');
- } else { // same as the code below (for CONN), but without parsing
- var mvs = [];
- var pls = [];
- for (i = 0; i < info_obj.moves.length; i++) {
- var new_mv = new Move (info_obj.moves[i]);
- mvs.push (new_mv);
- if (! in_lst(pls, new_mv.player)) { pls.push (new_mv.player); }
- }
- console.log (pls);
- this.moves = mvs;
- this.players = pls;
- this.payoff = "";
- this.result = null;
+ if (typeof info_obj.result != 'undefined') {
+ this.players = [];
+ this.result = info_obj.result;
+ var payoffs = [];
+ for (var player in info_obj.result) {
+ payoffs.push (player + ': ' + info_obj.result[player]);
}
- return (this);
- }
- // The fourth component is either the list of possible moves.
- // If there are no moves possible, it is the payoff.
- // The second option in "or" below is just for old format, will be removed.
- if (res_arr[3].substring(2, 3) =="(" || res_arr[3].substring(0, 1) =="(") {
- var move_strs = parse_list (';', res_arr[3]);
+ this.payoff = payoffs.join (', ');
+ } else {
var mvs = [];
var pls = [];
- for (i = 0; i < move_strs.length; i++) {
- var new_mv = new Move (move_strs[i]);
+ for (i = 0; i < info_obj.moves.length; i++) {
+ var new_mv = new Move (info_obj.moves[i]);
mvs.push (new_mv);
if (! in_lst(pls, new_mv.player)) { pls.push (new_mv.player); }
}
@@ -261,19 +161,7 @@
this.players = pls;
this.payoff = "";
this.result = null;
- } else {
- this.moves = [];
- this.players = [];
- this.payoff = res_arr[3];
- this.result = new Object();
- var players_pays = this.payoff.split(', ');
- for (var i = 0; i < players_pays.length; i++)
- {
- var help = players_pays[i].split(': ');
- this.result[help[0]] = parseFloat(help[1]);
- }
- };
-
+ }
return (this);
}
Modified: trunk/Toss/Client/Style.css
===================================================================
--- trunk/Toss/Client/Style.css 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Client/Style.css 2012-03-11 17:33:19 UTC (rev 1690)
@@ -156,19 +156,68 @@
height: 35em;
}
+.game-line {
+ position: relative;
+ top: 0px;
+ left: 0px;
+ width: 100%;
+ height: 100%;
+ text-align: justify;
+ display: block;
+}
+
+#more-games-bt-div {
+ margin-top: 1em;
+ margin-bottom: 1em;
+ text-align: center;
+ width: 100%;
+}
+
+#moregames {
+ display: none;
+}
+
+.game-picdiv1 {
+ position: relative;
+ top: 0px;
+ left: 0px;
+ width: 32%;
+ text-align: center;
+}
+.game-picdiv2 {
+ position: absolute;
+ top: 0px;
+ left: 33%;
+ width: 32%;
+ text-align: center;
+}
+.game-picdiv3 {
+ position: absolute;
+ top: 0px;
+ left: 66%;
+ width: 32%;
+ text-align: center;
+}
+
.game-picbt {
position: relative;
- top:0px;
- left:0px;
+ top: 0px;
+ left: 0px;
text-align: center;
- width:32%;
- text-align: center;
border-width: 0px;
color: #260314;
background-color: #fff1d4;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
}
+.game-picbt:hover {
+ cursor: pointer;
+}
+
+.game-picimg {
+ max-width: 95%;
+}
+
.game-picspan {
position: absolute;
top: 50%;
@@ -425,9 +474,11 @@
margin-right: 0em;
}
-.toprighttab {
- position: relative;
- top: 0.8em;
+#toprighttab {
+ display: none;
+ position: absolute;
+ right: 1em;
+ top: 1.3em;
background-color: #260314;
border-color: #fff1d4;
border-style: solid;
@@ -435,6 +486,9 @@
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;
}
@@ -492,10 +546,6 @@
-moz-border-radius: 0px 0px 6px 6px;
}
-#toss-link {
- display: none;
-}
-
#suggestions-toggle {
margin: 0px;
padding-top: 0px;
@@ -508,6 +558,10 @@
cursor: pointer;
}
+#sugbt {
+ display: none;
+}
+
/* Menu styles. */
#menu-top-par {
@@ -540,6 +594,10 @@
padding-bottom: 1em;
}
+#game-descs {
+ margin-bottom: 0.5em;
+}
+
.game-desc a, .game-desc a:link, .game-desc a:active, .game-desc a:visited {
color: #260314;
text-decoration: underline;
@@ -906,12 +964,14 @@
/* SVG styling */
#svg {
+ /* max-width: 40em;
+ width: 80%; */
+ height: 32em;
+ max-width: 32em;
+ min-height: 10em;
min-width: 10em;
- max-width: 120em;
- width: 80%;
- min-height: 10em;
- max-height: 40em;
- height: 80%;
+ /* max-height: 40em;
+ height: 40%; */
/* border: 1px solid #260314; */
}
Modified: trunk/Toss/Client/index.html
===================================================================
--- trunk/Toss/Client/index.html 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Client/index.html 2012-03-11 17:33:19 UTC (rev 1690)
@@ -8,13 +8,12 @@
<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="Local.js"> </script>
<script type="text/javascript" src="State.js"> </script>
<script type="text/javascript" src="Play.js"> </script>
<script type="text/javascript" src="Main.js"> </script>
</head>
-<body onload="startup_local('')">
+<body onload="startup ('')">
<div id="main">
@@ -28,11 +27,11 @@
<span id="localdown" style="position:relative; top: 0.7em;">
<span id="topuser"></span>
</span>
-
<span id="appstorelink">
<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>
</div>
<div id="welcome">
@@ -42,75 +41,89 @@
with our best interface on <span class="logo-in">tPlay</span>!
</p>
-<p style="width:100%; text-align: justify;">
-<button onclick="new_play_local('Pawn-Whopping')" class="game-picbt"
- class="boldobt" title="Play Pawn-Whopping">
- <img style="max-width:95%" src="img/Pawn-Whopping.png"
+<div class="game-line">
+<div class="game-picdiv1">
+<button onclick="new_play_click ('Pawn-Whopping')" class="game-picbt">
+ <img class="game-picimg" src="img/Pawn-Whopping.png"
alt="Pawn-Whopping Board" />
<span id="pdescPawn-Whopping" class="game-picspan">
<span class="game-pictxt">Pawn-Whopping</span>
</span>
</button>
-<button onclick="new_play_local('Connect4')" class="game-picbt"
- class="boldobt" title="Play Connect4">
- <img style="max-width:95%" src="img/Connect4.png" alt="Connect4 Board" />
+</div>
+<div class="game-picdiv2">
+<button onclick="new_play_click ('Connect4')" class="game-picbt">
+ <img class="game-picimg" src="img/Connect4.png" alt="Connect4 Board" />
<span id="pdescConnect4" class="game-picspan">
<span class="game-pictxt">Connect4</span>
</span>
</button>
-<button onclick="new_play_local('Breakthrough')" class="game-picbt"
- class="boldobt" title="Play Breakthrough">
- <img style="max-width:95%" src="img/Breakthrough.png"
+</div>
+<div class="game-picdiv3">
+<button onclick="new_play_click ('Breakthrough')" class="game-picbt">
+ <img class="game-picimg" src="img/Breakthrough.png"
alt="Breakthrough Board" />
<span id="pdescBreakthrough" class="game-picspan">
<span class="game-pictxt">Breakthrough</span>
</span>
</button>
-</p>
+</div>
+</div>
-<p style="width:100%; text-align: justify">
-<button onclick="new_play_local('Tic-Tac-Toe')" class="game-picbt"
- class="boldobt" title="Play Tic-Tac-Toe" id="btPlayTic-Tac-Toe">
- <img style="max-width:95%" src="img/Tic-Tac-Toe.png"
+<div class="game-line">
+<div class="game-picdiv1">
+<button onclick="new_play_click ('Tic-Tac-Toe')" class="game-picbt"
+ id="btPlayTic-Tac-Toe">
+ <img class="game-picimg" src="img/Tic-Tac-Toe.png"
alt="Tic-Tac-Toe Board" />
<span id="pdescTic-Tac-Toe" class="game-picspan">
<span class="game-pictxt">Tic-Tac-Toe</span>
</span>
</button>
-<button onclick="new_play_local('Checkers')" class="game-picbt"
- class="boldobt" title="Play Checkers">
- <img style="max-width:95%" src="img/Checkers.png" alt="Checkers Board" />
+</div>
+<div class="game-picdiv2">
+<button onclick="new_play_click ('Checkers')" class="game-picbt">
+ <img class="game-picimg" src="img/Checkers.png" alt="Checkers Board" />
<span id="pdescCheckers" class="game-picspan">
<span class="game-pictxt">Checkers</span>
</span>
</button>
-<button onclick="new_play_local('Gomoku')" class="game-picbt"
- class="boldobt" title="Play Gomoku">
- <img style="max-width:95%" src="img/Gomoku.png" alt="Gomoku Board" />
+</div>
+<div class="game-picdiv3">
+<button onclick="new_play_click ('Gomoku')" class="game-picbt">
+ <img class="game-picimg" src="img/Gomoku.png" alt="Gomoku Board" />
<span id="pdescGomoku" class="game-picspan">
<span class="game-pictxt">Gomoku</span>
</span>
</button>
-</p>
+</div>
+</div>
-<p id="moregames" style="width:100%; text-align: justify; display: none;">
-<button onclick="new_play_local('Chess')" class="game-picbt"
- class="boldobt" title="Play Chess">
- <img style="max-width:95%" src="img/Chess.png"
+<div id="more-games-bt-div">
+ <button id="more-games-bt" class="obt" onclick="toggle_more_games()"
+ >More Games</button>
+</div>
+
+<div id="moregames" 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>
+ </span>
+</button>
+</div>
+<div class="game-picdiv2">
+<button onclick="new_play_click ('Chess')" class="game-picbt">
+ <img class="game-picimg" src="img/Chess.png"
alt="Chess Board" />
<span id="pdescChess" class="game-picspan">
<span class="game-pictxt">Chess</span>
</span>
</button>
-<button onclick="new_play_local('Entanglement')" class="game-picbt"
- class="boldobt" title="Play Entanglement">
- <img style="max-width:95%" src="img/Entanglement.png"
- alt="Entanglement Graph" />
- <span id="pdescEntanglement" class="game-picspan">
- <span class="game-pictxt">Entanglement</span>
- </span>
-</button>
-</p>
+</div>
+</div>
<ul id="welcome-list-main" class="welcome-list">
<li>Play
@@ -159,9 +172,6 @@
<div id="game-disp">
<p id="game-info-par">
<span id="game-title"></span>
- <span id="play-nbr-info" style="display:none;">
- (game <span id="play-number">?</span>)
- </span>
<span id="game-title-move">Move <span id="movenbr">?</span>
<button id="prevmovebt" class="bt" onclick="prev_move_click()">
–
@@ -367,9 +377,7 @@
<div id="bottom">
<div id="bottomright">
- <a href="http://toss.sourceforge.net" id="toss-link">
- Powered by Toss
- </a>
+ <a href="http://toss.sourceforge.net" id="toss-link">Contact</a>
<button id="suggestions-toggle" style="display: none;"
onclick="toggle_suggestions()">
Ask Before Move
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-03-11 17:33:19 UTC (rev 1690)
@@ -51,6 +51,7 @@
test_pp "ex y (R(x, y) and P(y))";
test_pp "all y (R(x, y) or not P(y))";
test_pp "(:x - (:y + :z) < 0)";
+ test_pp "(:x - :y + :z < 0)";
);
]
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/GGP/Makefile 2012-03-11 17:33:19 UTC (rev 1690)
@@ -12,13 +12,13 @@
%.black: examples/%.gdl
make -C ..
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -nocache -d 1 &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -noprecache -d 1 &
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
%.white: examples/%.gdl
make -C ..
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -nocache -d 1 &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -noprecache -d 1 &
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-03-11 00:30:10 UTC (rev 1689)
+++ trunk/Toss/Server/Server.ml 2012-03-11 17:33:19 UT...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X