Thread: [Toss-devel-svn] SF.net SVN: toss:[1626] trunk/Toss (Page 11)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2011-11-10 23:59:50
|
Revision: 1626
http://toss.svn.sourceforge.net/toss/?rev=1626&view=rev
Author: lukaszkaiser
Date: 2011-11-10 23:59:43 +0000 (Thu, 10 Nov 2011)
Log Message:
-----------
Corrections to compile on older OCaml 3.11.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Server/LearnGame.ml
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2011-11-10 01:26:59 UTC (rev 1625)
+++ trunk/Toss/Arena/ContinuousRule.ml 2011-11-10 23:59:43 UTC (rev 1626)
@@ -30,7 +30,8 @@
let inv = FormulaSubst.subst_rels defs inv in
let post = FormulaSubst.subst_rels defs post in
(*let obj = DiscreteRule.compile_rule signat defs discrete in*)
- { discrete; dynamics; update; inv; post; }
+ { discrete = discrete; dynamics = dynamics; update = update;
+ inv = inv; post = post; }
@@ -52,7 +53,7 @@
else
{ struc_r with DiscreteRule.rhs_struc = res_struc } in
let discrete = DiscreteRule.compile_rule signat defs struc_r in
- {r with discrete}
+ {r with discrete = discrete}
let lhs r =
match r.discrete.DiscreteRule.struc_rule with
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-11-10 01:26:59 UTC (rev 1625)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-11-10 23:59:43 UTC (rev 1626)
@@ -2604,12 +2604,12 @@
let del_tuples = Aux.collect del in
let discrete = {
DiscreteRule.struc_rule = None;
- lhs_vars;
- rhs_vars;
- add_tuples;
- del_tuples;
- match_formula = precond;
- rlmap = None
+ DiscreteRule.lhs_vars = lhs_vars;
+ DiscreteRule.rhs_vars = rhs_vars;
+ DiscreteRule.add_tuples = add_tuples;
+ DiscreteRule.del_tuples = del_tuples;
+ DiscreteRule.match_formula = precond;
+ DiscreteRule.rlmap = None
} in
let rule =
ContinuousRule.make_rule [] discrete [] updates () in
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-11-10 01:26:59 UTC (rev 1625)
+++ trunk/Toss/Play/Heuristic.ml 2011-11-10 23:59:43 UTC (rev 1626)
@@ -1075,8 +1075,9 @@
let use_monotonic = ref true
-let default_heuristic_old ?struc ?advr
- ({Arena.rules; graph; starting_struc} as game) =
+let default_heuristic_old ?struc ?advr game =
+ let (rules, graph, starting_struc) =
+ (game.Arena.rules, game.Arena.graph, game.Arena.starting_struc) in
(* TODO: cache the default heuristic in game definition or state *)
let drules =
List.map (fun r -> (snd r).ContinuousRule.discrete) rules in
Modified: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml 2011-11-10 01:26:59 UTC (rev 1625)
+++ trunk/Toss/Server/LearnGame.ml 2011-11-10 23:59:43 UTC (rev 1626)
@@ -22,12 +22,14 @@
Distinguish.distinguish winningStates notWinningStates
let cleanStructure struc =
- let funs = List.map fst (Structure.StringMap.bindings (Structure.functions struc)) in
+ let funs = ref [] in
+ let append_fun f _ = funs := f :: !funs in
+ Structure.StringMap.iter append_fun (Structure.functions struc);
let struc = StructureParser.parse_structure Lexer.lex (Lexing.from_string (Structure.str struc)) in
Structure.replace_names (List.fold_left
(fun x y ->
Structure.clear_fun x y)
- struc funs) Structure.StringMap.empty
+ struc !funs) Structure.StringMap.empty
Structure.IntMap.empty
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-11 00:56:24
|
Revision: 1627
http://toss.svn.sourceforge.net/toss/?rev=1627&view=rev
Author: lukaszkaiser
Date: 2011-11-11 00:56:17 +0000 (Fri, 11 Nov 2011)
Log Message:
-----------
Making Aux.unique_sorted tail-recursive, corrects segfault in GDL translation of satlike.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/GGP/GDL.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-10 23:59:43 UTC (rev 1626)
+++ trunk/Toss/Formula/Aux.ml 2011-11-11 00:56:17 UTC (rev 1627)
@@ -340,13 +340,12 @@
| [] -> acc in
List.rev (aux (List.rev l2) l1)
-(* Not tail-recursive. *)
let unique_sorted ?(cmp = Pervasives.compare) l =
- let rec idemp = function
- | e1::(e2::_ as tl) when cmp e1 e2 = 0 -> idemp tl
- | e::tl -> e::idemp tl
- | [] -> [] in
- idemp (List.sort cmp l)
+ let rec idemp acc = function
+ | e1::(e2::_ as tl) when cmp e1 e2 = 0 -> idemp acc tl
+ | e::tl -> idemp (e::acc) tl
+ | [] -> acc in
+ idemp [] (List.sort (fun x y -> - (cmp x y)) l)
let all_subsets ?max_size set =
let size = match max_size with Some i -> i | None -> List.length set in
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-11-10 23:59:43 UTC (rev 1626)
+++ trunk/Toss/GGP/GDL.ml 2011-11-11 00:56:17 UTC (rev 1627)
@@ -637,15 +637,16 @@
(rel_atoms_str new_base3)
);
(* }}} *)
- let new_base = build_graph
- (new_base1 @ new_base2 @ new_base3)
- and new_irules = Aux.unique_sorted
- (new_irules1 @ new_irules2 @ new_irules3) in
+ let append_base = List.rev_append (List.rev new_base1)
+ (List.rev_append (List.rev new_base2) new_base3) in
+ let new_base = build_graph append_base
+ and all_new_irules =
+ List.rev_append (List.rev_append new_irules1 new_irules2) new_irules3 in
+ let new_irules = Aux.unique_sorted all_new_irules in
(* [new_base] is already disjoint from [base] *)
let new_irules = Aux.sorted_diff new_irules irules in
- if Aux.StrMap.is_empty new_base && new_irules = []
- then base
- else inst_stratum base irules new_base new_irules in
+ if Aux.StrMap.is_empty new_base && new_irules = [] then base else
+ inst_stratum base irules new_base new_irules in
let rec instantiate base = function
| [] -> base
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-11 22:08:45
|
Revision: 1628
http://toss.svn.sourceforge.net/toss/?rev=1628&view=rev
Author: lukaszkaiser
Date: 2011-11-11 22:08:39 +0000 (Fri, 11 Nov 2011)
Log Message:
-----------
More tail-recursiveness corrections for GDL translation, some added timeouts.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/TranslateGame.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-11 00:56:17 UTC (rev 1627)
+++ trunk/Toss/Formula/Aux.ml 2011-11-11 22:08:39 UTC (rev 1628)
@@ -246,23 +246,24 @@
try f hd
with Not_found -> find_try f tl
-let rec fold_left_try f accu l =
- match l with
- [] -> accu
- | a::l ->
- try
- fold_left_try f (f accu a) l
- with Not_found -> fold_left_try f accu l
+let rec fold_left_try f accu = function
+ | [] -> accu
+ | a::l ->
+ let new_accu = try f accu a with Not_found -> accu in
+ fold_left_try f new_accu l
-let rec power dom img =
- List.fold_right (fun v sbs ->
- concat_map (fun e -> List.map (fun sb -> (v,e)::sb) sbs) img)
- dom [[]]
+let rec power ?(timeout = fun () -> false) dom img =
+ List.fold_left (fun sbs v ->
+ concat_map (fun e -> if timeout () then raise (Timeout "Aux.product") else
+ List.rev (List.rev_map (fun sb -> (v,e)::sb) sbs)) img)
+ [[]] (List.rev dom)
-let product l =
- List.fold_right (fun set prod ->
- concat_map (fun el -> List.map (fun tup -> el::tup) prod) set)
- l [[]]
+let product ?(timeout = fun () -> false) l =
+ List.fold_left (fun prod set ->
+ concat_map (fun el -> if timeout () then raise (Timeout "Aux.product") else
+ List.rev (List.rev_map (fun tup -> el::tup) prod)
+ ) set)
+ [[]] (List.rev l)
let rec pairs l =
match l with
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-11-11 00:56:17 UTC (rev 1627)
+++ trunk/Toss/Formula/Aux.mli 2011-11-11 22:08:39 UTC (rev 1628)
@@ -159,11 +159,11 @@
val fold_left_try : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
(** [power dom img] generates all functions with domain [dom] and
- image [img], as graphs. *)
-val power : 'a list -> 'b list -> ('a * 'b) list list
+ image [img], as graphs. *)
+val power : ?timeout:(unit -> bool) -> 'a list -> 'b list -> ('a * 'b) list list
(** Cartesian product of lists. Not tail recursive. *)
-val product : 'a list list -> 'a list list
+val product : ?timeout:(unit -> bool) -> 'a list list -> 'a list list
(** A list of all pairs of elements that preserve the order of
elements from the list. *)
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-11-11 00:56:17 UTC (rev 1627)
+++ trunk/Toss/GGP/GDL.ml 2011-11-11 22:08:39 UTC (rev 1628)
@@ -934,6 +934,7 @@
(Aux.Strings.elements br_vars) in
let sb = List.map (fun (v,t) -> v, Var t) sb in
List.map (subst_br sb) brs in
+
let expand_pos_atom (rel, args as atom)
(sb, (head, r_body, r_neg_body)) =
(let try def_brs = freshen_brs (List.assoc rel defs) in
@@ -946,9 +947,11 @@
) def_brs
with Not_found ->
[sb, (head, (subst_rel sb atom)::r_body, r_neg_body)]) in
+
let pack_lits body neg_body =
List.map (fun a->Aux.Left a) body @
List.map (fun a->Aux.Right a) neg_body in
+
let expand_neg_atom (rel, args as atom)
(sb, (head, r_body, r_neg_body)) =
(let try def_brs = freshen_brs (List.assoc rel defs) in
@@ -963,14 +966,14 @@
def_brs in
if def_brs = [] then
[sb, (head, r_body, r_neg_body)]
- else
+ else (
(* DNF of the negation of [def_brs] disjunction --
[Left]/[Right] switch meaning *)
- let dnf_of_neg = Aux.product def_brs in
+ let dnf_of_neg = Aux.product ~timeout:!timeout def_brs in
List.map (fun dnf_br ->
let d_neg_body, d_body = Aux.partition_choice dnf_br in
sb, (head, d_body @ r_body, d_neg_body @ r_neg_body)
- ) dnf_of_neg
+ ) dnf_of_neg )
with Not_found ->
[sb, (head, r_body, (subst_rel sb atom)::r_neg_body)]) in
@@ -978,6 +981,7 @@
let init = [[], (head, [], [])] in
Aux.concat_foldr expand_neg_atom neg_body
(Aux.concat_foldr expand_pos_atom body init) in
+
let rec fix n_brs brs i =
let brs = Aux.concat_map expand_br brs in
let new_n_brs = List.length brs in
@@ -1000,7 +1004,7 @@
let clauses = List.map (fun (_,body,neg_body) ->
List.map (fun a -> pos (atom_of_rel a)) body @
List.map (fun a -> neg (atom_of_rel a)) neg_body) clauses in
- let negated = Aux.product clauses in
+ let negated = Aux.product ~timeout:!timeout clauses in
(* can raise [Not_found] in case of unsatisfiable "not distinct" *)
let nclause body =
let uniterms, lits =
@@ -1602,7 +1606,7 @@
(player_vars_of (List.map rel_of_atom (atoms_of_clause clause))) in
if plvars = [] then [clause]
else
- let sbs = Aux.power plvars players in
+ let sbs = Aux.power ~timeout:!timeout plvars players in
List.map (fun sb -> subst_clause sb clause) sbs in
Aux.concat_map exp_clause clauses
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-11-11 00:56:17 UTC (rev 1627)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-11-11 22:08:39 UTC (rev 1628)
@@ -1179,7 +1179,7 @@
);
(* }}} *)
List.map (fun sb->subst_clause sb g_cl) v_sbs in
- Aux.concat_map expand goal_cls @ clauses
+ List.rev_append (List.rev (Aux.concat_map expand goal_cls)) clauses
let prepare_relations_and_structure
ground_state_terms f_paths c_paths element_reps root_reps
@@ -1816,26 +1816,27 @@
(String.concat " "(List.map literal_str goal));
);
(* }}} *)
- let res =
- run_prolog_check_goal static_goal program &&
- let goal = optimize_goal ~testground goal in
- (* {{{ log entry *)
+ let res_prolog = run_prolog_check_goal static_goal program in
+ let res = res_prolog &&
+ let goal = optimize_goal ~testground goal in
+ (* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf
"goal=%s\n%!" (String.concat " "(List.map literal_str goal))
);
- (* }}} *)
- List.exists
+ (* }}} *)
+ List.exists
(fun state ->
- (* {{{ log entry *)
+ (* {{{ log entry *)
if !debug_level > 3 then Printf.printf ".%!";
- (* }}} *)
- run_prolog_check_goal goal
- (replace_rel_in_program "true" (state_cls state) program))
+ (* }}} *)
+ let repl_program =
+ replace_rel_in_program "true" (state_cls state) program in
+ run_prolog_check_goal goal repl_program)
playout_states in
- (* {{{ log entry *)
+ (* {{{ log entry *)
if !debug_level > 3 then Printf.printf " %B\n%!" res;
- (* }}} *)
+ (* }}} *)
res in
let unrequired_cls = Aux.map_some
(function
@@ -1909,9 +1910,10 @@
Array.iteri print_cl (Array.of_list unrequired_cls)
);
(* }}} *)
- let choices = Aux.power split_atoms [false; true] in
+ let choices = Aux.power ~timeout:!timeout split_atoms [false; true] in
let unrequired_cls = Array.of_list unrequired_cls in
let rule_case choice =
+ check_timeout ~print:false "rule_cases: internal rule_case: start";
let separation_cond =
List.map (fun (a,b) -> if b then Pos a else Neg a) choice in
let case =
@@ -1928,7 +1930,7 @@
) unrequired_cls in
let ids, cls = List.split (Array.to_list case) in
Aux.ints_of_list ids, separation_cond, cls in
- let cases = List.map rule_case choices in
+ let cases = List.rev (List.rev_map rule_case choices) in
let process_case (ids, separation_cond, case_cls) =
let case_cls = Aux.map_prepend case_cls
(fun (h,b) -> h, Legal_cl, b) required_cls in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-11 22:58:02
|
Revision: 1629
http://toss.svn.sourceforge.net/toss/?rev=1629&view=rev
Author: lukaszkaiser
Date: 2011-11-11 22:57:56 +0000 (Fri, 11 Nov 2011)
Log Message:
-----------
A few more small changes, all GDL translation tests go through.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/TranslateGame.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-11 22:08:39 UTC (rev 1628)
+++ trunk/Toss/Formula/Aux.ml 2011-11-11 22:57:56 UTC (rev 1629)
@@ -254,7 +254,7 @@
let rec power ?(timeout = fun () -> false) dom img =
List.fold_left (fun sbs v ->
- concat_map (fun e -> if timeout () then raise (Timeout "Aux.product") else
+ concat_map (fun e -> if timeout () then raise (Timeout "Aux.power") else
List.rev (List.rev_map (fun sb -> (v,e)::sb) sbs)) img)
[[]] (List.rev dom)
@@ -275,9 +275,10 @@
if n <= 0 then accu
else fold_n f (f accu) (n-1)
-let all_ntuples elems arity =
+let all_ntuples ?(timeout = fun () -> false) elems arity =
fold_n (fun tups ->
- concat_map (fun e -> (List.map (fun tup -> e::tup) tups))
+ concat_map (fun e -> if timeout () then raise (Timeout "Aux.all_ntuples")
+ else List.rev (List.rev_map (fun tup -> e::tup) tups))
elems) [[]] arity
let rec remove_one e = function
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-11-11 22:08:39 UTC (rev 1628)
+++ trunk/Toss/Formula/Aux.mli 2011-11-11 22:57:56 UTC (rev 1629)
@@ -170,7 +170,7 @@
val pairs : 'a list -> ('a * 'a) list
(** An [n]th cartesian power of the list. Tail recursive. *)
-val all_ntuples : 'a list -> int -> 'a list list
+val all_ntuples : ?timeout:(unit -> bool) -> 'a list -> int -> 'a list list
(** All subsets of a given [set] of size up to [max_size]. *)
val all_subsets : ?max_size: int -> 'a list -> 'a list list
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-11-11 22:08:39 UTC (rev 1628)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-11-11 22:57:56 UTC (rev 1629)
@@ -1056,9 +1056,10 @@
match List.assoc rel argpaths with
| Aux.Left argpaths ->
let arity = List.assoc rel arities in
- let elem_tups = Aux.all_ntuples element_reps arity in
+ let elem_tups =
+ Aux.all_ntuples ~timeout:!timeout element_reps arity in
let path_tups =
- Aux.product (Array.to_list argpaths) in
+ Aux.product ~timeout:!timeout (Array.to_list argpaths) in
List.fold_left (fun struc ptup ->
Aux.fold_left_try (fun struc etup ->
let rname = rel_on_paths rel ptup in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-12 23:54:03
|
Revision: 1630
http://toss.svn.sourceforge.net/toss/?rev=1630&view=rev
Author: lukaszkaiser
Date: 2011-11-12 23:53:56 +0000 (Sat, 12 Nov 2011)
Log Message:
-----------
Make GDL translation more stable for longer runtimes, avoid Aux.product if too big.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Solver/Solver.ml
Removed Paths:
-------------
trunk/Toss/GGP/examples/mastermind448.gdl
trunk/Toss/GGP/examples/uf20-01.cnf.SAT.gdl
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/Formula/Aux.ml 2011-11-12 23:53:56 UTC (rev 1630)
@@ -254,16 +254,24 @@
let rec power ?(timeout = fun () -> false) dom img =
List.fold_left (fun sbs v ->
- concat_map (fun e -> if timeout () then raise (Timeout "Aux.power") else
- List.rev (List.rev_map (fun sb -> (v,e)::sb) sbs)) img)
- [[]] (List.rev dom)
+ concat_map (fun e -> List.rev (List.rev_map (fun sb ->
+ if timeout () then raise (Timeout "Aux.power") else (v,e)::sb) sbs)
+ ) img) [[]] (List.rev dom)
-let product ?(timeout = fun () -> false) l =
+
+let product_size l =
+ let size = List.fold_left (fun size subl ->
+ Big_int.mult_int_big_int (List.length subl) size) Big_int.unit_big_int l in
+ try Big_int.int_of_big_int size with _ -> max_int
+
+let product ?upto ?(timeout = fun () -> false) l =
+ let _ = match upto with None -> () | Some n ->
+ let s = product_size l in if s > n then
+ raise (Timeout ("Aux.product: size would be >= "^ (string_of_int s))) in
List.fold_left (fun prod set ->
- concat_map (fun el -> if timeout () then raise (Timeout "Aux.product") else
- List.rev (List.rev_map (fun tup -> el::tup) prod)
- ) set)
- [[]] (List.rev l)
+ concat_map (fun el -> List.rev (List.rev_map (fun tup ->
+ if timeout () then raise (Timeout "Aux.product") else el::tup) prod)
+ ) set) [[]] (List.rev l)
let rec pairs l =
match l with
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/Formula/Aux.mli 2011-11-12 23:53:56 UTC (rev 1630)
@@ -159,12 +159,15 @@
val fold_left_try : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
(** [power dom img] generates all functions with domain [dom] and
- image [img], as graphs. *)
+ image [img], as graphs. Tail recursive. *)
val power : ?timeout:(unit -> bool) -> 'a list -> 'b list -> ('a * 'b) list list
-(** Cartesian product of lists. Not tail recursive. *)
-val product : ?timeout:(unit -> bool) -> 'a list list -> 'a list list
+(** Cartesian product of lists. Tail recursive. *)
+val product : ?upto:int -> ?timeout:(unit->bool) -> 'a list list -> 'a list list
+(** Size of the cartesian product of lists; max_int if the size is bigger. *)
+val product_size : 'a list list -> int
+
(** A list of all pairs of elements that preserve the order of
elements from the list. *)
val pairs : 'a list -> ('a * 'a) list
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/GGP/GDL.ml 2011-11-12 23:53:56 UTC (rev 1630)
@@ -969,20 +969,22 @@
else (
(* DNF of the negation of [def_brs] disjunction --
[Left]/[Right] switch meaning *)
- let dnf_of_neg = Aux.product ~timeout:!timeout def_brs in
- List.map (fun dnf_br ->
+ let dnf_of_neg = Aux.product ~upto:100100100 ~timeout:!timeout def_brs in
+ List.rev (List.rev_map (fun dnf_br ->
+ check_timeout ~print:false "GDL: expand_definitions: neg_atom: rmap";
let d_neg_body, d_body = Aux.partition_choice dnf_br in
sb, (head, d_body @ r_body, d_neg_body @ r_neg_body)
- ) dnf_of_neg )
+ ) dnf_of_neg) )
with Not_found ->
[sb, (head, r_body, (subst_rel sb atom)::r_neg_body)]) in
let expand_br (head, body, neg_body) =
let init = [[], (head, [], [])] in
- Aux.concat_foldr expand_neg_atom neg_body
- (Aux.concat_foldr expand_pos_atom body init) in
+ let with_pos_body = Aux.concat_foldr expand_pos_atom body init in
+ Aux.concat_foldr expand_neg_atom neg_body with_pos_body in
let rec fix n_brs brs i =
+ check_timeout "GDL: expand_definitions: fix";
let brs = Aux.concat_map expand_br brs in
let new_n_brs = List.length brs in
let brs = List.map snd brs in
@@ -1004,7 +1006,7 @@
let clauses = List.map (fun (_,body,neg_body) ->
List.map (fun a -> pos (atom_of_rel a)) body @
List.map (fun a -> neg (atom_of_rel a)) neg_body) clauses in
- let negated = Aux.product ~timeout:!timeout clauses in
+ let negated = Aux.product ~upto:100100100 ~timeout:!timeout clauses in
(* can raise [Not_found] in case of unsatisfiable "not distinct" *)
let nclause body =
let uniterms, lits =
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-11-12 23:53:56 UTC (rev 1630)
@@ -458,10 +458,16 @@
| Aux.Timeout msg -> (false, "Timeout: " ^ msg)
| e -> (false, "Failed: " ^ (Printexc.to_string e))
-let translate_dir_tests dirname timeout =
+let translate_dir_tests dirname from_file timeout =
let is_gdl fn = (String.length fn > 4) &&
String.sub fn ((String.length fn) - 4) 4 = ".gdl" in
let files = List.sort compare (List.filter is_gdl (Aux.list_dir dirname)) in
+ let from_file =
+ try let r = String.rindex from_file '/' in
+ String.sub from_file (r+1) ((String.length from_file)-r-1)
+ with Not_found -> from_file in
+ let files = if from_file = "" then files else
+ List.filter (fun f -> compare f from_file >= 0) files in
let mk_tst fname =
(fname ^ " (" ^ (string_of_int timeout) ^ "s)") >::
(fun () ->
@@ -470,6 +476,7 @@
(fun () -> Unix.gettimeofday() -. start > float (timeout));
let res, msg = translate_file (dirname ^ fname) None in
let t = Unix.gettimeofday() -. start in
+ Gc.compact ();
let final = if res then Printf.sprintf "Suceeded (%f sec.)\n%!" t else
Printf.sprintf "%s (%f sec)\n%!" msg t in
assert_bool final res
@@ -487,16 +494,17 @@
let opts = [
("-v", Arg.Unit (fun () -> set_debug_level 1), "be verbose");
("-d", Arg.Int (fun i -> set_debug_level i), "set debug level");
- ("-f", Arg.String (fun s -> file := s), "process file");
("-t", Arg.String (fun s -> testdir:= s), "run all tests from a directory");
+ ("-f", Arg.String (fun s -> file := s),
+ "process file if no -t; start directory tests from this file if -t given");
("-s", Arg.Int (fun i -> timeout := i), "set timeout for tests (seconds)");
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
- if !file <> "" then
+ if !file <> "" && !testdir = "" then
print_endline (snd (translate_file !file (Some !timeout)))
else if !testdir <> "" then
Aux.run_test_if_target "TranslateGameTest"
- (translate_dir_tests !testdir !timeout)
+ (translate_dir_tests !testdir !file !timeout)
else exec ()
let _ = Aux.run_if_target "TranslateGameTest" main
Deleted: trunk/Toss/GGP/examples/mastermind448.gdl
===================================================================
--- trunk/Toss/GGP/examples/mastermind448.gdl 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/GGP/examples/mastermind448.gdl 2011-11-12 23:53:56 UTC (rev 1630)
@@ -1,227 +0,0 @@
-;; GDL-II
-;;;;;;;;;;;;;;;;;;;;;; Mastermind 4 4 8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(role random)
-(role player)
-
-(color red)
-(color blue)
-(color green)
-(color pink)
-
-(number 1)
-(number 2)
-(number 3)
-(number 4)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(init (guess 1))
-(init setup)
-(succ 2 1)
-(succ 3 2)
-(succ 4 3)
-(succ 5 4)
-(succ 6 5)
-(succ 7 6)
-(succ 8 7)
-(succ 9 8)
-(succ 10 9)
-(succ 11 10)
-(succ 12 11)
-(succ 13 12)
-
-(<= (next (guess ?g))
- (true (guess ?gp))
- (succ ?g ?gp)
-)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(<= (sees ?r (does ?r ?m))
- (does ?r ?m)
-)
-
-(<= (legal random (set ?n ?c))
- (true (guess ?n))
- (color ?c)
- (true setup)
- (not (true (set ?n ?c2)))
- (color ?c2)
-)
-
-(<= (next (set ?n ?c))
- (or
- (true (set ?n ?c))
- (does random (set ?n ?c))
- )
-)
-
-(<= (legal random noop)
- (not (true setup))
-)
-
-(<= (next setup)
- (or
- (true (guess 1))
- (true (guess 2))
- (true (guess 3))
- )
-)
-
-(<= (legal player noop)
- (true setup)
-)
-
-(<= (legal player (guessColors ?c1 ?c2 ?c3 ?c4))
- (not (true setup))
- (color ?c1)
- (color ?c2)
- (color ?c3)
- (color ?c4)
-)
-
-(<= (sees player (set 1 ?c1))
- (does player (guessColors ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?c1))
-)
-(<= (sees player (set 2 ?c2))
- (does player (guessColors ?c1 ?c2 ?c3 ?c4))
- (true (set 2 ?c2))
-)
-(<= (sees player (set 3 ?c3))
- (does player (guessColors ?c1 ?c2 ?c3 ?c4))
- (true (set 3 ?c3))
-)
-(<= (sees player (set 4 ?c4))
- (does player (guessColors ?c1 ?c2 ?c3 ?c4))
- (true (set 4 ?c4))
-)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(<= terminal
- (true (guess 13))
-)
-
-(<= (sees player won)
- (true won)
-)
-(<= (next won)
- (does player (guessColors ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?c1))
- (true (set 2 ?c2))
- (true (set 3 ?c3))
- (true (set 4 ?c4))
-)
-(<= (next (playerset ?c1 ?c2 ?c3 ?c4))
- (does player (guessColors ?c1 ?c2 ?c3 ?c4))
-)
-
-(<= terminal
- (true won)
-)
-
-(goal random 100)
-
-(<= (goal player 100)
- (true won)
-)
-
-(<= (same ?x ?x)
- (color ?x))
-
-(<= (goal player 75)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?s1))
- (true (set 2 ?s2))
- (true (set 3 ?s3))
- (true (set 4 ?s4))
- (or
- (and (same ?c1 ?s1) (same ?c2 ?s2) (same ?c3 ?s3) (distinct ?c4 ?s4))
- (and (same ?c1 ?s1) (same ?c2 ?s2) (same ?c4 ?s4) (distinct ?c3 ?s3))
- (and (same ?c1 ?s1) (same ?c3 ?s3) (same ?c4 ?s4) (distinct ?c2 ?s2))
- (and (same ?c2 ?s2) (same ?c3 ?s3) (same ?c4 ?s4) (distinct ?c1 ?s1))
- )
-)
-
-(<= (goal player 50)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?s1))
- (true (set 2 ?s2))
- (true (set 3 ?s3))
- (true (set 4 ?s4))
- (or
- (and (same ?c1 ?s1) (same ?c2 ?s2) (distinct ?c3 ?s3) (distinct ?c4 ?s4))
- (and (same ?c1 ?s1) (same ?c3 ?s3) (distinct ?c2 ?s2) (distinct ?c4 ?s4))
- (and (same ?c1 ?s1) (same ?c4 ?s4) (distinct ?c2 ?s2) (distinct ?c3 ?s3))
- (and (same ?c2 ?s2) (same ?c3 ?s3) (distinct ?c1 ?s1) (distinct ?c4 ?s4))
- (and (same ?c2 ?s2) (same ?c4 ?s4) (distinct ?c1 ?s1) (distinct ?c3 ?s3))
- (and (same ?c3 ?s3) (same ?c4 ?s4) (distinct ?c1 ?s1) (distinct ?c2 ?s2))
- )
-)
-
-(<= (goal player 25)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?c1))
- (true (set 2 ?s2))
- (true (set 3 ?s3))
- (true (set 4 ?s4))
- (distinct ?c2 ?s2)
- (distinct ?c3 ?s3)
- (distinct ?c4 ?s4)
-)
-
-(<= (goal player 25)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?s1))
- (true (set 2 ?c2))
- (true (set 3 ?s3))
- (true (set 4 ?s4))
- (distinct ?c1 ?s1)
- (distinct ?c3 ?s3)
- (distinct ?c4 ?s4)
-)
-
-(<= (goal player 25)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?s1))
- (true (set 2 ?s2))
- (true (set 3 ?c3))
- (true (set 4 ?s4))
- (distinct ?c2 ?s2)
- (distinct ?c1 ?s1)
- (distinct ?c4 ?s4)
-)
-
-(<= (goal player 25)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?s1))
- (true (set 2 ?s2))
- (true (set 3 ?s3))
- (true (set 4 ?c4))
- (distinct ?c2 ?s2)
- (distinct ?c3 ?s3)
- (distinct ?c1 ?s1)
-)
-
-(<= (goal player 0)
- (true (guess 13))
- (true (playerset ?c1 ?c2 ?c3 ?c4))
- (true (set 1 ?s1))
- (true (set 2 ?s2))
- (true (set 3 ?s3))
- (true (set 4 ?s4))
- (distinct ?c1 ?s1)
- (distinct ?c2 ?s2)
- (distinct ?c3 ?s3)
- (distinct ?c4 ?s4)
-)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Deleted: trunk/Toss/GGP/examples/uf20-01.cnf.SAT.gdl
===================================================================
--- trunk/Toss/GGP/examples/uf20-01.cnf.SAT.gdl 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/GGP/examples/uf20-01.cnf.SAT.gdl 2011-11-12 23:53:56 UTC (rev 1630)
@@ -1,692 +0,0 @@
-(contains 1 4)
-(contains 1 (not 18))
-(contains 1 19)
-(contains 2 3)
-(contains 2 18)
-(contains 2 (not 5))
-(contains 3 (not 5))
-(contains 3 (not 8))
-(contains 3 (not 15))
-(contains 4 (not 20))
-(contains 4 7)
-(contains 4 (not 16))
-(contains 5 10)
-(contains 5 (not 13))
-(contains 5 (not 7))
-(contains 6 (not 12))
-(contains 6 (not 9))
-(contains 6 17)
-(contains 7 17)
-(contains 7 19)
-(contains 7 5)
-(contains 8 (not 16))
-(contains 8 9)
-(contains 8 15)
-(contains 9 11)
-(contains 9 (not 5))
-(contains 9 (not 14))
-(contains 10 18)
-(contains 10 (not 10))
-(contains 10 13)
-(contains 11 (not 3))
-(contains 11 11)
-(contains 11 12)
-(contains 12 (not 6))
-(contains 12 (not 17))
-(contains 12 (not 8))
-(contains 13 (not 18))
-(contains 13 14)
-(contains 13 1)
-(contains 14 (not 19))
-(contains 14 (not 15))
-(contains 14 10)
-(contains 15 12)
-(contains 15 18)
-(contains 15 (not 19))
-(contains 16 (not 8))
-(contains 16 4)
-(contains 16 7)
-(contains 17 (not 8))
-(contains 17 (not 9))
-(contains 17 4)
-(contains 18 7)
-(contains 18 17)
-(contains 18 (not 15))
-(contains 19 12)
-(contains 19 (not 7))
-(contains 19 (not 14))
-(contains 20 (not 10))
-(contains 20 (not 11))
-(contains 20 8)
-(contains 21 2)
-(contains 21 (not 15))
-(contains 21 (not 11))
-(contains 22 9)
-(contains 22 6)
-(contains 22 1)
-(contains 23 (not 11))
-(contains 23 20)
-(contains 23 (not 17))
-(contains 24 9)
-(contains 24 (not 15))
-(contains 24 13)
-(contains 25 12)
-(contains 25 (not 7))
-(contains 25 (not 17))
-(contains 26 (not 18))
-(contains 26 (not 2))
-(contains 26 20)
-(contains 27 20)
-(contains 27 12)
-(contains 27 4)
-(contains 28 19)
-(contains 28 11)
-(contains 28 14)
-(contains 29 (not 16))
-(contains 29 18)
-(contains 29 (not 4))
-(contains 30 (not 1))
-(contains 30 (not 17))
-(contains 30 (not 19))
-(contains 31 (not 13))
-(contains 31 15)
-(contains 31 10)
-(contains 32 (not 12))
-(contains 32 (not 14))
-(contains 32 (not 13))
-(contains 33 12)
-(contains 33 (not 14))
-(contains 33 (not 7))
-(contains 34 (not 7))
-(contains 34 16)
-(contains 34 10)
-(contains 35 6)
-(contains 35 10)
-(contains 35 7)
-(contains 36 20)
-(contains 36 14)
-(contains 36 (not 16))
-(contains 37 (not 19))
-(contains 37 17)
-(contains 37 11)
-(contains 38 (not 7))
-(contains 38 1)
-(contains 38 (not 20))
-(contains 39 (not 5))
-(contains 39 12)
-(contains 39 15)
-(contains 40 (not 4))
-(contains 40 (not 9))
-(contains 40 (not 13))
-(contains 41 12)
-(contains 41 (not 11))
-(contains 41 (not 7))
-(contains 42 (not 5))
-(contains 42 19)
-(contains 42 (not 8))
-(contains 43 1)
-(contains 43 16)
-(contains 43 17)
-(contains 44 20)
-(contains 44 (not 14))
-(contains 44 (not 15))
-(contains 45 13)
-(contains 45 (not 4))
-(contains 45 10)
-(contains 46 14)
-(contains 46 7)
-(contains 46 10)
-(contains 47 (not 5))
-(contains 47 9)
-(contains 47 20)
-(contains 48 10)
-(contains 48 1)
-(contains 48 (not 19))
-(contains 49 (not 16))
-(contains 49 (not 15))
-(contains 49 (not 1))
-(contains 50 16)
-(contains 50 3)
-(contains 50 (not 11))
-(contains 51 (not 15))
-(contains 51 (not 10))
-(contains 51 4)
-(contains 52 4)
-(contains 52 (not 15))
-(contains 52 (not 3))
-(contains 53 (not 10))
-(contains 53 (not 16))
-(contains 53 11)
-(contains 54 (not 8))
-(contains 54 12)
-(contains 54 (not 5))
-(contains 55 14)
-(contains 55 (not 6))
-(contains 55 12)
-(contains 56 1)
-(contains 56 6)
-(contains 56 11)
-(contains 57 (not 13))
-(contains 57 (not 5))
-(contains 57 (not 1))
-(contains 58 (not 7))
-(contains 58 (not 2))
-(contains 58 12)
-(contains 59 1)
-(contains 59 (not 20))
-(contains 59 19)
-(contains 60 (not 2))
-(contains 60 (not 13))
-(contains 60 (not 8))
-(contains 61 15)
-(contains 61 18)
-(contains 61 4)
-(contains 62 (not 11))
-(contains 62 14)
-(contains 62 9)
-(contains 63 (not 6))
-(contains 63 (not 15))
-(contains 63 (not 2))
-(contains 64 5)
-(contains 64 (not 12))
-(contains 64 (not 15))
-(contains 65 (not 6))
-(contains 65 17)
-(contains 65 5)
-(contains 66 (not 13))
-(contains 66 5)
-(contains 66 (not 19))
-(contains 67 20)
-(contains 67 (not 1))
-(contains 67 14)
-(contains 68 9)
-(contains 68 (not 17))
-(contains 68 15)
-(contains 69 (not 5))
-(contains 69 19)
-(contains 69 (not 18))
-(contains 70 (not 12))
-(contains 70 8)
-(contains 70 (not 10))
-(contains 71 (not 18))
-(contains 71 14)
-(contains 71 (not 4))
-(contains 72 15)
-(contains 72 (not 9))
-(contains 72 13)
-(contains 73 9)
-(contains 73 (not 5))
-(contains 73 (not 1))
-(contains 74 10)
-(contains 74 (not 19))
-(contains 74 (not 14))
-(contains 75 20)
-(contains 75 9)
-(contains 75 4)
-(contains 76 (not 9))
-(contains 76 (not 2))
-(contains 76 19)
-(contains 77 (not 5))
-(contains 77 13)
-(contains 77 (not 17))
-(contains 78 2)
-(contains 78 (not 10))
-(contains 78 (not 18))
-(contains 79 (not 18))
-(contains 79 3)
-(contains 79 11)
-(contains 80 7)
-(contains 80 (not 9))
-(contains 80 17)
-(contains 81 (not 15))
-(contains 81 (not 6))
-(contains 81 (not 3))
-(contains 82 (not 2))
-(contains 82 3)
-(contains 82 (not 13))
-(contains 83 12)
-(contains 83 3)
-(contains 83 (not 2))
-(contains 84 (not 2))
-(contains 84 (not 3))
-(contains 84 17)
-(contains 85 20)
-(contains 85 (not 15))
-(contains 85 (not 16))
-(contains 86 (not 5))
-(contains 86 (not 17))
-(contains 86 (not 19))
-(contains 87 (not 20))
-(contains 87 (not 18))
-(contains 87 11)
-(contains 88 (not 9))
-(contains 88 1)
-(contains 88 (not 5))
-(contains 89 (not 19))
-(contains 89 9)
-(contains 89 17)
-(contains 90 12)
-(contains 90 (not 2))
-(contains 90 17)
-(contains 91 4)
-(contains 91 (not 16))
-(contains 91 (not 5))
-(prop_var 1)
-(prop_var 2)
-(prop_var 3)
-(prop_var 4)
-(prop_var 5)
-(prop_var 6)
-(prop_var 7)
-(prop_var 8)
-(prop_var 9)
-(prop_var 10)
-(prop_var 11)
-(prop_var 12)
-(prop_var 13)
-(prop_var 14)
-(prop_var 15)
-(prop_var 16)
-(prop_var 17)
-(prop_var 18)
-(prop_var 19)
-(prop_var 20)
-(clause 1)
-(clause 2)
-(clause 3)
-(clause 4)
-(clause 5)
-(clause 6)
-(clause 7)
-(clause 8)
-(clause 9)
-(clause 10)
-(clause 11)
-(clause 12)
-(clause 13)
-(clause 14)
-(clause 15)
-(clause 16)
-(clause 17)
-(clause 18)
-(clause 19)
-(clause 20)
-(clause 21)
-(clause 22)
-(clause 23)
-(clause 24)
-(clause 25)
-(clause 26)
-(clause 27)
-(clause 28)
-(clause 29)
-(clause 30)
-(clause 31)
-(clause 32)
-(clause 33)
-(clause 34)
-(clause 35)
-(clause 36)
-(clause 37)
-(clause 38)
-(clause 39)
-(clause 40)
-(clause 41)
-(clause 42)
-(clause 43)
-(clause 44)
-(clause 45)
-(clause 46)
-(clause 47)
-(clause 48)
-(clause 49)
-(clause 50)
-(clause 51)
-(clause 52)
-(clause 53)
-(clause 54)
-(clause 55)
-(clause 56)
-(clause 57)
-(clause 58)
-(clause 59)
-(clause 60)
-(clause 61)
-(clause 62)
-(clause 63)
-(clause 64)
-(clause 65)
-(clause 66)
-(clause 67)
-(clause 68)
-(clause 69)
-(clause 70)
-(clause 71)
-(clause 72)
-(clause 73)
-(clause 74)
-(clause 75)
-(clause 76)
-(clause 77)
-(clause 78)
-(clause 79)
-(clause 80)
-(clause 81)
-(clause 82)
-(clause 83)
-(clause 84)
-(clause 85)
-(clause 86)
-(clause 87)
-(clause 88)
-(clause 89)
-(clause 90)
-(clause 91)
-(role exists)
-(truth_value t)
-(truth_value f)
-(init (control exists 1))
-(<= (legal ?v17219 (assign ?v17229 ?v17230)) (true (control ?v17219 ?v17229)) (role ?v17219) (prop_var ?v17229) (truth_value ?v17230))
-(<= (legal exists noop) (true (control forall ?v17265)) (prop_var ?v17265))
-(<= (legal forall noop) (true (control exists ?v17265)) (prop_var ?v17265))
-(<= (next (sat ?v17289)) (true (sat ?v17289)) (clause ?v17289))
-(<= (next (control exists 2)) (true (control exists 1)))
-(<= (next (control exists 3)) (true (control exists 2)))
-(<= (next (control exists 4)) (true (control exists 3)))
-(<= (next (control exists 5)) (true (control exists 4)))
-(<= (next (control exists 6)) (true (control exists 5)))
-(<= (next (control exists 7)) (true (control exists 6)))
-(<= (next (control exists 8)) (true (control exists 7)))
-(<= (next (control exists 9)) (true (control exists 8)))
-(<= (next (control exists 10)) (true (control exists 9)))
-(<= (next (control exists 11)) (true (control exists 10)))
-(<= (next (control exists 12)) (true (control exists 11)))
-(<= (next (control exists 13)) (true (control exists 12)))
-(<= (next (control exists 14)) (true (control exists 13)))
-(<= (next (control exists 15)) (true (control exists 14)))
-(<= (next (control exists 16)) (true (control exists 15)))
-(<= (next (control exists 17)) (true (control exists 16)))
-(<= (next (control exists 18)) (true (control exists 17)))
-(<= (next (control exists 19)) (true (control exists 18)))
-(<= (next (control exists 20)) (true (control exists 19)))
-(<= (next (control the end)) (true (control exists 20)))
-(<= (next (sat 1)) (does ?v18107 (assign 4 t)) (role ?v18107))
-(<= (next (sat 1)) (does ?v18128 (assign 18 f)) (role ?v18128))
-(<= (next (sat 1)) (does ?v18149 (assign 19 t)) (role ?v18149))
-(<= (next (sat 2)) (does ?v18172 (assign 3 t)) (role ?v18172))
-(<= (next (sat 2)) (does ?v18193 (assign 18 t)) (role ?v18193))
-(<= (next (sat 2)) (does ?v18214 (assign 5 f)) (role ?v18214))
-(<= (next (sat 3)) (does ?v18237 (assign 5 f)) (role ?v18237))
-(<= (next (sat 3)) (does ?v18258 (assign 8 f)) (role ?v18258))
-(<= (next (sat 3)) (does ?v18279 (assign 15 f)) (role ?v18279))
-(<= (next (sat 4)) (does ?v18302 (assign 20 f)) (role ?v18302))
-(<= (next (sat 4)) (does ?v18323 (assign 7 t)) (role ?v18323))
-(<= (next (sat 4)) (does ?v18344 (assign 16 f)) (role ?v18344))
-(<= (next (sat 5)) (does ?v18367 (assign 10 t)) (role ?v18367))
-(<= (next (sat 5)) (does ?v18388 (assign 13 f)) (role ?v18388))
-(<= (next (sat 5)) (does ?v18409 (assign 7 f)) (role ?v18409))
-(<= (next (sat 6)) (does ?v18432 (assign 12 f)) (role ?v18432))
-(<= (next (sat 6)) (does ?v18453 (assign 9 f)) (role ?v18453))
-(<= (next (sat 6)) (does ?v18474 (assign 17 t)) (role ?v18474))
-(<= (next (sat 7)) (does ?v18497 (assign 17 t)) (role ?v18497))
-(<= (next (sat 7)) (does ?v18518 (assign 19 t)) (role ?v18518))
-(<= (next (sat 7)) (does ?v18539 (assign 5 t)) (role ?v18539))
-(<= (next (sat 8)) (does ?v18562 (assign 16 f)) (role ?v18562))
-(<= (next (sat 8)) (does ?v18583 (assign 9 t)) (role ?v18583))
-(<= (next (sat 8)) (does ?v18604 (assign 15 t)) (role ?v18604))
-(<= (next (sat 9)) (does ?v18627 (assign 11 t)) (role ?v18627))
-(<= (next (sat 9)) (does ?v18648 (assign 5 f)) (role ?v18648))
-(<= (next (sat 9)) (does ?v18669 (assign 14 f)) (role ?v18669))
-(<= (next (sat 10)) (does ?v18692 (assign 18 t)) (role ?v18692))
-(<= (next (sat 10)) (does ?v18713 (assign 10 f)) (role ?v18713))
-(<= (next (sat 10)) (does ?v18734 (assign 13 t)) (role ?v18734))
-(<= (next (sat 11)) (does ?v18757 (assign 3 f)) (role ?v18757))
-(<= (next (sat 11)) (does ?v18778 (assign 11 t)) (role ?v18778))
-(<= (next (sat 11)) (does ?v18799 (assign 12 t)) (role ?v18799))
-(<= (next (sat 12)) (does ?v18822 (assign 6 f)) (role ?v18822))
-(<= (next (sat 12)) (does ?v18843 (assign 17 f)) (role ?v18843))
-(<= (next (sat 12)) (does ?v18864 (assign 8 f)) (role ?v18864))
-(<= (next (sat 13)) (does ?v18887 (assign 18 f)) (role ?v18887))
-(<= (next (sat 13)) (does ?v18908 (assign 14 t)) (role ?v18908))
-(<= (next (sat 13)) (does ?v18929 (assign 1 t)) (role ?v18929))
-(<= (next (sat 14)) (does ?v18952 (assign 19 f)) (role ?v18952))
-(<= (next (sat 14)) (does ?v18973 (assign 15 f)) (role ?v18973))
-(<= (next (sat 14)) (does ?v18994 (assign 10 t)) (role ?v18994))
-(<= (next (sat 15)) (does ?v19017 (assign 12 t)) (role ?v19017))
-(<= (next (sat 15)) (does ?v19038 (assign 18 t)) (role ?v19038))
-(<= (next (sat 15)) (does ?v19059 (assign 19 f)) (role ?v19059))
-(<= (next (sat 16)) (does ?v19082 (assign 8 f)) (role ?v19082))
-(<= (next (sat 16)) (does ?v19103 (assign 4 t)) (role ?v19103))
-(<= (next (sat 16)) (does ?v19124 (assign 7 t)) (role ?v19124))
-(<= (next (sat 17)) (does ?v19147 (assign 8 f)) (role ?v19147))
-(<= (next (sat 17)) (does ?v19168 (assign 9 f)) (role ?v19168))
-(<= (next (sat 17)) (does ?v19189 (assign 4 t)) (role ?v19189))
-(<= (next (sat 18)) (does ?v19212 (assign 7 t)) (role ?v19212))
-(<= (next (sat 18)) (does ?v19233 (assign 17 t)) (role ?v19233))
-(<= (next (sat 18)) (does ?v19254 (assign 15 f)) (role ?v19254))
-(<= (next (sat 19)) (does ?v19277 (assign 12 t)) (role ?v19277))
-(<= (next (sat 19)) (does ?v19298 (assign 7 f)) (role ?v19298))
-(<= (next (sat 19)) (does ?v19319 (assign 14 f)) (role ?v19319))
-(<= (next (sat 20)) (does ?v19342 (assign 10 f)) (role ?v19342))
-(<= (next (sat 20)) (does ?v19363 (assign 11 f)) (role ?v19363))
-(<= (next (sat 20)) (does ?v19384 (assign 8 t)) (role ?v19384))
-(<= (next (sat 21)) (does ?v19407 (assign 2 t)) (role ?v19407))
-(<= (next (sat 21)) (does ?v19428 (assign 15 f)) (role ?v19428))
-(<= (next (sat 21)) (does ?v19449 (assign 11 f)) (role ?v19449))
-(<= (next (sat 22)) (does ?v19472 (assign 9 t)) (role ?v19472))
-(<= (next (sat 22)) (does ?v19493 (assign 6 t)) (role ?v19493))
-(<= (next (sat 22)) (does ?v19514 (assign 1 t)) (role ?v19514))
-(<= (next (sat 23)) (does ?v19537 (assign 11 f)) (role ?v19537))
-(<= (next (sat 23)) (does ?v19558 (assign 20 t)) (role ?v19558))
-(<= (next (sat 23)) (does ?v19579 (assign 17 f)) (role ?v19579))
-(<= (next (sat 24)) (does ?v19602 (assign 9 t)) (role ?v19602))
-(<= (next (sat 24)) (does ?v19623 (assign 15 f)) (role ?v19623))
-(<= (next (sat 24)) (does ?v19644 (assign 13 t)) (role ?v19644))
-(<= (next (sat 25)) (does ?v19667 (assign 12 t)) (role ?v19667))
-(<= (next (sat 25)) (does ?v19688 (assign 7 f)) (role ?v19688))
-(<= (next (sat 25)) (does ?v19709 (assign 17 f)) (role ?v19709))
-(<= (next (sat 26)) (does ?v19732 (assign 18 f)) (role ?v19732))
-(<= (next (sat 26)) (does ?v19753 (assign 2 f)) (role ?v19753))
-(<= (next (sat 26)) (does ?v19774 (assign 20 t)) (role ?v19774))
-(<= (next (sat 27)) (does ?v19797 (assign 20 t)) (role ?v19797))
-(<= (next (sat 27)) (does ?v19818 (assign 12 t)) (role ?v19818))
-(<= (next (sat 27)) (does ?v19839 (assign 4 t)) (role ?v19839))
-(<= (next (sat 28)) (does ?v19862 (assign 19 t)) (role ?v19862))
-(<= (next (sat 28)) (does ?v19883 (assign 11 t)) (role ?v19883))
-(<= (next (sat 28)) (does ?v19904 (assign 14 t)) (role ?v19904))
-(<= (next (sat 29)) (does ?v19927 (assign 16 f)) (role ?v19927))
-(<= (next (sat 29)) (does ?v19948 (assign 18 t)) (role ?v19948))
-(<= (next (sat 29)) (does ?v19969 (assign 4 f)) (role ?v19969))
-(<= (next (sat 30)) (does ?v19992 (assign 1 f)) (role ?v19992))
-(<= (next (sat 30)) (does ?v20013 (assign 17 f)) (role ?v20013))
-(<= (next (sat 30)) (does ?v20034 (assign 19 f)) (role ?v20034))
-(<= (next (sat 31)) (does ?v20057 (assign 13 f)) (role ?v20057))
-(<= (next (sat 31)) (does ?v20078 (assign 15 t)) (role ?v20078))
-(<= (next (sat 31)) (does ?v20099 (assign 10 t)) (role ?v20099))
-(<= (next (sat 32)) (does ?v20122 (assign 12 f)) (role ?v20122))
-(<= (next (sat 32)) (does ?v20143 (assign 14 f)) (role ?v20143))
-(<= (next (sat 32)) (does ?v20164 (assign 13 f)) (role ?v20164))
-(<= (next (sat 33)) (does ?v20187 (assign 12 t)) (role ?v20187))
-(<= (next (sat 33)) (does ?v20208 (assign 14 f)) (role ?v20208))
-(<= (next (sat 33)) (does ?v20229 (assign 7 f)) (role ?v20229))
-(<= (next (sat 34)) (does ?v20252 (assign 7 f)) (role ?v20252))
-(<= (next (sat 34)) (does ?v20273 (assign 16 t)) (role ?v20273))
-(<= (next (sat 34)) (does ?v20294 (assign 10 t)) (role ?v20294))
-(<= (next (sat 35)) (does ?v20317 (assign 6 t)) (role ?v20317))
-(<= (next (sat 35)) (does ?v20338 (assign 10 t)) (role ?v20338))
-(<= (next (sat 35)) (does ?v20359 (assign 7 t)) (role ?v20359))
-(<= (next (sat 36)) (does ?v20382 (assign 20 t)) (role ?v20382))
-(<= (next (sat 36)) (does ?v20403 (assign 14 t)) (role ?v20403))
-(<= (next (sat 36)) (does ?v20424 (assign 16 f)) (role ?v20424))
-(<= (next (sat 37)) (does ?v20447 (assign 19 f)) (role ?v20447))
-(<= (next (sat 37)) (does ?v20468 (assign 17 t)) (role ?v20468))
-(<= (next (sat 37)) (does ?v20489 (assign 11 t)) (role ?v20489))
-(<= (next (sat 38)) (does ?v20512 (assign 7 f)) (role ?v20512))
-(<= (next (sat 38)) (does ?v20533 (assign 1 t)) (role ?v20533))
-(<= (next (sat 38)) (does ?v20554 (assign 20 f)) (role ?v20554))
-(<= (next (sat 39)) (does ?v20577 (assign 5 f)) (role ?v20577))
-(<= (next (sat 39)) (does ?v20598 (assign 12 t)) (role ?v20598))
-(<= (next (sat 39)) (does ?v20619 (assign 15 t)) (role ?v20619))
-(<= (next (sat 40)) (does ?v20642 (assign 4 f)) (role ?v20642))
-(<= (next (sat 40)) (does ?v20663 (assign 9 f)) (role ?v20663))
-(<= (next (sat 40)) (does ?v20684 (assign 13 f)) (role ?v20684))
-(<= (next (sat 41)) (does ?v20707 (assign 12 t)) (role ?v20707))
-(<= (next (sat 41)) (does ?v20728 (assign 11 f)) (role ?v20728))
-(<= (next (sat 41)) (does ?v20749 (assign 7 f)) (role ?v20749))
-(<= (next (sat 42)) (does ?v20772 (assign 5 f)) (role ?v20772))
-(<= (next (sat 42)) (does ?v20793 (assign 19 t)) (role ?v20793))
-(<= (next (sat 42)) (does ?v20814 (assign 8 f)) (role ?v20814))
-(<= (next (sat 43)) (does ?v20837 (assign 1 t)) (role ?v20837))
-(<= (next (sat 43)) (does ?v20858 (assign 16 t)) (role ?v20858))
-(<= (next (sat 43)) (does ?v20879 (assign 17 t)) (role ?v20879))
-(<= (next (sat 44)) (does ?v20902 (assign 20 t)) (role ?v20902))
-(<= (next (sat 44)) (does ?v20923 (assign 14 f)) (role ?v20923))
-(<= (next (sat 44)) (does ?v20944 (assign 15 f)) (role ?v20944))
-(<= (next (sat 45)) (does ?v20967 (assign 13 t)) (role ?v20967))
-(<= (next (sat 45)) (does ?v20988 (assign 4 f)) (role ?v20988))
-(<= (next (sat 45)) (does ?v21009 (assign 10 t)) (role ?v21009))
-(<= (next (sat 46)) (does ?v21032 (assign 14 t)) (role ?v21032))
-(<= (next (sat 46)) (does ?v21053 (assign 7 t)) (role ?v21053))
-(<= (next (sat 46)) (does ?v21074 (assign 10 t)) (role ?v21074))
-(<= (next (sat 47)) (does ?v21097 (assign 5 f)) (role ?v21097))
-(<= (next (sat 47)) (does ?v21118 (assign 9 t)) (role ?v21118))
-(<= (next (sat 47)) (does ?v21139 (assign 20 t)) (role ?v21139))
-(<= (next (sat 48)) (does ?v21162 (assign 10 t)) (role ?v21162))
-(<= (next (sat 48)) (does ?v21183 (assign 1 t)) (role ?v21183))
-(<= (next (sat 48)) (does ?v21204 (assign 19 f)) (role ?v21204))
-(<= (next (sat 49)) (does ?v21227 (assign 16 f)) (role ?v21227))
-(<= (next (sat 49)) (does ?v21248 (assign 15 f)) (role ?v21248))
-(<= (next (sat 49)) (does ?v21269 (assign 1 f)) (role ?v21269))
-(<= (next (sat 50)) (does ?v21292 (assign 16 t)) (role ?v21292))
-(<= (next (sat 50)) (does ?v21313 (assign 3 t)) (role ?v21313))
-(<= (next (sat 50)) (does ?v21334 (assign 11 f)) (role ?v21334))
-(<= (next (sat 51)) (does ?v21357 (assign 15 f)) (role ?v21357))
-(<= (next (sat 51)) (does ?v21378 (assign 10 f)) (role ?v21378))
-(<= (next (sat 51)) (does ?v21399 (assign 4 t)) (role ?v21399))
-(<= (next (sat 52)) (does ?v21422 (assign 4 t)) (role ?v21422))
-(<= (next (sat 52)) (does ?v21443 (assign 15 f)) (role ?v21443))
-(<= (next (sat 52)) (does ?v21464 (assign 3 f)) (role ?v21464))
-(<= (next (sat 53)) (does ?v21487 (assign 10 f)) (role ?v21487))
-(<= (next (sat 53)) (does ?v21508 (assign 16 f)) (role ?v21508))
-(<= (next (sat 53)) (does ?v21529 (assign 11 t)) (role ?v21529))
-(<= (next (sat 54)) (does ?v21552 (assign 8 f)) (role ?v21552))
-(<= (next (sat 54)) (does ?v21573 (assign 12 t)) (role ?v21573))
-(<= (next (sat 54)) (does ?v21594 (assign 5 f)) (role ?v21594))
-(<= (next (sat 55)) (does ?v21617 (assign 14 t)) (role ?v21617))
-(<= (next (sat 55)) (does ?v21638 (assign 6 f)) (role ?v21638))
-(<= (next (sat 55)) (does ?v21659 (assign 12 t)) (role ?v21659))
-(<= (next (sat 56)) (does ?v21682 (assign 1 t)) (role ?v21682))
-(<= (next (sat 56)) (does ?v21703 (assign 6 t)) (role ?v21703))
-(<= (next (sat 56)) (does ?v21724 (assign 11 t)) (role ?v21724))
-(<= (next (sat 57)) (does ?v21747 (assign 13 f)) (role ?v21747))
-(<= (next (sat 57)) (does ?v21768 (assign 5 f)) (role ?v21768))
-(<= (next (sat 57)) (does ?v21789 (assign 1 f)) (role ?v21789))
-(<= (next (sat 58)) (does ?v21812 (assign 7 f)) (role ?v21812))
-(<= (next (sat 58)) (does ?v21833 (assign 2 f)) (role ?v21833))
-(<= (next (sat 58)) (does ?v21854 (assign 12 t)) (role ?v21854))
-(<= (next (sat 59)) (does ?v21877 (assign 1 t)) (role ?v21877))
-(<= (next (sat 59)) (does ?v21898 (assign 20 f)) (role ?v21898))
-(<= (next (sat 59)) (does ?v21919 (assign 19 t)) (role ?v21919))
-(<= (next (sat 60)) (does ?v21942 (assign 2 f)) (role ?v21942))
-(<= (next (sat 60)) (does ?v21963 (assign 13 f)) (role ?v21963))
-(<= (next (sat 60)) (does ?v21984 (assign 8 f)) (role ?v21984))
-(<= (next (sat 61)) (does ?v22007 (assign 15 t)) (role ?v22007))
-(<= (next (sat 61)) (does ?v22028 (assign 18 t)) (role ?v22028))
-(<= (next (sat 61)) (does ?v22049 (assign 4 t)) (role ?v22049))
-(<= (next (sat 62)) (does ?v22072 (assign 11 f)) (role ?v22072))
-(<= (next (sat 62)) (does ?v22093 (assign 14 t)) (role ?v22093))
-(<= (next (sat 62)) (does ?v22114 (assign 9 t)) (role ?v22114))
-(<= (next (sat 63)) (does ?v22137 (assign 6 f)) (role ?v22137))
-(<= (next (sat 63)) (does ?v22158 (assign 15 f)) (role ?v22158))
-(<= (next (sat 63)) (does ?v22179 (assign 2 f)) (role ?v22179))
-(<= (next (sat 64)) (does ?v22202 (assign 5 t)) (role ?v22202))
-(<= (next (sat 64)) (does ?v22223 (assign 12 f)) (role ?v22223))
-(<= (next (sat 64)) (does ?v22244 (assign 15 f)) (role ?v22244))
-(<= (next (sat 65)) (does ?v22267 (assign 6 f)) (role ?v22267))
-(<= (next (sat 65)) (does ?v22288 (assign 17 t)) (role ?v22288))
-(<= (next (sat 65)) (does ?v22309 (assign 5 t)) (role ?v22309))
-(<= (next (sat 66)) (does ?v22332 (assign 13 f)) (role ?v22332))
-(<= (next (sat 66)) (does ?v22353 (assign 5 t)) (role ?v22353))
-(<= (next (sat 66)) (does ?v22374 (assign 19 f)) (role ?v22374))
-(<= (next (sat 67)) (does ?v22397 (assign 20 t)) (role ?v22397))
-(<= (next (sat 67)) (does ?v22418 (assign 1 f)) (role ?v22418))
-(<= (next (sat 67)) (does ?v22439 (assign 14 t)) (role ?v22439))
-(<= (next (sat 68)) (does ?v22462 (assign 9 t)) (role ?v22462))
-(<= (next (sat 68)) (does ?v22483 (assign 17 f)) (role ?v22483))
-(<= (next (sat 68)) (does ?v22504 (assign 15 t)) (role ?v22504))
-(<= (next (sat 69)) (does ?v22527 (assign 5 f)) (role ?v22527))
-(<= (next (sat 69)) (does ?v22548 (assign 19 t)) (role ?v22548))
-(<= (next (sat 69)) (does ?v22569 (assign 18 f)) (role ?v22569))
-(<= (next (sat 70)) (does ?v22592 (assign 12 f)) (role ?v22592))
-(<= (next (sat 70)) (does ?v22613 (assign 8 t)) (role ?v22613))
-(<= (next (sat 70)) (does ?v22634 (assign 10 f)) (role ?v22634))
-(<= (next (sat 71)) (does ?v22657 (assign 18 f)) (role ?v22657))
-(<= (next (sat 71)) (does ?v22678 (assign 14 t)) (role ?v22678))
-(<= (next (sat 71)) (does ?v22699 (assign 4 f)) (role ?v22699))
-(<= (next (sat 72)) (does ?v22722 (assign 15 t)) (role ?v22722))
-(<= (next (sat 72)) (does ?v22743 (assign 9 f)) (role ?v22743))
-(<= (next (sat 72)) (does ?v22764 (assign 13 t)) (role ?v22764))
-(<= (next (sat 73)) (does ?v22787 (assign 9 t)) (role ?v22787))
-(<= (next (sat 73)) (does ?v22808 (assign 5 f)) (role ?v22808))
-(<= (next (sat 73)) (does ?v22829 (assign 1 f)) (role ?v22829))
-(<= (next (sat 74)) (does ?v22852 (assign 10 t)) (role ?v22852))
-(<= (next (sat 74)) (does ?v22873 (assign 19 f)) (role ?v22873))
-(<= (next (sat 74)) (does ?v22894 (assign 14 f)) (role ?v22894))
-(<= (next (sat 75)) (does ?v22917 (assign 20 t)) (role ?v22917))
-(<= (next (sat 75)) (does ?v22938 (assign 9 t)) (role ?v22938))
-(<= (next (sat 75)) (does ?v22959 (assign 4 t)) (role ?v22959))
-(<= (next (sat 76)) (does ?v22982 (assign 9 f)) (role ?v22982))
-(<= (next (sat 76)) (does ?v23003 (assign 2 f)) (role ?v23003))
-(<= (next (sat 76)) (does ?v23024 (assign 19 t)) (role ?v23024))
-(<= (next (sat 77)) (does ?v23047 (assign 5 f)) (role ?v23047))
-(<= (next (sat 77)) (does ?v23068 (assign 13 t)) (role ?v23068))
-(<= (next (sat 77)) (does ?v23089 (assign 17 f)) (role ?v23089))
-(<= (next (sat 78)) (does ?v23112 (assign 2 t)) (role ?v23112))
-(<= (next (sat 78)) (does ?v23133 (assign 10 f)) (role ?v23133))
-(<= (next (sat 78)) (does ?v23154 (assign 18 f)) (role ?v23154))
-(<= (next (sat 79)) (does ?v23177 (assign 18 f)) (role ?v23177))
-(<= (next (sat 79)) (does ?v23198 (assign 3 t)) (role ?v23198))
-(<= (next (sat 79)) (does ?v23219 (assign 11 t)) (role ?v23219))
-(<= (next (sat 80)) (does ?v23242 (assign 7 t)) (role ?v23242))
-(<= (next (sat 80)) (does ?v23263 (assign 9 f)) (role ?v23263))
-(<= (next (sat 80)) (does ?v23284 (assign 17 t)) (role ?v23284))
-(<= (next (sat 81)) (does ?v23307 (assign 15 f)) (role ?v23307))
-(<= (next (sat 81)) (does ?v23328 (assign 6 f)) (role ?v23328))
-(<= (next (sat 81)) (does ?v23349 (assign 3 f)) (role ?v23349))
-(<= (next (sat 82)) (does ?v23372 (assign 2 f)) (role ?v23372))
-(<= (next (sat 82)) (does ?v23393 (assign 3 t)) (role ?v23393))
-(<= (next (sat 82)) (does ?v23414 (assign 13 f)) (role ?v23414))
-(<= (next (sat 83)) (does ?v23437 (assign 12 t)) (role ?v23437))
-(<= (next (sat 83)) (does ?v23458 (assign 3 t)) (role ?v23458))
-(<= (next (sat 83)) (does ?v23479 (assign 2 f)) (role ?v23479))
-(<= (next (sat 84)) (does ?v23502 (assign 2 f)) (role ?v23502))
-(<= (next (sat 84)) (does ?v23523 (assign 3 f)) (role ?v23523))
-(<= (next (sat 84)) (does ?v23544 (assign 17 t)) (role ?v23544))
-(<= (next (sat 85)) (does ?v23567 (assign 20 t)) (role ?v23567))
-(<= (next (sat 85)) (does ?v23588 (assign 15 f)) (role ?v23588))
-(<= (next (sat 85)) (does ?v23609 (assign 16 f)) (role ?v23609))
-(<= (next (sat 86)) (does ?v23632 (assign 5 f)) (role ?v23632))
-(<= (next (sat 86)) (does ?v23653 (assign 17 f)) (role ?v23653))
-(<= (next (sat 86)) (does ?v23674 (assign 19 f)) (role ?v23674))
-(<= (next (sat 87)) (does ?v23697 (assign 20 f)) (role ?v23697))
-(<= (next (sat 87)) (does ?v23718 (assign 18 f)) (role ?v23718))
-(<= (next (sat 87)) (does ?v23739 (assign 11 t)) (role ?v23739))
-(<= (next (sat 88)) (does ?v23762 (assign 9 f)) (role ?v23762))
-(<= (next (sat 88)) (does ?v23783 (assign 1 t)) (role ?v23783))
-(<= (next (sat 88)) (does ?v23804 (assign 5 f)) (role ?v23804))
-(<= (next (sat 89)) (does ?v23827 (assign 19 f)) (role ?v23827))
-(<= (next (sat 89)) (does ?v23848 (assign 9 t)) (role ?v23848))
-(<= (next (sat 89)) (does ?v23869 (assign 17 t)) (role ?v23869))
-(<= (next (sat 90)) (does ?v23892 (assign 12 t)) (role ?v23892))
-(<= (next (sat 90)) (does ?v23913 (assign 2 f)) (role ?v23913))
-(<= (next (sat 90)) (does ?v23934 (assign 17 t)) (role ?v23934))
-(<= (next (sat 91)) (does ?v23957 (assign 4 t)) (role ?v23957))
-(<= (next (sat 91)) (does ?v23978 (assign 16 f)) (role ?v23978))
-(<= (next (sat 91)) (does ?v23999 (assign 5 f)) (role ?v23999))
-(<= all_sat (true (sat 1)) (true (sat 2)) (true (sat 3)) (true (sat 4)) (true (sat 5)) (true (sat 6)) (true (sat 7)) (true (sat 8)) (true (sat 9)) (true (sat 10)) (true (sat 11)) (true (sat 12)) (true (sat 13)) (true (sat 14)) (true (sat 15)) (true (sat 16)) (true (sat 17)) (true (sat 18)) (true (sat 19)) (true (sat 20)) (true (sat 21)) (true (sat 22)) (true (sat 23)) (true (sat 24)) (true (sat 25)) (true (sat 26)) (true (sat 27)) (true (sat 28)) (true (sat 29)) (true (sat 30)) (true (sat 31)) (true (sat 32)) (true (sat 33)) (true (sat 34)) (true (sat 35)) (true (sat 36)) (true (sat 37)) (true (sat 38)) (true (sat 39)) (true (sat 40)) (true (sat 41)) (true (sat 42)) (true (sat 43)) (true (sat 44)) (true (sat 45)) (true (sat 46)) (true (sat 47)) (true (sat 48)) (true (sat 49)) (true (sat 50)) (true (sat 51)) (true (sat 52)) (true (sat 53)) (true (sat 54)) (true (sat 55)) (true (sat 56)) (true (sat 57)) (true (sat 58)) (true (sat 59)) (true (sat 60)) (true (sat 61)) (true (sat 62)) (true (sat 63)) (true (sat 64)) (true (sat 65)) (true (sat 66)) (true (sat 67)) (true (sat 68)) (true (sat 69)) (true (sat 70)) (true (sat 71)) (true (sat 72)) (true (sat 73)) (true (sat 74)) (true (sat 75)) (true (sat 76)) (true (sat 77)) (true (sat 78)) (true (sat 79)) (true (sat 80)) (true (sat 81)) (true (sat 82)) (true (sat 83)) (true (sat 84)) (true (sat 85)) (true (sat 86)) (true (sat 87)) (true (sat 88)) (true (sat 89)) (true (sat 90)) (true (sat 91)))
-(<= terminal all_sat)
-(<= terminal (true (control the end)))
-(<= (goal exists 100) all_sat)
-(<= (goal exists 0) (not all_sat))
-(<= (goal forall 100) (not all_sat))
-(<= (goal forall 0) all_sat)
\ No newline at end of file
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-11-11 22:57:56 UTC (rev 1629)
+++ trunk/Toss/Solver/Solver.ml 2011-11-12 23:53:56 UTC (rev 1630)
@@ -516,16 +516,26 @@
module M = struct
let solver = new_solver ()
- let evaluate struc phi =
- evaluate solver ~formula:(register_formula_s struc solver phi) struc
- let evaluate_real = evaluate_real
- let evaluate_partial struc intpr phi =
+ let check_cache x = x
+ (*
+ print_endline (string_of_int (Hashtbl.length solver.reg_formulas));
+ print_endline (string_of_int (Hashtbl.length solver.formulas_eval));
+ print_endline (string_of_int (Hashtbl.length solver.formulas_check));
+ x
+ *)
+
+ let evaluate struc phi = check_cache (
+ evaluate solver ~formula:(register_formula_s struc solver phi) struc)
+ let evaluate_real rvar expr struc =
+ check_cache (evaluate_real rvar expr struc)
+ let evaluate_partial struc intpr phi = check_cache (
evaluate_partial_aset solver ~formula:(register_formula_s struc solver phi)
- struc intpr
+ struc intpr)
- let check struc phi =
- check solver ~formula:(register_formula_s struc solver phi) struc
- let get_real_val ?asg re struc = get_real_val_cache ?asg solver struc re
+ let check struc phi = check_cache (
+ check solver ~formula:(register_formula_s struc solver phi) struc)
+ let get_real_val ?asg re struc = check_cache (
+ check_cache (get_real_val_cache ?asg solver struc re))
let set_timeout t = timeout := t
let clear_timeout () = timeout := (fun () -> false);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-14 15:49:57
|
Revision: 1632
http://toss.svn.sourceforge.net/toss/?rev=1632&view=rev
Author: lukaszkaiser
Date: 2011-11-14 15:49:50 +0000 (Mon, 14 Nov 2011)
Log Message:
-----------
Correcting a bug in simplify_re, connect4 plays from translation now.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaSubst.ml
trunk/Toss/Formula/FormulaSubst.mli
trunk/Toss/Play/HeuristicTest.ml
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-11-13 22:58:16 UTC (rev 1631)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-11-14 15:49:50 UTC (rev 1632)
@@ -278,6 +278,44 @@
(* Simplify. *)
(* ------------------------------------------------------------------------- *)
+let fp_var_subst s (v : [ mso_var | so_var ]) = to_mso_or_so (var_subst s v)
+
+(* Rename quantified variables avoiding the ones from [avs],
+ and the above-quantified ones. Does not go into real_expr. *)
+let rec rename_quant_avoiding avs = function
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as x -> x
+ | Not phi -> Not (rename_quant_avoiding avs phi)
+ | Or flist -> Or (List.map (rename_quant_avoiding avs) flist)
+ | And flist -> And (List.map (rename_quant_avoiding avs) flist)
+ | Ex (vs, phi) ->
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
+ if avoidv = [] then Ex (vs, rename_quant_avoiding (avs @ vs) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
+ Ex (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
+ | All (vs, phi) ->
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
+ if avoidv = [] then All (vs, rename_quant_avoiding (avs @ vs) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
+ All (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
+ | Lfp (v, vs, phi) ->
+ let vars = [(v :> var)] in
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
+ if avoidv=[] then Lfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nv = fp_var_subst subst v in
+ Lfp (nv, vs, rename_quant_avoiding ((nv :> var) :: avs) phi)
+ | Gfp (v, vs, phi) ->
+ let vars = [(v :> var)] in
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
+ if avoidv=[] then Gfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nv = fp_var_subst subst v in
+ Gfp (nv, vs, rename_quant_avoiding ((nv :> var) :: avs) phi)
+ | Let _ as phi -> rename_quant_avoiding avs (expand_formula phi)
+
+
let str_contains c s =
try let _ = String.index s c in true with Not_found -> false
@@ -408,23 +446,11 @@
and simplify_re ?(do_pnf=false) ?(do_formula=true) ?(ni=0) = function
| RVar _ | Const _ | Fun _ as atom -> atom
- | Char phi ->
- let name_i = ref ni in
- let namef () = incr name_i; string_of_int !name_i in
- let subst_l l = List.map (fun v -> (var_str v, "fo__cx_" ^ namef())) l in
- let get_fo sl = List.map (fun (_, v) -> var_of_string v) sl in
- let new_phi = match nnf phi with
- | Ex (x, f) when List.for_all is_fo x ->
- let sl = subst_l x in Ex (get_fo sl, subst_vars sl f)
- | All (x, f) when List.for_all is_fo x ->
- let sl = subst_l x in All (get_fo sl, subst_vars sl f)
- | psi ->
- (* {{{ log entry *)
- if !debug_level > 1 then (
- print_endline ("PSi: " ^ (Formula.str psi));
- );
- (* }}} *)
- psi in
+ | Char phi ->
+ let prefix = !FormulaSubst.subst_name_prefix in
+ FormulaSubst.subst_name_prefix := "fo_cx_";
+ let new_phi = rename_quant_avoiding (FormulaSubst.all_vars phi) phi in
+ FormulaSubst.subst_name_prefix := prefix;
if do_formula then
Char (simplify ~do_pnf ~do_re:true ~ni new_phi)
else Char new_phi
@@ -434,12 +460,14 @@
let subst_l = List.map (fun v -> (var_str v, "fo__sx_" ^ namef())) l in
let new_re = subst_vars_expr subst_l re in
let re_simp = simplify_re ~do_pnf ~do_formula ~ni:!name_i new_re in
- let new_phi = subst_vars subst_l phi in
+ let new_phi = flatten_sort (subst_vars subst_l phi) in
let phi_simp =
if do_formula then simplify ~do_pnf ~do_re:true ~ni:!name_i new_phi else
new_phi in
- Sum (List.map (fun (_, v) -> fo_var_of_string v) subst_l,
- phi_simp, re_simp)
+ if new_phi = Or [] then Const 0. else
+ if new_phi = And [] && l = [] then re_simp else
+ Sum (List.map (fun (_, v) -> fo_var_of_string v) subst_l,
+ phi_simp, re_simp)
| Plus _ | Times (Const _, _) | Times (_, Const _) as x ->
let rec get_linear = function
| Plus (p, q) -> List.rev_append (get_linear p) (get_linear q)
@@ -468,7 +496,9 @@
| Times (p, q) ->
let simp_p = simplify_re ~do_pnf ~do_formula ~ni p in
let simp_q = simplify_re ~do_pnf ~do_formula ~ni q in
- if simp_p = p && simp_q = q then Times (p, q) else
+ if size_real simp_p = size_real p && size_real simp_q = size_real q then
+ Times (p, q)
+ else
simplify_re ~do_pnf ~do_formula ~ni (Times (simp_p, simp_q))
| RLet _ as re -> simplify_re ~do_pnf ~do_formula ~ni (expand_real_expr re)
@@ -873,44 +903,6 @@
(* ------------ TNF with variable pushing --------- *)
-let fp_var_subst s (v : [ mso_var | so_var ]) = to_mso_or_so (var_subst s v)
-
-(* Rename quantified variables avoiding the ones from [avs],
- and the above-quantified ones. Does not go into real_expr. *)
-let rec rename_quant_avoiding avs = function
- | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as x -> x
- | Not phi -> Not (rename_quant_avoiding avs phi)
- | Or flist -> Or (List.map (rename_quant_avoiding avs) flist)
- | And flist -> And (List.map (rename_quant_avoiding avs) flist)
- | Ex (vs, phi) ->
- let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
- if avoidv = [] then Ex (vs, rename_quant_avoiding (avs @ vs) phi) else
- let subst = List.map (subst_name_avoiding avs) avoidv in
- let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
- Ex (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
- | All (vs, phi) ->
- let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
- if avoidv = [] then All (vs, rename_quant_avoiding (avs @ vs) phi) else
- let subst = List.map (subst_name_avoiding avs) avoidv in
- let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
- All (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
- | Lfp (v, vs, phi) ->
- let vars = [(v :> var)] in
- let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
- if avoidv=[] then Lfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
- let subst = List.map (subst_name_avoiding avs) avoidv in
- let nv = fp_var_subst subst v in
- Lfp (nv, vs, rename_quant_avoiding ((nv :> var) :: avs) phi)
- | Gfp (v, vs, phi) ->
- let vars = [(v :> var)] in
- let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
- if avoidv=[] then Gfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
- let subst = List.map (subst_name_avoiding avs) avoidv in
- let nv = fp_var_subst subst v in
- Gfp (nv, vs, rename_quant_avoiding ((nv :> var) :: avs) phi)
- | Let _ as phi -> rename_quant_avoiding avs (expand_formula phi)
-
-
let rec has_mso = function
| In _ -> true
| Rel _ | Eq _ | RealExpr _ | SO _ -> false
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-11-13 22:58:16 UTC (rev 1631)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-11-14 15:49:50 UTC (rev 1632)
@@ -221,6 +221,7 @@
simp_eq ":(ex x R(x)) - :(ex x R(x))" "0";
simp_eq ":(ex x P(x)) - :(ex y P(y))" "0";
simp_eq "Sum (x | P(x) : :f(x)) - Sum (y | P(y) : :f(y))" "0";
+ simp_eq "Sum (x | false : :f(x))" "0";
simp_eq ("Sum (x | P(x) : Sum (y | Q(y) : :f(x)))" ^
"- Sum (y | P(y) : Sum (z | Q(z) : :f(y)))") "0";
);
Modified: trunk/Toss/Formula/FormulaSubst.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubst.ml 2011-11-13 22:58:16 UTC (rev 1631)
+++ trunk/Toss/Formula/FormulaSubst.ml 2011-11-14 15:49:50 UTC (rev 1632)
@@ -17,6 +17,8 @@
let fo_var_subst subst (v : fo_var) = to_fo (var_subst subst v)
let fp_var_subst s (v : [ mso_var | so_var ]) = to_mso_or_so (var_subst s v)
+let subst_name_prefix = ref ""
+
(* Find a substitution for [v] which avoids [avs], string arguments *)
let subst_name_avoiding_str avs var_s =
(* Helper: strip digits from string end if it doesn't start with one.*)
@@ -26,7 +28,8 @@
if Aux.is_digit s.[len-1] then
strip_digits (String.sub s 0 (len-1))
else s in
- let v = strip_digits var_s in
+ let v = if !subst_name_prefix = "" then
+ strip_digits var_s else !subst_name_prefix in
let rec asubst i =
let vi = v ^ (string_of_int i) in
if not (List.mem vi avs) then (var_s, vi) else asubst (i+1) in
Modified: trunk/Toss/Formula/FormulaSubst.mli
===================================================================
--- trunk/Toss/Formula/FormulaSubst.mli 2011-11-13 22:58:16 UTC (rev 1631)
+++ trunk/Toss/Formula/FormulaSubst.mli 2011-11-14 15:49:50 UTC (rev 1632)
@@ -8,6 +8,9 @@
(** Find a substitution for [v] which avoids [avs], string arguments. *)
val subst_name_avoiding_str : string list -> string -> string * string
+(** Prefix for variable name replacements. Default (empty) = derived from var.*)
+val subst_name_prefix: string ref
+
(** Find a substitution for [v] which avoids [avs]. *)
val subst_name_avoiding : [< var] list -> [< var] -> string * string
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-11-13 22:58:16 UTC (rev 1631)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-11-14 15:49:50 UTC (rev 1632)
@@ -347,7 +347,7 @@
~advr:4.0 game in
assert_eq_str
-"100. * (Sum (cell_e_y8__BLANK_, cell_d_y8__BLANK_, cell_c1_y8__BLANK_, cell_b_y8__BLANK_, cell_a_y8__BLANK_ | ((cell_2x(cell_a_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and (cell_2b(cell_a_y8__BLANK_) or cell_2x(cell_a_y8__BLANK_)) and (cell_2b(cell_b_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_)) and (cell_2b(cell_c1_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_)) and (cell_2b(cell_d_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_)) and (cell_2b(cell_e_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and coordinate(cell_e_y8__BLANK_) and coordinate(cell_d_y8__BLANK_) and coordinate(cell_c1_y8__BLANK_) and coordinate(cell_b_y8__BLANK_) and coordinate(cell_a_y8__BLANK_) and R2(cell_d_y8__BLANK_, cell_e_y8__BLANK_) and R2(cell_c1_y8__BLANK_, cell_d_y8__BLANK_) and R2(cell_b_y8__BLANK_, cell_c1_y8__BLANK_) and R2(cell_a_y8__BLANK_, cell_b_y8__BLANK_)) : (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * 0.0016 ) + Sum (cell_x18_y14__BLANK_, cell_x17_y15__BLANK_, cell_x16_y16__BLANK_, cell_x15_y17__BLANK_, cell_x14_y18__BLANK_ | ((cell_2x(cell_x14_y18__BLANK_) or cell_2x(cell_x15_y17__BLANK_) or cell_2x(cell_x16_y16__BLANK_) or cell_2x(cell_x17_y15__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and (cell_2b(cell_x14_y18__BLANK_) or cell_2x(cell_x14_y18__BLANK_)) and (cell_2b(cell_x15_y17__BLANK_) or cell_2x(cell_x15_y17__BLANK_)) and (cell_2b(cell_x16_y16__BLANK_) or cell_2x(cell_x16_y16__BLANK_)) and (cell_2b(cell_x17_y15__BLANK_) or cell_2x(cell_x17_y15__BLANK_)) and (cell_2b(cell_x18_y14__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and coordinate(cell_x18_y14__BLANK_) and coordinate(cell_x17_y15__BLANK_) and coordinate(cell_x16_y16__BLANK_) and coordinate(cell_x15_y17__BLANK_) and coordinate(cell_x14_y18__BLANK_) and R1(cell_x17_y15__BLANK_, cell_x18_y14__BLANK_) and R1(cell_x16_y16__BLANK_, cell_x17_y15__BLANK_) and R1(cell_x15_y17__BLANK_, cell_x16_y16__BLANK_) and R1(cell_x14_y18__BLANK_, cell_x15_y17__BLANK_)) : (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * 0.0016 ) + Sum (cell_x9_y9__BLANK_, cell_x13_y13__BLANK_, cell_x12_y12__BLANK_, cell_x11_y11__BLANK_, cell_x10_y10__BLANK_ | ((cell_2x(cell_x10_y10__BLANK_) or cell_2x(cell_x11_y11__BLANK_) or cell_2x(cell_x12_y12__BLANK_) or cell_2x(cell_x13_y13__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and (cell_2b(cell_x10_y10__BLANK_) or cell_2x(cell_x10_y10__BLANK_)) and (cell_2b(cell_x11_y11__BLANK_) or cell_2x(cell_x11_y11__BLANK_)) and (cell_2b(cell_x12_y12__BLANK_) or cell_2x(cell_x12_y12__BLANK_)) and (cell_2b(cell_x13_y13__BLANK_) or cell_2x(cell_x13_y13__BLANK_)) and (cell_2b(cell_x9_y9__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and coordinate(cell_x9_y9__BLANK_) and coordinate(cell_x13_y13__BLANK_) and coordinate(cell_x12_y12__BLANK_) and coordinate(cell_x11_y11__BLANK_) and coordinate(cell_x10_y10__BLANK_) and R0(cell_x9_y9__BLANK_, cell_x10_y10__BLANK_) and R0(cell_x12_y12__BLANK_, cell_x13_y13__BLANK_) and R0(cell_x11_y11__BLANK_, cell_x12_y12__BLANK_) and R0(cell_x10_y10__BLANK_, cell_x11_y11__BLANK_)) : (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * 0.0016 ) + Sum (cell_x8_e0__BLANK_, cell_x8_d0__BLANK_, cell_x8_c2__BLANK_, cell_x8_b0__BLANK_, cell_x8_a0__BLANK_ | ((cell_2x(cell_x8_a0__BLANK_) or cell_2x(cell_x8_b0__BLANK_) or cell_2x(cell_x8_c2__BLANK_) or cell_2x(cell_x8_d0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and (cell_2b(cell_x8_a0__BLANK_) or cell_2x(cell_x8_a0__BLANK_)) and (cell_2b(cell_x8_b0__BLANK_) or cell_2x(cell_x8_b0__BLANK_)) and (cell_2b(cell_x8_c2__BLANK_) or cell_2x(cell_x8_c2__BLANK_)) and (cell_2b(cell_x8_d0__BLANK_) or cell_2x(cell_x8_d0__BLANK_)) and (cell_2b(cell_x8_e0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and coordinate(cell_x8_e0__BLANK_) and coordinate(cell_x8_d0__BLANK_) and coordinate(cell_x8_c2__BLANK_) and coordinate(cell_x8_b0__BLANK_) and coordinate(cell_x8_a0__BLANK_) and R(cell_x8_d0__BLANK_, cell_x8_e0__BLANK_) and R(cell_x8_c2__BLANK_, cell_x8_d0__BLANK_) and R(cell_x8_b0__BLANK_, cell_x8_c2__BLANK_) and R(cell_x8_a0__BLANK_, cell_x8_b0__BLANK_)) : (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * 0.0016 )) + 50. * Sum ( | false : 0. * 0. * 0. * 0. * inf)"
+ "100. * (Sum (cell_e_y8__BLANK_, cell_d_y8__BLANK_, cell_c1_y8__BLANK_, cell_b_y8__BLANK_, cell_a_y8__BLANK_ | ((cell_2x(cell_a_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and (cell_2b(cell_a_y8__BLANK_) or cell_2x(cell_a_y8__BLANK_)) and (cell_2b(cell_b_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_)) and (cell_2b(cell_c1_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_)) and (cell_2b(cell_d_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_)) and (cell_2b(cell_e_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and R2(cell_d_y8__BLANK_, cell_e_y8__BLANK_) and R2(cell_c1_y8__BLANK_, cell_d_y8__BLANK_) and R2(cell_b_y8__BLANK_, cell_c1_y8__BLANK_) and R2(cell_a_y8__BLANK_, cell_b_y8__BLANK_)) : (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * 0.0016 ) + Sum (cell_x18_y14__BLANK_, cell_x17_y15__BLANK_, cell_x16_y16__BLANK_, cell_x15_y17__BLANK_, cell_x14_y18__BLANK_ | ((cell_2x(cell_x14_y18__BLANK_) or cell_2x(cell_x15_y17__BLANK_) or cell_2x(cell_x16_y16__BLANK_) or cell_2x(cell_x17_y15__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and (cell_2b(cell_x14_y18__BLANK_) or cell_2x(cell_x14_y18__BLANK_)) and (cell_2b(cell_x15_y17__BLANK_) or cell_2x(cell_x15_y17__BLANK_)) and (cell_2b(cell_x16_y16__BLANK_) or cell_2x(cell_x16_y16__BLANK_)) and (cell_2b(cell_x17_y15__BLANK_) or cell_2x(cell_x17_y15__BLANK_)) and (cell_2b(cell_x18_y14__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and R1(cell_x17_y15__BLANK_, cell_x18_y14__BLANK_) and R1(cell_x16_y16__BLANK_, cell_x17_y15__BLANK_) and R1(cell_x15_y17__BLANK_, cell_x16_y16__BLANK_) and R1(cell_x14_y18__BLANK_, cell_x15_y17__BLANK_)) : (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * 0.0016 ) + Sum (cell_x9_y9__BLANK_, cell_x13_y13__BLANK_, cell_x12_y12__BLANK_, cell_x11_y11__BLANK_, cell_x10_y10__BLANK_ | ((cell_2x(cell_x10_y10__BLANK_) or cell_2x(cell_x11_y11__BLANK_) or cell_2x(cell_x12_y12__BLANK_) or cell_2x(cell_x13_y13__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and (cell_2b(cell_x10_y10__BLANK_) or cell_2x(cell_x10_y10__BLANK_)) and (cell_2b(cell_x11_y11__BLANK_) or cell_2x(cell_x11_y11__BLANK_)) and (cell_2b(cell_x12_y12__BLANK_) or cell_2x(cell_x12_y12__BLANK_)) and (cell_2b(cell_x13_y13__BLANK_) or cell_2x(cell_x13_y13__BLANK_)) and (cell_2b(cell_x9_y9__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and R0(cell_x9_y9__BLANK_, cell_x10_y10__BLANK_) and R0(cell_x12_y12__BLANK_, cell_x13_y13__BLANK_) and R0(cell_x11_y11__BLANK_, cell_x12_y12__BLANK_) and R0(cell_x10_y10__BLANK_, cell_x11_y11__BLANK_)) : (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * 0.0016 ) + Sum (cell_x8_e0__BLANK_, cell_x8_d0__BLANK_, cell_x8_c2__BLANK_, cell_x8_b0__BLANK_, cell_x8_a0__BLANK_ | ((cell_2x(cell_x8_a0__BLANK_) or cell_2x(cell_x8_b0__BLANK_) or cell_2x(cell_x8_c2__BLANK_) or cell_2x(cell_x8_d0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and (cell_2b(cell_x8_a0__BLANK_) or cell_2x(cell_x8_a0__BLANK_)) and (cell_2b(cell_x8_b0__BLANK_) or cell_2x(cell_x8_b0__BLANK_)) and (cell_2b(cell_x8_c2__BLANK_) or cell_2x(cell_x8_c2__BLANK_)) and (cell_2b(cell_x8_d0__BLANK_) or cell_2x(cell_x8_d0__BLANK_)) and (cell_2b(cell_x8_e0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and R(cell_x8_d0__BLANK_, cell_x8_e0__BLANK_) and R(cell_x8_c2__BLANK_, cell_x8_d0__BLANK_) and R(cell_x8_b0__BLANK_, cell_x8_c2__BLANK_) and R(cell_x8_a0__BLANK_, cell_x8_b0__BLANK_)) : (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * 0.0016 )) + 50. * Sum ( | false : 0. * 0. * 0. * 0. * inf)"
(Formula.real_str loc_heurs.(0).(0));
);
@@ -360,7 +360,7 @@
~advr:2.0 game in
assert_eq_str
- "100. * (0.99609375 + 1.9921875 * :( not ex cellholds_x28_y28__BLANK_ (cellholds_2black(cellholds_x28_y28__BLANK_) and index__cellholds_1(cellholds_x28_y28__BLANK_) and index__cellholds_1(cellholds_x28_y28__BLANK_)) ) + Sum (cellholds_x25_8__BLANK_ | (cellholds_2white(cellholds_x25_8__BLANK_) and index__cellholds_1(cellholds_x25_8__BLANK_)) : 0.0078125 + Sum (y | R(y, cellholds_x25_8__BLANK_) : 0.015625 + Sum (y0 | R(y0, y) : 0.03125 + Sum (y1 | R(y1, y0) : 0.0625 + Sum (y2 | R(y2, y1) : 0.125 + Sum (y3 | R(y3, y2) : 0.25 + Sum (y4 | R(y4, y3) : 0.5 + Sum (y5 | R(y5, y4) : 1.))) ) ) ) ) ))"
+ "100. * (0.99609375 + 1.9921875 * :( not ex cellholds_x28_y28__BLANK_ (cellholds_2black(cellholds_x28_y28__BLANK_) and index__cellholds_1(cellholds_x28_y28__BLANK_)) ) + Sum (cellholds_x25_8__BLANK_ | (cellholds_2white(cellholds_x25_8__BLANK_) and index__cellholds_1(cellholds_x25_8__BLANK_)) : 0.0078125 + Sum (y | R(y, cellholds_x25_8__BLANK_) : 0.015625 + Sum (y0 | R(y0, y) : 0.03125 + Sum (y1 | R(y1, y0) : 0.0625 + Sum (y2 | R(y2, y1) : 0.125 + Sum (y3 | R(y3, y2) : 0.25 + Sum (y4 | R(y4, y3) : 0.5 + Sum (y5 | R(y5, y4) : 1.))) ) ) ) ) ))"
(Formula.real_str loc_heurs.(0).(0));
);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-16 21:58:18
|
Revision: 1633
http://toss.svn.sourceforge.net/toss/?rev=1633&view=rev
Author: lukaszkaiser
Date: 2011-11-16 21:58:12 +0000 (Wed, 16 Nov 2011)
Log Message:
-----------
Better ordering in distinguish_by_type, gives more readable formulas.
Modified Paths:
--------------
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Server/Makefile
trunk/Toss/Solver/Distinguish.ml
trunk/Toss/Solver/DistinguishTest.ml
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-11-14 15:49:50 UTC (rev 1632)
+++ trunk/Toss/Formula/Formula.ml 2011-11-16 21:58:12 UTC (rev 1633)
@@ -129,10 +129,14 @@
let is_atom = function
- | Rel _ | Eq _ | In _ | SO _ | RealExpr _ -> true
+ | Rel _ | Eq _ | In _ | SO _ -> true
| _ -> false
+let rec is_literal = function
+ | Not f -> is_literal f
+ | f -> is_atom f
+
(* Helper power function, used in parser. *)
let rec pow p n =
if n = 0 then Const 1. else if n = 1 then p else Times (p, pow p (n-1))
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2011-11-14 15:49:50 UTC (rev 1632)
+++ trunk/Toss/Formula/Formula.mli 2011-11-16 21:58:12 UTC (rev 1633)
@@ -81,6 +81,7 @@
val compare : formula -> formula -> int
val is_atom : formula -> bool
+val is_literal : formula -> bool
(** Equation system: a left-hand-side [f,a] actually represents
[Fun (f, `FO a)] *)
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2011-11-14 15:49:50 UTC (rev 1632)
+++ trunk/Toss/Formula/FormulaTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
@@ -14,6 +14,16 @@
(And [rel "P" 1; rel "Q" 1; rel "S" 1]);
);
+ "size, compare" >::
+ (fun () ->
+ assert_equal ~printer:(fun x -> string_of_int x) 5
+ (size (And [rel "P" 1; rel "Q" 1; Not (rel "R" 2)]));
+
+ assert_equal ~printer:(fun x -> string_of_int x) 1
+ (compare (And [rel "P" 1; Not (rel "Q" 1); Not (rel "R" 2)])
+ (And [rel "P" 1; rel "Q" 1; Not (rel "R" 2)]));
+ );
+
"syntax check" >::
(fun () ->
assert_equal ~printer:string_of_bool true
Modified: trunk/Toss/Server/Makefile
===================================================================
--- trunk/Toss/Server/Makefile 2011-11-14 15:49:50 UTC (rev 1632)
+++ trunk/Toss/Server/Makefile 2011-11-16 21:58:12 UTC (rev 1633)
@@ -5,6 +5,7 @@
PictureTest:
ReqHandlerTest:
+LearnGameTest:
tests:
make -C .. ServerTestsVerbose
Modified: trunk/Toss/Solver/Distinguish.ml
===================================================================
--- trunk/Toss/Solver/Distinguish.ml 2011-11-14 15:49:50 UTC (rev 1632)
+++ trunk/Toss/Solver/Distinguish.ml 2011-11-16 21:58:12 UTC (rev 1633)
@@ -37,24 +37,40 @@
) (atoms @ (equalities (varnames k)))
+(* The [qr]-type in [length of tuple]-variables of [tuple] in [struc].
+ In [mem] we memorize the results for [qr] and [tuple], but *not* [struc]. *)
+let rec ntype_memo struc mem qr tuple =
+ try Hashtbl.find mem (qr, tuple) with Not_found ->
+ if qr = 0 then (
+ let res = Formula.flatten_sort (And (atoms struc tuple)) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ ) else (
+ let prevtp i e =
+ ntype_memo struc mem (qr-1) (Aux.array_replace tuple i e) in
+ let elems = Structure.elements struc in
+ let conj_prev_ex i =
+ And (List.map (fun e -> Ex ([var i], prevtp i e)) elems) in
+ let all_prev_disj i =
+ All ([var i], Or (List.map (prevtp i) elems)) in
+ let next_ntype i = And [conj_prev_ex i; all_prev_disj i] in
+ let nexttp = And (List.map next_ntype (Aux.range (Array.length tuple))) in
+ let res = Formula.flatten_sort (
+ And [ntype_memo struc mem (qr-1) tuple; nexttp]) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ )
+
(* The [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
-let rec ntype struc qr tuple =
- if qr = 0 then Formula.flatten_sort (And (atoms struc tuple)) else
- let prevtp i e = ntype struc (qr-1) (Aux.array_replace tuple i e) in
- let elems = Structure.elements struc in
- let conj_prev_ex i =
- And (List.map (fun e -> Ex ([var i], prevtp i e)) elems) in
- let all_prev_disj i =
- All ([var i], Or (List.map (prevtp i) elems)) in
- let next_ntype i = And [conj_prev_ex i; all_prev_disj i] in
- let nexttp = And (List.map next_ntype (Aux.range (Array.length tuple))) in
- Formula.flatten_sort (And [ntype struc (qr-1) tuple; nexttp])
+let ntype struc qr tuple = ntype_memo struc (Hashtbl.create 7) qr tuple
+
(* All types of rank [qr] of all [k]-tuples in [struc]. *)
let ntypes struc ~qr ~k =
let elems = Structure.elements struc in
let tups = List.map Array.of_list (Aux.all_ntuples elems k) in
- Aux.unique_sorted (List.rev_map (ntype struc qr) tups)
+ let mem = Hashtbl.create 63 in
+ Aux.unique_sorted (List.rev_map (ntype_memo struc mem qr) tups)
(* - Guards and Guarded Types - *)
@@ -104,39 +120,57 @@
(Formula.str atom) ^ " >"
+(* Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc].
+ In [mem] we memorize the results for [qr] and [tuple], but *not* [struc]. *)
+let rec guarded_type_memo struc mem qr tuple =
+ try Hashtbl.find mem (qr, tuple) with Not_found ->
+ if qr = 0 then (
+ let res = Formula.flatten_sort (And (atoms struc tuple)) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ ) else (
+ let prevtp tup = guarded_type_memo struc mem (qr-1) tup in
+ let conj_prev_ex vars guard subst_tuples =
+ let subst_tuples = List.filter (fun tup -> tup <> tuple) subst_tuples in
+ And (List.map (fun tup -> Ex (vars, prevtp tup)) subst_tuples) in
+ let all_prev_disj vars guard subst_tuples =
+ All (vars, Or ((Not guard) :: (List.map prevtp subst_tuples))) in
+ let next_gtype vs (g, ts) =
+ And [conj_prev_ex vs g ts; all_prev_disj vs g ts] in
+ let subst_tuples =
+ List.rev_map (fun (_,vs,t,_,_) -> (vs, t)) (guards struc tuple) in
+ let subst_tuples = Aux.unique_sorted (([], tuple) :: subst_tuples) in
+ let all_vars = varnames (Array.length tuple) in
+ let at_most_vs_tuples vs = List.concat (List.map (
+ fun vs -> Aux.assoc_all vs subst_tuples) (Aux.all_subsets vs)) in
+ let tuples_by_vs = List.map (fun vs -> (vs, at_most_vs_tuples vs))
+ (Aux.all_subsets (List.map var_of_string all_vars)) in
+ let all_guards =
+ FormulaOps.atoms (Structure.rel_signature struc) all_vars in
+ let guards_to_tups (vs, tuples) =
+ let has_vs a = List.for_all (fun v -> Aux.array_mem (to_fo v) a) vs in
+ let is_vs_guard a = has_vs a &&
+ Aux.array_existsi (fun _ v -> not (List.mem (v :> var) vs)) a in
+ let is_vs_guard = function Rel (_, a) -> is_vs_guard a | _ -> false in
+ let vs_guards = List.filter is_vs_guard all_guards in
+ let guarded_tups g = List.filter (fun tup-> check struc tup g) tuples in
+ (vs, List.map (fun g -> (g, guarded_tups g)) vs_guards) in
+ let tups_with_guards = List.map guards_to_tups tuples_by_vs in
+ let tups_with_guards =
+ List.filter (fun (vs,_) -> vs <> []) tups_with_guards in
+ let next_gtype_vs (vs, gtups) = And (List.map (next_gtype vs) gtups) in
+ let nextf = And (List.map next_gtype_vs tups_with_guards) in
+ let res = Formula.flatten_sort (
+ And [guarded_type_memo struc mem (qr-1) tuple; nextf]) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ )
+
(* Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
-let rec guarded_type struc qr tuple =
- if qr = 0 then Formula.flatten_sort (And (atoms struc tuple)) else
- let prevtp tup = guarded_type struc (qr-1) tup in
- let conj_prev_ex vars guard subst_tuples =
- let subst_tuples = List.filter (fun tup -> tup <> tuple) subst_tuples in
- And (List.map (fun tup -> Ex (vars, prevtp tup)) subst_tuples) in
- let all_prev_disj vars guard subst_tuples =
- All (vars, Or ((Not guard) :: (List.map prevtp subst_tuples))) in
- let next_gtype vs (g, ts) =
- And [conj_prev_ex vs g ts; all_prev_disj vs g ts] in
- let subst_tuples = Aux.unique_sorted (([], tuple) ::
- List.rev_map (fun (_,vs,t,_,_) -> (vs, t)) (guards struc tuple)) in
- let all_vars = varnames (Array.length tuple) in
- let at_most_vs_tuples vs = List.concat (List.map (
- fun vs -> Aux.assoc_all vs subst_tuples) (Aux.all_subsets vs)) in
- let tuples_by_vs = List.map (fun vs -> (vs, at_most_vs_tuples vs))
- (Aux.all_subsets (List.map var_of_string all_vars)) in
- let all_guards= FormulaOps.atoms (Structure.rel_signature struc) all_vars in
- let guards_to_tups (vs, tuples) =
- let has_vs a = List.for_all (fun v -> Aux.array_mem (to_fo v) a) vs in
- let is_vs_guard a = has_vs a &&
- Aux.array_existsi (fun _ v -> not (List.mem (v :> var) vs)) a in
- let is_vs_guard = function Rel (_, a) -> is_vs_guard a | _ -> false in
- let vs_guards = List.filter is_vs_guard all_guards in
- let guarded_tups g = List.filter (fun tup -> check struc tup g) tuples in
- (vs, List.map (fun g -> (g, guarded_tups g)) vs_guards) in
- let tups_with_guards = List.map guards_to_tups tuples_by_vs in
- let tups_with_guards = List.filter (fun (vs,_)-> vs<>[]) tups_with_guards in
- let next_gtype_vs (vs, gtups) = And (List.map (next_gtype vs) gtups) in
- let nextf = And (List.map next_gtype_vs tups_with_guards) in
- Formula.flatten_sort (And [guarded_type struc (qr-1) tuple; nextf])
+let guarded_type struc qr tuple =
+ guarded_type_memo struc (Hashtbl.create 7) qr tuple
+
(* All guarded types of rank [qr] of guarded [k]-tuples in [struc]. *)
let guarded_types struc ~qr ~k =
let tups = List.map (Structure.incident struc) (Structure.elements struc) in
@@ -146,7 +180,8 @@
List.map Array.of_list (Aux.all_ntuples (Array.to_list tup) k) in
let ktups = List.rev_map k_subtuples (Aux.unique_sorted tups) in
let ktups = Aux.unique_sorted (List.concat ktups) in
- Aux.unique_sorted (List.rev_map (guarded_type struc qr) ktups)
+ let mem = Hashtbl.create 63 in
+ Aux.unique_sorted (List.rev_map (guarded_type_memo struc mem qr) ktups)
@@ -172,30 +207,29 @@
| phi -> phi
-let distinguish_by_type ?(how=Guarded) ?(skip_outer_exists=false) ~qr ~k
- sPos sNeg =
+let distinguish_by_type ?(how=Guarded) ?(skip_outer_exists=false)
+ ~qr ~k pos_struc neg_struc =
let types s = match how with
| Guarded -> guarded_types s ~qr ~k
| Types -> ntypes s ~qr ~k in
- let (tpPos, tpNeg) = (List.map types sPos, List.map types sNeg) in
- (*let all_diff vars = Aux.map_some (
- function [x; y] -> if x < y then Some (Not (Eq (x, y))) else None| _ -> None
- ) (Aux.all_ntuples (List.map to_fo vars) 2) in *)
- let fails_neg f = (* check whether f fails on all negative structs *)
- (* let f = And (f :: (all_diff (FormulaSubst.free_vars f))) in *)
- not (List.exists (fun s -> check s [||] f) sNeg) in
- let succ_pos fl = (* check whether disjunction of fl holds on all positives *)
- (* let f = And ((Or fl):: (all_diff (FormulaSubst.free_vars (Or fl)))) in *)
- List.for_all (fun s -> check s [||] (Or fl)) sPos in
- let candidates = List.rev_append (List.concat tpPos)
- (List.map (fun f -> Not f) (List.concat tpNeg)) in
+ let (pos_tp, neg_tp) = (List.map types pos_struc, List.map types neg_struc) in
+ let candidates = List.rev_append (List.concat pos_tp)
+ (List.map (fun f -> Not f) (List.concat neg_tp)) in
+ let fails_neg f = not (List.exists (fun s -> check s [||] f) neg_struc) in
let fail_neg = List.filter fails_neg (Aux.unique_sorted candidates) in
- let phis = List.sort Formula.compare (Aux.unique_sorted fail_neg) in
+ let fail_neg =
+ List.rev_map (fun f -> Formula.flatten_sort (FormulaOps.nnf f)) fail_neg in
+ let tp_lits = function And fl -> List.filter Formula.is_literal fl | _-> [] in
+ let cmp_tp tp1 tp2 =
+ let c = Formula.compare (And (tp_lits tp1)) (And (tp_lits tp2)) in
+ if c <> 0 then c else Formula.compare tp1 tp2 in
+ let fail_neg = Aux.unique_sorted ~cmp:cmp_tp fail_neg in
+ let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_struc in
let rec find_type acc = function
| [] -> []
| x :: xs -> if succ_pos (x::acc) then x :: acc else
find_type (x::acc) xs in
- let dtypes = find_type [] phis in
+ let dtypes = find_type [] fail_neg in
if dtypes = [] then None else
let is_ok f = fails_neg f && succ_pos [f] in
let mintp = greedy_remove is_ok (Or dtypes) in
Modified: trunk/Toss/Solver/DistinguishTest.ml
===================================================================
--- trunk/Toss/Solver/DistinguishTest.ml 2011-11-14 15:49:50 UTC (rev 1632)
+++ trunk/Toss/Solver/DistinguishTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
@@ -293,13 +293,10 @@
P..
... ...
...P ...
-\"" in (*"P(x2) and ex x3 (P(x3) and C(x2,x3)) and ex x3 (P(x3) and C(x3,x2))"*)
- formula_eq
- ("C(x0, x1) and ex x2 (P(x2) and R(x2, x0)) and " ^
- "ex x2 (P(x2) and R(x2, x1)) and ex x2 (C(x1, x2) and not P(x2))")
- (Distinguish.distinguish ~skip_outer_exists:true
- [strucP] [strucN1; strucN2; strucN3]);
- assert true;
+\"" in formula_eq
+ "P(x0) and P(x1) and C(x0, x1) and ex x2 (P(x2) and C(x2, x0))"
+ (Distinguish.distinguish ~skip_outer_exists:true
+ [strucP] [strucN1; strucN2; strucN3]);
);
"breakthrough" >::
@@ -339,9 +336,8 @@
... ... ... W..
... ... ... ...
...W ... ... ...
-\"" in (* "W(x2) and all x3 not C(x2, x3)" *)
- (* Distinguish.set_debug_level 1; *)
- formula_eq "W(x0) and R(x0, x1) and all x2 not C(x1, x2)"
+\"" in (* Distinguish.set_debug_level 1; *)
+ formula_eq "W(x1) and all x0 not C(x1, x0)"
(Distinguish.distinguish ~skip_outer_exists:true [struc1] [struc2]);
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-17 17:12:57
|
Revision: 1634
http://toss.svn.sourceforge.net/toss/?rev=1634&view=rev
Author: lukaszkaiser
Date: 2011-11-17 17:12:44 +0000 (Thu, 17 Nov 2011)
Log Message:
-----------
Cleanups and optimizations in Distinguish, also changing variable order returned by free_vars, adding comments and reference.
Modified Paths:
--------------
trunk/Toss/Formula/FFTNFTest.ml
trunk/Toss/Formula/FormulaSubst.ml
trunk/Toss/Formula/FormulaSubstTest.ml
trunk/Toss/Formula/Makefile
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Server/LearnGame.ml
trunk/Toss/Server/LearnGameTest.ml
trunk/Toss/Server/Picture.ml
trunk/Toss/Solver/Distinguish.ml
trunk/Toss/Solver/Distinguish.mli
trunk/Toss/Solver/DistinguishTest.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Formula/FFTNFTest.ml
===================================================================
--- trunk/Toss/Formula/FFTNFTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Formula/FFTNFTest.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -17,7 +17,7 @@
let winQxyz =
"ex x, y, z ((((Q(x) and Q(y)) and Q(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
let winQzyx =
- "ex z, y, x (Q(x) and Q(y) and Q(z) and ((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (R(x, v) and C(v, y) and R(y, u) and C(u, z)) or ex u, v (R(x, v) and C(y, v) and R(y, u) and C(z, u))))"
+ "ex x, y, z (Q(x) and Q(y) and Q(z) and ((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (R(x, v) and C(v, y) and R(y, u) and C(u, z)) or ex u, v (R(x, v) and C(y, v) and R(y, u) and C(z, u))))"
let winPxyz =
"ex x, y, z ((((P(x) and P(y)) and P(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
@@ -156,7 +156,7 @@
(formula_of_str winQzyx)));
assert_eq_str ~msg:"reversing ff_tnf"
- "ex z, y, x (Q(z) and Q(y) and Q(x) and ex u0 (ex v0 (R(x, v0) and C(v0, y)) and R(y, u0) and C(u0, z))) or ex z, y, x (Q(z) and Q(y) and Q(x) and ex u (ex v (R(x, v) and C(y, v)) and R(y, u) and C(z, u))) or ex z, y, x (Q(z) and Q(y) and Q(x) and R(x, y) and R(y, z)) or ex z, y, x (Q(z) and Q(y) and Q(x) and C(x, y) and C(y, z))"
+ "ex x, y, z (Q(z) and Q(y) and Q(x) and ex u0 (ex v0 (R(x, v0) and C(v0, y)) and R(y, u0) and C(u0, z))) or ex x, y, z (Q(z) and Q(y) and Q(x) and ex u (ex v (R(x, v) and C(y, v)) and R(y, u) and C(z, u))) or ex x, y, z (Q(z) and Q(y) and Q(x) and R(x, y) and R(y, z)) or ex x, y, z (Q(z) and Q(y) and Q(x) and C(x, y) and C(y, z))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
@@ -275,7 +275,7 @@
(* interpretation warning: in cases below, pulled-out "Q" in the
result represents "not Q" actually (a negative literal) *)
assert_eq_str ~msg:"#5"
- "ex z (Q(z) and ex y not R(x, y)) or ex z, x (P(x) and Q(z) and ex y C(y, z))"
+ "ex z (Q(z) and ex y not R(x, y)) or ex x, z (P(x) and Q(z) and ex y C(y, z))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"])
(Aux.strings_of_list ["Q"])
Modified: trunk/Toss/Formula/FormulaSubst.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubst.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Formula/FormulaSubst.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -276,15 +276,6 @@
(* -------------------------- FREE VARIABLES -------------------------------- *)
-(* Helper function: remove duplicates from sorted list of variables. *)
-let rec remove_dup_vars acc = function
- [] -> acc
- | [v] -> v :: acc
- | v1 :: v2 :: vs ->
- match compare_vars v1 v2 with
- 0 -> remove_dup_vars acc (v2::vs)
- | _ -> remove_dup_vars (v1::acc) (v2::vs)
-
let rec all_vars_acc acc = function
| Eq (x, y) -> (x :> var) :: (y :> var) :: acc
| Rel (r, vs) -> List.rev_append ((Array.to_list vs) :> var list) acc
@@ -314,8 +305,7 @@
List.rev_append (List.rev_map var_str (all_vars_acc [] f)) (all_vars_real r)
| RLet (_, def, re) -> List.rev_append (all_vars_real def) (all_vars_real re)
-let all_vars phi =
- remove_dup_vars [] (List.sort compare_vars (all_vars_acc [] phi))
+let all_vars phi = Aux.unique_sorted ~cmp:compare_vars (all_vars_acc [] phi)
let rec free_vars_acc acc = function
| Eq (x, y) -> (x :> var) :: (y :> var) :: acc
@@ -350,8 +340,7 @@
List.filter (fun w -> not (List.mem w vs)) (free_vars_real r)
| RLet _ as r -> free_vars_real (expand_real_expr r)
-let free_vars phi =
- remove_dup_vars [] (List.sort compare_vars (free_vars_acc [] phi))
+let free_vars phi = Aux.unique_sorted ~cmp:compare_vars (free_vars_acc [] phi)
(* --------------------------- TRANSITIVE CLOSURE --------------------------- *)
Modified: trunk/Toss/Formula/FormulaSubstTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubstTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Formula/FormulaSubstTest.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -121,9 +121,9 @@
assert_equal ~printer:(fun x -> x)
vs (Formula.var_list_str (
FormulaSubst.free_vars (formula_of_string phi))) in
- fv_eq "not (P(x) and not Q(y))" "y, x";
+ fv_eq "not (P(x) and not Q(y))" "x, y";
fv_eq "Q(x) or (ex x P(x))" "x";
- fv_eq "P(x) or ex y (E(x, y) and y in T)" "x, T";
+ fv_eq "P(x) or ex y (E(x, y) and y in T)" "T, x";
fv_eq "lfp T(x) = (P(x) or ex y (E(x, y) and y in T))" "x";
);
Modified: trunk/Toss/Formula/Makefile
===================================================================
--- trunk/Toss/Formula/Makefile 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Formula/Makefile 2011-11-17 17:12:44 UTC (rev 1634)
@@ -5,6 +5,8 @@
AuxTest:
FormulaTest:
+FormulaMapTest:
+FormulaSubstTest:
BoolFormulaTest:
BoolFunctionTest:
FormulaOpsTest:
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -275,14 +275,14 @@
"[a | P:1 {}; Q:1 {} | ] -> [ | P:1 {}; Q(a) | ] emb P, Q"] in
assert_eq_str
- "Sum (z, y, x | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z))) * 0.33) - Sum (z, y, x | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z))) * 0.33)"
+ "Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z))) * 0.33) - Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z))) * 0.33)"
(Formula.real_str
(Heuristic.map_constants (fun c->(floor (c*.100.))/.100.)
(default_heuristic 1. rules
(real_of_str (":("^winPxyz^") - :("^winQxyz^")")))));
assert_eq_str
- "Sum (z, y, x | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z))) * (:(P(x)) + :(P(y)) + :(P(z))) * 0.11) - Sum (z, y, x | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(x)) + :(Q(y)) + :(Q(z))) * 0.11)"
+ "Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (P(x) or P(y) or P(z)) and (not Q(x) or P(x)) and (not Q(y) or P(y)) and (not Q(z) or P(z))) : (:(P(x)) + :(P(y)) + :(P(z))) * (:(P(x)) + :(P(y)) + :(P(z))) * 0.11) - Sum (x, y, z | (((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (C(z, u) and C(y, v) and R(y, u) and R(x, v)) or ex u, v (R(y, u) and R(x, v) and C(v, y) and C(u, z))) and (Q(x) or Q(y) or Q(z)) and (not P(x) or Q(x)) and (not P(y) or Q(y)) and (not P(z) or Q(z))) : (:(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(x)) + :(Q(y)) + :(Q(z))) * 0.11)"
(Formula.real_str
(Heuristic.map_constants (fun c->(floor (c*.100.))/.100.)
(default_heuristic 2. rules
@@ -298,14 +298,14 @@
"[a | P:1 {}; Q:1 {} | ] -> [ | P:1 {}; Q(a) | ] emb P, Q"] in
assert_eq_str
- "Sum (z, y, x, w, v | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * 0.04 ) - Sum (z, y, x, w, v | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * 0.04 )"
+ "Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * 0.04 ) - Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * 0.04 )"
(Formula.real_str
((* Heuristic.map_constants (fun c->(floor (c*.100.))/.100.) *)
(default_heuristic 2. rules
(real_of_str (":("^winPvwxyz^") - :("^winQvwxyz^")")))));
assert_eq_str
- "Sum (z, y, x, w, v | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * 0.008 ) - Sum (z, y, x, w, v | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * 0.008 )"
+ "Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (P(z) or P(y) or P(x) or P(w) or P(v)) and (not Q(z) or P(z)) and (not Q(y) or P(y)) and (not Q(x) or P(x)) and (not Q(w) or P(w)) and (not Q(v) or P(v))) : (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * (:(P(v)) + :(P(w)) + :(P(x)) + :(P(y)) + :(P(z))) * 0.008 ) - Sum (v, w, x, y, z | (((R(v, w) and R(w, x) and R(x, y) and R(y, z)) or (C(v, w) and C(w, x) and C(x, y) and C(y, z)) or ex r, s, t, u (C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)) or ex r, s, t, u (R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(z) or Q(z)) and (not P(y) or Q(y)) and (not P(x) or Q(x)) and (not P(w) or Q(w)) and (not P(v) or Q(v))) : (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * (:(Q(v)) + :(Q(w)) + :(Q(x)) + :(Q(y)) + :(Q(z))) * 0.008 )"
(Formula.real_str
((* Heuristic.map_constants (fun c->(floor (c*.1000.))/.1000.) *)
(default_heuristic 3. rules
@@ -347,7 +347,7 @@
~advr:4.0 game in
assert_eq_str
- "100. * (Sum (cell_e_y8__BLANK_, cell_d_y8__BLANK_, cell_c1_y8__BLANK_, cell_b_y8__BLANK_, cell_a_y8__BLANK_ | ((cell_2x(cell_a_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and (cell_2b(cell_a_y8__BLANK_) or cell_2x(cell_a_y8__BLANK_)) and (cell_2b(cell_b_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_)) and (cell_2b(cell_c1_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_)) and (cell_2b(cell_d_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_)) and (cell_2b(cell_e_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and R2(cell_d_y8__BLANK_, cell_e_y8__BLANK_) and R2(cell_c1_y8__BLANK_, cell_d_y8__BLANK_) and R2(cell_b_y8__BLANK_, cell_c1_y8__BLANK_) and R2(cell_a_y8__BLANK_, cell_b_y8__BLANK_)) : (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * 0.0016 ) + Sum (cell_x18_y14__BLANK_, cell_x17_y15__BLANK_, cell_x16_y16__BLANK_, cell_x15_y17__BLANK_, cell_x14_y18__BLANK_ | ((cell_2x(cell_x14_y18__BLANK_) or cell_2x(cell_x15_y17__BLANK_) or cell_2x(cell_x16_y16__BLANK_) or cell_2x(cell_x17_y15__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and (cell_2b(cell_x14_y18__BLANK_) or cell_2x(cell_x14_y18__BLANK_)) and (cell_2b(cell_x15_y17__BLANK_) or cell_2x(cell_x15_y17__BLANK_)) and (cell_2b(cell_x16_y16__BLANK_) or cell_2x(cell_x16_y16__BLANK_)) and (cell_2b(cell_x17_y15__BLANK_) or cell_2x(cell_x17_y15__BLANK_)) and (cell_2b(cell_x18_y14__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and R1(cell_x17_y15__BLANK_, cell_x18_y14__BLANK_) and R1(cell_x16_y16__BLANK_, cell_x17_y15__BLANK_) and R1(cell_x15_y17__BLANK_, cell_x16_y16__BLANK_) and R1(cell_x14_y18__BLANK_, cell_x15_y17__BLANK_)) : (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * 0.0016 ) + Sum (cell_x9_y9__BLANK_, cell_x13_y13__BLANK_, cell_x12_y12__BLANK_, cell_x11_y11__BLANK_, cell_x10_y10__BLANK_ | ((cell_2x(cell_x10_y10__BLANK_) or cell_2x(cell_x11_y11__BLANK_) or cell_2x(cell_x12_y12__BLANK_) or cell_2x(cell_x13_y13__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and (cell_2b(cell_x10_y10__BLANK_) or cell_2x(cell_x10_y10__BLANK_)) and (cell_2b(cell_x11_y11__BLANK_) or cell_2x(cell_x11_y11__BLANK_)) and (cell_2b(cell_x12_y12__BLANK_) or cell_2x(cell_x12_y12__BLANK_)) and (cell_2b(cell_x13_y13__BLANK_) or cell_2x(cell_x13_y13__BLANK_)) and (cell_2b(cell_x9_y9__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and R0(cell_x9_y9__BLANK_, cell_x10_y10__BLANK_) and R0(cell_x12_y12__BLANK_, cell_x13_y13__BLANK_) and R0(cell_x11_y11__BLANK_, cell_x12_y12__BLANK_) and R0(cell_x10_y10__BLANK_, cell_x11_y11__BLANK_)) : (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * 0.0016 ) + Sum (cell_x8_e0__BLANK_, cell_x8_d0__BLANK_, cell_x8_c2__BLANK_, cell_x8_b0__BLANK_, cell_x8_a0__BLANK_ | ((cell_2x(cell_x8_a0__BLANK_) or cell_2x(cell_x8_b0__BLANK_) or cell_2x(cell_x8_c2__BLANK_) or cell_2x(cell_x8_d0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and (cell_2b(cell_x8_a0__BLANK_) or cell_2x(cell_x8_a0__BLANK_)) and (cell_2b(cell_x8_b0__BLANK_) or cell_2x(cell_x8_b0__BLANK_)) and (cell_2b(cell_x8_c2__BLANK_) or cell_2x(cell_x8_c2__BLANK_)) and (cell_2b(cell_x8_d0__BLANK_) or cell_2x(cell_x8_d0__BLANK_)) and (cell_2b(cell_x8_e0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and R(cell_x8_d0__BLANK_, cell_x8_e0__BLANK_) and R(cell_x8_c2__BLANK_, cell_x8_d0__BLANK_) and R(cell_x8_b0__BLANK_, cell_x8_c2__BLANK_) and R(cell_x8_a0__BLANK_, cell_x8_b0__BLANK_)) : (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * 0.0016 )) + 50. * Sum ( | false : 0. * 0. * 0. * 0. * inf)"
+ "100. * (Sum (cell_a_y8__BLANK_, cell_b_y8__BLANK_, cell_c1_y8__BLANK_, cell_d_y8__BLANK_, cell_e_y8__BLANK_ | ((cell_2x(cell_a_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and (cell_2b(cell_a_y8__BLANK_) or cell_2x(cell_a_y8__BLANK_)) and (cell_2b(cell_b_y8__BLANK_) or cell_2x(cell_b_y8__BLANK_)) and (cell_2b(cell_c1_y8__BLANK_) or cell_2x(cell_c1_y8__BLANK_)) and (cell_2b(cell_d_y8__BLANK_) or cell_2x(cell_d_y8__BLANK_)) and (cell_2b(cell_e_y8__BLANK_) or cell_2x(cell_e_y8__BLANK_)) and R2(cell_d_y8__BLANK_, cell_e_y8__BLANK_) and R2(cell_c1_y8__BLANK_, cell_d_y8__BLANK_) and R2(cell_b_y8__BLANK_, cell_c1_y8__BLANK_) and R2(cell_a_y8__BLANK_, cell_b_y8__BLANK_)) : (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * (:(cell_2x(cell_a_y8__BLANK_)) + :(cell_2x(cell_b_y8__BLANK_)) + :(cell_2x(cell_c1_y8__BLANK_)) + :(cell_2x(cell_d_y8__BLANK_)) + :(cell_2x(cell_e_y8__BLANK_))) * 0.0016 ) + Sum (cell_x14_y18__BLANK_, cell_x15_y17__BLANK_, cell_x16_y16__BLANK_, cell_x17_y15__BLANK_, cell_x18_y14__BLANK_ | ((cell_2x(cell_x14_y18__BLANK_) or cell_2x(cell_x15_y17__BLANK_) or cell_2x(cell_x16_y16__BLANK_) or cell_2x(cell_x17_y15__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and (cell_2b(cell_x14_y18__BLANK_) or cell_2x(cell_x14_y18__BLANK_)) and (cell_2b(cell_x15_y17__BLANK_) or cell_2x(cell_x15_y17__BLANK_)) and (cell_2b(cell_x16_y16__BLANK_) or cell_2x(cell_x16_y16__BLANK_)) and (cell_2b(cell_x17_y15__BLANK_) or cell_2x(cell_x17_y15__BLANK_)) and (cell_2b(cell_x18_y14__BLANK_) or cell_2x(cell_x18_y14__BLANK_)) and R1(cell_x17_y15__BLANK_, cell_x18_y14__BLANK_) and R1(cell_x16_y16__BLANK_, cell_x17_y15__BLANK_) and R1(cell_x15_y17__BLANK_, cell_x16_y16__BLANK_) and R1(cell_x14_y18__BLANK_, cell_x15_y17__BLANK_)) : (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * (:(cell_2x(cell_x14_y18__BLANK_)) + :(cell_2x(cell_x15_y17__BLANK_)) + :(cell_2x(cell_x16_y16__BLANK_)) + :(cell_2x(cell_x17_y15__BLANK_)) + :(cell_2x(cell_x18_y14__BLANK_))) * 0.0016 ) + Sum (cell_x10_y10__BLANK_, cell_x11_y11__BLANK_, cell_x12_y12__BLANK_, cell_x13_y13__BLANK_, cell_x9_y9__BLANK_ | ((cell_2x(cell_x10_y10__BLANK_) or cell_2x(cell_x11_y11__BLANK_) or cell_2x(cell_x12_y12__BLANK_) or cell_2x(cell_x13_y13__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and (cell_2b(cell_x10_y10__BLANK_) or cell_2x(cell_x10_y10__BLANK_)) and (cell_2b(cell_x11_y11__BLANK_) or cell_2x(cell_x11_y11__BLANK_)) and (cell_2b(cell_x12_y12__BLANK_) or cell_2x(cell_x12_y12__BLANK_)) and (cell_2b(cell_x13_y13__BLANK_) or cell_2x(cell_x13_y13__BLANK_)) and (cell_2b(cell_x9_y9__BLANK_) or cell_2x(cell_x9_y9__BLANK_)) and R0(cell_x9_y9__BLANK_, cell_x10_y10__BLANK_) and R0(cell_x12_y12__BLANK_, cell_x13_y13__BLANK_) and R0(cell_x11_y11__BLANK_, cell_x12_y12__BLANK_) and R0(cell_x10_y10__BLANK_, cell_x11_y11__BLANK_)) : (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * (:(cell_2x(cell_x10_y10__BLANK_)) + :(cell_2x(cell_x11_y11__BLANK_)) + :(cell_2x(cell_x12_y12__BLANK_)) + :(cell_2x(cell_x13_y13__BLANK_)) + :(cell_2x(cell_x9_y9__BLANK_))) * 0.0016 ) + Sum (cell_x8_a0__BLANK_, cell_x8_b0__BLANK_, cell_x8_c2__BLANK_, cell_x8_d0__BLANK_, cell_x8_e0__BLANK_ | ((cell_2x(cell_x8_a0__BLANK_) or cell_2x(cell_x8_b0__BLANK_) or cell_2x(cell_x8_c2__BLANK_) or cell_2x(cell_x8_d0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and (cell_2b(cell_x8_a0__BLANK_) or cell_2x(cell_x8_a0__BLANK_)) and (cell_2b(cell_x8_b0__BLANK_) or cell_2x(cell_x8_b0__BLANK_)) and (cell_2b(cell_x8_c2__BLANK_) or cell_2x(cell_x8_c2__BLANK_)) and (cell_2b(cell_x8_d0__BLANK_) or cell_2x(cell_x8_d0__BLANK_)) and (cell_2b(cell_x8_e0__BLANK_) or cell_2x(cell_x8_e0__BLANK_)) and R(cell_x8_d0__BLANK_, cell_x8_e0__BLANK_) and R(cell_x8_c2__BLANK_, cell_x8_d0__BLANK_) and R(cell_x8_b0__BLANK_, cell_x8_c2__BLANK_) and R(cell_x8_a0__BLANK_, cell_x8_b0__BLANK_)) : (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * (:(cell_2x(cell_x8_a0__BLANK_)) + :(cell_2x(cell_x8_b0__BLANK_)) + :(cell_2x(cell_x8_c2__BLANK_)) + :(cell_2x(cell_x8_d0__BLANK_)) + :(cell_2x(cell_x8_e0__BLANK_))) * 0.0016 )) + 50. * Sum ( | false : 0. * 0. * 0. * 0. * inf)"
(Formula.real_str loc_heurs.(0).(0));
);
Modified: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Server/LearnGame.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -19,7 +19,13 @@
let winFormula winningStates notWinningStates =
- Distinguish.distinguish winningStates notWinningStates
+ if !debug_level > 0 then
+ print_endline (
+ "Searching WIN:\n" ^
+ (String.concat "\n" (List.map Structure.str winningStates)) ^ "\nNOT\n"^
+ (String.concat "\n" (List.map Structure.str notWinningStates)));
+ FormulaOps.tnf_fv
+ (Aux.unsome (Distinguish.distinguish winningStates notWinningStates))
let cleanStructure struc =
let funs = ref [] in
Modified: trunk/Toss/Server/LearnGameTest.ml
===================================================================
--- trunk/Toss/Server/LearnGameTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Server/LearnGameTest.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -6,43 +6,6 @@
let struc_of_string s =
StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-let formula_eq ?(flatten_sort=true) phi1 phi2 =
- if flatten_sort then
- assert_equal ~printer:(fun x -> Formula.sprint x)
- (Formula.flatten_sort (formula_of_string phi1))
- (Formula.flatten_sort phi2)
- else
- assert_equal ~printer:(fun x -> Formula.sprint x)
- (formula_of_string phi1) phi2
-
-let formula_list_eq ?(flatten_sort=true) l1 l2 =
- List.iter2 (formula_eq ~flatten_sort) l1 l2
-
-let formula_option_eq ?(flatten_sort=true) fopt1 fopt2 =
- let fopt_str = function None -> "None" | Some f -> Formula.str f in
- if fopt1 = "None" then
- assert_equal ~printer:fopt_str None fopt2
- else match fopt2 with
- | None -> assert_equal ~printer:(fun x -> x) fopt1 "None"
- | Some f -> formula_eq ~flatten_sort fopt1 f
-
-let hashtbl_eq struc list ht =
- let str_pair (tuple, phi) =
- (Structure.tuple_str struc tuple) ^ "->" ^ (Formula.str phi) in
- let str ps = String.concat "; " (List.map str_pair ps) in
- let hashtbl_to_list ht =
- let res = ref [] in
- Hashtbl.iter (fun k v -> res := (k, v) :: !res) ht; !res in
- let lst = List.map (fun (tp, fs) -> (tp, formula_of_string fs)) list in
- let simp l = List.sort Pervasives.compare
- (List.map (fun (t, f) -> (t, Formula.flatten f)) l) in
- assert_equal ~printer:str (simp lst) (simp (hashtbl_to_list ht))
-
-let array_list_str f a = "[| [" ^ (String.concat "]; [" (
- List.map (fun l -> String.concat ";" (List.map f l))
- (Array.to_list a))) ^ "] |]"
-
-
let tests = "LearnGame" >::: [
"simple test game" >::
(fun () ->
@@ -76,8 +39,8 @@
\"" ;]] in
let res_game =
"PLAYERS 1, 2
-REL Win1() = ex x0, x1 (Q(x1) and R(x1, x0))
-REL Win2() = ex x0, x1 (Q(x1) and R(x0, x1))
+REL Win1() = ex x1 (Q(x1) and ex x0 R(x1, x0))
+REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
RULE Mv1:
[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
emb R,Q,P pre not Win2()
Modified: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Server/Picture.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -362,7 +362,7 @@
Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And (basic :: mw));
if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint
- (Aux.unsome (Distinguish.distinguish_by_type ~qr:1 ~k:2 [right] [wrong]));
+ (Aux.unsome (Distinguish.distinguish_upto ~qr:1 ~k:2 [right] [wrong]));
Formula.flatten (Formula.Ex (ex_vars, Formula.And (basic :: mw)))
)
Modified: trunk/Toss/Solver/Distinguish.ml
===================================================================
--- trunk/Toss/Solver/Distinguish.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Solver/Distinguish.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -3,10 +3,9 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i)
-type distinguish_method = Types | Guarded
+type logic = FO | GuardedFO
-
(* Helper functions to construct variables for indices. *)
let varname i = "x" ^ string_of_int i
let varnames k = List.map varname (Aux.range k)
@@ -76,8 +75,9 @@
(* - Guards and Guarded Types - *)
(* Generate all guarded substitutions of [tuple] with the guards.
+ A subst-tuple is a substitution of [tuple] if it has the same length.
A subst-tuple is a guarded substitution of [tuple] if a permuted
- sub-tuple a of subst-tuple containig at least one element of
+ sub-tuple of subst-tuple containig at least one element of
the original [tuple] is in some relation R in the structure [struc].
The guard for subst-tuple is then the atomic formula R(x_i1, ..., x_iK)
such that a = (subst-tuple_i1, ..., subst-tuple_iK) and R(a) holds.
@@ -206,39 +206,50 @@
| All (vs, f) -> All (vs, greedy_remove (fun x -> cond (All (vs, x))) f)
| phi -> phi
+(* Order on types that we use to select the minimal one. *)
+let compare_types tp1 tp2 =
+ let tp_lits = function And fl -> List.filter Formula.is_literal fl | _-> [] in
+ let c = Formula.compare (And (tp_lits tp1)) (And (tp_lits tp2)) in
+ if c <> 0 then c else Formula.compare tp1 tp2
-let distinguish_by_type ?(how=Guarded) ?(skip_outer_exists=false)
- ~qr ~k pos_struc neg_struc =
- let types s = match how with
- | Guarded -> guarded_types s ~qr ~k
- | Types -> ntypes s ~qr ~k in
- let (pos_tp, neg_tp) = (List.map types pos_struc, List.map types neg_struc) in
- let candidates = List.rev_append (List.concat pos_tp)
- (List.map (fun f -> Not f) (List.concat neg_tp)) in
- let fails_neg f = not (List.exists (fun s -> check s [||] f) neg_struc) in
- let fail_neg = List.filter fails_neg (Aux.unique_sorted candidates) in
- let fail_neg =
- List.rev_map (fun f -> Formula.flatten_sort (FormulaOps.nnf f)) fail_neg in
- let tp_lits = function And fl -> List.filter Formula.is_literal fl | _-> [] in
- let cmp_tp tp1 tp2 =
- let c = Formula.compare (And (tp_lits tp1)) (And (tp_lits tp2)) in
- if c <> 0 then c else Formula.compare tp1 tp2 in
- let fail_neg = Aux.unique_sorted ~cmp:cmp_tp fail_neg in
- let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_struc in
+let compare_types = ref compare_types
+
+(* Find the minimal [logic]-type of [struc] not included in [neg_types]
+ and with at most [qr] quantifiers and [k] variables. *)
+let min_type_omitting ?(logic = GuardedFO) ~qr ~k neg_types struc =
+ let pos_types = match logic with
+ | GuardedFO -> guarded_types struc ~qr ~k
+ | FO -> ntypes struc ~qr ~k in
+ let ok_types = List.filter (fun f -> not (List.mem f neg_types)) pos_types in
+ let ok_types = List.sort !compare_types ok_types in
+ if ok_types = [] then None else Some (List.hd ok_types)
+
+(* Find a [logic]-formula with at most [qr] quantifiers and [k] variables
+ which holds on all [pos_strucs] and on no [neg_strucs]. *)
+let distinguish_upto ?(logic = GuardedFO) ~qr ~k pos_strucs neg_strucs =
+ let types s = match logic with
+ | GuardedFO -> guarded_types s ~qr ~k
+ | FO -> ntypes s ~qr ~k in
+ let neg_tps = Aux.unique_sorted (Aux.concat_map types neg_strucs) in
+ let pos_tps = Aux.unique_sorted ~cmp:!compare_types (
+ Aux.map_some (min_type_omitting ~logic ~qr ~k neg_tps) pos_strucs) in
+ let fails_neg f = not (List.exists (fun s -> check s [||] f) neg_strucs) in
+ let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
let rec find_type acc = function
| [] -> []
| x :: xs -> if succ_pos (x::acc) then x :: acc else
find_type (x::acc) xs in
- let dtypes = find_type [] fail_neg in
+ let dtypes = find_type [] pos_tps in
if dtypes = [] then None else
let is_ok f = fails_neg f && succ_pos [f] in
let mintp = greedy_remove is_ok (Or dtypes) in
let fv = FormulaSubst.free_vars mintp in
- let t = FormulaOps.rename_quant_avoiding fv mintp in
- if skip_outer_exists then Some t else
- Some (Ex (List.sort Formula.compare_vars fv, t))
+ Some (FormulaOps.rename_quant_avoiding fv mintp)
-let distinguish ?(how=Guarded) ?(skip_outer_exists=false) strucs1 strucs2 =
+
+(* Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
+ Leaves free variables (existential) if [skip_outer_exists] is set. *)
+let distinguish ?(how=GuardedFO) ?(skip_outer_exists=false) strucs1 strucs2 =
if !debug_level > 0 then
Printf.printf "distinguishing:\n\n%s\n\n and\n\n %s\n%!"
(String.concat "\n" (List.map Structure.str strucs1))
@@ -246,8 +257,10 @@
let rec diff qr k =
if qr > k then diff 0 (k+1) else (
if !debug_level > 0 then Printf.printf "distinguish qr %i k %i\n%!" qr k;
- match distinguish_by_type ~how ~skip_outer_exists ~qr ~k strucs1 strucs2 with
- | Some f -> f
+ match distinguish_upto ~logic:how ~qr ~k strucs1 strucs2 with
+ | Some f ->
+ if skip_outer_exists then Some f else
+ Some (Ex (FormulaSubst.free_vars f, f))
| None -> diff (qr+1) k
) in
diff 0 1
Modified: trunk/Toss/Solver/Distinguish.mli
===================================================================
--- trunk/Toss/Solver/Distinguish.mli 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Solver/Distinguish.mli 2011-11-17 17:12:44 UTC (rev 1634)
@@ -1,6 +1,6 @@
(** Distinguish sets of structures by formulas. *)
-type distinguish_method = Types | Guarded
+type logic = FO | GuardedFO
(** {2 Atoms and FO Types} *)
@@ -19,6 +19,7 @@
(** {2 Guards and Guarded Types} *)
(** Generate all guarded substitutions of [tuple] with the guards.
+ A subst-tuple is a substitution of [tuple] if it has the same length.
A subst-tuple is a guarded substitution of [tuple] if a permuted
sub-tuple a of subst-tuple containig at least one element of
the original [tuple] is in some relation R in the structure [struc].
@@ -45,14 +46,26 @@
(** {2 Distinguishing Structure Sets} *)
-val distinguish_by_type: ?how: distinguish_method -> ?skip_outer_exists: bool ->
- qr: int -> k: int -> Structure.structure list -> Structure.structure list ->
- Formula.formula option
-
-val distinguish: ?how: distinguish_method -> ?skip_outer_exists: bool ->
- Structure.structure list -> Structure.structure list -> Formula.formula
+(** Order on types that we use to select the minimal ones. *)
+val compare_types : (Formula.formula -> Formula.formula -> int) ref
+(** Find the minimal [logic]-type of [struc] not included in [neg_types]
+ and with at most [qr] quantifiers and [k] variables. *)
+val min_type_omitting: ?logic: logic -> qr: int -> k: int ->
+ Formula.formula list -> Structure.structure -> Formula.formula option
+(** Find a [logic]-formula with at most [qr] quantifiers and [k] variables
+ which holds on all [pos_strucs] and on no [neg_strucs].
+ Leaves free variables which are implicitly quantified existentially. *)
+val distinguish_upto: ?logic: logic -> qr: int -> k: int ->
+ Structure.structure list -> Structure.structure list -> Formula.formula option
+
+(** Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
+ Leaves free variables (existential) if [skip_outer_exists] is set. *)
+val distinguish: ?how: logic -> ?skip_outer_exists: bool ->
+ Structure.structure list -> Structure.structure list -> Formula.formula option
+
+
(** {2 Debugging} *)
val set_debug_level: int -> unit
Modified: trunk/Toss/Solver/DistinguishTest.ml
===================================================================
--- trunk/Toss/Solver/DistinguishTest.ml 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/Solver/DistinguishTest.ml 2011-11-17 17:12:44 UTC (rev 1634)
@@ -208,39 +208,38 @@
(List.length (Distinguish.guarded_types struc ~qr:1 ~k:2));
);
- "distinguish_by_type" >::
+ "distinguish_upto" >::
(fun () ->
let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
formula_option_eq "None"
- (Distinguish.distinguish_by_type ~qr:2 ~k:1 [struc1] [struc2]);
+ (Distinguish.distinguish_upto ~qr:2 ~k:1 [struc1] [struc2]);
formula_option_eq "None" (* we use guarded types - so None here *)
- (Distinguish.distinguish_by_type ~qr:0 ~k:2 [struc1] [struc2]);
+ (Distinguish.distinguish_upto ~qr:0 ~k:2 [struc1] [struc2]);
formula_option_eq "not R(x0, x1) and not x0 = x1 and not R(x1, x0)"
- (Distinguish.distinguish_by_type ~how:Types ~skip_outer_exists:true
- ~qr:0 ~k:2 [struc1] [struc2]);
+ (Distinguish.distinguish_upto ~logic:FO ~qr:0 ~k:2 [struc1] [struc2]);
formula_option_eq "None" (* we use guarded types - so None here *)
- (Distinguish.distinguish_by_type ~qr:0 ~k:3 [struc1] [struc2]);
+ (Distinguish.distinguish_upto ~qr:0 ~k:3 [struc1] [struc2]);
formula_option_eq "R(x0, x1) and ex x2 R(x2, x0)"
- (Distinguish.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
- [struc1] [struc2]);
+ (Distinguish.distinguish_upto ~qr:1 ~k:2 [struc1] [struc2]);
let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
- formula_option_eq "ex x0 P(x0)"
- (Distinguish.distinguish_by_type ~qr:0 ~k:1 [struc1] [struc2]);
+ formula_option_eq "P(x0)"
+ (Distinguish.distinguish_upto ~qr:0 ~k:1 [struc1] [struc2]);
);
"distinguish" >::
(fun () ->
let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
- formula_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x2, x0))"
+ formula_option_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x2, x0))"
(Distinguish.distinguish [struc1] [struc2]);
let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
- formula_eq "ex x0 P(x0)" (Distinguish.distinguish [struc1] [struc2]);
+ formula_option_eq "ex x0 P(x0)"
+ (Distinguish.distinguish [struc1] [struc2]);
let struc1 = struc_of_string "[ | | ] \"
...
@@ -254,7 +253,7 @@
...
...
\"" in
- formula_eq "ex x0, x1 (P(x0) and C(x0, x1))"
+ formula_option_eq "ex x0, x1 (P(x0) and C(x0, x1))"
(Distinguish.distinguish [struc1] [struc2]);
);
]
@@ -293,7 +292,7 @@
P..
... ...
...P ...
-\"" in formula_eq
+\"" in formula_option_eq
"P(x0) and P(x1) and C(x0, x1) and ex x2 (P(x2) and C(x2, x0))"
(Distinguish.distinguish ~skip_outer_exists:true
[strucP] [strucN1; strucN2; strucN3]);
@@ -337,7 +336,7 @@
... ... ... ...
...W ... ... ...
\"" in (* Distinguish.set_debug_level 1; *)
- formula_eq "W(x1) and all x0 not C(x1, x0)"
+ formula_option_eq "W(x1) and all x0 not C(x1, x0)"
(Distinguish.distinguish ~skip_outer_exists:true [struc1] [struc2]);
);
]
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-11-16 21:58:12 UTC (rev 1633)
+++ trunk/Toss/www/reference/reference.tex 2011-11-17 17:12:44 UTC (rev 1634)
@@ -1,4 +1,4 @@
-\documentclass{scrbook}
+\documentclass[oneside,fleqn]{scrbook}
% Font choice
\usepackage[sc]{mathpazo}
@@ -94,6 +94,7 @@
\newcommand{\TrST}{\ensuremath{\mathrm{TrST}}}
\newcommand{\lfp}{\mathrm{lfp}}
\newcommand{\gfp}{\mathrm{gfp}}
+\newcommand{\tp}{\mathrm{tp}}
% Theorem environments
\theoremstyle{plain}
@@ -1101,11 +1102,12 @@
\section{Solver Techniques}
-We used a SAT solver (MiniSAT) to operate on symbolic representations
-of MSO variables. We decided in favor of CNF representation instead of
-the more standard BDD approach as it seems to scale in a more consistent way.
+We use a SAT solver (from The Decision Procedure Toolkit, DPT) to operate on
+symbolic representations of MSO variables. We decided in favor of CNF
+representation instead of the more standard BDD approach as it seems to
+scale in a more consistent way.
-For handling real arithmetic, we implemented a quantifier elimination
+For handling real arithmetic, we implement a quantifier elimination
procedure based on Muchnik's proof. It is not as efficient as CAD
(cylindrical algebraic decomposition) but works very consistently
for many cases.
@@ -1113,7 +1115,156 @@
The main formula optimization is just performing the TNF, later we
only push predicates to the front.
+\chapter{Formula and Game Induction}
+In this chapter we present a method for constructing formulas that
+separate sets of structures from such sets given as input, and we
+describe how games can be learned from example plays using this method.
+
+\section{Fragments of First-Order Logic}
+
+The $k$-variable fragment of FO consists of all formulas which use only
+the variables $x_1, \ldots, x_{k-1}$, both as free ones and under quantifiers.
+
+The guarded fragment of FO is defined inductively by
+\[ \phi\ ::= \ R(\ol{x}) \ \mid \ x = x \ \mid \ \neg \phi \ \mid \
+ \phi \land \phi \ \mid \ \phi \lor \phi \ \mid \]
+\[ \phantom{\phi\ :==}\
+ \exists \ol{y} \big( R(\ol{x},\ol{y}) \land \phi(\ol{x},\ol{y}) \big)
+ \quad \mid \quad
+ \forall \ol{y} \big( \neg R(\ol{x},\ol{y}) \lor \phi(\ol{x},\ol{y})\big),\]
+where in the line above $\phi(\ol{x},\ol{y})$ means that all free variables
+of $\phi$ must be included in the set $\{\ol{x}\} \cup \{\ol{y}\}$.
+
+\begin{example}
+Formulas of modal logic translate to guarded first-order logic with two
+variables, so \eg a formula with one free variable $x$ expressing that
+``every $E$-sucessor of $x$ has an $R$-successor in which $P$ holds'' can be
+written in the guarded fragment with two variables as follows:
+\[ \exists y \big( E(x, y) \land \forall x (R(y, x) \to P(y)) \big). \]
+\end{example}
+
+
+\section{Types}
+
+Let $\calL$ be any set of formulas, \eg a fragment of first-order logic.
+The $\calL$-type of a tuple $\ol{a}$ in a structure $\frakA$ is the subset
+of $\calL$ of formulas with as many free variables as $|\ol{a}|$ which are
+satisified by $\ol{a}$ in $\frakA$, \ie
+\[ \calL-\mathrm{type}(\frakA, \ol{a}) =
+ \{ \phi(\ol{x}) \in \calL \mid |\ol{x}| = |\ol{a}| \text{ and }
+ \frakA \models \phi(\ol{a}) \}. \]
+
+The set described above is most often infinite even for trivial reasons, \eg
+it might contain formulas $P(x), P(x) \land P(x), P(x) \land P(x) \land P(x)$,
+and so on -- something which could be described just by $P(x)$. And since in
+many cases there exists one formula describing this set, we will often abuse
+the terminology and say that the $\calL$-type of $\ol{a}$ in $\frakA$ is one
+formula $\tau \in \calL$, denoted $\tau = \tp^\calL(\frakA, \ol{a})$, such that
+\[ \frakA \models \tau(\ol{a}) \text{ and for all } \phi \in
+ \calL-\mathrm{type}(\frakA, \ol{a}) \text{ holds }
+ \tau(\ol{x}) \Rightarrow \phi(\ol{x}). \]
+
+Note that, in principle, such a formula $\tau$ might not exist in $\calL$.
+But it does exist for fragments of FO with bounded quantifier rank,
+additionally bounded number of variables, and additionally guarded.
+The proof of existence is done by inductive construction, and the same
+constructions are also used in our algorithms to compute the types.
+
+\subsubsection{Type in FO with Bounded Rank and Variable Number}
+
+Let $n$ be the bound on the number of quantifiers and let us fix $\frakA$
+and $\ol{a}$ and assume that $|\ol{a}| = k$ is also the bound on the number
+of variables we are allowed to use. We denote the FO type with quantifier rank
+bounded by $n$ and variable number bounded by $k$ by $\tp^{n,k}(\frakA,\ol{a})$.
+
+For $n = 0$, the formula $\tp^{n,k}(\frakA,\ol{a})$ is simply a conjunction of
+all literals satisfied by $\ol{a}$ in $\frakA$, which we compute exhaustively.
+
+For $n > 0$, the formula $\tp^{n,k}(\frakA,\ol{a})$ is given by
+\[ \tp^{n-1,k}(\frakA,\ol{a}) \ \land\ \Land_{i < |\ol{a}|} \left(
+ \forall x_i \left( \Lor_{b \in \frakA}
+ \tp^{n-1,k}(\frakA,\ol{a}[a_i \ot b]) \right) \ \land \
+ \Land_{b \in \frakA} \exists x_i \left(
+ \tp^{n-1,k}(\frakA,\ol{a}[a_i \ot b]) \right) \right). \]
+We omit the proof of correctness for this formula.
+
+
+\subsubsection{Type in Guarded FO with Bounded Rank and Variable Number}
+
+Let $n$ be the bound on the number of quantifiers and let us fix $\frakA$
+and $\ol{a}$ and assume that $|\ol{a}| = k$ is also the bound on the number
+of variables we are allowed to use. We denote the guarded-FO type with
+quantifier rank bounded by $n$ and variable number bounded by $k$ by
+$\tp_g^{n,k}(\frakA,\ol{a})$.
+
+For $n = 0$, $\tp^{n,k}(\frakA,\ol{a})$ is again a conjunction of
+all literals satisfied by $\ol{a}$ in $\frakA$.
+
+For $n > 0$, we first need to consider all \emph{guarded substitutions} of
+the tuple $\ol{a}$. We say that $\ol{b}$ is a guarded substitution of $\ol{a}$
+in $\frakA$ if $|\ol{b}| = |\ol{a}|$, and there is a subset $\{b_1,\ldots,b_k\}$
+of $\ol{b}$ such that $(b_1, \ldots, b_k) \in R^\frakA$ for some $R$, at least
+one $b_i \in \ol{a}$, and on all positions $j < |b|$ either
+$b[j] = a[j]$ or $b[j] = b_i$ for some $i$.
+
+Let now $S$ be the set of all guarded substitutions of $\ol{a}$ and
+$V$ the set of all proper subsets of variables $x_0, \ldots, x_{|a|-1}$.
+For each non-empty set $\sfx \in V$ let $G_\sfx$ denote proper guards
+for $\sfx$, \ie formulas $R(\ol{x}, \ol{y})$ such that $\{\ol{x}\} = \sfx$
+and $\ol{y}$ is not empty. For each such $g \in G_\sfx$ let us denote by
+$S_g$ the subset of $S$ for which the guard $g$ holds, \ie
+$S_g = \{ \ol{b} \in S \mid \frakA \models g(\ol{b}) \}.$
+We will now construct the next type for $\sfx$ and $g \in G_\sfx$ as
+\[ \tau_{\sfx, g} =
+ \forall \sfx \left(g \to
+ \Lor_{\ol{b} \in S_g}\tp_g^{n-1,k}(\frakA,\ol{b}) \right) \ \land \
+ \Land_{\ol{b} \in S_g} \exists \sfx \left(
+ g \land \tp_g^{n-1,k}(\frakA,\ol{b}) \right). \]
+
+Finally, the guarded type $\tp_g^{n,k}(\frakA,\ol{a})$ is given by
+\[ \tp^{n-1,k}(\frakA,\ol{a}) \ \land\
+ \Land_{\sfx \in V} \Land_{g \in G_\sfx} \tau_{\sfx, g}. \]
+
+
+\section{Learning Games}
+
+Let us start by showing how to learn two-player zero-sum games with payoffs only
+$1$, $0$, and $-1$. First, we say that an abstract \emph{play} is a sequence
+\[ \frakA_0 \to_{p_0} \frakA_1 \to_{p_1} \dots \to_{p_{n-1}} \frakA_n, \]
+where each $\frakA_i$ is a structure (the state of the play) and each
+$p_i$ is the player who made that move, \ie $p_i \in \{0,1\}$.
+The input for learning a game as above consists of four sets of plays:
+\begin{enumerate}
+\item[$\Pi_1$] -- plays after which Player~$0$ gets payoff $1$,
+\item[$\Pi_0$] -- plays after which both players get payoff $0$,
+\item[$\Pi_{-1}$] -- plays after which Player~$0$ gets payoff $-1$,
+\item[$\Pi_W$] -- plays in which the last move is incorrect.
+\end{enumerate}
+
+To learn the game, we induce the winning conditions for both players and
+the termination condition, and the rules for moves of the players.
+
+\subsubsection{Termination Condition and Payoffs}
+
+To learn this, we apply the distinguish function described above $3$ times,
+to induce formulas for the last structures in $\Pi_1, \Pi_0$ and $\Pi_{-1}$.
+
+\subsubsection{Inducing Moves}
+
+First, we create for each of the two players two list of pairs
+$(\frakL, \frakR)$ -- one with all his correct moves in the sets $\Pi_*$ and
+the other with incorrect moves of this player, \ie the last ones from $\Pi_W$.
+We create the general move rules by taking the positive list and cutting
+each $(\frakL, \frakR)$ to only the elements that differ. If the list of
+wrong moves is empty, this is the end, we have the moves.
+
+If the list of wrong moves is not empty, we match each general move to
+the right and wrong move pairs in which it could have been applied,
+and use the function distinguish from above to learn a precondition or
+postcondition which will restrict the move only to the correct structures.
+
+
\chapter{GDL to Toss Translation}
\section{Game Description Language}
@@ -1167,28 +1318,20 @@
(init (cell c c b))
(init (control x))
(<= (next (control ?r)) (does ?r noop))
-(<= (next (cell ?x ?y ?r))
- (does ?r (mark ?x ?y)))
-(<= (next (cell ?x ?y ?c))
- (true (cell ?x ?y ?c))
- (does ?r (mark ?x1 ?y1))
+(<= (next (cell ?x ?y ?r)) (does ?r (mark ?x ?y)))
+(<= (next (cell ?x ?y ?c)) (true (cell ?x ?y ?c)) (does ?r (mark ?x1 ?y1))
(or (distinct ?x ?x1) (distinct ?y ?y1)))
-(<= (legal ?r (mark ?x ?y))
- (true (control ?r))
- (true (cell ?x ?y b)))
-(<= (legal ?r noop) (role ?r)
- (not (true (control ?r))))
+(<= (legal ?r (mark ?x ?y)) (true (control ?r)) (true (cell ?x ?y b)))
+(<= (legal ?r noop) (role ?r) (not (true (control ?r))))
(<= (goal ?r 100) (conn3 ?r))
-(<= (goal ?r 50) (role ?r)
- (not exists_line3))
+(<= (goal ?r 50) (role ?r) (not exists_line3))
(<= (goal x 0) (conn3 o))
(<= (goal o 0) (conn3 x))
(<= terminal exists_line3)
(<= terminal (not exists_blank))
(<= exists_blank (true (cell ?x ?y b)))
(<= exists_line3 (role ?r) (conn3 ?r))
-(<= (conn3 ?r) (or (col ?r) (row ?r)
- (diag1 ?r) (diag2 ?r)))
+(<= (conn3 ?r) (or (col ?r) (row ?r) (diag1 ?r) (diag2 ?r)))
(<= (row ?r)
(true (cell ?a ?y ?r)) (nextcol ?a ?b)
(true (cell ?b ?y ?r)) (nextcol ?b ?c)
@@ -2496,10 +2639,8 @@
-\chapter{Design}
+\chapter{Implementation}
-\section{Organization of Code}
-
Toss consists of the main \emph{TossServer} which is built from several
main modules explained in the sections below and corresponding to
directories in the code tree. The main modules contain OCaml modules
@@ -2512,7 +2653,7 @@
specification of available server requests and the response format.
-\section{Formula}
+\subsubsection{Formula}
This most basic directory implements formulas as described above and various
operations on formulas which are necessary for other modules. It also
@@ -2521,28 +2662,28 @@
simplification.
-\section{Solver}
+\subsubsection{Solver}
This directory contains the module which represents relational structures,
and the full Solver, including the elimination-based solver for the theory
of reals and the SAT-based solving algorithm for monadic second-order logic.
-\section{Arena}
+\subsubsection{Arena}
This directory contains modules which implement the game definition,
including discrete and continuous structure rewriting, game file parser
and client-server communication parser and request type.
-\section{Play}
+\subsubsection{Play}
This directory contains modules responsible for automatic play, including
the heuristic generation module, the abstract game tree module and its
instantiations to Maximax and UCT.
-\section{GGP}
+\subsubsection{GGP}
This directory contains the code which translates GDL files into Toss
format together with various needed simplifications. Multiple tests
@@ -2550,19 +2691,14 @@
of the Toss-GGP code.
-\section{Server}
+\subsubsection{Server}
In this directory we simply keep the implementation of TossServer
together with several high-level tests to check that it works ok.
-\section{Client}
+\subsubsection{WebClient}
-This stand-alone Toss client is written in python using the Qt4 library.
-
-
-\section{WebClient}
-
The browser-based client does not currently interface TossServer directly,
but uses a python request Handler.py as an intermediate step. This handler
also manages a database of users and games.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-17 23:56:48
|
Revision: 1635
http://toss.svn.sourceforge.net/toss/?rev=1635&view=rev
Author: lukaszkaiser
Date: 2011-11-17 23:56:41 +0000 (Thu, 17 Nov 2011)
Log Message:
-----------
Corrections in Distinguish, adding and cleaning up code documentation, removing old unused modules.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Formula/FormulaMap.mli
trunk/Toss/Formula/FormulaSubst.mli
trunk/Toss/Formula/Sat/Sat.mli
trunk/Toss/GGP/GameSimpl.mli
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/Server/DB.mli
trunk/Toss/Server/Picture.mli
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/Distinguish.ml
trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
trunk/Toss/Solver/RealQuantElim/OrderedPolySet.mli
trunk/Toss/Solver/RealQuantElim/Poly.mli
trunk/Toss/Solver/RealQuantElim/RealQuantElim.mli
trunk/Toss/Solver/RealQuantElim/SignTable.mli
trunk/Toss/Solver/Structure.mli
trunk/Toss/Toss.odocl
Removed Paths:
-------------
trunk/Toss/Formula/Sat/IntSet.ml
trunk/Toss/Formula/Sat/IntSet.mli
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Arena/DiscreteRule.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,4 +1,4 @@
-(** {1 Discrete Structure Rewriting Rules and Rewriting.} *)
+(** Discrete structure rewriting rules construction and rewriting. *)
val debug_level : int ref
Modified: trunk/Toss/Formula/FormulaMap.mli
===================================================================
--- trunk/Toss/Formula/FormulaMap.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Formula/FormulaMap.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,3 +1,5 @@
+(** Maps, iterators and folds over formulas and real-valued expressions. *)
+
open Formula
(** {2 Basic maps - to literals and atoms.} *)
Modified: trunk/Toss/Formula/FormulaSubst.mli
===================================================================
--- trunk/Toss/Formula/FormulaSubst.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Formula/FormulaSubst.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,3 +1,5 @@
+(** Substitutions in formulas and real-valued expressions. *)
+
open Formula
(** {2 Basic Substitution Functions} *)
Deleted: trunk/Toss/Formula/Sat/IntSet.ml
===================================================================
--- trunk/Toss/Formula/Sat/IntSet.ml 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Formula/Sat/IntSet.ml 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,688 +0,0 @@
-(**************************************************************************)
-(* *)
-(* Copyright (C) Jean-Christophe Filliatre *)
-(* *)
-(* This software is free software; you can redistribute it and/or *)
-(* modify it under the terms of the GNU Library General Public *)
-(* License version 2.1, with the special exception on linking *)
-(* described in file LICENSE. *)
-(* *)
-(* This software 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. *)
-(* *)
-(**************************************************************************)
-
-(*i $Id: ptset.ml,v 1.17 2008-07-22 06:44:06 filliatr Exp $ i*)
-
-(*s Sets of integers implemented as Patricia trees, following Chris
- Okasaki and Andrew Gill's paper {\em Fast Mergeable Integer Maps}
- ({\tt\small http://www.cs.columbia.edu/\~{}cdo/papers.html\#ml98maps}).
- Patricia trees provide faster operations than standard library's
- module [Set], and especially very fast [union], [subset], [inter]
- and [diff] operations. *)
-
-(*s The idea behind Patricia trees is to build a {\em trie} on the
- binary digits of the elements, and to compact the representation
- by branching only one the relevant bits (i.e. the ones for which
- there is at least on element in each subtree). We implement here
- {\em little-endian} Patricia trees: bits are processed from
- least-significant to most-significant. The trie is implemented by
- the following type [t]. [Empty] stands for the empty trie, and
- [Leaf k] for the singleton [k]. (Note that [k] is the actual
- element.) [Branch (m,p,l,r)] represents a branching, where [p] is
- the prefix (from the root of the trie) and [m] is the branching
- bit (a power of 2). [l] and [r] contain the subsets for which the
- branching bit is respectively 0 and 1. Invariant: the trees [l]
- and [r] are not empty. *)
-
-(*i*)
-type elt = int
-(*i*)
-
-type t =
- | Empty
- | Leaf of int
- | Branch of int * int * t * t
-
-(*s Example: the representation of the set $\{1,4,5\}$ is
- $$\mathtt{Branch~(0,~1,~Leaf~4,~Branch~(1,~4,~Leaf~1,~Leaf~5))}$$
- The first branching bit is the bit 0 (and the corresponding prefix
- is [0b0], not of use here), with $\{4\}$ on the left and $\{1,5\}$ on the
- right. Then the right subtree branches on bit 2 (and so has a branching
- value of $2^2 = 4$), with prefix [0b01 = 1]. *)
-
-(*s Empty set and singletons. *)
-
-let empty = Empty
-
-let is_empty = function Empty -> true | _ -> false
-
-let singleton k = Leaf k
-
-let is_singleton = function Leaf _ -> true | _ -> false
-
-(*s Testing the occurrence of a value is similar to the search in a
- binary search tree, where the branching bit is used to select the
- appropriate subtree. *)
-
-let zero_bit k m = (k land m) == 0
-
-let rec mem k = function
- | Empty -> false
- | Leaf j -> k == j
- | Branch (_, m, l, r) -> mem k (if zero_bit k m then l else r)
-
-(*s The following operation [join] will be used in both insertion and
- union. Given two non-empty trees [t0] and [t1] with longest common
- prefixes [p0] and [p1] respectively, which are supposed to
- disagree, it creates the union of [t0] and [t1]. For this, it
- computes the first bit [m] where [p0] and [p1] disagree and create
- a branching node on that bit. Depending on the value of that bit
- in [p0], [t0] will be the left subtree and [t1] the right one, or
- the converse. Computing the first branching bit of [p0] and [p1]
- uses a nice property of twos-complement representation of integers. *)
-
-let lowest_bit x = x land (-x)
-
-let branching_bit p0 p1 = lowest_bit (p0 lxor p1)
-
-let mask p m = p land (m-1)
-
-let join (p0,t0,p1,t1) =
- let m = branching_bit p0 p1 in
- if zero_bit p0 m then
- Branch (mask p0 m, m, t0, t1)
- else
- Branch (mask p0 m, m, t1, t0)
-
-(*s Then the insertion of value [k] in set [t] is easily implemented
- using [join]. Insertion in a singleton is just the identity or a
- call to [join], depending on the value of [k]. When inserting in
- a branching tree, we first check if the value to insert [k]
- matches the prefix [p]: if not, [join] will take care of creating
- the above branching; if so, we just insert [k] in the appropriate
- subtree, depending of the branching bit. *)
-
-let match_prefix k p m = (mask k m) == p
-
-let add k t =
- let rec ins = function
- | Empty -> Leaf k
- | Leaf j as t ->
- if j == k then t else join (k, Leaf k, j, t)
- | Branch (p,m,t0,t1) as t ->
- if match_prefix k p m then
- if zero_bit k m then
- Branch (p, m, ins t0, t1)
- else
- Branch (p, m, t0, ins t1)
- else
- join (k, Leaf k, p, t)
- in
- ins t
-
-(*s The code to remove an element is basically similar to the code of
- insertion. But since we have to maintain the invariant that both
- subtrees of a [Branch] node are non-empty, we use here the
- ``smart constructor'' [branch] instead of [Branch]. *)
-
-let branch = function
- | (_,_,Empty,t) -> t
- | (_,_,t,Empty) -> t
- | (p,m,t0,t1) -> Branch (p,m,t0,t1)
-
-let remove k t =
- let rec rmv = function
- | Empty -> Empty
- | Leaf j as t -> if k == j then Empty else t
- | Branch (p,m,t0,t1) as t ->
- if match_prefix k p m then
- if zero_bit k m then
- branch (p, m, rmv t0, t1)
- else
- branch (p, m, t0, rmv t1)
- else
- t
- in
- rmv t
-
-(*s One nice property of Patricia trees is to support a fast union
- operation (and also fast subset, difference and intersection
- operations). When merging two branching trees we examine the
- following four cases: (1) the trees have exactly the same
- prefix; (2/3) one prefix contains the other one; and (4) the
- prefixes disagree. In cases (1), (2) and (3) the recursion is
- immediate; in case (4) the function [join] creates the appropriate
- branching. *)
-
-let rec merge = function
- | Empty, t -> t
- | t, Empty -> t
- | Leaf k, t -> add k t
- | t, Leaf k -> add k t
- | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) ->
- if m == n && match_prefix q p m then
- (* The trees have the same prefix. Merge the subtrees. *)
- Branch (p, m, merge (s0,t0), merge (s1,t1))
- else if m < n && match_prefix q p m then
- (* [q] contains [p]. Merge [t] with a subtree of [s]. *)
- if zero_bit q m then
- Branch (p, m, merge (s0,t), s1)
- else
- Branch (p, m, s0, merge (s1,t))
- else if m > n && match_prefix p q n then
- (* [p] contains [q]. Merge [s] with a subtree of [t]. *)
- if zero_bit p n then
- Branch (q, n, merge (s,t0), t1)
- else
- Branch (q, n, t0, merge (s,t1))
- else
- (* The prefixes disagree. *)
- join (p, s, q, t)
-
-let union s t = merge (s,t)
-
-(*s When checking if [s1] is a subset of [s2] only two of the above
- four cases are relevant: when the prefixes are the same and when the
- prefix of [s1] contains the one of [s2], and then the recursion is
- obvious. In the other two cases, the result is [false]. *)
-
-let rec subset s1 s2 = match (s1,s2) with
- | Empty, _ -> true
- | _, Empty -> false
- | Leaf k1, _ -> mem k1 s2
- | Branch _, Leaf _ -> false
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- subset l1 l2 && subset r1 r2
- else if m1 > m2 && match_prefix p1 p2 m2 then
- if zero_bit p1 m2 then
- subset l1 l2 && subset r1 l2
- else
- subset l1 r2 && subset r1 r2
- else
- false
-
-(*s To compute the intersection and the difference of two sets, we
- still examine the same four cases as in [merge]. The recursion is
- then obvious. *)
-
-let rec inter s1 s2 = match (s1,s2) with
- | Empty, _ -> Empty
- | _, Empty -> Empty
- | Leaf k1, _ -> if mem k1 s2 then s1 else Empty
- | _, Leaf k2 -> if mem k2 s1 then s2 else Empty
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- merge (inter l1 l2, inter r1 r2)
- else if m1 < m2 && match_prefix p2 p1 m1 then
- inter (if zero_bit p2 m1 then l1 else r1) s2
- else if m1 > m2 && match_prefix p1 p2 m2 then
- inter s1 (if zero_bit p1 m2 then l2 else r2)
- else
- Empty
-
-let rec diff s1 s2 = match (s1,s2) with
- | Empty, _ -> Empty
- | _, Empty -> s1
- | Leaf k1, _ -> if mem k1 s2 then Empty else s1
- | _, Leaf k2 -> remove k2 s1
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- merge (diff l1 l2, diff r1 r2)
- else if m1 < m2 && match_prefix p2 p1 m1 then
- if zero_bit p2 m1 then
- merge (diff l1 s2, r1)
- else
- merge (l1, diff r1 s2)
- else if m1 > m2 && match_prefix p1 p2 m2 then
- if zero_bit p1 m2 then diff s1 l2 else diff s1 r2
- else
- s1
-
-(*s All the following operations ([cardinal], [iter], [fold], [for_all],
- [exists], [filter], [partition], [choose], [elements]) are
- implemented as for any other kind of binary trees. *)
-
-let rec cardinal = function
- | Empty -> 0
- | Leaf _ -> 1
- | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1
-
-let rec iter f = function
- | Empty -> ()
- | Leaf k -> f k
- | Branch (_,_,t0,t1) -> iter f t0; iter f t1
-
-let rec fold f s accu = match s with
- | Empty -> accu
- | Leaf k -> f k accu
- | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu)
-
-let rec for_all p = function
- | Empty -> true
- | Leaf k -> p k
- | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1
-
-let rec exists p = function
- | Empty -> false
- | Leaf k -> p k
- | Branch (_,_,t0,t1) -> exists p t0 || exists p t1
-
-let rec filter pr = function
- | Empty -> Empty
- | Leaf k as t -> if pr k then t else Empty
- | Branch (p,m,t0,t1) -> branch (p, m, filter pr t0, filter pr t1)
-
-let partition p s =
- let rec part (t,f as acc) = function
- | Empty -> acc
- | Leaf k -> if p k then (add k t, f) else (t, add k f)
- | Branch (_,_,t0,t1) -> part (part acc t0) t1
- in
- part (Empty, Empty) s
-
-let rec choose = function
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_, _,t0,_) -> choose t0 (* we know that [t0] is non-empty *)
-
-let elements s =
- let rec elements_aux acc = function
- | Empty -> acc
- | Leaf k -> k :: acc
- | Branch (_,_,l,r) -> elements_aux (elements_aux acc l) r
- in
- (* unfortunately there is no easy way to get the elements in ascending
- order with little-endian Patricia trees *)
- List.sort Pervasives.compare (elements_aux [] s)
-
-let split x s =
- let coll k (l, b, r) =
- if k < x then add k l, b, r
- else if k > x then l, b, add k r
- else l, true, r
- in
- fold coll s (Empty, false, Empty)
-
-(*s There is no way to give an efficient implementation of [min_elt]
- and [max_elt], as with binary search trees. The following
- implementation is a traversal of all elements, barely more
- efficient than [fold min t (choose t)] (resp. [fold max t (choose
- t)]). Note that we use the fact that there is no constructor
- [Empty] under [Branch] and therefore always a minimal
- (resp. maximal) element there. *)
-
-let rec min_elt = function
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_,_,s,t) -> min (min_elt s) (min_elt t)
-
-let rec max_elt = function
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_,_,s,t) -> max (max_elt s) (max_elt t)
-
-(*s Another nice property of Patricia trees is to be independent of the
- order of insertion. As a consequence, two Patricia trees have the
- same elements if and only if they are structurally equal. *)
-
-let equal = (=)
-
-let compare = compare
-
-(*i*)
-let make l = List.fold_right add l empty
-(*i*)
-
-(*s Additional functions w.r.t to [Set.S]. *)
-
-let rec intersect s1 s2 = match (s1,s2) with
- | Empty, _ -> false
- | _, Empty -> false
- | Leaf k1, _ -> mem k1 s2
- | _, Leaf k2 -> mem k2 s1
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- intersect l1 l2 || intersect r1 r2
- else if m1 < m2 && match_prefix p2 p1 m1 then
- intersect (if zero_bit p2 m1 then l1 else r1) s2
- else if m1 > m2 && match_prefix p1 p2 m2 then
- intersect s1 (if zero_bit p1 m2 then l2 else r2)
- else
- false
-
-
-(*s Big-endian Patricia trees *)
-
-module Big = struct
-
- type elt = int
-
- type t_ = t
- type t = t_
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let singleton k = Leaf k
-
- let zero_bit k m = (k land m) == 0
-
- let rec mem k = function
- | Empty -> false
- | Leaf j -> k == j
- | Branch (_, m, l, r) -> mem k (if zero_bit k m then l else r)
-
- let mask k m = (k lor (m-1)) land (lnot m)
-
- (* we first write a naive implementation of [highest_bit]
- only has to work for bytes *)
- let naive_highest_bit x =
- assert (x < 256);
- let rec loop i =
- if i = 0 then 1 else if x lsr i = 1 then 1 lsl i else loop (i-1)
- in
- loop 7
-
- (* then we build a table giving the highest bit for bytes *)
- let hbit = Array.init 256 naive_highest_bit
-
- (* to determine the highest bit of [x] we split it into bytes *)
- let highest_bit_32 x =
- let n = x lsr 24 in if n != 0 then hbit.(n) lsl 24
- else let n = x lsr 16 in if n != 0 then hbit.(n) lsl 16
- else let n = x lsr 8 in if n != 0 then hbit.(n) lsl 8
- else hbit.(x)
-
- let highest_bit_64 x =
- let n = x lsr 32 in if n != 0 then (highest_bit_32 n) lsl 32
- else highest_bit_32 x
-
- let highest_bit = match Sys.word_size with
- | 32 -> highest_bit_32
- | 64 -> highest_bit_64
- | _ -> assert false
-
- let branching_bit p0 p1 = highest_bit (p0 lxor p1)
-
- let join (p0,t0,p1,t1) =
- (*i let m = function Branch (_,m,_,_) -> m | _ -> 0 in i*)
- let m = branching_bit p0 p1 (*EXP (m t0) (m t1) *) in
- if zero_bit p0 m then
- Branch (mask p0 m, m, t0, t1)
- else
- Branch (mask p0 m, m, t1, t0)
-
- let match_prefix k p m = (mask k m) == p
-
- let add k t =
- let rec ins = function
- | Empty -> Leaf k
- | Leaf j as t ->
- if j == k then t else join (k, Leaf k, j, t)
- | Branch (p,m,t0,t1) as t ->
- if match_prefix k p m then
- if zero_bit k m then
- Branch (p, m, ins t0, t1)
- else
- Branch (p, m, t0, ins t1)
- else
- join (k, Leaf k, p, t)
- in
- ins t
-
- let remove k t =
- let rec rmv = function
- | Empty -> Empty
- | Leaf j as t -> if k == j then Empty else t
- | Branch (p,m,t0,t1) as t ->
- if match_prefix k p m then
- if zero_bit k m then
- branch (p, m, rmv t0, t1)
- else
- branch (p, m, t0, rmv t1)
- else
- t
- in
- rmv t
-
- let rec merge = function
- | Empty, t -> t
- | t, Empty -> t
- | Leaf k, t -> add k t
- | t, Leaf k -> add k t
- | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) ->
- if m == n && match_prefix q p m then
- (* The trees have the same prefix. Merge the subtrees. *)
- Branch (p, m, merge (s0,t0), merge (s1,t1))
- else if m > n && match_prefix q p m then
- (* [q] contains [p]. Merge [t] with a subtree of [s]. *)
- if zero_bit q m then
- Branch (p, m, merge (s0,t), s1)
- else
- Branch (p, m, s0, merge (s1,t))
- else if m < n && match_prefix p q n then
- (* [p] contains [q]. Merge [s] with a subtree of [t]. *)
- if zero_bit p n then
- Branch (q, n, merge (s,t0), t1)
- else
- Branch (q, n, t0, merge (s,t1))
- else
- (* The prefixes disagree. *)
- join (p, s, q, t)
-
- let union s t = merge (s,t)
-
- let rec subset s1 s2 = match (s1,s2) with
- | Empty, _ -> true
- | _, Empty -> false
- | Leaf k1, _ -> mem k1 s2
- | Branch _, Leaf _ -> false
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- subset l1 l2 && subset r1 r2
- else if m1 < m2 && match_prefix p1 p2 m2 then
- if zero_bit p1 m2 then
- subset l1 l2 && subset r1 l2
- else
- subset l1 r2 && subset r1 r2
- else
- false
-
- let rec inter s1 s2 = match (s1,s2) with
- | Empty, _ -> Empty
- | _, Empty -> Empty
- | Leaf k1, _ -> if mem k1 s2 then s1 else Empty
- | _, Leaf k2 -> if mem k2 s1 then s2 else Empty
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- merge (inter l1 l2, inter r1 r2)
- else if m1 > m2 && match_prefix p2 p1 m1 then
- inter (if zero_bit p2 m1 then l1 else r1) s2
- else if m1 < m2 && match_prefix p1 p2 m2 then
- inter s1 (if zero_bit p1 m2 then l2 else r2)
- else
- Empty
-
- let rec diff s1 s2 = match (s1,s2) with
- | Empty, _ -> Empty
- | _, Empty -> s1
- | Leaf k1, _ -> if mem k1 s2 then Empty else s1
- | _, Leaf k2 -> remove k2 s1
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- merge (diff l1 l2, diff r1 r2)
- else if m1 > m2 && match_prefix p2 p1 m1 then
- if zero_bit p2 m1 then
- merge (diff l1 s2, r1)
- else
- merge (l1, diff r1 s2)
- else if m1 < m2 && match_prefix p1 p2 m2 then
- if zero_bit p1 m2 then diff s1 l2 else diff s1 r2
- else
- s1
-
- (* same implementation as for little-endian Patricia trees *)
- let cardinal = cardinal
- let iter = iter
- let fold = fold
- let for_all = for_all
- let exists = exists
- let filter = filter
-
- let partition p s =
- let rec part (t,f as acc) = function
- | Empty -> acc
- | Leaf k -> if p k then (add k t, f) else (t, add k f)
- | Branch (_,_,t0,t1) -> part (part acc t0) t1
- in
- part (Empty, Empty) s
-
- let choose = choose
-
- let elements s =
- let rec elements_aux acc = function
- | Empty -> acc
- | Leaf k -> k :: acc
- | Branch (_,_,l,r) -> elements_aux (elements_aux acc r) l
- in
- (* we still have to sort because of possible negative elements *)
- List.sort Pervasives.compare (elements_aux [] s)
-
- let split x s =
- let coll k (l, b, r) =
- if k < x then add k l, b, r
- else if k > x then l, b, add k r
- else l, true, r
- in
- fold coll s (Empty, false, Empty)
-
- (* could be slightly improved (when we now that a branch contains only
- positive or only negative integers) *)
- let min_elt = min_elt
- let max_elt = max_elt
-
- let equal = (=)
-
- let compare = compare
-
- let make l = List.fold_right add l empty
-
- let rec intersect s1 s2 = match (s1,s2) with
- | Empty, _ -> false
- | _, Empty -> false
- | Leaf k1, _ -> mem k1 s2
- | _, Leaf k2 -> mem k2 s1
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- intersect l1 l2 || intersect r1 r2
- else if m1 > m2 && match_prefix p2 p1 m1 then
- intersect (if zero_bit p2 m1 then l1 else r1) s2
- else if m1 < m2 && match_prefix p1 p2 m2 then
- intersect s1 (if zero_bit p1 m2 then l2 else r2)
- else
- false
-
-end
-
-(*s Big-endian Patricia trees with non-negative elements only *)
-
-module BigPos = struct
-
- include Big
-
- let singleton x = if x < 0 then invalid_arg "BigPos.singleton"; singleton x
-
- let add x s = if x < 0 then invalid_arg "BigPos.add"; add x s
-
- (* Patricia trees are now binary search trees! *)
-
- let rec mem k = function
- | Empty -> false
- | Leaf j -> k == j
- | Branch (p, _, l, r) -> if k <= p then mem k l else mem k r
-
- let rec min_elt = function
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_,_,s,_) -> min_elt s
-
- let rec max_elt = function
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_,_,_,t) -> max_elt t
-
- (* we do not have to sort anymore *)
- let elements s =
- let rec elements_aux acc = function
- | Empty -> acc
- | Leaf k -> k :: acc
- | Branch (_,_,l,r) -> elements_aux (elements_aux acc r) l
- in
- elements_aux [] s
-
-end
-
-(*s EXPERIMENT: Big-endian Patricia trees with swapped bit sign *)
-
-module Bigo = struct
-
- include Big
-
- (* swaps the sign bit *)
- let swap x = if x < 0 then x land max_int else x lor min_int
-
- let mem x s = mem (swap x) s
-
- let add x s = add (swap x) s
-
- let singleton x = singleton (swap x)
-
- let remove x s = remove (swap x) s
-
- let elements s = List.map swap (elements s)
-
- let choose s = swap (choose s)
-
- let iter f = iter (fun x -> f (swap x))
-
- let fold f = fold (fun x a -> f (swap x) a)
-
- let for_all f = for_all (fun x -> f (swap x))
-
- let exists f = exists (fun x -> f (swap x))
-
- let filter f = filter (fun x -> f (swap x))
-
- let partition f = partition (fun x -> f (swap x))
-
- let split x s = split (swap x) s
-
- let rec min_elt = function
- | Empty -> raise Not_found
- | Leaf k -> swap k
- | Branch (_,_,s,_) -> min_elt s
-
- let rec max_elt = function
- | Empty -> raise Not_found
- | Leaf k -> swap k
- | Branch (_,_,_,t) -> max_elt t
-
-end
-
-let test empty add mem =
- let seed = Random.int max_int in
- Random.init seed;
- let s =
- let rec loop s i =
- if i = 1000 then s else loop (add (Random.int max_int) s) (succ i)
- in
- loop empty 0
- in
- Random.init seed;
- for i = 0 to 999 do assert (mem (Random.int max_int) s) done
-
-
Deleted: trunk/Toss/Formula/Sat/IntSet.mli
===================================================================
--- trunk/Toss/Formula/Sat/IntSet.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Formula/Sat/IntSet.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,111 +0,0 @@
-(**************************************************************************)
-(* *)
-(* Copyright (C) Jean-Christophe Filliatre *)
-(* *)
-(* This software is free software; you can redistribute it and/or *)
-(* modify it under the terms of the GNU Library General Public *)
-(* License version 2.1, with the special exception on linking *)
-(* described in file LICENSE. *)
-(* *)
-(* This software 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. *)
-(* *)
-(**************************************************************************)
-
-(*i $Id: ptset.mli,v 1.10 2008-07-21 14:53:06 filliatr Exp $ i*)
-
-(*s Sets of integers implemented as Patricia trees. The following
- signature is exactly [Set.S with type elt = int], with the same
- specifications. This is a purely functional data-structure. The
- performances are similar to those of the standard library's module
- [Set]. The representation is unique and thus structural comparison
- can be performed on Patricia trees. *)
-
-type t
-
-type elt = int
-
-val empty : t
-
-val is_empty : t -> bool
-
-val mem : int -> t -> bool
-
-val add : int -> t -> t
-
-val singleton : int -> t
-
-val is_singleton : t -> bool
-
-val remove : int -> t -> t
-
-val union : t -> t -> t
-
-val subset : t -> t -> bool
-
-val inter : t -> t -> t
-
-val diff : t -> t -> t
-
-val equal : t -> t -> bool
-
-val compare : t -> t -> int
-
-val elements : t -> int list
-
-val choose : t -> int
-
-val cardinal : t -> int
-
-val iter : (int -> unit) -> t -> unit
-
-val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a
-
-val for_all : (int -> bool) -> t -> bool
-
-val exists : (int -> bool) -> t -> bool
-
-val filter : (int -> bool) -> t -> t
-
-val partition : (int -> bool) -> t -> t * t
-
-val split : int -> t -> t * bool * t
-
-(*s Warning: [min_elt] and [max_elt] are linear w.r.t. the size of the
- set. In other words, [min_elt t] is barely more efficient than [fold
- min t (choose t)]. *)
-
-val min_elt : t -> int
-val max_elt : t -> int
-
-(*s Additional functions not appearing in the signature [Set.S] from ocaml
- standard library. *)
-
-(* [intersect u v] determines if sets [u] and [v] have a non-empty
- intersection. *)
-
-val intersect : t -> t -> bool
-
-
-(*s Big-endian Patricia trees *)
-
-module Big : sig
- include Set.S with type elt = int
- val intersect : t -> t -> bool
-end
-
-
-(*s Big-endian Patricia trees with non-negative elements. Changes:
- - [add] and [singleton] raise [Invalid_arg] if a negative element is given
- - [mem] is slightly faster (the Patricia tree is now a search tree)
- - [min_elt] and [max_elt] are now O(log(N))
- - [elements] returns a list with elements in ascending order
- *)
-
-module BigPos : sig
- include Set.S with type elt = int
- val intersect : t -> t -> bool
-end
-
-
Modified: trunk/Toss/Formula/Sat/Sat.mli
===================================================================
--- trunk/Toss/Formula/Sat/Sat.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Formula/Sat/Sat.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,46 +1,49 @@
-(* Basic interface to a sat solver and convertion between cnf and dnf formulas.
- Variables are given by positive integers and we use -n to denote 'not n'. *)
+(** Basic interface to a sat solver and convertion between cnf and dnf formulas.
+ Variables are given by positive integers and we use -n to denote 'not n'. *)
-(* ------- Main functions ------- *)
+(** {2 Main Functions} *)
(** Set timeout function for conversions. *)
val set_timeout : float -> unit
+
(** Clear timeout function. *)
val clear_timeout : unit -> unit
-
-(* Given a list of literals to set to true, simplify the given CNF formula. *)
+(** Given a list of literals to set to true, simplify the given CNF formula. *)
val simplify : int list -> int list list -> int list list
-(* Check satisfiability of a formula in CNF, return a satisfying assignment. *)
+(** Check satisfiability of a formula in CNF, return a satisfying assignment. *)
val sat : int list list -> int list option
+
+(** Check satisfiability of a formula in CNF, return just true or false. *)
val is_sat : int list list -> bool
-(* Convert a DNF formula to CNF (or equivalently, CNF to DNF). *)
exception OverBound
+
+(** Convert a DNF formula to CNF (or equivalently, CNF to DNF). *)
val convert : ?disc_vars: int list -> ?bound: int option -> int list list ->
int list list
-(* Convert a auxiliary CNF formula to "real" CNF (or, equivalently, to DNF). *)
+(** Convert a auxiliary CNF formula to "real" CNF (or, equivalently, to DNF). *)
val convert_aux_cnf : ?disc_vars: int list -> ?bound: int option ->
int -> int list list -> int list list
-(* ----- Printing helpers ------ *)
+(** {2 Printing} *)
-(* Return the given clause (disjunction of literals) as string. *)
+(** Return the given clause (disjunction of literals) as string. *)
val clause_str : int list -> string
-(* Return the given CNF formula as string. *)
+(** Return the given CNF formula as string. *)
val cnf_str : int list list -> string
-(* Return the given conjunction of literals as string. *)
+(** Return the given conjunction of literals as string. *)
val conjunct_str : int list -> string
-(* Return the given DNF formula as string. *)
+(** Return the given DNF formula as string. *)
val dnf_str : int list list -> string
-(* ------------------------- DEBUGGING ------------------------------------- *)
+(** {2 Debugging} *)
-(* Debugging information. At level 0 nothing is printed out. *)
+(** Debugging information. At level 0 nothing is printed out. *)
val set_debug_level : int -> unit
Modified: trunk/Toss/GGP/GameSimpl.mli
===================================================================
--- trunk/Toss/GGP/GameSimpl.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/GGP/GameSimpl.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,4 +1,4 @@
-(** {2 Simplification of Toss Games.}
+(** {2 Simplification of Toss games.}
Whole-game simplifications and helper functions that consider both
a structure and a formula.
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,3 +1,5 @@
+(** Translating formulas from GDL to Toss. *)
+
val debug_level : int ref
(** Whether to add root predicates. Note that not adding root
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,3 +1,5 @@
+(** Translating games from GDL to Toss. *)
+
(** Local level of logging. *)
val debug_level : int ref
val generate_test_case : string option ref
Modified: trunk/Toss/Server/DB.mli
===================================================================
--- trunk/Toss/Server/DB.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Server/DB.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,3 +1,6 @@
+(** Interface to the Toss database through Sqlite. *)
+
+
exception DBError of string
val debug_level : int ref
Modified: trunk/Toss/Server/Picture.mli
===================================================================
--- trunk/Toss/Server/Picture.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Server/Picture.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,4 +1,4 @@
-(** Processing Pictures to create Structures *)
+(** Processing pictures to create structures *)
(** {2 Debugging} *)
Modified: trunk/Toss/Server/ReqHandler.mli
===================================================================
--- trunk/Toss/Server/ReqHandler.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Server/ReqHandler.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,4 +1,4 @@
-(** Main Request Handler for Toss. *)
+(** Main request handler for Toss. *)
(** {2 Debugging} *)
@@ -35,5 +35,5 @@
req_state * bool
-(* Client db game setting - public only for caching reasons. *)
+(** Client db game setting - public only for caching reasons. *)
val client_set_game : string -> unit
Modified: trunk/Toss/Solver/AssignmentSet.mli
===================================================================
--- trunk/Toss/Solver/AssignmentSet.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/AssignmentSet.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,5 +1,4 @@
-(** This module contains the main type for partial assignments of
- values to variables. *)
+(** Main type for partial assignments of elements to variables. *)
(** {2 Basic type definition.} *)
Modified: trunk/Toss/Solver/Assignments.mli
===================================================================
--- trunk/Toss/Solver/Assignments.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/Assignments.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,7 +1,4 @@
-(** This module contains functions for handling partial assignments of
- values to variables. The main type [assignmnent_set] represents
- a set of assignments of values to variables and the main functions
- are [join], [sum], [project] and [complement] with natural meanings. *)
+(** Handling partial assignments of elements to variables. *)
(** {2 Basic Type Definition} *)
Modified: trunk/Toss/Solver/Distinguish.ml
===================================================================
--- trunk/Toss/Solver/Distinguish.ml 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/Distinguish.ml 2011-11-17 23:56:41 UTC (rev 1635)
@@ -190,7 +190,7 @@
(* Helper function: remove atoms from a formula if [cond] is still satisfied.
Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
-let rec greedy_remove cond phi =
+let rec greedy_remove ?(pos=false) cond phi =
let rec greedy_remove_list constructor acc = function
| [] -> acc
| x :: xs ->
@@ -200,8 +200,10 @@
greedy_remove_list constructor (minx::acc) xs in
match phi with
| And fl -> And (greedy_remove_list (fun l -> And l) [] (List.rev fl))
- | Or fl -> Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
- | Not f -> Not (greedy_remove (fun x -> cond (Not x)) f)
+ | Or fl -> if pos then Or fl else
+ Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
+ | Not f -> if pos then Not f else
+ Not (greedy_remove (fun x -> cond (Not x)) f)
| Ex (vs, f) -> Ex (vs, greedy_remove (fun x -> cond (Ex (vs, x))) f)
| All (vs, f) -> All (vs, greedy_remove (fun x -> cond (All (vs, x))) f)
| phi -> phi
@@ -231,20 +233,21 @@
| GuardedFO -> guarded_types s ~qr ~k
| FO -> ntypes s ~qr ~k in
let neg_tps = Aux.unique_sorted (Aux.concat_map types neg_strucs) in
- let pos_tps = Aux.unique_sorted ~cmp:!compare_types (
- Aux.map_some (min_type_omitting ~logic ~qr ~k neg_tps) pos_strucs) in
- let fails_neg f = not (List.exists (fun s -> check s [||] f) neg_strucs) in
- let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
- let rec find_type acc = function
- | [] -> []
- | x :: xs -> if succ_pos (x::acc) then x :: acc else
- find_type (x::acc) xs in
- let dtypes = find_type [] pos_tps in
- if dtypes = [] then None else
- let is_ok f = fails_neg f && succ_pos [f] in
- let mintp = greedy_remove is_ok (Or dtypes) in
- let fv = FormulaSubst.free_vars mintp in
- Some (FormulaOps.rename_quant_avoiding fv mintp)
+ let fails_on_negs f = not (List.exists (fun s-> check s [||] f) neg_strucs) in
+ let extend_by_pos acc struc =
+ if check struc [||] (Or acc) then acc else
+ match min_type_omitting ~logic ~qr ~k neg_tps struc with
+ | None -> raise Not_found
+ | Some f -> (greedy_remove ~pos:true fails_on_negs f) :: acc in
+ let pos_formulas =
+ try List.fold_left extend_by_pos [] pos_strucs with Not_found -> [] in
+ let pos_formulas = Aux.unique_sorted ~cmp:!compare_types pos_formulas in
+ if pos_formulas = [] then None else
+ let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
+ let is_ok f = fails_on_negs f && succ_pos [f] in
+ let minimized = greedy_remove is_ok (Or pos_formulas) in
+ let fv = FormulaSubst.free_vars minimized in
+ Some (FormulaOps.rename_quant_avoiding fv minimized)
(* Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,31 +1,31 @@
-(* Polynomials with ordered variables, integer coefficients.*)
+(** Polynomials with ordered variables and integer coefficients.*)
-(* ----------------------- BASIC TYPE DEFINITIONS --------------------------- *)
+(** {2 Basic Type Definitions} *)
type polynomial = Const of Num.num | Poly of string * (polynomial * int) list
-type t = polynomial (* to be compatible with OrderedType signature *)
+type t = polynomial (** to be compatible with OrderedType signature *)
exception Unmatched_variables
-(* Constructur 'Const' but taking normal integers. *)
+(** Constructur 'Const' but taking normal integers. *)
val const : int -> polynomial
-(* ------------------------- PRINTING FUNCTION ------------------------------ *)
+(** {2 Printing} *)
val str : polynomial -> string
-(* ------------------------- EQUALITY AND COMPARISON ------------------------ *)
+(** {2 Equality and Comparison} *)
val is_zero : polynomial -> bool
val equal : polynomial -> polynomial -> bool
val compare : polynomial -> polynomial -> int
-(* ------------------------- BASIC HELPER FUNCTIONS ------------------------- *)
+(** {Basic Operations} *)
val var : polynomial -> string
val lower : polynomial -> polynomial
@@ -39,7 +39,7 @@
val constant_factors : polynomial -> polynomial -> (Num.num * Num.num) option
-(* -------------------------- ARITHMETIC FUNCTIONS -------------------------- *)
+(** {2 Arithmetic Functions} *)
val add : polynomial -> polynomial -> polynomial
val neg : polynomial -> polynomial
@@ -51,11 +51,11 @@
polynomial * polynomial
-(* -------------------------- DIFFERENTIATION ------------------------------- *)
+(** {2 Differentiation} *)
val diff : polynomial -> polynomial
-(* ------------------------- MODIFIED REMAINDER ----------------------------- *)
+(** {2 Modified remainder} *)
val modified_remainder : polynomial -> polynomial -> polynomial
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPolySet.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPolySet.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPolySet.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,11 +1,11 @@
-(* Represent set of ordered polynomials and operate on it. *)
+(** Represent set of ordered polynomials and operate on it. *)
module PSet : Set.S with type elt = OrderedPoly.polynomial
type pset = PSet.t
-(* ------------------------ BASIC SET OPERATIONS ---------------------------- *)
+(** {2 Basic Set Operations} *)
val empty : PSet.t
val add : OrderedPoly.polynomial -> PSet.t -> PSet.t
@@ -15,50 +15,50 @@
val elements : PSet.t -> OrderedPoly.polynomial list
-(* ------------------------ PRINTING FUNCTION ------------------------------- *)
+(** {2 Printing} *)
-(* Print the given set as string. *)
+(** Print the given set as string. *)
val str : PSet.t -> string
-(* ------------- MAPPING WITH DEGREE DETECTION AND BASIC MAPS --------------- *)
+(** {2 Mapping with degree detection and basic maps} *)
-(* Maps a function to all polynomials in the set. Returns non-empty
- resulting polynomials of degree 0 and greater separately. *)
+(** Maps a function to all polynomials in the set. Returns non-empty
+ resulting polynomials of degree 0 and greater separately. *)
val map : (OrderedPoly.polynomial -> OrderedPoly.polynomial) -> PSet.t ->
PSet.t * PSet.t
-(* Extract leading coefficients from all polynomials in the set. *)
+(** Extract leading coefficients from all polynomials in the set. *)
val leading_coeff : PSet.t -> PSet.t
-(* Omit leading coefficients from all polynomials in the given set.
- Return resulting polynomials of degree 0 and greater separately. *)
+(** Omit leading coefficients from all polynomials in the given set.
+ Return resulting polynomials of degree 0 and greater separately. *)
val omit_leading : PSet.t -> PSet.t * PSet.t
-(* Differentiate all polynomials in the given set.
- Return resulting polynomials of degree 0 and greater separately. *)
+(** Differentiate all polynomials in the given set.
+ Return resulting polynomials of degree 0 and greater separately. *)
val differentiate: PSet.t -> PSet.t * PSet.t
-(* Compute factors r such that for some p,q in [ps,qs] holds p = r*q. *)
+(** Compute factors r such that for some p,q in [ps,qs] holds p = r*q. *)
val div : PSet.t -> PSet.t -> PSet.t
-(* ------------ MODIFIED REMAINDER OF ALL PAIRS BETWEEN TWO SETS ------------ *)
+(** {2 Modified remainder of all pairs between two sets} *)
-(* Compute the modified remainder for all pairs of polynomials p from
- ps1 and q!=p from qs1 such that the degree of p >= degree of q.
- Return resulting polynomials of degree 0 and greater separately. *)
+(** Compute the modified remainder for all pairs of polynomials p from
+ ps1 and q!=p from qs1 such that the degree of p >= degree of q.
+ Return resulting polynomials of degree 0 and greater separately. *)
val modified_remainder : PSet.t * PSet.t -> PSet.t * PSet.t
-(* ---------------- CLOSURE UNDER 4 ABOVE OPERATIONS ------------------------ *)
+(** {2 Closure under the 4 operations above} *)
exception Closure_count_exceeded of int
-(* Closure of a set of polynomials [polys] under the operations:
- - extracting the leading coefficient (if deg > 0)
- - omitting the leading term (if deg > 0)
- - taking the derivative (if deg > 0)
- - taking the modified remainder MR(p, q) for deg p >= deg q.
- Return resulting polynomials of degree 0 and greater separately. *)
+(** Closure of a set of polynomials [polys] under the operations:
+ - extracting the leading coefficient (if deg > 0)
+ - omitting the leading term (if deg > 0)
+ - taking the derivative (if deg > 0)
+ - taking the modified remainder MR(p, q) for deg p >= deg q.
+ Return resulting polynomials of degree 0 and greater separately. *)
val closure : ?upto : int -> PSet.t -> PSet.t * PSet.t
Modified: trunk/Toss/Solver/RealQuantElim/Poly.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/Poly.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/RealQuantElim/Poly.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,6 +1,6 @@
-(* Represent polynomials as written and convert to ordered form. *)
+(** Represent polynomials as written and convert to ordered form. *)
-(* ---------------------- BASIC TYPE DEFINITION ----------------------------- *)
+(** {2 Basic Type Definition} *)
type polynomial =
Var of string
@@ -9,22 +9,22 @@
| Plus of polynomial * polynomial
-(* ------------------------ PRINTING FUNCTION ------------------------------- *)
+(** {2 Printing} *)
-(* Print a polynomial as a string. *)
+(** Print a polynomial as a string. *)
val str : polynomial -> string
-(* ------------------ HELPER POWER FUNCTION USED IN PARSER ------------------ *)
+(** {Basic Functions used in Parser} *)
-(* Power function used in parser. *)
+(** Power function used in parser. *)
val pow : polynomial -> int -> polynomial
-(* Basic simplification, reduces constant polynomials to integers. *)
+(** Basic simplification, reduces constant polynomials to integers. *)
val simp_const : polynomial -> polynomial
-(* ----------------- CONVERTION TO UNORDERED POLYNOMIALS -------------------- *)
+(** {2 Convertion to Unordered Polynomials} *)
val make_unordered : OrderedPoly.polynomial -> polynomial
@@ -32,24 +32,24 @@
(polynomial * 'a) list
-(* ------------------ CONVERTION TO ORDERED POLYNOMIALS --------------------- *)
+(** {2 Convertion to Ordered Polynomials} *)
-(* List variables in the given polynomial. *)
+(** List variables in the given polynomial. *)
val vars : polynomial -> string list
-(* List variables in the given polynomial list. *)
+(** List variables in the given polynomial list. *)
val vars_list : polynomial list -> string list
-(* Make an ordered polynomial from [p] with [prio_list] order on variables, i.e.
- if x appears in [prio_list] before y then x < y. Strings not appearing
- in [prio_list] at all are considered smaller than any string that appears. *)
+(** Make an ordered polynomial from [p] with [prio_list] order on variables,i.e.
+ if x appears in [prio_list] before y then x < y. Strings not appearing
+ in [prio_list] at all are considered smaller than any string that appears.*)
val make_ordered : string list -> polynomial -> OrderedPoly.polynomial
-(* Make ordered polynomials from [ps] with [prio_list] order on variables. *)
+(** Make ordered polynomials from [ps] with [prio_list] order on variables. *)
val make_ordered_list : string list -> polynomial list ->
OrderedPoly.polynomial list
-(* Make ordered polynomials from first components of [ps], [prio_list] order. *)
+(** Make ordered polynomials from first components of [ps], [prio_list] order.*)
val make_ordered_pair_list : string list -> (polynomial * 'a) list ->
(OrderedPoly.polynomial * 'a) list
Modified: trunk/Toss/Solver/RealQuantElim/RealQuantElim.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/RealQuantElim.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/RealQuantElim/RealQuantElim.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,4 +1,4 @@
-(* Simplify existentially quantified conjunction of polynomial inequalities. *)
+(** Simplify existentially quantified conjunction of polynomial inequalities. *)
open OrderedPolySet
Modified: trunk/Toss/Solver/RealQuantElim/SignTable.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/SignTable.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/RealQuantElim/SignTable.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,42 +1,42 @@
-(* Handling Sign Tables for quantifier elimination. *)
+(** Handling sign tables for quantifier elimination. *)
open Formula
val poly_sign_op_cmp : OrderedPoly.polynomial * sign_op ->
OrderedPoly.polynomial * sign_op -> int
-(* Exception raised when contraditing ops are given to join_sign_ops. *)
+(** Exception raised when contraditing ops are given to join_sign_ops. *)
exception Contradicting_sign_ops
-(* Given two sign_ops [x] and [y] return a sign op for "x and y". *)
+(** Given two sign_ops [x] and [y] return a sign op for "x and y". *)
val join_sign_ops : sign_op -> sign_op -> sign_op
-(* Print a sign_op as string. *)
+(** Print a sign_op as string. *)
val sign_op_str : sign_op -> string
-(* Check if given float has sign as required by the sign_op. *)
+(** Check if given float has sign as required by the sign_op. *)
val check_sign : float -> sign_op -> bool
-(* Negate a sign_op. *)
+(** Negate a sign_op. *)
val neg_sign_op : sign_op -> sign_op
-(* Print a case, i.e. a list of polynomials and their signs, as string. *)
+(** Print a case, i.e. a list of polynomials and their signs, as string. *)
val int_case_str : (OrderedPoly.polynomial * int) list -> string
val case_str : (OrderedPoly.polynomial * sign_op) list -> string
-(* Estimate the (base-3) logarithm of the number of cases needed for [pset]. *)
+(** Estimate the (base-3) logarithm of the number of cases needed for [pset]. *)
val log_no_cases : ?upto: int -> (OrderedPoly.polynomial * sign_op) list -> int
-(* Build the array of polynomials and cases to check given set of polynomials.*)
+(** Build array of polynomials and cases to check given set of polynomials. *)
val build_cases : (OrderedPoly.polynomial * sign_op) list ->
(OrderedPoly.polynomial * int) list list * OrderedPoly.polynomial array
-(* Given cases and polynomial array as constructed by [build_cases] and
- requirement list for some polynomials, return all satisfying cases. *)
+(** Given cases and polynomial array as constructed by [build_cases] and
+ requirement list for some polynomials, return all satisfying cases. *)
val solve : (OrderedPoly.polynomial * int) list list *
OrderedPoly.polynomial array -> (OrderedPoly.polynomial * sign_op) list ->
(OrderedPoly.polynomial * sign_op) list list
-(* Debugging information. At level 0 nothing is printed out. *)
+(** Debugging information. At level 0 nothing is printed out. *)
val set_debug_level : int -> unit
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Solver/Structure.mli 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,4 +1,4 @@
-(** Representing Relational Structures with Real-Valued Functions *)
+(** Representing relational structures with real-valued functions. *)
(** {2 Modules used in structure representation.} *)
Modified: trunk/Toss/Toss.odocl
===================================================================
--- trunk/Toss/Toss.odocl 2011-11-17 17:12:44 UTC (rev 1634)
+++ trunk/Toss/Toss.odocl 2011-11-17 23:56:41 UTC (rev 1635)
@@ -1,5 +1,8 @@
Formula/Formula
Formula/FormulaParser
+Formula/FormulaMap
+Formula/FormulaSubst
+Formula/Sat/Sat
Formula/BoolFormula
Formula/BoolFunction
Formula/FFTNF
@@ -8,9 +11,16 @@
Solver/StructureParser
Solver/AssignmentSet
Solver/Assignments
+Solver/RealQuantElim/OrderedPoly
+Solver/RealQuantElim/OrderedPolySet
+Solver/RealQuantElim/Poly
+Solver/RealQuantElim/SignTable
+Solver/RealQuantElim/RealQuantElim
+Solver/RealQuantElim/RealQuantElimParser
Solver/Solver
Solver/Class
Solver/ClassParser
+Solver/Distinguish
Arena/Term
Arena/TermParser
Arena/DiscreteRule
@@ -25,5 +35,10 @@
Play/Play
GGP/GDL
GGP/GDLParser
+GGP/TranslateFormula
+GGP/TranslateGame
GGP/GameSimpl
Server/Picture
+Server/LearnGame
+Server/DB
+Server/ReqHandler
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-12-10 23:39:23
|
Revision: 1636
http://toss.svn.sourceforge.net/toss/?rev=1636&view=rev
Author: lukaszkaiser
Date: 2011-12-10 23:39:15 +0000 (Sat, 10 Dec 2011)
Log Message:
-----------
New directory for game learning stuff (will move later), starting visual recognition for grid-games using OpenCV.
Added Paths:
-----------
trunk/Toss/Learn/
trunk/Toss/Learn/.cvsignore
trunk/Toss/Learn/Makefile
trunk/Toss/Learn/grid.pdf
trunk/Toss/Learn/reco.cpp
trunk/Toss/Learn/shapes.c
trunk/Toss/Learn/shapes.h
trunk/Toss/Learn/videos/
trunk/Toss/Learn/videos/tic_tac_toe_0.3gp
Property changes on: trunk/Toss/Learn
___________________________________________________________________
Added: svn:ignore
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
reco
*~
*.o
log*.ppm
Added: trunk/Toss/Learn/.cvsignore
===================================================================
--- trunk/Toss/Learn/.cvsignore (rev 0)
+++ trunk/Toss/Learn/.cvsignore 2011-12-10 23:39:15 UTC (rev 1636)
@@ -0,0 +1,8 @@
+# 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 .
+
+reco
+*~
+*.o
+log*.ppm
Added: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile (rev 0)
+++ trunk/Toss/Learn/Makefile 2011-12-10 23:39:15 UTC (rev 1636)
@@ -0,0 +1,10 @@
+all: reco
+
+shapes.o: shapes.c shapes.h
+ gcc -c shapes.c
+
+reco: reco.cpp shapes.o
+ g++ shapes.o reco.cpp -o reco `pkg-config opencv --cflags --libs`
+
+clean:
+ rm -rf reco log*.ppm *.o *~
Property changes on: trunk/Toss/Learn/Makefile
___________________________________________________________________
Added: svn:executable
+ *
Added: trunk/Toss/Learn/grid.pdf
===================================================================
--- trunk/Toss/Learn/grid.pdf (rev 0)
+++ trunk/Toss/Learn/grid.pdf 2011-12-10 23:39:15 UTC (rev 1636)
@@ -0,0 +1,69 @@
+%PDF-1.4
+%\xD0\xD4\xC5\xD8
+1 0 obj
+<<>>
+endobj
+2 0 obj
+<<>>
+endobj
+3 0 obj
+<< /pgfprgb [/Pattern /DeviceRGB] >>
+endobj
+6 0 obj <<
+/Length 139
+/Filter /FlateDecode
+>>
+stream
+xڅ\x911\xC20 Ew\x9F\xE2_ \x96\x83S㜠3\xE2 ]Z$&\xAEOڡ\x90Ш\x8Bc\xFF\xFF\xBE\x9C(\x82 \x82\x91\xE4䌥
+"T\x8CU I2\xE7dx,\xF4B\xA1Fl( k\xF6o\xACr\xE2\xEC\xB1\xC0e
+\xF1*,.n\xF8i\x97\xCA\xF8v3\xE8T\x95 zƽ\xF6c\xCBj\x97u\xF5\x91\xFC\x978\xB4\xFC>7\x8F\xDB\xF5\xF6N\x9D@\x97\xBF\x81\x9E[m?\xE6\xF6\xD4U@
+endstream
+endobj
+5 0 obj <<
+/Type /Page
+/Contents 6 0 R
+/Resources 4 0 R
+/MediaBox [0 0 612 792]
+/Parent 7 0 R
+>> endobj
+4 0 obj <<
+ /ColorSpace 3 0 R /Pattern 2 0 R /ExtGState 1 0 R
+/ProcSet [ /PDF ]
+>> endobj
+7 0 obj <<
+/Type /Pages
+/Count 1
+/Kids [5 0 R]
+>> endobj
+8 0 obj <<
+/Type /Catalog
+/Pages 7 0 R
+>> endobj
+9 0 obj <<
+/Producer (pdfTeX-1.40.10)
+/Creator (TeX)
+/CreationDate (D:20111210202438+01'00')
+/ModDate (D:20111210202438+01'00')
+/Trapped /False
+/PTEX.Fullbanner (This is pdfTeX, Version 3.1415926-1.40.10-2.2 (TeX Live 2009/Debian) kpathsea version 5.0.0)
+>> endobj
+xref
+0 10
+0000000000 65535 f
+0000000015 00000 n
+0000000035 00000 n
+0000000055 00000 n
+0000000430 00000 n
+0000000326 00000 n
+0000000108 00000 n
+0000000521 00000 n
+0000000578 00000 n
+0000000627 00000 n
+trailer
+<< /Size 10
+/Root 8 0 R
+/Info 9 0 R
+/ID [<6450C2B72902EC0DBB009F58BA2907F2> <6450C2B72902EC0DBB009F58BA2907F2>] >>
+startxref
+892
+%%EOF
Added: trunk/Toss/Learn/reco.cpp
===================================================================
--- trunk/Toss/Learn/reco.cpp (rev 0)
+++ trunk/Toss/Learn/reco.cpp 2011-12-10 23:39:15 UTC (rev 1636)
@@ -0,0 +1,133 @@
+#include <opencv/cv.h>
+#include <opencv/ml.h>
+#include <opencv/cxcore.h>
+#include <opencv/cxtypes.h>
+#include <opencv/highgui.h>
+extern "C" {
+ #include "shapes.h"
+}
+#include<cstdio>
+
+#define SIZEX 146 //352 - MARGINX / 2
+#define SIZEY 130 //288 - MARGINY / 2
+#define MARGINX 22
+#define MARGINY 8
+
+void reset (char a[SIZEX][SIZEY]) {
+ for (int j = 0; j < SIZEY; j++) {
+ for (int i = 0; i < SIZEX; i++) {
+ a[i][j] = 1;
+ }
+ }
+}
+
+static int print_counter = 0;
+void print_ppm (char pic[SIZEX][SIZEY], char * prefix) {
+ char fname[80];
+ sprintf (fname, "%s%i.ppm", prefix, print_counter);
+ print_counter++;
+ FILE * f = fopen (fname, "w");
+ fprintf (f, "P3\n%i %i\n255\n", SIZEX, SIZEY);
+ for (int j = 0; j < SIZEY; j++) {
+ for (int i = 0; i < SIZEX; i++) {
+ if (pic[i][j] > 0) {
+ fprintf (f, "0 0 0 ");
+ } else {
+ fprintf (f, "255 255 255 ");
+ }
+ }
+ fprintf (f, "\n");
+ }
+ fclose (f);
+}
+
+CvPoint from_point (point p) {
+ double x = p.x + MARGINX; //(p.x * SIZEX) / (SIZEX + 2*MARGINX) + MARGINX;
+ double y = p.y + MARGINY;
+ return (cvPoint ((int) x, (int) y));
+}
+
+
+int main(int argc, char* argv[])
+{
+ char res[2000];
+ int rnbr = -2;
+
+ cvNamedWindow ("Reco", CV_WINDOW_AUTOSIZE);
+ CvCapture* capture = cvCreateFileCapture ("videos/tic_tac_toe_0.3gp");
+ //cvCreateCameraCapture( 0 );
+ IplImage* img;
+ IplImage* gray;
+ IplImage* small;
+ int data_count = 0;
+ char data[SIZEX][SIZEY];
+ unsigned int cur_data = 0;
+ int time = 0;
+ int ok_around;
+ char shape_str[SIZEX*SIZEY*24] = "";
+ int shape_str_pos = 0;
+
+ reset (data);
+
+ while (true) {
+ img = cvQueryFrame (capture);
+ if (!img) break;
+ gray = cvCreateImage (cvSize (img->width, img->height), 8, 1);
+ cvCvtColor (img, gray, CV_BGR2GRAY);
+ small = cvCreateImage (cvSize (SIZEX + 2*MARGINX, SIZEY + 2*MARGINY), 8, 1);
+ cvResize (gray, small, CV_INTER_LINEAR);
+ cvCanny (small, small, 50, 100);
+ data_count = 0;
+ for (int i = 0; i < SIZEX; i++) {
+ for (int j = 0; j < SIZEY; j++) {
+ cur_data = (unsigned int)
+ small->imageData[(i+MARGINX) + small->widthStep * (j+MARGINY)];
+ ok_around = i == 0 || j == 0 ? 1 :
+ data[i][j] + data[i-1][j] + data[i+1][j] +
+ data[i][j+1] + data[i-1][j-1] + data[i+1][j-1] +
+ data[i][j-1] + data[i-1][j+1] + data[i+1][j+1];
+ ok_around = ok_around == 0 ? 0 : 1;
+ data[i][j] = cur_data > 2 ? ok_around : 0;
+ if (data[i][j] == 1) data_count++;
+ }
+ }
+ if (time % 5 == 0 && data_count < 500) { // we see empty picture, reset
+ reset (data);
+ time = 1;
+ }
+ if (rnbr >= 0) {
+ shape p = (get_patterns())[rnbr];
+ for (int s = 0; s < p.size; s++) {
+ cvLine (small, from_point (p.shape[s].start),
+ from_point (p.shape[s].end), CV_RGB (200, 100, 100), 3);
+ }
+ }
+ cvShowImage( "Reco", small );
+ if (time % 70 == 0) { // wait < 4s for now
+ shape_str_pos = sprintf (shape_str, "START %i ", data_count);
+ for (int i = 0; i < SIZEX; i++) {
+ for (int j = 0; j < SIZEY; j++) {
+ if (data[i][j] == 1) {
+ shape_str_pos += sprintf (shape_str + shape_str_pos,
+ "(%i, %i) -- (%i, %i) ", i, j, i, j);
+ }
+ }
+ }
+ sprintf (shape_str + shape_str_pos, " END");
+ printf ("step: %i\nsize: %i\nreco:\n", time/70, data_count);
+ print_ppm (data, (char*) "log");
+ reset (data);
+ recognize_from_string (shape_str, res, &rnbr, time/70 - 1);
+ printf ("%i\n", rnbr);
+ for (int i = 0; i < 2000; i++) res[i] = 0;
+ for (int i = 0; i < SIZEX*SIZEY*24; i++) shape_str[i] = 0;
+ }
+ time++;
+ char c = cvWaitKey (50);
+ if (c == 27) break;
+ }
+ cvReleaseCapture (&capture);
+ cvDestroyWindow ("Reco");
+
+ return (0);
+}
Added: trunk/Toss/Learn/shapes.c
===================================================================
--- trunk/Toss/Learn/shapes.c (rev 0)
+++ trunk/Toss/Learn/shapes.c 2011-12-10 23:39:15 UTC (rev 1636)
@@ -0,0 +1,1858 @@
+/* Implementation of Shape Matching.
+ This is derived from a Xournal patch by Lukasz Kaiser.
+ In the future, we could consider external libraries for Frechet distance:
+ e.g. http://www.cs.uu.nl/centers/give/multimedia/matching/shame.html */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <math.h>
+#include <pthread.h>
+
+typedef struct point_s {double x; double y;} point;
+typedef struct interval_s {point start; point end;} interval;
+
+typedef struct shape_s {
+ interval* shape;
+ int size;
+ char name[80];
+ double max_dist;
+ double correction;
+ double scale_correction;
+ double min_rotation;
+ double max_rotation;
+ double rotation_density;
+} shape;
+
+
+static pthread_mutex_t shapes_stop_mutex;
+static pthread_mutex_t shapes_working_mutex;
+static pthread_mutex_t shapes_painting_mutex;
+static int stop_signal;
+
+#define min(x, y) (y < x ? y : x)
+#define max(x, y) (y > x ? y : x)
+
+/* The metric parameter used by computing averages. */
+static double metric_k_1 = 1.4;
+static int get_metric_k_1 () { return (metric_k_1); }
+static void set_metric_k_1 (double k) { metric_k_1 = k; }
+static double metric_k_2 = 14;
+static int get_metric_k_2 () { return (metric_k_2); }
+static void set_metric_k_2 (double k) { metric_k_2 = k; }
+
+/* Compare two points (compatible for qsort). */
+static int point_cmp (const void * p1, const void * p2)
+{
+ double x1 = ((point*) p1)->x;
+ double y1 = ((point*) p1)->y;
+ double x2 = ((point*) p2)->x;
+ double y2 = ((point*) p2)->y;
+ if (x1 - x2 == 0) {
+ if (y1 - y2 > 0) {
+ return (1);
+ } else if (y1 - y2 < 0) {
+ return (-1);
+ } else {
+ return (0);
+ }
+ } else {
+ if (x1 - x2 > 0) {
+ return (1);
+ } else if (x1 - x2 < 0) {
+ return (-1);
+ } else {
+ return (0);
+ }
+ }
+}
+
+/* Distance from (x, y) to the interval (x1, y1) -- (x2, y2). */
+static double distance (const point p, const interval i)
+{
+ double x = p.x;
+ double y = p.y;
+ double x1 = i.start.x;
+ double y1 = i.start.y;
+ double x2 = i.end.x;
+ double y2 = i.end.y;
+
+ /* find (x3, y3) so that:
+ - (y3-y1)*(x2-x1) = (y2-y1)*(x3-x1) // (x3, y3) on the line 1-2
+ <=> y3*dx - y1*dx = x3*dy - x1*dy
+ <=> y3 = x3*(dy/dx) + y1 - x1(dy/dx)
+ <=> x3 = y3(dx/dy) + x1 - y1(dx/dy)
+ - (x1-x3, y1-y3)*(x-x3, y-y3) = 0 // ortogonal
+ <=> (x3-x1)*(x3-x) = (y3-y1)*(y-y3)
+ <=> (x2-x1)*(x3-x) = (y1-y2)*(y3-y)
+ <=> x3*dx - x*dx = y*dy - y3*dy
+ <=> x3*dx - x*dx = y*dy - (x3*dy*dy/dx) - y1*dy + x1*dy*dy/dx
+ <=> x3*(dx*dx + dy*dy) = y*dy*dx + x*dx*dx - y1*dy*dx + x1*dy*dy
+ <=> y3*dx*dx/dy + x1*dx - y1*dx*dx/dy - x*dx = y*dy - y3*dy
+ <=> y3*(dx*dx + dy*dy) = y*dy*dy + y1*dx*dx + dx*dy*(x-x1)
+ */
+ const double dx = x2 - x1;
+ const double dy = y2 - y1;
+ const double dsq = dx*dx + dy*dy;
+ if (dsq < 0.000000001) {
+ return (sqrt ((x1 - x) * (x1 - x) + (y1 - y) * (y1 - y)));
+ } else {
+ const double x3 = (dx*dy*(y - y1) + dx*dx*x + dy*dy*x1) / dsq;
+ const double y3 = (dx*dy*(x - x1) + dx*dx*y1 + dy*dy*y) / dsq;
+ /* Use (x3, y3) if it lies on (x1,y1)--(x2,y2):
+ - (min (x1, x2) <= x3 <= max (x1, x2))
+ - (min (y1, y2) <= y3 <= max (y1, y2)), else use one of the ends.
+ */
+ if ((min (x1, x2) <= x3) && (max (x1, x2) >= x3) &&
+ (min (y1, y2) <= y3) && (max (y1, y2) >= y3)) {
+ return (sqrt ((x3-x) * (x3-x) + (y3-y) * (y3-y)));
+ } else {
+ double d1 = sqrt ((x1-x) * (x1-x) + (y1-y) * (y1-y));
+ double d2 = sqrt ((x2-x) * (x2-x) + (y2-y) * (y2-y));
+ return (min (d1, d2));
+ }
+ }
+}
+
+/* min_(intervals) distance p-interval */
+static double point_distance (const point p, const interval* ivs, const int size)
+{
+ if (size == 0) return (0.0);
+ if (size == 1) return (distance (p, ivs[0]));
+ double x = p.x;
+ double y = p.y;
+
+ double current_min_pt_dist =
+ distance (p, ivs[(rand() % (size/2)) + (size/2)]);
+
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ double x1 = ivs[i].start.x;
+ double y1 = ivs[i].start.y;
+ double x2 = ivs[i].end.x;
+ double y2 = ivs[i].end.y;
+ if (!(((x1 + current_min_pt_dist < x) && (x2 + current_min_pt_dist < x)) ||
+ ((y1 + current_min_pt_dist < y) && (y2 + current_min_pt_dist < y)) ||
+ ((x1 - current_min_pt_dist > x) && (x2 - current_min_pt_dist > x)) ||
+ ((y1 - current_min_pt_dist > y) && (y2 - current_min_pt_dist > y)))) {
+ current_min_pt_dist = min (current_min_pt_dist, distance (p, ivs[i]));
+ }
+ }
+
+ return (current_min_pt_dist);
+}
+
+
+/* Calculate k-avg_(points) min_(interval) distance point-interval, where
+ k-avg is L_k metric average: k-root of sum of k-powers divided by size. */
+static double set_distance (const point* pts, const int sizep,
+ const interval* ivs, const int sizei)
+{
+ /* For efficiency we include k-avg computation directly here. */
+ int i = 0;
+ double sum1 = 0.0;
+ double sum2 = 0.0;
+ for (i = 0; i < sizep; i++) {
+ double dist = point_distance (pts[i], ivs, sizei);
+ sum1 += pow (dist, metric_k_1);
+ sum2 += pow (dist, metric_k_2);
+ }
+ sum1 /= sizep;
+ sum2 /= sizep;
+ sum1 = pow (sum1, 1/metric_k_1);
+ sum2 = pow (sum2, 1/metric_k_2);
+
+ return (sum1 + sum2);
+}
+
+/* Make a list of points in a shape, sort them and remove repetitions. */
+static point* shape_points (const interval* shape, const int size, int* res_size)
+{
+ point points[2*size];
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ points[2*i] = shape[i].start;
+ points[2*i+1] = shape[i].end;
+ }
+ qsort (points, 2*size, sizeof (points[0]), point_cmp);
+
+ *res_size = 0;
+ for (i = 0; i < 2*size-1; i++) {
+ if ((points[i].x != points[i+1].x) || (points[i].y != points[i+1].y)) {
+ (*res_size)++;
+ }
+ }
+ (*res_size)++;
+
+ point* new_points = calloc ((*res_size), sizeof (point));
+ int j = 0;
+ for (i = 0; i < 2*size-1; i++) {
+ if ((points[i].x != points[i+1].x) || (points[i].y != points[i+1].y)) {
+ new_points[j] = points[i];
+ j++;
+ }
+ }
+ new_points[j] = points[2*size-1];
+
+ return (new_points);
+}
+
+/* Calculate the distance between two shapes fast using point sets. */
+static double shape_distance_fast (const interval* s1, const int size1,
+ const point* p1, const int sizep1,
+ const interval* s2, const int size2,
+ const point* p2, const int sizep2)
+{
+ double d1 = set_distance (p1, sizep1, s2, size2);
+ double d2 = set_distance (p2, sizep2, s1, size1);
+
+ return (sqrt (d1*d1 + d2*d2));
+}
+
+/* Calculate the distance between two shapes. */
+static double shape_distance (const interval* s1, const int size1,
+ const interval* s2, const int size2)
+{
+
+ int points_size1 = 0;
+ point* points1 = shape_points (s1, size1, &points_size1);
+
+ int points_size2 = 0;
+ point* points2 = shape_points (s2, size2, &points_size2);
+
+ double res = shape_distance_fast (s1, size1, points1, points_size1,
+ s2, size2, points2, points_size2);
+
+ free (points1);
+ free (points2);
+
+ return (res);
+}
+
+/* Move a shape by a translation vector, given as a point. */
+static void move_shape (const point t, interval* s, const int size)
+{
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ s[i].start.x += t.x;
+ s[i].start.y += t.y;
+ s[i].end.x += t.x;
+ s[i].end.y += t.y;
+ }
+}
+
+/* Move a shape and its points by a translation vector, given as a point. */
+static void move_shape_points (const point t, interval* s, const int size,
+ point* points, const int points_size)
+{
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ s[i].start.x += t.x;
+ s[i].start.y += t.y;
+ s[i].end.x += t.x;
+ s[i].end.y += t.y;
+ }
+
+ for (i = 0; i < points_size; i++) {
+ points[i].x += t.x;
+ points[i].y += t.y;
+ }
+}
+
+/* Compute the middle (avg) of shape x and y, and the height and width. */
+static interval mid_dimen (const interval* s, const int size)
+{
+ interval res;
+ res.start.x = 0;
+ res.start.y = 0;
+ res.end.x = 0;
+ res.end.y = 0;
+ if (size == 0) return (res);
+
+ double minx = s[0].start.x;
+ double miny = s[0].start.y;
+ double maxx = s[0].start.x;
+ double maxy = s[0].start.y;
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ minx = min (minx, min (s[i].start.x, s[i].end.x));
+ miny = min (miny, min (s[i].start.y, s[i].end.y));
+ maxx = max (maxx, max (s[i].start.x, s[i].end.x));
+ maxy = max (maxy, max (s[i].start.y, s[i].end.y));
+ }
+
+ res.start.x = (minx + maxx) / 2;
+ res.start.y = (miny + maxy) / 2;
+ res.end.x = maxx - minx;
+ res.end.y = maxy - miny;
+ return (res);
+}
+
+/* Scale a shape by a scale vector, given as a point. */
+static void scale_shape (const point scale, interval* shape, const int size)
+{
+ interval mids = mid_dimen (shape, size);
+ double mx = mids.start.x;
+ double my = mids.start.y;
+
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ shape[i].start.x = ((shape[i].start.x - mx) * scale.x) + mx;
+ shape[i].start.y = ((shape[i].start.y - my) * scale.y) + my;
+ shape[i].end.x = ((shape[i].end.x - mx) * scale.x) + mx;
+ shape[i].end.y = ((shape[i].end.y - my) * scale.y) + my;
+ }
+}
+
+/* Scale a shape and its points by a scale vector, given as a point. */
+static void scale_shape_points (const point scale, interval* shape, const int size,
+ point* points, const int points_size)
+{
+ interval mids = mid_dimen (shape, size);
+ double mx = mids.start.x;
+ double my = mids.start.y;
+
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ shape[i].start.x = ((shape[i].start.x - mx) * scale.x) + mx;
+ shape[i].start.y = ((shape[i].start.y - my) * scale.y) + my;
+ shape[i].end.x = ((shape[i].end.x - mx) * scale.x) + mx;
+ shape[i].end.y = ((shape[i].end.y - my) * scale.y) + my;
+ }
+
+ for (i = 0; i < points_size; i++) {
+ points[i].x = ((points[i].x - mx) * scale.x) + mx;
+ points[i].y = ((points[i].y - my) * scale.y) + my;
+ }
+}
+
+/* Rotate point [p] by angle [a] (in radians) around point [x, y]. */
+static void rotate_point (point* p, double a, double tx, double ty)
+{
+ double x = p->x - tx;
+ double y = p->y - ty;
+
+ p->x = (x * cos (a) - y * sin (a)) + tx;
+ p->y = (x * sin (a) + y * cos (a)) + ty;
+}
+
+/* Rotate a shape by an angle, in radians. */
+static void rotate_shape (const double angle, interval* shape, const int size)
+{
+ interval mids = mid_dimen (shape, size);
+ double mx = mids.start.x;
+ double my = mids.start.y;
+
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ rotate_point (&shape[i].start, angle, mx, my);
+ rotate_point (&shape[i].end, angle, mx, my);
+ }
+}
+
+/* Scale a shape and its points by a scale vector, given as a point. */
+static void rotate_shape_points (const double angle, interval* shape, const int size,
+ point* points, const int points_size)
+{
+ interval mids = mid_dimen (shape, size);
+ double mx = mids.start.x;
+ double my = mids.start.y;
+
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ rotate_point (&shape[i].start, angle, mx, my);
+ rotate_point (&shape[i].end, angle, mx, my);
+ }
+
+ for (i = 0; i < points_size; i++) {
+ rotate_point (&points[i], angle, mx, my);
+ }
+}
+
+
+/* Move and scale a shape by a vector, given as an interval. */
+static void move_scale_shape (const point t, const point s,
+ interval* shape, const int size)
+{
+ move_shape (t, shape, size);
+ scale_shape (s, shape, size);
+}
+
+/* Move and scale a shape and its points by a vector, given as an interval. */
+static void move_scale_shape_points (const point t, const point s,
+ interval* shape, const int size,
+ point* points, const int points_size)
+{
+ move_shape_points (t, shape, size, points, points_size);
+ scale_shape_points (s, shape, size, points, points_size);
+}
+
+/* Move and scale and rotate a shape by a vector and an angle. */
+static void move_scale_rotate_shape (const point t, const point s, const double angle,
+ interval* shape, const int size)
+{
+ move_shape (t, shape, size);
+ scale_shape (s, shape, size);
+ rotate_shape (angle, shape, size);
+}
+
+/* Move and scale and rotate a shape and its points by a vector and an angle. */
+static void move_scale_rotate_shape_points (const point t, const point s,
+ const double angle,
+ interval* shape, const int size,
+ point* points, const int points_size)
+{
+ move_shape_points (t, shape, size, points, points_size);
+ scale_shape_points (s, shape, size, points, points_size);
+ rotate_shape_points (angle, shape, size, points, points_size);
+}
+
+
+/* Make shape denser to improve precision. */
+static interval* dense_shape (const interval* shape, const int size)
+{
+ interval* new_shape = calloc (2 * size, sizeof (interval));
+
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ double midx = (shape[i].start.x + shape[i].end.x) / 2;
+ double midy = (shape[i].start.y + shape[i].end.y) / 2;
+
+ new_shape[2*i].start.x = shape[i].start.x;
+ new_shape[2*i].start.y = shape[i].start.y;
+ new_shape[2*i].end.x = midx;
+ new_shape[2*i].end.y = midy;
+
+ new_shape[2*i+1].start.x = midx;
+ new_shape[2*i+1].start.y = midy;
+ new_shape[2*i+1].end.x = shape[i].end.x;
+ new_shape[2*i+1].end.y = shape[i].end.y;
+ }
+
+ return (new_shape);
+}
+
+
+/* Read shape from file. */
+static interval* fread_shape (FILE* file, int* size)
+{
+ fscanf (file, " START %i", size);
+
+ interval* shape = calloc (*size, sizeof (interval));
+ int i = 0;
+ for (i = 0; i < *size; i++) {
+ double x1, y1, x2, y2;
+ fscanf (file, " (%lf, %lf) -- (%lf, %lf)", &x1, &y1, &x2, &y2);
+ shape[i].start.x = x1;
+ shape[i].start.y = y1;
+ shape[i].end.x = x2;
+ shape[i].end.y = y2;
+ }
+ fscanf (file, " END");
+
+ return (shape);
+}
+
+/* Move a string [n] spaces forward. */
+static int move_by_space (const int n, const char* s)
+{
+ int i = 0;
+ int j = 0;
+ for (j = 0; j < n; j++) {
+ while (s[i] == ' ') i++;
+ while (s[i] != ' ') i++;
+ }
+ return (i);
+}
+
+/* Read shape from string. */
+static interval* sread_shape (const char* str, int* size, int* offset)
+{
+ sscanf (str + *offset, " START %i", size);
+ *offset += move_by_space (2, str + *offset);
+
+ interval* shape = calloc (*size, sizeof (interval));
+ int i = 0;
+ for (i = 0; i < *size; i++) {
+ double x1, y1, x2, y2;
+ sscanf (str + *offset, " (%lf, %lf) -- (%lf, %lf)", &x1, &y1, &x2, &y2);
+ *offset += move_by_space (5, str + *offset);
+ shape[i].start.x = x1;
+ shape[i].start.y = y1;
+ shape[i].end.x = x2;
+ shape[i].end.y = y2;
+ }
+ sscanf (str + *offset, " END");
+ *offset += move_by_space (1, str + *offset);
+
+ return (shape);
+}
+
+/* Print shape. */
+static void print_shape (const interval* shape, const int size)
+{
+ printf ("START %i\n", size);
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ printf ("(%lf, %lf) -- (%lf, %lf)\n", shape[i].start.x, shape[i].start.y,
+ shape[i].end.x, shape[i].end.y);
+ }
+ printf ("END\n");
+}
+
+static void sprint_shape (char* s, const interval* shape, const int size)
+{
+ int o;
+ o = sprintf (s, "START %i\n", size);
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ o += sprintf (s+o, "(%lf, %lf) -- (%lf, %lf)\n",
+ shape[i].start.x, shape[i].start.y,
+ shape[i].end.x, shape[i].end.y);
+ }
+ sprintf (s+o, "END\n");
+}
+
+
+/* Print points. */
+static void print_points (const point* points, const int size)
+{
+ printf ("START %i\n", size);
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ printf ("(%lf, %lf)\n", points[i].x, points[i].y);
+ }
+ printf ("END\n");
+}
+
+
+
+/* Structure to hold shape and pattern, parameters for minimization. */
+typedef struct shape_and_pattern_s {
+ interval* shape;
+ int shape_size;
+ point* shape_points;
+ int shape_points_size;
+ interval* pattern;
+ int pattern_size;
+ point* pattern_points;
+ int pattern_points_size;
+} shape_and_pattern;
+
+
+/* We compute a penalty for very disproportional scaling. */
+static double disproportional_scale_penalty (double x, double y)
+{
+ double max_penalty_factor = 8;
+ double max_prop_diff = 16;
+ double free_d = 1.5;
+
+ if ((x < 0.0001) && (y < 0.0001)) {
+ return (-1);
+ } else if (x < 0.0001) {
+ return (-1);
+ } else if (y < 0.0001) {
+ return (-1);
+ } else {
+ double prop_diff = max (0, min (max (x / y, y / x)-free_d, max_prop_diff));
+ return (1 + max_penalty_factor * (prop_diff / max_prop_diff));
+ }
+}
+
+/* Minimal and maximal allowed rotation for the current shape. */
+static double min_rotation = 0;
+static double max_rotation = 0;
+
+/* Compute the distance between moved, scaled, rotated pattern and shape. */
+static double move_scale_rotate_distance (const point t, const point s,
+ const double a, const shape_and_pattern* s_p)
+{
+ double scale_penalty = disproportional_scale_penalty (s.x, s.y);
+ if (scale_penalty < 0) { // Infinite penalty = forbidden scaling.
+ return (100 * 100 * 100);
+ }
+
+ if ((a < min_rotation) || (a > max_rotation)) { //Disallowed rotation.
+ return (100 * 100 * 100);
+ }
+
+ interval new_pattern[s_p->pattern_size];
+ point new_pattern_points[s_p->pattern_points_size];
+
+ int i;
+ for (i = 0; i < s_p->pattern_size; i++) {
+ new_pattern[i] = s_p->pattern[i];
+ }
+ for (i = 0; i < s_p->pattern_points_size; i++) {
+ new_pattern_points[i] = s_p->pattern_points[i];
+ }
+
+ move_scale_rotate_shape_points (t, s, a, new_pattern, s_p->pattern_size,
+ new_pattern_points, s_p->pattern_points_size);
+ double res =
+ shape_distance_fast (new_pattern, s_p->pattern_size,
+ new_pattern_points, s_p->pattern_points_size,
+ s_p->shape, s_p->shape_size,
+ s_p->shape_points, s_p->shape_points_size);
+
+
+ return (res * scale_penalty);
+}
+
+
+/* Places for results during iteration of minimizing functions. */
+static point current_best_move;
+static point current_best_scale;
+static double current_best_rot;
+/* Step values for minimization. */
+static point current_move_step;
+static point current_scale_step;
+static double current_rot_step;
+/* Current minimization value. */
+static double current_min_dist;
+
+static const double min_improvement_factor = 1.0000001;
+
+
+/* Try adjusting current_best_move by trying to move by the
+ current_move_step in both directions. Report if adjusted. */
+static int adjust_translation (const shape_and_pattern* s_p)
+{
+ int done_something = 0;
+ int best_x = 0;
+ int best_y = 0;
+ int i = 0;
+
+ double scale_penalty =
+ disproportional_scale_penalty (current_best_scale.x, current_best_scale.y);
+ if (scale_penalty < 0) {
+ return (0);
+ }
+
+ interval new_pattern[s_p->pattern_size];
+ point new_pattern_points[s_p->pattern_points_size];
+ for (i = 0; i < s_p->pattern_size; i++) {
+ new_pattern[i] = s_p->pattern[i];
+ }
+ for (i = 0; i < s_p->pattern_points_size; i++) {
+ new_pattern_points[i] = s_p->pattern_points[i];
+ }
+
+ point prev_move;
+ int prev_move_x = 0;
+ int prev_move_y = 0;
+ for (i = -3; i <= 3; i++) {
+ int j = 0;
+ for (j = -3; j <= 3; j++) {
+ point t = current_best_move;
+ t.x += current_move_step.x * (i - prev_move_x);
+ t.y += current_move_step.y * (j - prev_move_y);
+ double dist = current_min_dist;
+ if (((i != 0) || (j != 0)) && ((i == 0) || (j == 0))) {
+ move_shape_points (t, new_pattern, s_p->pattern_size,
+ new_pattern_points, s_p->pattern_points_size);
+ dist =
+ shape_distance_fast (new_pattern, s_p->pattern_size,
+ new_pattern_points, s_p->pattern_points_size,
+ s_p->shape, s_p->shape_size,
+ s_p->shape_points, s_p->shape_points_size);
+ dist *= scale_penalty;
+
+ prev_move_x = i;
+ prev_move_y = j;
+ }
+ if (dist * min_improvement_factor < current_min_dist) {
+ best_x = i;
+ best_y = j;
+ current_min_dist = dist;
+ done_something = 1;
+ }
+ }
+ }
+
+ if (done_something) {
+ current_best_move.x += current_move_step.x * best_x;
+ current_best_move.y += current_move_step.y * best_y;
+ return (1);
+ } else {
+ return (0);
+ }
+}
+
+/* Try adjusting current_best_scale by trying to move by the
+ current_scale_step in both directions. Report if adjusted. */
+static int adjust_scale (const shape_and_pattern* params)
+{
+ int done_something = 0;
+ int best_x = 0;
+ int best_y = 0;
+ int i = 0;
+ for (i = -1; i <= 1; i++) {
+ int j = 0;
+ for (j = -1; j <= 1; j++) {
+ point s = current_best_scale;
+ s.x += current_scale_step.x * i;
+ s.y += current_scale_step.y * j;
+ double dist = current_min_dist + 1;
+ if (((i != 0) || (j != 0)) && ((i == 0) || (j == 0))) {
+ dist = move_scale_rotate_distance (current_best_move, s,
+ current_best_rot, params);
+ }
+ if (dist * min_improvement_factor < current_min_dist) {
+ best_x = i;
+ best_y = j;
+ current_min_dist = dist;
+ done_something = 1;
+ }
+ }
+ }
+
+ if (done_something) {
+ current_best_scale.x += current_scale_step.x * best_x;
+ current_best_scale.y += current_scale_step.y * best_y;
+ return (1);
+ } else {
+ return (0);
+ }
+}
+
+/* Try adjusting current_best_rot by trying to move by the
+ current_rot_step, plus or minus. */
+static int adjust_rotation (const shape_and_pattern* params)
+{
+ double dist1 =
+ move_scale_rotate_distance (current_best_move, current_best_scale,
+ current_best_rot + current_rot_step, params);
+ double dist2 =
+ move_scale_rotate_distance (current_best_move, current_best_scale,
+ current_best_rot - current_rot_step, params);
+
+ if ((dist1 * min_improvement_factor < current_min_dist) && (dist1 < dist2)) {
+ current_min_dist = dist1;
+ current_best_rot += current_rot_step;
+ return (1);
+ }
+ if (dist2 * min_improvement_factor < current_min_dist) {
+ current_min_dist = dist2;
+ current_best_rot -= current_rot_step;
+ return (1);
+ }
+ return (0);
+}
+
+
+/* Makes one step correction of current move, step and rot vectors. */
+static void correct_move_scale_rot_step (const shape_and_pattern* params)
+{
+ int should_adjust = 1;
+ int adjusted = 0;
+
+ should_adjust = adjust_scale (params);
+ while (should_adjust > 0) should_adjust = adjust_scale (params);
+
+ should_adjust = adjust_translation (params);
+ while (should_adjust > 0) should_adjust = adjust_translation (params);
+
+ should_adjust = adjust_rotation (params);
+ while (should_adjust > 0) {
+ adjusted = 1;
+ should_adjust = adjust_rotation (params);
+ }
+
+ if (adjusted) {
+ if (adjust_scale (params) > 0) adjust_rotation (params);
+ }
+}
+
+/* Minimize distance between moved and scaled and rotated pattern and shape.
+ Starts with and changes the current_best_{move,scale,rot} variables. */
+static double find_minimal_dist_rot (const shape_and_pattern* params,
+ const int no_iter)
+{
+ current_min_dist =
+ move_scale_rotate_distance (current_best_move, current_best_scale,
+ current_best_rot, params);
+
+ int iters = 0;
+ while (iters < no_iter) {
+ int should_stop = 0;
+ pthread_mutex_lock (&shapes_stop_mutex);
+ should_stop = stop_signal;
+ pthread_mutex_unlock (&shapes_stop_mutex);
+
+ if (should_stop) { return (current_min_dist); }
+
+ correct_move_scale_rot_step (params);
+ current_move_step.x /= 4;
+ current_move_step.y /= 4;
+ current_scale_step.x /= 4;
+ current_scale_step.y /= 4;
+ current_rot_step /= 4;
+ iters++;
+ }
+
+ return (current_min_dist);
+}
+
+
+/* Find scale factor given pattern and shape dimensions. */
+static point find_scale (const point pattern_dim, const point shape_dim) {
+ point res;
+ if ((pattern_dim.x < 0.01) && (pattern_dim.y < 0.01)) {
+ res.x = 1;
+ res.y = 1;
+ } else if (pattern_dim.x < 0.01) {
+ res.x = shape_dim.y / pattern_dim.y;
+ res.y = shape_dim.y / pattern_dim.y;
+ } else if (pattern_dim.y < 0.01) {
+ res.x = shape_dim.x / pattern_dim.x;
+ res.y = shape_dim.x / pattern_dim.x;
+ } else {
+ res.x = shape_dim.x / pattern_dim.x;
+ res.y = shape_dim.y / pattern_dim.y;
+ }
+ return (res);
+}
+
+/* Find best fit (scale and translation) between shape and pattern. */
+static interval best_fit (interval* shape, const int s_size, interval* pattern,
+ const int p_size, const int no_iter, double* metric,
+ double* rotation)
+{
+ shape_and_pattern params;
+ int points_size = 0;
+ params.shape = shape;
+ params.shape_size = s_size;
+ params.shape_points = shape_points (shape, s_size, &points_size);
+ params.shape_points_size = points_size;
+
+ params.pattern = pattern;
+ params.pattern_size = p_size;
+ params.pattern_points = shape_points (pattern, p_size, &points_size);
+ params.pattern_points_size = points_size;
+
+ interval shape_mids = mid_dimen (shape, s_size);
+ interval pattern_mids = mid_dimen (pattern, p_size);
+
+ point d_move;
+ d_move.x = shape_mids.start.x - pattern_mids.start.x;
+ d_move.y = shape_mids.start.y - pattern_mids.start.y;
+ point d_scale = find_scale (pattern_mids.end, shape_mids.end);
+ double d_rot = 0;
+
+
+ // Determine initial best rotation.
+ if (max_rotation - min_rotation > M_PI / 8) {
+ int rotate_try_size =
+ ((int) 16 * ((max_rotation - min_rotation + 0.001) / (2 * M_PI)));
+ if (rotate_try_size == 0) rotate_try_size = 1;
+ interval check_pattern[p_size];
+ point tmp_scale;
+ double cur_best = 0;
+ double cur_dist = move_scale_rotate_distance (d_move, d_scale, 0, ¶ms);
+ double angle = 0;
+ for (angle = min_rotation; angle < max_rotation + 0.0001;
+ angle += (max_rotation - min_rotation) / rotate_try_size) {
+ int j = 0;
+ for (j = 0; j < p_size; j++) {
+ check_pattern[j] = pattern[j];
+ }
+ rotate_shape (angle, check_pattern, p_size);
+
+ interval check_mids = mid_dimen (check_pattern, p_size);
+ tmp_scale = find_scale (check_mids.end, shape_mids.end);
+
+ double dist =
+ move_scale_rotate_distance (d_move, tmp_scale, angle, ¶ms);
+ if (dist < cur_dist) {
+ cur_best = angle;
+ d_scale = tmp_scale;
+ cur_dist = dist;
+ }
+ }
+ d_rot = cur_best;
+ }
+
+ // Set start and step values.
+ current_best_move = d_move;
+ current_best_scale = d_scale;
+ current_best_rot = d_rot;
+ current_move_step.x = (d_move.x > 1 ? d_move.x / 8 : 0.1);
+ current_move_step.y = (d_move.y > 1 ? d_move.y / 8 : 0.1);
+ current_scale_step.x = (d_scale.x > 0.1 ? d_scale.x / 8 : 0.01);
+ current_scale_step.y = (d_scale.y > 0.1 ? d_scale.y / 8 : 0.01);
+ current_rot_step = M_PI / 16;
+
+ *metric = find_minimal_dist_rot (¶ms, no_iter);
+
+ double shape_density = s_size /
+ ((shape_mids.end.x + 0.001) * (shape_mids.end.y + 0.001));
+ *metric = (*metric) * sqrt (shape_density) * 6;
+
+ interval res;
+ res.start = current_best_move;
+ res.end = current_best_scale;
+ *rotation = current_best_rot;
+
+ free (params.shape_points);
+ free (params.pattern_points);
+
+ return (res);
+}
+
+
+/* Shape management and fitting. */
+
+/* Storing shape patterns here. */
+static shape* patterns;
+static int no_patts = 0;
+shape* get_patterns () { return (patterns); }
+static int no_patterns () { return (no_patts); }
+
+/* Global scaling factor for distance. */
+static double scale_factor = 1;
+static double get_scale_factor () { return (scale_factor); }
+static void set_scale_factor (double s) { scale_factor = s; }
+
+/* Results will be put here. */
+static interval res_vec;
+static double res_min;
+static double res_rot;
+static point get_res_move () { return (res_vec.start); }
+static point get_res_scale () { return (res_vec.end); }
+static double get_res_rot () { return (res_rot); }
+static double get_res_min () { return (res_min); }
+
+/* How long to look for best fit. */
+static int number_of_iterations = 4;
+static int get_no_iterations () { return (number_of_iterations); }
+static void set_no_iterations (int n) { number_of_iterations = n; }
+
+/* Below what size should we make patterns denser. */
+static const int densing_size = 12;
+
+/* Initialize shape patterns from file. */
+static void init_patterns_from_file (const char* fname)
+{
+ const char mode = 'r';
+ FILE* file = fopen (fname, &mode);
+
+ pthread_mutex_init (&shapes_stop_mutex, PTHREAD_MUTEX_TIMED_NP);
+ pthread_mutex_init (&shapes_working_mutex, PTHREAD_MUTEX_TIMED_NP);
+ pthread_mutex_init (&shapes_painting_mutex, PTHREAD_MUTEX_TIMED_NP);
+
+ fscanf (file, " SHAPES %i PRECISION %i RECO FACTOR %lf",
+ &no_patts, &number_of_iterations, &scale_factor);
+ patterns = calloc (no_patts, sizeof(shape));
+
+ int i = 0;
+ int j = 0;
+ for (i = 0; i < no_patts; i++) {
+ int shape_size = 0;
+ double max_dist = 0;
+
+ fscanf (file, " SHAPE %s MAXDIST %lf CORRECTION %lf SCALE DEVIATION %lf",
+ patterns[i].name, &patterns[i].max_dist, &patterns[i].correction,
+ &patterns[i].scale_correction);
+ // printf ("Reading %s.\n", patterns[i].name);
+ fscanf (file, " ROTATION MIN %lf MAX %lf DENSITY %lf",
+ &patterns[i].min_rotation, &patterns[i].max_rotation,
+ &patterns[i].rotation_density);
+ patterns[i].min_rotation = M_PI * patterns[i].min_rotation / 180;
+ patterns[i].max_rotation = M_PI * patterns[i].max_rotation / 180;
+ patterns[i].rotation_density = M_PI * patterns[i].rotation_density / 180;
+ if (patterns[i].correction < 0) patterns[i].correction = 0;
+
+ interval* shape = fread_shape (file, &shape_size);
+
+ while (shape_size <= densing_size) {
+ interval* new_shape = dense_shape (shape, shape_size);
+ free (shape);
+ shape = new_shape;
+ shape_size *= 2;
+ }
+
+ patterns[i].shape = shape;
+ patterns[i].size = shape_size;
+ }
+
+ fclose (file);
+}
+
+/* Initialize shape patterns from string. */
+static void init_patterns_from_string (const char* str)
+{
+ int offset = 0;
+
+ pthread_mutex_init (&shapes_stop_mutex, PTHREAD_MUTEX_TIMED_NP);
+ pthread_mutex_init (&shapes_working_mutex, PTHREAD_MUTEX_TIMED_NP);
+
+ sscanf (str + offset, " SHAPES %i PRECISION %i RECO FACTOR %lf",
+ &no_patts, &number_of_iterations, &scale_factor);
+ offset += move_by_space (7, str + offset);
+ patterns = calloc (no_patts, sizeof(shape));
+
+ int i = 0;
+ int j = 0;
+ for (i = 0; i < no_patts; i++) {
+ int shape_size = 0;
+ double max_dist = 0;
+
+ sscanf (str + offset,
+ " SHAPE %s MAXDIST %lf CORRECTION %lf SCALE DEVIATION %lf",
+ patterns[i].name, &patterns[i].max_dist, &patterns[i].correction,
+ &patterns[i].scale_correction);
+ offset += move_by_space (9, str + offset);
+ // printf ("Reading %s.\n", patterns[i].name);
+ sscanf (str + offset, " ROTATION MIN %lf MAX %lf DENSITY %lf",
+ &patterns[i].min_rotation, &patterns[i].max_rotation,
+ &patterns[i].rotation_density);
+ offset += move_by_space (7, str + offset);
+ patterns[i].min_rotation = M_PI * patterns[i].min_rotation / 180;
+ patterns[i].max_rotation = M_PI * patterns[i].max_rotation / 180;
+ patterns[i].rotation_density = M_PI * patterns[i].rotation_density / 180;
+ if (patterns[i].correction < 0) patterns[i].correction = 0;
+
+ interval* shape = sread_shape (str, &shape_size, &offset);
+
+ while (shape_size <= densing_size) {
+ interval* new_shape = dense_shape (shape, shape_size);
+ free (shape);
+ shape = new_shape;
+ shape_size *= 2;
+ }
+
+ patterns[i].shape = shape;
+ patterns[i].size = shape_size;
+ }
+}
+
+/* Free shape patterns storage. */
+static void free_patterns ()
+{
+ no_patts = 0;
+ free (patterns);
+}
+
+static double prev_scale = 1;
+
+/* Find best matching pattern for the given shape.
+ Return pattern number if there is one or -1 else.
+ The required translation and scale are put in res_vec. */
+static int match_pattern (interval* shape, const int size)
+{
+ double min = 0;
+ res_min = -2;
+ int res = -1;
+ int i = 0;
+
+ for (i = 0; i < no_patts; i++) {
+ int should_stop = 0;
+ pthread_mutex_lock (&shapes_stop_mutex);
+ should_stop = stop_signal;
+ pthread_mutex_unlock (&shapes_stop_mutex);
+
+ if (should_stop) { return (-1); }
+
+ min_rotation = patterns[i].min_rotation;
+ max_rotation = patterns[i].max_rotation;
+ double rot = 0;
+ interval fit = best_fit (shape, size, patterns[i].shape, patterns[i].size,
+ number_of_iterations, &min, &rot);
+ if (rot < 0) rot += 2 * M_PI;
+ if (min > 2*patterns[i].correction) min -= patterns[i].correction;
+ min /= scale_factor;
+ //printf ("Distance to pattern %s: %lf.\n", patterns[i].name, min);
+ if ((min <= patterns[i].max_dist) &&
+ ((min < res_min) || (res_min < -1))) {
+ res_min = min;
+ res_rot = rot;
+ res_vec = fit;
+ res = i;
+ }
+ }
+ // printf ("\n");
+
+ if (res > -1) {
+ // Scale correction.
+ if ((res_vec.end.x > 0.0001) && (res_vec.end.y > 0.0001)) {
+ double quot = res_vec.end.x / res_vec.end.y;
+ double scale_correction = patterns[res].scale_correction;
+ if ((1 - scale_correction < quot) && (quot < 1 + scale_correction)) {
+ double q_pre = 2 * prev_scale / (res_vec.end.x + res_vec.end.y);
+ if ((1 - scale_correction < q_pre) && (q_pre < 1 + scale_correction)) {
+ res_vec.end.x = prev_scale;
+ res_vec.end.y = prev_scale;
+ } else {
+ res_vec.end.x = (res_vec.end.x + res_vec.end.y) / 2;
+ res_vec.end.y = res_vec.end.x;
+ prev_scale = res_vec.end.x;
+ }
+ }
+ }
+
+ // Rotation correction.
+ double rot_density = patterns[res].rotation_density;
+ if (rot_density > 0) {
+ res_rot = rint (res_rot / rot_density) * rot_density;
+ }
+ }
+
+ return (res);
+}
+
+/* Determine if two intervals can be merged looking at the angle they form. */
+static double merge_possibility (interval i1, interval i2)
+{
+ if ((i1.end.x != i2.start.x) || (i1.end.y != i2.start.y)) {
+ return (4);
+ } else {
+ double angle1 = atan2 (i1.start.y - i1.end.y, i1.start.x - i1.end.x);
+ double angle2 = atan2 (i2.end.y - i1.end.y, i2.end.x - i1.end.x);
+ return (fabs (fabs (angle1 - angle2) - M_PI));
+ }
+}
+
+/* The angle in degrees from which on we decide to merge. */
+static const double merge_degrees = 3;
+
+/* Decrease the size of the shape when possible, one step. */
+static interval* downsize_shape_step (const interval* shape, const int size,
+ int* new_size)
+{
+ double merge_diff = (M_PI * merge_degrees) / 180;
+ interval new_shape[size];
+
+ int i = 0;
+ int j = 0;
+ for (i = 0; i < size-1; i++) {
+ if (merge_possibility (shape[i], shape[i+1]) < merge_diff) {
+ new_shape[j].start = shape[i].start;
+ new_shape[j].end = shape[i+1].end;
+ j++;
+ i++;
+ } else {
+ new_shape[j] = shape[i];
+ j++;
+ }
+ }
+ if (i < size) { new_shape[j] = shape[i]; j++; }
+ *new_size = j;
+
+ interval* res_shape = calloc (*new_size, sizeof (interval));
+ for (i = 0; i < *new_size; i++) {
+ res_shape[i] = new_shape[i];
+ }
+
+ return (res_shape);
+}
+
+/* Decrease the size of the shape when possible, one step. */
+static interval* downsize_shape (const interval* shape, const int size,
+ int* final_size)
+{
+ int prev_size = size;
+ int cur_size = 0;
+ interval* cur_shape = downsize_shape_step (shape, size, &cur_size);
+
+ while (cur_size != prev_size) {
+ int new_size = 0;
+ interval* new_shape = downsize_shape_step (cur_shape, cur_size, &new_size);
+ prev_size = cur_size;
+ free (cur_shape);
+ cur_shape = new_shape;
+ cur_size = new_size;
+ }
+
+ *final_size = cur_size;
+ return (cur_shape);
+}
+
+/* Find best matching pattern for the given line segments.
+ Return pattern number if there is one or -1 else.
+ Combine with the previous pattern if [next] is set.
+ The required translation, scale, rotation are put in res_{move,scale,rot}. */
+static interval* current_lin_shape = NULL;
+static int current_lin_shape_size = 0;
+static interval* get_recent_shape () { return (current_lin_shape); }
+static int get_recent_shape_size () { return (current_lin_shape_size); }
+
+static int match_pattern_line (const double* segments, const int size, const int next)
+{
+ interval* shape;
+ int start;
+
+ if ((current_lin_shape_size > 0) && (next)) {
+ shape = calloc (current_lin_shape_size + size-1, sizeof (interval));
+ start = current_lin_shape_size;
+ } else {
+ shape = calloc (size-1, sizeof (interval));
+ start = 0;
+ }
+
+
+ int i = 0;
+ for (i = 0; i < start; i++) {
+ shape[i] = current_lin_shape[i];
+ }
+ for (i = 0; i < size-1; i++) {
+ shape[i+start].start.x = segments[2*i];
+ shape[i+start].start.y = segments[2*i+1];
+ shape[i+start].end.x = segments[2*i+2];
+ shape[i+start].end.y = segments[2*i+3];
+ }
+
+ free (current_lin_shape);
+
+ current_lin_shape =
+ downsize_shape (shape, start+size-1, ¤t_lin_shape_size);
+
+ free (shape);
+
+ return (match_pattern (current_lin_shape, current_lin_shape_size));
+}
+
+static void stop_recognition_forced ()
+{
+ pthread_mutex_lock (&shapes_stop_mutex);
+ stop_signal = 1;
+ pthread_mutex_unlock (&shapes_stop_mutex);
+
+ pthread_mutex_lock (&shapes_working_mutex);
+ pthread_mutex_unlock (&shapes_working_mutex);
+}
+
+static void stop_recognition (int milisec)
+{
+ stop_recognition_forced ();
+ int failed_lock = pthread_mutex_trylock (&shapes_working_mutex);
+
+ int i = 0;
+ while ((failed_lock > 0) && (i < milisec)) {
+ usleep (10000);
+ i++;
+ failed_lock = pthread_mutex_trylock (&shapes_working_mutex);
+ }
+
+ if (failed_lock > 0) {
+ stop_recognition_forced ();
+ } else {
+ pthread_mutex_unlock (&shapes_working_mutex);
+ }
+}
+
+static void stop_recognition_now ()
+{
+ if (pthread_mutex_trylock (&shapes_working_mutex) == 0) {
+ pthread_mutex_unlock (&shapes_working_mutex);
+ } else {
+ stop_recognition_forced ();
+ }
+}
+
+int status_recognize = 0;
+void set_recognize (int onoff) { status_recognize = onoff; }
+int should_recognize () { return (status_recognize); }
+
+/* Default patterns. */
+
+/* There are 35 shapes with letters, but we skip letters and use only 10. */
+/*(-3, -3) -- (-3, 3) \
+(-3, 3) -- (3, 3) \
+(3, 3) -- (3, -3) \
+(3, -3) -- (-3, -3) \ */
+static const char* default_shape_patterns = "\
+SHAPES 1 \
+PRECISION 4 \
+RECO FACTOR 1.6 \
+ \
+SHAPE grid3 MAXDIST 900 CORRECTION 2 \
+SCALE DEVIATION 0 \
+ROTATION MIN -1 MAX 1 DENSITY 0 \
+START 8 \
+(-3, -3) -- (-3, 3) \
+(-3, 3) -- (3, 3) \
+(3, 3) -- (3, -3) \
+(3, -3) -- (-3, -3) \
+(-1, -3) -- (-1, 3) \
+(1, -3) -- (1, 3) \
+(-3, -1) -- (3, -1) \
+(-3, 1) -- (3, 1) \
+END \
+ \
+SHAPE grid3mid MAXDIST 900 CORRECTION 1 \
+SCALE DEVIATION 0.2 \
+ROTATION MIN -10 MAX 10 DENSITY 0 \
+START 6 \
+(-1, -3) -- (-1, 3) \
+(1, -3) -- (1, 3) \
+(-3, -1) -- (3, -1) \
+(-3, 1) -- (3, 1) \
+(0.8, 0.8) -- (-0.8, -0.8) \
+(0.8, -0.8) -- (-0.8, 0.8) \
+END \
+ \
+SHAPE arrow2 MAXDIST 9 CORRECTION 2.2 \
+SCALE DEVIATION 0 \
+ROTATION MIN -180 MAX 180 DENSITY 0 \
+START 7 \
+(0, -2) -- (0, -1) \
+(0, -1) -- (0, 0) \
+(0, 0) -- (0, 1) \
+(0, 1) -- (0, 2) \
+(0, 2) -- (-0.5, 1.5) \
+(-0.5, 1.5) -- (0, 2) \
+(0, 2) -- (0.5, 1.5) \
+END \
+ \
+ \
+SHAPE backarrow1 MAXDIST 9 CORRECTION 1.6 \
+SCALE DEVIATION 0 \
+ROTATION MIN -180 MAX 180 DENSITY 0 \
+START 18 \
+(0.75, 0.25) -- (1, 0) \
+(1, 0) -- (1.25, 0.25) \
+(1.25, 0.25) -- (1, 0) \
+(1.000000, 0.000000) -- (0.951057, 0.309017) \
+(0.951057, 0.309017) -- (0.809017, 0.587785) \
+(0.809017, 0.587785) -- (0.587785, 0.809017) \
+(0.587785, 0.809017) -- (0.309017, 0.951057) \
+(0.309017, 0.951057) -- (0.000000, 1.000000) \
+(0.000000, 1.000000) -- (-0.309017, 0.951057) \
+(-0.309017, 0.951057) -- (-0.587785, 0.809017) \
+(-0.587785, 0.809017) -- (-0.809017, 0.587785) \
+(-0.809017, 0.587785) -- (-0.951057, 0.309017) \
+(-0.951057, 0.309017) -- (-1.000000, 0.000000) \
+(-1.000000, 0.000000) -- (-0.951057, -0.309017) \
+(-0.951057, -0.309017) -- (-0.809017, -0.587785) \
+(-0.809017, -0.587785) -- (-0.587785, -0.809017) \
+(-0.587785, -0.809017) -- (-0.309017, -0.951057) \
+(-0.309017, -0.951057) -- (-0.000000, -1.000000) \
+END \
+ \
+ \
+SHAPE backarrow2 MAXDIST 9 CORRECTION 1.6 \
+SCALE DEVIATION 0 \
+ROTATION MIN -180 MAX 180 DENSITY 0 \
+START 18 \
+(1.000000, 0.000000) -- (0.951057, 0.309017) \
+(0.951057, 0.309017) -- (0.809017, 0.587785) \
+(0.809017, 0.587785) -- (0.587785, 0.809017) \
+(0.587785, 0.809017) -- (0.309017, 0.951057) \
+(0.309017, 0.951057) -- (0.000000, 1.000000) \
+(0.000000, 1.000000) -- (-0.309017, 0.951057) \
+(-0.309017, 0.951057) -- (-0.587785, 0.809017) \
+(-0.587785, 0.809017) -- (-0.809017, 0.587785) \
+(-0.809017, 0.587785) -- (-0.951057, 0.309017) \
+(-0.951057, 0.309017) -- (-1.000000, 0.000000) \
+(-1.000000, 0.000000) -- (-0.951057, -0.309017) \
+(-0.951057, -0.309017) -- (-0.809017, -0.587785) \
+(-0.809017, -0.587785) -- (-0.587785, -0.809017) \
+(-0.587785, -0.809017) -- (-0.309017, -0.951057) \
+(-0.309017, -0.951057) -- (-0.000000, -1.000000) \
+(0, -1) -- (-0.25, -0.75) \
+(-0.25, -0.75) -- (0, -1) \
+(0, -1) -- (-0.25, -1.25) \
+END \
+ \
+ \
+SHAPE bentarrow1 MAXDIST 9 CORRECTION 2 \
+SCALE DEVIATION 0 \
+ROTATION MIN -180 MAX 180 DENSITY 0 \
+START 11 \
+(0.751057, 0.309017) -- (0.951057, 0.309017) \
+(0.951057, 0.309017) -- (0.951057, 0.509017) \
+(0.951057, 0.509017) -- (0.951057, 0.309017) \
+(0.951057, 0.309017) -- (0.809017, 0.587785) \
+(0.809017, 0.587785) -- (0.587785, 0.809017) \
+(0.587785, 0.809017) -- (0.309017, 0.951057) \
+(0.309017, 0.951057) -- (0.000000, 1.000000) \
+(0.000000, 1.000000) -- (-0.309017, 0.951057) \
+(-0.309017, 0.951057) -- (-0.587785, 0.809017) \
+(-0.587785, 0.809017) -- (-0.809017, 0.587785) \
+(-0.809017, 0.587785) -- (-0.951057, 0.309017) \
+END \
+ \
+ \
+SHAPE bentarrow2 MAXDIST 9 CORRECTION 2 \
+SCALE DEVIATION 0 \
+ROTATION MIN -180 MAX 180 DENSITY 0 \
+START 11 \
+(0.951057, 0.309017) -- (0.809017, 0.587785) \
+(0.809017, 0.587785) -- (0.587785, 0.809017) \
+(0.587785, 0.809017) -- (0.309017, 0.951057) \
+(0.309017, 0.951057) -- (0.000000, 1.000000) \
+(0.000000, 1.000000) -- (-0.309017, 0.951057) \
+(-0.309017, 0.951057) -- (-0.587785, 0.809017) \
+(-0.587785, 0.809017) -- (-0.809017, 0.587785) \
+(-0.809017, 0.587785) -- (-0.951057, 0.309017) \
+(-0.951057, 0.309017) -- (-0.951057, 0.509017) \
+(-0.951057, 0.509017) -- (-0.951057, 0.309017) \
+(-0.951057, 0.309017) -- (-0.751057, 0.309017) \
+END \
+ \
+ \
+SHAPE triangle MAXDIST 8 CORRECTION 1.7 \
+SCALE DEVIATION 0.2 \
+ROTATION MIN -180 MAX 180 DENSITY 30 \
+START 6 \
+(0, 0) -- (1, 0) \
+(1, 0) -- (2, 0) \
+(2, 0) -- (1.5, 0.866025) \
+(1.5, 0.866025) -- (1, 1.732051) \
+(1, 1.732051) -- (0.5, 0.866025) \
+(0.5, 0.866025) -- (0, 0) \
+END \
+ \
+ \
+SHAPE rectangle MAXDIST 7 CORRECTION 0.8 \
+SCALE DEVIATION 0.35 \
+ROTATION MIN -45 MAX 45 DENSITY 45 \
+START 8 \
+(0, 0) -- (0, 1) \
+(0, 1) -- (0, 2) \
+(0, 2) -- (1, 2) \
+(1, 2) -- (2, 2) \
+(2, 2) -- (2, 1) \
+(2, 1) -- (2, 0) \
+(2, 0) -- (1, 0) \
+(1, 0) -- (0, 0) \
+END \
+ \
+SHAPE circle MAXDIST 7 CORRECTION 0 \
+SCALE DEVIATION 0.35 \
+ROTATION MIN -45 MAX 45 DENSITY 90 \
+START 41 \
+(1.000000, 0.000000) -- (0.988280, 0.152649) \
+(0.988280, 0.152649) -- (0.953396, 0.301721) \
+(0.953396, 0.301721) -- (0.896166, 0.443720) \
+(0.896166, 0.443720) -- (0.817929, 0.575319) \
+(0.817929, 0.575319) -- (0.720522, 0.693433) \
+(0.720522, 0.693433) -- (0.606225, 0.795293) \
+(0.606225, 0.795293) -- (0.477720, 0.878512) \
+(0.477720, 0.878512) -- (0.338017, 0.941140) \
+(0.338017, 0.941140) -- (0.190391, 0.981708) \
+(0.190391, 0.981708) -- (0.038303, 0.999266) \
+(0.038303, 0.999266) -- (-0.114683, 0.993402) \
+(-0.114683, 0.993402) -- (-0.264982, 0.964253) \
+(-0.264982, 0.964253) -- (-0.409069, 0.912504) \
+(-0.409069, 0.912504) -- (-0.543568, 0.839365) \
+(-0.543568, 0.839365) -- (-0.665326, 0.746553) \
+(-0.665326, 0.746553) -- (-0.771489, 0.636242) \
+(-0.771489, 0.636242) -- (-0.859570, 0.511019) \
+(-0.859570, 0.511019) -- (-0.927502, 0.373817) \
+(-0.927502, 0.373817) -- (-0.973695, 0.227854) \
+(-0.973695, 0.227854) -- (-0.997066, 0.076549) \
+(-0.997066, 0.076549) -- (-0.997066, -0.076549) \
+(-0.997066, -0.076549) -- (-0.973695, -0.227854) \
+(-0.973695, -0.227854) -- (-0.927502, -0.373817) \
+(-0.927502, -0.373817) -- (-0.859570, -0.511019) \
+(-0.859570, -0.511019) -- (-0.771489, -0.636242) \
+(-0.771489, -0.636242) -- (-0.665326, -0.746553) \
+(-0.665326, -0.746553) -- (-0.543568, -0.839365) \
+(-0.543568, -0.839365) -- (-0.409069, -0.912504) \
+(-0.409069, -0.912504) -- (-0.264982, -0.964253) \
+(-0.264982, -0.964253) -- (-0.114683, -0.993402) \
+(-0.114683, -0.993402) -- (0.038303, -0.999266) \
+(0.038303, -0.999266) -- (0.190391, -0.981708) \
+(0.190391, -0.981708) -- (0.338017, -0.941140) \
+(0.338017, -0.941140) -- (0.477720, -0.878512) \
+(0.477720, -0.878512) -- (0.606225, -0.795293) \
+(0.606225, -0.795293) -- (0.720522, -0.693433) \
+(0.720522, -0.693433) -- (0.817929, -0.575319) \
+(0.817929, -0.575319) -- (0.896166, -0.443720) \
+(0.896166, -0.443720) -- (0.953396, -0.301721) \
+(0.953396, -0.301721) -- (0.988280, -0.152649) \
+(0.988280, -0.152649) -- (1.000000, -0.000000) \
+END \
+ \
+SHAPE A MAXDIST 8 CORRECTION 2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(0.5, 4) -- (0.2, 4) \
+(0.2, 4) -- (-1.5, 0) \
+(0.5, 4) -- (1.5, 0) \
+(-0.8, 2) -- (1.2, 2) \
+END \
+ \
+SHAPE B MAXDIST 8 CORRECTION 3.6 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 11 \
+(0, 4) -- (0, 0) \
+(0, 0) -- (1.5, 0) \
+(1.5, 0) -- (2.2, 0.5) \
+(2.2, 0.5) -- (2.4, 1.1) \
+(2.4, 1.1) -- (2.2, 1.7) \
+(2.2, 1.7) -- (1.5, 2.2) \
+(1.5, 2.2) -- (1.2, 2.2) \
+(1.2, 2.2) -- (1.8, 3.1) \
+(1.8, 3.1) -- (1.2, 4) \
+(1.2, 4) -- (0, 4) \
+(0, 2.2) -- (1.2, 2.2) \
+END \
+ \
+SHAPE C MAXDIST 8 CORRECTION 2.2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 8 \
+(3, 0.8) -- (2, 0) \
+(2, 0) -- (1, 0) \
+(1, 0) -- (0, 1) \
+(0, 1) -- (0, 2) \
+(0, 2) -- (0, 3) \
+(0, 3) -- (1, 4) \
+(1, 4) -- (2, 4) \
+(2, 4) -- (2.5, 3.5) \
+END \
+ \
+SHAPE D MAXDIST 8 CORRECTION 2.4 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 7 \
+(0, 4) -- (0, 2) \
+(0, 2) -- (0, 0) \
+(0, 0) -- (1, 0) \
+(1, 0) -- (2, 0.8) \
+(2, 0.8) -- (2, 2.8) \
+(2, 2.8) -- (1, 4) \
+(1, 4) -- (0, 4) \
+END \
+ \
+SHAPE E MAXDIST 8 CORRECTION 2.6 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 5 \
+(0, 4) -- (0, 0) \
+(2, 0) -- (0, 0) \
+(0, 0) -- (0, 2) \
+(1.5, 2) -- (0, 2) \
+(0, 4) -- (2, 4) \
+END \
+ \
+SHAPE F MAXDIST 8 CORRECTION 3.8 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(0, 0) -- (0, 4) \
+(0, 4) -- (2.5, 4) \
+(2.5, 4) -- (2.5, 3.8) \
+(0, 1.9) -- (1.8, 1.9) \
+END \
+ \
+SHAPE G MAXDIST 8 CORRECTION 3.4 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 9 \
+(2, 4) -- (1, 4) \
+(1, 4) -- (0, 3) \
+(0, 3) -- (0, 2) \
+(0, 2) -- (0, 1) \
+(0, 1) -- (1, 0) \
+(1, 0) -- (2, 0) \
+(2, 0) -- (2.5, 2) \
+(2.5, 2) -- (1.5, 2) \
+(1.5, 2) -- (3.5, 2) \
+END \
+ \
+SHAPE H MAXDIST 8 CORRECTION 2.4 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(0, 4) -- (0, 0) \
+(2.5, 4) -- (2.5, 0) \
+(0, 1.8) -- (1.5, 1.8) \
+(1.5, 1.8) -- (2.5, 2) \
+END \
+ \
+SHAPE I MAXDIST 8 CORRECTION 3.2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 3 \
+(-1, 0) -- (1, 0) \
+(0, 0) -- (0, 4) \
+(-1, 4) -- (1, 4) \
+END \
+ \
+SHAPE J MAXDIST 8 CORRECTION 3.8 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(-2, 4) -- (0, 4) \
+(0, 4) -- (0, 1) \
+(0, 1) -- (-1, 0) \
+(-1, 0) -- (-2, 1) \
+END \
+ \
+SHAPE K MAXDIST 8 CORRECTION 1.5 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 3 \
+(0, 4) -- (0, 0) \
+(0, 1) -- (3, 4) \
+(0.5, 1.5) -- (3, 0) \
+END \
+ \
+SHAPE L MAXDIST 8 CORRECTION 2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 2 \
+(0, 4) -- (0, 0) \
+(0, 0) -- (2, 0) \
+END \
+ \
+SHAPE M MAXDIST 8 CORRECTION 2.5 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 6 \
+(0, 0) -- (0, 4) \
+(0, 4) -- (1.2, 2.2) \
+(1.2, 2.2) -- (1.5, 2) \
+(1.5, 2) -- (1.8, 2.2) \
+(1.8, 2.2) -- (3, 4) \
+(3, 4) -- (3, 0) \
+END \
+ \
+SHAPE N MAXDIST 8 CORRECTION 2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(0, 0) -- (0, 4) \
+(0, 4) -- (2, 0.5) \
+(2, 0.5) -- (2.5, 1) \
+(2.5, 1) -- (2.8, 4) \
+END \
+ \
+SHAPE P MAXDIST 8 CORRECTION 1.5 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 6 \
+(0, 0) -- (0, 4) \
+(0, 4) -- (1, 4) \
+(1, 4) -- (2, 3.5) \
+(2, 3.5) -- (2, 2.5) \
+(2, 2.5) -- (1, 2) \
+(1, 2) -- (0, 2) \
+END \
+ \
+SHAPE Q MAXDIST 8 CORRECTION 3.4 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 9 \
+(2, 0) -- (1, 0) \
+(1, 0) -- (0, 1) \
+(0, 1) -- (0, 3) \
+(0, 3) -- (1, 4) \
+(1, 4) -- (2, 4) \
+(2, 4) -- (3, 3) \
+(3, 3) -- (3, 1) \
+(3, 1) -- (2, 0) \
+(2, 1) -- (4, 0) \
+END \
+ \
+SHAPE R MAXDIST 8 CORRECTION 2.2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 7 \
+(0, 0) -- (0, 4) \
+(0, 4) -- (1, 4) \
+(1, 4) -- (2, 3.5) \
+(2, 3.5) -- (2, 2.5) \
+(2, 2.5) -- (1, 2) \
+(1, 2) -- (0, 2) \
+(0, 2) -- (2, 0) \
+END \
+ \
+SHAPE S MAXDIST 8 CORRECTION 2.6 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 8 \
+(1.5, 3.5) -- (1, 4) \
+(1, 4) -- (0, 4) \
+(0, 4) -- (-1, 3) \
+(-1, 3) -- (0, 2) \
+(0, 2) -- (1, 1) \
+(1, 1) -- (0, 0) \
+(0, 0) -- (-1, 0) \
+(-1, 0) -- (-1.5, 0.5) \
+END \
+ \
+SHAPE T MAXDIST 8 CORRECTION 5.8 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(1.4, 3.8) -- (1.4, 4) \
+(1.4, 4) -- (-1.4, 4) \
+(-1.4, 4) -- (-1.4, 3.8) \
+(0, 4) -- (0, 0) \
+END \
+ \
+SHAPE U MAXDIST 8 CORRECTION 1.7 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 6 \
+(1, 4) -- (1, 1.5) \
+(1, 1.5) -- (1.4, 0) \
+(1, 1.5) -- (0, 0) \
+(0, 0) -- (-0.5, 0) \
+(-0.5, 0) -- (-1, 1) \
+(-1, 1) -- (-1, 4) \
+END \
+ \
+SHAPE V MAXDIST 8 CORRECTION 1.6 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 2 \
+(1.5, 4.5) -- (0, 0) \
+(-1, 4) -- (0, 0) \
+END \
+ \
+SHAPE W MAXDIST 8 CORRECTION 2 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(-1.5, 4) -- (-1, 0) \
+(-1, 0) -- (0, 2.5) \
+(0, 2.5) -- (1, 0) \
+(1, 0) -- (2, 4) \
+END \
+ \
+SHAPE X MAXDIST 8 CORRECTION 2.8 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 4 \
+(-2, 4) -- (0, 0) \
+(0, 0) -- (2, 4) \
+(-2, -4) -- (0, 0) \
+(0, 0) -- (2, -4) \
+END \
+ \
+SHAPE Y MAXDIST 8 CORRECTION 4.4 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 2 \
+(2, 4) -- (0, 0) \
+(-0.8, 4) -- (0.8, 1.6) \
+END \
+ \
+SHAPE Z MAXDIST 8 CORRECTION 2.8 \
+SCALE DEVIATION 0.5 \
+ROTATION MIN -9 MAX 9 DENSITY 20 \
+START 3 \
+(0, 4) -- (3, 4) \
+(3, 4) -- (0, 0) \
+(0, 0) -- (3, 0) \
+END \
+";
+
+
+/* Cut shape to the given rectangle. */
+static interval* cut_shape (const interval* shape, const int size,
+ point bottom_left, point top_right, int* res_size)
+{
+ int new_size = 0;
+ int i = 0;
+ for (i = 0; i < size; i++) {
+ if (shape[i].start.x > bottom_left.x && shape[i].start.y > bottom_left.y &&
+ shape[i].start.x < top_right.x && shape[i].start.y < top_right.y &&
+ shape[i].end.x > bottom_left.x && shape[i].end.y > bottom_left.y &&
+ shape[i].end.x < top_right.x && shape[i].end.y < top_right.y) {
+ new_size++;
+ }
+ }
+
+ interval* new_shape = calloc (new_size, sizeof (interval));
+ int j = 0;
+ for (i = 0; i < size; i++) {
+ if (shape[i].start.x > bottom_left.x && shape[i].start.y > bottom_left.y &&
+ shape[i].start.x < top_right.x && shape[i].start.y < top_right.y &&
+ shape[i].end.x > bottom_left.x && shape[i].end.y > bottom_left.y &&
+ shape[i].end.x < top_right.x && shape[i].end.y < top_right.y) {
+ new_shape[j].start.x = shape[i].start.x;
+ new_shape[j].start.y = shape[i].start.y;
+ new_shape[j].end.x = shape[i].end.x;
+ new_shape[j].end.y = shape[i].end.y;
+ j++;
+ }
+ }
+
+ *res_size = new_size;
+ return (new_shape);
+}
+
+#define gridSIZE 3
+#define gridJUMP 1
+#define gridMARGIN 0.28
+int gridSIZES[gridSIZE][gridSIZE];
+interval * gridSHAPES[gridSIZE][gridSIZE];
+
+
+/* Run complete recognition from string, return resul...
[truncated message content] |
|
From: <luk...@us...> - 2012-01-16 14:23:49
|
Revision: 1640
http://toss.svn.sourceforge.net/toss/?rev=1640&view=rev
Author: lukaszkaiser
Date: 2012-01-16 14:23:37 +0000 (Mon, 16 Jan 2012)
Log Message:
-----------
Tidy up: moving learning things to Learn.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Tests.ml
Added Paths:
-----------
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
Removed Paths:
-------------
trunk/Toss/Server/LearnGame.ml
trunk/Toss/Server/LearnGame.mli
trunk/Toss/Server/LearnGameTest.ml
trunk/Toss/Solver/Distinguish.ml
trunk/Toss/Solver/Distinguish.mli
trunk/Toss/Solver/DistinguishTest.ml
Copied: trunk/Toss/Learn/Distinguish.ml (from rev 1639, trunk/Toss/Solver/Distinguish.ml)
===================================================================
--- trunk/Toss/Learn/Distinguish.ml (rev 0)
+++ trunk/Toss/Learn/Distinguish.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -0,0 +1,269 @@
+open Formula
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
+type logic = FO | GuardedFO
+
+
+(* Helper functions to construct variables for indices. *)
+let varname i = "x" ^ string_of_int i
+let varnames k = List.map varname (Aux.range k)
+let var i = var_of_string (varname i)
+let fo_var i = fo_var_of_string (varname i)
+
+(* Helper function: check if a formula holds for a tuple on a structure. *)
+let check structure tuple formula =
+ 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 assignment = if tuple = [||] then AssignmentSet.Any else
+ Assignments.assignments_of_list elems vars [tuple] in
+ eval structure formula assignment <> AssignmentSet.Empty
+
+(* - Atoms and FO Types - *)
+
+(* The list of literals which hold for a tuple on a structure. *)
+let atoms struc tuple =
+ let k = Array.length tuple in
+ let rec equalities = function
+ | [] -> []
+ | v :: vs -> (List.map (fun x -> Eq (`FO v,`FO x)) vs) @ (equalities vs) in
+ let atoms = FormulaOps.atoms (Structure.rel_signature struc) (varnames k) in
+ List.map (
+ fun atom -> if check struc tuple atom then atom else (Not atom)
+ ) (atoms @ (equalities (varnames k)))
+
+
+(* The [qr]-type in [length of tuple]-variables of [tuple] in [struc].
+ In [mem] we memorize the results for [qr] and [tuple], but *not* [struc]. *)
+let rec ntype_memo struc mem qr tuple =
+ try Hashtbl.find mem (qr, tuple) with Not_found ->
+ if qr = 0 then (
+ let res = Formula.flatten_sort (And (atoms struc tuple)) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ ) else (
+ let prevtp i e =
+ ntype_memo struc mem (qr-1) (Aux.array_replace tuple i e) in
+ let elems = Structure.elements struc in
+ let conj_prev_ex i =
+ And (List.map (fun e -> Ex ([var i], prevtp i e)) elems) in
+ let all_prev_disj i =
+ All ([var i], Or (List.map (prevtp i) elems)) in
+ let next_ntype i = And [conj_prev_ex i; all_prev_disj i] in
+ let nexttp = And (List.map next_ntype (Aux.range (Array.length tuple))) in
+ let res = Formula.flatten_sort (
+ And [ntype_memo struc mem (qr-1) tuple; nexttp]) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ )
+
+(* The [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
+let ntype struc qr tuple = ntype_memo struc (Hashtbl.create 7) qr tuple
+
+
+(* All types of rank [qr] of all [k]-tuples in [struc]. *)
+let ntypes struc ~qr ~k =
+ let elems = Structure.elements struc in
+ let tups = List.map Array.of_list (Aux.all_ntuples elems k) in
+ let mem = Hashtbl.create 63 in
+ Aux.unique_sorted (List.rev_map (ntype_memo struc mem qr) tups)
+
+
+(* - Guards and Guarded Types - *)
+
+(* Generate all guarded substitutions of [tuple] with the guards.
+ A subst-tuple is a substitution of [tuple] if it has the same length.
+ A subst-tuple is a guarded substitution of [tuple] if a permuted
+ sub-tuple of subst-tuple containig at least one element of
+ the original [tuple] is in some relation R in the structure [struc].
+ The guard for subst-tuple is then the atomic formula R(x_i1, ..., x_iK)
+ such that a = (subst-tuple_i1, ..., subst-tuple_iK) and R(a) holds.
+ For every subst-tuple as above we return the quintuple:
+ <new elems in subst-tuple, their indices as vars, subst-tuple, a, guard>.
+ We do not generate subst-tuples with repeated new elements. *)
+let guards struc tuple =
+ let in_tuple e = Aux.array_mem e tuple in
+ let tuple = Array.to_list tuple in
+ let all_incident = List.concat (List.map (Structure.incident struc) tuple) in
+ let subst_tuples a = (* all subst-tuples for which [a] witnesses a guard *)
+ let new_in =
+ Aux.unique_sorted (Aux.array_find_all (fun x -> not (in_tuple x)) a) in
+ let subst_tups = Aux.product (
+ List.map (fun e->if List.mem e new_in then new_in else e::new_in) tuple)in
+ let is_complete subst =
+ List.for_all (fun e -> List.mem e subst) (Array.to_list a) in
+ let complete_new_once subst = is_complete subst && List.for_all (
+ fun n -> List.length (List.filter (fun x -> x = n) subst) = 1
+ ) new_in in
+ List.rev_map Array.of_list (List.filter complete_new_once subst_tups) in
+ let make_guard rel a stp =
+ let new_els = List.filter (fun x -> not (in_tuple x)) (Array.to_list stp) in
+ let sindex e = Aux.array_argfind (fun x -> x = e) stp in
+ let guard = Rel (rel, Array.map (fun e -> fo_var (sindex e)) a) in
+ let ret_els = Aux.unique_sorted new_els in
+ (ret_els, List.map (fun e -> var (sindex e)) ret_els, stp, a, guard) in
+ let make_guard rel a = List.rev_map (make_guard rel a) (subst_tuples a) in
+ let make_guard (rel, tps) = List.concat (List.rev_map (make_guard rel) tps) in
+ let guards = List.filter (fun (e,_,_,_,_) -> e <> [])
+ (List.concat (List.rev_map make_guard all_incident)) in
+ Aux.unique_sorted guards
+
+(* Print a guard tuple, as returned above, to string. *)
+let guard_tuple_str (new_elems, vars, tup, a, atom) =
+ "< " ^ (String.concat ", " (List.map string_of_int new_elems)) ^ " | " ^
+ (String.concat ", " (List.map var_str vars)) ^ " | " ^
+ (String.concat ", " (List.map string_of_int (Array.to_list tup))) ^ " | " ^
+ (String.concat ", " (List.map string_of_int (Array.to_list a))) ^ " | " ^
+ (Formula.str atom) ^ " >"
+
+
+(* Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc].
+ In [mem] we memorize the results for [qr] and [tuple], but *not* [struc]. *)
+let rec guarded_type_memo struc mem qr tuple =
+ try Hashtbl.find mem (qr, tuple) with Not_found ->
+ if qr = 0 then (
+ let res = Formula.flatten_sort (And (atoms struc tuple)) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ ) else (
+ let prevtp tup = guarded_type_memo struc mem (qr-1) tup in
+ let conj_prev_ex vars guard subst_tuples =
+ let subst_tuples = List.filter (fun tup -> tup <> tuple) subst_tuples in
+ And (List.map (fun tup -> Ex (vars, prevtp tup)) subst_tuples) in
+ let all_prev_disj vars guard subst_tuples =
+ All (vars, Or ((Not guard) :: (List.map prevtp subst_tuples))) in
+ let next_gtype vs (g, ts) =
+ And [conj_prev_ex vs g ts; all_prev_disj vs g ts] in
+ let subst_tuples =
+ List.rev_map (fun (_,vs,t,_,_) -> (vs, t)) (guards struc tuple) in
+ let subst_tuples = Aux.unique_sorted (([], tuple) :: subst_tuples) in
+ let all_vars = varnames (Array.length tuple) in
+ let at_most_vs_tuples vs = List.concat (List.map (
+ fun vs -> Aux.assoc_all vs subst_tuples) (Aux.all_subsets vs)) in
+ let tuples_by_vs = List.map (fun vs -> (vs, at_most_vs_tuples vs))
+ (Aux.all_subsets (List.map var_of_string all_vars)) in
+ let all_guards =
+ FormulaOps.atoms (Structure.rel_signature struc) all_vars in
+ let guards_to_tups (vs, tuples) =
+ let has_vs a = List.for_all (fun v -> Aux.array_mem (to_fo v) a) vs in
+ let is_vs_guard a = has_vs a &&
+ Aux.array_existsi (fun _ v -> not (List.mem (v :> var) vs)) a in
+ let is_vs_guard = function Rel (_, a) -> is_vs_guard a | _ -> false in
+ let vs_guards = List.filter is_vs_guard all_guards in
+ let guarded_tups g = List.filter (fun tup-> check struc tup g) tuples in
+ (vs, List.map (fun g -> (g, guarded_tups g)) vs_guards) in
+ let tups_with_guards = List.map guards_to_tups tuples_by_vs in
+ let tups_with_guards =
+ List.filter (fun (vs,_) -> vs <> []) tups_with_guards in
+ let next_gtype_vs (vs, gtups) = And (List.map (next_gtype vs) gtups) in
+ let nextf = And (List.map next_gtype_vs tups_with_guards) in
+ let res = Formula.flatten_sort (
+ And [guarded_type_memo struc mem (qr-1) tuple; nextf]) in
+ Hashtbl.add mem (qr, tuple) res;
+ res
+ )
+
+(* Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
+let guarded_type struc qr tuple =
+ guarded_type_memo struc (Hashtbl.create 7) qr tuple
+
+
+(* All guarded types of rank [qr] of guarded [k]-tuples in [struc]. *)
+let guarded_types struc ~qr ~k =
+ let tups = List.map (Structure.incident struc) (Structure.elements struc) in
+ let tups = List.concat (List.map snd (List.concat tups)) in
+ let tups = List.filter (fun tup -> Array.length tup >= k) tups in
+ let k_subtuples tup =
+ List.map Array.of_list (Aux.all_ntuples (Array.to_list tup) k) in
+ let ktups = List.rev_map k_subtuples (Aux.unique_sorted tups) in
+ let ktups = Aux.unique_sorted (List.concat ktups) in
+ let mem = Hashtbl.create 63 in
+ Aux.unique_sorted (List.rev_map (guarded_type_memo struc mem qr) ktups)
+
+
+
+(* - Distinguishing Structure Sets - *)
+
+
+(* Helper function: remove atoms from a formula if [cond] is still satisfied.
+ Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
+let rec greedy_remove ?(pos=false) cond phi =
+ let rec greedy_remove_list constructor acc = function
+ | [] -> acc
+ | x :: xs ->
+ let rest = acc @ xs in
+ if cond (constructor rest) then greedy_remove_list constructor acc xs else
+ let minx = greedy_remove (fun y -> cond (constructor (y :: rest))) x in
+ greedy_remove_list constructor (minx::acc) xs in
+ match phi with
+ | And fl -> And (greedy_remove_list (fun l -> And l) [] (List.rev fl))
+ | Or fl -> if pos then Or fl else
+ Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
+ | Not f -> if pos then Not f else
+ Not (greedy_remove (fun x -> cond (Not x)) f)
+ | Ex (vs, f) -> Ex (vs, greedy_remove (fun x -> cond (Ex (vs, x))) f)
+ | All (vs, f) -> All (vs, greedy_remove (fun x -> cond (All (vs, x))) f)
+ | phi -> phi
+
+(* Order on types that we use to select the minimal one. *)
+let compare_types tp1 tp2 =
+ let tp_lits = function And fl -> List.filter Formula.is_literal fl | _-> [] in
+ let c = Formula.compare (And (tp_lits tp1)) (And (tp_lits tp2)) in
+ if c <> 0 then c else Formula.compare tp1 tp2
+
+let compare_types = ref compare_types
+
+(* Find the minimal [logic]-type of [struc] not included in [neg_types]
+ and with at most [qr] quantifiers and [k] variables. *)
+let min_type_omitting ?(logic = GuardedFO) ~qr ~k neg_types struc =
+ let pos_types = match logic with
+ | GuardedFO -> guarded_types struc ~qr ~k
+ | FO -> ntypes struc ~qr ~k in
+ let ok_types = List.filter (fun f -> not (List.mem f neg_types)) pos_types in
+ let ok_types = List.sort !compare_types ok_types in
+ if ok_types = [] then None else Some (List.hd ok_types)
+
+(* Find a [logic]-formula with at most [qr] quantifiers and [k] variables
+ which holds on all [pos_strucs] and on no [neg_strucs]. *)
+let distinguish_upto ?(logic = GuardedFO) ~qr ~k pos_strucs neg_strucs =
+ let types s = match logic with
+ | GuardedFO -> guarded_types s ~qr ~k
+ | FO -> ntypes s ~qr ~k in
+ let neg_tps = Aux.unique_sorted (Aux.concat_map types neg_strucs) in
+ let fails_on_negs f = not (List.exists (fun s-> check s [||] f) neg_strucs) in
+ let extend_by_pos acc struc =
+ if check struc [||] (Or acc) then acc else
+ match min_type_omitting ~logic ~qr ~k neg_tps struc with
+ | None -> raise Not_found
+ | Some f -> (greedy_remove ~pos:true fails_on_negs f) :: acc in
+ let pos_formulas =
+ try List.fold_left extend_by_pos [] pos_strucs with Not_found -> [] in
+ let pos_formulas = Aux.unique_sorted ~cmp:!compare_types pos_formulas in
+ if pos_formulas = [] then None else
+ let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
+ let is_ok f = fails_on_negs f && succ_pos [f] in
+ let minimized = greedy_remove is_ok (Or pos_formulas) in
+ let fv = FormulaSubst.free_vars minimized in
+ Some (FormulaOps.rename_quant_avoiding fv minimized)
+
+
+(* Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
+ Leaves free variables (existential) if [skip_outer_exists] is set. *)
+let distinguish ?(how=GuardedFO) ?(skip_outer_exists=false) strucs1 strucs2 =
+ if !debug_level > 0 then
+ Printf.printf "distinguishing:\n\n%s\n\n and\n\n %s\n%!"
+ (String.concat "\n" (List.map Structure.str strucs1))
+ (String.concat "\n" (List.map Structure.str strucs2));
+ let rec diff qr k =
+ if qr > k then diff 0 (k+1) else (
+ if !debug_level > 0 then Printf.printf "distinguish qr %i k %i\n%!" qr k;
+ match distinguish_upto ~logic:how ~qr ~k strucs1 strucs2 with
+ | Some f ->
+ if skip_outer_exists then Some f else
+ Some (Ex (FormulaSubst.free_vars f, f))
+ | None -> diff (qr+1) k
+ ) in
+ diff 0 1
Copied: trunk/Toss/Learn/Distinguish.mli (from rev 1639, trunk/Toss/Solver/Distinguish.mli)
===================================================================
--- trunk/Toss/Learn/Distinguish.mli (rev 0)
+++ trunk/Toss/Learn/Distinguish.mli 2012-01-16 14:23:37 UTC (rev 1640)
@@ -0,0 +1,71 @@
+(** Distinguish sets of structures by formulas. *)
+
+type logic = FO | GuardedFO
+
+
+(** {2 Atoms and FO Types} *)
+
+(** The list of literals which hold for a tuple on a structure,
+ i.e. the atomic type of this tuple. *)
+val atoms: Structure.structure -> int array -> Formula.formula list
+
+(** The [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
+val ntype: Structure.structure -> int -> int array -> Formula.formula
+
+(** All types of rank [qr] of all [k]-tuples in [struc]. *)
+val ntypes: Structure.structure -> qr: int -> k:int -> Formula.formula list
+
+
+(** {2 Guards and Guarded Types} *)
+
+(** Generate all guarded substitutions of [tuple] with the guards.
+ A subst-tuple is a substitution of [tuple] if it has the same length.
+ A subst-tuple is a guarded substitution of [tuple] if a permuted
+ sub-tuple a of subst-tuple containig at least one element of
+ the original [tuple] is in some relation R in the structure [struc].
+ The guard for subst-tuple is then the atomic formula R(x_i1, ..., x_iK)
+ such that a = (subst-tuple_i1, ..., subst-tuple_iK) and R(a) holds.
+ For every subst-tuple as above we return the quintuple:
+ <new elems in subst-tuple, their indices as vars, subst-tuple, a, guard>.
+ We do not generate subst-tuples with repeated new elements. *)
+val guards: Structure.structure -> int array ->
+ (int list * Formula.var list * int array * int array * Formula.formula) list
+
+(** Print a guard tuple, as returned above, to string. *)
+val guard_tuple_str:
+ (int list * Formula.var list * int array * int array * Formula.formula) ->
+ string
+
+(** Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
+val guarded_type: Structure.structure -> int -> int array -> Formula.formula
+
+(** All guarded types of rank [qr] of guarded [k]-tuples in [struc]. *)
+val guarded_types: Structure.structure -> qr: int -> k:int ->
+ Formula.formula list
+
+
+(** {2 Distinguishing Structure Sets} *)
+
+(** Order on types that we use to select the minimal ones. *)
+val compare_types : (Formula.formula -> Formula.formula -> int) ref
+
+(** Find the minimal [logic]-type of [struc] not included in [neg_types]
+ and with at most [qr] quantifiers and [k] variables. *)
+val min_type_omitting: ?logic: logic -> qr: int -> k: int ->
+ Formula.formula list -> Structure.structure -> Formula.formula option
+
+(** Find a [logic]-formula with at most [qr] quantifiers and [k] variables
+ which holds on all [pos_strucs] and on no [neg_strucs].
+ Leaves free variables which are implicitly quantified existentially. *)
+val distinguish_upto: ?logic: logic -> qr: int -> k: int ->
+ Structure.structure list -> Structure.structure list -> Formula.formula option
+
+(** Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
+ Leaves free variables (existential) if [skip_outer_exists] is set. *)
+val distinguish: ?how: logic -> ?skip_outer_exists: bool ->
+ Structure.structure list -> Structure.structure list -> Formula.formula option
+
+
+(** {2 Debugging} *)
+
+val set_debug_level: int -> unit
Copied: trunk/Toss/Learn/DistinguishTest.ml (from rev 1639, trunk/Toss/Solver/DistinguishTest.ml)
===================================================================
--- trunk/Toss/Learn/DistinguishTest.ml (rev 0)
+++ trunk/Toss/Learn/DistinguishTest.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -0,0 +1,342 @@
+open OUnit
+open Distinguish
+
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+let struc_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
+let formula_eq ?(flatten_sort=true) phi1 phi2 =
+ if flatten_sort then
+ assert_equal ~printer:(fun x -> Formula.sprint x)
+ (Formula.flatten_sort (formula_of_string phi1))
+ (Formula.flatten_sort phi2)
+ else
+ assert_equal ~printer:(fun x -> Formula.sprint x)
+ (formula_of_string phi1) phi2
+
+let guards_eq res guards =
+ let guards_str gl = String.concat "\n" (List.map guard_tuple_str gl) in
+ assert_equal ~printer:(fun s -> s) res (guards_str guards)
+
+let formula_list_eq ?(flatten_sort=true) l1 l2 =
+ if List.length l1 = List.length l2 then
+ List.iter2 (formula_eq ~flatten_sort) l1 l2
+ else
+ let lstr l = "Length " ^ (string_of_int (List.length l)) ^
+ " [ " ^ (String.concat " | " l) ^ " ]" in
+ assert_equal ~printer:lstr l1 (List.map Formula.str l2)
+
+let formula_option_eq ?(flatten_sort=true) fopt1 fopt2 =
+ let fopt_str = function None -> "None" | Some f -> Formula.str f in
+ if fopt1 = "None" then
+ assert_equal ~printer:fopt_str None fopt2
+ else match fopt2 with
+ | None -> assert_equal ~printer:(fun x -> x) fopt1 "None"
+ | Some f -> formula_eq ~flatten_sort fopt1 f
+
+
+
+let tests = "Distinguish" >::: [
+ "atoms" >::
+ (fun () ->
+ let struc = struc_of_string "[ | R { (1, 2); (2, 3) } | ]" in
+ formula_eq
+ ("(not R(x0, x0) and R(x0, x1) and not R(x1, x0) " ^
+ "and not R(x1, x1) and not x0=x1)")
+ (Formula.And (atoms struc [|2; 3|]));
+ );
+
+ "ntype" >::
+ ( fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_eq ("R(x0, x1) and not R(x0, x0) and not x0=x1 and " ^
+ "not R(x1, x0) and not R(x1, x1)")
+ (Distinguish.ntype structure 0 [|1; 2|]);
+ formula_eq ("(R(x0,x1) and not R(x0,x0) and x0!=x1 and not R(x1,x0) and "^
+ "not R(x1, x1) and ex x0 (R(x0, x1) and not R(x0, x0) " ^
+ "and not x0 = x1 and not R(x1, x0) and not R(x1, x1)) " ^
+ "and ex x0 (x0 = x1 and not R(x0, x0) and not R(x0, x1) " ^
+ "and not R(x1,x0) and not R(x1,x1)) and ex x1(R(x0,x1) " ^
+ "and not R(x0, x0) and not x0 = x1 and not R(x1, x0) " ^
+ "and not R(x1,x1)) and ex x1 (x0=x1 and not R(x0, x0) " ^
+ "and not R(x0, x1) and not R(x1, x0) and not R(x1, x1))" ^
+ " and all x0 ((R(x0,x1) and not R(x0,x0) and x0!=x1 and " ^
+ "not R(x1, x0) and not R(x1, x1)) or (x0 = x1 and " ^
+ "not R(x0, x0) and not R(x0, x1) and not R(x1, x0) and " ^
+ "not R(x1,x1))) and all x1 ((R(x0, x1) and not R(x0, x0)" ^
+ " and not x0 = x1 and not R(x1, x0) and not R(x1, x1)) " ^
+ "or (x0 = x1 and not R(x0, x0) and not R(x0, x1) " ^
+ "and not R(x1, x0) and not R(x1, x1))))")
+ (Distinguish.ntype structure 1 [|1;2|]);
+ );
+
+ "ntypes" >::
+ (fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ formula_list_eq
+ [("R(x0, x1) and not R(x0, x0) and not x0 = x1 and " ^
+ "not R(x1, x0) and not R(x1, x1)");
+ ("R(x1, x0) and not R(x0, x0) and not R(x0, x1) and " ^
+ "not x0 = x1 and not R(x1, x1)");
+ ("x0 = x1 and not R(x0, x0) and not R(x0, x1) and " ^
+ "not R(x1, x0) and not R(x1, x1)");
+ ("not R(x0, x0) and not R(x0, x1) and not x0 = x1 and " ^
+ "not R(x1, x0) and not R(x1, x1)")]
+ (Distinguish.ntypes structure ~qr:0 ~k:2);
+ );
+
+ "guards" >::
+ (fun () ->
+ let struc = struc_of_string "[ | R { (1, 2); (2, 3) } | ]" in
+ guards_eq "< 3 | x0 | 3, 2 | 2, 3 | R(x1, x0) >" (guards struc [|1; 2|]);
+ guards_eq ("< 2 | x0 | 2, 1 | 1, 2 | R(x1, x0) >\n" ^
+ "< 2 | x1 | 1, 2 | 1, 2 | R(x0, x1) >")
+ (guards struc [|1; 1|]);
+ guards_eq ("< 1 | x0 | 1, 2 | 1, 2 | R(x0, x1) >\n" ^
+ "< 1 | x1 | 2, 1 | 1, 2 | R(x1, x0) >\n" ^
+ "< 3 | x0 | 3, 2 | 2, 3 | R(x1, x0) >\n" ^
+ "< 3 | x1 | 2, 3 | 2, 3 | R(x0, x1) >")
+ (guards struc [|2; 2|]);
+ guards_eq ("< 2 | x0 | 2, 3 | 2, 3 | R(x0, x1) >\n" ^
+ "< 2 | x1 | 1, 2 | 1, 2 | R(x0, x1) >")
+ (guards struc [|1; 3|]);
+ guards_eq ("< 2 | x0 | 2, 1 | 1, 2 | R(x1, x0) >\n" ^
+ "< 2 | x1 | 3, 2 | 2, 3 | R(x1, x0) >")
+ (guards struc [|3; 1|]);
+ guards_eq "" (guards struc [|1|]);
+ guards_eq "" (guards struc [|2|]);
+ guards_eq "" (guards struc [|3|]);
+ guards_eq "" (guards struc [|1; 2; 3|]);
+
+ let struc = struc_of_string "[ | R { (1, 2); (2, 4) } | ]" in
+ guards_eq ("< 4 | x0 | 4, 2, 3 | 2, 4 | R(x1, x0) >\n" ^
+ "< 4 | x2 | 1, 2, 4 | 2, 4 | R(x1, x2) >")
+ (guards struc [|1; 2; 3|]);
+
+ let struc = struc_of_string "[ | R { (1, 2, 2) } | ]" in
+ guards_eq ("< 2 | x0 | 2, 1 | 1, 2, 2 | R(x1, x0, x0) >\n" ^
+ "< 2 | x1 | 1, 2 | 1, 2, 2 | R(x0, x1, x1) >")
+ (guards struc [|1; 1|]);
+
+ let struc = struc_of_string "[ | R { (1, 2, 3) } | ]" in
+ guards_eq "" (guards struc [|1; 1|]);
+ guards_eq "" (guards struc [|1; 2; 3|]);
+ guards_eq ("< 3 | x0 | 3, 1, 2 | 1, 2, 3 | R(x1, x2, x0) >\n" ^
+ "< 3 | x1 | 1, 3, 2 | 1, 2, 3 | R(x0, x2, x1) >")
+ (guards struc [|1; 1; 2|]);
+ guards_eq ("< 2 | x0 | 2, 1, 3 | 1, 2, 3 | R(x1, x0, x2) >\n" ^
+ "< 2 | x1 | 1, 2, 3 | 1, 2, 3 | R(x0, x1, x2) >")
+ (guards struc [|1; 1; 3|]);
+ guards_eq ("< 1 | x0 | 1, 2, 3 | 1, 2, 3 | R(x0, x1, x2) >\n" ^
+ "< 1 | x2 | 3, 2, 1 | 1, 2, 3 | R(x2, x1, x0) >")
+ (guards struc [|3; 2; 3|]);
+ guards_eq ("< 1, 3 | x0, x1 | 1, 3, 2 | 1, 2, 3 | R(x0, x2, x1) >\n" ^
+ "< 1, 3 | x0, x2 | 1, 2, 3 | 1, 2, 3 | R(x0, x1, x2) >\n" ^
+ "< 1, 3 | x1, x0 | 3, 1, 2 | 1, 2, 3 | R(x1, x2, x0) >\n" ^
+ "< 1, 3 | x1, x2 | 2, 1, 3 | 1, 2, 3 | R(x1, x0, x2) >\n" ^
+ "< 1, 3 | x2, x0 | 3, 2, 1 | 1, 2, 3 | R(x2, x1, x0) >\n" ^
+ "< 1, 3 | x2, x1 | 2, 3, 1 | 1, 2, 3 | R(x2, x0, x1) >")
+ (guards struc [|2; 2; 2|]);
+
+ let struc = struc_of_string "[ | | ] \"
+ ... ...
+ ... P..
+ ...
+ P..
+ ... ...
+ ...P ...
+\"" in
+ guards_eq ("< 3 | x0 | 3, 2 | 2, 3 | R(x1, x0) >\n" ^
+ "< 4 | x1 | 1, 4 | 1, 4 | C(x0, x1) >\n" ^
+ "< 5 | x0 | 5, 2 | 2, 5 | C(x1, x0) >")
+ (guards struc [|1; 2|]);
+ );
+
+ "guarded_type" >::
+ (fun () ->
+ let struc = (struc_of_string "[ | R { (1, 2) } | ]") in
+ let lits = "R(x0,x1) and not R(x0,x0) and not x0=x1 and not R(x1,x0) " ^
+ "and not R(x1,x1)" in
+ formula_eq lits (guarded_type struc 0 [|1; 2|]);
+ formula_eq (lits ^ " and all x0 not R(x1, x0) and all x1 not R(x1, x0) " ^
+ "and all x0 (not R(x0, x1) or (not R(x0, x0) and " ^
+ "not x0 = x1 and not R(x1, x0) and not R(x1, x1))) and " ^
+ "all x1 (not R(x0, x1) or (not R(x0, x0) and not x0 = x1" ^
+ " and not R(x1, x0) and not R(x1, x1)))")
+ (guarded_type struc 1 [|1; 2|]);
+
+ let struc = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ formula_eq lits (guarded_type struc 0 [|1; 2|]);
+ formula_eq (lits ^ " and all x1 not R(x1, x0) and " ^
+ "ex x0 (R(x1, x0) and not R(x0, x0) and not R(x0, x1) and" ^
+ " not x0 = x1 and not R(x1, x1)) and " ^
+ "all x0 (not R(x0, x1) or (not R(x0, x0) and not x0 = x1" ^
+ " and not R(x1, x0) and not R(x1, x1))) and " ^
+ "all x0 (not R(x1, x0) or (not R(x0, x0) and not R(x0, x1)"^
+ " and not x0 = x1 and not R(x1, x1))) and " ^
+ "all x1 (not R(x0, x1) or (not R(x0, x0) and not x0 = x1" ^
+ " and not R(x1, x0) and not R(x1, x1)))")
+ (guarded_type struc 1 [|1; 2|]);
+ );
+
+ "guarded_types" >::
+ (fun () ->
+ let struc = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_list_eq [
+ ("(R(x0, x1) and not R(x0, x0) and not x0 = x1 and " ^
+ " not R(x1, x0) and not R(x1, x1))");
+ ("(R(x1, x0) and not R(x0, x0) and not R(x0, x1) and " ^
+ " not x0 = x1 and not R(x1, x1))");
+ ("(x0 = x1 and not R(x0, x0) and not R(x0, x1) and " ^
+ " not R(x1, x0) and not R(x1, x1))") ]
+ (Distinguish.guarded_types struc ~qr:0 ~k:2);
+ assert_equal ~printer:string_of_int 4
+ (List.length (Distinguish.guarded_types struc ~qr:1 ~k:2));
+
+ let struc = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ formula_list_eq [
+ ("(R(x0, x1) and not R(x0, x0) and not x0 = x1 and " ^
+ " not R(x1, x0) and not R(x1, x1))");
+ ("(R(x1, x0) and not R(x0, x0) and not R(x0, x1) and " ^
+ " not x0 = x1 and not R(x1, x1))");
+ ("(x0 = x1 and not R(x0, x0) and not R(x0, x1) and " ^
+ " not R(x1, x0) and not R(x1, x1))") ]
+ (Distinguish.guarded_types struc ~qr:0 ~k:2);
+ assert_equal ~printer:string_of_int 7
+ (List.length (Distinguish.guarded_types struc ~qr:1 ~k:2));
+ );
+
+ "distinguish_upto" >::
+ (fun () ->
+ let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_option_eq "None"
+ (Distinguish.distinguish_upto ~qr:2 ~k:1 [struc1] [struc2]);
+ formula_option_eq "None" (* we use guarded types - so None here *)
+ (Distinguish.distinguish_upto ~qr:0 ~k:2 [struc1] [struc2]);
+ formula_option_eq "not R(x0, x1) and not x0 = x1 and not R(x1, x0)"
+ (Distinguish.distinguish_upto ~logic:FO ~qr:0 ~k:2 [struc1] [struc2]);
+ formula_option_eq "None" (* we use guarded types - so None here *)
+ (Distinguish.distinguish_upto ~qr:0 ~k:3 [struc1] [struc2]);
+ formula_option_eq "R(x0, x1) and ex x2 R(x2, x0)"
+ (Distinguish.distinguish_upto ~qr:1 ~k:2 [struc1] [struc2]);
+
+ let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
+ let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
+ formula_option_eq "P(x0)"
+ (Distinguish.distinguish_upto ~qr:0 ~k:1 [struc1] [struc2]);
+ );
+
+ "distinguish" >::
+ (fun () ->
+ let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_option_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x2, x0))"
+ (Distinguish.distinguish [struc1] [struc2]);
+
+ let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
+ let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
+ formula_option_eq "ex x0 P(x0)"
+ (Distinguish.distinguish [struc1] [struc2]);
+
+ let struc1 = struc_of_string "[ | | ] \"
+ ...
+ ...
+ ...
+ P..
+\"" in
+ let struc2 = struc_of_string "[ | | ] \"
+ ...
+ P..
+ ...
+ ...
+\"" in
+ formula_option_eq "ex x0, x1 (P(x0) and C(x0, x1))"
+ (Distinguish.distinguish [struc1] [struc2]);
+ );
+]
+
+let bigtests = "DistinguishBig" >::: [
+ "semi-tic-tac-toe" >::
+ (fun () ->
+ let strucN1 = struc_of_string "[ | | ] \"
+ ... ...
+ ... P..
+ ...
+ P..
+ ... ...
+ ...P ...
+\"" in
+ let strucN2 = struc_of_string "[ | | ] \"
+ ... ...
+ ...P ...
+ ...
+ ...
+ ... ...
+ ...P ...
+\"" in
+ let strucN3 = struc_of_string "[ | | ] \"
+ ... ...
+ ...P ...
+ ...
+ P..
+ ... ...
+ ... ...
+\"" in
+ let strucP = struc_of_string "[ | | ] \"
+ ... ...
+ ...P ...
+ ...
+ P..
+ ... ...
+ ...P ...
+\"" in formula_option_eq
+ "P(x0) and P(x1) and C(x0, x1) and ex x2 (P(x2) and C(x2, x0))"
+ (Distinguish.distinguish ~skip_outer_exists:true
+ [strucP] [strucN1; strucN2; strucN3]);
+ );
+
+ "breakthrough" >::
+ (fun () ->
+ let struc1 = struc_of_string "[ | | ] \"
+ ... ... ... ...
+ ... W.. ...B ...
+ ... ... ... ...
+ ... ... ... B..
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+ ... ... ... ...
+ ...W ... ... ...
+\"" in
+ let struc2 = struc_of_string "[ | | ] \"
+ ... ... ... ...
+ ... ... ...B ...
+ ... ... ... ...
+ ... ...W ... B..
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+ ... ... ... ...
+ ...W ... ... ...
+\"" in (* Distinguish.set_debug_level 1; *)
+ formula_option_eq "W(x1) and all x0 not C(x1, x0)"
+ (Distinguish.distinguish ~skip_outer_exists:true [struc1] [struc2]);
+ );
+]
Copied: trunk/Toss/Learn/LearnGame.ml (from rev 1639, trunk/Toss/Server/LearnGame.ml)
===================================================================
--- trunk/Toss/Learn/LearnGame.ml (rev 0)
+++ trunk/Toss/Learn/LearnGame.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -0,0 +1,119 @@
+(* Learning games from examples. *)
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
+let rec evens ?(acc=[0]) k =
+ let last = (List.hd (List.rev acc)) in
+ if (List.hd (List.rev acc))> k then
+ (List.rev (List.tl ( List.rev acc)))
+ else
+ evens ~acc:(acc@[(last+2)]) k
+let odds k =
+ evens ~acc:[1] k
+
+
+let winFormula winningStates notWinningStates =
+ if !debug_level > 0 then
+ print_endline (
+ "Searching WIN:\n" ^
+ (String.concat "\n" (List.map Structure.str winningStates)) ^ "\nNOT\n"^
+ (String.concat "\n" (List.map Structure.str notWinningStates)));
+ FormulaOps.tnf_fv
+ (Aux.unsome (Distinguish.distinguish winningStates notWinningStates))
+
+let cleanStructure struc =
+ let funs = ref [] in
+ let append_fun f _ = funs := f :: !funs in
+ Structure.StringMap.iter append_fun (Structure.functions struc);
+ let struc = StructureParser.parse_structure Lexer.lex (Lexing.from_string (Structure.str struc)) in
+ Structure.replace_names (List.fold_left
+ (fun x y ->
+ Structure.clear_fun x y)
+ struc !funs) Structure.StringMap.empty
+ Structure.IntMap.empty
+
+
+let move struct1 struct2 =
+ let changed = (Aux.unique_sorted
+ ( List.map fst
+ (Structure.diff_elems struct1 struct2 )) ) in
+ let strucBefore =
+ fst (Structure.del_elems struct1
+ (Aux.list_diff
+ (Aux.unique_sorted (Structure.elements struct1))
+ changed )) in
+ let strucAfter =
+ fst (Structure.del_elems struct2
+ (Aux.list_diff
+ (Aux.unique_sorted (Structure.elements struct2))
+ changed )) in
+ ((cleanStructure strucBefore) , (cleanStructure strucAfter))
+
+let movesi i partylist =
+ Aux.unique_sorted
+ ~cmp: (fun (s1,s2) (t1,t2) ->
+ let c = ( Structure.compare s1 t1) in
+ if c != 0 then c
+ else (Structure.compare s2 t2))
+ (List.fold_left
+ (fun acc party ->
+ List.append acc
+ (List.fold_left
+ (fun prev i ->
+ if (i < ((List.length party)-1)) then
+ let m = move (List.nth party i) (List.nth party (i+1)) in
+ (List.append prev [m])
+ else
+ (List.append prev []))
+ [] (evens ~acc:[i] (List.length party)) ) )
+ [] partylist)
+
+let learnFromParties ~win0 ~win1 ~tie ~wrong =
+ let win0f = winFormula
+ (List.map (fun x -> List.hd (List.rev x)) win0)
+ (List.flatten ((List.map (fun x-> List.tl (List.rev x))
+ win0) @ win1)) in
+ let win1f = winFormula
+ (List.map (fun x -> List.hd (List.rev x)) win1)
+ (List.flatten ((List.map (fun x-> List.tl (List.rev x))
+ win1) @ win0)) in
+
+ let moves0 = movesi 0 (win0 @ win1) in
+ let moves1 = movesi 1 (win0 @ win1) in
+
+ "PLAYERS 1, 2\n"^
+ "REL Win1() = "^ (Formula.sprint win0f) ^"\n"^
+ "REL Win2() = "^ (Formula.sprint win1f) ^"\n"^
+ "RULE Mv1: " ^
+ (List.fold_left
+ (fun old x->
+ old ^ "\n"^
+ (Structure.str (fst x))^" -> "^(Structure.str
+ (snd x)) ^
+ "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
+ (fst x)) )) ^ " " ^
+ "pre not Win2()" )
+ "" moves0) ^"\n"^
+ "RULE Mv2: " ^
+ (List.fold_left
+ (fun old x->
+ old^"\n"^
+ (Structure.str (fst x))^" -> "^(Structure.str
+ (snd x)) ^
+ "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
+ (fst x)) )) ^ " " ^
+ "pre not Win1()" )
+ "" moves1) ^"\n"^
+ "LOC 0 {
+ PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
+ MOVES [Mv1 -> 1]}
+ PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
+}
+LOC 1{
+ PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
+ PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
+ MOVES [Mv2 -> 0] }
+}" ^"\n" ^
+ "MODEL "^(Structure.str (List.hd (List.hd win0)))
+
Copied: trunk/Toss/Learn/LearnGame.mli (from rev 1639, trunk/Toss/Server/LearnGame.mli)
===================================================================
--- trunk/Toss/Learn/LearnGame.mli (rev 0)
+++ trunk/Toss/Learn/LearnGame.mli 2012-01-16 14:23:37 UTC (rev 1640)
@@ -0,0 +1,21 @@
+(** Module for learning games from examples. *)
+
+val move: Structure.structure -> Structure.structure ->
+ Structure.structure * Structure.structure
+
+(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
+ game [source]: [wins0] which are now supposed to be won by Player 0,
+ [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
+ are not correct plays of the newly constructed game. The plays are given
+ as lists of ids to be retrieved from DB, result is a toss game string. *)
+val learnFromParties:
+ win0: Structure.structure list list ->
+ win1: Structure.structure list list ->
+ tie: Structure.structure list list ->
+ wrong: Structure.structure list list -> string
+
+
+(** {2 Debugging} *)
+
+(* At higher debug levels we prints out diagnostic information. *)
+val set_debug_level: int -> unit
Copied: trunk/Toss/Learn/LearnGameTest.ml (from rev 1639, trunk/Toss/Server/LearnGameTest.ml)
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml (rev 0)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -0,0 +1,340 @@
+open OUnit
+
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+let struc_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
+let tests = "LearnGame" >::: [
+ "simple test game" >::
+ (fun () ->
+ let partylist0 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+. .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+. P
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+Q P
+\"" ;]] in
+ let partylist1 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+. .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+P .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+P Q
+\"" ;]] in
+ let res_game =
+"PLAYERS 1, 2
+REL Win1() = ex x1 (Q(x1) and ex x0 R(x1, x0))
+REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
+RULE Mv1:
+[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
+emb R,Q,P pre not Win2()
+RULE Mv2:
+[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P:1 {}; Q (1); R:2 {} | ]
+emb R,Q,P pre not Win1()
+LOC 0 {
+ PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
+ MOVES [Mv1 -> 1]}
+ PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
+}
+LOC 1{
+ PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
+ PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
+ MOVES [Mv2 -> 0] }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] R R \"
+
+ . .
+\"" in
+ assert_equal ~printer:(fun x -> x) res_game
+ ((LearnGame.learnFromParties ~win0:partylist0 ~win1:partylist1
+ ~tie:[] ~wrong:[]));
+ );
+]
+
+
+let bigtests = "LearnGame" >::: [
+ "tic-tac-toe" >::
+ (fun () ->
+ Distinguish.set_debug_level 0; (* set to 1 to get some info printed out *)
+ let partylist0 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+P . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q .
+. . .
+P . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q .
+. . .
+P P .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q Q
+. . .
+P P .
+. . .
+. . .
+. . .
+\"";
+ ]; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+Q . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+Q P .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+Q P .
+. . .
+Q . .
+. . .
+\"";]
+ ] in
+let partylist1 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . P
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q P
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q P
+. . .
+. Q Q
+. . .
+. . .
+P P P
+\"";
+ ]; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P P
+\"";
+ ]
+ ; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+P P P
+\"";]
+ ; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. P .
+. . .
+. P .
+. . .
+. P .
+\"";]
+ ; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . P
+. . .
+. P .
+. . .
+P . .
+\"";]
+ ] in
+assert_equal ~printer:(fun x -> x) ""
+ ((LearnGame.learnFromParties ~win0:partylist0 ~win1:partylist1
+ ~tie:[] ~wrong:[]));
+ );
+
+]
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Makefile 2012-01-16 14:23:37 UTC (rev 1640)
@@ -46,8 +46,9 @@
SolverINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim
ArenaINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver
PlayINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
+LearnINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
GGPINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play
-ServerINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP
+ServerINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn
.INC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Server
%.native: %.ml caml_extensions/pa_let_try.cmo
@@ -125,6 +126,14 @@
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
./TossServer -fulltest GGP -v
+# Learn tests
+LearnTests: TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
+ ./TossServer -fulltest Learn
+LearnTestsVerbose: TossServer
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
+ ./TossServer -fulltest Learn -v
+
# Server tests
ServerTests: TossServer
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
@@ -153,4 +162,5 @@
clean:
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
Deleted: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Server/LearnGame.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -1,149 +0,0 @@
-(* Learning games from examples. *)
-
-let debug_level = ref 0
-let set_debug_level i = (debug_level := i)
-
-let struc_of_string s =
- StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-
-
-
-let rec evens ?(acc=[0]) k =
- let last = (List.hd (List.rev acc)) in
- if (List.hd (List.rev acc))> k then
- (List.rev (List.tl ( List.rev acc)))
- else
- evens ~acc:(acc@[(last+2)]) k
-let odds k =
- evens ~acc:[1] k
-
-
-let winFormula winningStates notWinningStates =
- if !debug_level > 0 then
- print_endline (
- "Searching WIN:\n" ^
- (String.concat "\n" (List.map Structure.str winningStates)) ^ "\nNOT\n"^
- (String.concat "\n" (List.map Structure.str notWinningStates)));
- FormulaOps.tnf_fv
- (Aux.unsome (Distinguish.distinguish winningStates notWinningStates))
-
-let cleanStructure struc =
- let funs = ref [] in
- let append_fun f _ = funs := f :: !funs in
- Structure.StringMap.iter append_fun (Structure.functions struc);
- let struc = StructureParser.parse_structure Lexer.lex (Lexing.from_string (Structure.str struc)) in
- Structure.replace_names (List.fold_left
- (fun x y ->
- Structure.clear_fun x y)
- struc !funs) Structure.StringMap.empty
- Structure.IntMap.empty
-
-
-let move struct1 struct2 =
- let changed = (Aux.unique_sorted
- ( List.map fst
- (Structure.diff_elems struct1 struct2 )) ) in
- let strucBefore =
- fst (Structure.del_elems struct1
- (Aux.list_diff
- (Aux.unique_sorted (Structure.elements struct1))
- changed )) in
- let strucAfter =
- fst (Structure.del_elems struct2
- (Aux.list_diff
- (Aux.unique_sorted (Structure.elements struct2))
- changed )) in
- ((cleanStructure strucBefore) , (cleanStructure strucAfter))
-
-let movesi i partylist =
- Aux.unique_sorted
- ~cmp: (fun (s1,s2) (t1,t2) ->
- let c = ( Structure.compare s1 t1) in
- if c != 0 then c
- else (Structure.compare s2 t2))
- (List.fold_left
- (fun acc party ->
- List.append acc
- (List.fold_left
- (fun prev i ->
- if (i < ((List.length party)-1)) then
- let m = move (List.nth party i) (List.nth party (i+1)) in
- (List.append prev [m])
- else
- (List.append prev []))
- [] (evens ~acc:[i] (List.length party)) ) )
- [] partylist)
-
-let learnFromParties partylistWin0 partylistWin1 =
- let win0 = winFormula
- (List.map (fun x -> List.hd (List.rev x)) partylistWin0)
- (List.flatten ((List.map (fun x-> List.tl (List.rev x))
- partylistWin0)@partylistWin1)) in
- let win1 = winFormula
- (List.map (fun x -> List.hd (List.rev x)) partylistWin1)
- (List.flatten ((List.map (fun x-> List.tl (List.rev x))
- partylistWin1)@partylistWin0)) in
-
- let moves0 = movesi 0 (partylistWin0 @ partylistWin1) in
- let moves1 = movesi 1 (partylistWin0 @ partylistWin1) in
-
- "PLAYERS 1, 2\n"^
- "REL Win1() = "^ (Formula.sprint win0) ^"\n"^
- "REL Win2() = "^ (Formula.sprint win1) ^"\n"^
- "RULE Mv1: " ^
- (List.fold_left
- (fun old x->
- old^"\n"^
- (Structure.str (fst x))^" -> "^(Structure.str
- (snd x)) ^
- "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
- (fst x)) )) ^ " " ^
- "pre not Win2()" )
- "" moves0) ^"\n"^
- "RULE Mv2: " ^
- (List.fold_left
- (fun old x->
- old^"\n"^
- (Structure.str (fst x))^" -> "^(Structure.str
- (snd x)) ^
- "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
- (fst x)) )) ^ " " ^
- "pre not Win1()" )
- "" moves1) ^"\n"^
- "LOC 0 {
- PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
- MOVES [Mv1 -> 1]}
- PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
-}
-LOC 1{
- PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
- PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
- MOVES [Mv2 -> 0] }
-}" ^"\n" ^
- "MODEL "^(Structure.str (List.hd (List.hd partylistWin0)))
-
-
-(* Get the play with given id from DB - as a sequence of structures. *)
-let playFromDB pid =
- let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
- let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
- let moveStrucs = List.map (fun x -> ((int_of_string x.(4)), x.(5))) res in
- let prevs = List.sort (fun (a, b) (c, d) -> a - c) moveStrucs in
- let cur = dbtable ("playid=" ^ (string_of_int pid)) "cur_states" in
- (List.map snd prevs) @ [(List.hd cur).(5)]
-
-(* Learn a two-player win-lose-or-tie game given 4 sets of plays of another
- game [source]: [wins0] which are now supposed to be won by Player 0,
- [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
- are not correct plays of the newly constructed game. *)
-let learnFromDB ~source ~wins0 ~wins1 ~tie ~wrong =
- if !debug_level > 0 then (
- let pl l = String.concat ", " (List.map string_of_int l) in
- print_endline ("Learning from " ^ source ^ " w0: " ^ (pl wins0) ^ " w1: " ^
- (pl wins1) ^" tie: "^ (pl tie) ^" wrong: "^ (pl wrong));
- );
- let (wins0, wins1, tie, wrong) =
- (List.map playFromDB wins0, List.map playFromDB wins1,
- List.map playFromDB tie, List.map playFromDB wrong) in
- learnFromParties (List.map (List.map struc_of_string) wins0)
- (List.map (List.map struc_of_string) wins1)
Deleted: trunk/Toss/Server/LearnGame.mli
===================================================================
--- trunk/Toss/Server/LearnGame.mli 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Server/LearnGame.mli 2012-01-16 14:23:37 UTC (rev 1640)
@@ -1,25 +0,0 @@
-(** Module for learning games from examples. *)
-
-val move: Structure.structure -> Structure.structure ->
- Structure.structure * Structure.structure
-
-val learnFromParties:
- Structure.structure list list -> Structure.structure list list -> string
-
-
-(** Get the play with given id from DB - as a sequence of structure strings. *)
-val playFromDB: int -> string list
-
-(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
- game [source]: [wins0] which are now supposed to be won by Player 0,
- [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
- are not correct plays of the newly constructed game. The plays are given
- as lists of ids to be retrieved from DB, result is a toss game string. *)
-val learnFromDB: source:string -> wins0: int list -> wins1: int list ->
- tie: int list -> wrong: int list -> string
-
-
-(** {2 Debugging} *)
-
-(* At higher debug levels we prints out diagnostic information. *)
-val set_debug_level: int -> unit
Deleted: trunk/Toss/Server/LearnGameTest.ml
===================================================================
--- trunk/Toss/Server/LearnGameTest.ml 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Server/LearnGameTest.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -1,338 +0,0 @@
-open OUnit
-
-let formula_of_string s =
- FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-
-let struc_of_string s =
- StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-
-let tests = "LearnGame" >::: [
- "simple test game" >::
- (fun () ->
- let partylist0 = [
- List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. .
-. .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-. .
-. P
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-. .
-Q P
-\"" ;]] in
- let partylist1 = [
- List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. .
-. .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-. .
-P .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-. .
-P Q
-\"" ;]] in
- let res_game =
-"PLAYERS 1, 2
-REL Win1() = ex x1 (Q(x1) and ex x0 R(x1, x0))
-REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
-RULE Mv1:
-[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
-emb R,Q,P pre not Win2()
-RULE Mv2:
-[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P:1 {}; Q (1); R:2 {} | ]
-emb R,Q,P pre not Win1()
-LOC 0 {
- PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
- MOVES [Mv1 -> 1]}
- PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
-}
-LOC 1{
- PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
- PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
- MOVES [Mv2 -> 0] }
-}
-MODEL [ | P:1 {}; Q:1 {} | ] R R \"
-
- . .
-\"" in
- assert_equal ~printer:(fun x -> x) res_game
- ((LearnGame.learnFromParties partylist0 partylist1 ));
- );
-]
-
-
-let bigtests = "LearnGame" >::: [
- "tic-tac-toe" >::
- (fun () ->
- Distinguish.set_debug_level 0; (* set to 1 to get some info printed out *)
- let partylist0 = [
- List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-P . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q .
-. . .
-P . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q .
-. . .
-P P .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q Q
-. . .
-P P .
-. . .
-. . .
-. . .
-\"";
- ]; List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-Q . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-Q P .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-Q P .
-. . .
-Q . .
-. . .
-\"";]
- ] in
-let partylist1 = [
- List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . P
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q P
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q P
-. . .
-. Q Q
-. . .
-. . .
-P P P
-\"";
- ]; List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q Q
-. . .
-. . .
-P P P
-\"";
- ]
- ; List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-P P P
-\"";]
- ; List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. P .
-. . .
-. P .
-. . .
-. P .
-\"";]
- ; List.map struc_of_string [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . P
-. . .
-. P .
-. . .
-P . .
-\"";]
- ] in
-assert_equal ~printer:(fun x -> x) ""
- ((LearnGame.learnFromParties partylist0 partylist1 ));
- );
-
-]
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Server/ReqHandler.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -690,9 +690,36 @@
let (w1, other) = List.partition (fun (_, b) -> b = "1") other in
let (tie, other) = List.partition (fun (_, b) -> b = "2") other in
let (wrong, _) = List.partition (fun (_, b) -> b = "3") other in
- LearnGame.learnFromDB ~source:game
- ~wins0:(List.map fst w0) ~wins1:(List.map fst w1)
- ~tie:(List.map fst tie) ~wrong:(List.map fst wrong) in
+ (* Get the play with given id from DB - as a sequence of structures. *)
+ let playFromDB pid =
+ let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
+ let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
+ let moveStrucs = List.map (fun x -> ((int_of_string x.(4)), x.(5))) res in
+ let prevs = List.sort (fun (a, b) (c, d) -> a - c) moveStrucs in
+ let cur = dbtable ("playid=" ^ (string_of_int pid)) "cur_states" in
+ (List.map snd prevs) @ [(List.hd cur).(5)] in
+ (* Learn a two-player win-lose-or-tie game given 4 sets of plays of another
+ game [source]: [wins0] which are now supposed to be won by Player 0,
+ [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
+ are not correct plays of the newly constructed game. *)
+ let learnFromDB source wins0 wins1 tie wrong =
+ if !debug_level > 0 then (
+ let pl l = String.concat ", " (List.map string_of_int l) in
+ print_endline ("Learning from "^ source ^" w0: "^ (pl wins0) ^" w1: "^
+ (pl wins1)^" tie: "^(pl tie) ^" wrong: "^ (pl wrong));
+ );
+ let (wins0, wins1, tie, wrong) =
+ (List.map playFromDB wins0, List.map playFromDB wins1,
+ List.map playFromDB tie, List.map playFromDB wrong) in
+ let struc_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s) in
+ LearnGame.learnFromParties
+ ~win0:(List.map (List.map struc_of_string) wins0)
+ ~win1:(List.map (List.map struc_of_string) wins1)
+ ~tie:(List.map (List.map struc_of_string) tie)
+ ~wrong:(List.map (List.map struc_of_string) wrong) in
+ learnFromDB game (List.map fst w0) (List.map fst w1)
+ (List.map fst tie) (List.map fst wrong) in
let (tcmd, data) = split_two "#" msg in
let resp, new_cookies = match tcmd with
| "USERNAME" ->
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Server/Tests.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -17,7 +17,6 @@
"AssignmentsTest", [AssignmentsTest.tests];
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
"ClassTest", [ClassTest.tests; ClassTest.bigtests];
- "DistinguishTest", [DistinguishTest.tests; DistinguishTest.bigtests];
]
let arena_tests = "Arena", [
@@ -41,10 +40,14 @@
"TranslateFormulaTest", [TranslateFormulaTest.tests];
]
+let learn_tests = "Learn", [
+ "DistinguishTest", [DistinguishTest.tests; DistinguishTest.bigtests];
+ "LearnGameTest", [LearnGameTest.tests; LearnGameTest.bigtests];
+]
+
let server_tests = "Server", [
"PictureTest", [PictureTest.tests];
"ReqHandlerTest", [ReqHandlerTest.tests];
- "LearnGameTest", [LearnGameTest.tests; LearnGameTest.bigtests];
]
let tests_l = [
@@ -53,6 +56,7 @@
arena_tests;
play_tests;
ggp_tests;
+ learn_tests;
server_tests;
]
Deleted: trunk/Toss/Solver/Distinguish.ml
===================================================================
--- trunk/Toss/Solver/Distinguish.ml 2012-01-16 01:49:42 UTC (rev 1639)
+++ trunk/Toss/Solver/Distinguish.ml 2012-01-16 14:23:37 UTC (rev 1640)
@@ -1,269 +0,0 @@
-open Formula
-
-let debug_level = ref 0
-let set_debug_level i = (debug_level := i)
-
-type logic = FO | GuardedFO
-
-
-(* Helper functions to construct variables for indices. *)
-let varname i = "x" ^ string_of_int i
-let varnames k = List.map varname (Aux.range k)
-let var i = var_of_string (varname i)
-let fo_var i = fo_var_of_string (varname i)
-
-(* Helper function: check if a formula holds for a tuple on a structure. *)
-let check structure tuple formula =
- 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 assignment = if tuple = [||] then AssignmentSet.Any else
- Assignments.assignments_of_list elems vars [tuple] in
- eval structure formula assignment <> AssignmentSet.Empty
-
-(* - Atoms and FO Types - *)
-
-(* The list of literals which hold for a tuple on a structure. *)
-let atoms struc tuple =
- let k = Array.length tuple in
- let rec equalities = function
- | [] -> []
- | v :: vs -> (List.map (fun x -> Eq (`FO v,`FO x)) vs) @ (equalities vs) in
- let atoms = FormulaOps.atoms (Structure.rel_signature struc) (varnames k) in
- List.map (
- fun atom -> if check struc tuple atom then atom else (Not atom)
- ) (ato...
[truncated message content] |
|
From: <luk...@us...> - 2012-01-17 00:38:24
|
Revision: 1641
http://toss.svn.sourceforge.net/toss/?rev=1641&view=rev
Author: lukaszkaiser
Date: 2012-01-17 00:38:17 +0000 (Tue, 17 Jan 2012)
Log Message:
-----------
Cleanups and improvements in Learn, adding tc-atoms distinguishing.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaSubst.ml
trunk/Toss/Formula/FormulaSubst.mli
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/Distinguish.mli
trunk/Toss/Learn/DistinguishTest.ml
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
Modified: trunk/Toss/Formula/FormulaSubst.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubst.ml 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Formula/FormulaSubst.ml 2012-01-17 00:38:17 UTC (rev 1641)
@@ -370,20 +370,22 @@
let inphi = And [In (xv, frX); All (([nxv; nyv] :> var list), impphi)] in
All ([(frX :> var)], Or [Not inphi; In (yv, frX)])
-(* First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *)
-let rec make_fo_tc_conj k x y phi =
+(* First-order [k]-step [?refl] transitive closure of [phi] over [x] and [y]. *)
+let rec make_fo_tc_conj ?(reflexive=true) k x y phi =
let (xv, yv) = (fo_var_of_string x, fo_var_of_string y) in
- if k = 0 then Eq (xv, yv) else if k = 1 then Or [Eq (xv, yv); phi] else
+ if k = 0 then Eq (xv, yv) else if k = 1 then
+ if reflexive then Or [Eq (xv, yv); phi] else phi
+ else
let (fv, k1, k2) = (free_vars phi, k / 2, k - (k / 2)) in
let (_, t) = subst_name_avoiding fv (var_of_string "t") in
- let (phi1, phi2) =
- (make_fo_tc_conj k1 x y phi, make_fo_tc_conj k2 x y phi) in
+ let (phi1, phi2) = (make_fo_tc_conj ~reflexive k1 x y phi,
+ make_fo_tc_conj ~reflexive k2 x y phi) in
let (phi1s, phi2s) =
(subst_vars [(y,t)] phi1, subst_vars [(x,t)] phi2) in
Ex ([var_of_string t], And [phi1s; phi2s])
(* First-order [k]-step refl. transitive closure of [phi], disjunctive form. *)
-let make_fo_tc_disj k x y phi =
+let make_fo_tc_disj ?(reflexive=true) k x y phi =
let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in
let (_, t) = subst_name_avoiding fv (var_of_string "t") in
let phi_t = subst_vars [(y,t)] phi in
@@ -392,4 +394,4 @@
let lst = k_step (i-1) in
let psi = subst_vars [(x,t)] (List.hd lst) in
Ex ([var_of_string t], And [phi_t; psi]) :: lst in
- Or (List.rev (k_step k))
+ if reflexive then Or (List.rev (k_step k)) else List.hd (k_step k)
Modified: trunk/Toss/Formula/FormulaSubst.mli
===================================================================
--- trunk/Toss/Formula/FormulaSubst.mli 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Formula/FormulaSubst.mli 2012-01-17 00:38:17 UTC (rev 1641)
@@ -65,8 +65,10 @@
val make_mso_tc : string -> string -> formula -> formula
(** First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *)
-val make_fo_tc_conj : int -> string -> string -> formula -> formula
-val make_fo_tc_disj : int -> string -> string -> formula -> formula
+val make_fo_tc_conj : ?reflexive: bool ->
+ int -> string -> string -> formula -> formula
+val make_fo_tc_disj : ?reflexive: bool ->
+ int -> string -> string -> formula -> formula
(** {2 Debugging} *)
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Learn/Distinguish.ml 2012-01-17 00:38:17 UTC (rev 1641)
@@ -3,7 +3,7 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i)
-type logic = FO | GuardedFO
+type logic = FO | ExFO | GuardedFO | ExGuardedFO
(* Helper functions to construct variables for indices. *)
@@ -22,6 +22,7 @@
Assignments.assignments_of_list elems vars [tuple] in
eval structure formula assignment <> AssignmentSet.Empty
+
(* - Atoms and FO Types - *)
(* The list of literals which hold for a tuple on a structure. *)
@@ -36,9 +37,9 @@
) (atoms @ (equalities (varnames k)))
-(* The [qr]-type in [length of tuple]-variables of [tuple] in [struc].
- In [mem] we memorize the results for [qr] and [tuple], but *not* [struc]. *)
-let rec ntype_memo struc mem qr tuple =
+(* The [?existential] [qr]-type in [length of tuple]-variables of [tuple] in
+ [struc]. We memorize [mem] results for [qr] and [tuple], *not* [struc]. *)
+let rec ntype_memo existential struc mem qr tuple =
try Hashtbl.find mem (qr, tuple) with Not_found ->
if qr = 0 then (
let res = Formula.flatten_sort (And (atoms struc tuple)) in
@@ -46,30 +47,34 @@
res
) else (
let prevtp i e =
- ntype_memo struc mem (qr-1) (Aux.array_replace tuple i e) in
+ ntype_memo existential struc mem (qr-1) (Aux.array_replace tuple i e) in
let elems = Structure.elements struc in
let conj_prev_ex i =
And (List.map (fun e -> Ex ([var i], prevtp i e)) elems) in
let all_prev_disj i =
All ([var i], Or (List.map (prevtp i) elems)) in
- let next_ntype i = And [conj_prev_ex i; all_prev_disj i] in
+ let next_ntype i =
+ if existential then conj_prev_ex i else
+ And [conj_prev_ex i; all_prev_disj i] in
let nexttp = And (List.map next_ntype (Aux.range (Array.length tuple))) in
let res = Formula.flatten_sort (
- And [ntype_memo struc mem (qr-1) tuple; nexttp]) in
+ And [ntype_memo existential struc mem (qr-1) tuple; nexttp]) in
Hashtbl.add mem (qr, tuple) res;
res
)
-(* The [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
-let ntype struc qr tuple = ntype_memo struc (Hashtbl.create 7) qr tuple
+(* The [?existential] [qr]-type in [length of tuple]-variables
+ of [tuple] in [struc]. *)
+let ntype ?(existential=false) struc qr tuple =
+ ntype_memo existential struc (Hashtbl.create 7) qr tuple
-(* All types of rank [qr] of all [k]-tuples in [struc]. *)
-let ntypes struc ~qr ~k =
+(* All [?existential] types of rank [qr] of all [k]-tuples in [struc]. *)
+let ntypes ?(existential=false) struc ~qr ~k =
let elems = Structure.elements struc in
let tups = List.map Array.of_list (Aux.all_ntuples elems k) in
let mem = Hashtbl.create 63 in
- Aux.unique_sorted (List.rev_map (ntype_memo struc mem qr) tups)
+ Aux.unique_sorted (List.rev_map (ntype_memo existential struc mem qr) tups)
(* - Guards and Guarded Types - *)
@@ -120,23 +125,24 @@
(Formula.str atom) ^ " >"
-(* Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc].
- In [mem] we memorize the results for [qr] and [tuple], but *not* [struc]. *)
-let rec guarded_type_memo struc mem qr tuple =
+(* Guarded [?existential] [qr]-type in [length of tuple]-variables of [tuple] in
+ [struc]. We memorize [mem] results for [qr] and [tuple], *not* [struc]. *)
+let rec guarded_type_memo existential struc mem qr tuple =
try Hashtbl.find mem (qr, tuple) with Not_found ->
if qr = 0 then (
let res = Formula.flatten_sort (And (atoms struc tuple)) in
Hashtbl.add mem (qr, tuple) res;
res
) else (
- let prevtp tup = guarded_type_memo struc mem (qr-1) tup in
+ let prevtp tup = guarded_type_memo existential struc mem (qr-1) tup in
let conj_prev_ex vars guard subst_tuples =
let subst_tuples = List.filter (fun tup -> tup <> tuple) subst_tuples in
And (List.map (fun tup -> Ex (vars, prevtp tup)) subst_tuples) in
let all_prev_disj vars guard subst_tuples =
All (vars, Or ((Not guard) :: (List.map prevtp subst_tuples))) in
let next_gtype vs (g, ts) =
- And [conj_prev_ex vs g ts; all_prev_disj vs g ts] in
+ if existential then conj_prev_ex vs g ts else
+ And [conj_prev_ex vs g ts; all_prev_disj vs g ts] in
let subst_tuples =
List.rev_map (fun (_,vs,t,_,_) -> (vs, t)) (guards struc tuple) in
let subst_tuples = Aux.unique_sorted (([], tuple) :: subst_tuples) in
@@ -161,18 +167,20 @@
let next_gtype_vs (vs, gtups) = And (List.map (next_gtype vs) gtups) in
let nextf = And (List.map next_gtype_vs tups_with_guards) in
let res = Formula.flatten_sort (
- And [guarded_type_memo struc mem (qr-1) tuple; nextf]) in
+ And [guarded_type_memo existential struc mem (qr-1) tuple; nextf]) in
Hashtbl.add mem (qr, tuple) res;
res
)
-(* Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
-let guarded_type struc qr tuple =
- guarded_type_memo struc (Hashtbl.create 7) qr tuple
+(* Guarded [?existential] [qr]-type in [length of tuple]-variables
+ of [tuple] in [struc]. *)
+let guarded_type ?(existential=false) struc qr tuple =
+ guarded_type_memo existential struc (Hashtbl.create 7) qr tuple
-(* All guarded types of rank [qr] of guarded [k]-tuples in [struc]. *)
-let guarded_types struc ~qr ~k =
+(* All guarded [?existential] types of rank [qr] of
+ guarded [k]-tuples in [struc]. *)
+let guarded_types ?(existential=false) struc ~qr ~k =
let tups = List.map (Structure.incident struc) (Structure.elements struc) in
let tups = List.concat (List.map snd (List.concat tups)) in
let tups = List.filter (fun tup -> Array.length tup >= k) tups in
@@ -181,13 +189,62 @@
let ktups = List.rev_map k_subtuples (Aux.unique_sorted tups) in
let ktups = Aux.unique_sorted (List.concat ktups) in
let mem = Hashtbl.create 63 in
- Aux.unique_sorted (List.rev_map (guarded_type_memo struc mem qr) ktups)
+ Aux.unique_sorted (List.rev_map
+ (guarded_type_memo existential struc mem qr) ktups)
+(* - Transitive Closure Formulas - *)
+(* Maximum n between [from] and [upto] such that n-step TC of phi holds. *)
+let tc_max struc phi ?(from=1) upto =
+ let from, upto = max from 1, max (max upto 1) from in
+ let tc n = FormulaSubst.make_fo_tc_disj ~reflexive:false n "x0" "x1" phi in
+ if not (check struc [||] (tc from)) then None else
+ let rec ok i =
+ if i > upto || not (check struc [||] (tc i)) then i-1 else ok (i+1) in
+ Some (ok (from+1))
+
+(* Pairs (n, phi) such that phi is a two-variable [?positive] atomic formula
+ and the n-step transitive closure of phi holds somewhere on [struc].
+ The n is between [?from] and [upto], at least 1, phi has 2 free variables. *)
+let tc_atomic ?(positive=false) ?(repeat_vars=true) struc ?(from=1) upto =
+ let rec rept i l = if i < 1 then [] else l :: (rept (i-1) l) in
+ let atoms = Array.of_list (FormulaOps.atoms ~repetitions:repeat_vars
+ (Structure.rel_signature struc) (varnames 2)) in
+ let choices = List.rev_map Array.of_list
+ (if positive then Aux.product (rept (Array.length atoms) [0; 1]) else
+ Aux.product (rept (Array.length atoms) [0; 1; -1])) in
+ let atom_chosen i = function
+ | c when c < 0 -> Not (atoms.(i))
+ | c when c = 0 -> And []
+ | c -> atoms.(i) in
+ let max_n_chosen l =
+ let f = Formula.flatten (And (Array.to_list (Array.mapi atom_chosen l))) in
+ if List.length (FormulaSubst.free_vars f) < 2 then None else
+ match tc_max struc f ~from upto with None -> None
+ | Some n -> Some (n, f) in
+ Aux.map_some max_n_chosen choices
+
+(* Find a upto-[n]-step transitive closures of two-variable [?positive] atomic
+ formulas that hold on all [pos_strucs] and on no [neg_strucs]. *)
+let tc_atomic_distinguish ?(positive=false) ?(repeat_vars=true) pos neg n =
+ if pos = [] then failwith "tc_atomic_distinguish: no pos" else
+ let tc n f= FormulaSubst.make_fo_tc_disj ~reflexive:false n "x0" "x1" f in
+ let is_ok (m, phi) negstruc = not (check negstruc [||] (tc m phi)) in
+ let ok_all (m, phi) = List.for_all (is_ok (m, phi)) neg in
+ let tcs s = List.filter ok_all (tc_atomic ~positive ~repeat_vars s n) in
+ let choose l =
+ if l = [] then raise Not_found else
+ let cmp (n1, f1) (n2, f2) =
+ if n1 <> n2 then n1-n2 else Formula.compare f1 f2 in
+ let (k, phi) = List.hd (List.sort cmp l) in
+ tc k phi in
+ try Some (Or (List.rev_map (fun s -> choose (tcs s)) pos)) with
+ Not_found -> None
+
+
(* - Distinguishing Structure Sets - *)
-
(* Helper function: remove atoms from a formula if [cond] is still satisfied.
Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
let rec greedy_remove ?(pos=false) cond phi =
@@ -218,20 +275,24 @@
(* Find the minimal [logic]-type of [struc] not included in [neg_types]
and with at most [qr] quantifiers and [k] variables. *)
-let min_type_omitting ?(logic = GuardedFO) ~qr ~k neg_types struc =
+let min_type_omitting ?(logic=ExGuardedFO) ~qr ~k neg_types struc =
let pos_types = match logic with
| GuardedFO -> guarded_types struc ~qr ~k
- | FO -> ntypes struc ~qr ~k in
+ | ExGuardedFO -> guarded_types ~existential:true struc ~qr ~k
+ | FO -> ntypes struc ~qr ~k
+ | ExFO -> ntypes ~existential:true struc ~qr ~k in
let ok_types = List.filter (fun f -> not (List.mem f neg_types)) pos_types in
let ok_types = List.sort !compare_types ok_types in
if ok_types = [] then None else Some (List.hd ok_types)
(* Find a [logic]-formula with at most [qr] quantifiers and [k] variables
which holds on all [pos_strucs] and on no [neg_strucs]. *)
-let distinguish_upto ?(logic = GuardedFO) ~qr ~k pos_strucs neg_strucs =
+let distinguish_upto ?(logic=ExGuardedFO) ~qr ~k pos_strucs neg_strucs =
let types s = match logic with
- | GuardedFO -> guarded_types s ~qr ~k
- | FO -> ntypes s ~qr ~k in
+ | GuardedFO -> guarded_types s ~qr ~k
+ | ExGuardedFO -> guarded_types ~existential:true s ~qr ~k
+ | 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
let fails_on_negs f = not (List.exists (fun s-> check s [||] f) neg_strucs) in
let extend_by_pos acc struc =
@@ -250,20 +311,29 @@
Some (FormulaOps.rename_quant_avoiding fv minimized)
-(* Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
+(* Find a formula holding on all [pos_strucs] and on no [neg_strucs].
Leaves free variables (existential) if [skip_outer_exists] is set. *)
-let distinguish ?(how=GuardedFO) ?(skip_outer_exists=false) strucs1 strucs2 =
+let distinguish ?(skip_outer_exists=false) s1 s2 =
if !debug_level > 0 then
Printf.printf "distinguishing:\n\n%s\n\n and\n\n %s\n%!"
- (String.concat "\n" (List.map Structure.str strucs1))
- (String.concat "\n" (List.map Structure.str strucs2));
+ (String.concat "\n" (List.map Structure.str s1))
+ (String.concat "\n" (List.map Structure.str s2));
let rec diff qr k =
if qr > k then diff 0 (k+1) else (
if !debug_level > 0 then Printf.printf "distinguish qr %i k %i\n%!" qr k;
- match distinguish_upto ~logic:how ~qr ~k strucs1 strucs2 with
- | Some f ->
- if skip_outer_exists then Some f else
- Some (Ex (FormulaSubst.free_vars f, f))
- | None -> diff (qr+1) k
+ if qr = 0 then
+ match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
+ | Some f -> f | None ->
+ match tc_atomic_distinguish ~positive:true
+ ~repeat_vars:false s1 s2 (3*k) with
+ | Some f -> Formula.flatten_sort f | None -> diff (qr+1) k
+ else
+ match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
+ | Some f ->
+ (match distinguish_upto ~logic:ExGuardedFO ~qr ~k s1 s2 with
+ | Some g-> if 2*(Formula.size f) < Formula.size g then f else g
+ | None -> f)
+ | None -> diff (qr+1) k
) in
- diff 0 1
+ let res = diff 0 1 in
+ if skip_outer_exists then res else Ex (FormulaSubst.free_vars res, res)
Modified: trunk/Toss/Learn/Distinguish.mli
===================================================================
--- trunk/Toss/Learn/Distinguish.mli 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Learn/Distinguish.mli 2012-01-17 00:38:17 UTC (rev 1641)
@@ -1,6 +1,6 @@
(** Distinguish sets of structures by formulas. *)
-type logic = FO | GuardedFO
+type logic = FO | ExFO | GuardedFO | ExGuardedFO
(** {2 Atoms and FO Types} *)
@@ -9,11 +9,14 @@
i.e. the atomic type of this tuple. *)
val atoms: Structure.structure -> int array -> Formula.formula list
-(** The [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
-val ntype: Structure.structure -> int -> int array -> Formula.formula
+(** The [?existential] [qr]-type in [length of tuple]-variables
+ of [tuple] in [struc]. *)
+val ntype: ?existential: bool ->
+ Structure.structure -> int -> int array -> Formula.formula
-(** All types of rank [qr] of all [k]-tuples in [struc]. *)
-val ntypes: Structure.structure -> qr: int -> k:int -> Formula.formula list
+(** All [?existential] types of rank [qr] of all [k]-tuples in [struc]. *)
+val ntypes: ?existential: bool ->
+ Structure.structure -> qr: int -> k:int -> Formula.formula list
(** {2 Guards and Guarded Types} *)
@@ -36,14 +39,36 @@
(int list * Formula.var list * int array * int array * Formula.formula) ->
string
-(** Guarded [qr]-type in [length of tuple]-variables of [tuple] in [struc]. *)
-val guarded_type: Structure.structure -> int -> int array -> Formula.formula
+(** Guarded [?existential] [qr]-type in [length of tuple]-variables
+ of [tuple] in [struc]. *)
+val guarded_type: ?existential: bool ->
+ Structure.structure -> int -> int array -> Formula.formula
-(** All guarded types of rank [qr] of guarded [k]-tuples in [struc]. *)
-val guarded_types: Structure.structure -> qr: int -> k:int ->
- Formula.formula list
+(** All guarded [?existential] types of rank [qr] of
+ guarded [k]-tuples in [struc]. *)
+val guarded_types: ?existential: bool ->
+ Structure.structure -> qr: int -> k:int -> Formula.formula list
+(** {2 Transitive Closure Formulas} *)
+
+(** Maximum n between [from] and [upto] such that n-step TC of phi holds. **)
+val tc_max:
+ Structure.structure -> Formula.formula -> ?from: int -> int -> int option
+
+(** Pairs (n, phi) such that phi is a two-variable [?positive] atomic formula
+ and the n-step transitive closure of phi holds somewhere on [struc].
+ The n is between [?from] - [upto], at least 1, phi has 2 free variables. **)
+val tc_atomic: ?positive: bool -> ?repeat_vars: bool ->
+ Structure.structure -> ?from: int -> int -> (int * Formula.formula) list
+
+(** Find a upto-[n]-step transitive closures of two-variable [?positive] atomic
+ formulas that hold on all [pos_strucs] and on no [neg_strucs]. **)
+val tc_atomic_distinguish: ?positive: bool -> ?repeat_vars: bool ->
+ Structure.structure list -> Structure.structure list -> int ->
+ Formula.formula option
+
+
(** {2 Distinguishing Structure Sets} *)
(** Order on types that we use to select the minimal ones. *)
@@ -60,10 +85,10 @@
val distinguish_upto: ?logic: logic -> qr: int -> k: int ->
Structure.structure list -> Structure.structure list -> Formula.formula option
-(** Find a [logic]-formula holding on all [pos_strucs] and on no [neg_strucs].
+(** Find a formula holding on all [pos_strucs] and on no [neg_strucs].
Leaves free variables (existential) if [skip_outer_exists] is set. *)
-val distinguish: ?how: logic -> ?skip_outer_exists: bool ->
- Structure.structure list -> Structure.structure list -> Formula.formula option
+val distinguish: ?skip_outer_exists: bool ->
+ Structure.structure list -> Structure.structure list -> Formula.formula
(** {2 Debugging} *)
Modified: trunk/Toss/Learn/DistinguishTest.ml
===================================================================
--- trunk/Toss/Learn/DistinguishTest.ml 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Learn/DistinguishTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
@@ -208,6 +208,27 @@
(List.length (Distinguish.guarded_types struc ~qr:1 ~k:2));
);
+ "tc_atomic" >::
+ (fun () ->
+ let struc = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ formula_list_eq [ "R(x1, x0)"; "R(x0, x1)" ]
+ (List.rev_map snd (tc_atomic ~positive:true struc 1));
+ formula_list_eq [ "R(x1, x0)"; "R(x0, x1)" ]
+ (List.rev_map snd (tc_atomic ~positive:true struc 2));
+ formula_list_eq [ "R(x1, x0)"; "R(x0, x1)" ]
+ (List.rev_map snd (tc_atomic ~positive:true struc ~from:2 2));
+ formula_list_eq []
+ (List.rev_map snd (tc_atomic ~positive:true struc ~from:3 3));
+ );
+
+ "tc_atomic_distinguish" >::
+ (fun () ->
+ let s1 = (struc_of_string "[ | P { 1; 2; 3 }; R { (1,2); (2,3) } | ]") in
+ let s2 = (struc_of_string "[ | P { 1; 2 }; R { (1,2); (2,3) } | ]") in
+ formula_option_eq "ex t (P(t) and P(x1) and R(t, x1) and R(x0, t))"
+ (tc_atomic_distinguish ~positive:true [s1] [s2] 2);
+ );
+
"distinguish_upto" >::
(fun () ->
let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
@@ -220,7 +241,7 @@
(Distinguish.distinguish_upto ~logic:FO ~qr:0 ~k:2 [struc1] [struc2]);
formula_option_eq "None" (* we use guarded types - so None here *)
(Distinguish.distinguish_upto ~qr:0 ~k:3 [struc1] [struc2]);
- formula_option_eq "R(x0, x1) and ex x2 R(x2, x0)"
+ formula_option_eq "R(x0, x1) and ex x2 R(x1, x2)"
(Distinguish.distinguish_upto ~qr:1 ~k:2 [struc1] [struc2]);
let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
@@ -233,13 +254,12 @@
(fun () ->
let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
- formula_option_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x2, x0))"
+ formula_eq "ex x0, x1, t (R(t, x1) and R(x0, t))"
(Distinguish.distinguish [struc1] [struc2]);
let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
- formula_option_eq "ex x0 P(x0)"
- (Distinguish.distinguish [struc1] [struc2]);
+ formula_eq "ex x0 P(x0)" (Distinguish.distinguish [struc1] [struc2]);
let struc1 = struc_of_string "[ | | ] \"
...
@@ -253,7 +273,7 @@
...
...
\"" in
- formula_option_eq "ex x0, x1 (P(x0) and C(x0, x1))"
+ formula_eq "ex x0, x1 (P(x0) and C(x0, x1))"
(Distinguish.distinguish [struc1] [struc2]);
);
]
@@ -292,8 +312,8 @@
P..
... ...
...P ...
-\"" in formula_option_eq
- "P(x0) and P(x1) and C(x0, x1) and ex x2 (P(x2) and C(x2, x0))"
+\"" in formula_eq
+ "ex t (P(t) and P(x0) and P(x1) and C(t, x1) and C(x0, t))"
(Distinguish.distinguish ~skip_outer_exists:true
[strucP] [strucN1; strucN2; strucN3]);
);
@@ -336,7 +356,7 @@
... ... ... ...
...W ... ... ...
\"" in (* Distinguish.set_debug_level 1; *)
- formula_option_eq "W(x1) and all x0 not C(x1, x0)"
+ formula_eq "W(x1) and all x0 not C(x1, x0)"
(Distinguish.distinguish ~skip_outer_exists:true [struc1] [struc2]);
);
]
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Learn/LearnGame.ml 2012-01-17 00:38:17 UTC (rev 1641)
@@ -19,8 +19,7 @@
"Searching WIN:\n" ^
(String.concat "\n" (List.map Structure.str winningStates)) ^ "\nNOT\n"^
(String.concat "\n" (List.map Structure.str notWinningStates)));
- FormulaOps.tnf_fv
- (Aux.unsome (Distinguish.distinguish winningStates notWinningStates))
+ FormulaOps.tnf_fv (Distinguish.distinguish winningStates notWinningStates)
let cleanStructure struc =
let funs = ref [] in
@@ -73,11 +72,11 @@
let win0f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win0)
(List.flatten ((List.map (fun x-> List.tl (List.rev x))
- win0) @ win1)) in
+ win0) @ win1 @ tie)) in
let win1f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win1)
(List.flatten ((List.map (fun x-> List.tl (List.rev x))
- win1) @ win0)) in
+ win1) @ win0 @ tie)) in
let moves0 = movesi 0 (win0 @ win1) in
let moves1 = movesi 1 (win0 @ win1) in
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
@@ -3,8 +3,15 @@
let formula_of_string s =
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-let struc_of_string s =
- StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+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));" ^
+ " Db (x, y) = ex u (R(x, u) and C(y, u))" in
+ match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
+ | Arena.StateStruc struc -> struc
+ | _ -> failwith "LearnGameTest:struc_of_string: not a structure"
+ else
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
let tests = "LearnGame" >::: [
"simple test game" >::
@@ -39,7 +46,7 @@
\"" ;]] in
let res_game =
"PLAYERS 1, 2
-REL Win1() = ex x1 (Q(x1) and ex x0 R(x1, x0))
+REL Win1() = ex x0 (Q(x0) and ex x1 R(x0, x1))
REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
RULE Mv1:
[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
@@ -73,7 +80,7 @@
(fun () ->
Distinguish.set_debug_level 0; (* set to 1 to get some info printed out *)
let partylist0 = [
- List.map struc_of_string [
+ List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . .
@@ -122,7 +129,7 @@
. . .
. . .
\"";
- ]; List.map struc_of_string [
+ ]; List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . .
@@ -170,17 +177,41 @@
. . .
Q . .
. . .
-\"";]
- ] in
-let partylist1 = [
- List.map struc_of_string [
+\"";]; List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . .
. . .
. . .
. . .
+Q Q Q
+\"";]; List.map (struc_of_string ~diag:true) [
+"[ | P:1 {}; Q:1 {} | ] \"
. . .
+. Q .
+. . .
+. Q .
+. . .
+. Q .
+\"";]; List.map (struc_of_string ~diag:true) [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . Q
+. . .
+. Q .
+. . .
+Q . .
+\"";]
+] in
+ let partylist1 = [
+ List.map (struc_of_string ~diag:true) [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
\"" ;
"[ | P:1 {}; Q:1 {} | ] \"
Q . .
@@ -246,7 +277,7 @@
. . .
P P P
\"";
- ]; List.map struc_of_string [
+ ]; List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . .
@@ -304,7 +335,7 @@
P P P
\"";
]
- ; List.map struc_of_string [
+ ; List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . .
@@ -313,7 +344,7 @@
. . .
P P P
\"";]
- ; List.map struc_of_string [
+ ; List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. P .
@@ -322,7 +353,7 @@
. . .
. P .
\"";]
- ; List.map struc_of_string [
+ ; List.map (struc_of_string ~diag:true) [
"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . P
@@ -331,10 +362,39 @@
. . .
P . .
\"";]
- ] in
+] in
+let tie = [
+ List.map (struc_of_string ~diag:true) [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. P .
+. . .
+. Q .
+. . .
+. P .
+\"";]
+ ; List.map (struc_of_string ~diag:true) [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . Q
+. . .
+. P .
+. . .
+P . .
+\"";]
+ ; List.map (struc_of_string ~diag:true) [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . P
+. . .
+. P .
+. . .
+Q . .
+\"";]
+] in
assert_equal ~printer:(fun x -> x) ""
((LearnGame.learnFromParties ~win0:partylist0 ~win1:partylist1
- ~tie:[] ~wrong:[]));
+ ~tie ~wrong:[]));
);
]
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-16 14:23:37 UTC (rev 1640)
+++ trunk/Toss/Learn/Makefile 2012-01-17 00:38:17 UTC (rev 1641)
@@ -1,4 +1,4 @@
-all: reco
+all: tests reco
shapes.o: shapes.c shapes.h
gcc -c shapes.c
@@ -6,5 +6,18 @@
reco: reco.cpp shapes.o
g++ shapes.o reco.cpp -o reco `pkg-config opencv --cflags --libs`
+%Test:
+ make -C .. Learn/$@Verbose
+
+DistinguishTest:
+LearnGameTest:
+
+
+tests:
+ make -C .. LearnTestsVerbose
+
+
+.PHONY: clean
+
clean:
rm -rf reco log*.ppm *.o *~
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-17 02:25:57
|
Revision: 1642
http://toss.svn.sourceforge.net/toss/?rev=1642&view=rev
Author: lukaszkaiser
Date: 2012-01-17 02:25:49 +0000 (Tue, 17 Jan 2012)
Log Message:
-----------
Testing js_of_ocaml, some refactoring for that.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.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/Makefile
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Play/MoveTest.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/DB.ml
trunk/Toss/Server/PictureTest.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/StructureTest.ml
Added Paths:
-----------
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/js_of_ocaml_test.html
trunk/Toss/js_of_ocaml_test.ml
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -116,7 +116,7 @@
(* skip_if true "Change to simpler and stable example."; *)
let fname = "./examples/rewriting_example.toss" in
let file = open_in fname in
- let contents = Aux.input_file file 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) =
@@ -126,5 +126,4 @@
);
]
-let a =
- Aux.run_test_if_target "ArenaTest" tests
+let a = AuxIO.run_test_if_target "ArenaTest" tests
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -171,5 +171,4 @@
]
-let a =
- Aux.run_test_if_target "ContinuousRuleTest" tests
+let a = AuxIO.run_test_if_target "ContinuousRuleTest" tests
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -801,8 +801,7 @@
]
-let a =
- Aux.run_test_if_target "DiscreteRuleTest" tests
+let a = AuxIO.run_test_if_target "DiscreteRuleTest" tests
let a () = DiscreteRule.debug_level := 7
Modified: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Arena/TermTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -67,5 +67,4 @@
);
];;
-let a =
- Aux.run_test_if_target "TermTest" tests
+let a = AuxIO.run_test_if_target "TermTest" tests
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/Aux.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -1,6 +1,9 @@
(* Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
+let gettimeofday () = Unix.gettimeofday (); (* 1. *)
+
+
exception Timeout of string
type ('a,'b) choice = Left of 'a | Right of 'b
@@ -50,6 +53,15 @@
(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 strip_spaces 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;
+ if !e < !b then "" else String.sub s !b (!e - !b + 1)
+
let fst3 (a,_,_) = a
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
@@ -259,10 +271,11 @@
) img) [[]] (List.rev dom)
-let product_size l =
- let size = List.fold_left (fun size subl ->
- Big_int.mult_int_big_int (List.length subl) size) Big_int.unit_big_int l in
- try Big_int.int_of_big_int size with _ -> max_int
+let product_size l =
+ let safe_mul size sublist =
+ let l = List.length sublist in
+ if l = 0 || max_int / l > size then l * size else max_int in
+ List.fold_left safe_mul 1 l
let product ?upto ?(timeout = fun () -> false) l =
let _ = match upto with None -> () | Some n ->
@@ -716,112 +729,9 @@
Format.fprintf f "%a%a" f_el hd pr_tail tl
-let run_if_target target_name f =
- let file_from_path p =
- String.sub p (String.rindex p '/'+1)
- (String.length p - String.rindex p '/' - 1) in
- let test_fname =
- let fname = file_from_path Sys.executable_name in
- 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 =
- 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
-
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 *)
}
-
-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 list_dir dirname =
- let files, dir_handle = (ref [], Unix.opendir dirname) in
- let rec add () = files := (Unix.readdir dir_handle) :: !files; add () in
- try add () with End_of_file -> Unix.closedir dir_handle; !files
-
-let is_space c =
- c = '\n' || c = '\r' || c = ' ' || c = '\t'
-
-let strip_spaces 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;
- if !e < !b then "" else String.sub s !b (!e - !b + 1)
-
-let rec input_http_message file =
- let buf = Buffer.create 256 in
- let get_pair s =
- let i, l = String.index s '=', String.length s in
- (String.sub s 0 i, String.sub s (i+1) (l-i-1)) in
- let rec get_cookies s =
- try
- let i, l = String.index s ';', String.length s in
- (get_pair (String.sub s 0 i)) :: get_cookies (String.sub s (i+1) (l-i-1))
- with Not_found -> [] in
- let line, head, cookies, msg_len = ref "HTTP", ref [], ref [], ref 0 in
- while !line <> "" do
- line := strip_spaces (input_line file);
- head := !line :: !head;
- let line_len = String.length !line in
- if line_len > 6 && String.lowercase (String.sub !line 0 6) = "cookie" then (
- let start = (String.index !line ' ') + 1 in
- let ck_str = String.sub !line start (line_len - start) in
- cookies := get_cookies (ck_str ^ ";") @ !cookies
- );
- if line_len > 16 &&
- String.lowercase (String.sub !line 0 15) = "content-length:" then (
- msg_len := int_of_string (String.sub !line 16 (line_len - 16));
- )
- done;
- Buffer.add_channel buf file !msg_len;
- (String.concat "\n" !head, Buffer.contents buf, !cookies)
-
-let input_if_http_message line in_ch =
- let ht1, ht2 = "GET /", "POST /" in
- let l1, l2, l = String.length ht1, String.length ht2, String.length line in
- if ((l > l1 && String.sub line 0 l1 = ht1) ||
- (l > l2 && String.sub line 0 l2 = ht2)) then
- Some (input_http_message in_ch)
- else None
-
-exception Host_not_found
-
-let get_inet_addr addr_s =
- try
- Unix.inet_addr_of_string addr_s
- with Failure _ ->
- try
- let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
- if Array.length addr_arr < 1 then raise Host_not_found else
- addr_arr.(0)
- with Not_found -> raise Host_not_found
-
-let toss_call (client_port, client_addr_s) f_in x =
- try
- let client_addr = get_inet_addr client_addr_s in
- let client_sock = Unix.ADDR_INET (client_addr, client_port) in
- let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
- output_string cl_out_ch "COMP\n";
- flush cl_out_ch;
- let f a = try `Res (f_in a) with exn -> `Exn exn in
- Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
- flush cl_out_ch;
- (fun () ->
- let res = Marshal.from_channel cl_in_ch in
- Unix.shutdown_connection cl_in_ch;
- match res with `Res r -> r | `Exn e -> raise e)
- with Unix.Unix_error (e, f, s) ->
- Printf.printf "Toss call failed: %s; %s %s\n%!" (Unix.error_message e) f s;
- (fun () -> f_in x)
-
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/Aux.mli 2012-01-17 02:25:49 UTC (rev 1642)
@@ -1,6 +1,10 @@
(** 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
@@ -349,37 +353,5 @@
?newline : int -> string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a list -> unit
-(** 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
-
(** Set more agressive Gc values optimized for heavier computations. *)
val set_optimized_gc : unit -> unit
-
-(** Input a file to a string. *)
-val input_file : in_channel -> string
-
-(** List the contents of a directory *)
-val list_dir : string -> string list
-
-(** Extracting the [Content-length] field and input the content of
- an HTTP message. Return the pair: header first, content next. *)
-val input_http_message : in_channel -> string * string * (string * string) list
-
-(** Input HTTP message if [line] is a http header, ie. "GET /" or "POST /".*)
-val input_if_http_message : string -> in_channel ->
- (string * string * (string * string) list) option
-
-(** Exception used in connections when the host is not found. *)
-exception Host_not_found
-
-(** Determine the internet address or raise Host_not_found. *)
-val get_inet_addr : string -> Unix.inet_addr
-
-(** Call a Toss Server on [port, server] to compute [f] on [x]. BEWARE:
- (1) references are not sent, e.g. you must redo timeouts.
- (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)
Added: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml (rev 0)
+++ trunk/Toss/Formula/AuxIO.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -0,0 +1,99 @@
+(* Auxiliary functions that operate on standard library data
+ structures and standard library-like definitions. *)
+open Aux
+
+
+let run_if_target target_name f =
+ let file_from_path p =
+ String.sub p (String.rindex p '/'+1)
+ (String.length p - String.rindex p '/' - 1) in
+ let test_fname =
+ let fname = file_from_path Sys.executable_name in
+ 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 =
+ 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
+
+
+
+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 list_dir dirname =
+ let files, dir_handle = (ref [], Unix.opendir dirname) in
+ let rec add () = files := (Unix.readdir dir_handle) :: !files; add () in
+ try add () with End_of_file -> Unix.closedir dir_handle; !files
+
+let rec input_http_message file =
+ let buf = Buffer.create 256 in
+ let get_pair s =
+ let i, l = String.index s '=', String.length s in
+ (String.sub s 0 i, String.sub s (i+1) (l-i-1)) in
+ let rec get_cookies s =
+ try
+ let i, l = String.index s ';', String.length s in
+ (get_pair (String.sub s 0 i)) :: get_cookies (String.sub s (i+1) (l-i-1))
+ with Not_found -> [] in
+ let line, head, cookies, msg_len = ref "HTTP", ref [], ref [], ref 0 in
+ while !line <> "" do
+ line := strip_spaces (input_line file);
+ head := !line :: !head;
+ let line_len = String.length !line in
+ if line_len > 6 && String.lowercase (String.sub !line 0 6) = "cookie" then (
+ let start = (String.index !line ' ') + 1 in
+ let ck_str = String.sub !line start (line_len - start) in
+ cookies := get_cookies (ck_str ^ ";") @ !cookies
+ );
+ if line_len > 16 &&
+ String.lowercase (String.sub !line 0 15) = "content-length:" then (
+ msg_len := int_of_string (String.sub !line 16 (line_len - 16));
+ )
+ done;
+ Buffer.add_channel buf file !msg_len;
+ (String.concat "\n" !head, Buffer.contents buf, !cookies)
+
+let input_if_http_message line in_ch =
+ let ht1, ht2 = "GET /", "POST /" in
+ let l1, l2, l = String.length ht1, String.length ht2, String.length line in
+ if ((l > l1 && String.sub line 0 l1 = ht1) ||
+ (l > l2 && String.sub line 0 l2 = ht2)) then
+ Some (input_http_message in_ch)
+ else None
+
+exception Host_not_found
+
+let get_inet_addr addr_s =
+ try
+ Unix.inet_addr_of_string addr_s
+ with Failure _ ->
+ try
+ let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
+ if Array.length addr_arr < 1 then raise Host_not_found else
+ addr_arr.(0)
+ with Not_found -> raise Host_not_found
+
+let toss_call (client_port, client_addr_s) f_in x =
+ try
+ let client_addr = get_inet_addr client_addr_s in
+ let client_sock = Unix.ADDR_INET (client_addr, client_port) in
+ let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
+ output_string cl_out_ch "COMP\n";
+ flush cl_out_ch;
+ let f a = try `Res (f_in a) with exn -> `Exn exn in
+ Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
+ flush cl_out_ch;
+ (fun () ->
+ let res = Marshal.from_channel cl_in_ch in
+ Unix.shutdown_connection cl_in_ch;
+ match res with `Res r -> r | `Exn e -> raise e)
+ with Unix.Unix_error (e, f, s) ->
+ Printf.printf "Toss call failed: %s; %s %s\n%!" (Unix.error_message e) f s;
+ (fun () -> f_in x)
Added: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli (rev 0)
+++ trunk/Toss/Formula/AuxIO.mli 2012-01-17 02:25:49 UTC (rev 1642)
@@ -0,0 +1,36 @@
+(** Auxiliary functions that operate on standard library data
+ structures and standard library-like definitions. *)
+
+
+(** 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
+
+
+(** Input a file to a string. *)
+val input_file : in_channel -> string
+
+(** List the contents of a directory *)
+val list_dir : string -> string list
+
+(** Extracting the [Content-length] field and input the content of
+ an HTTP message. Return the pair: header first, content next. *)
+val input_http_message : in_channel -> string * string * (string * string) list
+
+(** Input HTTP message if [line] is a http header, ie. "GET /" or "POST /".*)
+val input_if_http_message : string -> in_channel ->
+ (string * string * (string * string) list) option
+
+(** Exception used in connections when the host is not found. *)
+exception Host_not_found
+
+(** Determine the internet address or raise Host_not_found. *)
+val get_inet_addr : string -> Unix.inet_addr
+
+(** Call a Toss Server on [port, server] to compute [f] on [x]. BEWARE:
+ (1) references are not sent, e.g. you must redo timeouts.
+ (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)
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/AuxTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -483,5 +483,4 @@
]
-let a =
- Aux.run_test_if_target "AuxTest" tests
+let _ = AuxIO.run_test_if_target "AuxTest" tests
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -410,9 +410,9 @@
);
]
-let exec () = Aux.run_test_if_target "BoolFormulaTest" tests
+let exec () = AuxIO.run_test_if_target "BoolFormulaTest" tests
-let execbig ()= Aux.run_test_if_target "BoolFormulaTest" bigtests
+let execbig ()= AuxIO.run_test_if_target "BoolFormulaTest" bigtests
let main () =
@@ -431,4 +431,4 @@
print_endline (BoolFormula.str (elim_quant qbf))
)
-let _ = Aux.run_if_target "BoolFormulaTest" main
+let _ = AuxIO.run_if_target "BoolFormulaTest" main
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -127,7 +127,7 @@
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 = Aux.input_file f 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
@@ -157,4 +157,4 @@
)
-let _ = Aux.run_if_target "BoolFunctionTest" main
+let _ = AuxIO.run_if_target "BoolFunctionTest" main
Modified: trunk/Toss/Formula/FFTNFTest.ml
===================================================================
--- trunk/Toss/Formula/FFTNFTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/FFTNFTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -346,8 +346,7 @@
]
-let a =
- Aux.run_test_if_target "FFTNFTest" tests
+let a = AuxIO.run_test_if_target "FFTNFTest" tests
let a () = FFTNF.debug_level := 7
Modified: trunk/Toss/Formula/FormulaMapTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaMapTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/FormulaMapTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -42,4 +42,4 @@
);
]
-let exec = Aux.run_test_if_target "FormulaMapTest" tests
+let exec = AuxIO.run_test_if_target "FormulaMapTest" tests
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -310,7 +310,7 @@
]
-let exec = Aux.run_test_if_target "FormulaOpsTest" tests
+let exec = AuxIO.run_test_if_target "FormulaOpsTest" tests
(* --------------------------- Reals separation test ----------------------- *)
Modified: trunk/Toss/Formula/FormulaSubstTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubstTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/FormulaSubstTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -155,4 +155,4 @@
]
-let exec = Aux.run_test_if_target "FormulaSubstTest" tests
+let exec = AuxIO.run_test_if_target "FormulaSubstTest" tests
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -40,4 +40,4 @@
]
-let exec = Aux.run_test_if_target "FormulaTest" tests
+let exec = AuxIO.run_test_if_target "FormulaTest" tests
Modified: trunk/Toss/Formula/Sat/Sat.ml
===================================================================
--- trunk/Toss/Formula/Sat/Sat.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/Sat/Sat.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -6,12 +6,12 @@
let timeout = ref 0.
let minisat_timeout = ref 900.
let check_timeout msg =
- if !timeout > 0.5 && Unix.gettimeofday () > !timeout then
+ if !timeout > 0.5 && Aux.gettimeofday () > !timeout then
(timeout := 0.; raise (Aux.Timeout msg))
let set_timeout t =
minisat_timeout := 5. *. t; (* if MiniSat does it, it's important *)
- timeout := Unix.gettimeofday () +. t
+ timeout := Aux.gettimeofday () +. t
let clear_timeout () = (timeout := 0.; minisat_timeout := 900.)
Modified: trunk/Toss/Formula/Sat/SatTest.ml
===================================================================
--- trunk/Toss/Formula/Sat/SatTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Formula/Sat/SatTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -215,6 +215,6 @@
let exec = (
- Aux.run_test_if_target "SatTest" tests;
- Aux.run_test_if_target "SatTest" bigtests;
+ AuxIO.run_test_if_target "SatTest" tests;
+ AuxIO.run_test_if_target "SatTest" bigtests;
)
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/GGP/GDLTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -511,4 +511,4 @@
(* failwith "tested"; *)
()
-let exec = Aux.run_test_if_target "GDLTest" tests
+let exec = AuxIO.run_test_if_target "GDLTest" tests
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/GGP/GameSimplTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -14,8 +14,7 @@
]
-let a () =
- Aux.run_test_if_target "GameSimplTest" tests
+let a () = AuxIO.run_test_if_target "GameSimplTest" tests
let a () =
match test_filter
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -108,4 +108,4 @@
let a () =
()
-let exec = Aux.run_test_if_target "TranslateFormulaTest" tests
+let exec = AuxIO.run_test_if_target "TranslateFormulaTest" tests
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -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 = Aux.input_file (open_in ("./GGP/tests/"^goal_name)) in
+ let goal_str = AuxIO.input_file (open_in ("./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 = Aux.input_file (open_in ("./GGP/tests/"^goal_name)) in
+ let goal_str = AuxIO.input_file (open_in ("./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;
@@ -461,7 +461,7 @@
let translate_dir_tests dirname from_file timeout =
let is_gdl fn = (String.length fn > 4) &&
String.sub fn ((String.length fn) - 4) 4 = ".gdl" in
- let files = List.sort compare (List.filter is_gdl (Aux.list_dir dirname)) in
+ let files = List.sort compare (List.filter is_gdl (AuxIO.list_dir dirname)) in
let from_file =
try let r = String.rindex from_file '/' in
String.sub from_file (r+1) ((String.length from_file)-r-1)
@@ -484,7 +484,7 @@
("TranslateGame " ^ dirname) >::: (List.map mk_tst files)
let exec () =
- Aux.run_test_if_target "TranslateGameTest"
+ AuxIO.run_test_if_target "TranslateGameTest"
("TranslateGame" >::: [tests; bigtests])
@@ -503,8 +503,8 @@
if !file <> "" && !testdir = "" then
print_endline (snd (translate_file !file (Some !timeout)))
else if !testdir <> "" then
- Aux.run_test_if_target "TranslateGameTest"
+ AuxIO.run_test_if_target "TranslateGameTest"
(translate_dir_tests !testdir !file !timeout)
else exec ()
-let _ = Aux.run_if_target "TranslateGameTest" main
+let _ = AuxIO.run_if_target "TranslateGameTest" main
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Makefile 2012-01-17 02:25:49 UTC (rev 1642)
@@ -3,6 +3,9 @@
TossServer: Server/Server.native
cp _build/Server/Server.native TossServer
+js_of_ocaml_test.js: js_of_ocaml_test.byte
+ js_of_ocaml js_of_ocaml_test.byte
+
RELEASE=0.6
Release: TossServer doc
rm -f *~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
@@ -32,12 +35,15 @@
# -------- MAIN OCAMLBUILD PART --------
-OCB_LFLAG=-lflags -I,+oUnit,-I,+sqlite3,-I,+site-lib/oUnit,-I,+site-lib/sqlite3
-OCB_CFLAG=-cflags -I,+oUnit,-I,+sqlite3,-I,+site-lib/oUnit,-I,+site-lib/sqlite3,-g
+OCB_LFLAG=-lflags -I,+oUnit,-I,+sqlite3,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/sqlite3
+OCB_CFLAG=-cflags -I,+oUnit,-I,+sqlite3,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/sqlite3,-g
OCB_LIB=-libs str,nums,unix,oUnit,sqlite3
-OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo"
+OCB_LIBJS=-libs str,js_of_ocaml
+OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo js_of_ocaml/pa_js.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
+OCAMLBUILDJS=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
+ $(OCB_LIBJS) $(OCB_CFLAG) $(OCB_LFLAG)
OCAMLBUILDNOPP=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
@@ -49,7 +55,7 @@
LearnINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
GGPINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play
ServerINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn
-.INC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Server
+.INC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn,Server
%.native: %.ml caml_extensions/pa_let_try.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
@@ -58,7 +64,7 @@
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
%.byte: %.ml caml_extensions/pa_let_try.cmo
- $(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
+ $(OCAMLBUILDJS) -Is $($(subst /,INC,$(dir $@))) $@
%.d.byte: %.ml caml_extensions/pa_let_try.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Play/GameTree.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -13,7 +13,7 @@
let l = Array.length a in
if l = 0 then [||] else if l = 1 then [|f a.(0)|] else (
let (a1, a2) = (Array.sub a 0 (l/2+1), Array.sub a (l/2+1) (l-(l/2+1))) in
- let r1 = Aux.toss_call !parallel_toss (Array.map f) a1 in
+ let r1 = AuxIO.toss_call !parallel_toss (Array.map f) a1 in
(* If the server handling COMP is single-threaded, they must wait for it!
In such case replace the last line with the two lines below.
try let r2 = Array.map f a2 in Array.append (r1 ()) (r2) with exn ->
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Play/GameTreeTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -72,4 +72,4 @@
]
-let exec = Aux.run_test_if_target "GameTreeTest" tests
+let exec = AuxIO.run_test_if_target "GameTreeTest" tests
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Play/HeuristicTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -478,11 +478,9 @@
]
-let a =
- Aux.run_test_if_target "HeuristicTest" tests
+let a = AuxIO.run_test_if_target "HeuristicTest" tests
-let a =
- Aux.run_test_if_target "HeuristicTest" bigtests
+let a = AuxIO.run_test_if_target "HeuristicTest" bigtests
let a () =
DiscreteRule.debug_level := 4;
Modified: trunk/Toss/Play/MoveTest.ml
===================================================================
--- trunk/Toss/Play/MoveTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Play/MoveTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -14,8 +14,6 @@
assert_equal ~printer:(fun x -> x) (Move.move_str_short s mv)
"rule{x:1}"
);
-] ;;
+]
-let a =
- Aux.run_test_if_target "MoveTest" tests
-;;
+let a = AuxIO.run_test_if_target "MoveTest" tests
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Play/PlayTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -718,6 +718,6 @@
(* ----------------- RUN THE TESTS ------------- *)
-let exec = Aux.run_test_if_target "PlayTest" tests
+let exec = AuxIO.run_test_if_target "PlayTest" tests
-let execbig = Aux.run_test_if_target "PlayTest" bigtests
+let execbig = AuxIO.run_test_if_target "PlayTest" bigtests
Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Server/DB.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -43,7 +43,7 @@
"('computer', 'Computer', 'tPlay', 'co...@tp...', 'xxx')");
let insert_game g =
let f = open_in (games_path ^ "/" ^ g ^ ".toss") in
- let toss = Aux.input_file f in
+ let toss = AuxIO.input_file f in
close_in f;
exec ("insert into games(game, toss) values ('" ^ g ^ "','" ^ toss ^ "')");
print_endline ("Added " ^ g) in
@@ -59,7 +59,7 @@
print_endline "Deleted old games";
let reload_game g =
let f = open_in (games_path ^ "/" ^ g ^ ".toss") in
- let toss = Aux.input_file f in
+ let toss = AuxIO.input_file f in
close_in f;
exec ("insert into games(game, toss) values ('" ^ g ^ "','" ^ toss ^ "')");
print_endline ("Reloading games: added " ^ g) in
Modified: trunk/Toss/Server/PictureTest.ml
===================================================================
--- trunk/Toss/Server/PictureTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Server/PictureTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -48,4 +48,4 @@
) else ignore (OUnit.run_test_tt ~verbose:true tests)
-let _ = Aux.run_if_target "PictureTest" main
+let _ = AuxIO.run_if_target "PictureTest" main
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Server/ReqHandler.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -454,7 +454,7 @@
if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
if Sys.file_exists fname && not (Sys.is_directory fname) then (
let f = open_in fname in
- let content = Aux.input_file f in
+ let content = AuxIO.input_file f in
close_in f;
let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
| "ht" -> "text/html; charset=utf-8"
@@ -841,7 +841,7 @@
(* String.escaped *) line_in
else
(* String.escaped *) (String.sub line_in 0 (line_in_len-1)) in
- match Aux.input_if_http_message line_in in_ch with
+ match AuxIO.input_if_http_message line_in in_ch with
| Some (head, msg, cookies) ->
if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
let ck = List.map (fun (k, v) -> (strip_ws k, strip_ws v)) cookies in
Modified: trunk/Toss/Server/ReqHandlerTest.ml
===================================================================
--- trunk/Toss/Server/ReqHandlerTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Server/ReqHandlerTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -13,9 +13,9 @@
with End_of_file -> ());
close_in in_ch; close_out out_ch;
let result =
- Aux.input_file (open_in "./Server/ServerTest.temp") in
+ AuxIO.input_file (open_in "./Server/ServerTest.temp") in
let target =
- Aux.input_file (open_in "./Server/ServerTest.out") in
+ AuxIO.input_file (open_in "./Server/ServerTest.out") in
Sys.remove "./Server/ServerTest.temp";
assert_equal ~printer:(fun x->x)
(strip_spaces target) (strip_spaces result)
@@ -37,9 +37,9 @@
with End_of_file -> ());
close_in in_ch; close_out out_ch;
let result =
- Aux.input_file (open_in "./Server/ServerGDLTest.temp") in
+ AuxIO.input_file (open_in "./Server/ServerGDLTest.temp") in
let target =
- Aux.input_file (open_in "./Server/ServerGDLTest.out2") in
+ AuxIO.input_file (open_in "./Server/ServerGDLTest.out2") in
Sys.remove "./Server/ServerGDLTest.temp";
assert_equal ~printer:(fun x->x)
(strip_spaces target) (strip_spaces result);
@@ -49,8 +49,7 @@
]
-let a =
- Aux.run_test_if_target "ReqHandlerTest" tests
+let a = AuxIO.run_test_if_target "ReqHandlerTest" tests
let a () =
GDL.debug_level := 4
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Server/Server.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -35,7 +35,7 @@
Unix.setsockopt_optint sock Unix.SO_LINGER (Some 2);
Unix.setsockopt_float sock Unix.SO_RCVTIMEO (120.);
Unix.setsockopt sock Unix.SO_REUSEADDR true;
- Unix.bind sock (Unix.ADDR_INET (Aux.get_inet_addr (addr_s), port));
+ Unix.bind sock (Unix.ADDR_INET (AuxIO.get_inet_addr (addr_s), port));
Unix.listen sock 9; (* maximally 9 pending requests *)
let continue = ref true in
while !continue do
@@ -243,7 +243,7 @@
);
try
start_server req_handle !port !server
- with Aux.Host_not_found ->
+ with AuxIO.Host_not_found ->
print_endline "The host you specified was not found."
)
Modified: trunk/Toss/Solver/AssignmentsTest.ml
===================================================================
--- trunk/Toss/Solver/AssignmentsTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Solver/AssignmentsTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -141,4 +141,4 @@
]
-let exec = Aux.run_test_if_target "AssignmentsTest" tests
+let exec = AuxIO.run_test_if_target "AssignmentsTest" tests
Modified: trunk/Toss/Solver/ClassTest.ml
===================================================================
--- trunk/Toss/Solver/ClassTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Solver/ClassTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -449,7 +449,7 @@
ignore (OUnit.run_test_tt ~verbose:true bigtests);
) else (
let f = open_in !file in
- let s = Aux.input_file f in
+ let s = AuxIO.input_file f in
close_in f;
let i = Str.search_forward (Str.regexp_string "|=") s 0 in
let cl_s = String.sub s 0 i in
@@ -464,4 +464,4 @@
)
-let _ = Aux.run_if_target "ClassTest" main
+let _ = AuxIO.run_if_target "ClassTest" main
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Solver/SolverTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -405,6 +405,6 @@
]
-let exec = Aux.run_test_if_target "SolverTest" tests
+let exec = AuxIO.run_test_if_target "SolverTest" tests
-let execbig = Aux.run_test_if_target "SolverTest" bigtests
+let execbig = AuxIO.run_test_if_target "SolverTest" bigtests
Modified: trunk/Toss/Solver/StructureTest.ml
===================================================================
--- trunk/Toss/Solver/StructureTest.ml 2012-01-17 00:38:17 UTC (rev 1641)
+++ trunk/Toss/Solver/StructureTest.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -426,5 +426,4 @@
]
-let a =
- Aux.run_test_if_target "StructureTest" tests
+let a = AuxIO.run_test_if_target "StructureTest" tests
Added: trunk/Toss/js_of_ocaml_test.html
===================================================================
--- trunk/Toss/js_of_ocaml_test.html (rev 0)
+++ trunk/Toss/js_of_ocaml_test.html 2012-01-17 02:25:49 UTC (rev 1642)
@@ -0,0 +1,13 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>Test</title>
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+ <script type="text/javascript" src="js_of_ocaml_test.js"></script>
+ </head>
+ <body>
+ <p id="testp"></p>
+ </body>
+</html>
Added: trunk/Toss/js_of_ocaml_test.ml
===================================================================
--- trunk/Toss/js_of_ocaml_test.ml (rev 0)
+++ trunk/Toss/js_of_ocaml_test.ml 2012-01-17 02:25:49 UTC (rev 1642)
@@ -0,0 +1,17 @@
+let rec fib n = if n < 2 then 1 else fib (n-1) + fib (n-2)
+
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+let nnf s = Formula.str (FormulaOps.nnf (formula_of_string s))
+
+let fibstr () = Js.string (nnf "not (P(x) and Q(x))")
+
+let onload _ =
+ let d = Dom_html.document in
+ let div = Js.Opt.get (d##getElementById (Js.string "testp"))
+ (fun () -> assert false) in
+ Dom.appendChild div (d##createTextNode (fibstr ()));
+ Js._false
+
+let _ = Dom_html.window##onload <- Dom_html.handler onload
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-17 22:23:35
|
Revision: 1643
http://toss.svn.sourceforge.net/toss/?rev=1643&view=rev
Author: lukstafi
Date: 2012-01-17 22:23:28 +0000 (Tue, 17 Jan 2012)
Log Message:
-----------
js_of_ocaml-friendly changes: pa_macro-based conditional compilation of RealQuantElim and Unix references.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/Makefile
trunk/Toss/Solver/Solver.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Formula/Aux.ml 2012-01-17 22:23:28 UTC (rev 1643)
@@ -1,7 +1,11 @@
(* Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
-let gettimeofday () = Unix.gettimeofday (); (* 1. *)
+let gettimeofday () =
+ IFDEF NOUNIX
+ THEN 1.
+ ELSE Unix.gettimeofday ()
+ ENDIF
exception Timeout of string
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Formula/Aux.mli 2012-01-17 22:23:28 UTC (rev 1643)
@@ -52,7 +52,7 @@
(** Random element of a list. *)
val random_elem : 'a list -> 'a
-(** Concatenate results of a function. *)
+(** Concatenate results of a function. Tail-recursive. *)
val concat_map : ('a -> 'b list) -> 'a list -> 'b list
(** Map a second list and prepend the result to the first list, by
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-01-17 22:23:28 UTC (rev 1643)
@@ -55,7 +55,7 @@
{ Formula.Sum ($3, $5, $7) }
| COLON OPEN formula_expr CLOSE { Char (Formula.flatten $3) }
| OPEN real_expr CLOSE { $2 }
- | COLON LET_CMD COLON v = ID EQ def = real_expr IN re = real_expr
+ | COLON LET_CMD COLON v = ID EQ def = real_expr IN_MOD re = real_expr
{ RLet (":" ^ v, def, re) }
real_ineq:
@@ -88,13 +88,13 @@
| MINUS ID OPEN fo_var_list CLOSE { Rel ("-"^$2, Array.of_list $4) }
| ID EQ ID { Eq (fo_var_of_s $1, fo_var_of_s $3) }
| ID NEQ ID { Not(Eq (fo_var_of_s $1,fo_var_of_s $3))}
- | ID IN ID { In (fo_var_of_s $1, mso_var_of_s $3) }
+ | ID IN_MOD ID { In (fo_var_of_s $1, mso_var_of_s $3) }
| real_ineq { let (p, s) = $1 in RealExpr (p, s) }
| NOT formula_expr { Not ($2) }
| EX var_list formula_expr { Ex ($2, $3) }
| ALL var_list formula_expr { All ($2, $3) }
| TC ID COMMA ID formula_expr { FormulaSubst.make_lfp_tc $2 $4 $5 }
- | TC IN ID COMMA ID formula_expr { FormulaSubst.make_mso_tc $3 $5 $6 }
+ | TC IN_MOD ID COMMA ID formula_expr { FormulaSubst.make_mso_tc $3 $5 $6 }
| TC INT ID COMMA ID formula_expr { FormulaSubst.make_fo_tc_conj $2 $3 $5 $6 }
| LFP ID OPEN fo_var_list CLOSE EQ formula_expr
{ let vs = Array.of_list $4 in if Array.length vs <> 1 then
@@ -120,7 +120,7 @@
{ Or [And [Not ($1); Not ($3)]; And [$1; $3]] }
| OPEN formula_expr CLOSE { $2 }
| LET_CMD rel = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
- EQ body = formula_expr IN phi = formula_expr
+ EQ body = formula_expr IN_MOD phi = formula_expr
{ Let (rel, args, body, phi) } %prec LET_CMD
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Formula/Lexer.mll 2012-01-17 22:23:28 UTC (rev 1643)
@@ -1,9 +1,11 @@
{
+ let test = "test"
+
type token =
- | ID of (string)
- | INT of (int)
- | FLOAT of (float)
- | BOARD_STRING of (string)
+ | ID of string
+ | INT of int
+ | FLOAT of float
+ | BOARD_STRING of string
| APOSTROPHE
| COLON
| SEMICOLON
@@ -37,7 +39,7 @@
| CLOSESQ
| OPEN
| CLOSE
- | IN
+ | IN_MOD
| AND
| OR
| XOR
@@ -176,7 +178,7 @@
| '}' { CLOSECUR }
| '[' { OPENSQ }
| ']' { CLOSESQ }
- | "in" { IN }
+ | "in" { IN_MOD }
| "and" { AND }
| "or" { OR }
| "xor" { XOR }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Formula/Tokens.mly 2012-01-17 22:23:28 UTC (rev 1643)
@@ -7,7 +7,7 @@
%token SUM PLUS MINUS TIMES DIV POW GR GREQ LT EQLT EQ LTGR NEQ
%token LARR LDARR RARR RDARR LRARR LRDARR INTERV
%token OPENCUR CLOSECUR OPENSQ CLOSESQ OPEN CLOSE
-%token IN AND OR XOR NOT EX ALL TC
+%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 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
@@ -26,7 +26,7 @@
%left OR
%left AND
%left COMMA
-%nonassoc EQ IN
+%nonassoc EQ IN_MOD
%left NOT EX ALL
%%
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Makefile 2012-01-17 22:23:28 UTC (rev 1643)
@@ -35,14 +35,16 @@
# -------- MAIN OCAMLBUILD PART --------
-OCB_LFLAG=-lflags -I,+oUnit,-I,+sqlite3,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/sqlite3
-OCB_CFLAG=-cflags -I,+oUnit,-I,+sqlite3,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/sqlite3,-g
+# 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,+sqlite3,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/sqlite3
+OCB_CFLAG=-cflags -I,/usr/local/lib/ocaml/3.12.0/js_of_ocaml,-I,+oUnit,-I,+sqlite3,-I,+js_of_ocaml,-I,+site-lib/oUnit,-I,+site-lib/sqlite3,-g
OCB_LIB=-libs str,nums,unix,oUnit,sqlite3
OCB_LIBJS=-libs str,js_of_ocaml
-OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo js_of_ocaml/pa_js.cmo"
+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 -DNOREALQE -DNOUNIX js_of_ocaml/pa_js.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
-OCAMLBUILDJS=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
+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)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/Solver/Solver.ml 2012-01-17 22:23:28 UTC (rev 1643)
@@ -265,10 +265,14 @@
| [] ->
let poly = poly_of assgn p in
if check then
- if not (RealQuantElim.sat [(poly, sgn)]) then Empty else
- if RealQuantElim.sat [(poly, SignTable.neg_sign_op sgn)] then
- Real [[(poly, sgn)]]
- else Any
+ (IFDEF NOREALQE
+ THEN failwith "Solver.ml: RealQuantElim is not enabled"
+ ELSE
+ ( if not (RealQuantElim.sat [(poly, sgn)]) then Empty else
+ if RealQuantElim.sat [(poly, SignTable.neg_sign_op sgn)] then
+ Real [[(poly, sgn)]]
+ else Any)
+ ENDIF)
else Real [[(poly, sgn)]]
| v :: vs ->
let append_elem_asg acc e =
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2012-01-17 02:25:49 UTC (rev 1642)
+++ trunk/Toss/www/reference/reference.tex 2012-01-17 22:23:28 UTC (rev 1643)
@@ -1226,7 +1226,10 @@
\[ \tp^{n-1,k}(\frakA,\ol{a}) \ \land\
\Land_{\sfx \in V} \Land_{g \in G_\sfx} \tau_{\sfx, g}. \]
+\section{Distinguishing Structures}
+
+
\section{Learning Games}
Let us start by showing how to learn two-player zero-sum games with payoffs only
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-18 02:45:54
|
Revision: 1645
http://toss.svn.sourceforge.net/toss/?rev=1645&view=rev
Author: lukaszkaiser
Date: 2012-01-18 02:45:45 +0000 (Wed, 18 Jan 2012)
Log Message:
-----------
Redoing learn tests, plays in separate files, removing Picture.
Modified Paths:
--------------
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGame.mli
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Server/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/WebClient/Main.js
Added Paths:
-----------
trunk/Toss/Learn/examples/
trunk/Toss/Learn/examples/Breakthrough001_01.nwn
trunk/Toss/Learn/examples/Breakthrough001_01.wn0
trunk/Toss/Learn/examples/Breakthrough001_01.wn1
trunk/Toss/Learn/examples/Breakthrough001_02.nwn
trunk/Toss/Learn/examples/Breakthrough001_03.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn1
Removed Paths:
-------------
trunk/Toss/Server/Picture.ml
trunk/Toss/Server/Picture.mli
trunk/Toss/Server/PictureTest.ml
trunk/Toss/Server/def_pics/
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Formula/AuxIO.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -27,6 +27,11 @@
with End_of_file -> ());
Buffer.contents buf
+let input_fname fn =
+ let f = open_in fn in
+ let res = input_file f in
+ close_in f; res
+
let list_dir dirname =
let files, dir_handle = (ref [], Unix.opendir dirname) in
let rec add () = files := (Unix.readdir dir_handle) :: !files; add () in
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Formula/AuxIO.mli 2012-01-18 02:45:45 UTC (rev 1645)
@@ -12,6 +12,9 @@
(** 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
+
(** List the contents of a directory *)
val list_dir : string -> string list
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Learn/LearnGame.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -68,51 +68,48 @@
[] (evens ~acc:[i] (List.length party)) ) )
[] partylist)
-let learnFromParties ~win0 ~win1 ~tie ~wrong =
+let learnFromParties ~win0 ~win1 ~notwon ~wrong =
let win0f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win0)
(List.flatten ((List.map (fun x-> List.tl (List.rev x))
- win0) @ win1 @ tie)) in
+ win0) @ win1 @ notwon)) in
let win1f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win1)
(List.flatten ((List.map (fun x-> List.tl (List.rev x))
- win1) @ win0 @ tie)) in
+ win1) @ win0 @ notwon)) in
- let moves0 = movesi 0 (win0 @ win1) in
- let moves1 = movesi 1 (win0 @ win1) in
+ let moves0 = movesi 0 (win0 @ win1 @ notwon) in
+ let moves1 = movesi 1 (win0 @ win1 @ notwon) in
- "PLAYERS 1, 2\n"^
+ let cmpll l1 l2 = (List.length l2) - (List.length l1) in
+ let longest = List.hd (List.sort cmpll (win0 @ win1 @ notwon)) in
+
+ "PLAYERS 1, 2\n" ^
"REL Win1() = "^ (Formula.sprint win0f) ^"\n"^
"REL Win2() = "^ (Formula.sprint win1f) ^"\n"^
- "RULE Mv1: " ^
- (List.fold_left
- (fun old x->
- old ^ "\n"^
- (Structure.str (fst x))^" -> "^(Structure.str
- (snd x)) ^
- "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
- (fst x)) )) ^ " " ^
- "pre not Win2()" )
- "" moves0) ^"\n"^
- "RULE Mv2: " ^
- (List.fold_left
- (fun old x->
- old^"\n"^
- (Structure.str (fst x))^" -> "^(Structure.str
- (snd x)) ^
- "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
- (fst x)) )) ^ " " ^
- "pre not Win1()" )
- "" moves1) ^"\n"^
+ (fst (List.fold_left
+ (fun (old, i) x ->
+ (old ^ "\n" ^ "RULE Mv1-" ^ (string_of_int i) ^ ": \n" ^
+ (Structure.str (fst x)) ^ " -> " ^ (Structure.str (snd x)) ^ "\nemb "^
+ (String.concat "," (List.map fst (Structure.rel_signature (fst x)) ))^
+ "\npre not Win2()"), i+1)
+ ("", 0) moves0)) ^ "\n\n" ^
+ (fst (List.fold_left
+ (fun (old, i) x ->
+ (old ^ "\n" ^ "RULE Mv2-" ^ (string_of_int i) ^ ": \n" ^
+ (Structure.str (fst x)) ^ " -> " ^ (Structure.str (snd x)) ^ "\nemb "^
+ (String.concat "," (List.map fst (Structure.rel_signature (fst x)) ))^
+ "\npre not Win1()"), i+1)
+ ("",0) moves1)) ^ "\n\n" ^
"LOC 0 {
PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
MOVES [Mv1 -> 1]}
PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
}
-LOC 1{
+LOC 1 {
PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
MOVES [Mv2 -> 0] }
}" ^"\n" ^
- "MODEL "^(Structure.str (List.hd (List.hd win0)))
+ "MODEL "^(Structure.str (List.hd longest))
Modified: trunk/Toss/Learn/LearnGame.mli
===================================================================
--- trunk/Toss/Learn/LearnGame.mli 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Learn/LearnGame.mli 2012-01-18 02:45:45 UTC (rev 1645)
@@ -11,7 +11,7 @@
val learnFromParties:
win0: Structure.structure list list ->
win1: Structure.structure list list ->
- tie: Structure.structure list list ->
+ notwon: Structure.structure list list ->
wrong: Structure.structure list list -> string
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -48,18 +48,24 @@
"PLAYERS 1, 2
REL Win1() = ex x0 (Q(x0) and ex x1 R(x0, x1))
REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
-RULE Mv1:
+
+RULE Mv1-0:
[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
-emb R,Q,P pre not Win2()
-RULE Mv2:
+emb R,Q,P
+pre not Win2()
+
+
+RULE Mv2-0:
[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P:1 {}; Q (1); R:2 {} | ]
-emb R,Q,P pre not Win1()
+emb R,Q,P
+pre not Win1()
+
LOC 0 {
PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
MOVES [Mv1 -> 1]}
PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
}
-LOC 1{
+LOC 1 {
PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
MOVES [Mv2 -> 0] }
@@ -70,331 +76,46 @@
\"" in
assert_equal ~printer:(fun x -> x) res_game
((LearnGame.learnFromParties ~win0:partylist0 ~win1:partylist1
- ~tie:[] ~wrong:[]));
+ ~notwon:[] ~wrong:[]));
);
]
-let bigtests = "LearnGame" >::: [
- "tic-tac-toe" >::
- (fun () ->
- Distinguish.set_debug_level 0; (* set to 1 to get some info printed out *)
- let partylist0 = [
- List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-P . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q .
-. . .
-P . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q .
-. . .
-P P .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q Q
-. . .
-P P .
-. . .
-. . .
-. . .
-\"";
- ]; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-Q . .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-Q P .
-. . .
-. . .
-. . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q P .
-. . .
-Q P .
-. . .
-Q . .
-. . .
-\"";]; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-Q Q Q
-\"";]; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. Q .
-. . .
-. Q .
-. . .
-. Q .
-\"";]; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . Q
-. . .
-. Q .
-. . .
-Q . .
-\"";]
-] in
- let partylist1 = [
- List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . P
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q P
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q Q P
-. . .
-. Q Q
-. . .
-. . .
-P P P
-\"";
- ]; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-. . .
-\"" ;
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. . .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P . .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q .
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q Q
-. . .
-. . .
-P P .
-\"";
-"[ | P:1 {}; Q:1 {} | ] \"
-Q . .
-. . .
-. Q Q
-. . .
-. . .
-P P P
-\"";
- ]
- ; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . .
-. . .
-. . .
-. . .
-P P P
-\"";]
- ; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. P .
-. . .
-. P .
-. . .
-. P .
-\"";]
- ; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . P
-. . .
-. P .
-. . .
-P . .
-\"";]
-] in
-let tie = [
- List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. P .
-. . .
-. Q .
-. . .
-. P .
-\"";]
- ; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . Q
-. . .
-. P .
-. . .
-P . .
-\"";]
- ; List.map (struc_of_string ~diag:true) [
-"[ | P:1 {}; Q:1 {} | ] \"
-. . .
-. . P
-. . .
-. P .
-. . .
-Q . .
-\"";]
-] in
-assert_equal ~printer:(fun x -> x) ""
- ((LearnGame.learnFromParties ~win0:partylist0 ~win1:partylist1
- ~tie ~wrong:[]));
- );
+let get_strucs s =
+ let split_list ?(bound=None) pat s =
+ let r = Str.regexp_string pat in
+ match bound with None-> Str.split r s | Some b-> Str.bounded_split r s b in
+ let cl = String.index s '\n' in
+ let pref, st_s = String.sub s 0 cl, String.sub s cl ((String.length s)-cl) in
+ let s = List.filter (fun s -> s <> "") (split_list "\n\n" st_s) in
+ List.map (fun s -> struc_of_string ~diag:true (pref ^ " \n\"" ^ s ^"\n\"")) s
-]
+let main () =
+ Aux.set_optimized_gc ();
+ let (testname, dir) = (ref "", ref "examples") in
+ let dbg_level i = (LearnGame.set_debug_level i) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose");
+ ("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
+ ("-f", Arg.String (fun s -> testname := s), "process files");
+ ("-dir", Arg.String (fun s -> dir := s), "set files directory");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ if !testname <> "" then (
+ let tnlen = String.length !testname in
+ let is_test fn =
+ String.length fn > tnlen && String.sub fn 0 tnlen = !testname in
+ 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 strucs_of_files fs =
+ List.map (fun fn -> get_strucs (AuxIO.input_fname fn)) fs in
+ let (win0, win1, notwon, wrong) =
+ (strucs_of_files (List.filter (is_group "wn0") tfiles),
+ strucs_of_files (List.filter (is_group "wn1") tfiles),
+ strucs_of_files (List.filter (is_group "nwn") tfiles),
+ strucs_of_files (List.filter (is_group "wrg") tfiles)) in
+ print_endline (LearnGame.learnFromParties ~win0 ~win1 ~notwon ~wrong)
+ ) else ignore (OUnit.run_test_tt ~verbose:true tests)
+
+let _ = AuxIO.run_if_target "LearnGameTest" main
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Learn/Makefile 2012-01-18 02:45:45 UTC (rev 1645)
@@ -12,11 +12,22 @@
DistinguishTest:
LearnGameTest:
-
tests:
make -C .. LearnTestsVerbose
+LearnGameTest.native:
+ make -C .. Learn/LearnGameTest.native
+
+%.learn:
+ make -C .. Learn/LearnGameTest.native
+ ../LearnGameTest.native -f $(basename $@)
+
+learntests:
+ make Tic-Tac-Toe001.learn
+ make Breakthrough001.learn
+
+
.PHONY: clean
clean:
Added: trunk/Toss/Learn/examples/Breakthrough001_01.nwn
===================================================================
--- trunk/Toss/Learn/examples/Breakthrough001_01.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Breakthrough001_01.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,235 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+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
+
+
+ ... ... ... ...
+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
+
+
+ ... ... ... ...
+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
+
+
+ ... ... ... ...
+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
+
+
+ ... ... ... ...
+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
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..B ...B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... W..B ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W W.. W..W W..
+... ... ... ...
+W..W W..W W..W W..W
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..B ...B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... W.. ...
+ ... ... ... ...
+ ... ...B ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W W.. W..W W..
+... ... ... ...
+W..W W..W W..W W..W
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..B ...B B..B
+ ... ... ... ...
+ ... ...W ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ...B ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W W.. W..W W..
+... ... ... ...
+W..W W..W W..W W..W
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..B ...B B..B
+ ... ... ... ...
+ ... ...W ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... B.. ...
+ ... ... ... ...
+W W..W W.. W..W W..
+... ... ... ...
+W..W W..W W..W W..W
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..W ...B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... B.. ...
+ ... ... ... ...
+W W..W W.. W..W W..
+... ... ... ...
+W..W W..W W..W W..W
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..W ...B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W B.. W..W W..
+... ... ... ...
+W..W W..W W..W W..W
+
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+B..B B..W ...B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W W.. W..W W..
+... ... ... ...
+W..W ...W W..W W..W
+
+
+ ... ... ... ...
+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
+
Added: trunk/Toss/Learn/examples/Breakthrough001_01.wn0
===================================================================
--- trunk/Toss/Learn/examples/Breakthrough001_01.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Breakthrough001_01.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,18 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+B B.. W.. B..B B..
+... ... ... ...
+B..B ... ... B..B
+ ... ... ... ...
+ ...B ... ... ...
+... ... ... ...
+... ... B..B ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ... W..W W..
+... ... ... ...
+W..W ...W W..W W..W
Added: trunk/Toss/Learn/examples/Breakthrough001_01.wn1
===================================================================
--- trunk/Toss/Learn/examples/Breakthrough001_01.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Breakthrough001_01.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,18 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+... B..B ... ...
+ ... ... ... ...
+W ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W ... W..W ... ...
+... ... ... ...
+W.. ... ... W..
+ ... ... ... ...
+ ... ... ... W..
+... ... ... ...
+... ... B.. ...W
Added: trunk/Toss/Learn/examples/Breakthrough001_02.nwn
===================================================================
--- trunk/Toss/Learn/examples/Breakthrough001_02.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Breakthrough001_02.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,18 @@
+[ | B:1 {}; W: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..W
Added: trunk/Toss/Learn/examples/Breakthrough001_03.nwn
===================================================================
--- trunk/Toss/Learn/examples/Breakthrough001_03.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Breakthrough001_03.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,18 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+B B..B B..B B..B B..
+... ... ... ...
+... B..B ... ...
+ ... ... ... ...
+W ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W ... W..W ... ...
+... ... ... ...
+W.. ... ... W..
+ ... ... ... ...
+ ... ... ... W..
+... ... ... ...
+... ... ... ...W
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.nwn
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+P P Q
+. . .
+Q Q P
+. . .
+P Q Q
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn0
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,45 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+P . .
+. . .
+. . .
+. . .
+
+Q Q .
+. . .
+P . .
+. . .
+. . .
+. . .
+
+Q Q .
+. . .
+P P .
+. . .
+. . .
+. . .
+
+
+Q Q Q
+. . .
+P P .
+. . .
+. . .
+. . .
+
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn1
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,64 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+. . .
+. . .
+. . .
+P . .
+
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P . .
+
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P P .
+
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P .
+
+Q . P
+. . .
+. Q Q
+. . .
+. . .
+P P .
+
+Q Q P
+. . .
+. Q Q
+. . .
+. . .
+P P .
+
+Q Q P
+. . .
+. Q Q
+. . .
+. . .
+P P P
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.nwn
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+Q P P
+. . .
+P Q Q
+. . .
+Q Q P
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn0
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,43 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q P .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q P .
+. . .
+Q . .
+. . .
+. . .
+. . .
+
+Q P .
+. . .
+Q P .
+. . .
+. . .
+. . .
+
+Q P .
+. . .
+Q P .
+. . .
+Q . .
+. . .
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn1
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,50 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+
+Q . .
+. . .
+. . .
+. . .
+. . .
+P . .
+
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P . .
+
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P P .
+
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P .
+
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P P
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.nwn
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. P .
+. . .
+P . P
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn0
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. . .
+. . .
+Q Q Q
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn1
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . .
+. . .
+. . .
+. . .
+P P P
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.nwn
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+P . P
+. . .
+. P .
+. . .
+. . .
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn0
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,9 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. Q .
+. . .
+. Q .
+. . .
+. Q .
+
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn1
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. P .
+. . .
+. P .
+. . .
+. P .
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.nwn
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.nwn 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . P
+. . .
+. P .
+. . .
+. P .
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn0
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . Q
+. . .
+. Q .
+. . .
+Q . .
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn1
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+. . P
+. . .
+. P .
+. . .
+P . .
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn0
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn0 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+Q . .
+. . .
+. Q .
+. . .
+. . Q
Added: trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn1
===================================================================
--- trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn1 2012-01-18 02:45:45 UTC (rev 1645)
@@ -0,0 +1,8 @@
+[ | P:1 {}; Q:1 {} | ]
+
+. . .
+P . .
+. . .
+. P .
+. . .
+. . P
Modified: trunk/Toss/Server/Makefile
===================================================================
--- trunk/Toss/Server/Makefile 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Server/Makefile 2012-01-18 02:45:45 UTC (rev 1645)
@@ -3,7 +3,6 @@
%Test:
make -C .. Server/$@Verbose
-PictureTest:
ReqHandlerTest:
LearnGameTest:
Deleted: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Server/Picture.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -1,410 +0,0 @@
-(* Processing Pictures to create Structures *)
-
-let debug_level = ref 0
-let set_debug_level i = (debug_level := i;)
-
-
-(* --------- Basic Picture Functions --------- *)
-
-type picture = (int * int * int) array array
-
-(* Read a picture from a scanning buffer. *)
-let read_pic buf =
- let (width, height) = Scanf.bscanf buf "P3 %d %d 255" (fun x y -> (x, y)) in
- let pic = Array.make_matrix width height (0, 0, 0) in
- for j = 0 to height-1 do
- for i = 0 to width-1 do
- pic.(i).(j) <- Scanf.bscanf buf " %d %d %d" (fun x y z -> (x, y, z))
- done
- done;
- pic
-
-(* Print a matrix to the formatter [f], use [elem_f] for elements. *)
-let fprint_matrix f elem_f start mid m =
- let (width, height) = (Array.length m, Array.length (m.(0))) in
- Format.fprintf f "%s %d %d %s\n%!" start width height mid;
- for j = 0 to height-1 do
- for i = 0 to width-1 do
- Format.fprintf f "%a" elem_f m.(i).(j);
- done;
- Format.fprintf f "\n%!";
- done
-
-(* Print a picture in the simple PPM format to a formatter. *)
-let fprint_pic f pic =
- let pr fmt (a, b, c) = Format.fprintf fmt " %d %d %d\n" a b c in
- fprint_matrix f pr "P3" "255" pic
-
-(* Print a picture in the simple PPM format to standard output. *)
-let print_pic pic = fprint_pic Format.std_formatter pic
-
-
-(* Flip a picture. *)
-let flip pic =
- let (width, height) = (Array.length pic, Array.length (pic.(0))) in
- let flpic = Array.make_matrix height width (0, 0, 0) in
- for i = 0 to width-1 do
- for j = 0 to height-1 do
- flpic.(j).(i) <- pic.(i).(j)
- done
- done;
- flpic
-
-
-(* Cut a picture to the given rectangle. *)
-let cut (x1, y1) (x2, y2) pic =
- let (orig_w, orig_h) = (Array.length pic, Array.length (pic.(0))) in
- let x2 = if x2 <= 0 then orig_w + x2 - 1 else x2 in
- let y2 = if y2 <= 0 then orig_h + y2 - 1 else y2 in
- if x2 < x1+1 || y2 < y1+1 || orig_w<x2+1 || orig_h<y2+1 || x1<0 || y1<0 then
- failwith (Printf.sprintf "cut: wrong dimensions %i %i %i %i" x1 x2 y1 y2);
- let cutpic = Array.make_matrix (x2-x1+1) (y2-y1+1) (0, 0, 0) in
- for i = 0 to x2-x1 do
- for j = 0 to y2-y1 do
- cutpic.(i).(j) <- pic.(i+x1).(j+y1)
- done
- done;
- cutpic
-
-
-(* Apply the filter function [f] to each pixel in a picture. *)
-let apply_filter f pic =
- let (width, height) = (Array.length pic, Array.length (pic.(0))) in
- let fpic = Array.make_matrix width height (0, 0, 0) in
- for i = 0 to width-1 do
- for j = 0 to height-1 do
- fpic.(i).(j) <- f i j width height pic
- done
- done;
- fpic
-
-
-(* ------------ Change Detection ------------ *)
-
-let diff_filter maxdiff (distx, disty) x y w h pic =
- let res = ref false in
- for i = -distx to distx do
- for j = -disty to disty do
- if x+i >= 0 && x+i < w && y+j >= 0 && y+j < h then
- let (r1, g1, b1) = pic.(x).(y) in
- let (r2, g2, b2) = pic.(x+i).(y+j) in
- let (rd, gd, bd) = maxdiff in
- if rd >= abs (r1-r2) && gd >= abs (g1-g2) && bd >= abs (b1-b2) then
- res := false
- else res := true
- done
- done;
- if !res then (255, 255, 255) else (0, 0, 0)
-
-(* Calculate color difference, accept maxdiff differences up to dist. *)
-let diff ?(maxdiff=(1,1,1)) ?(dist=(1,1)) =
- apply_filter (diff_filter maxdiff dist)
-
-
-(* ------------ Simple Segmentation ------------ *)
-
-let all_in_color cl ((x1, y1), (x2, y2)) pic =
- let (w, h) = (Array.length pic, Array.length (pic.(0))) in
- if x2 < x1 || y2 < y1 || w < x2+1 || h < y2+1 || x1 < 0 || y1 < 0 then
- failwith (Printf.sprintf "all_in_color: wrong dim %i %i %i %i" x1 y1 x2 y2);
- let res = ref true in
- for i = x1 to x2 do
- for j = y1 to y2 do
- if pic.(i).(j) <> cl then res := false
- done
- done;
- !res
-
-let rec next_x cl i j w h pic =
- if pic.(i).(j) = cl then (i, j) else
- if i+1 < w then next_x cl (i+1) j w h pic else raise Not_found
-
-let rec next_y cl i j w h pic =
- if pic.(i).(j) = cl then (i, j) else
- if j+1 < h then next_y cl i (j+1) w h pic else raise Not_found
-
-let next_color cl i j w h pic =
- try
- let (i1, _) = next_x cl i j w h pic in
- if i1+1 < w && pic.(i1+1).(j) = cl then (i1, j) else raise Not_found
- with Not_found ->
- let (_, j1) = next_y cl 0 (j+1) w h pic in
- if j1+1 < h && pic.(i).(j1+1) = cl then (0, j1) else raise Not_found
-
-(* Make a row-first column-next black-white tour of a picture. *)
-let bw_tour pic =
- let (width, height) = (Array.length pic, Array.length (pic.(0))) in
- let (i, j, newi, newj) = (ref 0, ref 0, ref 0, ref 0) in
- let (rects, intv) = (ref [], ref []) in
- try
- while true do
- intv := [];
- while !j = !newj do
- let (ni, nj) = next_color (0, 0, 0) !i !j width height pic in
- newi := ni;
- let (nni, nnj) = next_color (255, 255, 255) ni nj width height pic in
- if nnj = !j then intv := (ni, nni-1) :: !intv;
- i := nni; j := !newj; newj := nnj;
- done;
- if !intv != [] then intv := (!newi, width-1) :: !intv;
- rects := (List.map (fun v-> v, (!j,!newj-1)) !intv) @ !rects;
- j := !newj; i := 0
- done;
- failwith "bw_tour: unreachable"
- with Not_found ->
- if !intv != [] then intv := (!newi, width-1) :: !intv;
- rects := (List.map (fun v-> v, (!j,height-1)) !intv) @ !rects;
- List.rev_map (fun ((a, b), (c, d)) -> (a, c), (b, d)) !rects
-
-let rect_dist ((x1, y1), (x2, y2)) ((a1, b1), (a2, b2)) pic =
- let (w, h, d) = (min (x2-x1) (a2-a1), min (y2-y1) (b2-b1), ref 0) in
- for i = 0 to w-1 do
- for j = 0 to h-1 do
- let (x, y, z), (a, b, c) = pic.(x1+i).(y1+j), pic.(a1+i).(b1+j) in
- d := !d + (abs (x-a)) + (abs (y-b)) + (abs (z-c))
- done
- done;
- (float !d) /. (float (w*h))
-
-let rect_dist_offset (x, y) ((x1, y1), (x2, y2)) ((a1, b1), (a2, b2)) pic =
- rect_dist ((x1+x, y1+y), (x2+x, y2+y)) ((a1+x, b1+y), (a2+x, b2+y)) pic
-
-(* Very basic picture segmentation, should work for grids. *)
-let segment offset threshold pic =
- let df = diff (cut (offset, offset) (-offset, -offset) pic) in
- let rects = bw_tour df in
- let assign_name (dict, i, bi) rect =
- let (a, b), (c, d) = rect in
- try
- let (r, n) =
- List.find (fun (r,_) ->
- rect_dist_offset (offset, offset) r rect pic < threshold) dict in
- if !debug_level > 0 then
- Printf.printf " (%i, %i) - (%i, %i) %s found \n%!" a b c d n;
- ((rect, n) :: dict, i, bi)
- with Not_found ->
- if all_in_color (0, 0, 0) rect df then (
- let n = Printf.sprintf "B%i" bi in
- if !debug_level > 0 then
- Printf.printf " (%i, %i) - (%i, %i) %s assigned \n%!" a b c d n;
- ((rect, n) :: dict, i, bi+1)
- ) else (
- let n = Printf.sprintf "P%i" i in
- if !debug_level > 0 then
- Printf.printf " (%i, %i) - (%i, %i) %s assigned \n%!" a b c d n;
- ((rect, n) :: dict, i+1, bi)
- ) in
- let (res, _, _) = List.fold_left assign_name ([], 1, 0) rects in
- List.rev res
-
-
-(* ------------- Structure from Segmented Data ------------ *)
-
-(* Create a structure from segmented data. *)
-let make_struc dict =
- let (prev_ys, prev_xs, maxdx, maxdy) =
- (ref (0, 0), ref (0, 0), ref 0, ref 0) in
- let add_el (struc, i, j) (((x1, y1), (x2, y2)), pred) =
- let (ni, nj) =
- if (y1, y2) = !prev_ys then (
- maxdx := max !maxdx (abs ((fst !prev_xs) - x1));
- prev_xs := (x1, x2);
- (i+1, j)
- ) else (
- maxdy := max !maxdy (abs ((fst !prev_ys) - y1));
- prev_xs := (x1, x2);
- prev_ys := (y1, y2);
- (1, j+1)
- ) in
- let name = try Structure.board_coords_name (ni, nj) with Not_found ->
- Printf.sprintf "e%i,%i" ni nj in
- let (s1, elem) = Structure.add_new_elem struc ~name () in
- let s2 = Structure.add_fun s1 "x" (elem, float (x1+x2) /. 2.) in
- let s3 = Structure.add_fun s2 "y" (elem, float (y1+y2) /. (2.)) in
- let s4 = Structure.add_fun s3 "x1" (elem, float x1) in
- let s5 = Structure.add_fun s4 "y1" (elem, float y1) in
- let s6 = Structure.add_fun s5 "x2" (elem, float x2) in
- let s7 = Structure.add_fun s6 "y2" (elem, float y2) in
- let s8 = Structure.add_fun s7 "vx" (elem, 0.) in
- let new_s = Structure.add_fun s8 "vy" (elem, 0.) in
- if pred = "B0" then (new_s, ni, nj) else
- (Structure.add_rel new_s pred [|elem|], ni, nj) in
- let (s, _, _) =
- List.fold_left add_el (Structure.empty_structure (), 1, 0) dict in
- (s, !maxdx, !maxdy)
-
-
-(* Minimal type of elements in a structure which is part-positive. *)
-let postp s rels els =
- let app_rel_phi (st, fos, vs, i) e =
- let r, v = "Elem" ^ (string_of_int i), Structure.elem_name st e in
- (Structure.add_rel st r [|e|],
- Formula.Rel (r, [|Formula.fo_var_of_string v|]) :: fos, v :: vs, i+1) in
- let (struc, els_phis, vars, _) = List.fold_left app_rel_phi (s,[],[],0) els in
- let neg_true = function Formula.Not _ -> Formula.And [] | x -> x in
- let pos phi =
- Formula.flatten (FormulaMap.map_to_literals neg_true (fun x->x) phi) in
- let pos_ok phi = let psi = pos phi in if psi = Formula.And [] then false else
- Solver.M.check struc (Formula.And (psi :: els_phis)) in
- let ts = List.map pos (FormulaOps.mintp pos_ok rels vars) in
- let tfvs = List.map (fun f-> (f,List.length (FormulaSubst.free_vars f))) ts in
- let maxfv = List.fold_left (fun m (_, x) -> max m x) 0 tfvs in
- List.map fst (List.filter (fun (f, x) -> x = maxfv) tfvs)
-
-let tp_rule drels (left, right, delems) =
- let not_drel (r,_) = not (List.mem r drels) in
- let crels = List.filter not_drel (Structure.rel_signature left) in
- if !debug_level > 0 then Printf.printf "CRels %i\n%!" (List.length crels);
- let tp = postp left crels delems in
- if !debug_level > -1 then
- Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And tp);
- let cut s = List.fold_left Structure.del_elem s
- (List.filter (fun e -> not (List.mem e delems)) (Structure.elements s)) in
- (cut left, cut right, tp)
-
-let geom_rule drels (left, right, delems) =
- let get_dim s e = (Structure.fun_val s "x" e, Structure.fun_val s "y" e) in
- let rect s els =
- let upd_rect (x1, y1, x2, y2) e =
- let (x, y) = get_dim s e in (min x1 x, min y1 y, max x2 x, max y2 y) in
- let (x, y) = get_dim s (List.hd els) in
- List.fold_left upd_rect (x, y, x, y) (List.tl els) in
- let in_rect s (x1, y1, x2, y2) e =
- let (x, y) = get_dim s e in (x1 < x && x < x2 && y1 < y && y < y2) in
- let (x1, y1, x2, y2) = rect left delems in
- let r = (x1 -. 0.5, y1 -. 0.5, x2 +. 0.5, y2 +. 0.5) in
- let els = List.filter (in_rect left r) (Structure.elements left) in
- let new_els = List.filter (fun e -> not (List.mem e delems)) els in
- if !debug_level > 0 then
- Format.printf "%s\n%!" (String.concat ", " (List.map string_of_int els));
- let cut s = List.fold_left Structure.del_elem s
- (List.filter (fun e -> not (List.mem e els)) (Structure.elements s)) in
- let is_unary r = List.assoc r (Structure.rel_signature left) = 1 in
- let un_drels = Aux.unique_sorted (List.filter is_unary drels) in
- let delopt s r = Structure.del_rels s r (List.map (fun e -> [|e|]) new_els) in
- let delopts s = List.fold_left delopt s un_drels in
- (delopts (cut left), delopts (cut right), delems)
-
-let addopts drels (left, right, delems) =
- let is_unary r = List.assoc r (Structure.rel_signature left) = 1 in
- let un_drels = Aux.unique_sorted (List.filter is_unary drels) in
- let un_opt_drels = List.map (fun r -> "_opt_" ^ r) un_drels in
- let els = Structure.elements left in
- let new_els = List.filter (fun e -> not (List.mem e delems)) els in
- let addopt s r = Structure.add_rels s r (List.map (fun e -> [|e|]) new_els) in
- let addoptrels s = List.fold_left addopt s un_opt_drels in
- (addoptrels left, addoptrels right, [])
-
-let print_rule emb (name, (l, r, pre_l)) =
- let emb_s = String.concat ", " (Aux.unique_sorted emb) in
- let pre_s = Formula.sprint (Formula.And pre_l) in
- let sprints () s = Structure.sprint s in
- Format.sprintf "RULE %s:@ @[<2>%a@]@ ->@ @[<2>%a@]@ emb %s pre %s"
- name sprints l sprints r emb_s pre_s
-
-let formula_of_string s =
- FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-
-let read_strucs rels offset threshold gname suffix =
- let get_struc fn =
- let pic = read_pic (Scanf.Scanning.from_file fn) in
- let (struc, dx, dy) = make_struc (segment offset threshold pic) in
- let formula_r = formula_of_string (Printf.sprintf (
- ":y(a) = :y(b) and :x(a) < :x(b) and :x(b) < :x(a) + %i.8") dx) in
- let formula_c = formula_of_string (Printf.sprintf (
- ":x(a) = :x(b) and :y(b) < :y(a) and :y(a) < :y(b) + %i.8") dy) in
- let row, col = ("R", ["a"; "b"], formula_r), ("C", ["a"; "b"], formula_c) in
- Arena.add_def_rels struc (row :: col :: rels) in
- let name i = Printf.sprintf "%s%s%02i.ppm" gname suffix i in
- let (strucs, i) = (ref [], ref 0) in
- while Sys.file_exists (name !i) do
- strucs := get_struc (name !i) :: !strucs; incr i;
- done;
- List.rev !strucs
-
-let make_cond drels (right, wrong, delem_rels) =
- let sg = Structure.rel_signature right in
- let is_unary r = List.assoc r sg = 1 in
- let name e = Structure.elem_name right e in
- let mk_atom e r = Formula.Rel (r, [|Formula.fo_var_of_string (name e)|]) in
- let preds (e, rels) =
- Formula.And (List.map (mk_atom e) (List.filter is_unary rels)) in
- let ex_var (e, _) = Formula.var_of_string (name e) in
- let ex_vars = List.map ex_var delem_rels in
- let basic = Formula.flatten (Formula.And (
- (List.fold_left (fun l x -> (preds x) :: l) [] delem_rels))) in
- if not (Solver.M.check wrong basic) then Formula.Ex (ex_vars, basic) else (
- let app_s s =
- let app_rel_phi (st, arels, fos, vs, i) (e, _) =
- let r, v = "Elem" ^ (string_of_int i), Structure.elem_name st e in
- (Structure.add_rel st r [|e|], (r, 1) :: arels,
- Formula.Rel (r, [|Formula.fo_var_of_string v|]) :: fos, v::vs, i+1) in
- List.fold_left app_rel_phi (s, [], [], [], 0) delem_rels in
- let (right_el, arels, afos, vars, _) = app_s right in
- let (wrong_el, _, _, _, _) = app_s wrong in
- let csg = List.filter (fun (r,_) -> not (List.mem r drels)) sg in
- let ok phi_in =
- let phi = Formula.And [phi_in; basic] in
- let psi = Formula.And (phi :: afos) in
- Solver.M.check right_el psi && not (Solver.M.check wrong_el phi) in
- let w = FormulaOps.mintp ok csg vars in
- let minimize phi =
- let atoms = FormulaMap.get_atoms phi in
- let subst_atom a b x = if x = a then b else x in
- let phi0 f a = FormulaMap.map_to_atoms (subst_atom a (Formula.Or[])) f in
- let phi1 f a = FormulaMap.map_to_atoms (subst_atom a (Formula.And[])) f in
- let mini f a =
- let (f0, f1) = (phi0 f a, phi1 f a) in
- Formula.flatten (if ok f0 then f0 else if ok f1 then f1 else f) in
- List.fold_left mini phi atoms in
- let mw = List.map minimize w in
- if !debug_level > -1 then
- Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And (basic :: mw));
- if !debug_level > -1 then
- Format.eprintf "@[%a@]@ \n%!" Formula.fprint
- (Aux.unsome (Distinguish.distinguish_upto ~qr:1 ~k:2 [right] [wrong]));
- Formula.flatten (Formula.Ex (ex_vars, Formula.And (basic :: mw)))
- )
-
-(* Make a game from sequence of pictures. *)
-let make_game ?(rels=[]) ?(offset=2) ?(threshold=70.) ?(types=false) fname =
- let flen = String.length fname in
- let gname = if (flen > 6 && fname.[flen-4] = '.') then
- String.sub fname 0 (flen - 6) else fname in
- let seq = read_strucs rels offset threshold gname "" in
- let win1s = Array.of_list (read_strucs rels offset threshold gname "Win1") in
- let win2s = Array.of_list (read_strucs rels offset threshold gname "Win2") in
- if seq = [] then failwith "Empty picture sequence for game play.";
- if !debug_level > 0 then Printf.printf "Read %i move pics, %i+%i win.\n%!"
- (List.length seq) (Array.length win1s) (Array.length win2s);
- let diff_struc (s, drels, prev) cur =
- let dels, drels_l = List.split (Structure.diff_elems prev cur) in
- ((prev, cur, dels) :: s, (List.concat drels_l) @ drels, cur) in
- if !debug_level > 0 then Printf.printf "Diffstrucs computed.\n%!";
- let (s, dr,_) = List.fold_left diff_struc ([],[],List.hd seq) (List.tl seq) in
- let rules_geom = List.rev_map (geom_rule dr) s in
- let rules = if not types then List.map (addopts dr) rules_geom else
- List.map (tp_rule dr) rules_geom in
- let wi i =
- formula_of_string (if i mod 2 = 0 then "not Win2()" else "not Win1()") in
- let add_win i (l, r, pre) = (Printf.sprintf "Mv%i" i, (l, r, (wi i)::pre)) in
- let wrs = Array.mapi (fun i r -> add_win i r) (Array.of_list rules) in
- let emb = List.map fst (Structure.rel_signature (List.hd seq)) @ dr in
- let rs = String.concat "\n" (List.map (print_rule emb) (Array.to_list wrs)) in
- let allms = Array.to_list (Array.mapi (fun i _ -> i) (Array.of_list rules)) in
- let (mvi1, mvi2) = List.partition (fun i -> i mod 2 = 0) allms in
- let make_mv loc i = Printf.sprintf "[Mv%i -> %s]" i loc in
- let mvs1 = String.concat "; " (List.map (make_mv "1") mvi1) in
- let mvs2 = String.concat "; " (List.map (make_mv "0") mvi2) in
- let pay1 = "PAYOFF :(Win1()) - :(Win2())" in
- let pay2 = "PAYOFF :(Win2()) - :(Win1())" in
- let loc0 = Printf.sprintf "LOC 0 {\n PLAYER 1 { %s }\n PLAYER 2 { %s }\n}"
- (pay1 ^ "\n MOVES " ^ mvs1 ^ "\n") pay2 in
- let loc1 = Printf.sprintf "LOC 1 {\n PLAYER 1 { %s }\n PLAYER 2 { %s }\n}"
- pay1 (pay2 ^ "\n MOVES " ^ mvs2 ^ "\n") in
- let model_s = Structure.sprint (List.hd seq) in
- let dws a i = (a.(2*i+1), a.(2*i), Structure.diff_elems a.(2*i+1) a.(2*i)) in
- let (win1, win2) = (make_cond dr (dws win1s 0), make_cond dr (dws win2s 0)) in
- let beg = Printf.sprintf "PLAYERS 1, 2\nREL Win1() = %s\nREL Win2() = %s"
- (Formula.sprint win1) (Formula.sprint win2) in
- Printf.sprintf "%s\n%s\n%s\n%s\nMODEL\n%s\n" beg rs loc0 loc1 model_s
Deleted: trunk/Toss/Server/Picture.mli
===================================================================
--- trunk/Toss/Server/Picture.mli 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Server/Picture.mli 2012-01-18 02:45:45 UTC (rev 1645)
@@ -1,54 +0,0 @@
-(** Processing pictures to create structures *)
-
-(** {2 Debugging} *)
-
-val set_debug_level : int -> unit
-
-
-(** {2 Basic Picture Functions} *)
-
-type picture = (int * int * int) array array
-
-
-(** Read a picture from a scanning buffer. *)
-val read_pic : Scanf.Scanning.scanbuf -> picture
-
-(** Print a picture in the simple PPM format to a formatter. *)
-val fprint_pic : Format.formatter -> picture -> unit
-
-(** Print a picture in the simple PPM format to standard output. *)
-val print_pic : picture -> unit
-
-(** Flip a picture. *)
-val flip : picture -> picture
-
-(** Cut a picture to the given rectangle. *)
-val cut : int * int -> int * int -> picture -> picture
-
-(** Apply the filter function [f] to each pixel in a picture. *)
-val apply_filter : (int -> int -> int -> int -> picture -> int * int * int) ->
- picture -> picture
-
-
-(** {2 Change Detection} *)
-
-(** Calculate color difference, accept maxdiff differences up to dist. *)
-val diff : ?maxdiff: int * int * int -> ?dist: int * int -> picture -> picture
-
-
-(** {2 Simple Segmentation} *)
-
-(** Very basic picture segmentation, should work for grids. *)
-val segment : int -> float -> picture ->
- (((int * int) * (int * int)) * string) list
-
-
-(** {2 Structure from Segmented Data} *)
-
-(** Create a structure from segmented data. *)
-val make_struc : (((int * int) * (int * int)) * string) list ->
- Structure.structure * int * int
-
-(** Create a game from sequence of images. *)
-val make_game : ?rels : (string * string list * Formula.formula) list ->
- ?offset : int -> ?threshold : float -> ?types : bool -> string -> string
Deleted: trunk/Toss/Server/PictureTest.ml
===================================================================
--- trunk/Toss/Server/PictureTest.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Server/PictureTest.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -1,51 +0,0 @@
-open OUnit
-
-Picture.set_debug_level 0
-
-let tests = "Picture" >::: [
- "segmentation size for breakthrough" >::
- (fun () ->
- let fname = "./www/img/Breakthrough.ppm" in
- let pic = Picture.read_pic (Scanf.Scanning.from_file fname) in
- let seg = Picture.segment 2 70. pic in
- assert_equal ~printer:string_of_int 64 (List.length seg)
- );
-
- "breakthrough structure P1 size" >::
- (fun () ->
- let fname = "./www/img/Breakthrough.ppm" in
- let pic = Picture.read_pic (Scanf.Scanning.from_file fname) in
- let seg = Picture.segment 2 70. pic in
- let (struc, _, _) = Picture.make_struc seg in
- assert_equal ~printer:string_of_int 16 (Structure.rel_size struc "P1")
- );
-]
-
-
-let main () =
- Aux.set_optimized_gc ();
- let (file, game, use_types) = (ref "", ref "", ref false) in
- let dbg_level i = (Picture.set_debug_level i) in
- let opts = [
- ("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose");
- ("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
- ("-f", Arg.String (fun s -> file := s), "process file");
- ("-g", Arg.String (fun s -> game := s), "process files for a game");
- ("-tp", Arg.Unit (fun () -> use_types := true), "use formulas in rules");
- ] in
- Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
- if !file <> "" then (
- let pic = Picture.read_pic (Scanf.Scanning.from_file !file) in
- let (struc, dx, dy) = Picture.make_struc (Picture.segment 2 70. pic) in
- let formula_r = Printf.sprintf
- ":y(a) = :y(b) and :x(a) < :x(b) and :x(b) < :x(a) + %i.8" dx in
- let formula_c = Printf.sprintf
- ":x(a) = :x(b) and :y(b) < :y(a) and :y(a) < :y(b) + %i.8" dy in
- Printf.printf "MODEL \n %s \n with \n R(a, b) = %s;\n C(a, b) = %s\n\n%!"
- (Structure.sprint struc) formula_r formula_c;
- ) else if !game <> "" then (
- print_endline (Picture.make_game ~types:!use_types !game)
- ) else ignore (OUnit.run_test_tt ~verbose:true tests)
-
-
-let _ = AuxIO.run_if_target "PictureTest" main
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Server/ReqHandler.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -688,7 +688,7 @@
let plays_int = List.map (fun (a, b) -> (int_of_string a, b)) plays in
let (w0, other) = List.partition (fun (_, b) -> b = "0") plays_int in
let (w1, other) = List.partition (fun (_, b) -> b = "1") other in
- let (tie, other) = List.partition (fun (_, b) -> b = "2") other in
+ let (notwon, other) = List.partition (fun (_, b) -> b = "2") other in
let (wrong, _) = List.partition (fun (_, b) -> b = "3") other in
(* Get the play with given id from DB - as a sequence of structures. *)
let playFromDB pid =
@@ -702,24 +702,24 @@
game [source]: [wins0] which are now supposed to be won by Player 0,
[wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
are not correct plays of the newly constructed game. *)
- let learnFromDB source wins0 wins1 tie wrong =
+ let learnFromDB source wins0 wins1 nw wrong =
if !debug_level > 0 then (
let pl l = String.concat ", " (List.map string_of_int l) in
print_endline ("Learning from "^ source ^" w0: "^ (pl wins0) ^" w1: "^
- (pl wins1)^" tie: "^(pl tie) ^" wrong: "^ (pl wrong));
+ (pl wins1)^" notwon: "^(pl nw)^" wrong: "^(pl wrong));
);
- let (wins0, wins1, tie, wrong) =
+ let (wins0, wins1, notwon, wrong) =
(List.map playFromDB wins0, List.map playFromDB wins1,
- List.map playFromDB tie, List.map playFromDB wrong) in
+ List.map playFromDB nw, List.map playFromDB wrong) in
let struc_of_string s =
StructureParser.parse_structure Lexer.lex (Lexing.from_string s) in
LearnGame.learnFromParties
~win0:(List.map (List.map struc_of_string) wins0)
~win1:(List.map (List.map struc_of_string) wins1)
- ~tie:(List.map (List.map struc_of_string) tie)
+ ~notwon:(List.map (List.map struc_of_string) notwon)
~wrong:(List.map (List.map struc_of_string) wrong) in
learnFromDB game (List.map fst w0) (List.map fst w1)
- (List.map fst tie) (List.map fst wrong) in
+ (List.map fst notwon) (List.map fst wrong) in
let (tcmd, data) = split_two "#" msg in
let resp, new_cookies = match tcmd with
| "USERNAME" ->
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/Server/Tests.ml 2012-01-18 02:45:45 UTC (rev 1645)
@@ -42,11 +42,10 @@
let learn_tests = "Learn", [
"DistinguishTest", [DistinguishTest.tests; DistinguishTest.bigtests];
- "LearnGameTest", [LearnGameTest.tests; LearnGameTest.bigtests];
+ "LearnGameTest", [LearnGameTest.tests];
]
let server_tests = "Server", [
- "PictureTest", [PictureTest.tests];
"ReqHandlerTest", [ReqHandlerTest.tests];
]
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2012-01-17 23:33:40 UTC (rev 1644)
+++ trunk/Toss/WebClient/Main.js 2012-01-18 02:45:45 UTC (rev 1645)
@@ -249,7 +249,7 @@
'<option class="play_select_opt" value="-1">skip</option>' +
'<option class="play_select_opt" value="0">wins0</option>' +
'<option class="play_select_opt" value="1">wins1</option>' +
- '<option class="play_select_opt" value="2">tie</option>' +
+ '<option class="play_select_opt" value="2">notwon</option>' +
'<option class="play_select_opt" value="3">wrong</option></select>';
} else {
li.innerHTML = bs;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-19 03:06:16
|
Revision: 1646
http://toss.svn.sourceforge.net/toss/?rev=1646&view=rev
Author: lukaszkaiser
Date: 2012-01-19 03:06:07 +0000 (Thu, 19 Jan 2012)
Log Message:
-----------
More game learning.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/Distinguish.mli
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGame.mli
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_01.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_02.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_03.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_04.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.nwn
Added Paths:
-----------
trunk/Toss/Learn/examples/Connect4001_01.nwn
trunk/Toss/Learn/examples/Connect4001_01.wn0
trunk/Toss/Learn/examples/Connect4001_01.wn1
trunk/Toss/Learn/examples/Connect4001_01.wrg
trunk/Toss/Learn/examples/Connect4001_02.nwn
trunk/Toss/Learn/examples/Connect4001_02.wn0
trunk/Toss/Learn/examples/Connect4001_02.wn1
trunk/Toss/Learn/examples/Connect4001_02.wrg
trunk/Toss/Learn/examples/Connect4001_03.nwn
trunk/Toss/Learn/examples/Connect4001_03.wn0
trunk/Toss/Learn/examples/Connect4001_03.wn1
trunk/Toss/Learn/examples/Connect4001_03.wrg
trunk/Toss/Learn/examples/Connect4001_04.nwn
trunk/Toss/Learn/examples/Connect4001_04.wn0
trunk/Toss/Learn/examples/Connect4001_04.wn1
trunk/Toss/Learn/examples/Connect4001_04.wrg
trunk/Toss/Learn/examples/Connect4001_05.nwn
trunk/Toss/Learn/examples/Connect4001_06.nwn
trunk/Toss/Learn/examples/Connect4001_07.nwn
trunk/Toss/Learn/examples/Connect4001_08.nwn
trunk/Toss/Learn/examples/Connect4001_09.nwn
trunk/Toss/Learn/examples/Connect4001_10.nwn
trunk/Toss/Learn/examples/Connect4001_11.nwn
trunk/Toss/Learn/examples/Connect4001_12.nwn
trunk/Toss/Learn/examples/Connect4001_13.nwn
trunk/Toss/Learn/examples/Gomoku001_01.nwn
trunk/Toss/Learn/examples/Gomoku001_01.wn0
trunk/Toss/Learn/examples/Gomoku001_01.wn1
trunk/Toss/Learn/examples/Gomoku001_02.nwn
trunk/Toss/Learn/examples/Gomoku001_02.wn0
trunk/Toss/Learn/examples/Gomoku001_02.wn1
trunk/Toss/Learn/examples/Gomoku001_03.nwn
trunk/Toss/Learn/examples/Gomoku001_03.wn0
trunk/Toss/Learn/examples/Gomoku001_03.wn1
trunk/Toss/Learn/examples/Gomoku001_04.nwn
trunk/Toss/Learn/examples/Gomoku001_04.wn0
trunk/Toss/Learn/examples/Gomoku001_04.wn1
trunk/Toss/Learn/examples/Gomoku001_05.nwn
trunk/Toss/Learn/examples/Gomoku001_06.nwn
trunk/Toss/Learn/examples/Gomoku001_07.nwn
trunk/Toss/Learn/examples/Gomoku001_08.nwn
trunk/Toss/Learn/examples/Gomoku001_09.nwn
trunk/Toss/Learn/examples/Pawn-Whopping001_01.nwn
trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn0
trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn1
trunk/Toss/Learn/examples/Pawn-Whopping001_01.wrg
trunk/Toss/Learn/examples/Pawn-Whopping001_02.nwn
trunk/Toss/Learn/examples/Pawn-Whopping001_02.wrg
trunk/Toss/Learn/examples/Pawn-Whopping001_03.nwn
trunk/Toss/Learn/examples/Pawn-Whopping001_04.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_07.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_08.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_09.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_10.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_11.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_12.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_13.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_14.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_15.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_16.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe001_17.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe002_01.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe002_01.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe002_01.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe002_02.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe002_02.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe002_02.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe002_03.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe002_03.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe002_03.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe002_04.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe002_04.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe002_04.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe002_05.nwn
trunk/Toss/Learn/examples/Tic-Tac-Toe002_05.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe002_05.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe002_06.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe002_06.wn1
Removed Paths:
-------------
trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_05.wn1
trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn0
trunk/Toss/Learn/examples/Tic-Tac-Toe001_06.wn1
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-01-19 03:06:07 UTC (rev 1646)
@@ -96,6 +96,8 @@
| TC ID COMMA ID formula_expr { FormulaSubst.make_lfp_tc $2 $4 $5 }
| TC IN_MOD ID COMMA ID formula_expr { FormulaSubst.make_mso_tc $3 $5 $6 }
| TC INT ID COMMA ID formula_expr { FormulaSubst.make_fo_tc_conj $2 $3 $5 $6 }
+ | TC PLUS INT ID COMMA ID formula_expr
+ { FormulaSubst.make_fo_tc_disj ~reflexive:false $3 $4 $6 $7 }
| LFP ID OPEN fo_var_list CLOSE EQ formula_expr
{ let vs = Array.of_list $4 in if Array.length vs <> 1 then
raise (Parsing_error "Monadic LFP with not one variable")
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Learn/Distinguish.ml 2012-01-19 03:06:07 UTC (rev 1646)
@@ -225,6 +225,9 @@
| Some n -> Some (n, f) in
Aux.map_some max_n_chosen choices
+(* Number of steps and base formulas if distinguish returns a TC. *)
+let distinguish_result_tc = ref None
+
(* Find a upto-[n]-step transitive closures of two-variable [?positive] atomic
formulas that hold on all [pos_strucs] and on no [neg_strucs]. *)
let tc_atomic_distinguish ?(positive=false) ?(repeat_vars=true) pos neg n =
@@ -238,9 +241,16 @@
let cmp (n1, f1) (n2, f2) =
if n1 <> n2 then n1-n2 else Formula.compare f1 f2 in
let (k, phi) = List.hd (List.sort cmp l) in
- tc k phi in
- try Some (Or (List.rev_map (fun s -> choose (tcs s)) pos)) with
- Not_found -> None
+ let phi = Formula.flatten_sort phi in
+ match !distinguish_result_tc with
+ | None -> distinguish_result_tc := Some [(k, phi)]; tc k phi
+ | Some l -> distinguish_result_tc := Some ((k, phi) :: l); tc k phi in
+ try distinguish_result_tc := None;
+ let res = Some (Or (List.rev_map (fun s -> choose (tcs s)) pos)) in
+ match !distinguish_result_tc with
+ | None -> res
+ | Some l -> distinguish_result_tc := Some (Aux.unique_sorted l); res
+ with Not_found -> distinguish_result_tc := None; None
(* - Distinguishing Structure Sets - *)
Modified: trunk/Toss/Learn/Distinguish.mli
===================================================================
--- trunk/Toss/Learn/Distinguish.mli 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Learn/Distinguish.mli 2012-01-19 03:06:07 UTC (rev 1646)
@@ -68,7 +68,10 @@
Structure.structure list -> Structure.structure list -> int ->
Formula.formula option
+(** Number of steps and base formula if distinguish returns a TC. *)
+val distinguish_result_tc : (int * Formula.formula) list option ref
+
(** {2 Distinguishing Structure Sets} *)
(** Order on types that we use to select the minimal ones. *)
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Learn/LearnGame.ml 2012-01-19 03:06:07 UTC (rev 1646)
@@ -13,30 +13,40 @@
evens ~acc:[1] k
-let winFormula winningStates notWinningStates =
+let winFormula ?(nicetc=true) winningStates notWinningStates =
if !debug_level > 0 then
print_endline (
"Searching WIN:\n" ^
(String.concat "\n" (List.map Structure.str winningStates)) ^ "\nNOT\n"^
(String.concat "\n" (List.map Structure.str notWinningStates)));
- FormulaOps.tnf_fv (Distinguish.distinguish winningStates notWinningStates)
+ let res = Distinguish.distinguish winningStates notWinningStates in
+ let print_tc (i,f) = Printf.sprintf "(tc+ %i x0 x1 (%s))" i (Formula.str f) in
+ match !Distinguish.distinguish_result_tc with
+ | None | Some [(1, _)] -> Formula.str (FormulaOps.tnf_fv res)
+ | Some l -> if not nicetc then Formula.str (FormulaOps.tnf_fv res) else
+ "ex x0, x1 (\n " ^ (String.concat " or\n " (List.map print_tc l)) ^ " )"
+
let cleanStructure struc =
let funs = ref [] in
let append_fun f _ = funs := f :: !funs in
Structure.StringMap.iter append_fun (Structure.functions struc);
- let struc = StructureParser.parse_structure Lexer.lex (Lexing.from_string (Structure.str struc)) in
- Structure.replace_names (List.fold_left
- (fun x y ->
- Structure.clear_fun x y)
- struc !funs) Structure.StringMap.empty
- Structure.IntMap.empty
+ let struc = StructureParser.parse_structure Lexer.lex
+ (Lexing.from_string (Structure.str struc)) in (* elems now from 1 *)
+ let nofun_struc =
+ List.fold_left (fun x y -> Structure.clear_fun x y) struc !funs in
+ let bind_name (sm, im) i =
+ (Structure.StringMap.add ("e" ^ (string_of_int i)) i sm,
+ Structure.IntMap.add i ("e" ^ (string_of_int i)) im) in
+ let bind_names l = List.fold_left bind_name
+ (Structure.StringMap.empty, Structure.IntMap.empty) l in
+ let (sm,im)= bind_names (Aux.range ~from:1 ((Structure.nbr_elems struc)+1)) in
+ Structure.replace_names nofun_struc sm im
let move struct1 struct2 =
- let changed = (Aux.unique_sorted
- ( List.map fst
- (Structure.diff_elems struct1 struct2 )) ) in
+ let changed =
+ Aux.unique_sorted (List.map fst (Structure.diff_elems struct1 struct2)) in
let strucBefore =
fst (Structure.del_elems struct1
(Aux.list_diff
@@ -47,27 +57,46 @@
(Aux.list_diff
(Aux.unique_sorted (Structure.elements struct2))
changed )) in
- ((cleanStructure strucBefore) , (cleanStructure strucAfter))
-
+ (struct1,struct2, ((cleanStructure strucBefore), (cleanStructure strucAfter)))
+
let movesi i partylist =
- Aux.unique_sorted
- ~cmp: (fun (s1,s2) (t1,t2) ->
- let c = ( Structure.compare s1 t1) in
- if c != 0 then c
- else (Structure.compare s2 t2))
- (List.fold_left
+ (List.fold_left
(fun acc party ->
List.append acc
(List.fold_left
- (fun prev i ->
- if (i < ((List.length party)-1)) then
- let m = move (List.nth party i) (List.nth party (i+1)) in
- (List.append prev [m])
- else
- (List.append prev []))
- [] (evens ~acc:[i] (List.length party)) ) )
- [] partylist)
+ (fun prev i ->
+ if (i < ((List.length party)-1)) then
+ (move (List.nth party i) (List.nth party (i+1))) :: prev
+ else prev) [] (evens ~acc:[i] (List.length party)))
+ ) [] partylist)
+
+let movecmp (s1,s2) (t1,t2) =
+ let c = (Structure.compare s1 t1) in
+ if c != 0 then c else (Structure.compare s2 t2)
+
+let add_precond moves wrong m =
+ let mwrong = List.filter (fun (l, r, x) -> movecmp x m = 0) wrong in
+ if mwrong = [] then (m, Formula.And []) else
+ let mright = List.filter (fun (l, r, x) -> movecmp x m = 0) moves in
+ let mark (l, r, _) =
+ let chg = Aux.unique_sorted (List.map fst (Structure.diff_elems l r)) in
+ Structure.add_rels l "chg" (List.map (fun e -> [|e|]) chg) in
+ let (good, bad) = (List.map mark mright, List.map mark mwrong) in
+ if !debug_level > 0 then (
+ List.iter Structure.print good;
+ List.iter Structure.print bad;
+ print_endline "";
+ );
+ let pre = Distinguish.distinguish good bad in
+ if !debug_level > 0 then print_endline (Formula.str pre);
+ let elems = Aux.range ~from:1 ((Structure.nbr_elems (fst m)) + 1) in
+ let eqs = List.map (fun i -> "x = e" ^ (string_of_int i)) elems in
+ let let_part = "let chg(x) = " ^ (String.concat " or " eqs) ^ " in " in
+ let phi = FormulaParser.parse_formula Lexer.lex
+ (Lexing.from_string (let_part ^ (Formula.str pre))) in
+ (m, FormulaOps.tnf_fv phi)
+
let learnFromParties ~win0 ~win1 ~notwon ~wrong =
let win0f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win0)
@@ -76,40 +105,53 @@
let win1f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win1)
(List.flatten ((List.map (fun x-> List.tl (List.rev x))
- win1) @ win0 @ notwon)) in
+ win1) @ win0 @ notwon)) in
- let moves0 = movesi 0 (win0 @ win1 @ notwon) in
- let moves1 = movesi 1 (win0 @ win1 @ notwon) in
+ let fullMoves0 = movesi 0 (win0 @ win1 @ notwon) in
+ let fullMoves1 = movesi 1 (win0 @ win1 @ notwon) in
+ let wrongPairs =
+ Aux.map_some (fun play -> if List.length play < 2 then None else
+ let r = List.rev play in Some (List.hd (List.tl r), List.hd r)) wrong in
+ let wrongMoves = List.map (fun (l, r) -> move l r) wrongPairs in
+
+ let moves0 = Aux.unique_sorted ~cmp:movecmp (List.map Aux.trd3 fullMoves0) in
+ let moves1 = Aux.unique_sorted ~cmp:movecmp (List.map Aux.trd3 fullMoves1) in
+
+ let moves0 = List.map (add_precond fullMoves0 wrongMoves) moves0 in
+ let moves1 = List.map (add_precond fullMoves1 wrongMoves) moves1 in
+
let cmpll l1 l2 = (List.length l2) - (List.length l1) in
let longest = List.hd (List.sort cmpll (win0 @ win1 @ notwon)) in
+ let mvlst pre post l = String.concat "; " (List.map (
+ fun i -> pre ^ (string_of_int i) ^ post) (Aux.range (List.length l))) in
"PLAYERS 1, 2\n" ^
- "REL Win1() = "^ (Formula.sprint win0f) ^"\n"^
- "REL Win2() = "^ (Formula.sprint win1f) ^"\n"^
+ "REL Win1() = "^ win0f ^ "\n"^
+ "REL Win2() = "^ win1f ^ "\n"^
(fst (List.fold_left
- (fun (old, i) x ->
+ (fun (old, i) ((l, r), pre) ->
(old ^ "\n" ^ "RULE Mv1-" ^ (string_of_int i) ^ ": \n" ^
- (Structure.str (fst x)) ^ " -> " ^ (Structure.str (snd x)) ^ "\nemb "^
- (String.concat "," (List.map fst (Structure.rel_signature (fst x)) ))^
- "\npre not Win2()"), i+1)
+ (Structure.str l) ^ " -> " ^ (Structure.str r) ^ "\nemb " ^
+ (String.concat "," (List.map fst (Structure.rel_signature l))) ^
+ "\npre (" ^ (Formula.str pre) ^ ") and not Win2()"), i+1)
("", 0) moves0)) ^ "\n\n" ^
(fst (List.fold_left
- (fun (old, i) x ->
+ (fun (old, i) ((l, r), pre) ->
(old ^ "\n" ^ "RULE Mv2-" ^ (string_of_int i) ^ ": \n" ^
- (Structure.str (fst x)) ^ " -> " ^ (Structure.str (snd x)) ^ "\nemb "^
- (String.concat "," (List.map fst (Structure.rel_signature (fst x)) ))^
- "\npre not Win1()"), i+1)
+ (Structure.str l) ^ " -> " ^ (Structure.str r) ^ "\nemb "^
+ (String.concat "," (List.map fst (Structure.rel_signature l))) ^
+ "\npre (" ^ (Formula.str pre) ^ ") and not Win1()"), i+1)
("",0) moves1)) ^ "\n\n" ^
"LOC 0 {
PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
- MOVES [Mv1 -> 1]}
+ MOVES [" ^ (mvlst "Mv1-" " -> 1" moves0) ^ "]}
PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
}
LOC 1 {
PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
- MOVES [Mv2 -> 0] }
-}" ^"\n" ^
- "MODEL "^(Structure.str (List.hd longest))
+ MOVES [" ^ (mvlst "Mv2-" " -> 0" moves1) ^ "] }
+}" ^ "\n" ^
+ "MODEL "^(Structure.str (List.hd longest))
Modified: trunk/Toss/Learn/LearnGame.mli
===================================================================
--- trunk/Toss/Learn/LearnGame.mli 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Learn/LearnGame.mli 2012-01-19 03:06:07 UTC (rev 1646)
@@ -1,7 +1,5 @@
(** Module for learning games from examples. *)
-val move: Structure.structure -> Structure.structure ->
- Structure.structure * Structure.structure
(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
game [source]: [wins0] which are now supposed to be won by Player 0,
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-01-19 03:06:07 UTC (rev 1646)
@@ -50,25 +50,25 @@
REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
RULE Mv1-0:
-[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
+[e1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [e1 | P (e1); Q:1 {}; R:2 {} | ]
emb R,Q,P
-pre not Win2()
+pre (true) and not Win2()
RULE Mv2-0:
-[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P:1 {}; Q (1); R:2 {} | ]
+[e1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [e1 | P:1 {}; Q (e1); R:2 {} | ]
emb R,Q,P
-pre not Win1()
+pre (true) and not Win1()
LOC 0 {
PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
- MOVES [Mv1 -> 1]}
+ MOVES [Mv1-0 -> 1]}
PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
}
LOC 1 {
PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
- MOVES [Mv2 -> 0] }
+ MOVES [Mv2-0 -> 0] }
}
MODEL [ | P:1 {}; Q:1 {} | ] R R \"
@@ -87,8 +87,10 @@
match bound with None-> Str.split r s | Some b-> Str.bounded_split r s b in
let cl = String.index s '\n' in
let pref, st_s = String.sub s 0 cl, String.sub s cl ((String.length s)-cl) in
- let s = List.filter (fun s -> s <> "") (split_list "\n\n" st_s) in
- List.map (fun s -> struc_of_string ~diag:true (pref ^ " \n\"" ^ s ^"\n\"")) s
+ let strucstr s = pref ^ " \n\"" ^ s ^ "\n\"" in
+ let getstruc s = let st = strucstr s in try struc_of_string ~diag:true st
+ with e -> print_endline st; raise e in
+ List.map getstruc (List.filter (fun s -> s <> "") (split_list "\n\n" st_s))
let main () =
Aux.set_optimized_gc ();
@@ -108,8 +110,9 @@
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 strucs_of_files fs =
- List.map (fun fn -> get_strucs (AuxIO.input_fname fn)) fs in
+ let get_struc fn = try get_strucs (AuxIO.input_fname 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) =
(strucs_of_files (List.filter (is_group "wn0") tfiles),
strucs_of_files (List.filter (is_group "wn1") tfiles),
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-18 02:45:45 UTC (rev 1645)
+++ trunk/Toss/Learn/Makefile 2012-01-19 03:06:07 UTC (rev 1646)
@@ -25,7 +25,11 @@
learntests:
make Tic-Tac-Toe001.learn
- make Breakthrough001.learn
+ make Tic-Tac-Toe002.learn
+ #make Breakthrough001.learn
+ make Gomoku001.learn
+ make Connect4001.learn
+ make Pawn-Whopping001.learn
.PHONY: clean
Added: trunk/Toss/Learn/examples/Connect4001_01.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_01.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_01.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,43 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ...Q ... ...
+
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+...P ...Q ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_01.wn0
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_01.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_01.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ Q..Q Q..Q ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_01.wn1
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_01.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_01.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ P..P P..P ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_01.wrg
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_01.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_01.wrg 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,29 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_02.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_02.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_02.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...Q Q..Q ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_02.wn0
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_02.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_02.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_02.wn1
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_02.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_02.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...P ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...P ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_02.wrg
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_02.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_02.wrg 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,29 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_03.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_03.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_03.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_03.wn0
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_03.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_03.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ...
+ ... Q.. ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ Q.. ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_03.wn1
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_03.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_03.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... P.. ...
+ ... ... ...
+ ... P.. ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ P.. ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_03.wrg
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_03.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_03.wrg 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,41 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P..Q ... ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P..Q ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_04.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_04.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_04.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ...
+ ... Q.. ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_04.wn0
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_04.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_04.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ... Q.. ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ...
+ ... ... Q..
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_04.wn1
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_04.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_04.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ... P.. ...
+... ... ... ...
+... ... P.. ...
+ ... ... ...
+ ... ... P..
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_04.wrg
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_04.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_04.wrg 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,41 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. Q.. ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. Q.. ...
+
Added: trunk/Toss/Learn/examples/Connect4001_05.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_05.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_05.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ... Q.. ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_06.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_06.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_06.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...P P..P ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_07.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_07.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_07.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...P ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...P ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_08.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_08.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_08.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... P.. ...
+ ... ... ...
+ ... P.. ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_09.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_09.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_09.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,15 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ... P.. ...
+... ... ... ...
+... ... P.. ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_10.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_10.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_10.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,29 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_11.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_11.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_11.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,29 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_12.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_12.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_12.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,41 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P..Q ... ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...P ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P..Q ... ...
+
Added: trunk/Toss/Learn/examples/Connect4001_13.nwn
===================================================================
--- trunk/Toss/Learn/examples/Connect4001_13.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Connect4001_13.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,41 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. ... ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. Q.. ...
+
+ ... ... ...
+ ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ...
+ ...P ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ...
+ ...Q ... ...
+... ... ... ...
+... P.. Q.. ...
+
Added: trunk/Toss/Learn/examples/Gomoku001_01.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_01.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_01.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,70 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...Q ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...Q ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...P ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...Q Q.. ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...P ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Gomoku001_01.wn0
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_01.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_01.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+...Q Q..Q Q..Q ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_01.wn1
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_01.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_01.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+...P P..P P..P ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_02.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_02.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_02.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... Q..Q Q..Q ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_02.wn0
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_02.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_02.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ...Q ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ...Q ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_02.wn1
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_02.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_02.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ...P ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ...P ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_03.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_03.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_03.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ...Q ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ...Q ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_03.wn0
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_03.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_03.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... Q.. ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ... ...
+ ... Q.. ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ Q.. ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_03.wn1
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_03.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_03.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... P.. ...
+... ... ... ...
+... ... P.. ...
+ ... ... ... ...
+ ... P.. ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ P.. ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_04.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_04.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_04.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... Q.. ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ... ...
+ ... Q.. ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_04.wn0
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_04.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_04.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ Q.. ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ... Q.. ... ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ... ...
+ ... ... Q.. ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_04.wn1
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_04.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_04.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ P.. ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ... P.. ... ...
+... ... ... ...
+... ... P.. ...
+ ... ... ... ...
+ ... ... P.. ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_05.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_05.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_05.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ Q.. ... ... ...
+... ... ... ...
+... Q.. ... ...
+ ... ... ... ...
+ ... Q.. ... ...
+... ... ... ...
+... ... Q.. ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_06.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_06.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_06.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... P..P P..P ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_07.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_07.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_07.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ...P ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ...P ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_08.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_08.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_08.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... P.. ...
+... ... ... ...
+... ... P.. ...
+ ... ... ... ...
+ ... P.. ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Gomoku001_09.nwn
===================================================================
--- trunk/Toss/Learn/examples/Gomoku001_09.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Gomoku001_09.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,18 @@
+[ | P:1 {}; Q:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... P.. ... ...
+ ... ... ... ...
+ ... P.. ... ...
+... ... ... ...
+... ... P.. ...
+ ... ... ... ...
+ ... ... P.. ...
+... ... ... ...
+... ... ... ...
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_01.nwn
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_01.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_01.nwn 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,199 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W W..W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... W.. ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ...W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ...B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... B.. ... ...
+ ... ... ... ...
+ ... W.. ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ...W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ...B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... W.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ...W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... B..B B..B
+ ... ... ... ...
+ ... B.. ... ...
+... ... ... ...
+... W.. ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ...W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... B..B B..B
+ ... ... ... ...
+ ... W.. ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ...W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... ...B B..B
+ ... ... ... ...
+ ... B.. ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ...W W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... ...B B..B
+ ... ... ... ...
+ ... B.. ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ...W ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ... W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... ...B ...B
+ ... ... ... ...
+ ... B.. ...B ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ...W ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ... W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... ...B ...B
+ ... ... ... ...
+ ... B.. ...B ...
+... ... ... ...
+... ... W.. ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ... W..W W..
+... ... ... ...
+... ... ... ...
+
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B..B ... ...B ...B
+ ... ... ... ...
+ ... ... ...B ...
+... ... ... ...
+... ... B.. ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+W W..W ... W..W W..
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn0
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn0 (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn0 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,19 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... W.. ... ...
+... ... ... ...
+B.. ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ...W ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn1
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn1 (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_01.wn1 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,19 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+B.. ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ...W ...
+... ... ... ...
+... ...B ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_01.wrg
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_01.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_01.wrg 2012-01-19 03:06:07 UTC (rev 1646)
@@ -0,0 +1,36 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... W.. ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...W ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_02.nwn
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_02.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-W...
[truncated message content] |
|
From: <luk...@us...> - 2012-01-20 02:32:28
|
Revision: 1647
http://toss.svn.sourceforge.net/toss/?rev=1647&view=rev
Author: lukaszkaiser
Date: 2012-01-20 02:32:20 +0000 (Fri, 20 Jan 2012)
Log Message:
-----------
Learning Pawn-Whopping.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Learn/Distinguish.ml
trunk/Toss/Learn/LearnGame.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Learn/Makefile
trunk/Toss/Learn/examples/Pawn-Whopping001_02.wrg
Added Paths:
-----------
trunk/Toss/Learn/examples/Pawn-Whopping001_03.wrg
trunk/Toss/Learn/examples/Pawn-Whopping001_04.wrg
trunk/Toss/Learn/examples/Pawn-Whopping001_05.nwn
trunk/Toss/Learn/examples/Pawn-Whopping001_05.wrg
trunk/Toss/Learn/examples/Pawn-Whopping001_06.wrg
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2012-01-20 02:32:20 UTC (rev 1647)
@@ -32,6 +32,8 @@
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)";
+ nnf_eq "tc !1 x, y R(x, y)" "R(x, y)";
nnf_eq "not ex x (not P(x) and Q(x))" "all x (P(x) or not Q(x))";
nnf_eq "not ex :x, :y (:x^2 + 3*:y + 2 < 0)"
"all :x, :y (not :x^2 + 3*:y + 2 < 0)";
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Formula/FormulaParser.mly 2012-01-20 02:32:20 UTC (rev 1647)
@@ -96,7 +96,7 @@
| TC ID COMMA ID formula_expr { FormulaSubst.make_lfp_tc $2 $4 $5 }
| TC IN_MOD ID COMMA ID formula_expr { FormulaSubst.make_mso_tc $3 $5 $6 }
| TC INT ID COMMA ID formula_expr { FormulaSubst.make_fo_tc_conj $2 $3 $5 $6 }
- | TC PLUS INT ID COMMA ID formula_expr
+ | TC NOT INT ID COMMA ID formula_expr
{ FormulaSubst.make_fo_tc_disj ~reflexive:false $3 $4 $6 $7 }
| LFP ID OPEN fo_var_list CLOSE EQ formula_expr
{ let vs = Array.of_list $4 in if Array.length vs <> 1 then
Modified: trunk/Toss/Learn/Distinguish.ml
===================================================================
--- trunk/Toss/Learn/Distinguish.ml 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Learn/Distinguish.ml 2012-01-20 02:32:20 UTC (rev 1647)
@@ -188,6 +188,7 @@
List.map Array.of_list (Aux.all_ntuples (Array.to_list tup) k) in
let ktups = List.rev_map k_subtuples (Aux.unique_sorted tups) in
let ktups = Aux.unique_sorted (List.concat ktups) in
+ if !debug_level>0 then print_endline "guarded_types:\t\t tuples generated";
let mem = Hashtbl.create 63 in
Aux.unique_sorted (List.rev_map
(guarded_type_memo existential struc mem qr) ktups)
@@ -211,6 +212,8 @@
let rec rept i l = if i < 1 then [] else l :: (rept (i-1) l) in
let atoms = Array.of_list (FormulaOps.atoms ~repetitions:repeat_vars
(Structure.rel_signature struc) (varnames 2)) in
+ if !debug_level > 0 then
+ Printf.printf "tc_atomic:\t\t %i atoms\n%!" (Array.length atoms);
let choices = List.rev_map Array.of_list
(if positive then Aux.product (rept (Array.length atoms) [0; 1]) else
Aux.product (rept (Array.length atoms) [0; 1; -1])) in
@@ -258,17 +261,27 @@
(* Helper function: remove atoms from a formula if [cond] is still satisfied.
Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
let rec greedy_remove ?(pos=false) cond phi =
- let rec greedy_remove_list constructor acc = function
+ if !debug_level > 1 then
+ Printf.printf "greedy_remove:\t\t %s\n%!" (Formula.str phi);
+ let rec greedy_remove_list minimize constructor acc = function
| [] -> acc
| x :: xs ->
let rest = acc @ xs in
- if cond (constructor rest) then greedy_remove_list constructor acc xs else
- let minx = greedy_remove (fun y -> cond (constructor (y :: rest))) x in
- greedy_remove_list constructor (minx::acc) xs in
+ if cond (constructor rest) then
+ greedy_remove_list minimize constructor acc xs
+ else if minimize then
+ let minx = greedy_remove (fun y-> cond (constructor (y :: rest))) x in
+ greedy_remove_list minimize constructor (minx::acc) xs
+ else greedy_remove_list minimize constructor (x::acc) xs in
+ let greedy_remove_lst cons lst =
+ let l = greedy_remove_list false cons [] lst in
+ if !debug_level > 1 then Printf.printf "greedy_remove_lst:\t min %i: %s\n%!"
+ (List.length l) (Formula.str (cons l));
+ greedy_remove_list true cons [] (List.rev l) in
match phi with
- | And fl -> And (greedy_remove_list (fun l -> And l) [] (List.rev fl))
+ | And fl -> And (greedy_remove_lst (fun l -> And l) (List.rev fl))
| Or fl -> if pos then Or fl else
- Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
+ Or (greedy_remove_lst (fun l -> Or l) (List.rev fl))
| Not f -> if pos then Not f else
Not (greedy_remove (fun x -> cond (Not x)) f)
| Ex (vs, f) -> Ex (vs, greedy_remove (fun x -> cond (Ex (vs, x))) f)
@@ -291,9 +304,10 @@
| ExGuardedFO -> guarded_types ~existential:true struc ~qr ~k
| FO -> ntypes struc ~qr ~k
| ExFO -> ntypes ~existential:true struc ~qr ~k in
+ if !debug_level > 0 then print_endline "min_type_omitting:\t types generated";
let ok_types = List.filter (fun f -> not (List.mem f neg_types)) pos_types in
let ok_types = List.sort !compare_types ok_types in
- if ok_types = [] then None else Some (List.hd ok_types)
+ if ok_types = [] then None else Some (Formula.flatten_sort (List.hd ok_types))
(* Find a [logic]-formula with at most [qr] quantifiers and [k] variables
which holds on all [pos_strucs] and on no [neg_strucs]. *)
@@ -304,6 +318,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
+ if !debug_level > 0 then print_endline "distinguish_upto:\t neg types done";
let fails_on_negs f = not (List.exists (fun s-> check s [||] f) neg_strucs) in
let extend_by_pos acc struc =
if check struc [||] (Or acc) then acc else
@@ -313,6 +328,8 @@
let pos_formulas =
try List.fold_left extend_by_pos [] pos_strucs with Not_found -> [] in
let pos_formulas = Aux.unique_sorted ~cmp:!compare_types pos_formulas in
+ if !debug_level > 0 then Printf.printf
+ "distinguish_upto:\t pos_formulas %i\n%!" (List.length pos_formulas);
if pos_formulas = [] then None else
let succ_pos fl = List.for_all (fun s -> check s [||] (Or fl)) pos_strucs in
let is_ok f = fails_on_negs f && succ_pos [f] in
@@ -330,7 +347,8 @@
(String.concat "\n" (List.map Structure.str s2));
let rec diff qr k =
if qr > k then diff 0 (k+1) else (
- if !debug_level > 0 then Printf.printf "distinguish qr %i k %i\n%!" qr k;
+ if !debug_level > 0 then
+ Printf.printf "distinguish:\t\t qr %i k %i\n%!" qr k;
if qr = 0 then
match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
| Some f -> f | None ->
@@ -340,9 +358,13 @@
else
match distinguish_upto ~logic:GuardedFO ~qr ~k s1 s2 with
| Some f ->
- (match distinguish_upto ~logic:ExGuardedFO ~qr ~k s1 s2 with
- | Some g-> if 2*(Formula.size f) < Formula.size g then f else g
- | None -> f)
+ if qr > 1 (* hurry up for large qr *) then f else (
+ if !debug_level > 0 then Printf.printf
+ "distinguish:\t\t guarded found: %s\n%!" (Formula.str f);
+ match distinguish_upto ~logic:ExGuardedFO ~qr ~k s1 s2 with
+ | Some g-> if 2*(Formula.size f) < Formula.size g then f else g
+ | None -> f
+ )
| None -> diff (qr+1) k
) in
let res = diff 0 1 in
Modified: trunk/Toss/Learn/LearnGame.ml
===================================================================
--- trunk/Toss/Learn/LearnGame.ml 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Learn/LearnGame.ml 2012-01-20 02:32:20 UTC (rev 1647)
@@ -20,7 +20,8 @@
(String.concat "\n" (List.map Structure.str winningStates)) ^ "\nNOT\n"^
(String.concat "\n" (List.map Structure.str notWinningStates)));
let res = Distinguish.distinguish winningStates notWinningStates in
- let print_tc (i,f) = Printf.sprintf "(tc+ %i x0 x1 (%s))" i (Formula.str f) in
+ let print_tc (i, f) =
+ Printf.sprintf "(tc !%i x0, x1 (%s))" i (Formula.str f) in
match !Distinguish.distinguish_result_tc with
| None | Some [(1, _)] -> Formula.str (FormulaOps.tnf_fv res)
| Some l -> if not nicetc then Formula.str (FormulaOps.tnf_fv res) else
@@ -81,7 +82,9 @@
let mright = List.filter (fun (l, r, x) -> movecmp x m = 0) moves in
let mark (l, r, _) =
let chg = Aux.unique_sorted (List.map fst (Structure.diff_elems l r)) in
- Structure.add_rels l "chg" (List.map (fun e -> [|e|]) chg) in
+ let mark_el (st, i) e =
+ (Structure.add_rel st ("ch" ^ string_of_int i) [|e|], i+1) in
+ fst (List.fold_left mark_el (l, 1) chg) in
let (good, bad) = (List.map mark mright, List.map mark mwrong) in
if !debug_level > 0 then (
List.iter Structure.print good;
@@ -91,10 +94,10 @@
let pre = Distinguish.distinguish good bad in
if !debug_level > 0 then print_endline (Formula.str pre);
let elems = Aux.range ~from:1 ((Structure.nbr_elems (fst m)) + 1) in
- let eqs = List.map (fun i -> "x = e" ^ (string_of_int i)) elems in
- let let_part = "let chg(x) = " ^ (String.concat " or " eqs) ^ " in " in
+ let let_part i = Printf.sprintf "let ch%i (x) = x = e%i in" i i in
+ let let_all = String.concat " " (List.map let_part elems) in
let phi = FormulaParser.parse_formula Lexer.lex
- (Lexing.from_string (let_part ^ (Formula.str pre))) in
+ (Lexing.from_string (let_all ^ " " ^ (Formula.str pre))) in
(m, FormulaOps.tnf_fv phi)
let learnFromParties ~win0 ~win1 ~notwon ~wrong =
@@ -105,7 +108,7 @@
let win1f = winFormula
(List.map (fun x -> List.hd (List.rev x)) win1)
(List.flatten ((List.map (fun x-> List.tl (List.rev x))
- win1) @ win0 @ notwon)) in
+ win1) @ win0 @ notwon)) in
let fullMoves0 = movesi 0 (win0 @ win1 @ notwon) in
let fullMoves1 = movesi 1 (win0 @ win1 @ notwon) in
@@ -123,7 +126,7 @@
let cmpll l1 l2 = (List.length l2) - (List.length l1) in
let longest = List.hd (List.sort cmpll (win0 @ win1 @ notwon)) in
- let mvlst pre post l = String.concat "; " (List.map (
+ let mvlst pre post l = String.concat "]; [" (List.map (
fun i -> pre ^ (string_of_int i) ^ post) (Aux.range (List.length l))) in
"PLAYERS 1, 2\n" ^
@@ -131,27 +134,26 @@
"REL Win2() = "^ win1f ^ "\n"^
(fst (List.fold_left
(fun (old, i) ((l, r), pre) ->
- (old ^ "\n" ^ "RULE Mv1-" ^ (string_of_int i) ^ ": \n" ^
+ (old ^ "\n" ^ "RULE Mv1r" ^ (string_of_int i) ^ ": \n" ^
(Structure.str l) ^ " -> " ^ (Structure.str r) ^ "\nemb " ^
(String.concat "," (List.map fst (Structure.rel_signature l))) ^
"\npre (" ^ (Formula.str pre) ^ ") and not Win2()"), i+1)
("", 0) moves0)) ^ "\n\n" ^
(fst (List.fold_left
(fun (old, i) ((l, r), pre) ->
- (old ^ "\n" ^ "RULE Mv2-" ^ (string_of_int i) ^ ": \n" ^
+ (old ^ "\n" ^ "RULE Mv2r" ^ (string_of_int i) ^ ": \n" ^
(Structure.str l) ^ " -> " ^ (Structure.str r) ^ "\nemb "^
(String.concat "," (List.map fst (Structure.rel_signature l))) ^
"\npre (" ^ (Formula.str pre) ^ ") and not Win1()"), i+1)
("",0) moves1)) ^ "\n\n" ^
"LOC 0 {
PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
- MOVES [" ^ (mvlst "Mv1-" " -> 1" moves0) ^ "]}
+ MOVES [" ^ (mvlst "Mv1r" " -> 1" moves0) ^ "]}
PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
}
LOC 1 {
PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
- MOVES [" ^ (mvlst "Mv2-" " -> 0" moves1) ^ "] }
+ MOVES [" ^ (mvlst "Mv2r" " -> 0" moves1) ^ "]}
}" ^ "\n" ^
"MODEL "^(Structure.str (List.hd longest))
-
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-01-20 02:32:20 UTC (rev 1647)
@@ -6,7 +6,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));" ^
- " Db (x, y) = ex u (R(x, u) and C(y, u))" in
+ " 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
| _ -> failwith "LearnGameTest:struc_of_string: not a structure"
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Learn/Makefile 2012-01-20 02:32:20 UTC (rev 1647)
@@ -21,15 +21,15 @@
%.learn:
make -C .. Learn/LearnGameTest.native
- ../LearnGameTest.native -f $(basename $@)
+ time ../LearnGameTest.native -f $(basename $@) > $(basename $@).toss
learntests:
make Tic-Tac-Toe001.learn
make Tic-Tac-Toe002.learn
- #make Breakthrough001.learn
+ make Breakthrough001.learn
make Gomoku001.learn
make Connect4001.learn
- make Pawn-Whopping001.learn
+ #make Pawn-Whopping001.learn
.PHONY: clean
Modified: trunk/Toss/Learn/examples/Pawn-Whopping001_02.wrg
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_02.wrg 2012-01-19 03:06:07 UTC (rev 1646)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_02.wrg 2012-01-20 02:32:20 UTC (rev 1647)
@@ -9,11 +9,11 @@
... ... ... ...
... ... ... ...
... ... ... ...
- ... ... ... ...
+ ... W.. ... ...
... ... ... ...
-... ...W ... ...
+... ... ... ...
... ... ... ...
- ... ... ... ...
+ ... W.. ... ...
... ... ... ...
... ... ... ...
@@ -22,15 +22,15 @@
... ... ... ...
... ... ... ...
... ... ... ...
- ... ... ... ...
+ ... W.. ... ...
... ... ... ...
-... ...W ... ...
+... ... ... ...
... ... ... ...
... ... ... ...
... ... ... ...
... ... ... ...
... ... ... ...
- ... ... ... ...
+ ... W.. ... ...
... ... ... ...
... ... ... ...
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_03.wrg
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_03.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_03.wrg 2012-01-20 02:32:20 UTC (rev 1647)
@@ -0,0 +1,36 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... B.. ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_04.wrg
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_04.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_04.wrg 2012-01-20 02:32:20 UTC (rev 1647)
@@ -0,0 +1,36 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_05.nwn
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_05.nwn (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_05.nwn 2012-01-20 02:32:20 UTC (rev 1647)
@@ -0,0 +1,53 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_05.wrg
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_05.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_05.wrg 2012-01-20 02:32:20 UTC (rev 1647)
@@ -0,0 +1,36 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... W.. ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... W.. ...
+... ... ... ...
+... ... ... ..
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
Added: trunk/Toss/Learn/examples/Pawn-Whopping001_06.wrg
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001_06.wrg (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001_06.wrg 2012-01-20 02:32:20 UTC (rev 1647)
@@ -0,0 +1,36 @@
+[ | B:1 {}; W:1 {} | ]
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ...B ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+...B ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...W
+ ... ... ... ...
+ ... ... ... ...
+... ... ... ...
+... ... ... ...
+
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-24 00:49:12
|
Revision: 1653
http://toss.svn.sourceforge.net/toss/?rev=1653&view=rev
Author: lukaszkaiser
Date: 2012-01-24 00:49:05 +0000 (Tue, 24 Jan 2012)
Log Message:
-----------
Nicer webpage on game rule learning, cleanups.
Modified Paths:
--------------
trunk/Toss/Learn/Makefile
trunk/Toss/www/xsl/common.xsl
Added Paths:
-----------
trunk/Toss/Learn/examples/Pawn-Whopping001.toss
trunk/Toss/www/learn.xml
Removed Paths:
-------------
trunk/Toss/Learn/learn.html
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-23 23:33:10 UTC (rev 1652)
+++ trunk/Toss/Learn/Makefile 2012-01-24 00:49:05 UTC (rev 1653)
@@ -34,7 +34,7 @@
make Breakthrough001.learn
make Gomoku001.learn
make Connect4001.learn
- #make Pawn-Whopping001.learn
+ make Pawn-Whopping001.learn
%.reco:
@@ -48,7 +48,7 @@
diff res.play.log examples/$(basename $@)
rm res.play.log
-VIDEOS_TO_TEST = videos/T*
+VIDEOS_TO_TEST = videos/*
VIDEOS = $(notdir $(shell find $(VIDEOS_TO_TEST) -maxdepth 1 -name '*.3gp'))
VIDEOS_BASE = $(basename $(VIDEOS))
VIDEOS_RECO = $(addsuffix .reco, $(VIDEOS_BASE))
@@ -56,6 +56,14 @@
recotests: reco $(VIDEOS_RECO)
+%.webm:
+ ffmpeg -an -i videos/$(basename $@).3gp $@
+
+VIDEOS_WEBM = $(addsuffix .webm, $(VIDEOS_BASE))
+
+webms: $(VIDEOS_WEBM)
+
+
.PHONY: clean
clean:
Added: trunk/Toss/Learn/examples/Pawn-Whopping001.toss
===================================================================
--- trunk/Toss/Learn/examples/Pawn-Whopping001.toss (rev 0)
+++ trunk/Toss/Learn/examples/Pawn-Whopping001.toss 2012-01-24 00:49:05 UTC (rev 1653)
@@ -0,0 +1,71 @@
+PLAYERS 1, 2
+REL Win1() = ex x1 (W(x1) and all x0 not C(x1, x0))
+REL Win2() = ex x1 (B(x1) and all x0 not C(x0, x1))
+
+RULE Mv1r0:
+[e1, e2 | B:1 {}; C:2 {}; Da:2 {}; Db:2 {}; R:2 {}; W (e1) | ] -> [e1, e2 | B:1 {}; C:2 {}; Da:2 {}; Db:2 {}; R:2 {}; W (e2) | ]
+emb W,R,Db,Da,C,B
+pre (ex x1
+ (W(x1) and ex x0 (C(x0, x1) and all x2 not C(x2, x0)) and
+ ex x0 (C(x1, x0) and ex x2 (C(x0, x2) and x2 = e2)))) and not Win2()
+RULE Mv1r1:
+[e1, e2 | B:1 {}; C (e1, e2); Da:2 {}; Db:2 {}; R:2 {}; W (e1) | ] -> [e1, e2 | B:1 {}; C (e1, e2); Da:2 {}; Db:2 {}; R:2 {}; W (e2) | ]
+emb W,R,Db,Da,C,B
+pre (true) and not Win2()
+RULE Mv1r2:
+[e1, e2 | B (e2); C:2 {}; Da:2 {}; Db (e1, e2); R:2 {}; W (e1) | ] -> [e1, e2 | B:1 {}; C:2 {}; Da:2 {}; Db (e1, e2); R:2 {}; W (e2) | ]
+emb W,R,Db,Da,C,B
+pre (true) and not Win2()
+RULE Mv1r3:
+[e1, e2 | B (e2); C:2 {}; Da (e1, e2); Db:2 {}; R:2 {}; W (e1) | ] -> [e1, e2 | B:1 {}; C:2 {}; Da (e1, e2); Db:2 {}; R:2 {}; W (e2) | ]
+emb W,R,Db,Da,C,B
+pre (true) and not Win2()
+
+
+RULE Mv2r0:
+[e1, e2 | B (e2); C:2 {}; Da:2 {}; Db:2 {}; R:2 {}; W:1 {} | ] -> [e1, e2 | B (e1); C:2 {}; Da:2 {}; Db:2 {}; R:2 {}; W:1 {} | ]
+emb W,R,Db,Da,C,B
+pre (ex x1
+ (B(x1) and ex x0 (C(x1, x0) and all x2 not C(x0, x2)) and
+ ex x0 (C(x0, x1) and ex x2 (C(x2, x0) and x2 = e1)))) and not Win1()
+RULE Mv2r1:
+[e1, e2 | B (e2); C:2 {}; Da:2 {}; Db (e1, e2); R:2 {}; W (e1) | ] -> [e1, e2 | B (e1); C:2 {}; Da:2 {}; Db (e1, e2); R:2 {}; W:1 {} | ]
+emb W,R,Db,Da,C,B
+pre (true) and not Win1()
+RULE Mv2r2:
+[e1, e2 | B (e2); C:2 {}; Da (e1, e2); Db:2 {}; R:2 {}; W (e1) | ] -> [e1, e2 | B (e1); C:2 {}; Da (e1, e2); Db:2 {}; R:2 {}; W:1 {} | ]
+emb W,R,Db,Da,C,B
+pre (true) and not Win1()
+RULE Mv2r3:
+[e1, e2 | B (e2); C (e1, e2); Da:2 {}; Db:2 {}; R:2 {}; W:1 {} | ] -> [e1, e2 | B (e1); C (e1, e2); Da:2 {}; Db:2 {}; R:2 {}; W:1 {} | ]
+emb W,R,Db,Da,C,B
+pre (true) and not Win1()
+
+LOC 0 {
+ PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
+ MOVES [Mv1r0 -> 1]; [Mv1r1 -> 1]; [Mv1r2 -> 1]; [Mv1r3 -> 1]}
+ PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
+}
+LOC 1 {
+ PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
+ PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
+ MOVES [Mv2r0 -> 0]; [Mv2r1 -> 0]; [Mv2r2 -> 0]; [Mv2r3 -> 0]}
+}
+MODEL [a1, b1, c1, d1, e1, f1, g1, h1, a2, b2, c2, d2, e2, f2, g2, h2, a3, b3, c3, d3, e3, f3, g3, h3, a4, b4, c4, d4, e4, f4, g4, h4, a5, b5, c5, d5, e5, f5, g5, h5, a6, b6, c6, d6, e6, f6, g6, h6, a7, b7, c7, d7, e7, f7, g7, h7, a8, b8, c8, d8, e8, f8, g8, h8 | Da {(a1, b2); (b1, c2); (c1, d2); (d1, e2); (e1, f2); (f1, g2); (g1, h2); (a2, b3); (b2, c3); (c2, d3); (d2, e3); (e2, f3); (f2, g3); (g2, h3); (a3, b4); (b3, c4); (c3, d4); (d3, e4); (e3, f4); (f3, g4); (g3, h4); (a4, b5); (b4, c5); (c4, d5); (d4, e5); (e4, f5); (f4, g5); (g4, h5); (a5, b6); (b5, c6); (c5, d6); (d5, e6); (e5, f6); (f5, g6); (g5, h6); (a6, b7); (b6, c7); (c6, d7); (d6, e7); (e6, f7); (f6, g7); (g6, h7); (a7, b8); (b7, c8); (c7, d8); (d7, e8); (e7, f8); (f7, g8); (g7, h8)}; Db {(b1, a2); (c1, b2); (d1, c2); (e1, d2); (f1, e2); (g1, f2); (h1, g2); (b2, a3); (c2, b3); (d2, c3); (e2, d3); (f2, e3); (g2, f3); (h2, g3); (b3, a4); (c3, b4); (d3, c4); (e3, d4); (f3, e4); (g3, f4); (h3, g4); (b4, a5); (c4, b5); (d4, c5); (e4, d5); (f4, e5); (g4, f5); (h4, g5); (b5, a6); (c5, b6); (d5, c6); (e5, d6); (f5, e6); (g5, f6); (h5, g6); (b6, a7); (c6, b7); (d6, c7); (e6, d7); (f6, e7); (g6, f7); (h6, g7); (b7, a8); (c7, b8); (d7, c8); (e7, d8); (f7, e8); (g7, f8); (h7, g8)} | ] "
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ ... ... ... ...
+"
Deleted: trunk/Toss/Learn/learn.html
===================================================================
--- trunk/Toss/Learn/learn.html 2012-01-23 23:33:10 UTC (rev 1652)
+++ trunk/Toss/Learn/learn.html 2012-01-24 00:49:05 UTC (rev 1653)
@@ -1,160 +0,0 @@
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:foaf="http://xmlns.com/foaf/0.1/" xmlns:bibtex="http://bibtexml.sf.net/" xml:lang="en" lang="en">
- <head>
- <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
- <link rel="stylesheet" type="text/css" href="./styles/common.css" media="all" />
- <link rel="stylesheet" type="text/css" href="./styles/screen.css" media="screen" />
- <link rel="stylesheet" type="text/css" href="./styles/print.css" media="print" />
- <link rel="stylesheet" type="text/css" href="http://fonts.googleapis.com/css?family=Ubuntu:regular,bold" />
- <link rel="shortcut icon" href="./img/favicon.ico" />
- <title>Learning Game Rules from Videos</title>
- <script src="./scripts/nomap.js" type="text/javascript"></script>
- <script src="./scripts/main.js" type="text/javascript"></script>
- </head>
- <body onload="gload()" onunload="gunload()">
- <div id="page">
- <div id="header">
- <div id="headerlogo">
- <a href="http://toss.sourceforge.net" id="logo"></a>
- <div id="mgi-title">
- <h3></h3>
- </div>
- </div>
- <a href="http://toss.sourceforge.net" id="left-logo">Toss</a>
- <div id="parentnav">
- <ul>
- <li>
- <a href="index.html.de">Deutsch</a>
- </li>
- <li class="selected">
- <span>English</span>
- </li>
- <li>
- <a href="index.html.fr">Français</a>
- </li>
- <li>
- <a href="index.html.pol">Polski</a>
- </li>
- </ul>
- </div>
- </div>
- <div id="container" class="with-sidebar">
- <div id="primary">
- <div id="content">
- <div>
-
-<div class="title">
- <h1 property="foaf:title">Learning Game Rules from Videos</h1>
-</div>
-
-<h2>Breakthrough</h2>
-
-<p>Illustrating plays and positions not won by anyone</p>
-<video width="352" height="288" controls="controls">
- <source src="videos/Breakthrough001_01.nwn.3gp" type="video/3gpp" />
- <source src="videos/Breakthrough001_01.nwn.webm" type="video/webm" />
- Your browser does not support the video tag.
-</video>
-<video width="352" height="288" controls="controls">
- <source src="videos/Breakthrough001_02.nwn.3gp" type="video/3gpp" />
- <source src="videos/Breakthrough001_02.nwn.webm" type="video/webm" />
- Your browser does not support the video tag.
-</video>
-<video width="352" height="288" controls="controls">
- <source src="videos/Breakthrough001_03.nwn.3gp" type="video/3gpp" />
- <source src="videos/Breakthrough001_03.nwn.webm" type="video/webm" />
- Your browser does not support the video tag.
-</video>
-
-
-<p>Winning for the first player</p>
-<video width="352" height="288" controls="controls">
- <source src="videos/Breakthrough001_01.wn0.3gp" type="video/3gpp" />
- <source src="videos/Breakthrough001_01.wn0.webm" type="video/webm" />
- Your browser does not support the video tag.
-</video>
-
-<p>Winning for the second player</p>
-<video width="352" height="288" controls="controls">
- <source src="videos/Breakthrough001_01.wn1.3gp" type="video/3gpp" />
- <source src="videos/Breakthrough001_01.wn1.webm" type="video/webm" />
- Your browser does not support the video tag.
-</video>
-
-
- </div>
- </div>
- </div>
- <div id="secondary">
- <div id="sidebar">
- <div class="childnav" id="menu">
- <div class="childnav-top"></div>
- <ul>
- <li class="selected">
- <a href="./index.html.en" class="menu-top">Home</a>
- </li>
- <li class="">
- <a href="http://tplay.org" class="menu-top">Play Online</a>
- </li>
- <li class="">
- <a href="http://sourceforge.net/project/showfiles.php?group_id=115606" class="menu-top">Download Toss</a>
- </li>
- <li class="">
- <a href="./create.html.en" class="menu-title menu-top">Create Games</a>
- <ul>
- <li class="">
- <a href="http://vimeo.com/10110495" class="menu-sub">Video Tutorial</a>
- </li>
- <li class="">
- <a href="./examples.html.en" class="menu-sub">Examples</a>
- </li>
- <li class="">
- <a href="./gui_interface.html.en" class="menu-sub">GUI Interface Guide</a>
- </li>
- </ul>
- </li>
- <li class="">
- <a href="./play.html.en" class="menu-top">Watch Toss Play</a>
- </li>
- <li class="">
- <a href="./docs.html.en" class="menu-title menu-top">Documentation</a>
- <ul>
- <li class="">
- <a href="./reference/reference.pdf" class="menu-sub">Reference (pdf)</a>
- </li>
- <li class="">
- <a href="./reference/index.html.en" class="menu-sub">Reference (html)</a>
- </li>
- </ul>
- </li>
- <li class="">
- <a href="./Publications/index.html.en" class="menu-top">Papers and Talks</a>
- </li>
- <li class="">
- <a href="./develop.html.en" class="menu-title menu-top">Develop Toss</a>
- <ul>
- <li class="">
- <a href="./ocaml.html.en" class="menu-sub">Mini OCaml Tutorial</a>
- </li>
- <li class="">
- <a href="./codebasics.html.en" class="menu-sub">Toss Code Basics</a>
- </li>
- <li class="">
- <a href="./code_doc/index.html.en" class="menu-sub">Code Documentation</a>
- </li>
- </ul>
- </li>
- <li class="">
- <a href="./contact.html.en" class="menu-top">Contact and Links</a>
- </li>
- </ul>
- </div>
- </div>
- </div>
- </div>
- </div>
- <div id="footer">
- © 2012 Toss Team
- </div>
- </body>
-</html>
Added: trunk/Toss/www/learn.xml
===================================================================
--- trunk/Toss/www/learn.xml (rev 0)
+++ trunk/Toss/www/learn.xml 2012-01-24 00:49:05 UTC (rev 1653)
@@ -0,0 +1,165 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE lecture SYSTEM "xsl/xhtml1-lat1.ent">
+
+<?xml-stylesheet type="text/xsl" href="xsl/main.xsl" charset="UTF-8"?>
+
+<personal>
+ <title lang="en">Learning Game Rules from Videos</title>
+ <title lang="de">Spielregeln von Videos Lehrnen (auf Englisch)</title>
+ <title lang="pol">Indukcja reguł gier z filmów (po angielsku)</title>
+ <title lang="fr">Apprendre des règles de jeux (à anglais)</title>
+ <history>
+ <link id="learn" href="/learn.html">Learning Game Rules from Videos</link>
+ </history>
+
+ <section title="Breakthrough">
+ <subsection>Resulting game: </subsection>
+ <a href="videos/Breakthrough001.toss.txt">toss file</a> <br/>
+
+ <subsection>Illustrating plays and positions not won by anyone</subsection>
+ <br/>
+ <playvideo name="Breakthrough001_01.nwn" />
+ <playvideo name="Breakthrough001_02.nwn" />
+ <playvideo name="Breakthrough001_03.nwn" />
+
+ <subsection>Winning for the first player</subsection> <br/>
+ <playvideo name="Breakthrough001_01.wn0" />
+
+ <subsection>Winning for the second player</subsection> <br/>
+ <playvideo name="Breakthrough001_01.wn1" />
+ </section>
+
+ <section title="Connect4">
+ <subsection>Resulting game: </subsection>
+ <a href="videos/Connect4001.toss.txt">toss file</a> <br/>
+
+ <subsection>Illustrating plays and positions not won by anyone</subsection>
+ <br/>
+ <playvideo name="Connect4001_01.nwn" />
+ <playvideo name="Connect4001_02.nwn" />
+ <playvideo name="Connect4001_03.nwn" />
+ <playvideo name="Connect4001_04.nwn" />
+ <playvideo name="Connect4001_05.nwn" />
+ <playvideo name="Connect4001_06.nwn" />
+ <playvideo name="Connect4001_07.nwn" />
+ <playvideo name="Connect4001_08.nwn" />
+ <playvideo name="Connect4001_09.nwn" />
+ <playvideo name="Connect4001_10.nwn" />
+ <playvideo name="Connect4001_11.nwn" />
+ <playvideo name="Connect4001_12.nwn" />
+ <playvideo name="Connect4001_13.nwn" />
+
+ <subsection>Winning for the first player</subsection> <br/>
+ <playvideo name="Connect4001_01.wn0" />
+ <playvideo name="Connect4001_02.wn0" />
+ <playvideo name="Connect4001_03.wn0" />
+ <playvideo name="Connect4001_04.wn0" />
+
+ <subsection>Winning for the second player</subsection> <br/>
+ <playvideo name="Connect4001_01.wn1" />
+ <playvideo name="Connect4001_02.wn1" />
+ <playvideo name="Connect4001_03.wn1" />
+ <playvideo name="Connect4001_04.wn1" />
+
+ <subsection>Illustrating illegal moves (last one)</subsection> <br/>
+ <playvideo name="Connect4001_01.wrg" />
+ <playvideo name="Connect4001_02.wrg" />
+ <playvideo name="Connect4001_03.wrg" />
+ <playvideo name="Connect4001_04.wrg" />
+ </section>
+
+
+ <section title="Pawn-Whopping">
+ <subsection>Resulting game: </subsection>
+ <a href="videos/Pawn-Whopping001.toss.txt">toss file</a> <br/>
+
+ <subsection>Illustrating plays and positions not won by anyone</subsection>
+ <br/>
+ <playvideo name="Pawn-Whopping001_01.nwn" />
+ <playvideo name="Pawn-Whopping001_02.nwn" />
+ <playvideo name="Pawn-Whopping001_03.nwn" />
+ <playvideo name="Pawn-Whopping001_04.nwn" />
+
+ <subsection>Winning for the first player</subsection> <br/>
+ <playvideo name="Pawn-Whopping001_01.wn0" />
+
+ <subsection>Winning for the second player</subsection> <br/>
+ <playvideo name="Pawn-Whopping001_01.wn1" />
+
+ <subsection>Illustrating illegal moves (last one)</subsection> <br/>
+ <playvideo name="Pawn-Whopping001_01.wrg" />
+ <playvideo name="Pawn-Whopping001_02.wrg" />
+ <playvideo name="Pawn-Whopping001_03.wrg" />
+ <playvideo name="Pawn-Whopping001_04.wrg" />
+ <playvideo name="Pawn-Whopping001_05.wrg" />
+ <playvideo name="Pawn-Whopping001_06.wrg" />
+ </section>
+
+ <section title="Tic-Tac-Toe">
+ <subsection>Resulting game: </subsection>
+ <a href="videos/Tic-Tac-Toe001.toss.txt">toss file</a> <br/>
+
+ <subsection>Illustrating plays and positions not won by anyone</subsection>
+ <br/>
+ <playvideo name="Tic-Tac-Toe001_01.nwn" />
+ <playvideo name="Tic-Tac-Toe001_02.nwn" />
+ <playvideo name="Tic-Tac-Toe001_03.nwn" />
+ <playvideo name="Tic-Tac-Toe001_04.nwn" />
+ <playvideo name="Tic-Tac-Toe001_05.nwn" />
+ <playvideo name="Tic-Tac-Toe001_06.nwn" />
+ <playvideo name="Tic-Tac-Toe001_07.nwn" />
+ <playvideo name="Tic-Tac-Toe001_08.nwn" />
+ <playvideo name="Tic-Tac-Toe001_09.nwn" />
+ <playvideo name="Tic-Tac-Toe001_10.nwn" />
+ <playvideo name="Tic-Tac-Toe001_11.nwn" />
+ <playvideo name="Tic-Tac-Toe001_12.nwn" />
+ <playvideo name="Tic-Tac-Toe001_13.nwn" />
+ <playvideo name="Tic-Tac-Toe001_14.nwn" />
+ <playvideo name="Tic-Tac-Toe001_15.nwn" />
+ <playvideo name="Tic-Tac-Toe001_16.nwn" />
+ <playvideo name="Tic-Tac-Toe001_17.nwn" />
+
+ <subsection>Winning for the first player</subsection> <br/>
+ <playvideo name="Tic-Tac-Toe001_01.wn0" />
+ <playvideo name="Tic-Tac-Toe001_02.wn0" />
+ <playvideo name="Tic-Tac-Toe001_03.wn0" />
+ <playvideo name="Tic-Tac-Toe001_04.wn0" />
+
+ <subsection>Winning for the second player</subsection> <br/>
+ <playvideo name="Tic-Tac-Toe001_01.wn1" />
+ <playvideo name="Tic-Tac-Toe001_02.wn1" />
+ <playvideo name="Tic-Tac-Toe001_03.wn1" />
+ <playvideo name="Tic-Tac-Toe001_04.wn1" />
+ </section>
+
+ <section title="Gomoku">
+ <subsection>Resulting game: </subsection>
+ <a href="videos/Gomoku001.toss.txt">toss file</a> <br/>
+
+ <subsection>Illustrating plays and positions not won by anyone</subsection>
+ <br/>
+ <playvideo name="Gomoku001_01.nwn" />
+ <playvideo name="Gomoku001_02.nwn" />
+ <playvideo name="Gomoku001_03.nwn" />
+ <playvideo name="Gomoku001_04.nwn" />
+ <playvideo name="Gomoku001_05.nwn" />
+ <playvideo name="Gomoku001_06.nwn" />
+ <playvideo name="Gomoku001_07.nwn" />
+ <playvideo name="Gomoku001_08.nwn" />
+ <playvideo name="Gomoku001_09.nwn" />
+
+ <subsection>Winning for the first player</subsection> <br/>
+ <playvideo name="Gomoku001_01.wn0" />
+ <playvideo name="Gomoku001_02.wn0" />
+ <playvideo name="Gomoku001_03.wn0" />
+ <playvideo name="Gomoku001_04.wn0" />
+
+ <subsection>Winning for the second player</subsection> <br/>
+ <playvideo name="Gomoku001_01.wn1" />
+ <playvideo name="Gomoku001_02.wn1" />
+ <playvideo name="Gomoku001_03.wn1" />
+ <playvideo name="Gomoku001_04.wn1" />
+ </section>
+
+
+</personal>
Modified: trunk/Toss/www/xsl/common.xsl
===================================================================
--- trunk/Toss/www/xsl/common.xsl 2012-01-23 23:33:10 UTC (rev 1652)
+++ trunk/Toss/www/xsl/common.xsl 2012-01-24 00:49:05 UTC (rev 1653)
@@ -110,13 +110,22 @@
</pre>
</xsl:template>
+<xsl:template match="playvideo">
+ <video width="352" height="288" controls="controls">
+ <source src="videos/{@name}.3gp" type="video/3gpp" />
+ <source src="videos/{@name}.webm" type="video/webm" />
+ Your browser does not support the video tag.
+ </video>
+ <a href="videos/{@name}.txt">Text</a>
+</xsl:template>
+
+
<xsl:template match="pre">
<pre class="code">
<xsl:apply-templates />
</pre>
</xsl:template>
-
<xsl:template match="em">
<em><xsl:apply-templates /></em>
</xsl:template>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-24 14:44:09
|
Revision: 1654
http://toss.svn.sourceforge.net/toss/?rev=1654&view=rev
Author: lukaszkaiser
Date: 2012-01-24 14:43:58 +0000 (Tue, 24 Jan 2012)
Log Message:
-----------
Allow reco in bash mode.
Modified Paths:
--------------
trunk/Toss/Learn/Makefile
trunk/Toss/Learn/reco.cpp
trunk/Toss/www/learn.xml
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-24 00:49:05 UTC (rev 1653)
+++ trunk/Toss/Learn/Makefile 2012-01-24 14:43:58 UTC (rev 1654)
@@ -39,11 +39,11 @@
%.reco:
if [[ $@ = Breakthrough* ]]; then \
- ./reco W B videos/$(basename $@).3gp > res.play.log; \
+ ./reco W B videos/$(basename $@).3gp n > res.play.log; \
elif [[ $@ = Pawn* ]]; then \
- ./reco W B videos/$(basename $@).3gp > res.play.log; \
+ ./reco W B videos/$(basename $@).3gp n > res.play.log; \
else \
- ./reco Q P videos/$(basename $@).3gp > res.play.log; \
+ ./reco Q P videos/$(basename $@).3gp n > res.play.log; \
fi
diff res.play.log examples/$(basename $@)
rm res.play.log
Modified: trunk/Toss/Learn/reco.cpp
===================================================================
--- trunk/Toss/Learn/reco.cpp 2012-01-24 00:49:05 UTC (rev 1653)
+++ trunk/Toss/Learn/reco.cpp 2012-01-24 14:43:58 UTC (rev 1654)
@@ -61,11 +61,13 @@
{
char res[2000];
int rnbr = -2;
+ int window = 1;
- if (argc != 4) {
- printf ("Usage: reco [letter for white] [letter for black] [filename]\n");
+ if ((argc != 4 && argc != 5) || (argc == 5 && argv[4][0] != 'n')) {
+ printf ("Usage: reco [white] [black] [filename] (n: no window) \n");
return (1);
}
+ if (argc == 5) { window = 0; }
// Print signature and set it in shapes module
printf ("[ | %c:1 {}; %c:1 {} | ]\n\n", argv[1][0], argv[2][0]);
@@ -73,7 +75,7 @@
setRedChar (argv[2][0]);
// Start recognition
- cvNamedWindow ("Reco", CV_WINDOW_AUTOSIZE);
+ if (window) { cvNamedWindow ("Reco", CV_WINDOW_AUTOSIZE); }
CvCapture* capture = cvCreateFileCapture (argv[3]);
// cvCreateCameraCapture( 0 );
IplImage *img, *col, *gray, *small, *smallpre;
@@ -154,7 +156,7 @@
from_point (p.shape[s].end), CV_RGB (200, 100, 100), 3);
}
}
- cvShowImage( "Reco", small );
+ if (window) { cvShowImage( "Reco", small ); }
if (time % timeSTEP == 0) { // wait timeSTEP frames
int ok_lines = 0;
for( i = 0; i < lines->total; i++ ) {
@@ -205,8 +207,10 @@
for (int i = 0; i < SIZEX*SIZEY*24; i++) fullsh_str[i] = 0;
}
time++;
- char c = cvWaitKey (50);
- if (c == 27) break;
+ if (window) {
+ char c = cvWaitKey (50);
+ if (c == 27) break;
+ }
}
cvReleaseCapture (&capture);
cvDestroyWindow ("Reco");
Modified: trunk/Toss/www/learn.xml
===================================================================
--- trunk/Toss/www/learn.xml 2012-01-24 00:49:05 UTC (rev 1653)
+++ trunk/Toss/www/learn.xml 2012-01-24 14:43:58 UTC (rev 1654)
@@ -14,7 +14,9 @@
<section title="Breakthrough">
<subsection>Resulting game: </subsection>
- <a href="videos/Breakthrough001.toss.txt">toss file</a> <br/>
+ <a href="videos/Breakthrough001.toss.txt">toss file</a>,
+ <a href="http://tplay.org/index.html?simple=true?game=Breakthrough"
+ >play</a> <br/>
<subsection>Illustrating plays and positions not won by anyone</subsection>
<br/>
@@ -31,7 +33,9 @@
<section title="Connect4">
<subsection>Resulting game: </subsection>
- <a href="videos/Connect4001.toss.txt">toss file</a> <br/>
+ <a href="videos/Connect4001.toss.txt">toss file</a>,
+ <a href="http://tplay.org/index.html?simple=true?game=Connect4"
+ >play</a> <br/>
<subsection>Illustrating plays and positions not won by anyone</subsection>
<br/>
@@ -71,7 +75,9 @@
<section title="Pawn-Whopping">
<subsection>Resulting game: </subsection>
- <a href="videos/Pawn-Whopping001.toss.txt">toss file</a> <br/>
+ <a href="videos/Pawn-Whopping001.toss.txt">toss file</a>,
+ <a href="http://tplay.org/index.html?simple=true?game=Pawn-Whopping"
+ >play</a> <br/>
<subsection>Illustrating plays and positions not won by anyone</subsection>
<br/>
@@ -97,7 +103,9 @@
<section title="Tic-Tac-Toe">
<subsection>Resulting game: </subsection>
- <a href="videos/Tic-Tac-Toe001.toss.txt">toss file</a> <br/>
+ <a href="videos/Tic-Tac-Toe001.toss.txt">toss file</a>,
+ <a href="http://tplay.org/index.html?simple=true?game=Tic-Tac-Toe"
+ >play</a> <br/>
<subsection>Illustrating plays and positions not won by anyone</subsection>
<br/>
@@ -134,7 +142,9 @@
<section title="Gomoku">
<subsection>Resulting game: </subsection>
- <a href="videos/Gomoku001.toss.txt">toss file</a> <br/>
+ <a href="videos/Gomoku001.toss.txt">toss file</a>,
+ <a href="http://tplay.org/index.html?simple=true?game=Gomoku"
+ >play</a> <br/>
<subsection>Illustrating plays and positions not won by anyone</subsection>
<br/>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-30 15:14:51
|
Revision: 1655
http://toss.svn.sourceforge.net/toss/?rev=1655&view=rev
Author: lukaszkaiser
Date: 2012-01-30 15:14:41 +0000 (Mon, 30 Jan 2012)
Log Message:
-----------
Technical correction to make videos work on www.
Modified Paths:
--------------
trunk/Toss/Learn/Makefile
trunk/Toss/www/xsl/common.xsl
Added Paths:
-----------
trunk/Toss/www/.htaccess
Modified: trunk/Toss/Learn/Makefile
===================================================================
--- trunk/Toss/Learn/Makefile 2012-01-24 14:43:58 UTC (rev 1654)
+++ trunk/Toss/Learn/Makefile 2012-01-30 15:14:41 UTC (rev 1655)
@@ -59,9 +59,17 @@
%.webm:
ffmpeg -an -i videos/$(basename $@).3gp $@
+%.mp4:
+ ffmpeg -an -i videos/$(basename $@).3gp $@
+
+%.ogv: %.mp4
+ ffmpeg -an -i videos/$(basename $@).3gp $@
+
VIDEOS_WEBM = $(addsuffix .webm, $(VIDEOS_BASE))
+VIDEOS_OGG = $(addsuffix .ogv, $(VIDEOS_BASE))
+VIDEOS_MP4 = $(addsuffix .mp4, $(VIDEOS_BASE))
-webms: $(VIDEOS_WEBM)
+webvideos: $(VIDEOS_WEBM) $(VIDEOS_MP4) $(VIDEOS_OGG)
.PHONY: clean
Added: trunk/Toss/www/.htaccess
===================================================================
--- trunk/Toss/www/.htaccess (rev 0)
+++ trunk/Toss/www/.htaccess 2012-01-30 15:14:41 UTC (rev 1655)
@@ -0,0 +1,3 @@
+AddType video/webm .webm
+AddType video/ogg .ogv
+AddType video/mp4 .mp4
Modified: trunk/Toss/www/xsl/common.xsl
===================================================================
--- trunk/Toss/www/xsl/common.xsl 2012-01-24 14:43:58 UTC (rev 1654)
+++ trunk/Toss/www/xsl/common.xsl 2012-01-30 15:14:41 UTC (rev 1655)
@@ -112,8 +112,9 @@
<xsl:template match="playvideo">
<video width="352" height="288" controls="controls">
- <source src="videos/{@name}.3gp" type="video/3gpp" />
+ <source src="videos/{@name}.mp4" type="video/mp4" />
<source src="videos/{@name}.webm" type="video/webm" />
+ <source src="videos/{@name}.ogv" type="video/ogg" />
Your browser does not support the video tag.
</video>
<a href="videos/{@name}.txt">Text</a>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-01-30 19:21:56
|
Revision: 1656
http://toss.svn.sourceforge.net/toss/?rev=1656&view=rev
Author: lukaszkaiser
Date: 2012-01-30 19:21:45 +0000 (Mon, 30 Jan 2012)
Log Message:
-----------
Small test correction, less Str in Structure.
Modified Paths:
--------------
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Solver/Structure.ml
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-30 15:14:41 UTC (rev 1655)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-01-30 19:21:45 UTC (rev 1656)
@@ -49,26 +49,26 @@
REL Win1() = ex x0 (Q(x0) and ex x1 R(x0, x1))
REL Win2() = ex x1 (Q(x1) and ex x0 R(x0, x1))
-RULE Mv1-0:
+RULE Mv1r0:
[e1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [e1 | P (e1); Q:1 {}; R:2 {} | ]
emb R,Q,P
pre (true) and not Win2()
-RULE Mv2-0:
+RULE Mv2r0:
[e1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [e1 | P:1 {}; Q (e1); R:2 {} | ]
emb R,Q,P
pre (true) and not Win1()
LOC 0 {
PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
- MOVES [Mv1-0 -> 1]}
+ MOVES [Mv1r0 -> 1]}
PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
}
LOC 1 {
PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
- MOVES [Mv2-0 -> 0] }
+ MOVES [Mv2r0 -> 0]}
}
MODEL [ | P:1 {}; Q:1 {} | ] R R \"
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-01-30 15:14:41 UTC (rev 1655)
+++ trunk/Toss/Solver/Structure.ml 2012-01-30 19:21:45 UTC (rev 1656)
@@ -1255,16 +1255,17 @@
let uniq = uniq1 @ uniq2 @ uniq3 in
let lines = Str.split (Str.regexp "[\r\n]+\t*") board in
let lines = List.filter (fun s->String.length s > 2) lines in
- let rexp =
- Str.regexp "[a-zA-Z0-9_ .*?#+-][a-zA-Z0-9_ .?#][a-zA-Z0-9_ .?#]" in
- let split_line line =
- List.map (function
- | Str.Delim field -> assert (String.length field = 3); field
- | Str.Text txt ->
- raise (Board_parse_error
- ("Unrecognized field line: \"" ^ txt ^
- "\" of board line: \"" ^ line ^"\"")))
- (Str.full_split rexp line) in
+ let rec split_line line =
+ let is_ok c = c = ' ' || c = '.' || Aux.is_alphanum c || c = '_' ||
+ c = '*' || c = '?' || c = '#' || c = '+' || c = '-' in
+ let error txt = raise (Board_parse_error
+ ("Unrecognized field line: \"" ^ txt ^
+ "\" of board line: \"" ^ line ^"\"")) in
+ if line = "" then [] else if String.length line < 3 then error line else
+ if (is_ok line.[0] && is_ok line.[1] && is_ok line.[2]) then
+ let rest = String.sub line 3 ((String.length line) - 3) in
+ (String.sub line 0 3) :: (split_line rest)
+ else error (String.sub line 0 3) in
let rec rev_combine_pairs acc = function
| [] -> acc
| [hd] ->
@@ -1284,7 +1285,7 @@
else
let fields = ref fields in
let parse s =
- let s = Str.string_before s
+ let s = String.sub s 0
(min (try String.index s ' ' with Not_found -> 3)
(try String.index s '.' with Not_found -> 3)) in
let sl = String.length s - 1 in
@@ -1295,12 +1296,12 @@
else if s.[0] = '*' then ["*"] (* treated specially *)
else if sl = 0 && s.[sl] = '?' then ["_any_"]
else if s.[0] = '+' then
- let p = unabbrev (omit 1 s) in ["_new_"^p; p]
+ let p = unabbrev (omit 1 s) in ["_new_" ^ p; p]
else if s.[0] = '-' then ["_del_"^unabbrev (omit 1 s)]
- else if s.[sl] = '?' then [unabbrev (Str.string_before s sl); "_any_"]
+ else if s.[sl] = '?' then [unabbrev (String.sub s 0 sl); "_any_"]
else if s.[0] = '?' then ["_opt_"^unabbrev (omit 1 s)]
else if s.[sl] = '#' then
- ["_diffthan_"^unabbrev (Str.string_before s sl); "_any_"]
+ ["_diffthan_" ^ unabbrev (String.sub s 0 sl); "_any_"]
else if s.[0] = '#' then ["_diffthan_"^unabbrev (omit 1 s)]
else [unabbrev s] in
let board_els =
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2012-02-01 10:17:29
|
Revision: 1657
http://toss.svn.sourceforge.net/toss/?rev=1657&view=rev
Author: lukstafi
Date: 2012-02-01 10:17:21 +0000 (Wed, 01 Feb 2012)
Log Message:
-----------
Standalone variant of JavaScript interface.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/RealQuantElim/SignTable.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Play.js
trunk/Toss/WebClient/State.js
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/Server/GameSelection.ml
trunk/Toss/Server/JsHandler.ml
trunk/Toss/Solver/RealQuantElim/N.ml
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/Local.js
trunk/Toss/WebClient/local.html
trunk/Toss/www/reference/TossComponents.dot
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/Aux.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -2,10 +2,12 @@
structures and standard library-like definitions. *)
let gettimeofday () =
- IFDEF NOUNIX
- THEN 1.
- ELSE Unix.gettimeofday ()
- ENDIF
+ 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
@@ -739,3 +741,34 @@
Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
}
+
+(* 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-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/Aux.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -355,3 +355,17 @@
(** Set more agressive Gc values optimized for heavier computations. *)
val set_optimized_gc : unit -> unit
+
+(** 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. *)
+val split_regexp : regexp:string -> string -> string list
+
+(** [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
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -14,12 +14,15 @@
if test_fname then f ()
let run_test_if_target target_name tests =
- 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
+ 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
-
let rec input_file file =
let buf = Buffer.create 256 in
(try
@@ -33,9 +36,14 @@
close_in f; res
let list_dir dirname =
- let files, dir_handle = (ref [], Unix.opendir dirname) in
- let rec add () = files := (Unix.readdir dir_handle) :: !files; add () in
- try add () with End_of_file -> Unix.closedir dir_handle; !files
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript file manipulation not implemented yet"
+ ) ELSE (
+ let files, dir_handle = (ref [], Unix.opendir dirname) in
+ let rec add () =
+ files := (Unix.readdir dir_handle) :: !files; add () in
+ try add () with End_of_file -> Unix.closedir dir_handle; !files
+ ) ENDIF
let rec input_http_message file =
let buf = Buffer.create 256 in
@@ -76,29 +84,38 @@
exception Host_not_found
let get_inet_addr addr_s =
- try
- Unix.inet_addr_of_string addr_s
- with Failure _ ->
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript TCP/IP manipulation not implemented yet"
+ ) ELSE (
try
- let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
- if Array.length addr_arr < 1 then raise Host_not_found else
- addr_arr.(0)
- with Not_found -> raise Host_not_found
+ Unix.inet_addr_of_string addr_s
+ with Failure _ ->
+ try
+ let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
+ if Array.length addr_arr < 1 then raise Host_not_found else
+ addr_arr.(0)
+ with Not_found -> raise Host_not_found
+ ) ENDIF
let toss_call (client_port, client_addr_s) f_in x =
- try
- let client_addr = get_inet_addr client_addr_s in
- let client_sock = Unix.ADDR_INET (client_addr, client_port) in
- let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
- output_string cl_out_ch "COMP\n";
- flush cl_out_ch;
- let f a = try `Res (f_in a) with exn -> `Exn exn in
- Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
- flush cl_out_ch;
- (fun () ->
- let res = Marshal.from_channel cl_in_ch in
- Unix.shutdown_connection cl_in_ch;
- match res with `Res r -> r | `Exn e -> raise e)
- with Unix.Unix_error (e, f, s) ->
- Printf.printf "Toss call failed: %s; %s %s\n%!" (Unix.error_message e) f s;
- (fun () -> f_in x)
+ IFDEF JAVASCRIPT THEN (
+ failwith "JavaScript TCP/IP manipulation not implemented yet"
+ ) ELSE (
+ try
+ let client_addr = get_inet_addr client_addr_s in
+ let client_sock = Unix.ADDR_INET (client_addr, client_port) in
+ let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
+ output_string cl_out_ch "COMP\n";
+ flush cl_out_ch;
+ let f a = try `Res (f_in a) with exn -> `Exn exn in
+ Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
+ flush cl_out_ch;
+ (fun () ->
+ let res = Marshal.from_channel cl_in_ch in
+ Unix.shutdown_connection cl_in_ch;
+ match res with `Res r -> r | `Exn e -> raise e)
+ with Unix.Unix_error (e, f, s) ->
+ Printf.printf "Toss call failed: %s; %s %s\n%!"
+ (Unix.error_message e) f s;
+ (fun () -> f_in x)
+ ) ENDIF
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -945,7 +945,7 @@
!clause in
let list_int line =
- let split = Str.split (Str.regexp "[ \t]+") line in
+ let split = Aux.split_regexp ~regexp:"[ \t]+" line in
List.rev (List.tl (List.rev_map
(fun s -> int_of_string s) (List.tl split))) in
Modified: trunk/Toss/Learn/LearnGameTest.ml
===================================================================
--- trunk/Toss/Learn/LearnGameTest.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Learn/LearnGameTest.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -84,7 +84,8 @@
let get_strucs s =
let split_list ?(bound=None) pat s =
let r = Str.regexp_string pat in
- match bound with None-> Str.split r s | Some b-> Str.bounded_split r s b in
+ match bound with None-> Str.split r s
+ | Some b-> Str.bounded_split r s b in
let cl = String.index s '\n' in
let pref, st_s = String.sub s 0 cl, String.sub s cl ((String.length s)-cl) in
let strucstr s = pref ^ " \n\"" ^ s ^ "\n\"" in
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Makefile 2012-02-01 10:17:21 UTC (rev 1657)
@@ -3,9 +3,13 @@
TossServer: Server/Server.native
cp _build/Server/Server.native TossServer
-js_of_ocaml_test.js: js_of_ocaml_test.byte
- js_of_ocaml js_of_ocaml_test.byte
+WebClient/JsHandler.js: Server/JsHandler.byte
+ js_of_ocaml _build/$<
+ cp _build/Server/JsHandler.js WebClient/JsHandler.js
+%.js: %.byte
+ js_of_ocaml _build/$<
+
RELEASE=0.6
Release: TossServer doc
rm -f *~ Formula/*~ Solver/*~ Arena/*~ Play/*~ GGP/*~ \
@@ -41,7 +45,7 @@
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 -DNOREALQE -DNOUNIX 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_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
OCAMLBUILDJS=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PPJS) \
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/GameTree.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -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
- Str.global_replace (Str.regexp "\n") ("\n" ^ prefix) res in
+ Aux.replace_regexp ~regexp:"\n" ~templ:("\n" ^ prefix) res in
if upto < 0 then " Cut;" else
match tree with
| Terminal (state, player, info) ->
Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/Move.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -12,12 +12,18 @@
TODO: fixed for now. *)
val cGRID_SIZE : int
-(** Generate moves available from a state, as an array, in fixed order. *)
+(** 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 -> Arena.player_loc -> Arena.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 -> Arena.game_state ->
float -> Arena.move array -> Arena.move array * Arena.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 : Arena.game -> Arena.game_state ->
(int * Arena.move * Arena.game_state) array
Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/Play.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -6,9 +6,9 @@
let set_debug_level i = debug_level := i
let timeout = ref 0.
-let set_timeout t = timeout := Unix.gettimeofday() +. t
+let set_timeout t = timeout := Aux.gettimeofday() +. t
let cancel_timeout () = timeout := 0.
-let timed_out () = !timeout > 1. && Unix.gettimeofday() +. 0.01 > !timeout
+let timed_out () = !timeout > 1. && Aux.gettimeofday() +. 0.01 > !timeout
(* ------------ MAXIMAX BY DEPTH ------------- *)
@@ -63,9 +63,11 @@
| Aux.Timeout msg ->
if !debug_level > 0 then
Printf.printf "Timeout %f (%s)%!"
- (Unix.gettimeofday() -. !timeout) msg;
+ (Aux.gettimeofday() -. !timeout) msg;
(t, mvs)
+let latest_gametree_size = ref 0
+
(* 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! *)
@@ -75,6 +77,7 @@
let t = init game state (fun _ _ _ -> 0) heur in
try
let (u, mvs) = unfold_maximax_upto ~ab count game heur (t, []) in
+ latest_gametree_size := GameTree.size u;
let nbr_to_check = min (2*check_stable + 1) (List.length mvs / 3) in
let last_mvs = Aux.take_n (max 1 nbr_to_check) mvs in
if !debug_level = 2 then
Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Play/Play.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -23,3 +23,7 @@
val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
Arena.game_state -> Formula.real_expr array array ->
(Arena.move * Arena.game_state) list
+
+(** Size of the game-tree produced by the latest call of
+ {!Play.maximax_unfold_choose}. *)
+val latest_gametree_size : int ref
Added: trunk/Toss/Server/GameSelection.ml
===================================================================
--- trunk/Toss/Server/GameSelection.ml (rev 0)
+++ trunk/Toss/Server/GameSelection.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,654 @@
+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_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
+ {heuristic = compute_heuristic adv_ratio game_with_state;
+ game_state = game_with_state;
+ playclock = 30; (* game clock from where? *)
+ game_str = game_str;
+ }
+
+(* Maximum call stack size exceeded in JS (pbbly parsing Chess)
+let chess_str =
+*)
+
+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 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))
+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..
+\"
+")
+
+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., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; vy { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; x { d4->100., a2->-50., a1->-50., b1->0., b2->0., e4->150., c2->50., c1->50., f4->200., d2->100., d1->100., f1->200., f2->200., g1->250., g2->250., h1->300., h2->300., e1->150., e2->150., i1->350., i2->350. }; y { d4->-150., a2->-100., a1->-50., b1->-50., b2->-100., e4->0., c2->-100., c1->-50., f4->-150., d2->-100., d1->-50., f1->-100., f2->-50., g1->-100., g2->-50., h1->-100., h2->-50., e1->-100., e2->-50., i1->-100., i2->-50. } ]
+")
+
+let tictactoe_str = ("
+PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 5, depth: 3
+REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
+REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
+REL Row3 (x, y, z) = R(x, y) and R(y, z)
+REL Col3 (x, y, z) = C(x, y) and C(y, z)
+REL DiagA3 (x, y, z) = DiagA(x, y) and DiagA(y, z)
+REL DiagB3 (x, y, z) = DiagB(x, y) and DiagB(y, z)
+REL Conn3 (x, y, z) =
+ Row3(x, y, z) or Col3(x, y, z) or DiagA3(x, y, z) or DiagB3(x, y, z)
+REL WinQ() = ex x, y, z (Q(x) and Q(y) and Q(z) and Conn3(x, y, z))
+REL WinP() = ex x, y, z (P(x) and P(y) and P(z) and Conn3(x, y, z))
+RULE Cross:
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P pre not WinQ()
+RULE Circle:
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] 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 {} | ] \"
+
+ . . .
+
+ . . .
+
+ . . .
+\"
+")
+
+let games = ref
+ [
+ "Breakthrough", compile_game_data breakthrough_str;
+ "Checkers", compile_game_data checkers_str;
+ (* "Chess", compile_game_data chess_str; *)
+ "Connect4", compile_game_data connect4_str;
+ "Entanglement", compile_game_data entanglement_str;
+ "Gomoku", compile_game_data gomoku_str;
+ "Pawn-Whopping", compile_game_data pawn_whopping_str;
+ "Tic-Tac-Toe", compile_game_data tictactoe_str;
+ ]
Added: trunk/Toss/Server/JsHandler.ml
===================================================================
--- trunk/Toss/Server/JsHandler.ml (rev 0)
+++ trunk/Toss/Server/JsHandler.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,184 @@
+(* JavaScript Handler for a subset of ReqHandler.handle_http_post requests. *)
+
+
+(* ---------- Basic request type and internal handler ---------- *)
+
+open GameSelection
+
+(* History of states in last-in-first-out order. *)
+let play_states = ref []
+(* Arbitrarily initialized -- [cur_game] only has effect with
+ non-empty [play_states]. The game state in any [game_data] is only
+ the initial state, not the current state of a game. *)
+let cur_game = ref (snd (List.hd !GameSelection.games))
+let cur_move = ref 0
+let cur_all_moves = ref [| |]
+
+(* TODO; FIXME; remove the function below. *)
+let select_moving a = (* temporary func - accept just one player w/ moves *)
+ let locs = Aux.array_find_all (fun l -> l.Arena.moves <> []) a in
+ if List.length locs <> 1 then failwith "too many moves" else
+ if locs = [] then a.(0) else List.hd locs
+
+
+(* ------------ The Handler ------------ *)
+let js = Js.string
+let of_js = Js.to_string
+let js_object = Js.Unsafe.variable "Object"
+let js_any = Js.Unsafe.inject
+
+let js_handler = Js.Unsafe.variable "LOCAL"
+let set_handle name f =
+ Js.Unsafe.set js_handler (js name) (Js.wrap_callback f)
+
+
+let js_of_move game state move_id (player, move, _) =
+ let struc = state.Arena.struc in
+ let matched = Js.array
+ (Aux.array_map_of_list (fun (_, e) ->
+ js (Structure.elem_name struc e)) move.Arena.matching) in
+ let js_move = jsnew js_object () in
+ let player_name = Aux.rev_assoc game.Arena.player_names player in
+ Js.Unsafe.set js_move (js"matched") matched;
+ Js.Unsafe.set js_move (js"rule") (js (move.Arena.rule));
+ Js.Unsafe.set js_move (js"player") (js player_name);
+ Js.Unsafe.set js_move (js"id") (Js.float (float_of_int move_id));
+ js_move
+
+(* Translate current structure into an "info_obj" format. *)
+let js_of_game_state game state =
+ let struc = state.Arena.struc in
+ let get_pos e =
+ Structure.fun_val struc "x" e, Structure.fun_val struc "y" e in
+ let elems = Structure.elements struc in
+ let (posx, posy) = List.split (List.map get_pos elems) in
+ let mkfl f l = List.fold_left f (List.hd l) (List.tl l) in
+ let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
+ let minx, maxx, miny, maxy = minl posx, maxl posx, minl posy, maxl posy in
+ (* elems are arrays of element name and position *)
+ let elems = Array.of_list
+ (List.map
+ (fun e ->
+ let e0 = js (Structure.elem_name struc e) in
+ let x, y = get_pos e in
+ Js.array [|js_any e0; js_any (Js.float x); js_any (Js.float y)|])
+ elems) in
+ (* rels are arrays of element names, with additional "name" field *)
+ let num = Js.number_of_float in
+ let rels = Array.of_list
+ (Aux.concat_map
+ (fun (rel, _) ->
+ let tups = Structure.Tuples.elements
+ (Structure.rel_graph rel struc) in
+ let tups = List.map
+ (fun args -> Js.array
+ (Array.map (fun e -> js (Structure.elem_name struc e)) args))
+ tups in
+ List.iter
+ (fun args -> Js.Unsafe.set args (js"name") (js rel)) tups;
+ tups)
+ (Structure.rel_signature struc)) in
+ let info_obj = jsnew js_object () in
+ Js.Unsafe.set info_obj (js"maxx") (num maxx);
+ Js.Unsafe.set info_obj (js"minx") (num minx);
+ Js.Unsafe.set info_obj (js"maxy") (num maxy);
+ Js.Unsafe.set info_obj (js"miny") (num miny);
+ Js.Unsafe.set info_obj (js"elems") (Js.array elems);
+ Js.Unsafe.set info_obj (js"rels") (Js.array rels);
+ if !cur_all_moves <> [||] then
+ Js.Unsafe.set info_obj (js"moves")
+ (Js.array (Array.mapi (js_of_move game state) !cur_all_moves))
+ else ( (* find payoffs *)
+ let payoffs = Array.mapi
+ (fun i v -> i, Solver.M.get_real_val v.Arena.payoff struc)
+ game.Arena.graph.(state.Arena.cur_loc) in
+ let result = jsnew js_object () in
+ Array.iter
+ (fun (i, payoff) ->
+ (* Players use their names on the JS side, not numbers! *)
+ let player_name = Aux.rev_assoc game.Arena.player_names i in
+ Js.Unsafe.set result (js player_name) (Js.float payoff))
+ payoffs;
+ Js.Unsafe.set info_obj (js"result") result);
+ 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, state = game_data.game_state in
+ cur_game := game_data;
+ play_states := [state];
+ cur_all_moves := Move.list_moves game state;
+ cur_move := 0;
+ js_of_game_state game state
+
+let _ = set_handle "new_play" new_play
+
+let preview_move move_nbr =
+ let n = List.length !play_states - (move_nbr + 1) in
+ if n < 0 then Js.null
+ else
+ let game, _ = !cur_game.game_state in
+ let state = List.nth !play_states n in
+ Js.some (js_of_game_state game state)
+
+let _ = set_handle "prev_move" preview_move
+
+let make_move move_id cont =
+ 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 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)|]
+
+let _ = set_handle "make_move" make_move
+
+let suggest player_name time cont =
+ (* We do not use the player name. *)
+ Random.self_init ();
+ let time = Js.to_float time in
+ Play.set_timeout time;
+ let comp_started = Aux.gettimeofday () in
+ let game, _ = !cur_game.game_state in
+ let state = List.hd !play_states in
+ try
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose 100000
+ game state !cur_game.heuristic) in
+ Play.cancel_timeout ();
+ let algo_iters = !Play.latest_gametree_size in
+ let move_id = Aux.array_argfind
+ (fun (_, m, _) -> m = move) !cur_all_moves in
+ let result =
+ js_of_move game state move_id (!cur_all_moves.(move_id)) in
+ Js.Unsafe.set result (js"comp_tree_size")
+ (Js.number_of_float (float_of_int algo_iters));
+ 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.Unsafe.fun_call cont [|js_any result|]
+ with Not_found -> Js.null
+
+let _ = set_handle "suggest" suggest
+
+let get_game game_name =
+ let game_data = List.assoc (of_js game_name) !GameSelection.games in
+ js game_data.game_str
+
+let _ = set_handle "get_game" get_game
+
+let set_game game_name game_str =
+ let game_name = of_js game_name and game_str = of_js game_str in
+ try
+ games := (game_name, compile_game_data game_str) :: !games;
+ js ("Game "^game_name^" set.")
+ with Lexer.Parsing_error s ->
+ js ("Game "^game_name^" ERROR: "^s)
+
+let _ = set_handle "set_game" set_game
Added: trunk/Toss/Solver/RealQuantElim/N.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/N.ml (rev 0)
+++ trunk/Toss/Solver/RealQuantElim/N.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,37 @@
+(* A proxy to the [Num] module from the [nums] library. *)
+
+module LocalNum = (struct
+ type num = int * int
+ let sign_num n = failwith "Local Num not implemented yet"
+ let mod_num m n = failwith "Local Num not implemented yet"
+ let div_num m n = failwith "Local Num not implemented yet"
+ let ( // ) = div_num
+ let num_of_int n = failwith "Local Num not implemented yet"
+ let ( +/ ) m n = failwith "Local Num not implemented yet"
+ let ( -/ ) m n = failwith "Local Num not implemented yet"
+ let ( */ ) m n = failwith "Local Num not implemented yet"
+ let float_of_num n = failwith "Local Num not implemented yet"
+ let num_of_string s = failwith "Local Num not implemented yet"
+ let string_of_num n = failwith "Local Num not implemented yet"
+ let abs_num n = failwith "Local Num not implemented yet"
+end : sig
+ type num
+ val sign_num : num -> int
+ val mod_num : num -> num -> num
+ val div_num : num -> num -> num
+ val ( // ) : num -> num -> num
+ val num_of_int : int -> num
+ val ( +/ ) : num -> num -> num
+ val ( -/ ) : num -> num -> num
+ val ( */ ) : num -> num -> num
+ val float_of_num : num -> float
+ val num_of_string : string -> num
+ val string_of_num : num -> string
+ val abs_num : num -> num
+end)
+
+IFDEF JAVASCRIPT THEN
+module Q = LocalNum
+ ELSE
+module Q = Num
+ ENDIF
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -1,6 +1,6 @@
(* Polynomials with ordered variables, integer coefficients.*)
-open Num
+open N.Q
(* ----------------------- BASIC TYPE DEFINITIONS --------------------------- *)
@@ -219,7 +219,7 @@
match (p, q) with
(Const n, Const m) ->
if allow_frac then Const (n // m) else
- if Num.sign_num (Num.mod_num n m) = 0 then Const (n // m) else
+ if N.Q.sign_num (N.Q.mod_num n m) = 0 then Const (n // m) else
raise Not_found
| (Poly (v, _), Poly (w, _)) ->
if v <> w then raise Unmatched_variables else
@@ -232,8 +232,8 @@
| Const n -> (
match u with
Const m ->
- if allow_frac then (Const (n // m), Const (Num.num_of_int 0)) else
- let r = Num.mod_num n m in (Const ((n -/ r) // m), Const r)
+ if allow_frac then (Const (n // m), Const (N.Q.num_of_int 0)) else
+ let r = N.Q.mod_num n m in (Const ((n -/ r) // m), Const r)
| Poly (_, _) -> raise Unmatched_variables
)
| Poly (v, (p, d) :: ps) ->
Modified: trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli
===================================================================
--- trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/OrderedPoly.mli 2012-02-01 10:17:21 UTC (rev 1657)
@@ -3,7 +3,7 @@
(** {2 Basic Type Definitions} *)
-type polynomial = Const of Num.num | Poly of string * (polynomial * int) list
+type polynomial = Const of N.Q.num | Poly of string * (polynomial * int) list
type t = polynomial (** to be compatible with OrderedType signature *)
@@ -29,14 +29,15 @@
val var : polynomial -> string
val lower : polynomial -> polynomial
-val constant_value : polynomial -> Num.num option
+val constant_value : polynomial -> N.Q.num option
val deg : polynomial -> int
val leading_coeff : int -> polynomial -> polynomial
val const_coeff : polynomial -> polynomial option
val omit_leading : polynomial -> polynomial
val multiple : int -> polynomial -> polynomial
-val multiple_num : Num.num -> polynomial -> polynomial
-val constant_factors : polynomial -> polynomial -> (Num.num * Num.num) option
+val multiple_num : N.Q.num -> polynomial -> polynomial
+val constant_factors :
+ polynomial -> polynomial -> (N.Q.num * N.Q.num) option
(** {2 Arithmetic Functions} *)
Modified: trunk/Toss/Solver/RealQuantElim/Poly.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/Poly.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -49,7 +49,7 @@
(* ----------------- CONVERTION TO UNORDERED POLYNOMIALS -------------------- *)
let rec make_unordered = function
- OrderedPoly.Const n -> Const (Num.float_of_num n)
+ OrderedPoly.Const n -> Const (N.Q.float_of_num n)
| OrderedPoly.Poly (v, lst) -> make_unordered_list v lst
and make_unordered_list v = function
@@ -74,11 +74,11 @@
let scale = 1000000 in
let f_scaled = Printf.sprintf "%.0f" (f *. (float_of_int scale)) in
if f_scaled = "nan" || f_scaled = "inf" || f_scaled = "-inf"
- then Num.num_of_int (-1) (* unlikely number *)
+ then N.Q.num_of_int (-1) (* unlikely number *)
else
- let num_scale = Num.num_of_int scale in
- let num_f_scaled = Num.num_of_string f_scaled in
- Num.div_num num_f_scaled num_scale
+ let num_scale = N.Q.num_of_int scale in
+ let num_f_scaled = N.Q.num_of_string f_scaled in
+ N.Q.div_num num_f_scaled num_scale
(* List variables in the given polynomial. *)
let rec vars = function
Modified: trunk/Toss/Solver/RealQuantElim/SignTable.ml
===================================================================
--- trunk/Toss/Solver/RealQuantElim/SignTable.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/RealQuantElim/SignTable.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -72,7 +72,7 @@
let int_case_str case =
let psgn_str (p, i) =
match constant_value p with
- Some n -> if Num.sign_num n <> sign i then "wrong" else "ok"
+ Some n -> if N.Q.sign_num n <> sign i then "wrong" else "ok"
| None ->
if i > 0 then (str p) ^ " > 0" else
if i = 0 then (str p) ^ " = 0" else (str p) ^ " < 0"
@@ -104,7 +104,7 @@
| (r, _) :: rs ->
let mulr = match q with None -> r | Some qp -> mul qp r in
match constant_factors p mulr with
- Some (c1, c2) -> ((-2, i), (Num.sign_num c1) * (Num.sign_num c2))
+ Some (c1, c2) -> ((-2, i), (N.Q.sign_num c1) * (N.Q.sign_num c2))
| None -> find_const_factor ~i:(i+1) ~q:q p rs
(* Helper function: find if p = q1 * q2 * c for some q1, q2 in [acc]. *)
@@ -120,7 +120,8 @@
[] -> acc
| p :: ps ->
match constant_value p with
- Some n -> determine_vals (acc @ [(p, ((-2, -2), Num.sign_num n))]) ps
+ Some n ->
+ determine_vals (acc @ [(p, ((-2, -2), N.Q.sign_num n))]) ps
| None ->
match find_const_factor p acc with
((-1, _), _) ->
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2012-01-30 19:21:45 UTC (rev 1656)
+++ trunk/Toss/Solver/Structure.ml 2012-02-01 10:17:21 UTC (rev 1657)
@@ -1253,19 +1253,19 @@
find_unique (StringMap.fold (fun rel _ acc -> rel::acc)
!struc.rel_signature []) in
let uniq = uniq1 @ uniq2 @ uniq3 in
- let lines = Str.split (Str.regexp "[\r\n]+\t*") board in
+ let lines = Aux.split_regexp ~regexp:"[\r\n]+\t*" board in
let lines = List.filter (fun s->String.length s > 2) lines in
- let rec split_line line =
- let is_ok c = c = ' ' || c = '.' || Aux.is_alphanum c || c = '_' ||
+ let rec split_line line =
+ let is_ok c = c = ' ' || c = '.' || Aux.is_alphanum c || c = '_' ||
c = '*' || c = '?' || c = '#' || c = '+' || c = '-' in
let error txt = raise (Board_parse_error
- ("Unrecognized field line: \"" ^ txt ^
- "\" of board line: \"" ^ line ^"\"")) in
+ ("Unrecognized field line: \"" ^ txt ^
+ "\" of board line: \"" ^ line ^"\"")) in
if line = "" then [] else if String.length line < 3 then error line else
- if (is_ok line.[0] && is_ok line.[1] && is_ok line.[2]) then
- let rest = String.sub line 3 ((String.length line) - 3) in
- (String.sub line 0 3) :: (split_line rest)
- else error (String.sub line 0 3) in
+ if (is_ok line.[0] && is_ok line.[1] && is_ok line.[2]) then
+ let rest = String.sub line 3 ((String.length line) - 3) in
+ (String.sub line 0 3) :: (split_line rest)
+ else error (String.sub line 0 3) in
let rec rev_combine_pairs acc = function
| [] -> acc
| [hd] ->
@@ -1296,12 +1296,12 @@
else if s.[0] = '*' then ["*"] (* treated specially *)
else if sl = 0 && s.[sl] = '?' then ["_any_"]
else if s.[0] = '+' then
- let p = unabbrev (omit 1 s) in ["_new_" ^ p; p]
+ let p = unabbrev (omit 1 s) in ["_new_"^p; p]
else if s.[0] = '-' then ["_del_"^unabbrev (omit 1 s)]
else if s.[sl] = '?' then [unabbrev (String.sub s 0 sl); "_any_"]
else if s.[0] = '?' then ["_opt_"^unabbrev (omit 1 s)]
else if s.[sl] = '#' then
- ["_diffthan_" ^ unabbrev (String.sub s 0 sl); "_any_"]
+ ["_diffthan_"^unabbrev (String.sub s 0 sl); "_any_"]
else if s.[0] = '#' then ["_diffthan_"^unabbrev (omit 1 s)]
else [unabbrev s] in
let board_els =
@@ -1346,8 +1346,8 @@
done;
if List.hd !fields <> [] then
raise (Board_parse_error
- (Printf.sprintf
- "Row %d is too long, expected %d columns" r c_max));
+ (Printf.sprintf
+ "Row %d is too long, expected %d columns" r c_max));
fields := List.tl !fields;
done;
!struc
Added: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js (rev 0)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-01 10:17:21 UTC (rev 1657)
@@ -0,0 +1,895 @@
+// 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) {
+ caml_raise_with_arg (tag, new MlWrappedString (msg));
+}
+function caml_invalid_argument (msg) {
+ caml_raise_with_string(caml_global_data[4], msg);
+}
+function caml_array_bound_error () {
+ caml_invalid_argument("index out of bounds");
+}
+function caml_str_repeat(n, s) {
+ if (!n) { return ""; }
+ if (n & 1) { return caml_str_repeat(n - 1, s) + s; }
+ var r = caml_str_repeat(n >> 1, s);
+ return r + r;
+}
+function MlString(param) {
+ if (param != null) {
+ this.bytes = this.fullBytes = param;
+ this.last = this.len = param.length;
+ }
+}
+MlString.prototype = {
+ string:null,
+ bytes:null,
+ fullBytes:null,
+ array:null,
+ len:null,
+ last:0,
+ toJsString:function() {
+ return this.string = decodeURIComponent (escape(this.getFullBytes()));
+ },
+ toBytes:function() {
+ if (this.string != null)
+ var b = unescape (encodeURIComponent (this.string));
+ else {
+ var b = "", a = this.array, l = a.length;
+ for (var i = 0; i < l; i ++) b += String.fromCharCode (a[i]);
+ }
+ this.bytes = this.fullBytes = b;
+ this.last = this.len = b.length;
+ return b;
+ },
+ getBytes:function() {
+ var b = this.bytes;
+ if (b == null) b = this.toBytes();
+ return b;
+ },
+ getFullBytes:function() {
+ var b = this.fullBytes;
+ if (b !== null) return b;
+ b = this.bytes;
+ if (b == null) b = this.toBytes ();
+ if (this.last < this.len) {
+ this.bytes = (b += caml_str_repeat(this.len - this.last, '\0'));
+ this.last = this.len;
+ }
+ this.fullBytes = b;
+ return b;
+ },
+ toArray:function() {
+ var b = this.bytes;
+ if (b == null) b = this.toBytes ();
+ var a = [], l = this.last;
+ for (var i = 0; i < l; i++) a[i] = b.charCodeAt(i);
+ for (l = this.len; i < l; i++) a[i] = 0;
+ this.string = this.bytes = this.fullBytes = null;
+ this.last = this.len;
+ this.array = a;
+ return a;
+ },
+ getArray:function() {
+ var a = this.array;
+ if (!a) a = this.toArray();
+ return a;
+ },
+ getLen:function() {
+ var len = this.len;
+ if (len !== null) return len;
+ this.toBytes();
+ return this.len;
+ },
+ toString:function() { var s = this.string; return s?s:this.toJsString(); },
+ valueOf:function() { var s = this.string; return s?s:this.toJsString(); },
+ blitToArray:function(i1, a2, i2, l) {
+ var a1 = this.array;
+ if (a1)
+ for (var i = 0; i < l; i++) a2 [i2 + i] = a1 [i1 + i];
+ else {
+ var b = this.bytes;
+ if (b == null) b = this.toBytes();
+ var l1 = this.last - i1;
+ if (l <= l1)
+ for (var i = 0; i < l; i++) a2 [i2 + i] = b.charCodeAt(i1 + i);
+ else {
+ for (var i = 0; i < l1; i++) a2 [i2 + i] = b.charCodeAt(i1 + i);
+ for (; i < l; i++) a2 [i2 + i] = 0;
+ }
+ }
+ },
+ get:function (i) {
+ var a = this.array;
+ if (a) return a[i];
+ var b = this.bytes;
+ if (b == null) b = this.toBytes();
+ return (i<this.last)?b.charCodeAt(i):0;
+ },
+ safeGet:function (i) {
+ if (!this.len) this.toBytes();
+ if ((i < 0) || (i >= this.len)) caml_array_bound_error ();
+ return this.get(i);
+ },
+ set:function (i, c) {
+ var a = this.array;
+ if (!a) {
+ if (this.last == i) {
+ this.bytes += String.fromCharCode (c & 0xff);
+ this.last ++;
+ return 0;
+ }
+ a = this.toArray();
+ } else if (this.bytes != null) {
+ this.bytes = this.fullBytes = this.string = null;
+ }
+ a[i] = c & 0xff;
+ return 0;
+ },
+ safeSet:function (i, c) {
+ if (this.len == null) this.toBytes ();
+ if ((i < 0) || (i >= this.len)) caml_array_bound_error ();
+ this.set(i, c);
+ },
+ fill:function (ofs, len, c) {
+ if (ofs >= this.last && this.last && c == 0) return;
+ var a = this.array;
+ if (!a) a = this.toArray();
+ else if (this.bytes != null) {
+ this.bytes = this.fullBytes = this.string = null;
+ }
+ var l = ofs + len;
+ for (var i = ofs; i < l; i++) a[i] = c;
+ },
+ compare:function (s2) {
+ if (this.string != null && s2.string != null) {
+ if (this.string < s2.string) return -1;
+ if (this.string > s2.string) return 1;
+ return 0;
+ }
+ var b1 = this.getFullBytes ();
+ var b2 = s2.getFullBytes ();
+ if (b1 < b2) return -1;
+ if (b1 > b2) return 1;
+ return 0;
+ },
+ equal:function (s2) {
+ if (this.string != null && s2.string != null)
+ return this.string == s2.string;
+ return this.getFullBytes () == s2.getFullBytes ();
+ },
+ lessThan:function (s2) {
+ if (this.string != null && s2.string != null)
+ return this.string < s2.string;
+ return this.getFullBytes () < s2.getFullBytes ();
+ },
+ lessEqual:function (s2) {
+ if (this.string != null && s2.string != null)
+ return this.string <= s2.string;
+ return this.getFullBytes () <= s2.getFullBytes ();
+ }
+}
+function MlWrappedString (s) { this.string = s; }
+MlWrappedString.prototype = new MlString();
+function MlMakeString (l) { this.bytes = ""; this.len = l; }
+MlMakeString.prototype = new MlString ();
+function caml_array_get (array, index) {
+ if ((index < 0) || (index >= array.length - 1)) caml_array_bound_error();
+ return array[index+1];
+}
+function caml_array_set (array, index, newval) {
+ if ((index < 0) || (index >= array.length - 1)) caml_array_bound_error();
+ array[index+1]=newval; return 0;
+}
+function caml_blit_string(s1, i1, s2, i2, len) {
+ if (len === 0) return;
+ if (i2 === s2.last && i1 === 0 && s1.last == len) {
+ var s = s1.bytes;
+ if (s !== null)
+ s2.bytes += s1.bytes;
+ else
+ s2.bytes += s1.getBytes();
+ s2.last += len;
+ return;
+ }
+ var a = s2.array;
+ if (!a) a = s2.toArray(); else { s2.bytes = s2.string = null; }
+ s1.blitToArray (i1, a, i2, len);
+}
+function caml_call_gen(f, args) {
+ if(f.fun)
+ return caml_call_gen(f.fun, args);
+ var n = f.length;
+ var d = n - args.length;
+ if (d == 0)
+ return f.apply(null, args);
+ else if (d < 0)
+ return caml_call_gen(f.apply(null, args.slice(0,n)), args.slice(n));
+ else
+ return function (x){ return caml_call_gen(f, args.concat([x])); };
+}
+function caml_classify_float (x) {
+ if (isFinite (x)) {
+ if (Math.abs(x) >= 2.2250738585072014e-308) return 0;
+ if (x != 0) return 1;
+ return 2;
+ }
+ return isNaN(x)?4:3;
+}
+function caml_int64_compare(x,y) {
+ var x3 = x[3] << 16;
+ var y3 = y[3] << 16;
+ if (x3 > y3) return 1;
+ if (x3 < y3) return -1;
+ if (x[2] > y[2]) return 1;
+ if (x[2] < y[2]) return -1;
+ if (x[1] > y[1]) return 1;
+ if (x[1] < y[1]) return -1;
+ return 0;
+}
+function caml_int_compare (a, b) {
+ if (a < b) return (-1); if (a == b) return 0; return 1;
+}
+function caml_compare_val (a, b, total) {
+ var stack = [];
+ for(;;) {
+ if (!(total && a === b)) {
+ if (a instanceof MlString) {
+ if (b instanceof MlString) {
+ if (a != b) {
+ var x = a.compare(b);
+ if (x != 0) return x;
+ }
+ } else
+ return 1;
+ } else if (a instanceof Array && a[0] == (a[0]|0)) {
+ var ta = a[0];
+ if (ta === 250) {
+ a = a[1];
+ continue;
+ } else if (b instanceof Array && b[0] == (b[0]|0)) {
+ var tb = b[0];
+ if (tb === 250) {
+ b = b[1];
+ continue;
+ } else if (ta != tb) {
+ return (ta < tb)?-1:1;
+ } else {
+ switch (ta) {
+ case 248: {
+ var x = caml_int_compare(a[2], b[2]);
+ if (x != 0) return x;
+ break;
+ }
+ case 255: {
+ var x = caml_int64_compare(a, b);
+ if (x != 0) return x;
+ break;
+ }
+ default:
+ if (a.length != b.length) return (a.length < b.length)?-1:1;
+ if (a.length > 1) stack.push(a, b, 1);
+ }
+ }
+ } else
+ return 1;
+ } else if (b instanceof MlString ||
+ (b instanceof Array && b[0] == (b[0]|0))) {
+ return -1;
+ } else {
+ if (a < b) return -1;
+ if (a > b) retur...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-01 18:27:11
|
Revision: 1659
http://toss.svn.sourceforge.net/toss/?rev=1659&view=rev
Author: lukaszkaiser
Date: 2012-02-01 18:27:03 +0000 (Wed, 01 Feb 2012)
Log Message:
-----------
MenhirLib sources to test --table with js_of_ocaml.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/menhir_conf
Added Paths:
-----------
trunk/Toss/MenhirLib/
trunk/Toss/MenhirLib/engine.ml
trunk/Toss/MenhirLib/engine.mli
trunk/Toss/MenhirLib/engineTypes.ml
trunk/Toss/MenhirLib/infiniteArray.ml
trunk/Toss/MenhirLib/infiniteArray.mli
trunk/Toss/MenhirLib/packedIntArray.ml
trunk/Toss/MenhirLib/packedIntArray.mli
trunk/Toss/MenhirLib/rowDisplacement.ml
trunk/Toss/MenhirLib/rowDisplacement.mli
trunk/Toss/MenhirLib/tableFormat.ml
trunk/Toss/MenhirLib/tableInterpreter.ml
trunk/Toss/MenhirLib/tableInterpreter.mli
Removed Paths:
-------------
trunk/Toss/js_of_ocaml_test.html
trunk/Toss/js_of_ocaml_test.ml
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2012-02-01 14:15:01 UTC (rev 1658)
+++ trunk/Toss/Makefile 2012-02-01 18:27:03 UTC (rev 1659)
@@ -53,15 +53,15 @@
OCAMLBUILDNOPP=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
-FormulaINCSatINC=Formula
-FormulaINC=Formula,Formula/Sat,Formula/Sat/dpll
-SolverINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim
-ArenaINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver
-PlayINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
-LearnINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena
-GGPINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play
-ServerINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn
-.INC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Learn,Server
+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
+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
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
Added: trunk/Toss/MenhirLib/engine.ml
===================================================================
--- trunk/Toss/MenhirLib/engine.ml (rev 0)
+++ trunk/Toss/MenhirLib/engine.ml 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,367 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+open EngineTypes
+
+(* The LR parsing engine. *)
+
+(* This module is used:
+
+ - at compile time, if so requested by the user, via the --interpret options;
+ - at run time, in the table-based back-end. *)
+
+module Make (T : TABLE) = struct
+
+ (* This propagates type and exception definitions. *)
+
+ include T
+
+ let _eRR : exn =
+ Error
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* [discard] takes a token off the input stream, queries the lexer
+ for a new one, and stores it into [env.token], overwriting the
+ previous token. If [env.shifted] has not yet reached its limit,
+ it is incremented. *)
+
+ let discard env =
+ let lexbuf = env.lexbuf in
+ let token = env.lexer lexbuf in
+ env.token <- token;
+ Log.lookahead_token lexbuf (T.token2terminal token);
+ let shifted = env.shifted + 1 in
+ if shifted >= 0 then
+ env.shifted <- shifted
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* The type [void] is empty. Many of the functions below have return type
+ [void]. This guarantees that they never return a value. Instead, they
+ must stop by raising an exception: either [Accept] or [Error]. *)
+
+ type void
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* In the code-based back-end, the [run] function is sometimes responsible
+ for pushing a new cell on the stack. This is motivated by code sharing
+ concerns. In this interpreter, there is no such concern; [run]'s caller
+ is always responsible for updating the stack. *)
+
+ (* In the code-based back-end, there is a [run] function for each state
+ [s]. This function can behave in two slightly different ways, depending
+ on when it is invoked, or (equivalently) depending on [s].
+
+ If [run] is invoked after shifting a terminal symbol (or, equivalently,
+ if [s] has a terminal incoming symbol), then [run] discards a token,
+ unless [s] has a default reduction on [#]. (Indeed, in that case,
+ requesting the next token might drive the lexer off the end of the input
+ stream.)
+
+ If, on the other hand, [run] is invoked after performing a goto transition,
+ or invoked directly by an entry point, then there is nothing to discard.
+
+ These two cases are reflected in [CodeBackend.gettoken].
+
+ Here, the code is structured in a slightly different way. It is up to
+ the caller of [run] to indicate whether to discard a token. *)
+
+ let rec run env please_discard : void =
+
+ (* Log the fact that we just entered this state. *)
+
+ let s = env.current in
+ Log.state s;
+
+ (* If [please_discard] is set, discard a token and fetch the next one. *)
+
+ (* This flag is set when [s] is being entered by shifting a terminal
+ symbol and [s] does not have a default reduction on [#]. *)
+
+ if please_discard then
+ discard env;
+
+ (* Examine what situation we are in. This case analysis is analogous to
+ that performed in [CodeBackend.gettoken], in the sub-case where we do
+ not have a terminal incoming symbol. *)
+
+ T.default_reduction
+ s
+ reduce (* there is a default reduction; perform it *)
+ continue (* there is none; continue below *)
+ env
+
+ and continue env : void =
+
+ (* There is no default reduction. Consult the current lookahead token
+ so as to determine which action should be taken. *)
+
+ (* Peeking at the first input token, without taking it off the input
+ stream, is normally done by reading [env.token]. However, we check
+ [env.shifted] first: if it is -1, then the lookahead token is the
+ [error] token. *)
+
+ (* Note that, if we just called [discard] above, then the lookahead
+ token cannot be [error]. *)
+
+ if env.shifted = (-1) then begin
+ Log.resuming_error_handling();
+ error env
+ end
+ else
+ action env
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* When [action] is invoked, we know that the current state does not have
+ a default reduction. We also know that the current lookahead token is
+ not [error]: it is a real token, stored in [env.token]. *)
+
+ and action env : void =
+
+ (* We consult the two-dimensional action table, indexed by the
+ current state and the current lookahead token, in order to
+ determine which action should be taken. *)
+
+ let token = env.token in
+ T.action
+ env.current (* determines a row *)
+ (T.token2terminal token) (* determines a column *)
+ (T.token2value token)
+ shift (* shift continuation *)
+ reduce (* reduce continuation *)
+ initiate (* failure continuation *)
+ env
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* This function takes care of shift transitions along a terminal symbol.
+ (Goto transitions are taken care of within [reduce] below.) The symbol
+ can be either an actual token or the [error] pseudo-token. *)
+
+ and shift env
+ (please_discard : bool)
+ (terminal : terminal)
+ (value : semantic_value)
+ (s' : state)
+ : void =
+
+ (* Log the transition. *)
+
+ Log.shift terminal s';
+
+ (* Push a new cell onto the stack, containing the identity of the
+ state that we are leaving. *)
+
+ let lexbuf = env.lexbuf in
+ env.stack <- {
+ state = env.current;
+ semv = value;
+ startp = lexbuf.Lexing.lex_start_p;
+ endp = lexbuf.Lexing.lex_curr_p;
+ next = env.stack;
+ };
+
+ (* Switch to state [s']. *)
+
+ env.current <- s';
+ run env please_discard
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* This function takes care of reductions. *)
+
+ and reduce env (prod : production) : void =
+
+ (* Log a reduction event. *)
+
+ Log.reduce_or_accept prod;
+
+ (* Invoke the semantic action. The semantic action is responsible for
+ truncating the stack, updating the current state, producing a cell that
+ contains a new semantic value, and raising [Accept] or [Error] if
+ appropriate. *)
+
+ (* If the semantic action raises [Error], we catch it immediately and
+ initiate error handling. *)
+
+ (* The apparently weird idiom used here is an encoding for a
+ [let/unless] construct, which does not exist in ocaml. *)
+
+ if (
+ try
+ T.semantic_action prod env;
+ true
+ with Error ->
+ false
+ ) then begin
+
+ (* By our convention, the semantic action is responsible for updating
+ the stack. The state now found in the top stack cell is the return
+ state. *)
+
+ (* Perform a goto transition. The target state is determined
+ by consulting the goto table at the return state and at
+ production [prod]. *)
+
+ env.current <- T.goto env.stack.state prod;
+ run env false
+
+ end
+ else
+ errorbookkeeping env
+
+
+ (* --------------------------------------------------------------------------- *)
+
+ (* The following functions deal with errors. *)
+
+ (* [initiate] and [errorbookkeeping] initiate error handling. See the functions
+ by the same names in [CodeBackend]. *)
+
+ and initiate env : void =
+ assert (env.shifted >= 0);
+ if T.recovery && env.shifted = 0 then begin
+ Log.discarding_last_token (T.token2terminal env.token);
+ discard env;
+ env.shifted <- 0;
+ action env
+ end
+ else
+ errorbookkeeping env
+
+ and errorbookkeeping env =
+ Log.initiating_error_handling();
+ env.previouserror <- env.shifted;
+ env.shifted <- (-1);
+ error env
+
+ (* [error] handles errors. *)
+
+ and error env : void =
+
+ (* Consult the column associated with the [error] pseudo-token in the
+ action table. *)
+
+ T.action
+ env.current (* determines a row *)
+ T.error_terminal (* determines a column *)
+ T.error_value
+ error_shift (* shift continuation *)
+ error_reduce (* reduce continuation *)
+ error_fail (* failure continuation *)
+ env
+
+ and error_shift env please_discard terminal value s' =
+
+ (* Here, [terminal] is [T.error_terminal], and [value] is [T.error_value]. *)
+
+ assert (terminal = T.error_terminal && value = T.error_value);
+
+ (* This state is capable of shifting the [error] token. *)
+
+ Log.handling_error env.current;
+ shift env please_discard terminal value s'
+
+ and error_reduce env prod =
+
+ (* This state is capable of performing a reduction on [error]. *)
+
+ Log.handling_error env.current;
+ reduce env prod
+
+ and error_fail env =
+
+ (* This state is unable to handle errors. Attempt to pop a stack
+ cell. *)
+
+ let cell = env.stack in
+ let next = cell.next in
+ if next == cell then
+
+ (* The stack is empty. Die. *)
+
+ raise _eRR
+
+ else begin
+
+ (* The stack is nonempty. Pop a cell, updating the current state
+ with that found in the popped cell, and try again. *)
+
+ env.stack <- next;
+ env.current <- cell.state;
+ error env
+
+ end
+
+ (* --------------------------------------------------------------------------- *)
+
+ let entry
+ (s : state)
+ (lexer : Lexing.lexbuf -> token)
+ (lexbuf : Lexing.lexbuf)
+ : semantic_value =
+
+ (* Build an empty stack. This is a dummy cell, which is its own
+ successor. Its fields other than [next] contain dummy values. *)
+
+ let rec empty = {
+ state = s; (* dummy *)
+ semv = T.error_value; (* dummy *)
+ startp = lexbuf.Lexing.lex_start_p; (* dummy *)
+ endp = lexbuf.Lexing.lex_curr_p; (* dummy *)
+ next = empty;
+ } in
+
+ (* Perform an initial call to the lexer. *)
+
+ let token : token =
+ lexer lexbuf
+ in
+
+ (* Log our first lookahead token. *)
+
+ Log.lookahead_token lexbuf (T.token2terminal token);
+
+ (* Build an initial environment. *)
+
+ let env = {
+ lexer = lexer;
+ lexbuf = lexbuf;
+ token = token;
+ shifted = max_int;
+ previouserror = max_int;
+ stack = empty;
+ current = s;
+ } in
+
+ (* Run. Catch [Accept], which represents normal termination. Let [Error]
+ escape. *)
+
+ try
+
+ (* If ocaml offered a [match/with] construct with zero branches, this is
+ what we would use here, since the type [void] has zero cases. *)
+
+ let (_ : void) = run env false in
+ assert false (* cannot fail *)
+
+ with
+ | Accept v ->
+ v
+
+end
+
Added: trunk/Toss/MenhirLib/engine.mli
===================================================================
--- trunk/Toss/MenhirLib/engine.mli (rev 0)
+++ trunk/Toss/MenhirLib/engine.mli 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+open EngineTypes
+
+(* The LR parsing engine. *)
+
+module Make (T : TABLE) : ENGINE with type state = T.state
+ and type token = T.token
+ and type semantic_value = T.semantic_value
Added: trunk/Toss/MenhirLib/engineTypes.ml
===================================================================
--- trunk/Toss/MenhirLib/engineTypes.ml (rev 0)
+++ trunk/Toss/MenhirLib/engineTypes.ml 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,331 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* This file defines several types and module types that are used in the
+ specification of module [Engine]. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* It would be nice if we could keep the structure of stacks and environments
+ hidden. However, stacks and environments must be accessible to semantic
+ actions, so the following data structure definitions must be public. *)
+
+(* --------------------------------------------------------------------------- *)
+
+(* A stack is a linked list of cells. A sentinel cell -- which is its own
+ successor -- is used to mark the bottom of the stack. The sentinel cell
+ itself is not significant -- it contains dummy values. *)
+
+type ('state, 'semantic_value) stack = {
+
+ (* The state that we should go back to if we pop this stack cell. *)
+
+ (* This convention means that the state contained in the top stack cell is
+ not the current state [env.current]. It also means that the state found
+ within the sentinel is a dummy -- it is never consulted. This convention
+ is the same as that adopted by the code-based back-end. *)
+
+ state: 'state;
+
+ (* The semantic value associated with the chunk of input that this cell
+ represents. *)
+
+ semv: 'semantic_value;
+
+ (* The start and end positions of the chunk of input that this cell
+ represents. *)
+
+ startp: Lexing.position;
+ endp: Lexing.position;
+
+ (* The next cell down in the stack. If this is a self-pointer, then this
+ cell is the sentinel, and the stack is conceptually empty. *)
+
+ next: ('state, 'semantic_value) stack;
+
+}
+
+(* --------------------------------------------------------------------------- *)
+
+(* A parsing environment contains basically all of the automaton's state. *)
+
+type ('state, 'semantic_value, 'token) env = {
+
+ (* The lexer. *)
+
+ lexer: Lexing.lexbuf -> 'token;
+
+ (* The lexing buffer. It is used as an argument to the lexer, and also
+ accessed directly when extracting positions. *)
+
+ lexbuf: Lexing.lexbuf;
+
+ (* The last token that was obtained from the lexer. *)
+
+ mutable token: 'token;
+
+ (* A count of how many tokens were shifted since the beginning, or since
+ the last [error] token was encountered. By convention, if [shifted]
+ is (-1), then the current lookahead token is [error]. *)
+
+ mutable shifted: int;
+
+ (* A copy of the value of [shifted] just before the most recent error
+ was detected. This value is not used by the automaton itself, but
+ is made accessible to semantic actions. *)
+
+ mutable previouserror: int;
+
+ (* The stack. In [CodeBackend], it is passed around on its own,
+ whereas, here, it is accessed via the environment. *)
+
+ mutable stack: ('state, 'semantic_value) stack;
+
+ (* The current state. In [CodeBackend], it is passed around on its
+ own, whereas, here, it is accessed via the environment. *)
+
+ mutable current: 'state;
+
+}
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the parameters that must be supplied to the LR
+ engine. *)
+
+module type TABLE = sig
+
+ (* The type of automaton states. *)
+
+ type state
+
+ (* The type of tokens. These can be thought of as real tokens, that is,
+ tokens returned by the lexer. They carry a semantic value. This type
+ does not include the [error] pseudo-token. *)
+
+ type token
+
+ (* The type of terminal symbols. These can be thought of as integer codes.
+ They do not carry a semantic value. This type does include the [error]
+ pseudo-token. *)
+
+ type terminal
+
+ (* The type of semantic values. *)
+
+ type semantic_value
+
+ (* A token is conceptually a pair of a (non-[error]) terminal symbol and
+ a semantic value. The following two functions are the pair projections. *)
+
+ val token2terminal: token -> terminal
+ val token2value: token -> semantic_value
+
+ (* Even though the [error] pseudo-token is not a real token, it is a
+ terminal symbol. Furthermore, for regularity, it must have a semantic
+ value. *)
+
+ val error_terminal: terminal
+ val error_value: semantic_value
+
+ (* The type of productions. *)
+
+ type production
+
+ (* If a state [s] has a default reduction on production [prod], then, upon
+ entering [s], the automaton should reduce [prod] without consulting the
+ lookahead token. The following function allows determining which states
+ have default reductions. *)
+
+ (* Instead of returning a value of a sum type -- either [DefRed prod], or
+ [NoDefRed] -- it accepts two continuations, and invokes just one of
+ them. This mechanism allows avoiding a memory allocation. *)
+
+ val default_reduction:
+ state ->
+ ('env -> production -> 'answer) ->
+ ('env -> 'answer) ->
+ 'env -> 'answer
+
+ (* An LR automaton can normally take three kinds of actions: shift, reduce,
+ or fail. (Acceptance is a particular case of reduction: it consists in
+ reducing a start production.) *)
+
+ (* There are two variants of the shift action. [shift/discard s] instructs
+ the automaton to discard the current token, request a new one from the
+ lexer, and move to state [s]. [shift/nodiscard s] instructs it to move to
+ state [s] without requesting a new token. This instruction should be used
+ when [s] has a default reduction on [#]. See [CodeBackend.gettoken] for
+ details. *)
+
+ (* This is the automaton's action table. It maps a pair of a state and a
+ terminal symbol to an action. *)
+
+ (* Instead of returning a value of a sum type -- one of shift/discard,
+ shift/nodiscard, reduce, or fail -- this function accepts three
+ continuations, and invokes just one them. This mechanism allows avoiding
+ a memory allocation. *)
+
+ (* In summary, the parameters to [action] are as follows:
+
+ - the first two parameters, a state and a terminal symbol, are used to
+ look up the action table;
+
+ - the next parameter is the semantic value associated with the above
+ terminal symbol; it is not used, only passed along to the shift
+ continuation, as explained below;
+
+ - the shift continuation expects an environment; a flag that tells
+ whether to discard the current token; the terminal symbol that
+ is being shifted; its semantic value; and the target state of
+ the transition;
+
+ - the reduce continuation expects an environment and a production;
+
+ - the fail continuation expects an environment;
+
+ - the last parameter is the environment; it is not used, only passed
+ along to the selected continuation. *)
+
+ val action:
+ state ->
+ terminal ->
+ semantic_value ->
+ ('env -> bool -> terminal -> semantic_value -> state -> 'answer) ->
+ ('env -> production -> 'answer) ->
+ ('env -> 'answer) ->
+ 'env -> 'answer
+
+ (* This is the automaton's goto table. It maps a pair of a state and a
+ production to a new state.
+
+ This convention is slightly different from the textbook approach. The
+ goto table is usually indexed by a state and a non-terminal symbol. *)
+
+ val goto: state -> production -> state
+
+ (* By convention, a semantic action is responsible for:
+
+ 1. fetching whatever semantic values and positions it needs off the stack;
+
+ 2. popping an appropriate number of cells off the stack, as dictated
+ by the length of the right-hand side of the production; this involves
+ updating [env.stack];
+
+ 3. computing a new semantic value, as well as new start and end positions;
+
+ 4. pushing a new stack cell, which contains the three values
+ computed in step 3; this again involves updating [env.stack]
+ (only one update is necessary).
+
+ Point 1 is essentially forced upon us: if semantic values were fetched
+ off the stack by this interpreter, then the calling convention for
+ semantic actions would be variadic: not all semantic actions would have
+ the same number of arguments. The rest follows rather naturally. *)
+
+ (* If production [prod] is an accepting production, then the semantic action
+ is responsible for raising exception [Accept], instead of returning
+ normally. This convention allows us to not distinguish between regular
+ productions and accepting productions. All we have to do is catch that
+ exception at top level. *)
+
+ (* Semantic actions are allowed to raise [Error]. *)
+
+ exception Accept of semantic_value
+ exception Error
+
+ type semantic_action =
+ (state, semantic_value, token) env -> unit
+
+ val semantic_action: production -> semantic_action
+
+ (* The LR engine can attempt error recovery. This consists in discarding
+ tokens, just after an error has been successfully handled, until a token
+ that can be successfully handled is found. This mechanism is optional.
+ The following flag enables it. *)
+
+ val recovery: bool
+
+ (* The LR engine requires a number of hooks, which are used for logging. *)
+
+ (* The comments below indicate the conventional messages that correspond
+ to these hooks in the code-based back-end; see [CodeBackend]. *)
+
+ module Log : sig
+
+ (* State %d: *)
+
+ val state: state -> unit
+
+ (* Shifting (<terminal>) to state <state> *)
+
+ val shift: terminal -> state -> unit
+
+ (* Reducing a production should be logged either as a reduction
+ event (for regular productions) or as an acceptance event (for
+ start productions). *)
+
+ (* Reducing production <production> / Accepting *)
+
+ val reduce_or_accept: production -> unit
+
+ (* Lookahead token is now <terminal> (<pos>-<pos>) *)
+
+ val lookahead_token: Lexing.lexbuf -> terminal -> unit
+
+ (* Initiating error handling *)
+
+ val initiating_error_handling: unit -> unit
+
+ (* Resuming error handling *)
+
+ val resuming_error_handling: unit -> unit
+
+ (* Handling error in state <state> *)
+
+ val handling_error: state -> unit
+
+ (* Discarding last token read (<terminal>) *)
+
+ val discarding_last_token: terminal -> unit
+
+ end
+
+end
+
+(* --------------------------------------------------------------------------- *)
+
+(* This signature describes the LR engine. *)
+
+module type ENGINE = sig
+
+ type state
+
+ type token
+
+ type semantic_value
+
+ (* An entry point to the engine requires a start state, a lexer, and a lexing
+ buffer. It either succeeds and produces a semantic value, or fails and
+ raises [Error]. *)
+
+ exception Error
+
+ val entry:
+ state ->
+ (Lexing.lexbuf -> token) ->
+ Lexing.lexbuf ->
+ semantic_value
+
+end
Added: trunk/Toss/MenhirLib/infiniteArray.ml
===================================================================
--- trunk/Toss/MenhirLib/infiniteArray.ml (rev 0)
+++ trunk/Toss/MenhirLib/infiniteArray.ml 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,64 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* $Id: infiniteArray.ml,v 1.6 2007/09/10 21:09:37 fpottier Exp $ *)
+
+(** This module implements infinite arrays, that is, arrays that grow
+ transparently upon demand. *)
+
+type 'a t = {
+ default: 'a;
+ mutable table: 'a array;
+ mutable extent: int; (* the index of the greatest [set] ever, plus one *)
+ }
+
+let default_size =
+ 16384 (* must be non-zero *)
+
+let make x = {
+ default = x;
+ table = Array.make default_size x;
+ extent = 0;
+}
+
+let rec new_length length i =
+ if i < length then
+ length
+ else
+ new_length (2 * length) i
+
+let ensure a i =
+ let table = a.table in
+ let length = Array.length table in
+ if i >= length then begin
+ let table' = Array.make (new_length (2 * length) i) a.default in
+ Array.blit table 0 table' 0 length;
+ a.table <- table'
+ end
+
+let get a i =
+ ensure a i;
+ a.table.(i)
+
+let set a i x =
+ ensure a i;
+ a.table.(i) <- x;
+ a.extent <- max (i + 1) a.extent
+
+let extent a =
+ a.extent
+
+let domain a =
+ Array.sub a.table 0 a.extent
+
Added: trunk/Toss/MenhirLib/infiniteArray.mli
===================================================================
--- trunk/Toss/MenhirLib/infiniteArray.mli (rev 0)
+++ trunk/Toss/MenhirLib/infiniteArray.mli 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* $Id: infiniteArray.mli,v 1.5 2007/09/10 21:09:37 fpottier Exp $ *)
+
+(** This module implements infinite arrays. **)
+type 'a t
+
+(** [make x] creates an infinite array, where every slot contains [x]. **)
+val make: 'a -> 'a t
+
+(** [get a i] returns the element contained at offset [i] in the array [a].
+ Slots are numbered 0 and up. **)
+val get: 'a t -> int -> 'a
+
+(** [set a i x] sets the element contained at offset [i] in the array
+ [a] to [x]. Slots are numbered 0 and up. **)
+val set: 'a t -> int -> 'a -> unit
+
+(** [extent a] is the length of an initial segment of the array [a]
+ that is sufficiently large to contain all [set] operations ever
+ performed. In other words, all elements beyond that segment have
+ the default value. *)
+val extent: 'a t -> int
+
+(** [domain a] is a fresh copy of an initial segment of the array [a]
+ whose length is [extent a]. *)
+val domain: 'a t -> 'a array
Added: trunk/Toss/MenhirLib/packedIntArray.ml
===================================================================
--- trunk/Toss/MenhirLib/packedIntArray.ml (rev 0)
+++ trunk/Toss/MenhirLib/packedIntArray.ml 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,199 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* A packed integer array is represented as a pair of an integer [k] and
+ a string [s]. The integer [k] is the number of bits per integer that we
+ use. The string [s] is just an array of bits, which is read in 8-bit
+ chunks. *)
+
+(* The ocaml programming language treats string literals and array literals
+ in slightly different ways: the former are statically allocated, while
+ the latter are dynamically allocated. (This is rather arbitrary.) In the
+ context of Menhir's table-based back-end, where compact, immutable
+ integer arrays are needed, ocaml strings are preferable to ocaml arrays. *)
+
+type t =
+ int * string
+
+(* The magnitude [k] of an integer [v] is the number of bits required
+ to represent [v]. It is rounded up to the nearest power of two, so
+ that [k] divides [Sys.word_size]. *)
+
+let magnitude (v : int) =
+ if v < 0 then
+ Sys.word_size
+ else
+ let rec check k max = (* [max] equals [2^k] *)
+ if (max <= 0) || (v < max) then
+ k
+ (* if [max] just overflew, then [v] requires a full ocaml
+ integer, and [k] is the number of bits in an ocaml integer
+ plus one, that is, [Sys.word_size]. *)
+ else
+ check (2 * k) (max * max)
+ in
+ check 1 2
+
+(* [pack a] turns an array of integers into a packed integer array. *)
+
+(* Because the sign bit is the most significant bit, the magnitude of
+ any negative number is the word size. In other words, [pack] does
+ not achieve any space savings as soon as [a] contains any negative
+ numbers, even if they are ``small''. *)
+
+let pack (a : int array) : t =
+
+ let m = Array.length a in
+
+ (* Compute the maximum magnitude of the array elements. This tells
+ us how many bits per element we are going to use. *)
+
+ let k =
+ Array.fold_left (fun k v ->
+ max k (magnitude v)
+ ) 1 a
+ in
+
+ (* Because access to ocaml strings is performed on an 8-bit basis,
+ two cases arise. If [k] is less than 8, then we can pack multiple
+ array entries into a single character. If [k] is greater than 8,
+ then we must use multiple characters to represent a single array
+ entry. *)
+
+ if k <= 8 then begin
+
+ (* [w] is the number of array entries that we pack in a character. *)
+
+ assert (8 mod k = 0);
+ let w = 8 / k in
+
+ (* [n] is the length of the string that we allocate. *)
+
+ let n =
+ if m mod w = 0 then
+ m / w
+ else
+ m / w + 1
+ in
+
+ let s =
+ String.create n
+ in
+
+ (* Define a reader for the source array. The reader might run off
+ the end if [w] does not divide [m]. *)
+
+ let i = ref 0 in
+ let next () =
+ let ii = !i in
+ if ii = m then
+ 0 (* ran off the end, pad with zeroes *)
+ else
+ let v = a.(ii) in
+ i := ii + 1;
+ v
+ in
+
+ (* Fill up the string. *)
+
+ for j = 0 to n - 1 do
+ let c = ref 0 in
+ for x = 1 to w do
+ c := (!c lsl k) lor next()
+ done;
+ s.[j] <- Char.chr !c
+ done;
+
+ (* Done. *)
+
+ k, s
+
+ end
+ else begin (* k > 8 *)
+
+ (* [w] is the number of characters that we use to encode an array entry. *)
+
+ assert (k mod 8 = 0);
+ let w = k / 8 in
+
+ (* [n] is the length of the string that we allocate. *)
+
+ let n =
+ m * w
+ in
+
+ let s =
+ String.create n
+ in
+
+ (* Fill up the string. *)
+
+ for i = 0 to m - 1 do
+ let v = ref a.(i) in
+ for x = 1 to w do
+ s.[(i + 1) * w - x] <- Char.chr (!v land 255);
+ v := !v lsr 8
+ done
+ done;
+
+ (* Done. *)
+
+ k, s
+
+ end
+
+(* Access to a string. *)
+
+let read (s : string) (i : int) : int =
+ Char.code (String.unsafe_get s i)
+
+(* [get1 t i] returns the integer stored in the packed array [t] at index [i].
+ It assumes (and does not check) that the array's bit width is [1]. The
+ parameter [t] is just a string. *)
+
+let get1 (s : string) (i : int) : int =
+ let c = read s (i lsr 3) in
+ let c = c lsr ((lnot i) land 0b111) in
+ let c = c land 0b1 in
+ c
+
+(* [get t i] returns the integer stored in the packed array [t] at index [i]. *)
+
+(* Together, [pack] and [get] satisfy the following property: if the index [i]
+ is within bounds, then [get (pack a) i] equals [a.(i)]. *)
+
+let get ((k, s) : t) (i : int) : int =
+ match k with
+ | 1 ->
+ get1 s i
+ | 2 ->
+ let c = read s (i lsr 2) in
+ let c = c lsr (2 * ((lnot i) land 0b11)) in
+ let c = c land 0b11 in
+ c
+ | 4 ->
+ let c = read s (i lsr 1) in
+ let c = c lsr (4 * ((lnot i) land 0b1)) in
+ let c = c land 0b1111 in
+ c
+ | 8 ->
+ read s i
+ | 16 ->
+ let j = 2 * i in
+ (read s j) lsl 8 + read s (j + 1)
+ | _ ->
+ assert (k = 32); (* 64 bits unlikely, not supported *)
+ let j = 4 * i in
+ (((read s j lsl 8) + read s (j + 1)) lsl 8 + read s (j + 2)) lsl 8 + read s (j + 3)
+
Added: trunk/Toss/MenhirLib/packedIntArray.mli
===================================================================
--- trunk/Toss/MenhirLib/packedIntArray.mli (rev 0)
+++ trunk/Toss/MenhirLib/packedIntArray.mli 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* A packed integer array is represented as a pair of an integer [k] and
+ a string [s]. The integer [k] is the number of bits per integer that we
+ use. The string [s] is just an array of bits, which is read in 8-bit
+ chunks. *)
+
+(* The ocaml programming language treats string literals and array literals
+ in slightly different ways: the former are statically allocated, while
+ the latter are dynamically allocated. (This is rather arbitrary.) In the
+ context of Menhir's table-based back-end, where compact, immutable
+ integer arrays are needed, ocaml strings are preferable to ocaml arrays. *)
+
+type t =
+ int * string
+
+(* [pack a] turns an array of integers into a packed integer array. *)
+
+(* Because the sign bit is the most significant bit, the magnitude of
+ any negative number is the word size. In other words, [pack] does
+ not achieve any space savings as soon as [a] contains any negative
+ numbers, even if they are ``small''. *)
+
+val pack: int array -> t
+
+(* [get t i] returns the integer stored in the packed array [t] at index [i]. *)
+
+(* Together, [pack] and [get] satisfy the following property: if the index [i]
+ is within bounds, then [get (pack a) i] equals [a.(i)]. *)
+
+val get: t -> int -> int
+
+(* [get1 t i] returns the integer stored in the packed array [t] at index [i].
+ It assumes (and does not check) that the array's bit width is [1]. The
+ parameter [t] is just a string. *)
+
+val get1: string -> int -> int
+
Added: trunk/Toss/MenhirLib/rowDisplacement.ml
===================================================================
--- trunk/Toss/MenhirLib/rowDisplacement.ml (rev 0)
+++ trunk/Toss/MenhirLib/rowDisplacement.ml 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,272 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* This module compresses a two-dimensional table, where some values
+ are considered insignificant, via row displacement. *)
+
+(* This idea reportedly appears in Aho and Ullman's ``Principles
+ of Compiler Design'' (1977). It is evaluated in Tarjan and Yao's
+ ``Storing a Sparse Table'' (1979) and in Dencker, D\xFCrre, and Heuft's
+ ``Optimization of Parser Tables for Portable Compilers'' (1984). *)
+
+(* A compressed table is represented as a pair of arrays. The
+ displacement array is an array of offsets into the data array. *)
+
+type 'a table =
+ int array * (* displacement *)
+ 'a array (* data *)
+
+(* In a natural version of this algorithm, displacements would be greater
+ than (or equal to) [-n]. However, in the particular setting of Menhir,
+ both arrays are intended to be compressed with [PackedIntArray], which
+ does not efficiently support negative numbers. For this reason, we are
+ careful not to produce negative displacements. *)
+
+(* In order to avoid producing negative displacements, we simply use the
+ least significant bit as the sign bit. This is implemented by [encode]
+ and [decode] below. *)
+
+(* One could also think, say, of adding [n] to every displacement, so as
+ to ensure that all displacements are nonnegative. This would work, but
+ would require [n] to be published, for use by the decoder. *)
+
+let encode (displacement : int) : int =
+ if displacement >= 0 then
+ displacement lsl 1
+ else
+ (-displacement) lsl 1 + 1
+
+let decode (displacement : int) : int =
+ if displacement land 1 = 0 then
+ displacement lsr 1
+ else
+ -(displacement lsr 1)
+
+(* It is reasonable to assume that, as matrices grow large, their
+ density becomes low, i.e., they have many insignificant entries.
+ As a result, it is important to work with a sparse data structure
+ for rows. We internally represent a row as a list of its
+ significant entries, where each entry is a pair of a [j] index and
+ an element. *)
+
+type 'a row =
+ (int * 'a) list
+
+(* [compress equal insignificant dummy m n t] turns the two-dimensional table
+ [t] into a compressed table. The parameter [equal] is equality of data
+ values. The parameter [wildcard] tells which data values are insignificant,
+ and can thus be overwritten with other values. The parameter [dummy] is
+ used to fill holes in the data array. [m] and [n] are the integer
+ dimensions of the table [t]. *)
+
+let compress
+ (equal : 'a -> 'a -> bool)
+ (insignificant : 'a -> bool)
+ (dummy : 'a)
+ (m : int) (n : int)
+ (t : 'a array array)
+ : 'a table =
+
+ (* Be defensive. *)
+
+ assert (Array.length t = m);
+ assert begin
+ for i = 0 to m - 1 do
+ assert (Array.length t.(i) = n)
+ done;
+ true
+ end;
+
+ (* This turns a row-as-array into a row-as-sparse-list. *)
+
+ let sparse (line : 'a array) : 'a row =
+
+ let rec loop (j : int) (row : 'a row) =
+ if j < 0 then
+ row
+ else
+ let x = line.(j) in
+ loop
+ (j - 1)
+ (if insignificant x then row else (j, x) :: row)
+ in
+
+ loop (n - 1) []
+
+ in
+
+ (* Define the rank of a row as its number of significant entries. *)
+
+ let rank (row : 'a row) : int =
+ List.length row
+ in
+
+ (* Construct a list of all rows, together with their index and rank. *)
+
+ let rows : (int * int * 'a row) list = (* index, rank, row *)
+ Array.to_list (
+ Array.mapi (fun i line ->
+ let row = sparse line in
+ i, rank row, row
+ ) t
+ )
+ in
+
+ (* Sort this list by decreasing rank. This does not have any impact
+ on correctness, but reportedly improves compression. The
+ intuitive idea is that rows with few significant elements are
+ easy to fit, so they should be inserted last, after the problem
+ has become quite constrained by fitting the heavier rows. This
+ heuristic is attributed to Ziegler. *)
+
+ let rows =
+ List.sort (fun (_, rank1, _) (_, rank2, _) ->
+ compare rank2 rank1
+ ) rows
+ in
+
+ (* Allocate a one-dimensional array of displacements. *)
+
+ let displacement : int array =
+ Array.make m 0
+ in
+
+ (* Allocate a one-dimensional, infinite array of values. Indices
+ into this array are written [k]. *)
+
+ let data : 'a InfiniteArray.t =
+ InfiniteArray.make dummy
+ in
+
+ (* Determine whether [row] fits at offset [k] within the current [data]
+ array, up to extension of this array. *)
+
+ (* Note that this check always succeeds when [k] equals the length of
+ the [data] array. Indeed, the loop is then skipped. This property
+ guarantees the termination of the recursive function [fit] below. *)
+
+ let fits k (row : 'a row) : bool =
+
+ let d = InfiniteArray.extent data in
+
+ let rec loop = function
+ | [] ->
+ true
+ | (j, x) :: row ->
+
+ (* [x] is a significant element. *)
+
+ (* By hypothesis, [k + j] is nonnegative. If it is greater than or
+ equal to the current length of the data array, stop -- the row
+ fits. *)
+
+ assert (k + j >= 0);
+
+ if k + j >= d then
+ true
+
+ (* We now know that [k + j] is within bounds of the data
+ array. Check whether it is compatible with the element [y] found
+ there. If it is, continue. If it isn't, stop -- the row does not
+ fit. *)
+
+ else
+ let y = InfiniteArray.get data (k + j) in
+ if insignificant y || equal x y then
+ loop row
+ else
+ false
+
+ in
+ loop row
+
+ in
+
+ (* Find the leftmost position where a row fits. *)
+
+ (* If the leftmost significant element in this row is at offset [j],
+ then we can hope to fit as far left as [-j] -- so this element
+ lands at offset [0] in the data array. *)
+
+ (* Note that displacements may be negative. This means that, for
+ insignificant elements, accesses to the data array could fail: they could
+ be out of bounds, either towards the left or towards the right. This is
+ not a problem, as long as [get] is invoked only at significant
+ elements. *)
+
+ let rec fit k row : int =
+ if fits k row then
+ k
+ else
+ fit (k + 1) row
+ in
+
+ let fit row =
+ match row with
+ | [] ->
+ 0 (* irrelevant *)
+ | (j, _) :: _ ->
+ fit (-j) row
+ in
+
+ (* Write [row] at (compatible) offset [k]. *)
+
+ let rec write k = function
+ | [] ->
+ ()
+ | (j, x) :: row ->
+ InfiniteArray.set data (k + j) x;
+ write k row
+ in
+
+ (* Iterate over the sorted list of rows. Fit and write each row at
+ the leftmost compatible offset. Update the displacement table. *)
+
+ let () =
+ List.iter (fun (i, _, row) ->
+ let k = fit row in (* if [row] has leading insignificant elements, then [k] can be negative *)
+ write k row;
+ displacement.(i) <- encode k
+ ) rows
+ in
+
+ (* Return the compressed tables. *)
+
+ displacement, InfiniteArray.domain data
+
+(* [get ct i j] returns the value found at indices [i] and [j] in the
+ compressed table [ct]. This function call is permitted only if the
+ value found at indices [i] and [j] in the original table is
+ significant -- otherwise, it could fail abruptly. *)
+
+(* Together, [compress] and [get] have the property that, if the value
+ found at indices [i] and [j] in an uncompressed table [t] is
+ significant, then [get (compress t) i j] is equal to that value. *)
+
+let get (displacement, data) i j =
+ assert (0 <= i && i < Array.length displacement);
+ let k = decode displacement.(i) in
+ assert (0 <= k + j && k + j < Array.length data);
+ (* failure of this assertion indicates an attempt to access an
+ insignificant element that happens to be mapped out of the bounds
+ of the [data] array. *)
+ data.(k + j)
+
+(* [getget] is a variant of [get] which only requires read access,
+ via accessors, to the two components of the table. *)
+
+let getget get_displacement get_data (displacement, data) i j =
+ let k = decode (get_displacement displacement i) in
+ get_data data (k + j)
+
Added: trunk/Toss/MenhirLib/rowDisplacement.mli
===================================================================
--- trunk/Toss/MenhirLib/rowDisplacement.mli (rev 0)
+++ trunk/Toss/MenhirLib/rowDisplacement.mli 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* This module compresses a two-dimensional table, where some values
+ are considered insignificant, via row displacement. *)
+
+(* A compressed table is represented as a pair of arrays. The
+ displacement array is an array of offsets into the data array. *)
+
+type 'a table =
+ int array * (* displacement *)
+ 'a array (* data *)
+
+(* [compress equal insignificant dummy m n t] turns the two-dimensional table
+ [t] into a compressed table. The parameter [equal] is equality of data
+ values. The parameter [wildcard] tells which data values are insignificant,
+ and can thus be overwritten with other values. The parameter [dummy] is
+ used to fill holes in the data array. [m] and [n] are the integer
+ dimensions of the table [t]. *)
+
+val compress:
+ ('a -> 'a -> bool) ->
+ ('a -> bool) ->
+ 'a ->
+ int -> int ->
+ 'a array array ->
+ 'a table
+
+(* [get ct i j] returns the value found at indices [i] and [j] in the
+ compressed table [ct]. This function call is permitted only if the
+ value found at indices [i] and [j] in the original table is
+ significant -- otherwise, it could fail abruptly. *)
+
+(* Together, [compress] and [get] have the property that, if the value
+ found at indices [i] and [j] in an uncompressed table [t] is
+ significant, then [get (compress t) i j] is equal to that value. *)
+
+val get:
+ 'a table ->
+ int -> int ->
+ 'a
+
+(* [getget] is a variant of [get] which only requires read access,
+ via accessors, to the two components of the table. *)
+
+val getget:
+ ('displacement -> int -> int) ->
+ ('data -> int -> 'a) ->
+ 'displacement * 'data ->
+ int -> int ->
+ 'a
+
Added: trunk/Toss/MenhirLib/tableFormat.ml
===================================================================
--- trunk/Toss/MenhirLib/tableFormat.ml (rev 0)
+++ trunk/Toss/MenhirLib/tableFormat.ml 2012-02-01 18:27:03 UTC (rev 1659)
@@ -0,0 +1,134 @@
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Fran\xE7ois Pottier, INRIA Rocquencourt *)
+(* Yann R\xE9gis-Gianas, PPS, Universit\xE9 Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 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 described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* This signature defines the format of the parse tables. It is used as
+ an argument to [TableInterpreter]. *)
+
+module type TABLES = sig
+
+ (* This is the parser's type of tokens. *)
+
+ type token
+
+ (* This maps a token to its internal (generation-time) integer code. *)
+
+ val token2terminal: token -> int
+
+ (* This is the integer code for the error pseudo-token. *)
+
+ val error_terminal: int
+
+ (* This maps a token to its semantic value. *)
+
+ val token2value: token -> Obj.t
+
+ (* Traditionally, an LR automaton is described by two tables, namely, an
+ action table and a goto table. See, for instance, the Dragon book.
+
+ The action table is a two-dimensional matrix that maps a state and a
+ lookahead token to an action. An action is one of: shift to a certain
+ state, reduce a certain production, accept, or fail.
+
+ The goto table is a two-dimensional matrix that maps a state and a
+ non-terminal symbol to either a state or undefined. By construction, this
+ table is sparse: its undefined entries are never looked up. A compression
+ technique is free to overlap them with other entries.
+
+ In Menhir, things are slightly different. If a state has a default
+ reduction on token [#], then that reduction must be performed without
+ consulting the lookahead token. As a result, we must first determine
+ whether that is the case, before we can obtain a lookahead token and use it
+ as an index in the action table.
+
+ Thus, Menhir's tables are as follows.
+
+ A one-dimensional default reduction table maps a state to either ``no
+ default reduction'' (encoded as: 0) or ``by default, reduce prod''
+ (encoded as: 1 + prod). The action table is looked up only when there
+ is no default reduction. *)
+
+ val default_reduction: PackedIntArray.t
+
+ (* Menhir follows Dencker, D\xFCrre and Heuft, who point out that, although the
+ action table is not sparse by nature (i.e., the error entries are
+ significant), it can be made sparse by first factoring out a binary error
+ matrix, then replacing the error entries in the action table with undefined
+ entries. Thus:
+
+ A two-dimensional error bitmap maps a state and a terminal to either
+ ``fail'' (encoded as: 0) or ``do not fail'' (encoded as: 1). The action
+ table, which is now sparse, is looked up only in the latter case. *)
+
+ (* The error bitmap is flattened into a one-dimensional table; its width is
+ recorded so as to allow indexing. The table is then compressed via
+ [PackedIntArray]. The bit width of the resulting packed array must be
+ [1], so it is not explicitly recorded. *)
+
+ (* The error bitmap does not contain a column for the [#] pseudo-terminal.
+ Thus, its width is [Terminal.n - 1]. We exploit the fact that the integer
+ code assigned to [#] is greatest: the fact that the right-most column
+ in the bitmap is missing does not affect the code for accessing it. *)
+
+ val error: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *)
+
+ (* A two-dimensional action table maps a state and a terminal to one of
+ ``shift to state s and discard the current token'' (encoded as: s | 10),
+ ``shift to state s without discarding the current token'' (encoded as: s |
+ 11), or ``reduce prod'' (encoded as: prod | 01). *)
+
+ (* The action table is first compressed via [RowDisplacement], then packed
+ via [PackedIntArray]. *)
+
+ (* Like the error bitmap, the action table does not contain a column for the
+ [#] pseudo-terminal. *)
+
+ val action: PackedIntArray.t * PackedIntArray.t
+
+ (* A one-dimensional lhs table maps a production to its left-hand side (a
+ non-terminal symbol). *)
+
+ val lhs: PackedIntArray.t
+
+ (* A two-dimensional goto table maps a state and a non-terminal symbol to
+ either undefined (encoded as: 0) or a new state s (encoded as: 1 + s). *)
+
+ (* The goto table is first compressed via [RowDisplacement], then packed
+ via [PackedIntArray]. *)
+
+ val goto: PackedIntArray.t * PackedIntArray.t
+
+ (* A one-dimensional semantic action table maps productions to semantic
+ actions. The calling convention for semantic actions is described in
+ [EngineTypes]. *)
+
+ val semantic_action: ((int, Obj.t, token) EngineTypes.env -> unit) array
+
+ (* The parser defines its own [Error] exception. This exception can be
+ raised by semantic actions and caught by the engine, and raised by the
+ engine towards the final user. *)
+
+ exception Error
+
+ (* The parser indicates whether to perform error recovery. *)
+
+ val recovery: bool
+
+ (* The parser...
[truncated message content] |
|
From: <luk...@us...> - 2012-02-01 19:28:49
|
Revision: 1660
http://toss.svn.sourceforge.net/toss/?rev=1660&view=rev
Author: lukstafi
Date: 2012-02-01 19:28:39 +0000 (Wed, 01 Feb 2012)
Log Message:
-----------
Local JS client: display iterations instead of tree size; diagnostic alerts for preparations of games; recompiled JsHandler.js.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Server/GameSelection.ml
trunk/Toss/Server/JsHandler.ml
trunk/Toss/WebClient/JsHandler.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Play.js
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/Formula/Aux.ml 2012-02-01 19:28:39 UTC (rev 1660)
@@ -772,3 +772,14 @@
) 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-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/Formula/Aux.mli 2012-02-01 19:28:39 UTC (rev 1660)
@@ -369,3 +369,7 @@
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/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2012-02-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/Play/Play.ml 2012-02-01 19:28:39 UTC (rev 1660)
@@ -45,6 +45,8 @@
unfold ~timeout:timed_out ~ab:ab game heur ~info_leaf:(fun _ _ _ -> 0)
~info_node:(maxdepth_node) ~choice:(maximax_depth_choice ab)
+let latest_unfold_iters_left = ref 0
+
(* Maximax unfolding upto depth. *)
let rec unfold_maximax_upto ?(ab=false) count game heur (t, pmvs) =
let mvs = (choose_moves game t) :: pmvs in
@@ -61,13 +63,12 @@
with
| Not_found -> (t, mvs)
| Aux.Timeout msg ->
+ latest_unfold_iters_left := count;
if !debug_level > 0 then
Printf.printf "Timeout %f (%s)%!"
(Aux.gettimeofday() -. !timeout) msg;
(t, mvs)
-let latest_gametree_size = ref 0
-
(* 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! *)
@@ -77,7 +78,6 @@
let t = init game state (fun _ _ _ -> 0) heur in
try
let (u, mvs) = unfold_maximax_upto ~ab count game heur (t, []) in
- latest_gametree_size := GameTree.size u;
let nbr_to_check = min (2*check_stable + 1) (List.length mvs / 3) in
let last_mvs = Aux.take_n (max 1 nbr_to_check) mvs in
if !debug_level = 2 then
Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli 2012-02-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/Play/Play.mli 2012-02-01 19:28:39 UTC (rev 1660)
@@ -13,17 +13,18 @@
int GameTree.game_tree -> int GameTree.game_tree
-(** Maximax unfolding upto depth, keep previous moves for stability. *)
+(** Maximax unfolding upto iterations, keep previous moves for stability. *)
val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
Formula.real_expr array array ->
int GameTree.game_tree * (Arena.move * Arena.game_state) list list ->
int GameTree.game_tree * (Arena.move * Arena.game_state) list list
-(** Maximax unfold upto depth and choose move. *)
+(** Maximax unfold upto iterations and choose move. *)
val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
Arena.game_state -> Formula.real_expr array array ->
(Arena.move * Arena.game_state) list
-(** Size of the game-tree produced by the latest call of
- {!Play.maximax_unfold_choose}. *)
-val latest_gametree_size : int ref
+(** In case the computation is interrupted by a timeout, how many
+ iterations were left to perform by {!Play.maximax_unfold_choose}
+ or {!Play.unfold_maximax_upto}. *)
+val latest_unfold_iters_left : int ref
Modified: trunk/Toss/Server/GameSelection.ml
===================================================================
--- trunk/Toss/Server/GameSelection.ml 2012-02-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/Server/GameSelection.ml 2012-02-01 19:28:39 UTC (rev 1660)
@@ -20,22 +20,1205 @@
with Not_found ->
Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
-let compile_game_data game_str =
+let compile_game_data game_name game_str =
+ Aux.alert ("Parsing "^game_name^"...");
let (game, game_state as game_with_state) =
ArenaParser.parse_game_state Lexer.lex (Lexing.from_string game_str) in
+ Aux.alert ("Parsed "^game_name^" -- computing its heuristic...");
let adv_ratio =
try Some (float_of_string (List.assoc "adv_ratio" game.Arena.data))
with Not_found -> None in
- {heuristic = compute_heuristic adv_ratio game_with_state;
+ let heuristic = compute_heuristic adv_ratio game_with_state in
+ Aux.alert ("Heuristic for "^game_name^" computed.");
+ game_name,
+ {heuristic = heuristic;
game_state = game_with_state;
playclock = 30; (* game clock from where? *)
game_str = game_str;
}
-(* Maximum call stack size exceeded in JS (pbbly parsing Chess)
-let chess_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 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)))
+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)) post true
+RULE WhiteRightCastle:
+ [ | | ] \"
+ ... ...
+ wK. ...wR
+\" -> [ | | ] \"
+ ... ...
+ ...wR wK.
+\" emb w,b pre not (bBeats(a1) or bBeats(b1) or bBeats(c1)) post true
+RULE BlackLeftCastle:
+ [ | | ] \"
+ ... ... ...
+ bR. ... bK.
+\" -> [ | | ] \"
+ ... ... ...
+ ... bK.bR ...
+\" emb w,b pre not(wBeats(c1) or wBeats(d1) or wBeats(e1)) post true
+RULE BlackRightCastle:
+ [ | | ] \"
+ ... ...
+ bK. ...bR
+\" -> [ | | ] \"
+ ... ...
+ ...bR bK.
+\" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) post true
+LOC 0 { // both can castle
+ 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 -> 5];
+ [WhiteRookH1 -> 3];
+ [WhiteQueen -> 1];
+ [WhiteLeftCastle -> 7];
+ [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 1 { // both can castle
+ 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 -> 16];
+ [BlackRookH8 -> 8];
+ [BlackQueen -> 0];
+ [BlackLeftCastle -> 24];
+ [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 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.
+ ... ... ... ...
+ 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)) )
+")
+
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)
@@ -643,12 +1826,12 @@
let games = ref
[
- "Breakthrough", compile_game_data breakthrough_str;
- "Checkers", compile_game_data checkers_str;
- (* "Chess", compile_game_data chess_str; *)
- "Connect4", compile_game_data connect4_str;
- "Entanglement", compile_game_data entanglement_str;
- "Gomoku", compile_game_data gomoku_str;
- "Pawn-Whopping", compile_game_data pawn_whopping_str;
- "Tic-Tac-Toe", compile_game_data tictactoe_str;
+ 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;
]
Modified: trunk/Toss/Server/JsHandler.ml
===================================================================
--- trunk/Toss/Server/JsHandler.ml 2012-02-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/Server/JsHandler.ml 2012-02-01 19:28:39 UTC (rev 1660)
@@ -147,16 +147,17 @@
let game, _ = !cur_game.game_state in
let state = List.hd !play_states in
try
+ let large_iters = 100000 in
let (move, _) =
- Aux.random_elem (Play.maximax_unfold_choose 100000
+ Aux.random_elem (Play.maximax_unfold_choose large_iters
game state !cur_game.heuristic) in
Play.cancel_timeout ();
- let algo_iters = !Play.latest_gametree_size in
+ let algo_iters = large_iters - !Play.latest_unfold_iters_left in
let move_id = Aux.array_argfind
(fun (_, m, _) -> m = move) !cur_all_moves in
let result =
js_of_move game state move_id (!cur_all_moves.(move_id)) in
- Js.Unsafe.set result (js"comp_tree_size")
+ Js.Unsafe.set result (js"comp_iters")
(Js.number_of_float (float_of_int algo_iters));
Js.Unsafe.set result (js"comp_started")
(Js.number_of_float comp_started);
@@ -176,7 +177,7 @@
let set_game game_name game_str =
let game_name = of_js game_name and game_str = of_js game_str in
try
- games := (game_name, compile_game_data game_str) :: !games;
+ games := compile_game_data game_name game_str :: !games;
js ("Game "^game_name^" set.")
with Lexer.Parsing_error s ->
js ("Game "^game_name^" ERROR: "^s)
Modified: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js 2012-02-01 18:27:03 UTC (rev 1659)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-01 19:28:39 UTC (rev 1660)
@@ -892,4 +892,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-02 11:17:03
|
Revision: 1661
http://toss.svn.sourceforge.net/toss/?rev=1661&view=rev
Author: lukstafi
Date: 2012-02-02 11:16:52 +0000 (Thu, 02 Feb 2012)
Log Message:
-----------
Trampolined Menhir engine; added chess to local JS game selection (not in interface).
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/MenhirLib/engine.ml
trunk/Toss/Server/GameSelection.ml
trunk/Toss/WebClient/JsHandler.js
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2012-02-01 19:28:39 UTC (rev 1660)
+++ trunk/Toss/Arena/Arena.ml 2012-02-02 11:16:52 UTC (rev 1661)
@@ -315,6 +315,13 @@
let graph = Aux.array_from_assoc (List.rev locations) in
let pats=List.rev_map (FormulaSubst.subst_rels_expr def_rels_pure) patterns in
let apply_moves rules mvs s = List.fold_left (apply_move rules) s mvs in
+ let result_state =
+ apply_moves rules hist {
+ struc = state;
+ time = time;
+ cur_loc = cur_loc;
+ history = [];
+ } in
{
rules = rules;
patterns = pats;
@@ -324,13 +331,7 @@
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
starting_struc = state;
- },
- apply_moves rules hist {
- struc = state;
- time = time;
- cur_loc = cur_loc;
- history = [];
- }
+ }, result_state
Modified: trunk/Toss/MenhirLib/engine.ml
===================================================================
--- trunk/Toss/MenhirLib/engine.ml 2012-02-01 19:28:39 UTC (rev 1660)
+++ trunk/Toss/MenhirLib/engine.ml 2012-02-02 11:16:52 UTC (rev 1661)
@@ -48,12 +48,22 @@
(* --------------------------------------------------------------------------- *)
- (* The type [void] is empty. Many of the functions below have return type
- [void]. This guarantees that they never return a value. Instead, they
- must stop by raising an exception: either [Accept] or [Error]. *)
+ (* Many of the functions below have return type [trampoline]. This
+ guarantees that they never return a value, but continue the
+ computation. Instead, they must stop by raising an exception:
+ either [Accept] or [Error]. *)
- type void
+ type trampoline =
+ | Run of t_env * bool
+ | Continue of t_env
+ | Action of t_env
+ | Shift of t_env * bool * terminal * T.semantic_value * state
+ | Reduce of t_env * T.production
+ | Initiate of t_env
+ | ErrorCont of t_env
+ and t_env = (state, semantic_value, token) env
+
(* --------------------------------------------------------------------------- *)
(* In the code-based back-end, the [run] function is sometimes responsible
@@ -79,7 +89,7 @@
Here, the code is structured in a slightly different way. It is up to
the caller of [run] to indicate whether to discard a token. *)
- let rec run env please_discard : void =
+ let run env please_discard : trampoline =
(* Log the fact that we just entered this state. *)
@@ -100,11 +110,13 @@
T.default_reduction
s
- reduce (* there is a default reduction; perform it *)
- continue (* there is none; continue below *)
+ (fun env prod -> Reduce (env, prod))
+ (* there is a default reduction; perform it *)
+ (fun env -> Continue env)
+ (* there is none; continue below *)
env
- and continue env : void =
+ and continue env : trampoline =
(* There is no default reduction. Consult the current lookahead token
so as to determine which action should be taken. *)
@@ -119,10 +131,10 @@
if env.shifted = (-1) then begin
Log.resuming_error_handling();
- error env
+ ErrorCont env
end
else
- action env
+ Action env
(* --------------------------------------------------------------------------- *)
@@ -130,7 +142,7 @@
a default reduction. We also know that the current lookahead token is
not [error]: it is a real token, stored in [env.token]. *)
- and action env : void =
+ let action env : trampoline =
(* We consult the two-dimensional action table, indexed by the
current state and the current lookahead token, in order to
@@ -141,9 +153,10 @@
env.current (* determines a row *)
(T.token2terminal token) (* determines a column *)
(T.token2value token)
- shift (* shift continuation *)
- reduce (* reduce continuation *)
- initiate (* failure continuation *)
+ (fun env please_discard terminal value s' ->
+ Shift (env, please_discard, terminal, value, s'))
+ (fun env prod -> Reduce (env, prod))
+ (fun env -> Initiate env) (* failure continuation *)
env
(* --------------------------------------------------------------------------- *)
@@ -152,12 +165,12 @@
(Goto transitions are taken care of within [reduce] below.) The symbol
can be either an actual token or the [error] pseudo-token. *)
- and shift env
+ let shift env
(please_discard : bool)
(terminal : terminal)
(value : semantic_value)
(s' : state)
- : void =
+ : trampoline =
(* Log the transition. *)
@@ -178,13 +191,19 @@
(* Switch to state [s']. *)
env.current <- s';
- run env please_discard
+ Run (env, please_discard)
(* --------------------------------------------------------------------------- *)
+ let errorbookkeeping env =
+ Log.initiating_error_handling();
+ env.previouserror <- env.shifted;
+ env.shifted <- (-1);
+ ErrorCont env
+
(* This function takes care of reductions. *)
- and reduce env (prod : production) : void =
+ let reduce env (prod : production) : trampoline =
(* Log a reduction event. *)
@@ -218,7 +237,7 @@
production [prod]. *)
env.current <- T.goto env.stack.state prod;
- run env false
+ Run (env, false)
end
else
@@ -232,41 +251,21 @@
(* [initiate] and [errorbookkeeping] initiate error handling. See the functions
by the same names in [CodeBackend]. *)
- and initiate env : void =
+ let initiate env : trampoline =
assert (env.shifted >= 0);
if T.recovery && env.shifted = 0 then begin
Log.discarding_last_token (T.token2terminal env.token);
discard env;
env.shifted <- 0;
- action env
+ Action env
end
else
errorbookkeeping env
- and errorbookkeeping env =
- Log.initiating_error_handling();
- env.previouserror <- env.shifted;
- env.shifted <- (-1);
- error env
-
(* [error] handles errors. *)
- and error env : void =
+ let error_shift env please_discard terminal value s' =
- (* Consult the column associated with the [error] pseudo-token in the
- action table. *)
-
- T.action
- env.current (* determines a row *)
- T.error_terminal (* determines a column *)
- T.error_value
- error_shift (* shift continuation *)
- error_reduce (* reduce continuation *)
- error_fail (* failure continuation *)
- env
-
- and error_shift env please_discard terminal value s' =
-
(* Here, [terminal] is [T.error_terminal], and [value] is [T.error_value]. *)
assert (terminal = T.error_terminal && value = T.error_value);
@@ -274,16 +273,16 @@
(* This state is capable of shifting the [error] token. *)
Log.handling_error env.current;
- shift env please_discard terminal value s'
+ Shift (env, please_discard, terminal, value, s')
- and error_reduce env prod =
+ let error_reduce env prod =
(* This state is capable of performing a reduction on [error]. *)
Log.handling_error env.current;
- reduce env prod
+ Reduce (env, prod)
- and error_fail env =
+ let error_fail env =
(* This state is unable to handle errors. Attempt to pop a stack
cell. *)
@@ -303,10 +302,24 @@
env.stack <- next;
env.current <- cell.state;
- error env
+ ErrorCont env
end
+ let error env : trampoline =
+
+ (* Consult the column associated with the [error] pseudo-token in the
+ action table. *)
+
+ T.action
+ env.current (* determines a row *)
+ T.error_terminal (* determines a column *)
+ T.error_value
+ error_shift (* shift continuation *)
+ error_reduce (* reduce continuation *)
+ error_fail (* failure continuation *)
+ env
+
(* --------------------------------------------------------------------------- *)
let entry
@@ -353,12 +366,25 @@
try
- (* If ocaml offered a [match/with] construct with zero branches, this is
- what we would use here, since the type [void] has zero cases. *)
-
- let (_ : void) = run env false in
- assert false (* cannot fail *)
-
+ let result = ref (run env false) in
+ while true do
+ match !result with
+ | Run (env, please_discard) ->
+ result := run env please_discard
+ | Continue env ->
+ result := continue env
+ | Action env ->
+ result := action env
+ | Shift (env, please_discard, terminal, value, s') ->
+ result := shift env please_discard terminal value s'
+ | Reduce (env, prod) ->
+ result := reduce env prod
+ | Initiate env ->
+ result := initiate env
+ | ErrorCont env ->
+ result := error env
+ done;
+ assert false
with
| Accept v ->
v
Modified: trunk/Toss/Server/GameSelection.ml
===================================================================
--- trunk/Toss/Server/GameSelection.ml 2012-02-01 19:28:39 UTC (rev 1660)
+++ trunk/Toss/Server/GameSelection.ml 2012-02-02 11:16:52 UTC (rev 1661)
@@ -21,15 +21,13 @@
Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
let compile_game_data game_name game_str =
- Aux.alert ("Parsing "^game_name^"...");
+ 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
- Aux.alert ("Parsed "^game_name^" -- computing its heuristic...");
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
- Aux.alert ("Heuristic for "^game_name^" computed.");
game_name,
{heuristic = heuristic;
game_state = game_with_state;
@@ -1533,6 +1531,7 @@
\"
")
+
let checkers_str = ("
PLAYERS 1, 2
DATA depth: 4, adv_ratio: 2
@@ -1828,7 +1827,7 @@
[
compile_game_data "Breakthrough" breakthrough_str;
compile_game_data "Checkers" checkers_str;
- (* compile_game_data "Chess" chess_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;
Modified: trunk/Toss/WebClient/JsHandler.js
===================================================================
--- trunk/Toss/WebClient/JsHandler.js 2012-02-01 19:28:39 UTC (rev 1660)
+++ trunk/Toss/WebClient/JsHandler.js 2012-02-02 11:16:52 UTC (rev 1661)
@@ -892,4 +892,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.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X