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 ?...
[truncated message content] |
|
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 ...
[truncated message content] |
|
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 c...
[truncated message content] |
|
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...
[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; *)
+ formul...
[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...
[truncated message content] |
|
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
=============================...
[truncated message content] |
|
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...
[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 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
[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 mak...
[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()) -...
[truncated message content] |
|
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.
|
Thanks for helping keep SourceForge clean.
X