Thread: [Toss-devel-svn] SF.net SVN: toss:[1590] trunk/Toss (Page 10)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2011-10-12 15:57:30
|
Revision: 1590
http://toss.svn.sourceforge.net/toss/?rev=1590&view=rev
Author: lukaszkaiser
Date: 2011-10-12 15:57:24 +0000 (Wed, 12 Oct 2011)
Log Message:
-----------
Adding a placeholder file for WL stuff.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Makefile
Added Paths:
-----------
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-10-11 10:33:28 UTC (rev 1589)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-10-12 15:57:24 UTC (rev 1590)
@@ -102,7 +102,7 @@
(* --- AType with variables over given relations, no repetition, equality --- *)
-let atp rels vars_in =
+let atoms ?(repetitions=true) rels vars_in =
if vars_in = [] then [] else
let vars = List.rev_map fo_var_of_string vars_in in
let rec rept i l = if i < 1 then [] else l :: (rept (i-1) l) in
@@ -110,12 +110,18 @@
if i < 1 then [] else if i = 1 then
List.map (fun v -> [|v|]) vars
else let arr l =
- if List.length (Aux.unique_sorted l) = i then
- Some (Array.of_list l)
- else None in
+ if repetitions then Some (Array.of_list l) else
+ if List.length (Aux.unique_sorted l) = i then
+ Some (Array.of_list l)
+ else None in
Aux.map_some arr (Aux.product (rept i vars)) in
let atom (rel, i) = List.rev_map (fun vs -> Rel (rel, vs)) (prod i) in
- let atoms = Array.of_list (List.concat (List.map atom rels)) in
+ List.concat (List.map atom rels)
+
+let atp rels vars_in =
+ if vars_in = [] then [] else
+ let rec rept i l = if i < 1 then [] else l :: (rept (i-1) l) in
+ let atoms = Array.of_list (atoms ~repetitions:false rels vars_in) in
let choices = Aux.product (rept (Array.length atoms) [true; false]) in
let atom_choice i c = if c then atoms.(i) else Not (atoms.(i)) in
let tp_of_choice l = And (Array.to_list (Array.mapi atom_choice l)) in
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-10-11 10:33:28 UTC (rev 1589)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-10-12 15:57:24 UTC (rev 1590)
@@ -22,6 +22,10 @@
(** {2 Type generating functions.} *)
+(** All atoms over given signature and variables. *)
+val atoms : ?repetitions: bool -> (string * int) list ->
+ string list -> formula list
+
(** AType with variables over given relations, no repetition, equality. *)
val atp : (string * int) list -> string list -> formula list
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-10-11 10:33:28 UTC (rev 1589)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-10-12 15:57:24 UTC (rev 1590)
@@ -247,7 +247,7 @@
((not Succ(t, s)) or (t in X) or (not (s in C))))))"
);
- "atp, mintp" >::
+ "atoms, atp, mintp" >::
(fun () ->
let report phis =
(* List.iter (fun f -> Format.printf "\n%!"; Formula.print f) phis; *)
@@ -269,6 +269,9 @@
let phis = report (FormulaOps.mintp (nv 2) [("R", 2); ("P", 1)] []) in
assert_equal ~printer:string_of_int 16 (List.length phis);
+
+ let phis = report (FormulaOps.atoms [("R", 2); ("P", 1)] ["x"; "y"]) in
+ assert_equal ~printer:string_of_int 6 (List.length phis);
);
"remove_redundant default" >::
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-10-11 10:33:28 UTC (rev 1589)
+++ trunk/Toss/Server/Tests.ml 2011-10-12 15:57:24 UTC (rev 1590)
@@ -17,6 +17,7 @@
"AssignmentsTest", [AssignmentsTest.tests];
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
"ClassTest", [ClassTest.tests; ClassTest.bigtests];
+ "WLTest", [WLTest.tests];
]
let arena_tests = "Arena", [
Modified: trunk/Toss/Solver/Makefile
===================================================================
--- trunk/Toss/Solver/Makefile 2011-10-11 10:33:28 UTC (rev 1589)
+++ trunk/Toss/Solver/Makefile 2011-10-12 15:57:24 UTC (rev 1590)
@@ -9,6 +9,7 @@
FFSolverTest:
ClassTest:
PresbTest:
+WLTest:
tests:
make -C .. SolverTestsVerbose
Added: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml (rev 0)
+++ trunk/Toss/Solver/WL.ml 2011-10-12 15:57:24 UTC (rev 1590)
@@ -0,0 +1,27 @@
+open Formula
+
+let rec klist ?(i=1) k =
+ if i>=k then [k]
+ else i :: klist ~i:(i+1) k
+
+let rec existential index_l structure tuple k n =
+ match index_l with [element; index] ->
+ let replace array i elem =
+ let a = Array.copy array in
+ a.(i) <- elem;
+ a
+ in
+ Ex ([`FO ("x" ^ string_of_int(index))],
+ ntype structure (replace tuple index element) k n)
+ | _ -> failwith "wrong index list"
+
+and ntype structure tuple k n =
+ if n=0 then
+ And (FormulaOps.atoms (Structure.rel_signature structure)
+ (Array.to_list (Array.map string_of_int tuple)))
+ else
+ let eq = Eq(`FO "x", `FO "x") in
+ let indices = Aux.product [Structure.elements structure; klist k] in
+ let formulas =
+ List.map (fun x -> (existential x structure tuple k n)) indices in
+ And (eq :: formulas)
Added: trunk/Toss/Solver/WL.mli
===================================================================
--- trunk/Toss/Solver/WL.mli (rev 0)
+++ trunk/Toss/Solver/WL.mli 2011-10-12 15:57:24 UTC (rev 1590)
@@ -0,0 +1,3 @@
+(* The WL algorithm and related tests. *)
+
+val klist: ?i : int -> int -> int list
Added: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml (rev 0)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-12 15:57:24 UTC (rev 1590)
@@ -0,0 +1,12 @@
+open OUnit
+
+let tests = "WL" >::: [
+ "klist" >::
+ (fun () ->
+ assert_equal ~printer:(fun x -> string_of_int x)
+ 6 (List.length (WL.klist 6));
+ );
+]
+
+
+let exec = Aux.run_test_if_target "WLTest" tests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <si...@us...> - 2011-10-13 10:10:22
|
Revision: 1592
http://toss.svn.sourceforge.net/toss/?rev=1592&view=rev
Author: simles
Date: 2011-10-13 10:10:15 +0000 (Thu, 13 Oct 2011)
Log Message:
-----------
Added range function to Aux, added functions to WL
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-10-12 21:49:59 UTC (rev 1591)
+++ trunk/Toss/Formula/Aux.ml 2011-10-13 10:10:15 UTC (rev 1592)
@@ -355,6 +355,10 @@
| _ -> acc in
List.rev (aux n [] l)
+let rec range ?(from=1) k =
+ if from>=k then [k]
+ else from :: range ~from:(from+1) k
+
let array_map_some f a =
let r = Array.map f a in
let rl = ref (Array.length r) in
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-10-12 21:49:59 UTC (rev 1591)
+++ trunk/Toss/Formula/Aux.mli 2011-10-13 10:10:15 UTC (rev 1592)
@@ -213,6 +213,9 @@
contain enough values. *)
val take_n : int -> 'a list -> 'a list
+(** Returns an int list from from to k.*)
+val range: ?from : int -> int -> int list
+
(** Make an array from an association from indices to values. The
indices must cover the [0..length-1] range; raises
[Invalid_argument "Aux.array_from_assoc"] otherwise. *)
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-12 21:49:59 UTC (rev 1591)
+++ trunk/Toss/Solver/WL.ml 2011-10-13 10:10:15 UTC (rev 1592)
@@ -1,27 +1,57 @@
open Formula
-let rec klist ?(i=1) k =
- if i>=k then [k]
- else i :: klist ~i:(i+1) k
+let atoms structure listOfLiterals (tuple: int array) variable =
+ let variables = (Array.sub variable 0 (Array.length tuple)) in
+ let eval structure literal assignment =
+ (Solver.M.evaluate_partial structure assignment literal) in
+ let set_listS = Assignments.Set (Structure.Elems.cardinal (Structure.elems structure),
+ (Structure.elems structure)) in
+ let assignment = Assignments.assignments_of_list (ref
+ set_listS) variables [tuple] in
+ List.map
+ ( fun literal ->
+ ( if (( eval structure literal assignment )=AssignmentSet.Empty ) then (Not literal)
+ else ( literal )))
+ listOfLiterals
let rec existential index_l structure tuple k n =
match index_l with [element; index] ->
let replace array i elem =
let a = Array.copy array in
- a.(i) <- elem;
- a
+ if (i-1) < (Array.length tuple) then
+ (a.(i-1) <- elem;
+ a)
+ else Array.append a [|elem|]
in
Ex ([`FO ("x" ^ string_of_int(index))],
ntype structure (replace tuple index element) k n)
| _ -> failwith "wrong index list"
+and universal index_l structure tuple k n =
+ match index_l with [element; index] ->
+ let replace array i elem =
+ let a = Array.copy array in
+ if (i-1) < (Array.length tuple) then
+ (a.(i-1) <- elem;
+ a)
+ else Array.append a [|elem|]
+ in
+ ntype structure (replace tuple index element) k n
+ | _ -> failwith "wrong index list"
+
and ntype structure tuple k n =
+ let variables = List.map (fun i -> "x"^string_of_int(i))
+ (Aux.range k) in
+ let ats = FormulaOps.atoms (Structure.rel_signature structure)
+ (Aux.take_n (Array.length tuple) variables) in
if n=0 then
- And (FormulaOps.atoms (Structure.rel_signature structure)
- (Array.to_list (Array.map string_of_int tuple)))
+ Formula.flatten (And (atoms structure ats tuple (Array.of_list(List.map
+ fo_var_of_string variables))))
else
- let eq = Eq(`FO "x", `FO "x") in
- let indices = Aux.product [Structure.elements structure; klist k] in
+ let indices = Aux.product [Structure.elements structure; Aux.range k] in
let formulas =
- List.map (fun x -> (existential x structure tuple k n)) indices in
- And (eq :: formulas)
+ List.map (fun x -> (
+ existential x structure tuple k (n-1))) indices in
+ let uformula =
+ List.map (fun x -> (universal x structure tuple k (n-1))) indices in
+ Formula.flatten (And (formulas))
Modified: trunk/Toss/Solver/WL.mli
===================================================================
--- trunk/Toss/Solver/WL.mli 2011-10-12 21:49:59 UTC (rev 1591)
+++ trunk/Toss/Solver/WL.mli 2011-10-13 10:10:15 UTC (rev 1592)
@@ -1,3 +1,5 @@
(* The WL algorithm and related tests. *)
-val klist: ?i : int -> int -> int list
+val atoms: Structure.structure -> Formula.formula list -> int array -> Formula.fo_var array -> Formula.formula list
+
+val ntype: Structure.structure -> int array -> int -> int -> Formula.formula
Modified: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml 2011-10-12 21:49:59 UTC (rev 1591)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-13 10:10:15 UTC (rev 1592)
@@ -1,11 +1,45 @@
open OUnit
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+let struc_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
let tests = "WL" >::: [
"klist" >::
(fun () ->
assert_equal ~printer:(fun x -> string_of_int x)
- 6 (List.length (WL.klist 6));
+ 6 (List.length (Aux.range 6));
);
+ "atoms" >::
+ (fun () ->
+ let variables = ["x1";"x2"] in
+ let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ assert_equal ~printer:(fun x -> x)
+ "(not R(x1, x1) and R(x1, x2) and not R(x2, x1) and not R(x2, x2))" (Formula.str (Formula.And (WL.atoms structure
+ (FormulaOps.atoms (Structure.rel_signature structure) variables)
+ [|2; 3|]
+ (Array.of_list(List.map Formula.fo_var_of_string variables))
+ )));
+ );
+ "ntype1" >::
+ ( fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2) } | ]") in
+ assert_equal ~printer:(fun x-> x)
+ "(ex x1 (not R(x1, x1) and R(x1, x2) and not R(x2, x1) and not R(x2, x2)) and
+ ex x2 (not R(x1, x1) and not R(x1, x2) and not R(x2, x1) and not R(x2, x2)) and
+ ex x1 (not R(x1, x1) and not R(x1, x2) and not R(x2, x1) and not R(x2, x2)) and
+ ex x2 (not R(x1, x1) and R(x1, x2) and not R(x2, x1) and not R(x2, x2)))"
+ (Formula.str (WL.ntype structure [|1;2|] 2 1) );
+ );
+ "ntype2" >::
+ ( fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2) } | ]") in
+ assert_equal ~printer:(fun x-> x)
+ ""
+ (Formula.str (WL.ntype structure [|1;2|] 3 1) );
+ );
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-13 12:28:28
|
Revision: 1593
http://toss.svn.sourceforge.net/toss/?rev=1593&view=rev
Author: lukaszkaiser
Date: 2011-10-13 12:28:21 +0000 (Thu, 13 Oct 2011)
Log Message:
-----------
Improvements to the assignments and structure interfaces.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Formula/Aux.ml 2011-10-13 12:28:21 UTC (rev 1593)
@@ -547,6 +547,9 @@
true
with Not_found -> false
+let array_replace array i elem =
+ let a = Array.copy array in a.(i-1) <- elem; a
+
let neg f x = not (f x)
let is_right = function Right _ -> true | Left _ -> false
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Formula/Aux.mli 2011-10-13 12:28:21 UTC (rev 1593)
@@ -260,6 +260,9 @@
arrays are of different lengths. *)
val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+(** Return a copy of [array] with the [i]th element replaced by [elem]. *)
+val array_replace : 'a array -> int -> 'a -> 'a array
+
(** Find all maximal elements in a list. *)
val list_find_all_max : ('a -> 'a -> int) -> 'a list -> 'a list
(** Find all maximal elements in an array. *)
Modified: trunk/Toss/Solver/Assignments.ml
===================================================================
--- trunk/Toss/Solver/Assignments.ml 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/Assignments.ml 2011-10-13 12:28:21 UTC (rev 1593)
@@ -42,6 +42,10 @@
(* Helper type to represent a set or a list of elements with length. *)
type set_list = List of int * int list | Set of int * Elems.t
+(* Create a set_list out of a set. *)
+let set_to_set_list set = ref (Set ((Elems.cardinal set), set))
+let list_to_set_list list = ref (List ((List.length list), list))
+
(* List a set or list ref; changes from set to list if required. *)
let slist slr =
match !slr with
@@ -447,34 +451,43 @@
(* -------- CREATING ASSIGNMENTS FROM VARIABLES AND ELEMENT TUPLES --------- *)
-(* Helper function to remove duplicate assignments to variables and append.*)
-let remove_dup_append assgn_list asgn =
- let rec remove_dup acc = function
- | [] -> acc :: assgn_list
- | [x] -> (x :: acc) :: assgn_list
- | (v1, e1) :: (v2, e2) :: xs when v1 = v2 ->
- if e1 = e2 then remove_dup acc ((v2, e2) :: xs) else assgn_list
- | (v1, e1) :: (v2, e2) :: xs -> remove_dup ((v1, e1)::acc) ((v2, e2) :: xs)
- in
- remove_dup [] asgn
+(* Helper function for assignment creation below. *)
+let make_assign vl tuple =
+ let compare_asvs (v1, e1) (v2, e2) =
+ let c = compare_vars (v1 :> Formula.var) (v2 :> Formula.var) in
+ if c != 0 then -c else compare_elems e1 e2 in
+ List.sort compare_asvs (Array.to_list (Aux.array_combine vl tuple))
(* Create an assignment set out of a list of variables and assigned tuples. *)
let assignments_of_list elems vl tl =
- let compare_asvs (v1, e1) (v2, e2) =
- let c = compare_vars (v1 :> Formula.var) (v2 :> Formula.var) in
- if c != 0 then -c else compare_elems e1 e2 in
- let make_assign tuple =
- List.sort compare_asvs (Array.to_list (Aux.array_combine vl tuple)) in
- let make_append l t = remove_dup_append l (make_assign t) in
+ (* Helper function to remove duplicate assignments to variables and append.*)
+ let remove_dup_append assgn_list asgn =
+ let rec remove_dup acc = function
+ | [] -> acc :: assgn_list
+ | [x] -> (x :: acc) :: assgn_list
+ | (v1, e1) :: (v2, e2) :: xs when v1 = v2 ->
+ if e1 = e2 then remove_dup acc ((v2, e2) :: xs) else assgn_list
+ | (v1, e1) :: (v2, e2) :: xs ->
+ remove_dup ((v1, e1)::acc) ((v2, e2) :: xs) in
+ remove_dup [] asgn in
+ let make_append l t = remove_dup_append l (make_assign vl t) in
let asgn_list = List.fold_left make_append [] tl in
let rec set_of_single = function
| [] -> Empty
| [(v, e)] -> FO (v, [(e, Any)])
- | (v, e) :: rest -> FO (v, [(e, set_of_single rest)])
- in
- List.fold_left (fun s t -> sum elems s (set_of_single t)) Empty asgn_list
+ | (v, e) :: rest -> FO (v, [(e, set_of_single rest)]) in
+ List.fold_left (fun s t -> sum elems s (set_of_single t)) Empty asgn_list
+(* Create an assignment out of a list of variables and a tuple.
+ WRONG THIS WAY
+let assignment_of_list vl t =
+ let rec set_of_single = function
+ | [] -> Empty
+ | [(v, e)] -> FO (v, [(e, Any)])
+ | (v, e) :: rest -> FO (v, [(e, set_of_single rest)]) in
+ set_of_single (make_assign vl t)
+*)
(* ----------------- JOIN A RELATION WITH AN ASSIGNMENT -------------------- *)
Modified: trunk/Toss/Solver/Assignments.mli
===================================================================
--- trunk/Toss/Solver/Assignments.mli 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/Assignments.mli 2011-10-13 12:28:21 UTC (rev 1593)
@@ -18,14 +18,17 @@
(** Helper type to represent a set or a list of elements with length. *)
-type set_list = List of int * int list | Set of int * Structure.Elems.t
+type set_list
+(** Create a set_list *)
+val set_to_set_list : Structure.Elems.t -> set_list ref
+val list_to_set_list : int list -> set_list ref
+
(** List a set or list ref; changes from set to list if required. *)
val slist : set_list ref -> int list
val sset : set_list ref -> Structure.Elems.t
val sllen : set_list ref -> int
-
(** {2 Join} *)
@@ -86,12 +89,10 @@
(** {2 Creating Assignments from Variables and Element Tuples} *)
-
(** Create an assignment set out of an array of variables and a list of
- assigned tuples. *)
+ assigned tuples. The first argument are elements of the structure. *)
val assignments_of_list : set_list ref ->
- Formula.fo_var array -> int array list ->
- assignment_set
+ Formula.fo_var array -> int array list -> assignment_set
(** {2 Join a Relation with an Assignment} *)
Modified: trunk/Toss/Solver/AssignmentsTest.ml
===================================================================
--- trunk/Toss/Solver/AssignmentsTest.ml 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/AssignmentsTest.ml 2011-10-13 12:28:21 UTC (rev 1593)
@@ -23,21 +23,20 @@
let test_join = test2 "Join" join str
let test_join_tup elems_l (vns1, tps1) (vns2, tps2) =
- let elems = ref (List (List.length elems_l, elems_l)) in
+ let elems = list_to_set_list elems_l in
let vs1 = List.map (fun s -> Formula.fo_var_of_string s) vns1 in
let vs2 = List.map (fun s -> Formula.fo_var_of_string s) vns2 in
let as1 = assignments_of_list elems (Array.of_list vs1) tps1 in
let as2 = assignments_of_list elems (Array.of_list vs2) tps2 in
test_join as1 as2
-let test_sum elems =
- test2 "Sum" (sum (ref (List (List.length elems, elems)))) str
+let test_sum elems = test2 "Sum" (sum (list_to_set_list elems)) str
let test_complement elems =
- test1 "Complement" (complement (ref (List (List.length elems, elems)))) str
+ test1 "Complement" (complement (list_to_set_list elems)) str
let test_project elems v =
- test1 "Project" (project (ref (List (List.length elems, elems))) v) str
+ test1 "Project" (project (list_to_set_list elems) v) str
(* ------ Some constants used in tests ------ *)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/Solver.ml 2011-10-13 12:28:21 UTC (rev 1593)
@@ -283,9 +283,7 @@
(* Evaluate with assignment, no cache. *)
let evaluate_partial_aset solver ~formula struc fo_aset =
- let elems =
- ref (Set (Elems.cardinal (Structure.elems struc),
- (Structure.elems struc))) in
+ let elems = Assignments.set_to_set_list (Structure.elems struc) in
let phi = Hashtbl.find solver.formulas_eval formula in
incr eval_counter;
eval [] struc elems fo_aset phi
@@ -364,21 +362,14 @@
res
with Not_found ->
if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi));
- let els = Set (Elems.cardinal (Structure.elems struc),
- (Structure.elems struc)) in
+ let els = Assignments.set_to_set_list (Structure.elems struc) in
check_timeout "Solver.eval_m.not_found";
- let asg = eval [] struc (ref els) Any phi in
+ let asg = eval [] struc els Any phi in
incr eval_counter;
Hashtbl.add !cache_results phi (asg, phi_rels phi);
asg
)
-(* Helper function, assignment of tuple. *)
-let asg_of_tuple struc vars tuple =
- let els = Set (Elems.cardinal (Structure.elems struc),
- (Structure.elems struc)) in
- assignments_of_list (ref els) (Array.of_list vars) [tuple]
-
(* Evaluate real expressions. Result is represented as assignments with
real-valued polynomials using variable [rvar] to represent [expr].
We assume that [rvar] does not occur in [expr]. *)
@@ -456,7 +447,8 @@
let tps = tuples (Structure.elems struc)
(List.map var_str all_vs) asg_gd in
let add_val acc tp =
- let tp_asg = asg_of_tuple struc all_vs tp in
+ let tp_asg = assignments_of_list
+ (set_to_set_list(Structure.elems struc))(Array.of_list all_vs) [tp] in
acc +. (get_real_val solver tp_asg r struc) in
List.fold_left add_val 0. tps
| _ ->
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/Structure.mli 2011-10-13 12:28:21 UTC (rev 1593)
@@ -1,6 +1,6 @@
-(** Representing Structures *)
+(** Representing Relational Structures with Real-Valued Functions *)
-val debug_level : int ref
+(** {2 Modules used in structure representation.} *)
module IntMap : Map.S with type key = int (** Maps from int to 'alpha *)
@@ -10,31 +10,59 @@
val add_elems : int list -> Elems.t -> Elems.t
val elems_of_list : int list -> Elems.t
-module Tuples : Set.S with type elt = int array
+module Tuples : Set.S with type elt = int array (** Sets of tuples of ints *)
val add_tuples : int array list -> Tuples.t -> Tuples.t
val tuples_of_list : int array list -> Tuples.t
-(** No element is named by a decimal numeral other than its
- number. Elements not appearing in [names] are assumed to be named
- by their decimal numeral. *)
+(** {2 Structure type and basic getters.} *)
+
+(** Elements are internally represented by integers, bu the structure
+ also stores a naming of elements. No element is named by a decimal
+ numeral other than its number to prevent misunderstandings.
+ Elements not appearing in [names] are assumed to be named
+ by their decimal numeral. *)
type structure
+(** Comparison function for elements. *)
val compare_elems : int -> int -> int
+(** Comparison function for structures. *)
val compare : structure -> structure -> int
+(** Equality check on structures. *)
val equal : structure -> structure -> bool
+(** Return the list of elements in a structure. *)
val elements : structure -> int list
+
+(** Return the set of elements in a structure. *)
val elems : structure -> Elems.t
+
+(** Number of elements in a structure. *)
val nbr_elems : structure -> int
+(** Relations in the structure. *)
+val relations : structure -> Tuples.t StringMap.t
+
+(** Functions in the structure. *)
+val functions : structure -> (float IntMap.t) StringMap.t
+
+(** {3 Elements and their names.} *)
+
+(** The integer corresponding to a given element name. *)
val elem_nbr : structure -> string -> int
+
+(** The element name of an element (given by integers) *)
val elem_name : structure -> int -> string
+
+(** The map containing element names. *)
val names : structure -> int StringMap.t
+
+(** The inverse map of element names. *)
val inv_names : structure -> string IntMap.t
+
+(** Replace the names of elements by new maps. *)
val replace_names : structure -> int StringMap.t -> string IntMap.t -> structure
-val functions : structure -> (float IntMap.t) StringMap.t
-val relations : structure -> Tuples.t StringMap.t
+
(** {2 Basic helper functions} *)
(** Size of a relation, i.e. number of tuples in it. *)
@@ -251,3 +279,9 @@
?pos_initial:float * float ->
?pos_increment:float * float ->
?struc:structure -> string -> structure
+
+
+(** {2 Debugging} *)
+
+val debug_level : int ref
+
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/WL.ml 2011-10-13 12:28:21 UTC (rev 1593)
@@ -4,40 +4,35 @@
let variables = (Array.sub variable 0 (Array.length tuple)) in
let eval structure literal assignment =
(Solver.M.evaluate_partial structure assignment literal) in
- let set_listS = Assignments.Set (Structure.Elems.cardinal (Structure.elems structure),
- (Structure.elems structure)) in
- let assignment = Assignments.assignments_of_list (ref
- set_listS) variables [tuple] in
+ let elems = Assignments.set_to_set_list (Structure.elems structure) in
+ let assignment = Assignments.assignments_of_list elems variables [tuple] in
List.map
( fun literal ->
- ( if (( eval structure literal assignment )=AssignmentSet.Empty ) then (Not literal)
- else ( literal )))
+ ( if (( eval structure literal assignment )=AssignmentSet.Empty ) then
+ (Not literal)
+ else ( literal )))
listOfLiterals
let rec existential index_l structure tuple k n =
- match index_l with [element; index] ->
- let replace array i elem =
- let a = Array.copy array in
- if (i-1) < (Array.length tuple) then
- (a.(i-1) <- elem;
- a)
- else Array.append a [|elem|]
- in
- Ex ([`FO ("x" ^ string_of_int(index))],
- ntype structure (replace tuple index element) k n)
- | _ -> failwith "wrong index list"
+ match index_l with
+ | [element; index] ->
+ let substituted =
+ if (index-1) < (Array.length tuple) then
+ Aux.array_replace tuple index element
+ else Array.append (Array.copy tuple) [|element|] in
+ Ex ([`FO ("x" ^ string_of_int(index))],
+ ntype structure substituted k n)
+ | _ -> failwith "existential: wrong index list"
and universal index_l structure tuple k n =
- match index_l with [element; index] ->
- let replace array i elem =
- let a = Array.copy array in
- if (i-1) < (Array.length tuple) then
- (a.(i-1) <- elem;
- a)
- else Array.append a [|elem|]
- in
- ntype structure (replace tuple index element) k n
- | _ -> failwith "wrong index list"
+ match index_l with
+ | [element; index] ->
+ let substituted =
+ if (index-1) < (Array.length tuple) then
+ Aux.array_replace tuple index element
+ else Array.append (Array.copy tuple) [|element|] in
+ ntype structure substituted k n
+ | _ -> failwith "universal: wrong index list"
and ntype structure tuple k n =
let variables = List.map (fun i -> "x"^string_of_int(i))
Modified: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml 2011-10-13 10:10:15 UTC (rev 1592)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-13 12:28:21 UTC (rev 1593)
@@ -7,21 +7,20 @@
StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
let tests = "WL" >::: [
- "klist" >::
- (fun () ->
- assert_equal ~printer:(fun x -> string_of_int x)
- 6 (List.length (Aux.range 6));
- );
"atoms" >::
(fun () ->
let variables = ["x1";"x2"] in
let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
assert_equal ~printer:(fun x -> x)
- "(not R(x1, x1) and R(x1, x2) and not R(x2, x1) and not R(x2, x2))" (Formula.str (Formula.And (WL.atoms structure
- (FormulaOps.atoms (Structure.rel_signature structure) variables)
- [|2; 3|]
- (Array.of_list(List.map Formula.fo_var_of_string variables))
- )));
+ "(not R(x1, x1) and R(x1, x2) and not R(x2, x1) and not R(x2, x2))"
+ (Formula.str (Formula.And
+ (WL.atoms structure
+ (FormulaOps.atoms (Structure.rel_signature structure)
+ variables)
+ [|2; 3|]
+ (Array.of_list
+ (List.map Formula.fo_var_of_string variables))
+ )));
);
"ntype1" >::
( fun () ->
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <si...@us...> - 2011-10-13 13:36:24
|
Revision: 1594
http://toss.svn.sourceforge.net/toss/?rev=1594&view=rev
Author: simles
Date: 2011-10-13 13:36:15 +0000 (Thu, 13 Oct 2011)
Log Message:
-----------
updated ntype in WL, fixed index issue in Aux.array_replace
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Solver/WL.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-10-13 12:28:21 UTC (rev 1593)
+++ trunk/Toss/Formula/Aux.ml 2011-10-13 13:36:15 UTC (rev 1594)
@@ -548,7 +548,7 @@
with Not_found -> false
let array_replace array i elem =
- let a = Array.copy array in a.(i-1) <- elem; a
+ let a = Array.copy array in a.(i) <- elem; a
let neg f x = not (f x)
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-13 12:28:21 UTC (rev 1593)
+++ trunk/Toss/Solver/WL.ml 2011-10-13 13:36:15 UTC (rev 1594)
@@ -13,40 +13,61 @@
else ( literal )))
listOfLiterals
-let rec existential index_l structure tuple k n =
- match index_l with
- | [element; index] ->
- let substituted =
- if (index-1) < (Array.length tuple) then
- Aux.array_replace tuple index element
- else Array.append (Array.copy tuple) [|element|] in
- Ex ([`FO ("x" ^ string_of_int(index))],
- ntype structure substituted k n)
- | _ -> failwith "existential: wrong index list"
+let rec conj_b_ex_xmplus1_typesN structure tuple k n =
+ let elements = Structure.elements structure in
+ And(
+ List.map
+ (fun x -> Ex ( [`FO ("x"^(string_of_int((Array.length tuple)+1)))],
+ (ntype structure (Array.append tuple [|x|]) k n)))
+ elements)
-and universal index_l structure tuple k n =
- match index_l with
- | [element; index] ->
- let substituted =
- if (index-1) < (Array.length tuple) then
- Aux.array_replace tuple index element
- else Array.append (Array.copy tuple) [|element|] in
- ntype structure substituted k n
- | _ -> failwith "universal: wrong index list"
+and all_xmplus1_disj_b_typesN structure tuple k n =
+ let elements = Structure.elements structure in
+ All ([`FO ("x"^(string_of_int((Array.length tuple)+1)))],
+ ( Or
+ (List.map
+ (fun x -> (ntype structure (Array.append tuple [|x|]) k n))
+ elements ) ))
+and conj_b_ex_xi_typesN_replace_ai_by_b structure tuple k n i =
+ let elements = Structure.elements structure in
+ let substituted e = (Aux.array_replace tuple (i-1) e) in
+ And(
+ List.map
+ (fun x-> Ex( [`FO ("x"^(string_of_int i))],
+ (ntype structure (substituted x) k n)))
+ elements)
+
+and all_xi_disj_b_typesN_replace_ai_by_b structure tuple k n i=
+ let elements = Structure.elements structure in
+ let substituted e = (Aux.array_replace tuple (i-1) e) in
+ All ([`FO ("x"^(string_of_int i))],
+ ( Or
+ (List.map
+ (fun x -> (ntype structure (substituted x) k n))
+ elements )))
+
+
and ntype structure tuple k n =
+ let m = (Array.length tuple) in
let variables = List.map (fun i -> "x"^string_of_int(i))
(Aux.range k) in
let ats = FormulaOps.atoms (Structure.rel_signature structure)
- (Aux.take_n (Array.length tuple) variables) in
+ (Aux.take_n m variables) in
if n=0 then
Formula.flatten (And (atoms structure ats tuple (Array.of_list(List.map
fo_var_of_string variables))))
else
- let indices = Aux.product [Structure.elements structure; Aux.range k] in
- let formulas =
- List.map (fun x -> (
- existential x structure tuple k (n-1))) indices in
- let uformula =
- List.map (fun x -> (universal x structure tuple k (n-1))) indices in
- Formula.flatten (And (formulas))
+ if m < k then
+ Formula.flatten (And [ (ntype structure tuple k (n-1) );
+ (* conjunction b in A of ex x(m+1) (n-1)-type (tuple b) *)
+ (conj_b_ex_xmplus1_typesN structure tuple k (n-1));
+ (all_xmplus1_disj_b_typesN structure tuple k (n-1))])
+ else (*hard case, all variables already used*)
+ let indices = Aux.range k in
+ Formula.flatten (And [ (ntype structure tuple k (n-1));
+ (And ( (List.map
+ (fun i ->(And
+ [(conj_b_ex_xi_typesN_replace_ai_by_b structure tuple k (n-1) i);
+ (all_xi_disj_b_typesN_replace_ai_by_b structure tuple k (n-1) i)]))
+ indices )))])
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-17 22:44:47
|
Revision: 1599
http://toss.svn.sourceforge.net/toss/?rev=1599&view=rev
Author: lukaszkaiser
Date: 2011-10-17 22:44:40 +0000 (Mon, 17 Oct 2011)
Log Message:
-----------
Removing the almost unused pa_backtrace extension, some points in the code basics tutorial.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Makefile
trunk/Toss/Solver/Solver.mli
trunk/Toss/www/bin/hrefprocess
trunk/Toss/www/codebasics.xml
Removed Paths:
-------------
trunk/Toss/caml_extensions/pa_backtrace.ml
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/Arena/ArenaTest.ml 2011-10-17 22:44:40 UTC (rev 1599)
@@ -50,7 +50,7 @@
);
"simple parsing and printing" >::
- (fun () -> backtrace (
+ (fun () ->
let s = "PLAYERS white, black
RULE finish: [ | R(a, b) | ] -> [ | R(a, c); R(c, b) | ] emb R
with [a<-a, b<-b]
@@ -109,10 +109,10 @@
assert_equal ~printer:(fun x->x) ~msg:"equational style"
res2 (Arena.sprint_state gs);
- ));
+ );
"setting states from examples dir" >::
- (fun () -> backtrace (
+ (fun () ->
(* skip_if true "Change to simpler and stable example."; *)
let fname = "./examples/rewriting_example.toss" in
let file = open_in fname in
@@ -123,8 +123,7 @@
Arena.handle_request gs (req_of_str "GET STATE") in
assert_equal ~msg:("Set "^fname) ~printer:(fun x->x)
contents msg;
- ));
-
+ );
]
let a =
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2011-10-17 22:44:40 UTC (rev 1599)
@@ -84,7 +84,7 @@
);
"rewrite" >::
- (fun () -> backtrace (
+ (fun () ->
let dr =
"[| P { (a) } | ] -> [| P:1{}; Q { (b) } | ] emb P with [b<-a]" in
let signat = ["P", 1; "Q", 1] in
@@ -100,7 +100,6 @@
assert_equal ~printer:(fun x->x)
"[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]"
(remove_insignificant_digits (Structure.str res));
- )
);
"deterministic dynamics" >::
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/Makefile 2011-10-17 22:44:40 UTC (rev 1599)
@@ -29,18 +29,14 @@
ocamlc -I +camlp4 -pp "camlp4o pa_extend.cmo q_MLast.cmo" \
-c caml_extensions/pa_let_try.ml
-caml_extensions/pa_backtrace.cmo: caml_extensions/pa_backtrace.ml
- ocamlc -I +camlp4 -pp "camlp4o pa_extend.cmo q_MLast.cmo" \
- -c caml_extensions/pa_backtrace.ml
-
# -------- MAIN OCAMLBUILD PART --------
OCB_LFLAG=-lflags -I,+oUnit,-I,+sqlite3,-I,+site-lib/oUnit,-I,+site-lib/sqlite3
OCB_LFLAGBT=-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_LIB=-libs str,nums,unix,oUnit,sqlite3
-OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_backtrace.cmo"
+OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
OCAMLBUILDBT=ocamlbuild -log build.log -j 8 menhir ../menhir_conf $(OCB_PP) \
@@ -57,19 +53,16 @@
ServerINC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP
.INC=Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP,Server
-%.native: %.ml \
- caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo
+%.native: %.ml caml_extensions/pa_let_try.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-%.p.native: %.ml \
- caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo
+%.p.native: %.ml caml_extensions/pa_let_try.cmo
$(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@
-%.d.byte: %.ml \
- caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo
+%.d.byte: %.ml caml_extensions/pa_let_try.cmo
$(OCAMLBUILDBT) -Is $($(subst /,INC,$(dir $@))) $@
-doc: caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo
+doc: caml_extensions/pa_let_try.cmo
$(OCAMLBUILDNOPP) -Is +oUnit,+sqlite3,$(.INC) Toss.docdir/index.html
make -C www code_doc_link
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/Solver/Solver.mli 2011-10-17 22:44:40 UTC (rev 1599)
@@ -28,6 +28,7 @@
(** Set timeout function. *)
val set_timeout : (unit -> bool) -> unit
+
(** Clear timeout function. *)
val clear_timeout : unit -> unit
end
Deleted: trunk/Toss/caml_extensions/pa_backtrace.ml
===================================================================
--- trunk/Toss/caml_extensions/pa_backtrace.ml 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/caml_extensions/pa_backtrace.ml 2011-10-17 22:44:40 UTC (rev 1599)
@@ -1,31 +0,0 @@
-open Camlp4
-
-module Id : Sig.Id =
-struct
- let name = "pa_backtrace"
- let version = "0.1"
-end
-
-module Make (Syntax : Sig.Camlp4Syntax) =
-struct
- open Sig
- include Syntax
-
- EXTEND Gram
- expr: LEVEL "top" [
- [ "backtrace"; "("; e = expr ; ")" ->
- <:expr< (try $e$ with exn ->
- ( print_endline "Backtracing exception:";
- List.iter print_endline
- (Str.split (Str.regexp_string "\\\\n") (Printexc.to_string exn));
- print_endline "Exception backtrace:";
- List.iter print_endline
- (Str.split (Str.regexp_string "\\\\n") (Printexc.get_backtrace ()));
- raise exn )
- ) >>
- ]
- ];
- END
-end
-
-module M = Register.OCamlSyntaxExtension(Id)(Make)
Modified: trunk/Toss/www/bin/hrefprocess
===================================================================
--- trunk/Toss/www/bin/hrefprocess 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/www/bin/hrefprocess 2011-10-17 22:44:40 UTC (rev 1599)
@@ -4,13 +4,5 @@
sed 's&href="/\([^"]*\)"&href="'$1'/\1"&g' |\
sed '/href="http/!s&href="\([^"]*\)/"&href="\1/index.html.'$2'"&g' |\
sed '/href="http/!s&href="\([^"]*\)\.html"&href="\1.html.'$2'"&g' |\
-#
-# delete xmlns-attributes
-#
-# COMMENTING THIS OUT FOR NOW - I DO NOT UNDERSTAND WHY WE DID THIS?
-#
-#sed 's/<html xmlns/<html xmlnamespace/' |\
-#sed 's& xmlns\(:[^=]*\)\?="[^"]*"&&g' |\
-#sed 's/<html xmlnamespace/<html xmlns/' |\
-#sed 's/<script \([^>]*\)\/>/<script \1><\/script>/g'
+sed '/href="http/!s&href="code_doc\([^"]*\)\.html.\([a-z]*\)"&href="code_doc\1.html"&g' |\
sed ''
Modified: trunk/Toss/www/codebasics.xml
===================================================================
--- trunk/Toss/www/codebasics.xml 2011-10-17 12:11:04 UTC (rev 1598)
+++ trunk/Toss/www/codebasics.xml 2011-10-17 22:44:40 UTC (rev 1599)
@@ -12,16 +12,182 @@
<link id="develop" href="/develop.html">Develop Toss</link>
</history>
+ <section title="What's in the Directories?">
+ Here are the main directories of Toss source code, in order of
+ dependency, i.e. the first one listed does not depend on anything else,
+ and the last one contains the main executable and uses all previous ones.
+ <itemize>
+ <item><em>Formula</em> contains the type definition for formulas and
+ functions which operate on formulas only — substitutions for
+ variables, normal forms, simplifications, parsing and printing.
+ We also keep the module <em>Aux</em>, with many useful auxiliary
+ functions, in this directory.
+ </item>
+ <item><em>Solver</em> directory contains type definitions for structures,
+ variable assignments to structure elements, and the solver module for
+ calculating the assignments which satisfy a formula on
+ a structure.
+ </item>
+ <item><em>Arena</em> is the directory in which we define structure
+ rewriting games — discrete and continuous rewriting rules first,
+ and finally the whole games in the <em>Arena</em> module.
+ Discrete rule application is handled in the <em>DiscreteRule</em> module
+ by translating rules to formulas and using the solver. Continuous dynamics
+ is split into the <em>Term</em> module and <em>ContinuousRule</em>.
+ The parser for complete Toss games, i.e. the <em>.toss</em> files,
+ is defined in <em>ArenaParser.mly</em>.
+ </item>
+ <item><em>Play</em> contains the modules related to making Toss play
+ any defined game automatically — we generate heuristics in
+ the <em>Heuristic</em> module and use <em>GameTree</em> to implement
+ a search to finally <em>Play</em>.
+ </item>
+ <item><em>GGP</em> is a directory devoted to translating games in the GDL
+ language (Game Description Language) to the Toss format. We implement
+ GDL parsing, basic operations, stepwise translation and finally some
+ simplification of the resulting games. There are also tests in the
+ <em>GGP/examples</em> sub-directory.
+ </item>
+ <item><em>Language</em> is not used for now, we keep it because we plan
+ to experiment with better syntax for Toss in the future.
+ </item>
+ <item><em>Server</em> contains the main executable of Toss (in the file
+ <em>Server.ml</em>) and the main request handler in the
+ <em>ReqHandler</em> module, with other files as needed
+ (e.g. database connection handler in <em>DB</em>). We also keep
+ the lists of all unit tests there, in <em>Server/Tests.ml</em>.
+ </item>
+ </itemize>
+ The command <em>make TossFullTest</em> runs all unit tests for all modules
+ from all directories. As this takes some time, we often execute only
+ a subset of fast-running tests by <em>make TossTest</em>.
+ </section>
- <section title="Simple Calls">
- What do we show here? Some code?
- <code name="Formula.ml">
-type formula =
- | Var of string
- | Not of formula
- | Or of formula * formula
- | And of formula * formula
+ <section title="Adding Your Module">
+ Code in Toss is organized in a way analogous to the one presented in
+ our <a href="ocaml.html">Mini OCaml Tutorial</a>. Thus, to start coding
+ new functions with Toss, you should add 3 Files: an <em>ml</em> file
+ with your functions, an <em>mli</em> file with the interface (and for
+ documentation) and an <em>...Test.ml</em> file with your calls and unit
+ tests. As described above, the directories are organized hierarchically,
+ so if you intend to only operate on formulas, you should add your module
+ to the <em>Formula</em> directory. If you want to be able to use all
+ functions of Toss (or just not worry about the dependencies for now),
+ add your module to the <em>Server</em> directory, which incldues all
+ other directories in its dependency list.<br/>
+ As a starting example, let's add a module that parses a formula and
+ a structure from strings and returns a print-out of the satisfying
+ assignments. Here is the interface (<em>mli</em> file) assuming we name
+ the module <em>MyModule</em> and put it is <em>Server</em> directory.
+ <code name="Server/MyModule.mli">
+(** This is just a sample module. *)
+
+(** Parse a formula and a structure and return the satisfying assignments. *)
+val show_satisfying : formula: string -> structure: string -> string
</code>
+ This function can be implemented as follows.
+ <code name="Server/MyModule.ml">
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+let structure_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
+let show_satisfying ~formula ~structure =
+ let (f, struc) = (formula_of_string formula, structure_of_string structure) in
+ AssignmentSet.str (Solver.M.evaluate struc f)
+ </code>
+ To test this function, we need to add a file with unit tests, e.g. this one.
+ <code name="Server/MyModuleTest.ml">
+open OUnit
+
+let tests = "MyModule" >::: [
+ "show_satisfying" >::
+ (fun () ->
+ assert_equal ~printer:(fun x -> x)
+ "???"
+ (MyModule.show_satisfying
+ ~structure:"[ | R { (a, b); (a, c) } | ]"
+ ~formula:"ex x R (x, y)");
+ );
+]
+ </code>
+ Note that, since we are not sure about the result of the call
+ yet, we left <em>???</em> as the expected value of this test — it
+ should fail and tell us the value returned by the program. But how do
+ we run the test? As described in the <a href="ocaml.html">Mini OCaml
+ Tutorial</a>, we do not run the tests separately but execute them all
+ from the main Toss file. To add <em>MyModuleTest.tests</em> to the list
+ of executed tests, edit the file <em>Server/Tests.ml</em> and add one line
+ after the <em>let server_tests = "Server"</em> line. This part should
+ now look as follows.
+ <code name="Server/Tests.ml">
+...
+let server_tests = "Server", [
+ "MyModuleTest", [MyModuleTest.tests];
+...
+ </code>
+ We can now compile and run the tests by running <em>make MyModuleTest</em>
+ from the <em>Server</em> directory, or <em>make Server/MyModuleTest</em>
+ from the main <em>Toss</em> directory.
+ <pre>
+~/Toss/Server$ make MyModuleTest
+~/Toss$ make Server/MyModuleTest
+ </pre>
+ Note that, in fact, it is the main <em>TossServer</em> file that is
+ executed, and an option specifies which test should be run. The result
+ is, as expected, a failure.
+ <pre>
+Failure: Toss:0:Server:0:MyModule:0:show_satisfying
+
+OUnit: expected: ?? but got: { y->2, y->3 }
+ </pre>
+ And indeed — the right assignment for the given formula on
+ the structure we entered is <em>y</em> equal to <em>2</em> or <em>3</em>,
+ so we can correct the test now.
+ <code name="Server/MyModuleTest.ml">
+open OUnit
+
+let tests = "MyModule" >::: [
+ "show_satisfying" >::
+ (fun () ->
+ assert_equal ~printer:(fun x -> x)
+ "{ y->2, y->3 }"
+ (MyModule.show_satisfying
+ ~structure:"[ | R { (a, b); (a, c) } | ]"
+ ~formula:"ex x R (x, y)");
+ );
+]
+ </code>
+ and check that the answer is correct.
+ <pre>
+~/Toss$ make Server/MyModuleTest
+ocamlbuild -log build.log -j 8 -menhir ../menhir_conf
+ -pp "camlp4o ../caml_extensions/pa_let_try.cmo" -libs str,nums,unix,oUnit,sqlite3
+ -cflags -I,+oUnit,-I,+sqlite3,-I,+site-lib/oUnit,-I,+site-lib/sqlite3,-g
+ -lflags -I,+oUnit,-I,+sqlite3,-I,+site-lib/oUnit,-I,+site-lib/sqlite3
+ -Is Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver,Arena,Play,GGP
+ Server/Server.native
+Finished, 336 targets (332 cached) in 00:00:02.
+cp _build/Server/Server.native TossServer
+OCAMLRUNPARAM=b; export OCAMLRUNPARAM; \
+ ./TossServer -fulltest Server/MyModuleTest
+.
+Ran: 1 tests in: 0.00 seconds.
+ </pre>
</section>
+ <section title="Example Toss Calls">
+ Already in the section above, we have shown how to call the
+ <a href="code_doc/FormulaParser.html">Formula Parser</a> to parse formulas
+ and the <a href="code_doc/StructureParser.html">Structure Parser</a> to
+ parse a structure. We called the
+ <a href="code_doc/Solver.M.html">Solver.M</a> module to evaluate the formula
+ (we call it <em>Solver.M</em> and not just <em>Solver</em> to make it easier
+ to substitute other solvers and experiment with different solving methods).
+ Finally, to print out the resulting set of assignments, we used the basic
+ <em>str</em> function from the
+ <a href="code_doc/AssignmentSet.html">Assignment Set</a> module.
+ </section>
+
</personal>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-18 14:30:38
|
Revision: 1600
http://toss.svn.sourceforge.net/toss/?rev=1600&view=rev
Author: lukaszkaiser
Date: 2011-10-18 14:30:27 +0000 (Tue, 18 Oct 2011)
Log Message:
-----------
First attempt to use WL in PictureTest.
Modified Paths:
--------------
trunk/Toss/Server/Picture.ml
trunk/Toss/Server/def_pics/Makefile
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml 2011-10-17 22:44:40 UTC (rev 1599)
+++ trunk/Toss/Server/Picture.ml 2011-10-18 14:30:27 UTC (rev 1600)
@@ -256,8 +256,8 @@
let crels = List.filter not_drel (Structure.rel_signature left) in
if !debug_level > 0 then Printf.printf "CRels %i\n%!" (List.length crels);
let tp = postp left crels delems in
- if !debug_level > 0 then
- Format.printf "@[%a@]@ \n%!" Formula.fprint (Formula.And tp);
+ if !debug_level > -1 then
+ Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And tp);
let cut s = List.fold_left Structure.del_elem s
(List.filter (fun e -> not (List.mem e delems)) (Structure.elements s)) in
(cut left, cut right, tp)
@@ -358,8 +358,11 @@
Formula.flatten (if ok f0 then f0 else if ok f1 then f1 else f) in
List.fold_left mini phi atoms in
let mw = List.map minimize w in
- if !debug_level > 0 then
- Format.printf "@[%a@]@ \n%!" Formula.fprint (Formula.And mw);
+ if !debug_level > -1 then
+ Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And (basic :: mw));
+ (*if !debug_level > -1 then
+ Format.eprintf "@[%a@]@ \n%!" Formula.fprint
+ (Aux.unsome (WL.distinguish_by_type ~qr:1 ~k:2 right wrong));*)
Formula.flatten (Formula.Ex (ex_vars, Formula.And (basic :: mw)))
)
Modified: trunk/Toss/Server/def_pics/Makefile
===================================================================
--- trunk/Toss/Server/def_pics/Makefile 2011-10-17 22:44:40 UTC (rev 1599)
+++ trunk/Toss/Server/def_pics/Makefile 2011-10-18 14:30:27 UTC (rev 1600)
@@ -15,6 +15,7 @@
Breakthrough09.ppm Breakthrough10.ppm Breakthrough11.ppm \
Breakthrough12.ppm BreakthroughWin100.ppm BreakthroughWin101.ppm \
BreakthroughWin200.ppm BreakthroughWin201.ppm
+ make -C ../.. Server/PictureTest.native
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../../PictureTest.native -tp \
-g Breakthrough | sed "s/P1/B/g" | sed "s/P2/W/g" > Breakthrough.toss
Modified: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml 2011-10-17 22:44:40 UTC (rev 1599)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-18 14:30:27 UTC (rev 1600)
@@ -86,5 +86,43 @@
not R(x1, x1) and not R(x1, x2) and not x1 = x2 and not R(x2, x2)))"
(WL.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
structure1 structure2);
+ let struc1 = struc_of_string "[ | | ] \"
+ ... ... ... ...
+ B.. W.. ... ...
+ ... ... ... ...
+ ...B ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+ ... ... ... ...
+ ...W ... ... ...
+\"" in
+ let struc2 = struc_of_string "[ | | ] \"
+ ... ... ... ...
+ B.. ... ... ...
+ ... ... ... ...
+ ...B ...W ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+ ... ... ... ...
+ ...W ... ... ...
+\"" in
+ formula_option_eq "None"
+ (WL.distinguish_by_type ~qr:1 ~k:1 struc1 struc2);
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-18 23:44:56
|
Revision: 1602
http://toss.svn.sourceforge.net/toss/?rev=1602&view=rev
Author: lukaszkaiser
Date: 2011-10-18 23:44:49 +0000 (Tue, 18 Oct 2011)
Log Message:
-----------
Corrections to WL and next steps in Picture integration tests.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Server/Picture.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-10-18 15:37:54 UTC (rev 1601)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-10-18 23:44:49 UTC (rev 1602)
@@ -12,7 +12,11 @@
(** Delete top-most quantification of [vs] in the formula. *)
val del_vars_quant : var list -> formula -> formula
+(** Rename quantified variables avoiding the ones from [avs],
+ and the above-quantified ones. Does not go into real_expr. *)
+val rename_quant_avoiding : var list -> formula -> formula
+
(** {2 Relation sign} *)
(** Find all positively and negatively occurring relations. *)
Modified: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml 2011-10-18 15:37:54 UTC (rev 1601)
+++ trunk/Toss/Server/Picture.ml 2011-10-18 23:44:49 UTC (rev 1602)
@@ -258,6 +258,12 @@
let tp = postp left crels delems in
if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And tp);
+ if !debug_level > -1 then (
+ let nofluent_left = Structure.clear_rels left (fun r -> List.mem r drels) in
+ let tbl = WL.all_ntypes_simplified nofluent_left 1 2 in
+ Format.eprintf "@[%a@]@ \n%!" Formula.fprint
+ (Hashtbl.find tbl (Array.of_list delems));
+ );
let cut s = List.fold_left Structure.del_elem s
(List.filter (fun e -> not (List.mem e delems)) (Structure.elements s)) in
(cut left, cut right, tp)
@@ -360,9 +366,9 @@
let mw = List.map minimize w in
if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And (basic :: mw));
- (*if !debug_level > -1 then
+ if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint
- (Aux.unsome (WL.distinguish_by_type ~qr:1 ~k:2 right wrong));*)
+ (Aux.unsome (WL.distinguish_by_type ~qr:1 ~k:2 right wrong));
Formula.flatten (Formula.Ex (ex_vars, Formula.And (basic :: mw)))
)
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-10-18 15:37:54 UTC (rev 1601)
+++ trunk/Toss/Server/Tests.ml 2011-10-18 23:44:49 UTC (rev 1602)
@@ -17,7 +17,7 @@
"AssignmentsTest", [AssignmentsTest.tests];
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
"ClassTest", [ClassTest.tests; ClassTest.bigtests];
- "WLTest", [WLTest.tests];
+ "WLTest", [WLTest.tests; WLTest.bigtests];
]
let arena_tests = "Arena", [
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-18 15:37:54 UTC (rev 1601)
+++ trunk/Toss/Solver/WL.ml 2011-10-18 23:44:49 UTC (rev 1602)
@@ -1,5 +1,39 @@
open Formula
+(* Given an array of lists, i.e. a.(i) is a list, find an array b of the same
+ size of sub-lists (b.(i) subset a.(i)) such that if there was an element
+ distinguishing a.(i) from a.(j) then one separates b.(i) from b.(j).
+ This can be done in many ways (is it NP-complete to get the shortest b?),
+ we remove common intersections and branch on [select]-ed elements.
+ To branches not containing the element append [neg] of the element. *)
+let min_select l =
+ match Aux.unique_sorted l with [] -> None | x -> Some (List.hd x)
+let rec separate ?(select = min_select) ?(neg = fun e -> []) a =
+ let no_intersect arr =
+ let sorted = Array.map Aux.unique_sorted arr in
+ let nonempty_intersect l1 l2 =
+ if l1 = [] then l2 else if l2 = [] then l1 else Aux.sorted_inter l1 l2 in
+ let inter = Array.fold_left nonempty_intersect sorted.(0) sorted in
+ Array.map (fun x -> Aux.list_diff x inter) arr in
+ let elems arr = List.concat (Array.to_list arr) in
+ if Array.length a = 0 then a else
+ let b = no_intersect a in
+ match select (elems b) with None -> b | Some e ->
+ let b0 = Array.map (fun l -> if List.mem e l then l else []) b in
+ let b1 = Array.map (fun l -> if List.mem e l then [] else l) b in
+ let (min0, min1) = (separate ~select ~neg b0, separate ~select ~neg b1) in
+ let c = Array.mapi (fun i _ -> if b.(i) = [] then [] else
+ if b0.(i) = [] then (neg e) @ min1.(i) else e :: min0.(i)) b in
+ Array.map Aux.unique_sorted c
+
+(* Call the separate function from above on an array of conjunctions. *)
+let separate_conjs conjs =
+ let select_f phis =
+ match List.sort Formula.compare phis with
+ | [] | [_] -> None | x::__ -> Some x in
+ separate ~select:select_f ~neg:(function Not f -> [f] | f -> [Not f]) conjs
+
+
(* Helper function: check if a formula holds for a tuple on a structure. *)
let check structure tuple variables formula =
let eval structure phi assignment =
@@ -26,8 +60,9 @@
(* The n-type from FO^k for the [tuple] in [structure]. *)
-let rec ntype structure tuple k n =
- let m = (Array.length tuple) in
+let rec ntype structure tuple k_in n =
+ let m = Array.length tuple in
+ let k = max k_in m in
let variables = (List.map (fun i -> "x"^string_of_int(i)) (Aux.range k)) in
if n=0 then
Formula.flatten_sort (And (atoms structure tuple (Array.of_list variables)))
@@ -80,95 +115,106 @@
| _ -> acc_types
-let atomsSimplified structure tuples variables =
+(* --- WITH SIMPLIFICATION --- *)
+
+let atoms_simplified structure tuples variables =
let tlist = Array.map (fun tuple ->
Aux.unique_sorted (atoms structure tuple variables)) tuples in
- let tlistIntersect = Array.fold_left
- Aux.sorted_inter (Array.get tlist 0) tlist in
- let tlistF = Array.map
- (fun x-> Aux.list_diff x tlistIntersect ) tlist in
- let tuplesTable = Hashtbl.create 1 in
+ let tlistF = separate_conjs tlist in
+ let tuplesTable = Hashtbl.create 7 in
Array.iteri (fun i tuple->
- Hashtbl.add tuplesTable tuple (And (tlistF.(i)))) tuples;
+ Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
+ ) tuples;
tuplesTable
let nextTypes structure tuples variables types =
let conjuncts tuple =
let indices = Aux.range (Array.length tuple) in
- let substituted i e = (Aux.array_replace tuple (i-1) e) in
+ let substituted i e = Aux.array_replace tuple (i-1) e in
+ let sorted tp = Array.of_list (Aux.unique_sorted (Array.to_list tp)) in
let conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i =
- Aux.unique_sorted (List.map (fun x ->
- Ex ([`FO ("x"^(string_of_int i))],
- (Hashtbl.find types (substituted i x)))
+ Aux.unique_sorted (Aux.map_some (fun x ->
+ let subst = substituted i x in
+ if Array.length (sorted subst) < Array.length tuple then None else
+ Some (Ex ([`FO ("x"^(string_of_int i))], (Hashtbl.find types subst)))
) (Structure.elements structure)) in
let all_xi_disj_b_typesN_replace_ai_by_b structure tuple i=
All ([`FO ("x"^(string_of_int i))],
- ( Or (Aux.unique_sorted(List.map (fun x ->
- (Hashtbl.find types (substituted i x))) (Structure.elements
- structure) )))) in
- Aux.unique_sorted
- ((Hashtbl.find types tuple)::
- (List.flatten (List.map (fun i ->
- (all_xi_disj_b_typesN_replace_ai_by_b structure tuple i)::
- (conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i))
- indices ))) in
- let tlist = Array.map (fun tuple ->
- Aux.unique_sorted (conjuncts tuple)) tuples in
- let tlistIntersect = Array.fold_left
- Aux.sorted_inter (Array.get tlist 0) tlist in
- let tlistF = Array.map
- (fun x-> Aux.list_diff x tlistIntersect ) tlist in
- let tuplesTable = Hashtbl.create 1 in
+ (Or (Aux.unique_sorted (Aux.map_some (
+ fun x ->
+ let subst = substituted i x in
+ if Array.length (sorted subst) < Array.length tuple then None
+ else Some (Hashtbl.find types (substituted i x))
+ ) (Structure.elements structure) )))) in
+ ((Hashtbl.find types tuple)::
+ (List.flatten (List.map (fun i ->
+ (all_xi_disj_b_typesN_replace_ai_by_b structure tuple i)::
+ (conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i)
+ ) indices ))) in
+ let tlist = Array.map conjuncts tuples in
+ let tlistF = separate_conjs tlist in
+ let tuplesTable = Hashtbl.create 7 in
Array.iteri (fun i tuple->
- Hashtbl.add tuplesTable tuple (And (tlistF.(i)))) tuples;
+ Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
+ ) tuples;
tuplesTable
-let rec ntypesSimplified ?(types=None) ?(tuples=None) ?(variables=None)
-?(current=None) structure n k =
- let tuples = match tuples with Some tp -> tp
- | None -> Array.of_list (List.map Array.of_list
- (Aux.all_ntuples (Structure.elements structure) k)) in
- let variables = match variables with Some x -> x
- | None -> (Array.map (fun i -> "x"^string_of_int(i)) (Array.of_list
- (Aux.range k))) in
- let types = match types with Some x -> x | None -> (atomsSimplified
- structure tuples variables) in
- match current with
- None -> ntypesSimplified
- ~types:(Some types)
- ~tuples:(Some tuples )
- ~variables:(Some variables)
- ~current:(Some 0) structure n k
- | Some x -> if x>= n then types
- else (ntypesSimplified
- ~types:(Some (nextTypes structure tuples variables types))
- ~tuples:(Some tuples)
- ~variables:(Some variables)
- ~current:(Some (x+1)) structure n k)
-
+let rec ntypesSimplified ?cur_types tuples variables structure n k =
+ let x, types = match cur_types with
+ | Some (step, typs) -> (step, typs)
+ | None -> (0, atoms_simplified structure tuples variables) in
+ if x >= n then types else
+ ntypesSimplified
+ ~cur_types:(x+1, nextTypes structure tuples variables types)
+ tuples variables structure n k
+let rec all_ntypes_simplified structure n k =
+ let rec no_rept l = List.length l = List.length (Aux.unique_sorted l) in
+ let tuples =
+ Array.of_list (List.map Array.of_list (List.filter no_rept (
+ Aux.all_ntuples (Structure.elements structure) k))) in
+ let variables =
+ Array.map (fun i -> "x"^string_of_int(i)) (Array.of_list (Aux.range k)) in
+ ntypesSimplified tuples variables structure n k
+
+(* Helper function: remove atoms from a formula if [cond] is still satisfied.
+ Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
+let rec greedy_remove cond phi =
+ let rec greedy_remove_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 -> Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
+ | Not f -> 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
+
+
let distinguish_by_type ?(skip_outer_exists=false) ~qr ~k struct1 struct2 =
- let makeList table =
- Hashtbl.fold (fun x y z -> [y]@z) table [] in
- let types1 = Aux.unique_sorted (makeList (ntypesSimplified struct1 qr k)) in
- let types2 = Aux.unique_sorted (makeList (ntypesSimplified struct2 qr k)) in
- if types1 = types2 then None else
- let diff1 = (List.filter (fun x -> not (List.mem x types2)) types1) in
- let dtype = if List.length diff1 > 0 then List.hd diff1 else
- List.hd (List.filter (fun x -> not (List.mem x types1)) types2) in
- let distinguishes f = (* check whether f distinguishes the two structures *)
- let (v1, v2) = (check struct1 [||] [||] f, check struct2 [||] [||] f) in
- (not v1 && v2) || (not v2 && v1) in
- let rec minimize acc = function (* greedy heuristic to minimize the type *)
- | [] -> acc | x :: xs ->
- if distinguishes (And (acc @ xs)) then
- minimize acc xs
- else minimize (x::acc) xs in
- let minimized_type = match dtype with
- | And fl -> And (minimize [] (List.rev fl))
- | phi -> phi in
- if skip_outer_exists then Some minimized_type else
- let fv = FormulaSubst.free_vars minimized_type in
- Some (Ex (List.sort Formula.compare_vars fv, minimized_type))
+ let listht table = Hashtbl.fold (fun x y z -> y :: z) table [] in
+ let types1= Aux.unique_sorted (listht (all_ntypes_simplified struct1 qr k)) in
+ let types2= Aux.unique_sorted (listht (all_ntypes_simplified struct2 qr k)) 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 distinguishes f = (* check whether f distinguishes the two structures *)
+ let f = And (f :: (all_diff (FormulaSubst.free_vars f))) in
+ let (v1, v2) = (check struct1 [||] [||] f, check struct2 [||] [||] f) in
+ (not v1 && v2) || (not v2 && v1) in
+ let phis = List.sort Formula.compare (Aux.unique_sorted (types1 @ types2)) in
+ try
+ let dtype = List.find distinguishes phis in
+ let mintp = greedy_remove distinguishes dtype in
+ let fv = FormulaSubst.free_vars dtype in
+ let t= FormulaOps.rename_quant_avoiding ((var_of_string "x0")::fv) mintp in
+ if skip_outer_exists then Some t else
+ Some (Ex (List.sort Formula.compare_vars fv, t))
+ with Not_found -> None
Modified: trunk/Toss/Solver/WL.mli
===================================================================
--- trunk/Toss/Solver/WL.mli 2011-10-18 15:37:54 UTC (rev 1601)
+++ trunk/Toss/Solver/WL.mli 2011-10-18 23:44:49 UTC (rev 1602)
@@ -1,5 +1,14 @@
(* The WL algorithm and related tests. *)
+(** Given an array of lists, i.e. a.(i) is a list, find an array b of the same
+ size of sub-lists (b.(i) subset a.(i)) such that if there was an element
+ distinguishing a.(i) from a.(j) then one separates b.(i) from b.(j).
+ This can be done in many ways (is it NP-complete to get the shortest b?),
+ we remove common intersections and branch on [select]-ed elements.
+ To branches not containing the element, we append [neg] of the elem. *)
+val separate: ?select: ('a list -> 'a option) -> ?neg: ('a -> 'a list) ->
+ 'a list array -> 'a list array
+
(** 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 -> string array ->
@@ -17,11 +26,7 @@
val distinguish_by_type: ?skip_outer_exists: bool -> qr: int -> k: int ->
Structure.structure -> Structure.structure -> Formula.formula option
-val atomsSimplified: Structure.structure -> int array array -> string array -> (int array,Formula.formula) Hashtbl.t
+val atoms_simplified: Structure.structure -> int array array -> string array -> (int array,Formula.formula) Hashtbl.t
-val ntypesSimplified: ?types:(int array, Formula.formula) Hashtbl.t option ->
- ?tuples:int array array option ->
- ?variables:string array option ->
- ?current:int option ->
- Structure.structure ->
- int -> int -> (int array, Formula.formula) Hashtbl.t
+val all_ntypes_simplified: Structure.structure -> int -> int ->
+ (int array, Formula.formula) Hashtbl.t
Modified: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml 2011-10-18 15:37:54 UTC (rev 1601)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-18 23:44:49 UTC (rev 1602)
@@ -26,8 +26,37 @@
| 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 = "WL" >::: [
+ "separate" >::
+ (fun () ->
+ let str = array_list_str string_of_int in
+ assert_equal ~printer:str [| [1]; [] |]
+ (WL.separate [| [1;2]; [2;3] |]);
+ assert_equal ~printer:str [| [1]; [-1] |]
+ (WL.separate ~neg:(fun e -> [-e]) [| [1;2]; [2;3] |]);
+ assert_equal ~printer:str [| []; [-3]; [-1] |]
+ (WL.separate [| [1;2;3;4]; [1;2;-3;4]; [-1;2;3;4] |]);
+ assert_equal ~printer:str [| [1;3]; [-3]; [-1;3] |]
+ (WL.separate ~neg:(fun e-> [-e]) [|[1;2;3;4]; [1;2;-3;4]; [-1;2;3;4]|]);
+ );
+
"atoms" >::
(fun () ->
let variables = ["x1";"x2"] in
@@ -40,6 +69,8 @@
"ntype" >::
( fun () ->
let structure = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_eq ("R(x1,x2) and not R(x1,x1) and not x1=x2 and not R(x2, x1)" ^
+ " and not R(x2, x2)") (WL.ntype structure [|1;2|] 1 0);
formula_eq
"(R(x1, x2) and not R(x1, x1) and not x1 = x2 and not R(x2, x1) and not R(x2, x2) and
ex x1 (R(x1, x2) and not R(x1, x1) and not x1 = x2 and not R(x2, x1) and not R(x2, x2)) and
@@ -72,20 +103,46 @@
(WL.all_ntypes_ktuples structure 0 2);
);
- "distinguish" >::
+ "atoms_simplified" >::
(fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ hashtbl_eq structure
+ [ ([|1;2|], "R(x1, x2)"); ([|3;3|], "not R(x1, x2)") ]
+ (WL.atoms_simplified structure [| [| 1;2 |]; [|3;3|] |] [|"x1";"x2"|]);
+ );
+
+ "all_ntypes_simplified" >::
+ (fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ hashtbl_eq structure
+ [ ([|1;2|], "R(x1, x2)");
+ ([|2;1|], "R(x2, x1) and not R(x1, x2)");
+ ([|1;3|], "not R(x1, x2) and not R(x2, x1)");
+ ([|3;1|], "not R(x1, x2) and not R(x2, x1)");
+ ([|2;3|], "R(x1, x2)");
+ ([|3;2|], "R(x2, x1) and not R(x1, x2)")]
+ (WL.all_ntypes_simplified structure 0 2);
+ );
+
+ "distinguish_by_type" >::
+ (fun () ->
let structure1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let structure2 = (struc_of_string "[ | R { (1, 2) } | ]") in
formula_option_eq "None"
(WL.distinguish_by_type ~qr:2 ~k:1 structure1 structure2);
- formula_option_eq "ex x1, x2 (not R(x1, x2) and not x1 = x2 and not R(x2, x1))"
+ formula_option_eq "ex x1, x2 (not R(x1, x2) and not R(x2, x1))"
(WL.distinguish_by_type ~qr:0 ~k:2 structure1 structure2);
formula_option_eq "ex x1, x2, x3 (R(x1, x2) and R(x2, x3))"
(WL.distinguish_by_type ~qr:0 ~k:3 structure1 structure2);
- formula_option_eq "(R(x1, x2) and not x1 = x2 and not R(x2, x1) and
- ex x1 (R(x2, x1) and not R(x1, x2) and not x1 = x2))"
+ formula_option_eq "not R(x1, x2) and not R(x2, x1)"
(WL.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
structure1 structure2);
+ );
+]
+
+let bigtests = "WLBig" >::: [
+ "distinguish_by_type" >::
+ (fun () ->
let struc1 = struc_of_string "[ | | ] \"
... ... ... ...
B.. W.. ... ...
@@ -122,34 +179,8 @@
... ... ... ...
...W ... ... ...
\"" in
- formula_option_eq "None"
- (WL.distinguish_by_type ~qr:1 ~k:2 struc1 struc2);
+ formula_option_eq "W(x1) and not ex x3 C(x1, x3)"
+ (WL.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
+ struc1 struc2);
);
-
- (*"atomsSimplified" >::
- (fun () ->
- let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
-
- Hashtbl.iter
- (fun x z->
- print_endline (Array.fold_left (fun y r ->
- y^""^(string_of_int r)) "" x);
- print_endline (Formula.sprint z) ;
- print_endline "" )
- (WL.atomsSimplified structure [| [| 1;2 |]; [|3;3|]|] [|"x1";"x2"|]);
- assert_equal "a" "a";
- );*)
-
- "ntypesSimplified" >::
- (fun () ->
- let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
- (*Hashtbl.iter
- (fun x z->
- print_endline (Array.fold_left (fun y r ->
- y^""^(string_of_int r)) "" x);
- print_endline (Formula.sprint z) ;
- print_endline "" )
- (WL.ntypesSimplified structure 1 2);*)
- assert_equal "a" "a";
- );
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-19 15:46:23
|
Revision: 1603
http://toss.svn.sourceforge.net/toss/?rev=1603&view=rev
Author: lukaszkaiser
Date: 2011-10-19 15:46:13 +0000 (Wed, 19 Oct 2011)
Log Message:
-----------
WL corrections.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-10-18 23:44:49 UTC (rev 1602)
+++ trunk/Toss/Formula/Aux.ml 2011-10-19 15:46:13 UTC (rev 1603)
@@ -324,12 +324,12 @@
List.rev (aux (List.rev l2) l1)
(* Not tail-recursive. *)
-let unique_sorted l =
+let unique_sorted ?(cmp = Pervasives.compare) l =
let rec idemp = function
- | e1::(e2::_ as tl) when e1 = e2 -> idemp tl
+ | e1::(e2::_ as tl) when cmp e1 e2 = 0 -> idemp tl
| e::tl -> e::idemp tl
| [] -> [] in
- idemp (List.sort Pervasives.compare l)
+ idemp (List.sort cmp l)
let unique_append l1 l2 =
List.fold_left (fun l2 e ->
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-10-18 23:44:49 UTC (rev 1602)
+++ trunk/Toss/Formula/Aux.mli 2011-10-19 15:46:13 UTC (rev 1603)
@@ -195,7 +195,7 @@
(** Return the list of structurally unique elements, in order sorted
by {!Pervasives.compare}. Not tail-recursive. *)
-val unique_sorted : 'a list -> 'a list
+val unique_sorted : ?cmp: ('a -> 'a -> int) -> 'a list -> 'a list
(** [unique_append l1 l2] appends elements not occurring in [l2] to
it, without repeating elements. *)
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-18 23:44:49 UTC (rev 1602)
+++ trunk/Toss/Solver/WL.ml 2011-10-19 15:46:13 UTC (rev 1603)
@@ -4,34 +4,34 @@
size of sub-lists (b.(i) subset a.(i)) such that if there was an element
distinguishing a.(i) from a.(j) then one separates b.(i) from b.(j).
This can be done in many ways (is it NP-complete to get the shortest b?),
- we remove common intersections and branch on [select]-ed elements.
- To branches not containing the element append [neg] of the element. *)
-let min_select l =
- match Aux.unique_sorted l with [] -> None | x -> Some (List.hd x)
-let rec separate ?(select = min_select) ?(neg = fun e -> []) a =
+ we remove the intersection and after this greedily unused elements if
+ the option [greedy_cleanup] is set. *)
+let rec separate ?(cmp = Pervasives.compare) ?(greedy_cleanup = true) a =
+ let nonempty_intersect l1 l2 =
+ if l1 = [] then l2 else if l2 = [] then l1 else Aux.sorted_inter l1 l2 in
let no_intersect arr =
let sorted = Array.map Aux.unique_sorted arr in
- let nonempty_intersect l1 l2 =
- if l1 = [] then l2 else if l2 = [] then l1 else Aux.sorted_inter l1 l2 in
let inter = Array.fold_left nonempty_intersect sorted.(0) sorted in
Array.map (fun x -> Aux.list_diff x inter) arr in
- let elems arr = List.concat (Array.to_list arr) in
+ let cleanup arr =
+ let suffices orig l i = Aux.array_for_alli (
+ fun j lst -> j = i || lst = orig ||
+ List.exists (fun x -> not (List.mem x a.(j))) l) arr in
+ let rec filter orig i acc rest =
+ if rest = [] || suffices orig acc i then acc else
+ filter orig i ((List.hd rest)::acc) (List.tl rest) in
+ Array.mapi (fun i l -> filter l i [] (List.sort cmp l)) arr in
+ let rec rec_cleanup arr =
+ let new_arr = cleanup arr in
+ if new_arr = arr then arr else rec_cleanup new_arr in
if Array.length a = 0 then a else
let b = no_intersect a in
- match select (elems b) with None -> b | Some e ->
- let b0 = Array.map (fun l -> if List.mem e l then l else []) b in
- let b1 = Array.map (fun l -> if List.mem e l then [] else l) b in
- let (min0, min1) = (separate ~select ~neg b0, separate ~select ~neg b1) in
- let c = Array.mapi (fun i _ -> if b.(i) = [] then [] else
- if b0.(i) = [] then (neg e) @ min1.(i) else e :: min0.(i)) b in
- Array.map Aux.unique_sorted c
+ if greedy_cleanup then rec_cleanup b else b
+
(* Call the separate function from above on an array of conjunctions. *)
-let separate_conjs conjs =
- let select_f phis =
- match List.sort Formula.compare phis with
- | [] | [_] -> None | x::__ -> Some x in
- separate ~select:select_f ~neg:(function Not f -> [f] | f -> [Not f]) conjs
+let separate_conjs greedy conjs =
+ separate ~cmp:Formula.compare ~greedy_cleanup:greedy conjs
(* Helper function: check if a formula holds for a tuple on a structure. *)
@@ -120,7 +120,7 @@
let atoms_simplified structure tuples variables =
let tlist = Array.map (fun tuple ->
Aux.unique_sorted (atoms structure tuple variables)) tuples in
- let tlistF = separate_conjs tlist in
+ let tlistF = separate_conjs (Array.length tuples < 80) tlist in
let tuplesTable = Hashtbl.create 7 in
Array.iteri (fun i tuple->
Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
@@ -132,15 +132,21 @@
let indices = Aux.range (Array.length tuple) in
let substituted i e = Aux.array_replace tuple (i-1) e in
let sorted tp = Array.of_list (Aux.unique_sorted (Array.to_list tp)) in
+ let all_diff i = Array.to_list (Aux.array_mapi_some (
+ fun j v -> if j = i then None else
+ Some (Not (Eq (fo_var_of_string variables.(i), fo_var_of_string variables.(j))))
+ ) variables) in
+ let all_eq i = List.map (function Not f-> f | _-> failwith "neq") (all_diff i) in
let conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i =
Aux.unique_sorted (Aux.map_some (fun x ->
let subst = substituted i x in
if Array.length (sorted subst) < Array.length tuple then None else
- Some (Ex ([`FO ("x"^(string_of_int i))], (Hashtbl.find types subst)))
+ Some (Ex ([`FO ("x"^(string_of_int i))],
+ And ( (Hashtbl.find types subst) :: (all_diff (i-1)))))
) (Structure.elements structure)) in
let all_xi_disj_b_typesN_replace_ai_by_b structure tuple i=
All ([`FO ("x"^(string_of_int i))],
- (Or (Aux.unique_sorted (Aux.map_some (
+ (Or ((all_eq (i-1)) @ Aux.unique_sorted (Aux.map_some (
fun x ->
let subst = substituted i x in
if Array.length (sorted subst) < Array.length tuple then None
@@ -152,7 +158,7 @@
(conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i)
) indices ))) in
let tlist = Array.map conjuncts tuples in
- let tlistF = separate_conjs tlist in
+ let tlistF = separate_conjs false tlist in
let tuplesTable = Hashtbl.create 7 in
Array.iteri (fun i tuple->
Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
@@ -218,3 +224,10 @@
with Not_found -> None
+let distinguish ?(skip_outer_exists=false) struc1 struc2 =
+ let rec diff qr k =
+ if qr > k then diff 0 (k+1) else
+ match distinguish_by_type ~skip_outer_exists ~qr ~k struc1 struc2 with
+ | Some f -> f
+ | None -> diff (qr+1) k in
+ diff 0 1
Modified: trunk/Toss/Solver/WL.mli
===================================================================
--- trunk/Toss/Solver/WL.mli 2011-10-18 23:44:49 UTC (rev 1602)
+++ trunk/Toss/Solver/WL.mli 2011-10-19 15:46:13 UTC (rev 1603)
@@ -1,12 +1,12 @@
-(* The WL algorithm and related tests. *)
+(** The WL algorithm and related tests. *)
(** Given an array of lists, i.e. a.(i) is a list, find an array b of the same
size of sub-lists (b.(i) subset a.(i)) such that if there was an element
distinguishing a.(i) from a.(j) then one separates b.(i) from b.(j).
This can be done in many ways (is it NP-complete to get the shortest b?),
- we remove common intersections and branch on [select]-ed elements.
- To branches not containing the element, we append [neg] of the elem. *)
-val separate: ?select: ('a list -> 'a option) -> ?neg: ('a -> 'a list) ->
+ we remove the intersection and after this greedily unused elements if
+ the option [greedy_cleanup] is set. *)
+val separate: ?cmp: ('a -> 'a -> int) -> ?greedy_cleanup: bool ->
'a list array -> 'a list array
(** The list of literals which hold for a tuple on a structure,
@@ -30,3 +30,7 @@
val all_ntypes_simplified: Structure.structure -> int -> int ->
(int array, Formula.formula) Hashtbl.t
+
+(** Distinguish two structures. *)
+val distinguish: ?skip_outer_exists: bool ->
+ Structure.structure -> Structure.structure -> Formula.formula
Modified: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml 2011-10-18 23:44:49 UTC (rev 1602)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-19 15:46:13 UTC (rev 1603)
@@ -47,14 +47,14 @@
"separate" >::
(fun () ->
let str = array_list_str string_of_int in
- assert_equal ~printer:str [| [1]; [] |]
+ assert_equal ~printer:str [| [1]; [3] |]
(WL.separate [| [1;2]; [2;3] |]);
- assert_equal ~printer:str [| [1]; [-1] |]
- (WL.separate ~neg:(fun e -> [-e]) [| [1;2]; [2;3] |]);
- assert_equal ~printer:str [| []; [-3]; [-1] |]
+ assert_equal ~printer:str [| [1]; [3] |]
+ (WL.separate [| [1;2]; [2;3] |]);
+ assert_equal ~printer:str [| [3;1]; [-3]; [-1] |]
(WL.separate [| [1;2;3;4]; [1;2;-3;4]; [-1;2;3;4] |]);
- assert_equal ~printer:str [| [1;3]; [-3]; [-1;3] |]
- (WL.separate ~neg:(fun e-> [-e]) [|[1;2;3;4]; [1;2;-3;4]; [-1;2;3;4]|]);
+ assert_equal ~printer:str [| [3;1]; [-3]; [-1] |]
+ (WL.separate [|[1;2;3;4]; [1;2;-3;4]; [-1;2;3;4]|]);
);
"atoms" >::
@@ -107,20 +107,25 @@
(fun () ->
let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
hashtbl_eq structure
- [ ([|1;2|], "R(x1, x2)"); ([|3;3|], "not R(x1, x2)") ]
+ [ ([|1;2|], "R(x1, x2)"); ([|3;3|], "x1 = x2") ]
(WL.atoms_simplified structure [| [| 1;2 |]; [|3;3|] |] [|"x1";"x2"|]);
);
"all_ntypes_simplified" >::
(fun () ->
+ let structure = (struc_of_string "[ | R { (1, 2) } | ]") in
+ hashtbl_eq structure
+ [ ([|1;2|], "R(x1, x2)");
+ ([|2;1|], "R(x2, x1)")]
+ (WL.all_ntypes_simplified structure 0 2);
let structure = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
hashtbl_eq structure
[ ([|1;2|], "R(x1, x2)");
- ([|2;1|], "R(x2, x1) and not R(x1, x2)");
+ ([|2;1|], "R(x2, x1)");
([|1;3|], "not R(x1, x2) and not R(x2, x1)");
([|3;1|], "not R(x1, x2) and not R(x2, x1)");
([|2;3|], "R(x1, x2)");
- ([|3;2|], "R(x2, x1) and not R(x1, x2)")]
+ ([|3;2|], "R(x2, x1)")]
(WL.all_ntypes_simplified structure 0 2);
);
@@ -137,17 +142,30 @@
formula_option_eq "not R(x1, x2) and not R(x2, x1)"
(WL.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
structure1 structure2);
+
+ let structure1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
+ let structure2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
+ formula_option_eq "ex x P(x)"
+ (WL.distinguish_by_type ~qr:0 ~k:1 structure1 structure2);
);
+
+ "distinguish" >::
+ (fun () ->
+ let structure1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ let structure2 = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_eq "ex x1, x2 (not R(x1, x2) and not R(x2, x1))"
+ (WL.distinguish structure1 structure2);
+ );
]
let bigtests = "WLBig" >::: [
- "distinguish_by_type" >::
+ "distinguish" >::
(fun () ->
let struc1 = struc_of_string "[ | | ] \"
... ... ... ...
- B.. W.. ... ...
+ ... W.. ...B ...
... ... ... ...
- ...B ... ... ...
+ ... ... ... B..
... ... ... ...
... ... ... ...
... ... ... ...
@@ -163,9 +181,9 @@
\"" in
let struc2 = struc_of_string "[ | | ] \"
... ... ... ...
- B.. ... ... ...
+ ... ... ...B ...
... ... ... ...
- ...B ...W ... ...
+ ... ...W ... B..
... ... ... ...
... ... ... ...
... ... ... ...
@@ -179,8 +197,7 @@
... ... ... ...
...W ... ... ...
\"" in
- formula_option_eq "W(x1) and not ex x3 C(x1, x3)"
- (WL.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
- struc1 struc2);
+ formula_eq "W(x2) and all x3 not C(x2, x3)"
+ (WL.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-10-19 17:23:38
|
Revision: 1604
http://toss.svn.sourceforge.net/toss/?rev=1604&view=rev
Author: lukaszkaiser
Date: 2011-10-19 17:23:31 +0000 (Wed, 19 Oct 2011)
Log Message:
-----------
WL for sets of structures.
Modified Paths:
--------------
trunk/Toss/Server/Picture.ml
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml 2011-10-19 15:46:13 UTC (rev 1603)
+++ trunk/Toss/Server/Picture.ml 2011-10-19 17:23:31 UTC (rev 1604)
@@ -368,7 +368,7 @@
Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And (basic :: mw));
if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint
- (Aux.unsome (WL.distinguish_by_type ~qr:1 ~k:2 right wrong));
+ (Aux.unsome (WL.distinguish_by_type ~qr:1 ~k:2 [right] [wrong]));
Formula.flatten (Formula.Ex (ex_vars, Formula.And (basic :: mw)))
)
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-19 15:46:13 UTC (rev 1603)
+++ trunk/Toss/Solver/WL.ml 2011-10-19 17:23:31 UTC (rev 1604)
@@ -202,32 +202,40 @@
| phi -> phi
-let distinguish_by_type ?(skip_outer_exists=false) ~qr ~k struct1 struct2 =
+let distinguish_by_type ?(skip_outer_exists=false) ~qr ~k sPos sNeg =
let listht table = Hashtbl.fold (fun x y z -> y :: z) table [] in
- let types1= Aux.unique_sorted (listht (all_ntypes_simplified struct1 qr k)) in
- let types2= Aux.unique_sorted (listht (all_ntypes_simplified struct2 qr k)) in
+ let types s = Aux.unique_sorted (listht (all_ntypes_simplified 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 distinguishes f = (* check whether f distinguishes the two structures *)
+ let fails_neg f = (* check whether f fails on all negative structs *)
let f = And (f :: (all_diff (FormulaSubst.free_vars f))) in
- let (v1, v2) = (check struct1 [||] [||] f, check struct2 [||] [||] f) in
- (not v1 && v2) || (not v2 && v1) in
- let phis = List.sort Formula.compare (Aux.unique_sorted (types1 @ types2)) in
- try
- let dtype = List.find distinguishes phis in
- let mintp = greedy_remove distinguishes dtype in
- let fv = FormulaSubst.free_vars dtype 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 [||] [||] f) sPos in
+ let candidates = List.rev_append (List.concat tpPos)
+ (List.map (fun f -> Not f) (List.concat tpNeg)) 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 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
+ if dtypes = [] then None else
+ let is_ok f = fails_neg f && succ_pos [f] in
+ let mintp = greedy_remove is_ok (Or dtypes) in
+ let fv = FormulaSubst.free_vars (Or dtypes) in
let t= FormulaOps.rename_quant_avoiding ((var_of_string "x0")::fv) mintp in
if skip_outer_exists then Some t else
Some (Ex (List.sort Formula.compare_vars fv, t))
- with Not_found -> None
-
-let distinguish ?(skip_outer_exists=false) struc1 struc2 =
+let distinguish ?(skip_outer_exists=false) strucs1 strucs2 =
let rec diff qr k =
if qr > k then diff 0 (k+1) else
- match distinguish_by_type ~skip_outer_exists ~qr ~k struc1 struc2 with
+ match distinguish_by_type ~skip_outer_exists ~qr ~k strucs1 strucs2 with
| Some f -> f
| None -> diff (qr+1) k in
diff 0 1
Modified: trunk/Toss/Solver/WL.mli
===================================================================
--- trunk/Toss/Solver/WL.mli 2011-10-19 15:46:13 UTC (rev 1603)
+++ trunk/Toss/Solver/WL.mli 2011-10-19 17:23:31 UTC (rev 1604)
@@ -24,7 +24,7 @@
(** Distinguish two structures using n-types from FO^k, a bit minimized. *)
val distinguish_by_type: ?skip_outer_exists: bool -> qr: int -> k: int ->
- Structure.structure -> Structure.structure -> Formula.formula option
+ Structure.structure list -> Structure.structure list -> Formula.formula option
val atoms_simplified: Structure.structure -> int array array -> string array -> (int array,Formula.formula) Hashtbl.t
@@ -33,4 +33,4 @@
(** Distinguish two structures. *)
val distinguish: ?skip_outer_exists: bool ->
- Structure.structure -> Structure.structure -> Formula.formula
+ Structure.structure list -> Structure.structure list -> Formula.formula
Modified: trunk/Toss/Solver/WLTest.ml
===================================================================
--- trunk/Toss/Solver/WLTest.ml 2011-10-19 15:46:13 UTC (rev 1603)
+++ trunk/Toss/Solver/WLTest.ml 2011-10-19 17:23:31 UTC (rev 1604)
@@ -134,19 +134,19 @@
let structure1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let structure2 = (struc_of_string "[ | R { (1, 2) } | ]") in
formula_option_eq "None"
- (WL.distinguish_by_type ~qr:2 ~k:1 structure1 structure2);
+ (WL.distinguish_by_type ~qr:2 ~k:1 [structure1] [structure2]);
formula_option_eq "ex x1, x2 (not R(x1, x2) and not R(x2, x1))"
- (WL.distinguish_by_type ~qr:0 ~k:2 structure1 structure2);
+ (WL.distinguish_by_type ~qr:0 ~k:2 [structure1] [structure2]);
formula_option_eq "ex x1, x2, x3 (R(x1, x2) and R(x2, x3))"
- (WL.distinguish_by_type ~qr:0 ~k:3 structure1 structure2);
+ (WL.distinguish_by_type ~qr:0 ~k:3 [structure1] [structure2]);
formula_option_eq "not R(x1, x2) and not R(x2, x1)"
(WL.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
- structure1 structure2);
+ [structure1] [structure2]);
let structure1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
let structure2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
formula_option_eq "ex x P(x)"
- (WL.distinguish_by_type ~qr:0 ~k:1 structure1 structure2);
+ (WL.distinguish_by_type ~qr:0 ~k:1 [structure1] [structure2]);
);
"distinguish" >::
@@ -154,7 +154,7 @@
let structure1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let structure2 = (struc_of_string "[ | R { (1, 2) } | ]") in
formula_eq "ex x1, x2 (not R(x1, x2) and not R(x2, x1))"
- (WL.distinguish structure1 structure2);
+ (WL.distinguish [structure1] [structure2]);
);
]
@@ -196,8 +196,45 @@
... ... ... W..
... ... ... ...
...W ... ... ...
+\"" in assert true;
+ (* formula_eq "W(x2) and all x3 not C(x2, x3)"
+ (WL.distinguish ~skip_outer_exists:true [struc1] [struc2]); *)
+
+ let strucN1 = struc_of_string "[ | | ] \"
+ ... ...
+ ... P..
+ ...
+ P..
+ ... ...
+ ...P ...
\"" in
- formula_eq "W(x2) and all x3 not C(x2, x3)"
- (WL.distinguish ~skip_outer_exists:true struc1 struc2);
+ 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_eq
+ "P(x2) and ex x3 (P(x3) and C(x2, x3)) and ex x3 (P(x3) and C(x3, x2))"
+ (WL.distinguish ~skip_outer_exists:true
+ [strucP] [strucN1; strucN2; strucN3]);
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <si...@us...> - 2011-10-19 18:07:21
|
Revision: 1605
http://toss.svn.sourceforge.net/toss/?rev=1605&view=rev
Author: simles
Date: 2011-10-19 18:07:14 +0000 (Wed, 19 Oct 2011)
Log Message:
-----------
added LearnGame module
Modified Paths:
--------------
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Structure.mli
Added Paths:
-----------
trunk/Toss/Server/LearnGame.ml
trunk/Toss/Server/LearnGame.mli
trunk/Toss/Server/LearnGameTest.ml
Added: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml (rev 0)
+++ trunk/Toss/Server/LearnGame.ml 2011-10-19 18:07:14 UTC (rev 1605)
@@ -0,0 +1,110 @@
+let rec evens ?(acc=[0]) k =
+ let last = (List.hd (List.rev acc)) in
+ if (List.hd (List.rev acc))> k then
+ (List.rev (List.tl ( List.rev acc)))
+ else
+ evens ~acc:(acc@[(last+2)]) k
+let odds k =
+ evens ~acc:[1] k
+
+let playFromDB pid =
+ let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
+ let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
+ List.map (fun x -> ((int_of_string x.(4)),x.(5))) res
+
+
+let winFormula winningStates notWinningStates =
+ WL.distinguish winningStates notWinningStates
+
+let cleanStructure struc =
+ let funs = List.map fst (Structure.StringMap.bindings (Structure.functions struc)) in
+ let struc = StructureParser.parse_structure Lexer.lex (Lexing.from_string (Structure.str struc)) in
+ Structure.replace_names (List.fold_left
+ (fun x y ->
+ Structure.clear_fun x y)
+ struc funs) Structure.StringMap.empty
+ Structure.IntMap.empty
+
+
+let move struct1 struct2 =
+ let changed = (Aux.unique_sorted
+ ( List.map fst
+ (Structure.diff_elems struct1 struct2 )) ) in
+ let strucBefore =
+ fst (Structure.del_elems struct1
+ (Aux.list_diff
+ (Aux.unique_sorted (Structure.elements struct1))
+ changed )) in
+ let strucAfter =
+ fst (Structure.del_elems struct2
+ (Aux.list_diff
+ (Aux.unique_sorted (Structure.elements struct2))
+ changed )) in
+ ((cleanStructure strucBefore) , (cleanStructure strucAfter))
+
+let movesi i partylist =
+ Aux.unique_sorted
+ ~cmp: (fun (s1,s2) (t1,t2) ->
+ let c = ( Structure.compare s1 t1) in
+ if c != 0 then c
+ else (Structure.compare s2 t2))
+ (List.fold_left
+ (fun acc party ->
+ List.append acc
+ (List.fold_left
+ (fun prev i ->
+ if (i < ((List.length party)-1)) then
+ let m = move (List.nth party i) (List.nth party (i+1)) in
+ (List.append prev [m])
+ else
+ (List.append prev []))
+ [] (evens ~acc:[i] (List.length party)) ) )
+ [] partylist)
+
+let learnFromParties partylistWin0 partylistWin1 =
+ let win0 = winFormula
+ (List.map (fun x -> List.hd (List.rev x)) partylistWin0)
+ (List.flatten ((List.map (fun x-> List.tl (List.rev x))
+ partylistWin0)@partylistWin1)) in
+ let win1 = winFormula
+ (List.map (fun x -> List.hd (List.rev x)) partylistWin1)
+ (List.flatten ((List.map (fun x-> List.tl (List.rev x))
+ partylistWin1)@partylistWin0)) in
+
+ let moves0 = movesi 0 (partylistWin0 @ partylistWin1) in
+ let moves1 = movesi 1 (partylistWin0 @ partylistWin1) in
+
+ "PLAYERS 1, 2\n"^
+ "REL Win1() = "^ (Formula.sprint win0) ^"\n"^
+ "REL Win2() = "^ (Formula.sprint win1) ^"\n"^
+ "RULE Mv1: " ^
+ (List.fold_left
+ (fun old x->
+ old^"\n"^
+ (Structure.str (fst x))^" -> "^(Structure.str
+ (snd x)) ^
+ "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
+ (fst x)) )) ^ " " ^
+ "pre not Win2()" )
+ "" moves0) ^"\n"^
+ "RULE Mv2: " ^
+ (List.fold_left
+ (fun old x->
+ old^"\n"^
+ (Structure.str (fst x))^" -> "^(Structure.str
+ (snd x)) ^
+ "\nemb "^(String.concat "," (List.map fst (Structure.rel_signature
+ (fst x)) )) ^ " " ^
+ "pre not Win1()" )
+ "" moves1) ^"\n"^
+ "LOC 0 {
+ PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
+ MOVES [Mv1 -> 1]}
+ PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
+}
+LOC 1{
+ PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
+ PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
+ MOVES [Mv2 -> 0] }
+}" ^"\n" ^
+ "MODEL "^(Structure.str (List.hd (List.hd partylistWin0)))
Added: trunk/Toss/Server/LearnGame.mli
===================================================================
--- trunk/Toss/Server/LearnGame.mli (rev 0)
+++ trunk/Toss/Server/LearnGame.mli 2011-10-19 18:07:14 UTC (rev 1605)
@@ -0,0 +1,6 @@
+val learnFromParties: Structure.structure list list -> Structure.structure list list -> string
+
+val move: Structure.structure -> Structure.structure
+ -> Structure.structure * Structure.structure
+
+val playFromDB: int -> (int*string) list
Added: trunk/Toss/Server/LearnGameTest.ml
===================================================================
--- trunk/Toss/Server/LearnGameTest.ml (rev 0)
+++ trunk/Toss/Server/LearnGameTest.ml 2011-10-19 18:07:14 UTC (rev 1605)
@@ -0,0 +1,313 @@
+open OUnit
+
+let formula_of_string s =
+ FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
+
+let struc_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
+let 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" >::: [
+ "learnFromParties" >::
+ (fun () ->
+ let partylist0 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+P . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q .
+. . .
+P . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q .
+. . .
+P P .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q Q
+. . .
+P P .
+. . .
+. . .
+. . .
+\"";
+ ]; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+Q . .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+Q P .
+. . .
+. . .
+. . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q P .
+. . .
+Q P .
+. . .
+Q . .
+. . .
+\"";]
+ ] in
+let partylist1 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . P
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q P
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q Q P
+. . .
+. Q Q
+. . .
+. . .
+P P P
+\"";
+ ]; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+. . .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. . .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P . .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q .
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P .
+\"";
+"[ | P:1 {}; Q:1 {} | ] \"
+Q . .
+. . .
+. Q Q
+. . .
+. . .
+P P P
+\"";
+ ]
+ ; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . .
+. . .
+. . .
+. . .
+P P P
+\"";]
+ ; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. P .
+. . .
+. P .
+. . .
+. P .
+\"";]
+ ; List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. . .
+. . P
+. . .
+. P .
+. . .
+P . .
+\"";]
+ ] in
+ assert_equal ~printer:(fun x -> x) ""
+ ((LearnGame.learnFromParties partylist0 partylist1 ));
+ );
+
+]
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-10-19 17:23:31 UTC (rev 1604)
+++ trunk/Toss/Server/Tests.ml 2011-10-19 18:07:14 UTC (rev 1605)
@@ -44,6 +44,7 @@
let server_tests = "Server", [
"PictureTest", [PictureTest.tests];
"ReqHandlerTest", [ReqHandlerTest.tests];
+ "LearnGameTest", [LearnGameTest.tests];
]
let tests_l = [
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2011-10-19 17:23:31 UTC (rev 1604)
+++ trunk/Toss/Solver/Structure.mli 2011-10-19 18:07:14 UTC (rev 1605)
@@ -250,6 +250,10 @@
val clear_rels :
?remove_from_sig:bool -> structure -> (string -> bool) -> structure
+val clear_fun :
+ structure -> string -> structure
+
+
(** Remove the element [e] and all incident relation tuples from [struc]. *)
val del_elem : structure -> int -> structure
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-19 22:59:03
|
Revision: 1606
http://toss.svn.sourceforge.net/toss/?rev=1606&view=rev
Author: lukaszkaiser
Date: 2011-10-19 22:58:56 +0000 (Wed, 19 Oct 2011)
Log Message:
-----------
Correcting tests, adding debug output and small corrections in WL, first Learn button in the GUI.
Modified Paths:
--------------
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Server/LearnGameTest.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/index.html
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-10-19 18:07:14 UTC (rev 1605)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-10-19 22:58:56 UTC (rev 1606)
@@ -346,7 +346,7 @@
~advr:4.0 game in
assert_eq_str
- "50. + -50. * (Sum (cell_x52_e8__blank_, cell_x52_d8__blank_, cell_x52_c8__blank_, cell_x52_b8__blank_, cell_x52_a8__blank_ | ((cell_x_y_o(cell_x52_a8__blank_) or cell_x_y_o(cell_x52_b8__blank_) or cell_x_y_o(cell_x52_c8__blank_) or cell_x_y_o(cell_x52_d8__blank_) or cell_x_y_o(cell_x52_e8__blank_)) and (cell_x_y_b(cell_x52_a8__blank_) or cell_x_y_o(cell_x52_a8__blank_)) and (cell_x_y_b(cell_x52_b8__blank_) or cell_x_y_o(cell_x52_b8__blank_)) and (cell_x_y_b(cell_x52_c8__blank_) or cell_x_y_o(cell_x52_c8__blank_)) and (cell_x_y_b(cell_x52_d8__blank_) or cell_x_y_o(cell_x52_d8__blank_)) and (cell_x_y_b(cell_x52_e8__blank_) or cell_x_y_o(cell_x52_e8__blank_)) and R2(cell_x52_d8__blank_, cell_x52_e8__blank_) and R2(cell_x52_c8__blank_, cell_x52_d8__blank_) and R2(cell_x52_b8__blank_, cell_x52_c8__blank_) and R2(cell_x52_a8__blank_, cell_x52_b8__blank_)) : (:(cell_x_y_o(cell_x52_a8__blank_)) + :(cell_x_y_o(cell_x52_b8__blank_)) + :(cell_x_y_o(cell_x52_c8__blank_)) + :(cell_x_y_o(cell_x52_d8__blank_)) + :(cell_x_y_o(cell_x52_e8__blank_))) * (:(cell_x_y_o(cell_x52_a8__blank_)) + :(cell_x_y_o(cell_x52_b8__blank_)) + :(cell_x_y_o(cell_x52_c8__blank_)) + :(cell_x_y_o(cell_x52_d8__blank_)) + :(cell_x_y_o(cell_x52_e8__blank_))) * (:(cell_x_y_o(cell_x52_a8__blank_)) + :(cell_x_y_o(cell_x52_b8__blank_)) + :(cell_x_y_o(cell_x52_c8__blank_)) + :(cell_x_y_o(cell_x52_d8__blank_)) + :(cell_x_y_o(cell_x52_e8__blank_))) * (:(cell_x_y_o(cell_x52_a8__blank_)) + :(cell_x_y_o(cell_x52_b8__blank_)) + :(cell_x_y_o(cell_x52_c8__blank_)) + :(cell_x_y_o(cell_x52_d8__blank_)) + :(cell_x_y_o(cell_x52_e8__blank_))) * 0.0016 ) + Sum (cell_e9_y53__blank_, cell_d9_y53__blank_, cell_c9_y53__blank_, cell_b9_y53__blank_, cell_a9_y53__blank_ | ((cell_x_y_o(cell_a9_y53__blank_) or cell_x_y_o(cell_b9_y53__blank_) or cell_x_y_o(cell_c9_y53__blank_) or cell_x_y_o(cell_d9_y53__blank_) or cell_x_y_o(cell_e9_y53__blank_)) and (cell_x_y_b(cell_a9_y53__blank_) or cell_x_y_o(cell_a9_y53__blank_)) and (cell_x_y_b(cell_b9_y53__blank_) or cell_x_y_o(cell_b9_y53__blank_)) and (cell_x_y_b(cell_c9_y53__blank_) or cell_x_y_o(cell_c9_y53__blank_)) and (cell_x_y_b(cell_d9_y53__blank_) or cell_x_y_o(cell_d9_y53__blank_)) and (cell_x_y_b(cell_e9_y53__blank_) or cell_x_y_o(cell_e9_y53__blank_)) and R1(cell_d9_y53__blank_, cell_e9_y53__blank_) and R1(cell_c9_y53__blank_, cell_d9_y53__blank_) and R1(cell_b9_y53__blank_, cell_c9_y53__blank_) and R1(cell_a9_y53__blank_, cell_b9_y53__blank_)) : (:(cell_x_y_o(cell_a9_y53__blank_)) + :(cell_x_y_o(cell_b9_y53__blank_)) + :(cell_x_y_o(cell_c9_y53__blank_)) + :(cell_x_y_o(cell_d9_y53__blank_)) + :(cell_x_y_o(cell_e9_y53__blank_))) * (:(cell_x_y_o(cell_a9_y53__blank_)) + :(cell_x_y_o(cell_b9_y53__blank_)) + :(cell_x_y_o(cell_c9_y53__blank_)) + :(cell_x_y_o(cell_d9_y53__blank_)) + :(cell_x_y_o(cell_e9_y53__blank_))) * (:(cell_x_y_o(cell_a9_y53__blank_)) + :(cell_x_y_o(cell_b9_y53__blank_)) + :(cell_x_y_o(cell_c9_y53__blank_)) + :(cell_x_y_o(cell_d9_y53__blank_)) + :(cell_x_y_o(cell_e9_y53__blank_))) * (:(cell_x_y_o(cell_a9_y53__blank_)) + :(cell_x_y_o(cell_b9_y53__blank_)) + :(cell_x_y_o(cell_c9_y53__blank_)) + :(cell_x_y_o(cell_d9_y53__blank_)) + :(cell_x_y_o(cell_e9_y53__blank_))) * 0.0016 ) + Sum (cell_x62_y63__blank_, cell_x61_y62__blank_, cell_x60_y61__blank_, cell_x59_y60__blank_, cell_x58_y59__blank_ | ((cell_x_y_o(cell_x58_y59__blank_) or cell_x_y_o(cell_x59_y60__blank_) or cell_x_y_o(cell_x60_y61__blank_) or cell_x_y_o(cell_x61_y62__blank_) or cell_x_y_o(cell_x62_y63__blank_)) and (cell_x_y_b(cell_x58_y59__blank_) or cell_x_y_o(cell_x58_y59__blank_)) and (cell_x_y_b(cell_x59_y60__blank_) or cell_x_y_o(cell_x59_y60__blank_)) and (cell_x_y_b(cell_x60_y61__blank_) or cell_x_y_o(cell_x60_y61__blank_)) and (cell_x_y_b(cell_x61_y62__blank_) or cell_x_y_o(cell_x61_y62__blank_)) and (cell_x_y_b(cell_x62_y63__blank_) or cell_x_y_o(cell_x62_y63__blank_)) and R0(cell_x62_y63__blank_, cell_x61_y62__blank_) and R0(cell_x61_y62__blank_, cell_x60_y61__blank_) and R0(cell_x60_y61__blank_, cell_x59_y60__blank_) and R0(cell_x59_y60__blank_, cell_x58_y59__blank_)) : (:(cell_x_y_o(cell_x58_y59__blank_)) + :(cell_x_y_o(cell_x59_y60__blank_)) + :(cell_x_y_o(cell_x60_y61__blank_)) + :(cell_x_y_o(cell_x61_y62__blank_)) + :(cell_x_y_o(cell_x62_y63__blank_))) * (:(cell_x_y_o(cell_x58_y59__blank_)) + :(cell_x_y_o(cell_x59_y60__blank_)) + :(cell_x_y_o(cell_x60_y61__blank_)) + :(cell_x_y_o(cell_x61_y62__blank_)) + :(cell_x_y_o(cell_x62_y63__blank_))) * (:(cell_x_y_o(cell_x58_y59__blank_)) + :(cell_x_y_o(cell_x59_y60__blank_)) + :(cell_x_y_o(cell_x60_y61__blank_)) + :(cell_x_y_o(cell_x61_y62__blank_)) + :(cell_x_y_o(cell_x62_y63__blank_))) * (:(cell_x_y_o(cell_x58_y59__blank_)) + :(cell_x_y_o(cell_x59_y60__blank_)) + :(cell_x_y_o(cell_x60_y61__blank_)) + :(cell_x_y_o(cell_x61_y62__blank_)) + :(cell_x_y_o(cell_x62_y63__blank_))) * 0.0016 ) + Sum (cell_x57_y58__blank_, cell_x56_y57__blank_, cell_x55_y56__blank_, cell_x54_y55__blank_, cell_x53_y54__blank_ | ((cell_x_y_o(cell_x53_y54__blank_) or cell_x_y_o(cell_x54_y55__blank_) or cell_x_y_o(cell_x55_y56__blank_) or cell_x_y_o(cell_x56_y57__blank_) or cell_x_y_o(cell_x57_y58__blank_)) and (cell_x_y_b(cell_x53_y54__blank_) or cell_x_y_o(cell_x53_y54__blank_)) and (cell_x_y_b(cell_x54_y55__blank_) or cell_x_y_o(cell_x54_y55__blank_)) and (cell_x_y_b(cell_x55_y56__blank_) or cell_x_y_o(cell_x55_y56__blank_)) and (cell_x_y_b(cell_x56_y57__blank_) or cell_x_y_o(cell_x56_y57__blank_)) and (cell_x_y_b(cell_x57_y58__blank_) or cell_x_y_o(cell_x57_y58__blank_)) and R(cell_x57_y58__blank_, cell_x56_y57__blank_) and R(cell_x56_y57__blank_, cell_x55_y56__blank_) and R(cell_x55_y56__blank_, cell_x54_y55__blank_) and R(cell_x54_y55__blank_, cell_x53_y54__blank_)) : (:(cell_x_y_o(cell_x53_y54__blank_)) + :(cell_x_y_o(cell_x54_y55__blank_)) + :(cell_x_y_o(cell_x55_y56__blank_)) + :(cell_x_y_o(cell_x56_y57__blank_)) + :(cell_x_y_o(cell_x57_y58__blank_))) * (:(cell_x_y_o(cell_x53_y54__blank_)) + :(cell_x_y_o(cell_x54_y55__blank_)) + :(cell_x_y_o(cell_x55_y56__blank_)) + :(cell_x_y_o(cell_x56_y57__blank_)) + :(cell_x_y_o(cell_x57_y58__blank_))) * (:(cell_x_y_o(cell_x53_y54__blank_)) + :(cell_x_y_o(cell_x54_y55__blank_)) + :(cell_x_y_o(cell_x55_y56__blank_)) + :(cell_x_y_o(cell_x56_y57__blank_)) + :(cell_x_y_o(cell_x57_y58__blank_))) * (:(cell_x_y_o(cell_x53_y54__blank_)) + :(cell_x_y_o(cell_x54_y55__blank_)) + :(cell_x_y_o(cell_x55_y56__blank_)) + :(cell_x_y_o(cell_x56_y57__blank_)) + :(cell_x_y_o(cell_x57_y58__blank_))) * 0.0016 )) + 50. * (Sum (cell_x51_y52__blank_, cell_x50_y51__blank_, cell_x49_y50__blank_, cell_x48_y49__blank_, cell_x47_y48__blank_ | ((cell_x_y_x(cell_x47_y48__blank_) or cell_x_y_x(cell_x48_y49__blank_) or cell_x_y_x(cell_x49_y50__blank_) or cell_x_y_x(cell_x50_y51__blank_) or cell_x_y_x(cell_x51_y52__blank_)) and (cell_x_y_b(cell_x47_y48__blank_) or cell_x_y_x(cell_x47_y48__blank_)) and (cell_x_y_b(cell_x48_y49__blank_) or cell_x_y_x(cell_x48_y49__blank_)) and (cell_x_y_b(cell_x49_y50__blank_) or cell_x_y_x(cell_x49_y50__blank_)) and (cell_x_y_b(cell_x50_y51__blank_) or cell_x_y_x(cell_x50_y51__blank_)) and (cell_x_y_b(cell_x51_y52__blank_) or cell_x_y_x(cell_x51_y52__blank_)) and R0(cell_x51_y52__blank_, cell_x50_y51__blank_) and R0(cell_x50_y51__blank_, cell_x49_y50__blank_) and R0(cell_x49_y50__blank_, cell_x48_y49__blank_) and R0(cell_x48_y49__blank_, cell_x47_y48__blank_)) : (:(cell_x_y_x(cell_x47_y48__blank_)) + :(cell_x_y_x(cell_x48_y49__blank_)) + :(cell_x_y_x(cell_x49_y50__blank_)) + :(cell_x_y_x(cell_x50_y51__blank_)) + :(cell_x_y_x(cell_x51_y52__blank_))) * (:(cell_x_y_x(cell_x47_y48__blank_)) + :(cell_x_y_x(cell_x48_y49__blank_)) + :(cell_x_y_x(cell_x49_y50__blank_)) + :(cell_x_y_x(cell_x50_y51__blank_)) + :(cell_x_y_x(cell_x51_y52__blank_))) * (:(cell_x_y_x(cell_x47_y48__blank_)) + :(cell_x_y_x(cell_x48_y49__blank_)) + :(cell_x_y_x(cell_x49_y50__blank_)) + :(cell_x_y_x(cell_x50_y51__blank_)) + :(cell_x_y_x(cell_x51_y52__blank_))) * (:(cell_x_y_x(cell_x47_y48__blank_)) + :(cell_x_y_x(cell_x48_y49__blank_)) + :(cell_x_y_x(cell_x49_y50__blank_)) + :(cell_x_y_x(cell_x50_y51__blank_)) + :(cell_x_y_x(cell_x51_y52__blank_))) * 0.0016 ) + Sum (cell_x46_y47__blank_, cell_x45_y46__blank_, cell_x44_y45__blank_, cell_x43_y44__blank_, cell_x42_y43__blank_ | ((cell_x_y_x(cell_x42_y43__blank_) or cell_x_y_x(cell_x43_y44__blank_) or cell_x_y_x(cell_x44_y45__blank_) or cell_x_y_x(cell_x45_y46__blank_) or cell_x_y_x(cell_x46_y47__blank_)) and (cell_x_y_b(cell_x42_y43__blank_) or cell_x_y_x(cell_x42_y43__blank_)) and (cell_x_y_b(cell_x43_y44__blank_) or cell_x_y_x(cell_x43_y44__blank_)) and (cell_x_y_b(cell_x44_y45__blank_) or cell_x_y_x(cell_x44_y45__blank_)) and (cell_x_y_b(cell_x45_y46__blank_) or cell_x_y_x(cell_x45_y46__blank_)) and (cell_x_y_b(cell_x46_y47__blank_) or cell_x_y_x(cell_x46_y47__blank_)) and R(cell_x46_y47__blank_, cell_x45_y46__blank_) and R(cell_x45_y46__blank_, cell_x44_y45__blank_) and R(cell_x44_y45__blank_, cell_x43_y44__blank_) and R(cell_x43_y44__blank_, cell_x42_y43__blank_)) : (:(cell_x_y_x(cell_x42_y43__blank_)) + :(cell_x_y_x(cell_x43_y44__blank_)) + :(cell_x_y_x(cell_x44_y45__blank_)) + :(cell_x_y_x(cell_x45_y46__blank_)) + :(cell_x_y_x(cell_x46_y47__blank_))) * (:(cell_x_y_x(cell_x42_y43__blank_)) + :(cell_x_y_x(cell_x43_y44__blank_)) + :(cell_x_y_x(cell_x44_y45__blank_)) + :(cell_x_y_x(cell_x45_y46__blank_)) + :(cell_x_y_x(cell_x46_y47__blank_))) * (:(cell_x_y_x(cell_x42_y43__blank_)) + :(cell_x_y_x(cell_x43_y44__blank_)) + :(cell_x_y_x(cell_x44_y45__blank_)) + :(cell_x_y_x(cell_x45_y46__blank_)) + :(cell_x_y_x(cell_x46_y47__blank_))) * (:(cell_x_y_x(cell_x42_y43__blank_)) + :(cell_x_y_x(cell_x43_y44__blank_)) + :(cell_x_y_x(cell_x44_y45__blank_)) + :(cell_x_y_x(cell_x45_y46__blank_)) + :(cell_x_y_x(cell_x46_y47__blank_))) * 0.0016 ) + Sum (cell_x41_e6__blank_, cell_x41_d6__blank_, cell_x41_c6__blank_, cell_x41_b6__blank_, cell_x41_a6__blank_ | ((cell_x_y_x(cell_x41_a6__blank_) or cell_x_y_x(cell_x41_b6__blank_) or cell_x_y_x(cell_x41_c6__blank_) or cell_x_y_x(cell_x41_d6__blank_) or cell_x_y_x(cell_x41_e6__blank_)) and (cell_x_y_b(cell_x41_a6__blank_) or cell_x_y_x(cell_x41_a6__blank_)) and (cell_x_y_b(cell_x41_b6__blank_) or cell_x_y_x(cell_x41_b6__blank_)) and (cell_x_y_b(cell_x41_c6__blank_) or cell_x_y_x(cell_x41_c6__blank_)) and (cell_x_y_b(cell_x41_d6__blank_) or cell_x_y_x(cell_x41_d6__blank_)) and (cell_x_y_b(cell_x41_e6__blank_) or cell_x_y_x(cell_x41_e6__blank_)) and R2(cell_x41_d6__blank_, cell_x41_e6__blank_) and R2(cell_x41_c6__blank_, cell_x41_d6__blank_) and R2(cell_x41_b6__blank_, cell_x41_c6__blank_) and R2(cell_x41_a6__blank_, cell_x41_b6__blank_)) : (:(cell_x_y_x(cell_x41_a6__blank_)) + :(cell_x_y_x(cell_x41_b6__blank_)) + :(cell_x_y_x(cell_x41_c6__blank_)) + :(cell_x_y_x(cell_x41_d6__blank_)) + :(cell_x_y_x(cell_x41_e6__blank_))) * (:(cell_x_y_x(cell_x41_a6__blank_)) + :(cell_x_y_x(cell_x41_b6__blank_)) + :(cell_x_y_x(cell_x41_c6__blank_)) + :(cell_x_y_x(cell_x41_d6__blank_)) + :(cell_x_y_x(cell_x41_e6__blank_))) * (:(cell_x_y_x(cell_x41_a6__blank_)) + :(cell_x_y_x(cell_x41_b6__blank_)) + :(cell_x_y_x(cell_x41_c6__blank_)) + :(cell_x_y_x(cell_x41_d6__blank_)) + :(cell_x_y_x(cell_x41_e6__blank_))) * (:(cell_x_y_x(cell_x41_a6__blank_)) + :(cell_x_y_x(cell_x41_b6__blank_)) + :(cell_x_y_x(cell_x41_c6__blank_)) + :(cell_x_y_x(cell_x41_d6__blank_)) + :(cell_x_y_x(cell_x41_e6__blank_))) * 0.0016 ) + Sum (cell_e7_y42__blank_, cell_d7_y42__blank_, cell_c7_y42__blank_, cell_b7_y42__blank_, cell_a7_y42__blank_ | ((cell_x_y_x(cell_a7_y42__blank_) or cell_x_y_x(cell_b7_y42__blank_) or cell_x_y_x(cell_c7_y42__blank_) or cell_x_y_x(cell_d7_y42__blank_) or cell_x_y_x(cell_e7_y42__blank_)) and (cell_x_y_b(cell_a7_y42__blank_) or cell_x_y_x(cell_a7_y42__blank_)) and (cell_x_y_b(cell_b7_y42__blank_) or cell_x_y_x(cell_b7_y42__blank_)) and (cell_x_y_b(cell_c7_y42__blank_) or cell_x_y_x(cell_c7_y42__blank_)) and (cell_x_y_b(cell_d7_y42__blank_) or cell_x_y_x(cell_d7_y42__blank_)) and (cell_x_y_b(cell_e7_y42__blank_) or cell_x_y_x(cell_e7_y42__blank_)) and R1(cell_d7_y42__blank_, cell_e7_y42__blank_) and R1(cell_c7_y42__blank_, cell_d7_y42__blank_) and R1(cell_b7_y42__blank_, cell_c7_y42__blank_) and R1(cell_a7_y42__blank_, cell_b7_y42__blank_)) : (:(cell_x_y_x(cell_a7_y42__blank_)) + :(cell_x_y_x(cell_b7_y42__blank_)) + :(cell_x_y_x(cell_c7_y42__blank_)) + :(cell_x_y_x(cell_d7_y42__blank_)) + :(cell_x_y_x(cell_e7_y42__blank_))) * (:(cell_x_y_x(cell_a7_y42__blank_)) + :(cell_x_y_x(cell_b7_y42__blank_)) + :(cell_x_y_x(cell_c7_y42__blank_)) + :(cell_x_y_x(cell_d7_y42__blank_)) + :(cell_x_y_x(cell_e7_y42__blank_))) * (:(cell_x_y_x(cell_a7_y42__blank_)) + :(cell_x_y_x(cell_b7_y42__blank_)) + :(cell_x_y_x(cell_c7_y42__blank_)) + :(cell_x_y_x(cell_d7_y42__blank_)) + :(cell_x_y_x(cell_e7_y42__blank_))) * (:(cell_x_y_x(cell_a7_y42__blank_)) + :(cell_x_y_x(cell_b7_y42__blank_)) + :(cell_x_y_x(cell_c7_y42__blank_)) + :(cell_x_y_x(cell_d7_y42__blank_)) + :(cell_x_y_x(cell_e7_y42__blank_))) * 0.0016 ))"
+"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)"
(Formula.real_str loc_heurs.(0).(0));
);
@@ -359,7 +359,7 @@
~advr:2.0 game in
assert_eq_str
- "100. * (0.99609375 + 1.9921875 * :( not ex cellholds_x29_y28__blank_ (cellholds_x2_y2_black(cellholds_x29_y28__blank_) and not control_MV1(cellholds_x29_y28__blank_)) ) + Sum (cellholds_x28_8__blank_ | (cellholds_x2_y2_white(cellholds_x28_8__blank_) and not control_MV1(cellholds_x28_8__blank_)) : 0.0078125 + Sum (y | R1(y, cellholds_x28_8__blank_) : 0.015625 + Sum (y0 | R1(y0, y) : 0.03125 + Sum (y1 | R1(y1, y0) : 0.0625 + Sum (y2 | R1(y2, y1) : 0.125 + Sum (y3 | R1(y3, y2) : 0.25 + Sum (y4 | R1(y4, y3) : 0.5 + Sum (y5 | R1(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_) 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));
);
Modified: trunk/Toss/Server/LearnGameTest.ml
===================================================================
--- trunk/Toss/Server/LearnGameTest.ml 2011-10-19 18:07:14 UTC (rev 1605)
+++ trunk/Toss/Server/LearnGameTest.ml 2011-10-19 22:58:56 UTC (rev 1606)
@@ -44,11 +44,73 @@
let tests = "LearnGame" >::: [
- "learnFromParties" >::
+ "simple test game" >::
(fun () ->
let partylist0 = [
List.map struc_of_string [
"[ | P:1 {}; Q:1 {} | ] \"
+. .
+. .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+. P
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+Q P
+\"" ;]] in
+ let partylist1 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+. .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+P .
+\"" ;
+"[ | P:1 {}; Q:1 {} | ] \"
+. .
+P Q
+\"" ;]] in
+ let res_game =
+"PLAYERS 1, 2
+REL Win1() = ex x1, x2 (Q(x2) and R(x2, x1))
+REL Win2() = ex x1, x2 (Q(x2) and R(x1, x2))
+RULE Mv1:
+[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
+emb R,Q,P pre not Win2()
+RULE Mv2:
+[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P:1 {}; Q (1); R:2 {} | ]
+emb R,Q,P pre not Win1()
+LOC 0 {
+ PLAYER 1 { PAYOFF : (Win1()) - :(Win2())
+ MOVES [Mv1 -> 1]}
+ PLAYER 2 { PAYOFF : (Win2()) - :(Win1()) }
+}
+LOC 1{
+ PLAYER 1 { PAYOFF :(Win1()) - :(Win2()) }
+ PLAYER 2 { PAYOFF :(Win2()) - :(Win1())
+ MOVES [Mv2 -> 0] }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] R R \"
+
+ . .
+\"" in
+ assert_equal ~printer:(fun x -> x) res_game
+ ((LearnGame.learnFromParties partylist0 partylist1 ));
+ );
+]
+
+
+let bigtests = "LearnGame" >::: [
+ "tic-tac-toe" >::
+ (fun () ->
+ WL.set_debug_level 0; (* set to 1 to get some info printed out *)
+ let partylist0 = [
+ List.map struc_of_string [
+"[ | P:1 {}; Q:1 {} | ] \"
. . .
. . .
. . .
@@ -306,8 +368,8 @@
P . .
\"";]
] in
- assert_equal ~printer:(fun x -> x) ""
- ((LearnGame.learnFromParties partylist0 partylist1 ));
+assert_equal ~printer:(fun x -> x) ""
+ ((LearnGame.learnFromParties partylist0 partylist1 ));
);
]
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-10-19 18:07:14 UTC (rev 1605)
+++ trunk/Toss/Server/Tests.ml 2011-10-19 22:58:56 UTC (rev 1606)
@@ -44,7 +44,7 @@
let server_tests = "Server", [
"PictureTest", [PictureTest.tests];
"ReqHandlerTest", [ReqHandlerTest.tests];
- "LearnGameTest", [LearnGameTest.tests];
+ "LearnGameTest", [LearnGameTest.tests; LearnGameTest.bigtests];
]
let tests_l = [
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-10-19 18:07:14 UTC (rev 1605)
+++ trunk/Toss/Solver/WL.ml 2011-10-19 22:58:56 UTC (rev 1606)
@@ -1,5 +1,8 @@
open Formula
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
(* Given an array of lists, i.e. a.(i) is a list, find an array b of the same
size of sub-lists (b.(i) subset a.(i)) such that if there was an element
distinguishing a.(i) from a.(j) then one separates b.(i) from b.(j).
@@ -117,17 +120,18 @@
(* --- WITH SIMPLIFICATION --- *)
-let atoms_simplified structure tuples variables =
+let atoms_simplified ?(min=true) structure tuples variables =
let tlist = Array.map (fun tuple ->
Aux.unique_sorted (atoms structure tuple variables)) tuples in
- let tlistF = separate_conjs (Array.length tuples < 80) tlist in
+ let tlistF =
+ if min then separate_conjs (Array.length tuples < 80) tlist else tlist in
let tuplesTable = Hashtbl.create 7 in
Array.iteri (fun i tuple->
Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
) tuples;
tuplesTable
-let nextTypes structure tuples variables types =
+let nextTypes ?(min=true) structure tuples variables types =
let conjuncts tuple =
let indices = Aux.range (Array.length tuple) in
let substituted i e = Aux.array_replace tuple (i-1) e in
@@ -158,30 +162,30 @@
(conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i)
) indices ))) in
let tlist = Array.map conjuncts tuples in
- let tlistF = separate_conjs false tlist in
+ let tlistF = if min then separate_conjs false tlist else tlist in
let tuplesTable = Hashtbl.create 7 in
Array.iteri (fun i tuple->
Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
) tuples;
tuplesTable
-let rec ntypesSimplified ?cur_types tuples variables structure n k =
+let rec ntypesSimplified ?(min=true) ?cur_types tuples variables structure n k =
let x, types = match cur_types with
| Some (step, typs) -> (step, typs)
- | None -> (0, atoms_simplified structure tuples variables) in
+ | None -> (0, atoms_simplified ~min structure tuples variables) in
if x >= n then types else
ntypesSimplified
- ~cur_types:(x+1, nextTypes structure tuples variables types)
+ ~cur_types:(x+1, nextTypes ~min structure tuples variables types)
tuples variables structure n k
-let rec all_ntypes_simplified structure n k =
+let rec all_ntypes_simplified ?(min=true) structure n k =
let rec no_rept l = List.length l = List.length (Aux.unique_sorted l) in
let tuples =
Array.of_list (List.map Array.of_list (List.filter no_rept (
Aux.all_ntuples (Structure.elements structure) k))) in
let variables =
Array.map (fun i -> "x"^string_of_int(i)) (Array.of_list (Aux.range k)) in
- ntypesSimplified tuples variables structure n k
+ ntypesSimplified ~min tuples variables structure n k
(* 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. *)
@@ -202,9 +206,9 @@
| phi -> phi
-let distinguish_by_type ?(skip_outer_exists=false) ~qr ~k sPos sNeg =
+let distinguish_by_type ?(min=true) ?(skip_outer_exists=false) ~qr ~k sPos sNeg=
let listht table = Hashtbl.fold (fun x y z -> y :: z) table [] in
- let types s = Aux.unique_sorted (listht (all_ntypes_simplified s qr k)) in
+ let types s= Aux.unique_sorted (listht (all_ntypes_simplified ~min 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
@@ -233,9 +237,18 @@
Some (Ex (List.sort Formula.compare_vars fv, t))
let distinguish ?(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 qr > k then diff 0 (k+1) else (
+ if !debug_level > 0 then Printf.printf "distinguish qr %i k %i\n%!" qr k;
match distinguish_by_type ~skip_outer_exists ~qr ~k strucs1 strucs2 with
| Some f -> f
- | None -> diff (qr+1) k in
+ | None -> match distinguish_by_type ~min:false ~skip_outer_exists
+ ~qr ~k strucs1 strucs2 with
+ | Some f -> f
+ | None -> diff (qr+1) k
+ ) in
diff 0 1
Modified: trunk/Toss/Solver/WL.mli
===================================================================
--- trunk/Toss/Solver/WL.mli 2011-10-19 18:07:14 UTC (rev 1605)
+++ trunk/Toss/Solver/WL.mli 2011-10-19 22:58:56 UTC (rev 1606)
@@ -22,15 +22,22 @@
?tuples: int array list option ->
Structure.structure -> int -> int -> Formula.formula list
+val atoms_simplified: ?min:bool -> Structure.structure -> int array array ->
+ string array -> (int array,Formula.formula) Hashtbl.t
+
+val all_ntypes_simplified: ?min:bool -> Structure.structure -> int -> int ->
+ (int array, Formula.formula) Hashtbl.t
+
(** Distinguish two structures using n-types from FO^k, a bit minimized. *)
-val distinguish_by_type: ?skip_outer_exists: bool -> qr: int -> k: int ->
+val distinguish_by_type: ?min:bool -> ?skip_outer_exists: bool ->
+ qr: int -> k: int ->
Structure.structure list -> Structure.structure list -> Formula.formula option
-val atoms_...
[truncated message content] |
|
From: <luk...@us...> - 2011-10-20 19:22:51
|
Revision: 1607
http://toss.svn.sourceforge.net/toss/?rev=1607&view=rev
Author: lukstafi
Date: 2011-10-20 19:22:44 +0000 (Thu, 20 Oct 2011)
Log Message:
-----------
Solver: semantics for partial functions. GDL: prolog interpreter: treat positive lits of relations with negations in their definitions similarly to negative literals. GDL translation: cleaner val_ elems; include frame clauses when analysing how to build defined relations (select_argpath function).
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/Arena/Arena.ml 2011-10-20 19:22:44 UTC (rev 1607)
@@ -89,9 +89,20 @@
let lhs =
(List.assoc rname game.rules
).ContinuousRule.discrete.DiscreteRule.lhs_struc in
- List.map (fun (lhs_e, m_e) ->
- Structure.find_elem lhs lhs_e, Structure.find_elem state.struc m_e)
- emb_str
+ try
+ List.map (fun (lhs_e, m_e) ->
+ Structure.find_elem lhs lhs_e, Structure.find_elem state.struc m_e)
+ emb_str
+ with Not_found ->
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "emb_of_names: failed at LHS=\n%s\nSTRUC=\n%s\n%!"
+ (Structure.str lhs) (Structure.str state.struc)
+ );
+ (* }}} *)
+ failwith ("emb_of_names: could not find " ^
+ String.concat "; "
+ (List.map (fun (v,e) ->v^"<-"^e) emb_str))
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/GDL.ml 2011-10-20 19:22:44 UTC (rev 1607)
@@ -439,8 +439,8 @@
"(" ^ rel ^ " " ^
String.concat " " (Array.to_list (Array.map term_str args)) ^ ")"
-let terms_str facts =
- String.concat ", " (List.map term_str facts)
+let terms_str args =
+ String.concat ", " (List.map term_str (Array.to_list args))
let rel_atoms_str body = String.concat " " (List.map rel_atom_str body)
@@ -470,6 +470,9 @@
"(<= "^rel_atom_str head^"\n "^String.concat "\n "
(List.map literal_str body)^")"
+let clauses_str cls =
+ String.concat "\n" (List.map clause_str cls)
+
let sb_str sb =
String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
@@ -640,35 +643,54 @@
the program. *)
let run_prolog_aggregate = ref false
-(* In the future, [prolog_program] could implement deeper hashing to
+(* [string list] stores negative relations.
+ In the future, [prolog_program] could implement deeper hashing to
be used by [assoc_clauses]. *)
-type prolog_program = clause list Aux.StrMap.t
+type prolog_program = string list * clause list Aux.StrMap.t
+let negative_clause (_, body) = List.exists
+ (function Neg (Distinct _) -> false
+ | Neg _ | Pos (Distinct _) -> true
+ | Pos _ -> false
+ | Disj disj
+ when List.for_all (function Pos (Distinct _) -> false
+ | Neg (Distinct _) -> true | Pos _ -> true | _ -> false) disj
+ -> false
+ | Disj _ -> true)
+ body
+
+let positive_lit negative_rels =
+ function Neg (Distinct _) -> true
+ | Neg _ | Pos (Distinct _) -> false
+ | Pos (Rel (r, _)) when List.mem r negative_rels -> false
+ | Pos _ -> true
+ | Disj disj
+ when List.for_all (function Pos (Distinct _) -> false
+ | Pos (Rel (r, _)) when List.mem r negative_rels -> false
+ | Neg (Distinct _) -> true | Pos _ -> true | _ -> false) disj
+ -> true
+ | Disj _ -> false
+
(** Push negative literals to the right. *)
-let preprocess_goal goal =
+let preprocess_goal negative_rels goal =
let ground, nonground = List.partition
(fun l -> Aux.Strings.is_empty (literals_vars [l])) goal in
- let posi, nega = List.partition
- (function Neg (Distinct _) -> true
- | Neg _ | Pos (Distinct _) -> false
- | Pos _ -> true
- | Disj disj
- when List.for_all (function Pos (Distinct _) -> false
- | Neg (Distinct _) -> true | Pos _ -> true | _ -> false) disj
- -> true
- | Disj _ -> false)
- nonground in
+ let posi, nega =
+ List.partition (positive_lit negative_rels) nonground in
ground @ posi @ nega
let preprocess_program clauses =
+ let negative_rels = Aux.unique_sorted
+ (Aux.map_some (fun ((r,_),_ as cl) ->
+ if negative_clause cl then Some r else None) clauses) in
let clauses = List.map
(fun ((rel,args as head), body) ->
- rel, (head, preprocess_goal body)) clauses in
+ rel, (head, preprocess_goal negative_rels body)) clauses in
let clauses = Aux.collect clauses in
- Aux.strmap_of_assoc clauses
+ negative_rels, Aux.strmap_of_assoc clauses
-let replace_rel_in_program rel clauses p =
- Aux.StrMap.add rel clauses p
+let replace_rel_in_program rel clauses (nrels, p) =
+ nrels, Aux.StrMap.add rel clauses p
let used_vars = ref Aux.Strings.empty
@@ -700,7 +722,7 @@
Printf.printf
"assoc_clauses: trying %s with:\n%s\n%!"
(rel_atom_str a)
- (String.concat "\n"(List.map clause_str cls))
+ (clauses_str cls)
);
(* }}} *)
cls
@@ -781,7 +803,7 @@
| Disj (lit::lits) ->
run_lit lit p sc (fun () -> run_lit (Disj lits) p sc fc sb) sb
-let run_prolog_atom (rel, args as q : rel_atom) (p : prolog_program) =
+let run_prolog_atom (rel, args as q : rel_atom) ((_,p) : prolog_program) =
(*used_vars := Aux.StrMap.fold (fun _ cls acc ->
Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;*)
used_vars := (* Aux.Strings.union !used_vars *) terms_vars args;
@@ -807,17 +829,17 @@
(* }}} *)
res
-let run_prolog_goal (g : literal list) (p : prolog_program) =
+let run_prolog_goal (g : literal list) ((negative_rels, p) : prolog_program) =
(*used_vars := Aux.StrMap.fold (fun _ cls acc ->
Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;*)
used_vars := (* Aux.Strings.union !used_vars *) literals_vars g;
- let g = preprocess_goal g in
+ let g = preprocess_goal negative_rels g in
let sc_init fc sb = fun m -> fc () (sb::m) in
let fc_init () = fun m -> m in
let extract res = res [] in
extract (run_goal g p sc_init fc_init [])
-let run_prolog_check_atom (rel, args) (p : prolog_program) =
+let run_prolog_check_atom (rel, args) ((_,p) : prolog_program) =
(*used_vars := Aux.StrMap.fold (fun _ cls acc ->
Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;*)
used_vars := (* Aux.Strings.union !used_vars *) terms_vars args;
@@ -825,11 +847,12 @@
let fc_init () = false in
run_clauses (Rel (rel, args)) p sc_init fc_init []
-let run_prolog_check_goal (g : literal list) (p : prolog_program) =
+let run_prolog_check_goal (g : literal list)
+ ((negative_rels, p) : prolog_program) =
(*used_vars := Aux.StrMap.fold (fun _ cls acc ->
Aux.Strings.union (clauses_vars cls) acc) p Aux.Strings.empty;*)
used_vars := (* Aux.Strings.union !used_vars *) literals_vars g;
- let g = preprocess_goal g in
+ let g = preprocess_goal negative_rels g in
let sc_init fc _ = true in
let fc_init () = false in
run_goal g p sc_init fc_init []
@@ -840,22 +863,14 @@
let ground, nonground = List.partition
(fun l -> Aux.Strings.is_empty (literals_vars [l])) goal in
let posi, nega = List.partition
- (function Neg (Distinct _) -> true
- | Neg _ | Pos (Distinct _) -> false
- | Pos _ -> true
- | Disj disj
- when List.for_all (function Pos (Distinct _) -> false
- | Neg (Distinct _) -> true | Pos _ -> true | _ -> false) disj
- -> true
- | Disj _ -> false)
- nonground in
+ (positive_lit (fst testground)) nonground in
let unif, posi = List.partition
(function Neg (Distinct _) -> true | _ -> false) posi in
let sc_init fc _ = fun m -> fc () (m + 1) in
let fc_init () = fun m -> m in
let rec branching_f = function
| Pos a as l ->
- run_clauses a testground sc_init fc_init [] 0, l
+ run_clauses a (snd testground) sc_init fc_init [] 0, l
| Neg (Distinct _) as l -> 0, l
| Disj disj as l ->
List.fold_left (+) 0 (List.map (fst -| branching_f) disj), l
@@ -865,7 +880,8 @@
let posi = List.sort (fun (i,_) (j,_) -> i-j) posi in
ground @ unif @ List.map snd posi @ nega
-let optimize_program ~testground program =
+let optimize_program ~testground (ncls, program) =
+ ncls,
Aux.StrMap.map
(fun cls -> List.map
(fun (h,b) -> h, optimize_goal testground b)
@@ -1379,11 +1395,11 @@
performs a random ply. Aggregate playouts are "deprecated",
especially for uses other than generating all possible state
terms. *)
-let playout_prolog ~aggregate players horizon program =
+let playout_prolog ~aggregate players horizon (_, pr_cls as program) =
let program =
if aggregate then
- let next_cls = assoc_clauses ("next",[|Var "x"|]) program in
- let legal_cls = assoc_clauses ("legal",[|Var "x"|]) program in
+ let next_cls = assoc_clauses ("next",[|Var "x"|]) pr_cls in
+ let legal_cls = assoc_clauses ("legal",[|Var "x"|]) pr_cls in
replace_rel_in_program "next" (remove_neg_lits next_cls)
(replace_rel_in_program "legal" (remove_neg_lits legal_cls) program)
else program in
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/GDL.mli 2011-10-20 19:22:44 UTC (rev 1607)
@@ -166,6 +166,7 @@
val counter_n : string
val term_str : term -> string
+val terms_str : term array -> string
val term_to_name : ?nested:bool -> term -> string
val state_terms : literal list -> term list
@@ -177,6 +178,7 @@
val literal_str : literal -> string
val literals_str : literal list -> string
val clause_str : clause -> string
+val clauses_str : clause list -> string
val sb_str : (string * term) list -> string
val topsort_callgraph : (* string list -> *) clause list -> string list
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/GameSimplTest.ml 2011-10-20 19:22:44 UTC (rev 1607)
@@ -10,41 +10,7 @@
let tests = "GameSimpl" >::: [
- "connect5" >::
- (fun () ->
- let connect5 = state_of_file "./GGP/tests/connect5-raw.toss" in
- let res = GameSimpl.simplify connect5 in
- let goal = state_of_file "./GGP/tests/connect5-simpl.toss" in
- let resf = open_out "./GGP/tests/connect5-temp.toss" in
- let res_str = Arena.state_str res in
- output_string resf res_str;
- close_out resf;
- let eq, msg = Arena.compare_diff goal res in
- assert_bool
- ("tests/connect5-raw.toss to tests/connect5-simpl.toss, see \
- GGP/tests/connect5-temp.toss: "^msg)
- eq;
- Sys.remove "./GGP/tests/connect5-temp.toss"
- );
-
- "breakthrough" >::
- (fun () ->
- let breakthrough = state_of_file "./GGP/tests/breakthrough-raw.toss" in
- let res = GameSimpl.simplify breakthrough in
- let goal = state_of_file "./GGP/tests/breakthrough-simpl.toss" in
- let resf = open_out "./GGP/tests/breakthrough-temp.toss" in
- let res_str = Arena.state_str res in
- output_string resf res_str;
- close_out resf;
- let eq, msg = Arena.compare_diff goal res in
- assert_bool
- ("tests/breakthrough-raw.toss to tests/breakthrough-simpl.toss, see \
- GGP/tests/breakthrough-temp.toss: "^msg)
- eq;
- Sys.remove "./GGP/tests/breakthrough-temp.toss"
- );
-
]
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-10-20 19:22:44 UTC (rev 1607)
@@ -1,6 +1,7 @@
(** {2 Translating GDL definition: formulas.} *)
open GDL
+open Aux.BasicOperators
let debug_level = ref 0
@@ -175,7 +176,16 @@
stuples in
if sign then atoms
else List.map (fun a -> Formula.Not a) atoms
- with Not_found -> assert false) in
+ with Not_found ->
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf
+ "transl_coordrel: failed args=%s; s_subterms keys=%s\n%!"
+ (terms_str args)
+ (String.concat ", " (List.map (term_str -| fst) s_subterms))
+ );
+ (* }}} *)
+ assert false) in
let transl_rel sign rel args =
match List.assoc rel data.argpaths with
| Aux.Left _ ->
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-10-20 19:22:44 UTC (rev 1607)
@@ -258,16 +258,23 @@
playout_satur ~aggregate:true players_wo_env !playout_horizon rules in
(* *)
(*
- let program = preprocess_program clauses in
- let agg_actions, agg_states =
- playout_prolog ~aggregate:true players !playout_horizon program in
+ let program = preprocess_program clauses in
+ let agg_actions, agg_states =
+ playout_prolog ~aggregate:true players !playout_horizon program in
*)
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "prepare_paths_and_elems: static_base= %s\n%!"
+ (String.concat ", "
+ (List.map rel_atom_str (graph_to_atoms static_base)))
+ );
+ (* }}} *)
let ground_state_terms = List.fold_left
(fun acc st ->
Aux.sorted_merge (Aux.unique_sorted st) acc) []
(terminal_state::agg_states) in
let init_state = List.hd agg_states in
- check_timeout "TranslateGame: create_init_struc: init_state";
+ check_timeout "TranslateGame: prepare_paths_and_elems: init_state";
let arities =
("EQ_", 2)::
Aux.unique_sorted
@@ -278,7 +285,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "create_init_struc: static_rels=%s; nonstatic_rels=%s\n%!"
+ "prepare_paths_and_elems: static_rels=%s; nonstatic_rels=%s\n%!"
(String.concat ", " static_rels) (String.concat ", " nonstatic_rels)
);
(* }}} *)
@@ -290,7 +297,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "create_init_struc: f_paths=%s\n%!"
+ "prepare_paths_and_elems: f_paths=%s\n%!"
(String.concat "; "
(List.map GDL.path_str (GDL.paths_to_list f_paths)))
);
@@ -314,7 +321,7 @@
frame_clauses in
(* {{{ log entry *)
if !debug_level > 2 then (
- Printf.printf "create_init_struc:\nused_roots=%s\nunused_roots=%s\nframed_fluents=%s; static_rels=%s\n%!"
+ Printf.printf "prepare_paths_and_elems:\nused_roots=%s\nunused_roots=%s\nframed_fluents=%s; static_rels=%s\n%!"
(String.concat ", "(Aux.Strings.elements used_roots))
(String.concat ", "(Aux.Strings.elements unused_roots))
(String.concat ", " (List.map (fun (p, subt) ->
@@ -357,7 +364,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "create_init_struc: element_reps=\n%s\n%!"
+ "prepare_paths_and_elems: element_reps=\n%s\n%!"
(String.concat ", " (List.map term_str element_reps))
);
(* }}} *)
@@ -367,7 +374,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "create_init_struc: c_paths=%s\n%!"
+ "prepare_paths_and_elems: c_paths=%s\n%!"
(String.concat "; "
(List.map GDL.path_str (GDL.paths_to_list c_paths)))
);
@@ -379,11 +386,11 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "create_init_struc: refined c_paths=%s\n%!"
+ "prepare_paths_and_elems: refined c_paths=%s\n%!"
(String.concat "; "
(List.map GDL.path_str (GDL.paths_to_list res)))
);
- (* }}} *)
+ (* }}} *)
res
) else c_paths in
let root_reps =
@@ -401,6 +408,8 @@
Aux.concat_map Array.to_list
(gdl_rel_graph r static_base))
static_rels) Terms.empty in
+ let needed_coords = Terms.filter
+ (Aux.Strings.is_empty -| term_vars) needed_coords in
(* TODO: we also need players? *)
(*let needed_coords =
add_terms (Array.to_list players_wo_env) needed_coords in*)
@@ -409,15 +418,20 @@
(List.map (at_paths f_paths) ground_state_terms) needed_coords in*)
let missing_coords =
Terms.diff needed_coords coord_subterms in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf
+ "missing_coords: (static base) %s; (ground state terms) %s\n%!"
+ (String.concat ", "
+ (List.map term_str (Terms.elements missing_coords)))
+ (String.concat ", "
+ (List.map term_str (Aux.concat_map (at_paths f_paths)
+ ground_state_terms)))
+ );
+ (* }}} *)
let missing_coords = List.fold_right add_terms
(List.map (at_paths f_paths) ground_state_terms) missing_coords in
let missing_coords = Terms.elements missing_coords in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "create_init_struc: missing_coords=%s\n%!"
- (String.concat ", "(List.map term_str missing_coords))
- );
- (* }}} *)
let val_elems = List.map
(fun subt -> Func ("val_", [|subt|])) missing_coords in
let term_arities =
@@ -435,7 +449,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "create_init_struc: root_reps=\n%s\n%!"
+ "prepare_paths_and_elems: root_reps=\n%s\n%!"
(String.concat ", " (List.map term_str root_reps))
);
(* }}} *)
@@ -476,15 +490,28 @@
let select_argpaths static_rels init_state program c_paths f_paths
ground_at_c_paths clauses rel =
- let atoms_sterms = List.map
+ let atoms_sterms = Aux.map_some
(fun ((r, args), body) ->
let r_atoms = if r = rel then [args] else [] in
let r_atoms = r_atoms @ Aux.map_some
(function Rel (r, args) when r = rel -> Some args
| _ -> None)
(atoms_of_body body) in
- r_atoms, state_terms body)
+ if r_atoms <> [] then Some
+ (r_atoms, state_terms body)
+ else None)
clauses in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "select_argpaths: rel=%s atoms-sterms=\n%s\n%!"
+ rel
+ (String.concat "\n"
+ (List.map (fun (atoms, sterms) ->
+ String.concat "; "(List.map terms_str atoms) ^
+ " ==> " ^
+ String.concat "; "(List.map term_str sterms)) atoms_sterms))
+ );
+ (* }}} *)
let check_path args p s_p =
let inds = Aux.array_argfind_all (fun r -> r=s_p) args in
List.map (fun i->p,i) inds in
@@ -666,10 +693,12 @@
atoms (that have subterms instead of blanks). *)
let call_transform term_arities ground_at_c_paths
rel partition ((h_rel,h_args as h),body) =
+ let important_clause =
+ not (List.mem h_rel ["frame next"; "additional clause"]) in
let r_atoms = if h_rel = rel then [h_args] else [] in
let r_atoms = r_atoms @ Aux.map_some
(function Rel (r, args) when r = rel -> Some args
- | Distinct args when rel = "distinct" && h_rel <> "frame next"
+ | Distinct args when rel = "distinct" && important_clause
-> Some args
| _ -> None)
(atoms_of_body body) in
@@ -701,7 +730,7 @@
Some (blank_outside_subterm term_arities path arg) in
let add_sterms = Aux.concat_map
(fun args ->
- if rel = "distinct" && h_rel <> "frame next" then
+ if rel = "distinct" && important_clause then
Aux.map_some (fun x->x)
(Array.to_list (Array.map sterm_arg_for_distinct args))
else if rel = "distinct" then []
@@ -734,13 +763,23 @@
["goal"; "next"; "rule clause"; "update clause";"legal"]
let prepare_rels static_rels nonstatic_rels init_state c_paths f_paths
- ground_at_c_paths term_arities counters clauses =
+ ground_at_c_paths term_arities counters additional_clauses clauses =
let ord_rels =
topsort_callgraph (*(static_rels @ nonstatic_rels)*) clauses in
let all_rels = Aux.list_diff ord_rels (not_callable @ counters) in
let c_pathl = paths_to_list c_paths in
+ let additional_clauses =
+ List.map (fun ((_,args),body) ->
+ ("additional clause",args), body) additional_clauses in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "prepare_rels: additional_clauses=\n%s\nclauses=\n%s\n\n%!"
+ (clauses_str additional_clauses) (clauses_str clauses)
+ );
+ (* }}} *)
(* program is only used to find default argpaths *)
let program = preprocess_program clauses in
+ let clauses = additional_clauses @ clauses in
let is_strucrel rel = List.mem rel static_rels &&
if !as_defined_rels = By_const_param
then List.exists
@@ -761,7 +800,7 @@
List.partition is_strucrel static_rels in
struc_rels := as_struc;
defined_rels := as_defined @ nonstatic_rels);
-
+
(* first pass *)
let fstpass_clauses = List.fold_left
(fun clauses rel ->
@@ -807,8 +846,8 @@
let argpaths =
List.map Aux.trd3 (List.rev (List.sort Pervasives.compare argpaths)) in
let argpaths =
- (* actually, arity mismatch for "distinct" is captured in
- call_transform *)
+ (* actually, arity mismatch for "distinct" is captured in
+ call_transform *)
("distinct", Aux.Left (Array.make 2 c_pathl))::argpaths in
let clauses = List.fold_left
(fun clauses (rel, partition) ->
@@ -843,6 +882,8 @@
(String.concat ", " struc_rels) (String.concat ", " defined_rels)
);
(* }}} *)
+ let clauses = List.filter
+ (fun ((hrel,_),_) -> hrel<>"additional clause") clauses in
struc_rels, defined_rels,
("EQ_", Aux.Left (Array.make 2 c_pathl)) :: argpaths, clauses
@@ -857,22 +898,27 @@
let defs = List.filter
(fun ((rel,_),_) -> List.mem rel expand_rels) clauses in
let defs = defs_of_rules (Aux.concat_map rules_of_clause defs) in
+ let legal_defs =
+ try List.assoc "legal" defs with Not_found -> [] in
let frame_clauses = List.map
(fun (h,body)->("next",[|h|]),body) frame_clauses in
let frame_defs =
try List.assoc "next"
(defs_of_rules (Aux.concat_map rules_of_clause frame_clauses))
with Not_found -> [] in
- let frame_defs = expand_definitions defs frame_defs in
+ let exp_frame_defs = expand_definitions defs frame_defs in
+ (* FIXME: shouldn't we expand "does" above as we do below? *)
+ let lexp_frame_defs =
+ expand_definitions ["does", legal_defs] frame_defs in
let pos = function Distinct _ as a -> Neg a | a -> Pos a in
let neg = function Distinct _ as a -> Pos a | a -> Neg a in
- let frame_clauses = List.map
- (fun (args, body, neg_body) ->
- ("next", args),
- List.map (fun a->pos (atom_of_rel a)) body @
- List.map (fun a->neg (atom_of_rel a)) neg_body)
- frame_defs in
- frame_clauses
+ let def_to_clause (args, body, neg_body) =
+ ("next", args),
+ List.map (fun a->pos (atom_of_rel a)) body @
+ List.map (fun a->neg (atom_of_rel a)) neg_body in
+ let frame_clauses = List.map def_to_clause exp_frame_defs in
+ let lexp_frame_clauses = List.map def_to_clause lexp_frame_defs in
+ lexp_frame_clauses, frame_clauses
(* Generate the initial structure. *)
@@ -1024,7 +1070,7 @@
let prepare_relations_and_structure
ground_state_terms f_paths c_paths element_reps root_reps
static_base init_state term_arities arities static_rels nonstatic_rels
- program ~playout_states counters clauses =
+ program ~playout_states counters additional_clauses clauses =
let ground_at_c_paths = List.map
(fun p-> p,
Aux.unique_sorted (Aux.map_try (fun s->at_path s p)
@@ -1032,7 +1078,9 @@
(paths_to_list c_paths) in
let struc_rels, defined_rels, argpaths, clauses =
prepare_rels static_rels nonstatic_rels init_state c_paths f_paths
- ground_at_c_paths term_arities counters clauses in
+ (* additional_clauses provide additional information about how
+ "defined relations" are used *)
+ ground_at_c_paths term_arities counters additional_clauses clauses in
let stable_rels, fluents, struc =
create_init_struc ground_state_terms c_paths f_paths
element_reps root_reps
@@ -1745,7 +1793,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "create_rule_cands: legal_cls --\n%s\n%!"
- (String.concat "\n"(List.map clause_str legal_cls));
+ (clauses_str legal_cls);
Printf.printf "create_rule_cands: next_cls --\n%s\n%!"
(String.concat "\n"(List.map (fun (h,fr,body) ->
Printf.sprintf "%s <=fr:%B= %s"
@@ -2627,7 +2675,8 @@
frame_clauses, move_clauses, clauses =
prepare_paths_and_elems players_wo_env program ~playout_states clauses in
let clauses = ground_goal_values ground_state_terms clauses in
- let frame_clauses =
+ (* [lexp_frame_clauses] have only the "legal" atoms expanded *)
+ let lexp_frame_clauses, frame_clauses =
process_frame_clauses clauses frame_clauses in
let frame_clauses = List.map
(fun ((_,args),body) -> ("frame next", args), body) frame_clauses in
@@ -2657,7 +2706,7 @@
if !debug_level > 3 then (
Printf.printf
"translate_game: clauses after grounding fluents\n%s\n\n%!"
- (String.concat "\n"(List.map clause_str clauses));
+ (clauses_str clauses);
);
(* }}} *)
let clauses = elim_ground_distinct clauses in
@@ -2674,12 +2723,14 @@
if !perform_ground_arg_elim
then elim_ground_args nonstatic_rels clauses
else nonstatic_rels, clauses in
+ (* eliminate once again since more variables have been instantiated *)
+ let clauses = elim_ground_distinct clauses in
let nonstatic_rels = "goal"::"legal"::nonstatic_rels in
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf
"translate_game: clauses before creating rule cands\n%s\n\n%!"
- (String.concat "\n"(List.map clause_str clauses));
+ (clauses_str clauses);
);
(* }}} *)
check_timeout "TranslateGame: clauses";
@@ -2739,14 +2790,16 @@
prepare_relations_and_structure
ground_state_terms f_paths c_paths element_reps root_reps
static_base init_state term_arities arities static_rels nonstatic_rels
- program ~playout_states counters clauses in
+ (* we pass frame clauses because they provide additional
+ information about how "defined relations" are used *)
+ program ~playout_states counters lexp_frame_clauses clauses in
let defined_rels = Aux.list_diff defined_rels
["goal"; "legal"; "next"] in
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf
"traslate_game: all non-counter clauses after preparing\n%s\n\n%!"
- (String.concat "\n"(List.map clause_str clauses));
+ (clauses_str clauses);
);
(* }}} *)
check_timeout
@@ -2773,7 +2826,7 @@
if !debug_level > 2 then (
Printf.printf
"traslate_game: all clauses prior to building defined rels\n%s\n\n%!"
- (String.concat "\n"(List.map clause_str clauses));
+ (clauses_str clauses);
);
(* }}} *)
let defined_rels =
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-10-20 19:22:44 UTC (rev 1607)
@@ -198,6 +198,22 @@
~loc1_noop:"noop" ~loc1_move:"(mark 1 1)"
);
+ "tictactoe-different definition" >::
+ (fun () ->
+ game_test_case ~game_name:"tictactoe-other" ~player:"xPLAYER"
+ ~own_plnum:0 ~opponent_plnum:1
+ ~loc0_rule_name:"mARK_X9_Y9_nOOP"
+ ~loc0_emb:[
+ "cELL_X9_Y9__BLANK_", "cELL_2_2__BLANK_";
+ "cONTROL__BLANK_", "cONTROL__BLANK_"]
+ ~loc0_move:"(MARK 2 2)" ~loc0_noop:"NOOP"
+ ~loc1:1 ~loc1_rule_name:"nOOP_mARK_X10_Y10"
+ ~loc1_emb:[
+ "cELL_X10_Y10__BLANK_", "cELL_3_3__BLANK_";
+ "cONTROL__BLANK_", "cONTROL__BLANK_"]
+ ~loc1_noop:"NOOP" ~loc1_move:"(MARK 3 3)"
+ );
+
"2player_normal_form_2010" >::
(fun () ->
simult_test_case ~game_name:"2player_normal_form_2010" ~player:"row"
@@ -345,24 +361,18 @@
let a () =
set_debug_level 4;
- simult_test_case ~game_name:"pacman3p" ~player:"pacman"
- ~plnum:1 (* 0 is environment! *)
- ~moves:[|"(move east)"; "(move nowhere)"; "(move nowhere)"|]
- ~rules_and_embs:[|
- "move_east", [
- "gdl__counter", "gdl__counter";
- "location__BLANK__x10_y10", "location__BLANK__6_3";
- "location__BLANK__x9_y9", "location__BLANK__5_3";
- "location__BLANK__x_y", "location__BLANK__5_3";
- "synch_control_", "synch_control_"];
- "move_nowhere0", [
- "location__BLANK__x11_y11", "location__BLANK__4_6";
- "location__BLANK__x12_y12", "location__BLANK__4_6";
- "synch_control_", "synch_control_"];
- "move_nowhere1", [
- "location__BLANK__x13_y13", "location__BLANK__5_6";
- "location__BLANK__x14_y14", "location__BLANK__5_6";
- "synch_control_", "synch_control_"]|];
+ game_test_case ~game_name:"tictactoe" ~player:"xplayer"
+ ~own_plnum:0 ~opponent_plnum:1
+ ~loc0_rule_name:"mark_x6_y_noop"
+ ~loc0_emb:[
+ "cell_x6_y__BLANK_", "cell_2_2__BLANK_";
+ "control__BLANK_", "control__BLANK_"]
+ ~loc0_move:"(mark 2 2)" ~loc0_noop:"noop"
+ ~loc1:1 ~loc1_rule_name:"noop_mark_x7_y0"
+ ~loc1_emb:[
+ "cell_x7_y0__BLA...
[truncated message content] |
|
From: <luk...@us...> - 2011-10-21 22:00:46
|
Revision: 1610
http://toss.svn.sourceforge.net/toss/?rev=1610&view=rev
Author: lukstafi
Date: 2011-10-21 22:00:39 +0000 (Fri, 21 Oct 2011)
Log Message:
-----------
GameSimpl: bug fix. GDL translation: setting the counter element by Sum guard.
Modified Paths:
--------------
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-10-21 14:16:20 UTC (rev 1609)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-10-21 22:00:39 UTC (rev 1610)
@@ -190,8 +190,15 @@
List.filter (fun v -> not (List.mem_assoc (var_str v) sb)) vs in
let phi = FormulaSubst.subst_vars sb (And (more_conj @ conj)) in
if vs = [] then phi else Ex (vs, phi)
- | phi -> phi} in
- FormulaMap.map_formula f_map phi
+ | phi -> Ex (vs, phi)} in
+ let res = FormulaMap.map_formula f_map phi in
+ (* {{{ log entry *)
+ if !debug_level > 3 && phi <> res then (
+ Printf.printf "remove_exist:\nphi=%s\nres=%s\n%!"
+ (Formula.str phi) (Formula.str res)
+ );
+ (* }}} *)
+ res
(* A heuristic measure of how easy a formula is to solve or provide a
good heuristic. Very crude for now, not using the structure yet. *)
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-10-21 14:16:20 UTC (rev 1609)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-10-21 22:00:39 UTC (rev 1610)
@@ -204,15 +204,20 @@
if sign then Formula.EQZero else Formula.NEQZero in
let cc = Formula.Fun (c, counter_v) and ct = transl_c t in
if cc = ct then []
- else [Formula.RealExpr (minus cc ct, sign_op)] in
+ else [Formula.RealExpr (
+ Formula.Sum ([counter_v], Formula.Rel (counter_n, [|counter_v|]),
+ minus cc ct)
+ , sign_op)] in
let transl_numfun_rel sign rel t1 t2 =
let sign_op =
if sign then Formula.EQZero else Formula.NEQZero in
let f_result =
FormulaSubst.subst_real [":x", transl_c t1]
(List.assoc rel data.num_functions) in
- [Formula.RealExpr
- (minus f_result (transl_c t2), sign_op)] in
+ [Formula.RealExpr (
+ Formula.Sum ([counter_v], Formula.Rel (counter_n, [|counter_v|]),
+ minus f_result (transl_c t2))
+ , sign_op)] in
let rec aux = function
| Pos (True (Func (c, [|t|])))
when List.mem c data.counters &&
@@ -368,22 +373,12 @@
if pos_vars = [] then base_part
else Formula.Ex ((pos_vars :> Formula.var list), base_part)
-let has_counter t =
- FormulaMap.fold_formula
- {FormulaMap.make_fold ( || ) false with
- FormulaMap.fold_Fun = (fun _ v -> v = counter_v)} t
-
(* Translate a disjunction of conjunctions of literals (and disjs of lits). *)
let translate data disj =
let disj = separate_disj data.counters disj in
- let res =
- Formula.Or (List.map (fun (rels_phi, pos_state, neg_state) ->
- transl_disjunct data rels_phi pos_state neg_state []
- ) disj) in
- if has_counter res
- then Formula.Ex
- ([counter_v], Formula.And [Formula.Rel (counter_n, [|counter_v|]); res])
- else res
+ Formula.Or (List.map (fun (rels_phi, pos_state, neg_state) ->
+ transl_disjunct data rels_phi pos_state neg_state []
+ ) disj)
(* **************************************** *)
(* {3 Build defined relations.} *)
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-10-21 14:16:20 UTC (rev 1609)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-10-21 22:00:39 UTC (rev 1610)
@@ -2166,7 +2166,13 @@
~add:rhs_add ~nondistinct ~emb_rels:fluents ~signat ~struc_elems in
let updates = List.map
(fun (f, cond_updates) -> (f, counter_n),
- transl_cond_updates transl_data num_functions cond_updates)
+ (* a trick to force instantiating the counter variable -- note
+ that variable with the same name is also part of the
+ precondition *)
+ Formula.Sum (
+ [`FO counter_n],
+ Formula.Rel (counter_n, [|`FO counter_n|]),
+ transl_cond_updates transl_data num_functions cond_updates))
counter_cls in
let rule =
ContinuousRule.make_rule signat [] discrete
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-10-21 14:16:20 UTC (rev 1609)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-10-21 22:00:39 UTC (rev 1610)
@@ -361,14 +361,24 @@
let a () =
set_debug_level 4;
- simult_test_case ~game_name:"2player_normal_form_joint" ~player:"row"
+ simult_test_case ~game_name:"pacman3p" ~player:"pacman"
~plnum:1 (* 0 is environment! *)
- ~moves:[|"r1"; "c1"|]
+ ~moves:[|"(move east)"; "(move nowhere)"; "(move nowhere)"|]
~rules_and_embs:[|
- "m", ["did__BLANK__m", "did__BLANK__r1";
- "synch_control_", "synch_control_"];
- "m2", ["did__BLANK__m2", "did__BLANK__c1";
- "synch_control_", "synch_control_"] |];
+ "move_east", [
+ "gdl__counter", "gdl__counter";
+ "location__BLANK__x10_y10", "location__BLANK__6_3";
+ "location__BLANK__x9_y9", "location__BLANK__5_3";
+ "location__BLANK__x_y", "location__BLANK__5_3";
+ "synch_control_", "synch_control_"];
+ "move_nowhere0", [
+ "location__BLANK__x11_y11", "location__BLANK__4_6";
+ "location__BLANK__x12_y12", "location__BLANK__4_6";
+ "synch_control_", "synch_control_"];
+ "move_nowhere1", [
+ "location__BLANK__x13_y13", "location__BLANK__5_6";
+ "location__BLANK__x14_y14", "location__BLANK__5_6";
+ "synch_control_", "synch_control_"]|];
(* failwith "tested"; *)
()
@@ -414,7 +424,7 @@
(* regenerate ~debug:false ~game_name:"connect4" ~player:"white"; *)
(* regenerate ~debug:false ~game_name:"2player_normal_form_2010" ~player:"row"; *)
(* regenerate ~debug:false ~game_name:"2player_normal_form_joint" ~player:"row"; *)
- (* regenerate ~debug:true ~game_name:"pacman3p" ~player:"pacman"; *)
+ (* regenerate ~debug:false ~game_name:"pacman3p" ~player:"pacman"; *)
(* failwith "generated"; *)
()
Modified: trunk/Toss/GGP/tests/pacman3p-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-raw.toss 2011-10-21 14:16:20 UTC (rev 1609)
+++ trunk/Toss/GGP/tests/pacman3p-raw.toss 2011-10-21 22:00:39 UTC (rev 1610)
@@ -187,14 +187,15 @@
location__BLANK___BLANK___BLANK_(location__BLANK__xnew0_y20) and
location__BLANK___BLANK___BLANK_(location__BLANK__x20_y20)))
REL nopellets() =
- ex gdl__counter
- (gdl__counter(gdl__counter) and
- (:collected(gdl__counter) - 35. = 0) and true)
+ ((Sum (gdl__counter | gdl__counter(gdl__counter) :
+ :collected(gdl__counter) - 35.) = 0) and
+ true)
REL terminal() =
(captured() and true) or (nopellets() and true) or (timeout() and true)
REL timeout() =
- ex gdl__counter
- (gdl__counter(gdl__counter) and (:step(gdl__counter) - 100. = 0) and true)
+ ((Sum (gdl__counter | gdl__counter(gdl__counter) :
+ :step(gdl__counter) - 100.) = 0) and
+ true)
PLAYERS environment, pacman, blinky, inky
RULE move_east:
[gdl__counter, location__BLANK__x10_y10, location__BLANK__x9_y9,
@@ -257,25 +258,27 @@
location_0pellet
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__east(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__east(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -343,25 +346,27 @@
location_0pellet
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__north(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__north(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -429,25 +434,27 @@
location_0pellet
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__south(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__south(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -515,25 +522,27 @@
location_0pellet
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__west(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__west(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -594,25 +603,28 @@
location_0pellet
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__nowhere(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__nowhere(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__nowhere(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__nowhere(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__nowhere(location__BLANK__x5_y5,
+ location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__nowhere(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
not
@@ -1271,7 +1283,8 @@
location_0pellet
update
:step(gdl__counter) =
- :((true and true)) * (1. * (:step(gdl__counter) - 98.) + 99.)
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
+ :((true and true)) * (1. * (:step(gdl__counter) - 98.) + 99.))
RULE environment0:
[gdl__counter, control__BLANK_, synch_control_ |
_opt_blinky__SYNC {gdl__counter; control__BLANK_};
@@ -1297,7 +1310,8 @@
location_0pellet
update
:step(gdl__counter) =
- :((true and true)) * (1. * (:step(gdl__counter) - 98.) + 99.)
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
+ :((true and true)) * (1. * (:step(gdl__counter) - 98.) + 99.))
LOC 0 {
PLAYER environment { PAYOFF 0.
Modified: trunk/Toss/GGP/tests/pacman3p-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-simpl.toss 2011-10-21 14:16:20 UTC (rev 1609)
+++ trunk/Toss/GGP/tests/pacman3p-simpl.toss 2011-10-21 22:00:39 UTC (rev 1610)
@@ -58,12 +58,12 @@
location__BLANK___BLANK___BLANK_(location__BLANK__xnew0_y20) and
not blocked(v0, location__BLANK__xnew0_y20))
REL nopellets() =
- ex gdl__counter
- (gdl__counter(gdl__counter) and (:collected(gdl__counter) - 35. = 0))
+ (Sum (gdl__counter | gdl__counter(gdl__counter) :
+ :collected(gdl__counter) - 35.) = 0)
REL terminal() = captured() or nopellets() or timeout()
REL timeout() =
- ex gdl__counter
- (gdl__counter(gdl__counter) and (:step(gdl__counter) - 100. = 0))
+ (Sum (gdl__counter | gdl__counter(gdl__counter) : :step(gdl__counter) - 100.
+ ) = 0)
PLAYERS environment, pacman, blinky, inky
DATA R0: EQ___location_1__location_1__AND__c43c43__location_2__location_2,
R: EQ___location_2__location_2__AND__c43c43__location_1__location_1
@@ -128,25 +128,27 @@
pacman__SYNC
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__east(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__east(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__east(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -213,25 +215,27 @@
pacman__SYNC
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__north(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__north(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__north(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -298,25 +302,27 @@
pacman__SYNC
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__south(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__south(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__south(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -383,25 +389,27 @@
pacman__SYNC
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
- ) * :collected(gdl__counter) +
+ Sum (gdl__counter | gdl__counter(gdl__counter) :
:(
- ex location__BLANK__x3_y3, location__BLANK__x4_y4
- (nextcell__west(location__BLANK__x3_y3, location__BLANK__x4_y4) and
- location_0pacman(location__BLANK__x3_y3) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
- location_0pellet(location__BLANK__x4_y4) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
- ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ ex location__BLANK__x6_y6, location__BLANK__x5_y5
+ (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
+ location_0pacman(location__BLANK__x5_y5) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
+ not
+ (nextcell__west(location__BLANK__x5_y5, location__BLANK__x6_y6) and
+ location_0pellet(location__BLANK__x6_y6) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6)))
+ ) * :collected(gdl__counter) +
+ :(
+ ex location__BLANK__x3_y3, location__BLANK__x4_y4
+ (nextcell__west(location__BLANK__x3_y3, location__BLANK__x4_y4) and
+ location_0pacman(location__BLANK__x3_y3) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x3_y3) and
+ location_0pellet(location__BLANK__x4_y4) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x4_y4))
+ ) * (1. * (:collected(gdl__counter) - 98.) + 99.)
+ )
pre
(not terminal() and
ex val__pacman, control__BLANK_
@@ -461,27 +469,30 @@
pacman__SYNC
update
:collected(gdl__counter) =
- :(
- ex location__BLANK__x6_y6, location__BLANK__x5_y5
- (nextcell__nowhere(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x6_y6) and
- location_0pacman(location__BLANK__x5_y5) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x5_y5) and
- not
- (nextcell__nowhere(location__BLANK__x5_y5, location__BLANK__x6_y6) and
- location_0pellet(location__BLA...
[truncated message content] |
|
From: <luk...@us...> - 2011-10-23 00:13:40
|
Revision: 1612
http://toss.svn.sourceforge.net/toss/?rev=1612&view=rev
Author: lukstafi
Date: 2011-10-23 00:13:32 +0000 (Sun, 23 Oct 2011)
Log Message:
-----------
GDL translation: recognize when a disjunction of <distinct> leads to <not equal>.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/Formula/Aux.mli 2011-10-23 00:13:32 UTC (rev 1612)
@@ -68,7 +68,7 @@
val map_reduce :
('a -> 'b * 'c) -> ('d -> 'c -> 'd) -> 'd -> 'a list -> ('b * 'd) list
-(** Collects elements by key. Same as
+(** Collects elements by key, in a list sorted by key. Same as
[map_reduce (fun x -> x) (fun y x->x::y) []]. *)
val collect : ('a * 'b) list -> ('a * 'b list) list
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/GGP/GDL.ml 2011-10-23 00:13:32 UTC (rev 1612)
@@ -1974,3 +1974,40 @@
(fun s -> List.for_all (fun (p,i) ->
try at_path s p = args.(i) with Not_found -> false) apset)
sterms
+
+(* Check whether each of argpaths covers some tree in c_paths
+ completely. *)
+let complete_paths_for c_paths argpaths =
+ let rec complete ?(root=false) c_paths paths =
+ List.mem [] paths ||
+ let paths = Aux.collect
+ (List.map (function
+ | (r, arg)::tl -> r, (arg, tl)
+ | _ -> assert false) paths) in
+ match c_paths with
+ | Empty -> true
+ | Here -> false
+ | Below c_brs | Here_and_below c_brs ->
+ if root then
+ let rel, p_args = List.hd paths in
+ let c_args = List.assoc rel c_brs in
+ (* fill-in the paths outside of c_args *)
+ let more_p_args =
+ Aux.array_mapi_some (fun i c_ps ->
+ if c_ps = Empty then Some (i, [])
+ else None) c_args in
+ let p_args = Array.to_list more_p_args @ p_args in
+ let p_args = Aux.array_from_assoc (Aux.collect p_args) in
+ Aux.array_for_all2 complete c_args p_args
+ else (
+ List.for_all2
+ (fun (c_rel, c_args) (p_rel, p_args) ->
+ c_rel = p_rel &&
+ let p_args = Aux.array_from_assoc (Aux.collect p_args) in
+ Aux.array_for_all2 complete c_args p_args)
+ c_brs paths) in
+ try
+ List.for_all
+ (fun aps -> complete ~root:true c_paths (List.map fst aps))
+ argpaths
+ with Not_found | Invalid_argument _ -> false
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/GGP/GDL.mli 2011-10-23 00:13:32 UTC (rev 1612)
@@ -299,3 +299,7 @@
type argpaths = (path * int) list list
val find_rel_arg : term list -> term array -> (path * int) list -> term
+
+(** Check whether each of argpaths covers some tree in c_paths
+ completely. *)
+val complete_paths_for : path_set -> argpaths -> bool
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-10-23 00:13:32 UTC (rev 1612)
@@ -383,6 +383,51 @@
(* **************************************** *)
(* {3 Build defined relations.} *)
+let distinct_lit = function
+ | (Pos (Distinct _)) -> true
+ | _ -> false
+
+(* A relation defined by a disjunction of differences on all paths of
+ a state term. *)
+let is_distinctcell c_paths partition cls =
+ try
+ List.iter (fun (_, body) ->
+ if not (List.exists distinct_lit body)
+ then raise Not_found) cls;
+ let cls = List.map
+ (fun (args, body) -> args,
+ List.filter distinct_lit body)
+ cls in
+ if not (complete_paths_for c_paths partition)
+ then raise Not_found;
+ let swap (i,j) = j,i in
+ let v1, v2 =
+ match partition with
+ | [v1; v2] -> List.map swap v1, List.map swap v2
+ | _ -> assert false in
+ let distinct_pairs =
+ List.map (function
+ | args, [Pos (Distinct [|t1; t2|])] ->
+ Aux.array_argfind (fun t->t=t1) args,
+ Aux.array_argfind (fun t->t=t2) args
+ | _ -> raise Not_found) cls in
+ let distinct_pairs = List.map
+ (fun (i,j) ->
+ if List.mem_assoc i v1 && List.mem_assoc j v2
+ then i, j
+ else if List.mem_assoc i v2 && List.mem_assoc j v1
+ then j, i
+ else raise Not_found)
+ distinct_pairs in
+ List.for_all
+ (fun (iv1, pv1) ->
+ let j = List.assoc iv1 distinct_pairs in
+ let pv2 = List.assoc j v2 in
+ pv1 = pv2)
+ v1
+ with Not_found -> false
+
+
let build_defrels data clauses =
let build_defrel drel =
try
@@ -401,21 +446,46 @@
let d_arity = List.length partition in
let defvars =
Array.init d_arity (fun i -> "v"^string_of_int i) in
+ let distinctcell, r_clauses =
+ if d_arity = 2 && (* DEBUG *) drel = "distinctcell" &&
+ is_distinctcell data.c_paths partition r_clauses
+ then true,
+ List.map (fun (args, body) ->
+ args, List.filter (not -| distinct_lit) body) r_clauses
+ else false, r_clauses in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "build_defrel: clauses=\n%s\n\n%!"
+ (clauses_str
+ (List.map (fun (args,body)-> (drel,args),body) r_clauses))
+ );
+ (* }}} *)
let tr_def_r (args, body) =
- let sterms = Aux.map_some
- (function Pos (True s) -> Some s | _ -> None) body in
- let s_l = List.map (find_rel_arg sterms args) partition in
- let v_l = List.map (var_of_term data) s_l in
- let eqs = List.map2
- (fun v sv -> Formula.Eq (`FO v, sv))
- (Array.to_list defvars) v_l in
- let def_phi = FormulaOps.del_vars_quant (v_l :> Formula.var list)
- (translate data [body]) in
- if v_l = [] then Formula.And (eqs @ [def_phi])
- else Formula.Ex ((v_l :> Formula.var list),
- Formula.And (eqs @ [def_phi])) in
- drel, (Array.to_list defvars,
- Formula.Or (List.map tr_def_r r_clauses))
+ if body = [] then Formula.And []
+ else
+ let sterms = Aux.map_some
+ (function Pos (True s) -> Some s | _ -> None) body in
+ let s_l = List.map (find_rel_arg sterms args) partition in
+ let v_l = List.map (var_of_term data) s_l in
+ let eqs = List.map2
+ (fun v sv -> Formula.Eq (`FO v, sv))
+ (Array.to_list defvars) v_l in
+ let def_phi = FormulaOps.del_vars_quant (v_l :> Formula.var list)
+ (translate data [body]) in
+ if v_l = [] then Formula.And (eqs @ [def_phi])
+ else Formula.Ex ((v_l :> Formula.var list),
+ Formula.And (eqs @ [def_phi])) in
+ let dbody = match r_clauses with
+ | [] -> assert false
+ | [r_cl] -> tr_def_r r_cl
+ | _ -> Formula.Or (List.map tr_def_r r_clauses) in
+ if distinctcell then
+ drel, (Array.to_list defvars,
+ Formula.And
+ [Formula.Not (Formula.Eq (`FO defvars.(0), `FO defvars.(1)));
+ dbody])
+ else
+ drel, (Array.to_list defvars, dbody)
with Not_found -> drel, ([], Formula.Or []) in
List.map build_defrel data.defined_rels
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-10-23 00:13:32 UTC (rev 1612)
@@ -360,7 +360,7 @@
let a () =
- set_debug_level 4;
+ (* set_debug_level 4; *)
simult_test_case ~game_name:"pacman3p" ~player:"pacman"
~plnum:1 (* 0 is environment! *)
~moves:[|"(move east)"; "(move nowhere)"; "(move nowhere)"|]
Modified: trunk/Toss/GGP/tests/pacman3p-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-raw.toss 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/GGP/tests/pacman3p-raw.toss 2011-10-23 00:13:32 UTC (rev 1612)
@@ -1,18 +1,15 @@
REL distinctcell(v0, v1) =
- ex location__BLANK__x33_y33, location__BLANK__x34_y34
- (v0 = location__BLANK__x33_y33 and v1 = location__BLANK__x34_y34 and
- cell(location__BLANK__x33_y33) and cell(location__BLANK__x34_y34) and
- not EQ___location_1__location_1(location__BLANK__x33_y33,
- location__BLANK__x34_y34) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x34_y34) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x33_y33)) or
- ex location__BLANK__x35_y35, location__BLANK__x36_y36
- (v0 = location__BLANK__x35_y35 and v1 = location__BLANK__x36_y36 and
- cell(location__BLANK__x35_y35) and cell(location__BLANK__x36_y36) and
- not EQ___location_2__location_2(location__BLANK__x35_y35,
- location__BLANK__x36_y36) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x36_y36) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x35_y35))
+ (not v0 = v1 and
+ (ex location__BLANK__x33_y33, location__BLANK__x34_y34
+ (v0 = location__BLANK__x33_y33 and v1 = location__BLANK__x34_y34 and
+ cell(location__BLANK__x33_y33) and cell(location__BLANK__x34_y34) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x34_y34) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x33_y33)) or
+ ex location__BLANK__x35_y35, location__BLANK__x36_y36
+ (v0 = location__BLANK__x35_y35 and v1 = location__BLANK__x36_y36 and
+ cell(location__BLANK__x35_y35) and cell(location__BLANK__x36_y36) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x36_y36) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x35_y35))))
REL nextcell__east(v0, v1) =
ex location__BLANK__x24_y24, location__BLANK__xnew1_y24
(v0 = location__BLANK__x24_y24 and v1 = location__BLANK__xnew1_y24 and
Modified: trunk/Toss/GGP/tests/pacman3p-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-simpl.toss 2011-10-22 07:38:04 UTC (rev 1611)
+++ trunk/Toss/GGP/tests/pacman3p-simpl.toss 2011-10-23 00:13:32 UTC (rev 1612)
@@ -1,10 +1,9 @@
REL distinctcell(v0, v1) =
- (location__BLANK___BLANK___BLANK_(v0) and
- location__BLANK___BLANK___BLANK_(v1) and
- not EQ___location_1__location_1(v0, v1)) or
- (location__BLANK___BLANK___BLANK_(v0) and
- location__BLANK___BLANK___BLANK_(v1) and
- not EQ___location_2__location_2(v0, v1))
+ (not v0 = v1 and
+ ((location__BLANK___BLANK___BLANK_(v0) and
+ location__BLANK___BLANK___BLANK_(v1)) or
+ (location__BLANK___BLANK___BLANK_(v0) and
+ location__BLANK___BLANK___BLANK_(v1))))
REL nextcell__east(v0, v1) =
(R(v0, v1) and location__BLANK___BLANK___BLANK_(v0) and
location__BLANK___BLANK___BLANK_(v1))
@@ -1245,1034 +1244,6 @@
val__blinky, val__east, val__ghosts, val__inky, val__north, val__nowhere,
val__pacman, val__pellet, val__south, val__west, control__BLANK_,
gdl__counter, synch_control_ |
- EQ___location_1__location_1 {
- (location__BLANK__1_1, location__BLANK__1_1);
- (location__BLANK__1_1, location__BLANK__1_2);
- (location__BLANK__1_1, location__BLANK__1_3);
- (location__BLANK__1_1, location__BLANK__1_4);
- (location__BLANK__1_1, location__BLANK__1_5);
- (location__BLANK__1_1, location__BLANK__1_6);
- (location__BLANK__1_1, location__BLANK__1_7);
- (location__BLANK__1_1, location__BLANK__1_8);
- (location__BLANK__1_2, location__BLANK__1_1);
- (location__BLANK__1_2, location__BLANK__1_2);
- (location__BLANK__1_2, location__BLANK__1_3);
- (location__BLANK__1_2, location__BLANK__1_4);
- (location__BLANK__1_2, location__BLANK__1_5);
- (location__BLANK__1_2, location__BLANK__1_6);
- (location__BLANK__1_2, location__BLANK__1_7);
- (location__BLANK__1_2, location__BLANK__1_8);
- (location__BLANK__1_3, location__BLANK__1_1);
- (location__BLANK__1_3, location__BLANK__1_2);
- (location__BLANK__1_3, location__BLANK__1_3);
- (location__BLANK__1_3, location__BLANK__1_4);
- (location__BLANK__1_3, location__BLANK__1_5);
- (location__BLANK__1_3, location__BLANK__1_6);
- (location__BLANK__1_3, location__BLANK__1_7);
- (location__BLANK__1_3, location__BLANK__1_8);
- (location__BLANK__1_4, location__BLANK__1_1);
- (location__BLANK__1_4, location__BLANK__1_2);
- (location__BLANK__1_4, location__BLANK__1_3);
- (location__BLANK__1_4, location__BLANK__1_4);
- (location__BLANK__1_4, location__BLANK__1_5);
- (location__BLANK__1_4, location__BLANK__1_6);
- (location__BLANK__1_4, location__BLANK__1_7);
- (location__BLANK__1_4, location__BLANK__1_8);
- (location__BLANK__1_5, location__BLANK__1_1);
- (location__BLANK__1_5, location__BLANK__1_2);
- (location__BLANK__1_5, location__BLANK__1_3);
- (location__BLANK__1_5, location__BLANK__1_4);
- (location__BLANK__1_5, location__BLANK__1_5);
- (location__BLANK__1_5, location__BLANK__1_6);
- (location__BLANK__1_5, location__BLANK__1_7);
- (location__BLANK__1_5, location__BLANK__1_8);
- (location__BLANK__1_6, location__BLANK__1_1);
- (location__BLANK__1_6, location__BLANK__1_2);
- (location__BLANK__1_6, location__BLANK__1_3);
- (location__BLANK__1_6, location__BLANK__1_4);
- (location__BLANK__1_6, location__BLANK__1_5);
- (location__BLANK__1_6, location__BLANK__1_6);
- (location__BLANK__1_6, location__BLANK__1_7);
- (location__BLANK__1_6, location__BLANK__1_8);
- (location__BLANK__1_7, location__BLANK__1_1);
- (location__BLANK__1_7, location__BLANK__1_2);
- (location__BLANK__1_7, location__BLANK__1_3);
- (location__BLANK__1_7, location__BLANK__1_4);
- (location__BLANK__1_7, location__BLANK__1_5);
- (location__BLANK__1_7, location__BLANK__1_6);
- (location__BLANK__1_7, location__BLANK__1_7);
- (location__BLANK__1_7, location__BLANK__1_8);
- (location__BLANK__1_8, location__BLANK__1_1);
- (location__BLANK__1_8, location__BLANK__1_2);
- (location__BLANK__1_8, location__BLANK__1_3);
- (location__BLANK__1_8, location__BLANK__1_4);
- (location__BLANK__1_8, location__BLANK__1_5);
- (location__BLANK__1_8, location__BLANK__1_6);
- (location__BLANK__1_8, location__BLANK__1_7);
- (location__BLANK__1_8, location__BLANK__1_8);
- (location__BLANK__2_1, location__BLANK__2_1);
- (location__BLANK__2_1, location__BLANK__2_2);
- (location__BLANK__2_1, location__BLANK__2_3);
- (location__BLANK__2_1, location__BLANK__2_4);
- (location__BLANK__2_1, location__BLANK__2_5);
- (location__BLANK__2_1, location__BLANK__2_6);
- (location__BLANK__2_1, location__BLANK__2_7);
- (location__BLANK__2_1, location__BLANK__2_8);
- (location__BLANK__2_2, location__BLANK__2_1);
- (location__BLANK__2_2, location__BLANK__2_2);
- (location__BLANK__2_2, location__BLANK__2_3);
- (location__BLANK__2_2, location__BLANK__2_4);
- (location__BLANK__2_2, location__BLANK__2_5);
- (location__BLANK__2_2, location__BLANK__2_6);
- (location__BLANK__2_2, location__BLANK__2_7);
- (location__BLANK__2_2, location__BLANK__2_8);
- (location__BLANK__2_3, location__BLANK__2_1);
- (location__BLANK__2_3, location__BLANK__2_2);
- (location__BLANK__2_3, location__BLANK__2_3);
- (location__BLANK__2_3, location__BLANK__2_4);
- (location__BLANK__2_3, location__BLANK__2_5);
- (location__BLANK__2_3, location__BLANK__2_6);
- (location__BLANK__2_3, location__BLANK__2_7);
- (location__BLANK__2_3, location__BLANK__2_8);
- (location__BLANK__2_4, location__BLANK__2_1);
- (location__BLANK__2_4, location__BLANK__2_2);
- (location__BLANK__2_4, location__BLANK__2_3);
- (location__BLANK__2_4, location__BLANK__2_4);
- (location__BLANK__2_4, location__BLANK__2_5);
- (location__BLANK__2_4, location__BLANK__2_6);
- (location__BLANK__2_4, location__BLANK__2_7);
- (location__BLANK__2_4, location__BLANK__2_8);
- (location__BLANK__2_5, location__BLANK__2_1);
- (location__BLANK__2_5, location__BLANK__2_2);
- (location__BLANK__2_5, location__BLANK__2_3);
- (location__BLANK__2_5, location__BLANK__2_4);
- (location__BLANK__2_5, location__BLANK__2_5);
- (location__BLANK__2_5, location__BLANK__2_6);
- (location__BLANK__2_5, location__BLANK__2_7);
- (location__BLANK__2_5, location__BLANK__2_8);
- (location__BLANK__2_6, location__BLANK__2_1);
- (location__BLANK__2_6, location__BLANK__2_2);
- (location__BLANK__2_6, location__BLANK__2_3);
- (location__BLANK__2_6, location__BLANK__2_4);
- (location__BLANK__2_6, location__BLANK__2_5);
- (location__BLANK__2_6, location__BLANK__2_6);
- (location__BLANK__2_6, location__BLANK__2_7);
- (location__BLANK__2_6, location__BLANK__2_8);
- (location__BLANK__2_7, location__BLANK__2_1);
- (location__BLANK__2_7, location__BLANK__2_2);
- (location__BLANK__2_7, location__BLANK__2_3);
- (location__BLANK__2_7, location__BLANK__2_4);
- (location__BLANK__2_7, location__BLANK__2_5);
- (location__BLANK__2_7, location__BLANK__2_6);
- (location__BLANK__2_7, location__BLANK__2_7);
- (location__BLANK__2_7, location__BLANK__2_8);
- (location__BLANK__2_8, location__BLANK__2_1);
- (location__BLANK__2_8, location__BLANK__2_2);
- (location__BLANK__2_8, location__BLANK__2_3);
- (location__BLANK__2_8, location__BLANK__2_4);
- (location__BLANK__2_8, location__BLANK__2_5);
- (location__BLANK__2_8, location__BLANK__2_6);
- (location__BLANK__2_8, location__BLANK__2_7);
- (location__BLANK__2_8, location__BLANK__2_8);
- (location__BLANK__3_1, location__BLANK__3_1);
- (location__BLANK__3_1, location__BLANK__3_2);
- (location__BLANK__3_1, location__BLANK__3_3);
- (location__BLANK__3_1, location__BLANK__3_4);
- (location__BLANK__3_1, location__BLANK__3_5);
- (location__BLANK__3_1, location__BLANK__3_6);
- (location__BLANK__3_1, location__BLANK__3_7);
- (location__BLANK__3_1, location__BLANK__3_8);
- (location__BLANK__3_2, location__BLANK__3_1);
- (location__BLANK__3_2, location__BLANK__3_2);
- (location__BLANK__3_2, location__BLANK__3_3);
- (location__BLANK__3_2, location__BLANK__3_4);
- (location__BLANK__3_2, location__BLANK__3_5);
- (location__BLANK__3_2, location__BLANK__3_6);
- (location__BLANK__3_2, location__BLANK__3_7);
- (location__BLANK__3_2, location__BLANK__3_8);
- (location__BLANK__3_3, location__BLANK__3_1);
- (location__BLANK__3_3, location__BLANK__3_2);
- (location__BLANK__3_3, location__BLANK__3_3);
- (location__BLANK__3_3, location__BLANK__3_4);
- (location__BLANK__3_3, location__BLANK__3_5);
- (location__BLANK__3_3, location__BLANK__3_6);
- (location__BLANK__3_3, location__BLANK__3_7);
- (location__BLANK__3_3, location__BLANK__3_8);
- (location__BLANK__3_4, location__BLANK__3_1);
- (location__BLANK__3_4, location__BLANK__3_2);
- (location__BLANK__3_4, location__BLANK__3_3);
- (location__BLANK__3_4, location__BLANK__3_4);
- (location__BLANK__3_4, location__BLANK__3_5);
- (location__BLANK__3_4, location__BLANK__3_6);
- (location__BLANK__3_4, location__BLANK__3_7);
- (location__BLANK__3_4, location__BLANK__3_8);
- (location__BLANK__3_5, location__BLANK__3_1);
- (location__BLANK__3_5, location__BLANK__3_2);
- (location__BLANK__3_5, location__BLANK__3_3);
- (location__BLANK__3_5, location__BLANK__3_4);
- (location__BLANK__3_5, location__BLANK__3_5);
- (location__BLANK__3_5, location__BLANK__3_6);
- (location__BLANK__3_5, location__BLANK__3_7);
- (location__BLANK__3_5, location__BLANK__3_8);
- (location__BLANK__3_6, location__BLANK__3_1);
- (location__BLANK__3_6, location__BLANK__3_2);
- (location__BLANK__3_6, location__BLANK__3_3);
- (location__BLANK__3_6, location__BLANK__3_4);
- (location__BLANK__3_6, location__BLANK__3_5);
- (location__BLANK__3_6, location__BLANK__3_6);
- (location__BLANK__3_6, location__BLANK__3_7);
- (location__BLANK__3_6, location__BLANK__3_8);
- (location__BLANK__3_7, location__BLANK__3_1);
- (location__BLANK__3_7, location__BLANK__3_2);
- (location__BLANK__3_7, location__BLANK__3_3);
- (location__BLANK__3_7, location__BLANK__3_4);
- (location__BLANK__3_7, location__BLANK__3_5);
- (location__BLANK__3_7, location__BLANK__3_6);
- (location__BLANK__3_7, location__BLANK__3_7);
- (location__BLANK__3_7, location__BLANK__3_8);
- (location__BLANK__3_8, location__BLANK__3_1);
- (location__BLANK__3_8, location__BLANK__3_2);
- (location__BLANK__3_8, location__BLANK__3_3);
- (location__BLANK__3_8, location__BLANK__3_4);
- (location__BLANK__3_8, location__BLANK__3_5);
- (location__BLANK__3_8, location__BLANK__3_6);
- (location__BLANK__3_8, location__BLANK__3_7);
- (location__BLANK__3_8, location__BLANK__3_8);
- (location__BLANK__4_1, location__BLANK__4_1);
- (location__BLANK__4_1, location__BLANK__4_2);
- (location__BLANK__4_1, location__BLANK__4_3);
- (location__BLANK__4_1, location__BLANK__4_4);
- (location__BLANK__4_1, location__BLANK__4_5);
- (location__BLANK__4_1, location__BLANK__4_6);
- (location__BLANK__4_1, location__BLANK__4_7);
- (location__BLANK__4_1, location__BLANK__4_8);
- (location__BLANK__4_2, location__BLANK__4_1);
- (location__BLANK__4_2, location__BLANK__4_2);
- (location__BLANK__4_2, location__BLANK__4_3);
- (location__BLANK__4_2, location__BLANK__4_4);
- (location__BLANK__4_2, location__BLANK__4_5);
- (location__BLANK__4_2, location__BLANK__4_6);
- (location__BLANK__4_2, location__BLANK__4_7);
- (location__BLANK__4_2, location__BLANK__4_8);
- (location__BLANK__4_3, location__BLANK__4_1);
- (location__BLANK__4_3, location__BLANK__4_2);
- (location__BLANK__4_3, location__BLANK__4_3);
- (location__BLANK__4_3, location__BLANK__4_4);
- (location__BLANK__4_3, location__BLANK__4_5);
- (location__BLANK__4_3, location__BLANK__4_6);
- (location__BLANK__4_3, location__BLANK__4_7);
- (location__BLANK__4_3, location__BLANK__4_8);
- (location__BLANK__4_4, location__BLANK__4_1);
- (location__BLANK__4_4, location__BLANK__4_2);
- (location__BLANK__4_4, location__BLANK__4_3);
- (location__BLANK__4_4, location__BLANK__4_4);
- (location__BLANK__4_4, location__BLANK__4_5);
- (location__BLANK__4_4, location__BLANK__4_6);
- (location__BLANK__4_4, location__BLANK__4_7);
- (location__BLANK__4_4, location__BLANK__4_8);
- (location__BLANK__4_5, location__BLANK__4_1);
- (location__BLANK__4_5, location__BLANK__4_2);
- (location__BLANK__4_5, location__BLANK__4_3);
- (location__BLANK__4_5, location__BLANK__4_4);
- (location__BLANK__4_5, location__BLANK__4_5);
- (location__BLANK__4_5, location__BLANK__4_6);
- (location__BLANK__4_5, location__BLANK__4_7);
- (location__BLANK__4_5, location__BLANK__4_8);
- (location__BLANK__4_6, location__BLANK__4_1);
- (location__BLANK__4_6, location__BLANK__4_2);
- (location__BLANK__4_6, location__BLANK__4_3);
- (location__BLANK__4_6, location__BLANK__4_4);
- (location__BLANK__4_6, location__BLANK__4_5);
- (location__BLANK__4_6, location__BLANK__4_6);
- (location__BLANK__4_6, location__BLANK__4_7);
- (location__BLANK__4_6, location__BLANK__4_8);
- (location__BLANK__4_7, location__BLANK__4_1);
- (location__BLANK__4_7, location__BLANK__4_2);
- (location__BLANK__4_7, location__BLANK__4_3);
- (location__BLANK__4_7, location__BLANK__4_4);
- (location__BLANK__4_7, location__BLANK__4_5);
- (location__BLANK__4_7, location__BLANK__4_6);
- (location__BLANK__4_7, location__BLANK__4_7);
- (location__BLANK__4_7, location__BLANK__4_8);
- (location__BLANK__4_8, location__BLANK__4_1);
- (location__BLANK__4_8, location__BLANK__4_2);
- (location__BLANK__4_8, location__BLANK__4_3);
- (location__BLANK__4_8, location__BLANK__4_4);
- (location__BLANK__4_8, location__BLANK__4_5);
- (location__BLANK__4_8, location__BLANK__4_6);
- (location__BLANK__4_8, location__BLANK__4_7);
- (location__BLANK__4_8, location__BLANK__4_8);
- (location__BLANK__5_1, location__BLANK__5_1);
- (location__BLANK__5_1, location__BLANK__5_2);
- (location__BLANK__5_1, location__BLANK__5_3);
- (location__BLANK__5_1, location__BLANK__5_4);
- (location__BLANK__5_1, location__BLANK__5_5);
- (location__BLANK__5_1, location__BLANK__5_6);
- (location__BLANK__5_1, location__BLANK__5_7);
- (location__BLANK__5_1, location__BLANK__5_8);
- (location__BLANK__5_2, location__BLANK__5_1);
- (location__BLANK__5_2, location__BLANK__5_2);
- (location__BLANK__5_2, location__BLANK__5_3);
- (location__BLANK__5_2, location__BLANK__5_4);
- (location__BLANK__5_2, location__BLANK__5_5);
- (location__BLANK__5_2, location__BLANK__5_6);
- (location__BLANK__5_2, location__BLANK__5_7);
- (location__BLANK__5_2, location__BLANK__5_8);
- (location__BLANK__5_3, location__BLANK__5_1);
- (location__BLANK__5_3, location__BLANK__5_2);
- (location__BLANK__5_3, location__BLANK__5_3);
- (location__BLANK__5_3, location__BLANK__5_4);
- (location__BLANK__5_3, location__BLANK__5_5);
- (location__BLANK__5_3, location__BLANK__5_6);
- (location__BLANK__5_3, location__BLANK__5_7);
- (location__BLANK__5_3, location__BLANK__5_8);
- (location__BLANK__5_4, location__BLANK__5_1);
- (location__BLANK__5_4, location__BLANK__5_2);
- (location__BLANK__5_4, location__BLANK__5_3);
- (location__BLANK__5_4, location__BLANK__5_4);
- (location__BLANK__5_4, location__BLANK__5_5);
- (location__BLANK__5_4, location__BLANK__5_6);
- (location__BLANK__5_4, location__BLANK__5_7);
- (location__BLANK__5_4, location__BLANK__5_8);
- (location__BLANK__5_5, location__BLANK__5_1);
- (location__BLANK__5_5, location__BLANK__5_2);
- (location__BLANK__5_5, location__BLANK__5_3);
- (location__BLANK__5_5, location__BLANK__5_4);
- (location__BLANK__5_5, location__BLANK__5_5);
- (location__BLANK__5_5, location__BLANK__5_6);
- (location__BLANK__5_5, location__BLANK__5_7);
- (location__BLANK__5_5, location__BLANK__5_8);
- (location__BLANK__5_6, location__BLANK__5_1);
- (location__BLANK__5_6, location__BLANK__5_2);
- (location__BLANK__5_6, location__BLANK__5_3);
- (location__BLANK__5_6, location__BLANK__5_4);
- (location__BLANK__5_6, location__BLANK__5_5);
- (location__BLANK__5_6, location__BLANK__5_6);
- (location__BLANK__5_6, location__BLANK__5_7);
- (location__BLANK__5_6, location__BLANK__5_8);
- (location__BLANK__5_7, location__BLANK__5_1);
- (location__BLANK__5_7, location__BLANK__5_2);
- (location__BLANK__5_7, location__BLANK__5_3);
- (location__BLANK__5_7, location__BLANK__5_4);
- (location__BLANK__5_7, location__BLANK__5_5);
- (location__BLANK__5_7, location__BLANK__5_6);
- (location__BLANK__5_7, location__BLANK__5_7);
- (location__BLANK__5_7, location__BLANK__5_8);
- (location__BLANK__5_8, location__BLANK__5_1);
- (location__BLANK__5_8, location__BLANK__5_2);
- (location__BLANK__5_8, location__BLANK__5_3);
- (location__BLANK__5_8, location__BLANK__5_4);
- (location__BLANK__5_8, location__BLANK__5_5);
- (location__BLANK__5_8, location__BLANK__5_6);
- (location__BLANK__5_8, location__BLANK__5_7);
- (location__BLANK__5_8, location__BLANK__5_8);
- (location__BLANK__6_1, location__BLANK__6_1);
- (location__BLANK__6_1, location__BLANK__6_2);
- (location__BLANK__6_1, location__BLANK__6_3);
- (location__BLANK__6_1, location__BLANK__6_4);
- (location__BLANK__6_1, location__BLANK__6_5);
- (location__BLANK__6_1, location__BLANK__6_6);
- (location__BLANK__6_1, location__BLANK__6_7);
- (location__BLANK__6_1, location__BLANK__6_8);
- (location__BLANK__6_2, location__BLANK__6_1);
- (location__BLANK__6_2, location__BLANK__6_2);
- (location__BLANK__6_2, location__BLANK__6_3);
- (location__BLANK__6_2, location__BLANK__6_4);
- (location__BLANK__6_2, location__BLANK__6_5);
- (location__BLANK__6_2, location__BLANK__6_6);
- (location__BLANK__6_2, location__BLANK__6_7);
- (location__BLANK__6_2, location__BLANK__6_8);
- (location__BLANK__6_3, location__BLANK__6_1);
- (location__BLANK__6_3, location__BLANK__6_2);
- (location__BLANK__6_3, location__BLANK__6_3);
- (location__BLANK__6_3, location__BLANK__6_4);
- (location__BLANK__6_3, location__BLANK__6_5);
- (location__BLANK__6_3, location__BLANK__6_6);
- (location__BLANK__6_3, location__BLANK__6_7);
- (location__BLANK__6_3, location__BLANK__6_8);
- (location__BLANK__6_4, location__BLANK__6_1);
- (location__BLANK__6_4, location__BLANK__6_2);
- (location__BLANK__6_4, location__BLANK__6_3);
- (location__BLANK__6_4, location__BLANK__6_4);
- (location__BLANK__6_4, location__BLANK__6_5);
- (location__BLANK__6_4, location__BLANK__6_6);
- (location__BLANK__6_4, location__BLANK__6_7...
[truncated message content] |
|
From: <luk...@us...> - 2011-10-23 18:48:15
|
Revision: 1613
http://toss.svn.sourceforge.net/toss/?rev=1613&view=rev
Author: lukaszkaiser
Date: 2011-10-23 18:48:09 +0000 (Sun, 23 Oct 2011)
Log Message:
-----------
Learning games tied to WebClient.
Modified Paths:
--------------
trunk/Toss/Server/LearnGame.ml
trunk/Toss/Server/LearnGame.mli
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Connect.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
Modified: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/Server/LearnGame.ml 2011-10-23 18:48:09 UTC (rev 1613)
@@ -1,3 +1,13 @@
+(* Learning games from examples. *)
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
+let struc_of_string s =
+ StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
+
+
+
let rec evens ?(acc=[0]) k =
let last = (List.hd (List.rev acc)) in
if (List.hd (List.rev acc))> k then
@@ -7,11 +17,6 @@
let odds k =
evens ~acc:[1] k
-let playFromDB pid =
- let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
- let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
- List.map (fun x -> ((int_of_string x.(4)),x.(5))) res
-
let winFormula winningStates notWinningStates =
WL.distinguish winningStates notWinningStates
@@ -108,3 +113,29 @@
MOVES [Mv2 -> 0] }
}" ^"\n" ^
"MODEL "^(Structure.str (List.hd (List.hd partylistWin0)))
+
+
+(* Get the play with given id from DB - as a sequence of structures. *)
+let playFromDB pid =
+ let dbtable select tbl = DB.get_table !DB.dbFILE ~select tbl in
+ let res = dbtable ("playid=" ^ (string_of_int pid) ) "old_states" in
+ let moveStrucs = List.map (fun x -> ((int_of_string x.(4)), x.(5))) res in
+ let prevs = List.sort (fun (a, b) (c, d) -> a - c) moveStrucs in
+ let cur = dbtable ("playid=" ^ (string_of_int pid)) "cur_states" in
+ (List.map snd prevs) @ [(List.hd cur).(5)]
+
+(* Learn a two-player win-lose-or-tie game given 4 sets of plays of another
+ game [source]: [wins0] which are now supposed to be won by Player 0,
+ [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
+ are not correct plays of the newly constructed game. *)
+let learnFromDB ~source ~wins0 ~wins1 ~tie ~wrong =
+ if !debug_level > 0 then (
+ let pl l = String.concat ", " (List.map string_of_int l) in
+ print_endline ("Learning from " ^ source ^ " w0: " ^ (pl wins0) ^ " w1: " ^
+ (pl wins1) ^" tie: "^ (pl tie) ^" wrong: "^ (pl wrong));
+ );
+ let (wins0, wins1, tie, wrong) =
+ (List.map playFromDB wins0, List.map playFromDB wins1,
+ List.map playFromDB tie, List.map playFromDB wrong) in
+ learnFromParties (List.map (List.map struc_of_string) wins0)
+ (List.map (List.map struc_of_string) wins1)
Modified: trunk/Toss/Server/LearnGame.mli
===================================================================
--- trunk/Toss/Server/LearnGame.mli 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/Server/LearnGame.mli 2011-10-23 18:48:09 UTC (rev 1613)
@@ -1,6 +1,25 @@
-val learnFromParties: Structure.structure list list -> Structure.structure list list -> string
+(** Module for learning games from examples. *)
-val move: Structure.structure -> Structure.structure
- -> Structure.structure * Structure.structure
+val move: Structure.structure -> Structure.structure ->
+ Structure.structure * Structure.structure
-val playFromDB: int -> (int*string) list
+val learnFromParties:
+ Structure.structure list list -> Structure.structure list list -> string
+
+
+(** Get the play with given id from DB - as a sequence of structure strings. *)
+val playFromDB: int -> string list
+
+(** Learn a two-player win-lose-or-tie game given 4 sets of plays of another
+ game [source]: [wins0] which are now supposed to be won by Player 0,
+ [wins1] - now won by Player 1, [tie] - now a tie, and [wrong] which
+ are not correct plays of the newly constructed game. The plays are given
+ as lists of ids to be retrieved from DB, result is a toss game string. *)
+val learnFromDB: source:string -> wins0: int list -> wins1: int list ->
+ tie: int list -> wrong: int list -> string
+
+
+(** {2 Debugging} *)
+
+(* At higher debug levels we prints out diagnostic information. *)
+val set_debug_level: int -> unit
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/Server/ReqHandler.ml 2011-10-23 18:48:09 UTC (rev 1613)
@@ -684,6 +684,16 @@
| Lexer.Parsing_error msg -> "Parsing error: " ^ msg
| _ -> "Parsing error"
else "Sorry, saving games is not allowed on this server." in
+ let learn_game game plays_str =
+ let plays = List.map (split_two ":") (split_list "$" plays_str) in
+ let plays_int = List.map (fun (a, b) -> (int_of_string a, b)) plays in
+ let (w0, other) = List.partition (fun (_, b) -> b = "0") plays_int in
+ let (w1, other) = List.partition (fun (_, b) -> b = "1") other in
+ let (tie, other) = List.partition (fun (_, b) -> b = "2") other in
+ let (wrong, _) = List.partition (fun (_, b) -> b = "3") other in
+ LearnGame.learnFromDB ~source:game
+ ~wins0:(List.map fst w0) ~wins1:(List.map fst w1)
+ ~tie:(List.map fst tie) ~wrong:(List.map fst wrong) in
let (tcmd, data) = split_two "#" msg in
let resp, new_cookies = match tcmd with
| "USERNAME" ->
@@ -753,6 +763,8 @@
let tp2 = String.sub tp_s (tp_i+1) (tp_l - tp_i - 1) in
let tp, a = (strip_ws tp0, strip_ws tp1, strip_ws tp2), get_args args_s in
move_play tp a.(0), []
+ | "LEARNGAME" ->
+ let a = get_args data in learn_game a.(0) a.(1), []
| "GETGAME" ->
let res = dbtable ("game='" ^ data ^ "'") "games" in
(match List.length res with
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/Connect.js 2011-10-23 18:48:09 UTC (rev 1613)
@@ -152,6 +152,9 @@
this.change_data = function (name, surname, email) {
return (srv ("CHANGEUSR", name +"$"+ surname +"$"+ email));
}
+ this.learn_game = function (game, plays) {
+ return (srv ("LEARNGAME", game + ", " + plays));
+ }
this.get_game = function (game) { return (srv("GETGAME", game)); }
this.set_game = function (game, toss) {
return (srv("SETGAME", game + " $_$ " + toss));
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/Main.js 2011-10-23 18:48:09 UTC (rev 1613)
@@ -95,7 +95,7 @@
paragraph.completed_button = completed_bt;
completed_bt.setAttribute("class", "completedbt");
completed_bt.setAttribute("onclick",
- "GAMESPAGE.toggle_completed ('" + game + "')");
+ "GAMESPAGE.toggle_completed ('" +game+ "')");
completed_bt.innerHTML = "Completed games (Show)";
closed_plays.appendChild (completed_bt);
@@ -103,7 +103,7 @@
paragraph.learn_button = learn_button;
learn_button.setAttribute("class", "completedbt");
learn_button.setAttribute("onclick",
- "GAMESPAGE.learn_game ('" + game + "')");
+ "GAMESPAGE.learn_game ('" + game + "')");
learn_button.innerHTML = "Learn";
learn_button.style.display = "none";
closed_plays.appendChild (learn_button);
@@ -172,7 +172,19 @@
}
GamesPage.prototype.learn_game = function (game) {
- alert ("Learning a new game - from plays of " + game + " below - soon.");
+ var lst = CONN.list_plays (game, UNAME);
+ var lst_plays = parse_list ('##', lst);
+ var plays = "$";
+ for (var i = 0; i < lst_plays.length; i++) {
+ lst_plays[i] = play_from_string (game, lst_plays[i]);
+ if (lst_plays[i].cur_state.result != null) {
+ var pid = lst_plays[i].pid;
+ var val = document.getElementById ("select_" + pid).value;
+ if (val != -1) plays += pid + ":" + val + "$";
+ }
+ }
+ var res = CONN.learn_game (game, plays)
+ alert (res);
}
GamesPage.prototype.toggle_completed = function (game) {
@@ -226,9 +238,22 @@
var bs = '<button class="obt" title="Open game ' + PLAYS[i].pid +
'" onclick="'+ "play_click('" + game + "', " + PLAYS[i].pid + ", " +
i + ')">' + pname + '</button> ';
- li.innerHTML = bs;
- if (PLAYS[i].cur_state.result != null) li.innerHTML += '<span class="list_result">' + PLAYS[i].get_formatted_result_string() + '</span>';
- // +'<a href="#" onclick="'+ "del_play('"+ fn + "')" + '">Delete</a>';
+ if (PLAYS[i].cur_state.result != null) { // completed game
+ li.innerHTML = bs;
+ li.innerHTML += '<span class="list_result">' +
+ PLAYS[i].get_formatted_result_string() + '</span>';
+ li.innerHTML += ' <span class="play_learn">' +
+ "Learning:</span>";
+ li.innerHTML +=
+ '<select class="play_select" id="select_' + PLAYS[i].pid + '">' +
+ '<option class="play_select_opt" value="-1">skip</option>' +
+ '<option class="play_select_opt" value="0">wins0</option>' +
+ '<option class="play_select_opt" value="1">wins1</option>' +
+ '<option class="play_select_opt" value="2">tie</option>' +
+ '<option class="play_select_opt" value="3">wrong</option></select>';
+ } else {
+ li.innerHTML = bs;
+ }
return (li);
}
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/Style.css 2011-10-23 18:48:09 UTC (rev 1613)
@@ -233,6 +233,33 @@
border-width: 0px;
}
+.play_select {
+ position: relative;
+ top: -0.1em;
+ color: #260314;
+ font-family: Verdana, 'TeXGyreHerosRegular', sans;
+ font-size: 0.8em;
+ background-color: #fff1d4;
+ padding: 0px;
+ margin: 0px;
+ border-color: #fff1d4;
+ border-radius: 4px;
+ -moz-border-radius: 4px;
+ border-width: 0px;
+}
+
+.play_select_opt {
+ color: #260314;
+ background-color: #fff1d4;
+ border-width: 0px;
+}
+
+.play_learn {
+ color: #260314;
+ font-family: Verdana, 'TeXGyreHerosRegular', sans;
+ font-size: 0.8em;
+}
+
.forminput, .hiddenforminput {
border-color: #fff1d4;
border-radius: 4px;
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-10-23 00:13:32 UTC (rev 1612)
+++ trunk/Toss/WebClient/index.html 2011-10-23 18:48:09 UTC (rev 1613)
@@ -177,6 +177,7 @@
<div id="news">
<h3>News</h3>
<ul id="welcome-list-news" class="welcome-list">
+<li><b>24/10/11</b> Learning games from examples in web interface</li>
<li><b>19/10/11</b> Games learning engine and first buttons in the UI</li>
<li><b>14/09/11</b> Simple editing of games added to web interface</li>
<li><b>31/07/11</b> Store date and time of moves in games</li>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-23 20:28:56
|
Revision: 1614
http://toss.svn.sourceforge.net/toss/?rev=1614&view=rev
Author: lukstafi
Date: 2011-10-23 20:28:50 +0000 (Sun, 23 Oct 2011)
Log Message:
-----------
GDL translation: small fix to translating as <not equal>.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-10-23 18:48:09 UTC (rev 1613)
+++ trunk/Toss/GGP/GDL.mli 2011-10-23 20:28:50 UTC (rev 1614)
@@ -68,6 +68,8 @@
type substitution = (string * term) list
val unify : substitution -> term list -> term list -> substitution
+val unify_args :
+ ?sb:substitution -> term array -> term array -> substitution
(** Match terms on the left to ground terms on the right, ignoring
[Const "_BLANK_"] on the right. *)
val match_nonblank : substitution -> term list -> term list -> substitution
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-10-23 18:48:09 UTC (rev 1613)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-10-23 20:28:50 UTC (rev 1614)
@@ -388,7 +388,9 @@
| _ -> false
(* A relation defined by a disjunction of differences on all paths of
- a state term. *)
+ a state term. Disjunctions can have common part, which is
+ identified by unification of clause heads alone (no matching of
+ local variables). *)
let is_distinctcell c_paths partition cls =
try
List.iter (fun (_, body) ->
@@ -426,6 +428,25 @@
pv1 = pv2)
v1
with Not_found -> false
+
+let try_if_common cls =
+ try
+ let bodies = List.map
+ (fun (_, body) -> List.filter (not -| distinct_lit) body)
+ cls in
+ let acc_args, all_args = match List.map fst cls with
+ | hd::tl -> hd, tl | _ -> assert false in
+ let sb, acc_args = List.fold_left
+ (fun (sb, acc_args) args ->
+ let sb = unify_args ~sb args acc_args in
+ sb, Array.map (subst sb) acc_args)
+ ([], acc_args) all_args in
+ let bodies = List.map
+ (subst_literals sb -| Aux.unique_sorted) bodies in
+ (match Aux.unique_sorted bodies with
+ | [body] -> true, [acc_args, body]
+ | _ -> raise Not_found)
+ with Not_found | Invalid_argument _ -> false, cls
let build_defrels data clauses =
@@ -449,9 +470,8 @@
let distinctcell, r_clauses =
if d_arity = 2 && (* DEBUG *) drel = "distinctcell" &&
is_distinctcell data.c_paths partition r_clauses
- then true,
- List.map (fun (args, body) ->
- args, List.filter (not -| distinct_lit) body) r_clauses
+ then
+ try_if_common r_clauses
else false, r_clauses in
(* {{{ log entry *)
if !debug_level > 3 then (
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-10-23 18:48:09 UTC (rev 1613)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-10-23 20:28:50 UTC (rev 1614)
@@ -17,23 +17,10 @@
defined relation: a Toss defined relation (i.e. does not normally
occur in the structure)
- TODO: filter out legal tuples that are not statically satisfiable
-
TODO: perform "fluent path prediate inversion" by transforming
single-argument state terms into two arguments of a "value" state
term.
- TODO-FIXME: add "preserved fluents" check, make rewrite rules
- remove fluents that are not covered by any frame clause. (Erasure
- clauses are only built from frame clauses, i.e. they handle only
- fluents that are preserved elsewhere.) Unfortunately it cannot be
- assumed that an element holding a non-preserved fluent is
- different from an element where the fluent is to be added! Extract
- one variable under non-preserved fluent from the precondition to
- LHS, if present, and duplicate the rewrite rule generating one
- copy where the variable is equal to the "target" variable (head of
- the "next" clause).
-
TODO-FIXME: limit translation as concurrent games to cases where
rules do not check fluents affected by other rules to be performed
concurrently.
Modified: trunk/Toss/GGP/tests/pacman3p-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-raw.toss 2011-10-23 18:48:09 UTC (rev 1613)
+++ trunk/Toss/GGP/tests/pacman3p-raw.toss 2011-10-23 20:28:50 UTC (rev 1614)
@@ -1,15 +1,10 @@
REL distinctcell(v0, v1) =
(not v0 = v1 and
- (ex location__BLANK__x33_y33, location__BLANK__x34_y34
- (v0 = location__BLANK__x33_y33 and v1 = location__BLANK__x34_y34 and
- cell(location__BLANK__x33_y33) and cell(location__BLANK__x34_y34) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x34_y34) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x33_y33)) or
- ex location__BLANK__x35_y35, location__BLANK__x36_y36
- (v0 = location__BLANK__x35_y35 and v1 = location__BLANK__x36_y36 and
- cell(location__BLANK__x35_y35) and cell(location__BLANK__x36_y36) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x36_y36) and
- location__BLANK___BLANK___BLANK_(location__BLANK__x35_y35))))
+ ex location__BLANK__x33_y33, location__BLANK__x34_y34
+ (v0 = location__BLANK__x33_y33 and v1 = location__BLANK__x34_y34 and
+ cell(location__BLANK__x33_y33) and cell(location__BLANK__x34_y34) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x33_y33) and
+ location__BLANK___BLANK___BLANK_(location__BLANK__x34_y34)))
REL nextcell__east(v0, v1) =
ex location__BLANK__x24_y24, location__BLANK__xnew1_y24
(v0 = location__BLANK__x24_y24 and v1 = location__BLANK__xnew1_y24 and
Modified: trunk/Toss/GGP/tests/pacman3p-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/pacman3p-simpl.toss 2011-10-23 18:48:09 UTC (rev 1613)
+++ trunk/Toss/GGP/tests/pacman3p-simpl.toss 2011-10-23 20:28:50 UTC (rev 1614)
@@ -1,9 +1,6 @@
REL distinctcell(v0, v1) =
- (not v0 = v1 and
- ((location__BLANK___BLANK___BLANK_(v0) and
- location__BLANK___BLANK___BLANK_(v1)) or
- (location__BLANK___BLANK___BLANK_(v0) and
- location__BLANK___BLANK___BLANK_(v1))))
+ (location__BLANK___BLANK___BLANK_(v0) and
+ location__BLANK___BLANK___BLANK_(v1) and not v0 = v1)
REL nextcell__east(v0, v1) =
(R(v0, v1) and location__BLANK___BLANK___BLANK_(v0) and
location__BLANK___BLANK___BLANK_(v1))
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-10-23 18:48:09 UTC (rev 1613)
+++ trunk/Toss/www/reference/reference.tex 2011-10-23 20:28:50 UTC (rev 1614)
@@ -2405,6 +2405,24 @@
in the previous section. The move and player markers are erased by the
game state transition rule of the ``environment'' player.
+\subsection{Translation-specific Simplification}
+
+In Section~\ref{sec-game-simpl}, we describe general game
+simplification in Toss. Here, we describe parts of the translation
+process that were added to make the translation result more compact
+and efficient.
+
+\paragraph{Introducing disequalities.} When a defined relation is
+built from clauses that contain a single \texttt{distinct} positive
+literal each, when the defined relation is translated as a binary
+relation, a disjunction of those \texttt{distinct} literals would be
+semantically equivalent to a disequality of the relation arguments,
+and the remaining literals are the same for all bodies (modulo
+renaming of variables), the disequality is introduced to the
+translation and the \texttt{distinct} literals are removed.
+
+\paragraph{}
+
\section{Game Simplification in Toss} \label{sec-game-simpl}
Games automatically translated from GDL, as described above, are verbose
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-10-24 21:38:38
|
Revision: 1615
http://toss.svn.sourceforge.net/toss/?rev=1615&view=rev
Author: lukstafi
Date: 2011-10-24 21:38:29 +0000 (Mon, 24 Oct 2011)
Log Message:
-----------
GDL translation: pruning next clause literals that are redundant wrt. legal clause literals; reverting from using Sum to set the counter element. Solver: exposing the ability to provide the assignment of free variables to get_real_val. ContinuousRule: computing the update (of functions) using the assignment on which the rewrite is performed.
Modified Paths:
--------------
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/connect4-raw.toss
trunk/Toss/GGP/tests/connect4-simpl.toss
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/AssignmentSet.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/Arena/ContinuousRule.ml 2011-10-24 21:38:29 UTC (rev 1615)
@@ -175,8 +175,11 @@
(lhs, FormulaSubst.subst_real ["t", Formula.Const !time] rhs)) upd in
(* we don't need to use val_map because !last_struc contains the
evolved values *)
+ let asg = AssignmentSet.fo_assgn_of_list
+ (List.map (fun (e, a) ->
+ `FO (left_elname e), a) m) in
let upd_vals = List.map
- (fun (lhs,expr) -> lhs, Solver.M.get_real_val expr !last_struc)
+ (fun (lhs,expr) -> lhs, Solver.M.get_real_val ~asg expr !last_struc)
upd in
(* we pass the evolved structure to discrete rewriting, so that
function values can be copied to new elements in case they are
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/Formula/Aux.ml 2011-10-24 21:38:29 UTC (rev 1615)
@@ -229,6 +229,12 @@
try f hd :: tl
with Not_found -> tl
+let rec find_try f = function
+ | [] -> raise Not_found
+ | hd::tl ->
+ try f hd
+ with Not_found -> find_try f tl
+
let rec fold_left_try f accu l =
match l with
[] -> accu
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/Formula/Aux.mli 2011-10-24 21:38:29 UTC (rev 1615)
@@ -142,6 +142,10 @@
raise [Not_found]. Therefore [map_try] call cannot raise [Not_found]. *)
val map_try : ('a -> 'b) -> 'a list -> 'b list
+(** Find the first element of the list on which the function does not
+ raise [Not_found] and return its result. Raises [Not_found] if
+ the function results in [Not_found] on all elements. *)
+val find_try : ('a -> 'b) -> 'a list -> 'b
(** Fold [f] over the list collecting results whose computation does
not raise [Not_found]. Therefore [fold_left_try] call cannot raise
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/Formula/AuxTest.ml 2011-10-24 21:38:29 UTC (rev 1615)
@@ -124,7 +124,7 @@
) [] ["a",1; "b",2; "b",1; "a",1])
);
- "unsome, map_try" >::
+ "unsome, map_try, find_try" >::
(fun () ->
assert_equal ~printer:(fun x->x)
"x" (Aux.unsome (Some "x"));
@@ -138,6 +138,12 @@
assert_equal ~printer:(String.concat "; ")
["a";"b";"d"]
(Aux.map_try f [`A;`B;`C;`D]);
+
+ let f = function `A -> "a" | `B -> "b" | `C -> raise Not_found
+ | `D -> "d" in
+ assert_equal ~printer:(fun x->x)
+ "a"
+ (Aux.find_try f [`C;`A;`B;`C;`D]);
);
"product, all_ntuples, concat_foldr" >::
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/GDL.mli 2011-10-24 21:38:29 UTC (rev 1615)
@@ -76,6 +76,7 @@
(** Check for equality modulo ground terms on the right. *)
val mask_blank : term list -> term list -> bool
val unify_all : substitution -> term list -> substitution
+val unify_rels : ?sb:substitution -> rel_atom -> rel_atom -> substitution
val rels_unify : rel_atom -> rel_atom -> bool
val subst : substitution -> term -> term
val subst_consts : substitution -> term -> term
@@ -84,6 +85,7 @@
val subst_literal : substitution -> literal -> literal
val subst_literals : substitution -> literal list -> literal list
val subst_clause : substitution -> clause -> clause
+val subst_consts_literals : substitution -> literal list -> literal list
val subst_consts_clause : substitution -> clause -> clause
module Tuples : Set.S with type elt = term array
@@ -176,6 +178,7 @@
val atom_str : atom -> string
val rel_atom_str : rel_atom -> string
+val rel_atoms_str : rel_atom list -> string
val def_str : string * def_branch list -> string
val literal_str : literal -> string
val literals_str : literal list -> string
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-10-24 21:38:29 UTC (rev 1615)
@@ -205,9 +205,8 @@
let cc = Formula.Fun (c, counter_v) and ct = transl_c t in
if cc = ct then []
else [Formula.RealExpr (
- Formula.Sum ([counter_v], Formula.Rel (counter_n, [|counter_v|]),
- minus cc ct)
- , sign_op)] in
+ (* Formula.Sum ([counter_v], Formula.Rel (counter_n, [|counter_v|]),) *)
+ minus cc ct, sign_op)] in
let transl_numfun_rel sign rel t1 t2 =
let sign_op =
if sign then Formula.EQZero else Formula.NEQZero in
@@ -215,9 +214,8 @@
FormulaSubst.subst_real [":x", transl_c t1]
(List.assoc rel data.num_functions) in
[Formula.RealExpr (
- Formula.Sum ([counter_v], Formula.Rel (counter_n, [|counter_v|]),
- minus f_result (transl_c t2))
- , sign_op)] in
+ (* Formula.Sum ([counter_v], Formula.Rel (counter_n, [|counter_v|]),) *)
+ minus f_result (transl_c t2), sign_op)] in
let rec aux = function
| Pos (True (Func (c, [|t|])))
when List.mem c data.counters &&
@@ -373,12 +371,23 @@
if pos_vars = [] then base_part
else Formula.Ex ((pos_vars :> Formula.var list), base_part)
+let has_counter t =
+ FormulaMap.fold_formula
+ {FormulaMap.make_fold ( || ) false with
+ FormulaMap.fold_Fun = (fun _ v -> v = counter_v)} t
+
(* Translate a disjunction of conjunctions of literals (and disjs of lits). *)
-let translate data disj =
+let translate ?(counter_guard=true) data disj =
let disj = separate_disj data.counters disj in
- Formula.Or (List.map (fun (rels_phi, pos_state, neg_state) ->
- transl_disjunct data rels_phi pos_state neg_state []
- ) disj)
+ let res =
+ Formula.Or (List.map (fun (rels_phi, pos_state, neg_state) ->
+ transl_disjunct data rels_phi pos_state neg_state []
+ ) disj) in
+ if counter_guard && has_counter res
+ then Formula.Ex
+ ([counter_v],
+ Formula.And [Formula.Rel (counter_n, [|counter_v|]); res])
+ else res
(* **************************************** *)
(* {3 Build defined relations.} *)
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-10-24 21:38:29 UTC (rev 1615)
@@ -24,8 +24,12 @@
string list -> GDL.literal list list ->
(GDL.literal list * GDL.literal list * GDL.literal list) list
+(** Translate a disjunction of conjunctions of literals (and disjs of
+ lits). [counter_guard] is set to false, do not introduce
+ "gdl__counter(gdl__counter)" atom. *)
val translate :
- transl_data -> GDL.literal list list -> Formula.formula
+ ?counter_guard:bool -> transl_data -> GDL.literal list list ->
+ Formula.formula
val build_defrels :
transl_data -> GDL.clause list ->
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-10-24 21:38:29 UTC (rev 1615)
@@ -80,6 +80,16 @@
rule needs to match in at least one generated state to be kept). *)
let playouts_for_rule_filtering = ref 4
+(** When [filter_possibly_redundant] is false, only whole groups of
+ variable-sharing "next" clause literals that together are subsumed
+ by "legal" clause literals are filtered out. With
+ [filter_possibly_redundant] set to true, subsumed "next" literals
+ are removed, even though they may be intended for different
+ elements as witnessed by remaining "next" clause literals (which
+ get their variables renamed to match the "legal" clause
+ literals). *)
+let filter_possibly_redundant = ref true
+
let env_player = Const "environment"
type tossrule_data = {
@@ -1671,9 +1681,126 @@
List.map (add_erasure_clauses f_paths) move_tups
+(* Partition literals into connected components where edges are
+ shared variables. *)
+let partition_lits lits =
+ let parts = List.fold_left
+ (fun parts lit ->
+ let l_vars = literals_vars [lit] in
+ let more_parts, cur_parts = List.partition
+ (fun (_, p_vars) ->
+ Aux.Strings.is_empty (Aux.Strings.inter l_vars p_vars))
+ parts in
+ let cur_part = List.fold_left
+ (fun (c_lits, c_vars) (p_lits, p_vars) ->
+ c_lits @ p_lits, Aux.Strings.union c_vars p_vars)
+ ([lit], l_vars) cur_parts in
+ cur_part::more_parts)
+ [] lits in
+ List.map fst parts
+
+let encode_lit = function
+ | Pos a ->
+ let rel, args = rel_of_atom a in
+ "Pos "^rel, args
+ | Neg a ->
+ let rel, args = rel_of_atom a in
+ "Neg "^rel, args
+ | Disj _ -> raise Not_found
+
+
+let filter_poss_redundant legal_lits body =
+ let legal_lits_enc = Aux.map_try encode_lit legal_lits in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "filter_poss_redundant:\nlegal_lits=%s\nbody=%s\n\n%!"
+ (rel_atoms_str legal_lits_enc) (literals_str body)
+ );
+ (* }}} *)
+ List.fold_right
+ (fun lit (sb, keep) ->
+ try
+ let lit_enc = encode_lit lit in
+ let sb =
+ Aux.find_try (unify_rels ~sb lit_enc) legal_lits_enc in
+ sb, keep
+ with Not_found -> sb, lit::keep)
+ body ([], [])
+
+(* We remove literals in [body] that are considered subsumed by
+ [legal_lits]. We find the most coarse partition of [body] such that
+ different classes do not share variables. A group of [body]
+ literals is considered subsumed if its every literal unifies with a
+ [legal_lits] literal under a common substitution. The current
+ algorithm is greedy in that we only consider the first matching
+ legal literal for a given [body] literal. We also ignore
+ disjunctions.
+
+ If [filter_possibly_redundant] is true, rather than processing
+ [body] literals in bulk, check each literal separately, removing
+ those that unify with some "legal" clause literal, even though they
+ may be intended for different elements as witnessed by remaining
+ "next" clause literals. *)
+let filter_redundant legal_lits body =
+ if !filter_possibly_redundant
+ then filter_poss_redundant legal_lits body
+ else
+ let parts = partition_lits body in
+ let legal_lits_enc = Aux.map_try encode_lit legal_lits in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "filter_redundant:\nlegal_lits=%s\nbody=%s\n\n%!"
+ (rel_atoms_str legal_lits_enc) (literals_str body)
+ );
+ (* }}} *)
+ let sbs, keep_parts = Aux.partition_map
+ (fun part ->
+ try
+ let sb = List.fold_left
+ (fun sb lit ->
+ let lit_enc = encode_lit lit in
+ Aux.find_try (unify_rels ~sb lit_enc) legal_lits_enc)
+ [] part in
+ Aux.Left sb
+ with Not_found -> Aux.Right part)
+ parts in
+ List.concat sbs, List.concat keep_parts
+
+(* Filter the "next" clauses removing conditions common with legal
+ clauses, pass the result to [rule_cases]. *)
let add_legal_cond counters num_functors static_rels testground
- program playout_states (legal_tup, next_cls) =
+ program playout_states (legal_tup, next_cls) =
let legal_tup, legal_conds = List.split legal_tup in
+ (* We fix the variables in the legal conditions because we will
+ search for "embeddings" of parts of legal conditions in "next"
+ clause bodies. *)
+ let legal_lits = List.concat legal_conds in
+ let fixed_vars = terms_vars (Array.of_list legal_tup) in
+ let fixed_vars = Aux.Strings.elements
+ (Aux.Strings.union fixed_vars (literals_vars legal_lits)) in
+ let var_to_fixed = List.map
+ (fun v -> v, Const v) fixed_vars in
+ let legal_lits = subst_literals var_to_fixed legal_lits in
+ let next_cls = List.map (* fix [legal_tup] vars in "next" *)
+ (fun (head, req, body) ->
+ subst_consts var_to_fixed head, req,
+ subst_consts_literals var_to_fixed body)
+ next_cls in
+ (* Filter-out redundant conditions. Note that unfixed variables in
+ "next" clauses are local to clauses. *)
+ let next_cls = List.map
+ (fun (head, req, body) ->
+ let sb, body = filter_redundant legal_lits body in
+ subst sb head, req, subst_literals sb body)
+ next_cls in
+ let fixed_to_var = List.map
+ (fun v -> v, Var v) fixed_vars in
+ let next_cls = List.map
+ (fun (head, req, body) ->
+ subst_consts fixed_to_var head, req,
+ subst_consts_literals fixed_to_var body)
+ next_cls in
+
let legal_cls = List.map (* required clauses *)
(fun body -> ignore_rhs, true, body) legal_conds in
List.map
@@ -2034,10 +2161,13 @@
List.fold_left comp_f xvar path
| _ -> assert false
-let transl_cond_updates transl_data num_functions cond_updates =
+let transl_cond_updates transl_data rule_elems num_functions cond_updates =
let cond_update (cond, update) =
let update = transl_update_path num_functions update in
- let cond = TranslateFormula.translate transl_data [cond] in
+ let cond = FormulaOps.del_vars_quant
+ (List.map Formula.fo_var_of_string rule_elems :> Formula.var list)
+ (TranslateFormula.translate
+ ~counter_guard:false transl_data [cond]) in
Formula.Times (Formula.Char cond, update) in
match cond_updates with
| [] -> assert false
@@ -2156,10 +2286,9 @@
(* a trick to force instantiating the counter variable -- note
that variable with the same name is also part of the
precondition *)
- Formula.Sum (
- [`FO counter_n],
- Formula.Rel (counter_n, [|`FO counter_n|]),
- transl_cond_updates transl_data num_functions cond_updates))
+ (*Formula.Sum ([`FO counter_n],
+ Formula.Rel (counter_n, [|`FO counter_n|]),) *)
+ transl_cond_updates transl_data struc_elems num_functions cond_updates)
counter_cls in
let rule =
ContinuousRule.make_rule signat [] discrete
@@ -2392,7 +2521,7 @@
match counter_goal_cls with
| [] -> Formula.Const 0.
| cond_upds ->
- transl_cond_updates transl_data num_functions cond_upds in
+ transl_cond_updates transl_data [] num_functions cond_upds in
if num_payoff = Formula.Const 0.
then counter_payoff
else if counter_payoff = Formula.Const 0.
Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/TranslateGame.mli 2011-10-24 21:38:29 UTC (rev 1615)
@@ -17,6 +17,16 @@
rule needs to match in at least one generated state to be kept). *)
val playouts_for_rule_filtering : int ref
+(** When [filter_possibly_redundant] is false, only whole groups of
+ variable-sharing "next" clause literals that together are subsumed
+ by "legal" clause literals are filtered out. With
+ [filter_possibly_redundant] set to true, subsumed "next" literals
+ are removed, even though they may be intended for different
+ elements as witnessed by remaining "next" clause literals (which
+ get their variables renamed to match the "legal" clause
+ literals). *)
+val filter_possibly_redundant : bool ref
+
type tossrule_data = {
legal_tuple : GDL.term array;
(* the "legal"/"does" term of the player that performs the move
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-10-24 21:38:29 UTC (rev 1615)
@@ -312,22 +312,31 @@
"connect4" >::
(fun () ->
+ (* Works with [filter_possibly_redundant] both true and false. *)
+ let old_filter_possibly_redundant =
+ !TranslateGame.filter_possibly_redundant in
+ TranslateGame.filter_possibly_redundant := false;
game_test_case ~game_name:"connect4" ~player:"white"
~own_plnum:0 ~opponent_plnum:1
~loc0_rule_name:"drop_c11_noop"
~loc0_emb:[
- "cell_c11_h4__BLANK_", "cell_2_1__BLANK_";
+ "cell_c11_y18__BLANK_", "cell_2_1__BLANK_";
"control__BLANK_", "control__BLANK_"]
~loc0_move:"(drop 2)" ~loc0_noop:"noop"
~loc1:1 ~loc1_rule_name:"noop_drop_c12"
~loc1_emb:[
- "cell_c12_h6__BLANK_", "cell_2_2__BLANK_";
+ "cell_c12_y20__BLANK_", "cell_2_2__BLANK_";
"control__BLANK_", "control__BLANK_"]
- ~loc1_noop:"noop" ~loc1_move:"(drop 2)"
+ ~loc1_noop:"noop" ~loc1_move:"(drop 2)";
+ TranslateGame.filter_possibly_redundant := old_filter_possibly_redundant;
);
"pacman3p" >::
(fun () ->
+ (* Works only with [filter_possibly_redundant] true. *)
+ let old_filter_possibly_redundant =
+ !TranslateGame.filter_possibly_redundant in
+ TranslateGame.filter_possibly_redundant := true;
simult_test_case ~game_name:"pacman3p" ~player:"pacman"
~plnum:1 (* 0 is environment! *)
~moves:[|"(move east)"; "(move nowhere)"; "(move nowhere)"|]
@@ -335,7 +344,6 @@
"move_east", [
"gdl__counter", "gdl__counter";
"location__BLANK__x10_y10", "location__BLANK__6_3";
- "location__BLANK__x9_y9", "location__BLANK__5_3";
"location__BLANK__x_y", "location__BLANK__5_3";
"synch_control_", "synch_control_"];
"move_nowhere0", [
@@ -346,6 +354,7 @@
"location__BLANK__x13_y13", "location__BLANK__5_6";
"location__BLANK__x14_y14", "location__BLANK__5_6";
"synch_control_", "synch_control_"]|];
+ TranslateGame.filter_possibly_redundant := old_filter_possibly_redundant;
);
]
@@ -360,25 +369,18 @@
let a () =
- (* set_debug_level 4; *)
- simult_test_case ~game_name:"pacman3p" ~player:"pacman"
- ~plnum:1 (* 0 is environment! *)
- ~moves:[|"(move east)"; "(move nowhere)"; "(move nowhere)"|]
- ~rules_and_embs:[|
- "move_east", [
- "gdl__counter", "gdl__counter";
- "location__BLANK__x10_y10", "location__BLANK__6_3";
- "location__BLANK__x9_y9", "location__BLANK__5_3";
- "location__BLANK__x_y", "location__BLANK__5_3";
- "synch_control_", "synch_control_"];
- "move_nowhere0", [
- "location__BLANK__x11_y11", "location__BLANK__4_6";
- "location__BLANK__x12_y12", "location__BLANK__4_6";
- "synch_control_", "synch_control_"];
- "move_nowhere1", [
- "location__BLANK__x13_y13", "location__BLANK__5_6";
- "location__BLANK__x14_y14", "location__BLANK__5_6";
- "synch_control_", "synch_control_"]|];
+ game_test_case ~game_name:"connect4" ~player:"white"
+ ~own_plnum:0 ~opponent_plnum:1
+ ~loc0_rule_name:"drop_c11_noop"
+ ~loc0_emb:[
+ "cell_c11_y18__BLANK_", "cell_2_1__BLANK_";
+ "control__BLANK_", "control__BLANK_"]
+ ~loc0_move:"(drop 2)" ~loc0_noop:"noop"
+ ~loc1:1 ~loc1_rule_name:"noop_drop_c12"
+ ~loc1_emb:[
+ "cell_c12_y20__BLANK_", "cell_2_2__BLANK_";
+ "control__BLANK_", "control__BLANK_"]
+ ~loc1_noop:"noop" ~loc1_move:"(drop 2)";
(* failwith "tested"; *)
()
Modified: trunk/Toss/GGP/tests/connect4-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/connect4-raw.toss 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/tests/connect4-raw.toss 2011-10-24 21:38:29 UTC (rev 1615)
@@ -262,80 +262,54 @@
(line__r() and true) or (line__w() and true) or (not open() and true)
PLAYERS white, red
RULE drop_c11_noop:
- [cell_c11_h4__BLANK_, control__BLANK_ |
+ [cell_c11_y18__BLANK_, control__BLANK_ |
_opt_cell_2b (control__BLANK_);
- _opt_cell_2dirt {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_cell_2r {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_cell_2w {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_control_0red {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_control_0white (cell_c11_h4__BLANK_); cell_2b (cell_c11_h4__BLANK_);
- cell__BLANK___BLANK___BLANK_ (cell_c11_h4__BLANK_);
+ _opt_cell_2dirt {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_cell_2r {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_cell_2w {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_control_0red {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_control_0white (cell_c11_y18__BLANK_);
+ cell_2b (cell_c11_y18__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_c11_y18__BLANK_);
control_0white (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
- [cell_c11_h4__BLANK_, control__BLANK_ |
- cell_2w (cell_c11_h4__BLANK_); control_0red (control__BLANK_) |
- ] emb cell_2b, cell_2dirt, cell_2r, cell_2w, control_0red, control_0white
+ [cell_c11_y18__BLANK_, control__BLANK_ |
+ cell_2w (cell_c11_y18__BLANK_); control_0red (control__BLANK_) |
+ ]
+ emb cell_2b, cell_2dirt, cell_2r, cell_2w, control_0red, control_0white
pre
(not terminal() and
- ex cell_c11_y17__BLANK_, cell_c11_h3__BLANK_, cell_c11_y18__BLANK_
- (cell__BLANK___BLANK___BLANK_(cell_c11_h3__BLANK_) and
- filled(cell_c11_h3__BLANK_) and
- cell__BLANK___BLANK___BLANK_(cell_c11_y17__BLANK_) and
- filled(cell_c11_y17__BLANK_) and cell_2b(cell_c11_y18__BLANK_) and
- cell__BLANK___BLANK___BLANK_(cell_c11_y18__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_h3__BLANK_, cell_c11_h4__BLANK_) and
- succ__cell_1__cell_1(cell_c11_h3__BLANK_, cell_c11_h4__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_h3__BLANK_, cell_c11_y17__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_h3__BLANK_, cell_c11_y18__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_h4__BLANK_, cell_c11_h3__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_h4__BLANK_, cell_c11_y17__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_h4__BLANK_, cell_c11_y18__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_y17__BLANK_, cell_c11_h3__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_y17__BLANK_, cell_c11_h4__BLANK_) and
+ ex cell_c11_y17__BLANK_
+ (cell__BLANK___BLANK___BLANK_(cell_c11_y17__BLANK_) and
+ filled(cell_c11_y17__BLANK_) and
EQ___cell_0__cell_0(cell_c11_y17__BLANK_, cell_c11_y18__BLANK_) and
succ__cell_1__cell_1(cell_c11_y17__BLANK_, cell_c11_y18__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_y18__BLANK_, cell_c11_h3__BLANK_) and
- EQ___cell_0__cell_0(cell_c11_y18__BLANK_, cell_c11_h4__BLANK_) and
EQ___cell_0__cell_0(cell_c11_y18__BLANK_, cell_c11_y17__BLANK_)))
RULE noop_drop_c12:
- [cell_c12_h6__BLANK_, control__BLANK_ |
+ [cell_c12_y20__BLANK_, control__BLANK_ |
_opt_cell_2b (control__BLANK_);
- _opt_cell_2dirt {cell_c12_h6__BLANK_; control__BLANK_};
- _opt_cell_2r {cell_c12_h6__BLANK_; control__BLANK_};
- _opt_cell_2w {cell_c12_h6__BLANK_; control__BLANK_};
- _opt_control_0red (cell_c12_h6__BLANK_);
- _opt_control_0white {cell_c12_h6__BLANK_; control__BLANK_};
- cell_2b (cell_c12_h6__BLANK_);
- cell__BLANK___BLANK___BLANK_ (cell_c12_h6__BLANK_);
+ _opt_cell_2dirt {cell_c12_y20__BLANK_; control__BLANK_};
+ _opt_cell_2r {cell_c12_y20__BLANK_; control__BLANK_};
+ _opt_cell_2w {cell_c12_y20__BLANK_; control__BLANK_};
+ _opt_control_0red (cell_c12_y20__BLANK_);
+ _opt_control_0white {cell_c12_y20__BLANK_; control__BLANK_};
+ cell_2b (cell_c12_y20__BLANK_);
+ cell__BLANK___BLANK___BLANK_ (cell_c12_y20__BLANK_);
control_0red (control__BLANK_); control__BLANK_ (control__BLANK_)
|
] ->
- [cell_c12_h6__BLANK_, control__BLANK_ |
- cell_2r (cell_c12_h6__BLANK_); control_0white (control__BLANK_) |
+ [cell_c12_y20__BLANK_, control__BLANK_ |
+ cell_2r (cell_c12_y20__BLANK_); control_0white (control__BLANK_) |
]
emb cell_2b, cell_2dirt, cell_2r, cell_2w, control_0red, control_0white
pre
(not terminal() and
- ex cell_c12_y19__BLANK_, cell_c12_h5__BLANK_, cell_c12_y20__BLANK_
- (cell__BLANK___BLANK___BLANK_(cell_c12_h5__BLANK_) and
- filled(cell_c12_h5__BLANK_) and
- cell__BLANK___BLANK___BLANK_(cell_c12_y19__BLANK_) and
- filled(cell_c12_y19__BLANK_) and cell_2b(cell_c12_y20__BLANK_) and
- cell__BLANK___BLANK___BLANK_(cell_c12_y20__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_h5__BLANK_, cell_c12_h6__BLANK_) and
- succ__cell_1__cell_1(cell_c12_h5__BLANK_, cell_c12_h6__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_h5__BLANK_, cell_c12_y19__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_h5__BLANK_, cell_c12_y20__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_h6__BLANK_, cell_c12_h5__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_h6__BLANK_, cell_c12_y19__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_h6__BLANK_, cell_c12_y20__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_y19__BLANK_, cell_c12_h5__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_y19__BLANK_, cell_c12_h6__BLANK_) and
+ ex cell_c12_y19__BLANK_
+ (cell__BLANK___BLANK___BLANK_(cell_c12_y19__BLANK_) and
+ filled(cell_c12_y19__BLANK_) and
EQ___cell_0__cell_0(cell_c12_y19__BLANK_, cell_c12_y20__BLANK_) and
succ__cell_1__cell_1(cell_c12_y19__BLANK_, cell_c12_y20__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_y20__BLANK_, cell_c12_h5__BLANK_) and
- EQ___cell_0__cell_0(cell_c12_y20__BLANK_, cell_c12_h6__BLANK_) and
EQ___cell_0__cell_0(cell_c12_y20__BLANK_, cell_c12_y19__BLANK_)))
LOC 0 {
Modified: trunk/Toss/GGP/tests/connect4-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect4-simpl.toss 2011-10-23 20:28:50 UTC (rev 1614)
+++ trunk/Toss/GGP/tests/connect4-simpl.toss 2011-10-24 21:38:29 UTC (rev 1615)
@@ -103,58 +103,47 @@
R: EQ___cell_0__cell_0__AND__succ__cell_1__cell_1,
R1: succ__cell_0__cell_0__AND_INV__succ__cell_1__cell_1
RULE drop_c11_noop:
- [cell_c11_h4__BLANK_, control__BLANK_ |
+ [cell_c11_y18__BLANK_, control__BLANK_ |
_opt_cell_2b (control__BLANK_);
- _opt_cell_2dirt {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_cell_2r {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_cell_2w {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_control_0red {cell_c11_h4__BLANK_; control__BLANK_};
- _opt_control_0white (cell_c11_h4__BLANK_); cell_2b (cell_c11_h4__BLANK_);
- control_0white (control__BLANK_); control__BLANK_ (control__BLANK_);
- number__cell_1 (cell_c11_h4__BLANK_)
+ _opt_cell_2dirt {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_cell_2r {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_cell_2w {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_control_0red {cell_c11_y18__BLANK_; control__BLANK_};
+ _opt_control_0white (cell_c11_y18__BLANK_);
+ cell_2b (cell_c11_y18__BLANK_); control_0white (control__BLANK_);
+ control__BLANK_ (control__BLANK_); number__cell_1 (cell_c11_y18__BLANK_)
|
] ->
- [cell_c11_h4__BLANK_, control__BLANK_ |
- cell_2w (cell_c11_h4__BLANK_); control_0red (control__BLANK_) |
- ] emb cell_2b, cell_2dirt, cell_2r, cell_2w, control_0red, control_0white
+ [cell_c11_y18__BLANK_, control__BLANK_ |
+ cell_2w (cell_c11_y18__BLANK_); control_0red (control__BLANK_) |
+ ]
+ emb cell_2b, cell_2dirt, cell_2r, cell_2w, control_0red, control_0white
pre
(not terminal() and
- ex cell_c11_y17__BLANK_, cell_c11_h3__BLANK_, cell_c11_y18__BLANK_
- (R(cell_c11_h3__BLANK_, cell_c11_h4__BLANK_) and R(cell_c11_y17__BLANK_,
- cell_c11_y18__BLANK_) and EQ___cell_0__cell_0(cell_c11_h4__BLANK_,
- cell_c11_y17__BLANK_) and EQ___cell_0__cell_0(cell_c11_h3__BLANK_,
- cell_c11_y17__BLANK_) and number__cell_1(cell_c11_h3__BLANK_) and
- number__cell_1(cell_c11_y17__BLANK_) and
- number__cell_1(cell_c11_y18__BLANK_) and
- filled(cell_c11_h3__BLANK_) and filled(cell_c11_y17__BLANK_) and
- cell_2b(cell_c11_y18__BLANK_)))
+ ex cell_c11_y17__BLANK_
+ (R(cell_c11_y17__BLANK_, cell_c11_y18__BLANK_) and
+ number__cell_1(cell_c11_y17__BLANK_) and filled(cell_c11_y17__BLANK_)))
RULE noop_drop_c12:
- [cell_c12_h6__BLANK_, control__BLANK_ |
+ [cell_c12_y20__BLANK_, control__BLANK_ |
_opt_cell_2b (control__BLANK_);
- _opt_cell_2dirt {cell_c12_h6__BLANK_; control__BLANK_};
- _opt_cell_2r {cell_c12_h6__BLANK_; control__BLANK_};
- _opt_ce...
[truncated message content] |
|
From: <luk...@us...> - 2011-10-25 21:41:01
|
Revision: 1617
http://toss.svn.sourceforge.net/toss/?rev=1617&view=rev
Author: lukstafi
Date: 2011-10-25 21:40:52 +0000 (Tue, 25 Oct 2011)
Log Message:
-----------
GDL translation: turning single-argument state term functions with domain greater than three into value_ terms, e.g. (x 10) into (value_ x 10); more refined handling of move clauses: not all containing a matching <does> are required; bug fix in finding fluent paths. GDL tests: asteroids-scrambled not using numbers for position and velocity (weak integration of counters and structural parts); test fails due to current shortcomings in erasure and unframed fluents handling.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
Added Paths:
-----------
trunk/Toss/GGP/examples/asteroids-scrambled.gdl
trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss
trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-10-25 08:24:28 UTC (rev 1616)
+++ trunk/Toss/Arena/Arena.ml 2011-10-25 21:40:52 UTC (rev 1617)
@@ -91,13 +91,20 @@
).ContinuousRule.discrete.DiscreteRule.lhs_struc in
try
List.map (fun (lhs_e, m_e) ->
- Structure.find_elem lhs lhs_e, Structure.find_elem state.struc m_e)
+ (try Structure.find_elem lhs lhs_e
+ with Not_found -> Printf.printf "NF lhs_e=%s\n%!" lhs_e;
+ raise Not_found),
+ (try Structure.find_elem state.struc m_e
+ with Not_found -> Printf.printf "NF m_e=%s\n%!" m_e;
+ raise Not_found))
emb_str
with Not_found ->
(* {{{ log entry *)
if !debug_level > 0 then (
- Printf.printf "emb_of_names: failed at LHS=\n%s\nSTRUC=\n%s\n%!"
+ Printf.printf "emb_of_names: failed at LHS=\n%s\nSTRUC=\n%s\nEMB=%s\n%!"
(Structure.str lhs) (Structure.str state.struc)
+ (String.concat "; "
+ (List.map (fun (v,e) ->v^"<-"^e) emb_str))
);
(* }}} *)
failwith ("emb_of_names: could not find " ^
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-10-25 08:24:28 UTC (rev 1616)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-10-25 21:40:52 UTC (rev 1617)
@@ -134,6 +134,9 @@
literal). Compute the relation-argument-position, predicate
implications including relations produced by gluing.
+ TODO-FIXME: extend operations (specifically 2) to handle formulas
+ nested in real expressions; with special treatment for update
+ expressions in rules (using the compiled precondition as context).
*)
open Formula
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-10-25 08:24:28 UTC (rev 1616)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-10-25 21:40:52 UTC (rev 1617)
@@ -17,13 +17,14 @@
defined relation: a Toss defined relation (i.e. does not normally
occur in the structure)
- TODO: perform "fluent path prediate inversion" by transforming
- single-argument state terms into two arguments of a "value" state
- term.
-
TODO-FIXME: limit translation as concurrent games to cases where
rules do not check fluents affected by other rules to be performed
concurrently.
+
+ TODO-FIXME: missing interactions between counters and the
+ structural part of rewriting (try translate "asteroids.gdl").
+
+ TODO-FIXME: add make_all_nondistinct by default.
*)
open GDL
@@ -90,6 +91,22 @@
literals). *)
let filter_possibly_redundant = ref true
+(** When [require_all_w_does] is true, rule generation is optimized by
+ requiring all "next" clauses that match a given "legal/does" term
+ -- that have a "does" atom -- be present in a rule. Setting to
+ true violates correctness for games like "asteroids" where a
+ single "(turn clock)" legal term is used for different headings
+ which have different "next" clauses. *)
+let require_all_w_does = ref false
+
+(** When true, keep only rule candidates with maximal sets of clauses. *)
+let filter_maximal_rules = ref true
+
+(** TODO: Translate all rules as "nondistinct", i.e. not forcing difference
+ of elements while finding the "rule embedding" homomorphism.
+ TODO: modify Arena to do that by a simple rule marker. *)
+let make_all_nondistinct = ref true
+
let env_player = Const "environment"
type tossrule_data = {
@@ -203,12 +220,27 @@
else
let new_paths = term_paths
(function Func _ -> false | _ -> true) head in
- let p_subterms = Aux.concat_map
- (map_paths (fun p s -> p, s) new_paths) ground_state_terms in
+ let p_subterms = Aux.unique_sorted
+ (Aux.concat_map
+ (map_paths (fun p s -> p, s) new_paths) ground_state_terms) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "find_cl_fluent: p_subterms=%s\n%!"
+ (String.concat "; "(List.map (fun (p,s)->
+ path_str p^"->"^term_str s) p_subterms))
+ );
+ (* }}} *)
let p_subterms = Aux.collect p_subterms in
- match List.sort (fun (_,i) (_,j)->j-i)
- (List.map (fun (p,ts) -> p, List.length ts) p_subterms)
- with
+ let p_subterms = List.sort (fun (_,i) (_,j)->i-j)
+ (List.map (fun (p,ts) -> p, List.length ts) p_subterms) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "find_cl_fluent: p_subterm counts=%s\n%!"
+ (String.concat "; "(List.map (fun (p,num)->
+ path_str p^": "^string_of_int num) p_subterms))
+ );
+ (* }}} *)
+ match p_subterms with
| [] -> failwith
("fluent_paths_and_frames: next head "^term_str head^
" has no instance among ground state terms")
@@ -223,13 +255,13 @@
let f_paths =
List.fold_left find_cl_fluent empty_path_set move_cls in
(* {{{ log entry *)
-if !debug_level > 3 then (
- Printf.printf "frame clauses:\n%s\n"
- (String.concat "\n"
- (List.map (fun (h,body)->term_str h^" <== "^literals_str body)
- frame_cls))
-);
-(* }}} *)
+ if !debug_level > 3 then (
+ Printf.printf "frame clauses:\n%s\n"
+ (String.concat "\n"
+ (List.map (fun (h,body)->term_str h^" <== "^literals_str body)
+ frame_cls))
+ );
+ (* }}} *)
frame_cls, move_cls, f_paths
@@ -240,13 +272,18 @@
let val_path = ["val_", 0]
-(* Expand role variables, find fluent and coordinate paths, lift
- unused state terms into relations and add state terms / elements
- for missing subterms. *)
-let prepare_paths_and_elems players_wo_env program ~playout_states clauses =
+(* Expand role variables. Compute all ground state terms. Transform
+ single-argument state terms with more than three ground terms
+ having the same functor into two-argument "value_" state terms:
+ e.g. "(x 10)" into "(value_ x 10)". Find fluent and coordinate
+ paths. Lift unused state terms into relations. Add state terms /
+ elements for missing subterms. *)
+let prepare_paths_and_elems players_wo_env ~playout_states clauses =
let rules = Aux.concat_map rules_of_clause clauses in
let static_rels, nonstatic_rels =
static_rels (defs_of_rules rules) in
+ let static_rels = Aux.list_diff static_rels
+ ["goal"; "next"; "legal"] in
(* Turns out the saturation-based solver is sometimes far better for
performing aggregate playout, which is very much
saturation-like. *)
@@ -255,9 +292,9 @@
playout_satur ~aggregate:true players_wo_env !playout_horizon rules in
(* *)
(*
- let program = preprocess_program clauses in
- let agg_actions, agg_states =
- playout_prolog ~aggregate:true players !playout_horizon program in
+ let program = preprocess_program clauses in
+ let agg_actions, agg_states =
+ playout_prolog ~aggregate:true players !playout_horizon program in
*)
(* {{{ log entry *)
if !debug_level > 4 then (
@@ -270,8 +307,68 @@
(fun acc st ->
Aux.sorted_merge (Aux.unique_sorted st) acc) []
(terminal_state::agg_states) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf
+ "prepare_paths_and_elems: initial ground_state_terms=\n%s\n%!"
+ (String.concat " "(List.map term_str ground_state_terms))
+ );
+ (* }}} *)
let init_state = List.hd agg_states in
check_timeout "TranslateGame: prepare_paths_and_elems: init_state";
+ let value_terms = Aux.map_some
+ (function Func (f, [| arg |]) -> Some (f, arg)
+ | _ -> None) ground_state_terms in
+ let value_terms = List.filter
+ (fun (f, graph) -> List.length graph > 3)
+ (Aux.collect value_terms) in
+ let value_funcs = Aux.strings_of_list (List.map fst value_terms) in
+ let value_terms = Aux.concat_map
+ (fun (f,graph) -> List.map
+ (fun arg-> Func ("value_", [|Const f; arg|])) graph)
+ value_terms in
+ let ground_state_terms = List.filter
+ (function Func (f, [| _ |]) -> not (Aux.Strings.mem f value_funcs)
+ | _ -> true) ground_state_terms in
+ let ground_state_terms = value_terms @ ground_state_terms in
+ let rec lift_to_value = function
+ | Pos (True (Func (f, [|arg|])))
+ when Aux.Strings.mem f value_funcs ->
+ Pos (True (Func ("value_", [|Const f; arg|])))
+ | Neg (True (Func (f, [|arg|])))
+ when Aux.Strings.mem f value_funcs ->
+ Neg (True (Func ("value_", [|Const f; arg|])))
+ | Disj disj -> Disj (List.map lift_to_value disj)
+ | l -> l in
+ let clauses =
+ if Aux.Strings.is_empty value_funcs then clauses
+ else List.map
+ (function
+ | ("init", [|Func (f, [|arg|])|]), body
+ when Aux.Strings.mem f value_funcs ->
+ ("init", [|Func ("value_", [|Const f; arg|])|]),
+ List.map lift_to_value body
+ | ("next", [|Func (f, [|arg|])|]), body
+ when Aux.Strings.mem f value_funcs ->
+ ("next", [|Func ("value_", [|Const f; arg|])|]),
+ List.map lift_to_value body
+ | h, body ->
+ h, List.map lift_to_value body) clauses in
+ let state_lift_value state = List.map
+ (function
+ | Func (f, [|arg|]) when Aux.Strings.mem f value_funcs ->
+ Func ("value_", [|Const f; arg|])
+ | sterm -> sterm) state in
+ let playout_states = List.map state_lift_value playout_states in
+ let init_state = state_lift_value init_state in
+ let program = preprocess_program clauses in
+(* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "after-lift-value: playout_states=%s\n\n%!"
+ (String.concat "\n" (List.map (fun state->
+ String.concat " "(List.map term_str state)) playout_states))
+ );
+ (* }}} *)
let arities =
("EQ_", 2)::
Aux.unique_sorted
@@ -330,6 +427,13 @@
(function
| Func (f, _) when Aux.Strings.mem f unused_roots -> false
| _ -> true) ground_state_terms in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf
+ "prepare_paths_and_elems: resulting ground_state_terms=\n%s\n%!"
+ (String.concat " "(List.map term_str ground_state_terms))
+ );
+ (* }}} *)
let more_base = Aux.map_some
(function
| [|Func (f, args)|] when Aux.Strings.mem f unused_roots ->
@@ -453,7 +557,7 @@
static_base, init_state, c_paths, f_paths, element_reps, root_reps,
framed_fluents,
ground_state_terms, arities, term_arities, static_rels, nonstatic_rels,
- frame_clauses, move_clauses, clauses
+ frame_clauses, move_clauses, clauses, program, playout_states
let default_argpaths rel ar init_state program ground_at_c_paths =
@@ -1108,37 +1212,7 @@
subst sb head, subst_literals sb body
-(* Callgraph for creating "move tuples" and Toss rules.
- (1) [create_init_struc] prepares [next_cls], segregated into frame
- clauses and normal clauses, with head term extracted.
-
- (2) [move_tuples] selects maximal tuples of [next_cls] such that
- their "legal"/"does" terms unify.
-
- (3) [add_erasure_clauses] converts frame into erasure clauses, and
- adds the result to non-frame clauses (without framing
- information).
-
- (4) [process_rule_cands] calls [move_tuples], applies the unifier,
- and calls [add_erasure_clauses].
-
- (5) [rule_cases] distributes clauses from a move tuple to
- disjointly cover all applicability conditions. Then it collects all
- head terms and conflates the bodies to produce a rule
- candidate. Legality conditions are not passed to [rule_cases].
-
- (6) [turnbased_rule_cases], [concurrent_rule_cases] and
- [general_int_rule_cases] call [rule_cases], add legal terms and
- legality conditions to the result when appropriate (the
- environment does not have legality conditions). Rules for players
- as well as for the environment (when not turn-based) are built.
-
- (7) [create_rule_cands] calls the right routine of (6).
-
-*)
-
-
(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Also handles as
special cases: "concurrent" case with selecting clauses for only
one player, and "environment" case for selecting clauses not
@@ -1233,7 +1307,7 @@
if List.exists
(function Pos (Does _) -> true | _ -> false) body
then
- head, (frame, true),
+ head, (frame, !require_all_w_does),
List.filter
(function Pos (Does _) -> false | _ -> true) body
else
@@ -1575,16 +1649,12 @@
(fun (h, required, body) ->
if required then Some (h, body) else None) rule_cls in
let required_body = Aux.concat_map snd required_cls in
- let counter_cls = List.map
- (fun (f, brs) ->
- let brs = List.map
- (fun (cond, update) ->
- let sb, cond = filter_redundant required_body cond in
- subst_literals sb cond, update)
- brs in
- f, brs)
- counter_cls in
-
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "rule_cases: required_body=%s\n%!"
+ (literals_str required_body)
+ );
+ (* }}} *)
let unrequired_cls = Aux.map_some
(fun (h, required, body) ->
if not required then Some (h, body) else None) rule_cls in
@@ -1607,9 +1677,9 @@
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf
- "\nrule_cases: checking urequired %s\nstatic_goal=%s\n%!"
+ "\nrule_cases: checking unrequired %s\nstatic_goal=%s\n%!"
(String.concat " "(List.map literal_str unreq_body))
- (String.concat " "(List.map literal_str static_goal))
+ (String.concat " "(List.map literal_str static_goal));
);
(* }}} *)
let res =
@@ -1655,8 +1725,9 @@
Printf.printf "rule_cases: single partition\n%!";
);
(* }}} *)
- [Aux.unique_sorted case_rhs, counter_cls,
- Aux.unique_sorted (List.concat case_conds)]
+ [Aux.Ints.singleton 0,
+ (Aux.unique_sorted case_rhs, counter_cls,
+ Aux.unique_sorted (List.concat case_conds))]
else
let patterns =
let unrequired_cls = Array.of_list unrequired_cls in
@@ -1690,18 +1761,26 @@
);
(* }}} *)
let choices = Aux.power split_atoms [false; true] in
+ let unrequired_cls = Array.of_list unrequired_cls in
let rule_case choice =
let separation_cond =
List.map (fun (a,b) -> if b then Pos a else Neg a) choice in
- let case_cls =
- List.filter (fun (_, body) ->
- List.for_all (fun (a,b) ->
- if b then (* atom not excluded *)
- not (List.mem (Neg a) body)
- else (* atom not included *)
- not (List.mem (Pos a) body)
- ) choice
+ let case =
+ Aux.array_mapi_some (fun i (_, body as cl) ->
+ if
+ List.for_all (fun (a,b) ->
+ if b then (* atom not excluded *)
+ not (List.mem (Neg a) body)
+ else (* atom not included *)
+ not (List.mem (Pos a) body)
+ ) choice
+ then Some (i, cl)
+ else None
) 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 process_case (ids, separation_cond, case_cls) =
let case_cls = case_cls @ required_cls in
let case_rhs, case_conds = List.split case_cls in
let case_rhs =
@@ -1726,9 +1805,19 @@
(String.concat " " (List.map literal_str case_conds))
);
(* }}} *)
- case_rhs, counter_cls,
+ let case_cond =
Aux.unique_sorted (separation_cond @ case_conds) in
- let res = List.map rule_case choices in
+ let counter_cls = List.map
+ (fun (f, brs) ->
+ let brs = List.map
+ (fun (cond, update) ->
+ let sb, cond = filter_redundant case_cond cond in
+ subst_literals sb cond, update)
+ brs in
+ f, brs)
+ counter_cls in
+ ids, (case_rhs, counter_cls, case_cond) in
+ let res = List.map process_case cases in
(* {{{ log entry *)
if !debug_level > 2 then (
let cond_upd_str (cond, update) =
@@ -1738,7 +1827,7 @@
counter^": "^String.concat ", "
(List.map cond_upd_str cond_updates) in
Printf.printf "rule_cases: next clauses partitioned into rules\n%!";
- let print_case i (case_rhs, counter_cls, case_cond) =
+ let print_case i (ids, (case_rhs, counter_cls, case_cond)) =
Printf.printf "\nRCAND: #%d\nRHS: %s\nCOUNTER_CLs: %s\nLHS: %s\n%!" i
(String.concat " " (List.map term_str case_rhs))
(String.concat "; " (List.map counters_str counter_cls))
@@ -1814,8 +1903,8 @@
let legal_cls = List.map (* required clauses *)
(fun body -> ignore_rhs, true, body) legal_conds in
List.map
- (fun (case_rhs, updates, case_cond) ->
- legal_tup, case_rhs, updates, case_cond)
+ (fun (ids, (case_rhs, updates, case_cond)) ->
+ ids, (legal_tup, case_rhs, updates, case_cond))
(rule_cases counters num_functors static_rels testground program
playout_states (legal_cls @ next_cls))
@@ -1860,12 +1949,18 @@
used_vars f_paths next_cls `General
players_wo_env legal_tuples in
check_timeout "TranslateGame: turnbased_rule_cases: processed rule cands";
- let rules = Aux.concat_map
- (add_legal_cond counters num_functors static_rels
- testground program playout_states) move_tups in
+ let rules = Array.mapi
+ (fun i move_tup ->
+ let res =
+ add_legal_cond counters num_functors static_rels
+ testground program playout_states move_tup in
+ (* marking candidates to not override across legal tups *)
+ List.map (fun (ids, case) ->
+ Aux.Ints.add (~-i - 1) ids, case) res)
+ (Array.of_list move_tups) in
(* we do not look for the players -- for turn-based case, it's done
while building game graph *)
- Aux.Left rules
+ Aux.Left (List.concat (Array.to_list rules))
(* If "Concurrent Moves" case, divide rule clauses among players. *)
@@ -1877,7 +1972,7 @@
process_rule_cands used_vars f_paths next_cls `Environment [||] [[]] in
let player_rules =
List.map2 (fun player legal_cls ->
- (* [process_rule_cands] works with players tuples, so we "cheat" *)
+ (* [process_rule_cands] works with players tuples, so we "cheat" *)
let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
let move_tups =
process_rule_cands
@@ -1887,9 +1982,16 @@
check_timeout "TranslateGame: concurrent_rule_cases";
let player_rules = List.map
(fun (player, move_tups) ->
- player, Aux.concat_map
- (add_legal_cond counters num_functors static_rels
- testground program playout_states) move_tups)
+ let rules = Array.mapi
+ (fun i move_tup ->
+ let res =
+ add_legal_cond counters num_functors static_rels
+ testground program playout_states move_tup in
+ (* marking candidates to not override across legal tups *)
+ List.map (fun (ids, case) ->
+ Aux.Ints.add (~-i - 1) ids, case) res)
+ (Array.of_list move_tups) in
+ player, List.concat (Array.to_list rules))
(player_rules @ [env_pl_tups]) in
Aux.Right player_rules
@@ -1981,7 +2083,7 @@
let counters_str (counter, cond_updates) =
counter^": "^String.concat ", "
(List.map cond_upd_str cond_updates) in
- let print_rcand i (_, case_rhs, counter_cls, case_cond) =
+ let print_rcand i (_, (_, case_rhs, counter_cls, case_cond)) =
Printf.printf "\nRCAND: #%d\nRHS: %s\nCOUNTER_CLs: %s\nLHS: %s\n%!" i
(String.concat " " (List.map term_str case_rhs))
(String.concat "; " (List.map counters_str counter_cls))
@@ -2003,28 +2105,35 @@
let filter_rule_cands static_rels players f_paths program
playout_states rule_cands =
let check_cands cands =
- List.filter (fun (_, _, _, case_conds) ->
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "check_cands: cond %s%!"
- (String.concat " "(List.map literal_str case_conds))
- );
- (* }}} *)
- let res =
- run_prolog_check_goal (keep_rels static_rels case_conds) program
- && List.exists
- (fun state ->
- (* {{{ log entry *)
- if !debug_level > 1 then Printf.printf ".%!";
- (* }}} *)
- run_prolog_check_goal case_conds
- (replace_rel_in_program "true" (state_cls state) program))
- playout_states in
- (* {{{ log entry *)
- if !debug_level > 1 then Printf.printf " %B\n%!" res;
- (* }}} *)
- res
- ) cands in
+ let cands =
+ List.filter (fun (_, (_, _, _, case_conds)) ->
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "check_cands: cond %s%!"
+ (String.concat " "(List.map literal_str case_conds))
+ );
+ (* }}} *)
+ let res =
+ run_prolog_check_goal (keep_rels static_rels case_conds) program
+ && List.exists
+ (fun state ->
+ (* {{{ log entry *)
+ if !debug_level > 1 then Printf.printf ".%!";
+ (* }}} *)
+ run_prolog_check_goal case_conds
+ (replace_rel_in_program "true" (state_cls state) program))
+ playout_states in
+ (* {{{ log entry *)
+ if !debug_level > 1 then Printf.printf " %B\n%!" res;
+ (* }}} *)
+ res
+ ) cands in
+ if not !filter_maximal_rules
+ then List.map snd cands
+ else List.map snd
+ (Aux.maximal_unique
+ (fun (s1, _) (s2, _) -> Aux.Ints.subset s1 s2)
+ cands) in
let add_rhs_as_lhs (legal_tup, case_rhs, updates, case_cond) =
let case_blanks = List.map
(fun s -> Pos (True (simult_subst f_paths blank s))) case_rhs in
@@ -2818,8 +2927,12 @@
let static_base, init_state, c_paths, f_paths, element_reps, root_reps,
framed_fluents,
ground_state_terms, arities, term_arities, static_rels, nonstatic_rels,
- frame_clauses, move_clauses, clauses =
- prepare_paths_and_elems players_wo_env program ~playout_states clauses in
+ frame_clauses, move_clauses, clauses, program, playout_states =
+ prepare_paths_and_elems players_wo_env ~playout_states clauses in
+ (* recompile the program *)
+ let testground =
+ replace_rel_in_program "true" (state_cls init_state) program in
+ let program = optimize_program ~testground program in
let clauses = ground_goal_values ground_state_terms clauses in
(* [lexp_frame_clauses] have only the "legal" atoms expanded *)
let lexp_frame_clauses, frame_clauses =
@@ -2864,14 +2977,15 @@
then elim_ground_args elim_static_rels clauses
else elim_static_rels, clauses in
let static_rels = elim_static_rels @ nonelim_static_rels in
- let nonstatic_rels = Aux.list_diff nonstatic_rels ["goal"; "legal"] in
+ let nonstatic_rels =
+ Aux.list_diff nonstatic_rels ["goal"; "legal"; "next"] in
let nonstatic_rels, clauses =
if !perform_ground_arg_elim
then elim_ground_args nonstatic_rels clauses
else nonstatic_rels, clauses in
(* eliminate once again since more variables have been instantiated *)
let clauses = elim_ground_distinct clauses in
- let nonstatic_rels = "goal"::"legal"::nonstatic_rels in
+ let nonstatic_rels = "goal"::(* "legal":: *)nonstatic_rels in
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf
@@ -2911,8 +3025,9 @@
(* optimize candidates for fast pruning *)
let rule_cands =
let process cands = List.map
- (fun (legal_tup, rhs_tup, updates, cond) ->
- legal_tup, rhs_tup, updates, optimize_goal ~testground cond)
+ (fun (ids, (legal_tup, rhs_tup, updates, cond)) ->
+ ids, (legal_tup, rhs_tup, updates,
+ optimize_goal ~testground cond))
cands in
match rule_cands with
| Aux.Left cands -> Aux.Left (process cands)
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2011-10-25 08:24:28 UTC (rev 1616)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2011-10-25 21:40:52 UTC (rev 1617)
@@ -45,8 +45,8 @@
let game_test_case ~game_name ~player ~own_plnum ~opponent_plnum
~loc0_rule_name ~loc0_emb
- ~loc0_move ~loc0_noop ~loc1 ~loc1_rule_name ~loc1_emb ~loc1_noop
- ~loc1_move =
+ ~loc0_move ?loc0_noop ~loc1 ~loc1_rule_name ~loc1_emb ?loc1_noop
+ ~loc1_move () =
let game = load_rules ("./GGP/examples/"^game_name^".gdl") in
let gdl, r_game, (r_inl_game, r_struc as res) =
TranslateGame.translate_game ~playing_as:(Const player) game in
@@ -70,10 +70,13 @@
let transl =
TranslateGame.translate_outgoing_move gdl res rname emb in
assert_equal ~printer:(fun x->x) loc0_move transl;
+ let moves = match loc0_noop with
+ | Some loc0_noop -> [pte loc0_move; pte loc0_noop]
+ | None -> [pte loc0_move] in
let moves =
TranslateGame.translate_incoming_move gdl res
(* FIXME: should use the player ordering "plnum" right? *)
- [pte loc0_move; pte loc0_noop] in
+ moves in
let move = List.assoc own_plnum moves in
assert_equal ~msg:"own incoming move" ~printer:(emb_str res)
(norm_move (rname, emb)) (norm_move move);
@@ -83,10 +86,13 @@
let rname = loc1_rule_name in
let emb =
Arena.emb_of_names res rname loc1_emb in
+ let moves = match loc1_noop with
+ | Some loc1_noop -> [pte loc1_noop; pte loc1_move]
+ | None -> [pte loc1_move] in
let moves =
TranslateGame.translate_incoming_move gdl res
(* FIXME: should use the player ordering "plnum" right? *)
- [pte loc1_noop; pte loc1_move] in
+ moves in
let move = List.assoc opponent_plnum moves in
assert_equal ~msg:"opponent incoming move"
~printer:(emb_str res)
@@ -195,7 +201,7 @@
~loc1_emb:[
"cell_x7_y0__BLANK_", "cell_1_1__BLANK_";
"control__BLANK_", "control__BLANK_"]
- ~loc1_noop:"noop" ~loc1_move:"(mark 1 1)"
+ ~loc1_noop:"noop" ~loc1_move:"(mark 1 1)" ()
);
"tictactoe-different definition" >::
@@ -211,7 +217,7 @@
~loc1_emb:[
"cELL_X10_Y10__BLANK_", "cELL_3_3__BLANK_";
"cONTROL__BLANK_", "cONTROL__BLANK_"]
- ~loc1_noop:"NOOP" ~loc1_move:"(MARK 3 3)"
+ ~loc1_noop:"NOOP" ~loc1_move:"(MARK 3 3)" ()
);
"2player_normal_form_joint" >::
@@ -229,53 +235,7 @@
]
let bigtests = "TranslateGameBig" >::: [
- (* TODO: migrate to use [prepare_relations_and_structure]
- "connect5 translation data" >::
- (fun () ->
- let descr = load_rules ("./GGP/examples/connect5.gdl") in
- let clauses = GDL.expand_players descr in
- let program = preprocess_program clauses in
- let rules,
- clauses, f_paths, c_paths, root_reps, defined_rels,
- stable_rels, fluents,
- init_state, struc, ground_state_terms, elem_term_map =
- TranslateGame.create_init_struc program ~playout_states:[] clauses in
- assert_equal ~msg:"f_paths" ~printer:(fun x->x)
- "cell_2; control_0"
- (String.concat "; "
- (List.map GDL.path_str (GDL.paths_to_list f_paths)));
-
- assert_equal ~msg:"c_paths" ~printer:(fun x->x)
- "cell_0; cell_1"
- (String.concat "; "
- (List.map GDL.path_str (GDL.paths_to_list c_paths)));
-
- assert_equal ~msg:"root_reps" ~printer:(fun x->x)
- "(cell _BLANK_ _BLANK_ _BLANK_); (control _BLANK_)"
- (String.concat "; "
- (List.map GDL.term_str root_reps));
-
- (* adjacent_cell is a defined relation only because it has
- large arity: see {!TranslateGame.defined_arity_above}. *)
- assert_equal ~msg:"defined_rels" ~printer:(fun x->x)
- "adjacent, adjacent_cell, col, conn5, diag1, diag2, exists_empty_cell, exists_line_of_five, goal, legal, next, row, terminal"
- (String.concat ", " (List.sort String.compare defined_rels));
-
- assert_equal ~msg:"fluents" ~printer:(fun x->x)
- "cell_2b, cell_2o, cell_2x, control_0o, control_0x"
- (String.concat ", " fluents);
-
- assert_equal ~msg:"stable_rels" ~printer:(fun x->x)
- "EQ___cell_0__cell_0, EQ___cell_0__cell_1, EQ___cell_1__cell_0, EQ___cell_1__cell_1, cell_0a, cell_0b, cell_0c, cell_0d, cell_0e, cell_0f, cell_0g, cell_0h, cell_1a, cell_1b, cell_1c, cell_1d, cell_1e, cell_1f, cell_1g, cell_1h, cell__BLANK___BLANK___BLANK_, control__BLANK_, coordinate__cell_0, coordinate__cell_1, nextcol__cell_0__cell_0, nextcol__cell_0__cell_1, nextcol__cell_1__cell_0, nextcol__cell_1__cell_1"
- (String.concat ", " stable_rels);
-
- assert_equal ~msg:"structure elements" ~printer:(fun x->x)
- "cell_a_a__BLANK_, cell_a_b__BLANK_, cell_a_c__BLANK_, cell_a_d__BLANK_, cell_a_e__BLANK_, cell_a_f__BLANK_, cell_a_g__BLANK_, cell_a_h__BLANK_, cell_b_a__BLAN...
[truncated message content] |
|
From: <luk...@us...> - 2011-11-01 09:32:21
|
Revision: 1618
http://toss.svn.sourceforge.net/toss/?rev=1618&view=rev
Author: lukstafi
Date: 2011-11-01 09:32:09 +0000 (Tue, 01 Nov 2011)
Log Message:
-----------
GDL translation: enhancing erasure clauses, initial commit. Not verified, tests not updated yet.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-10-25 21:40:52 UTC (rev 1617)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-11-01 09:32:09 UTC (rev 1618)
@@ -1060,7 +1060,7 @@
[nondistinct_pairs] connects elements that are potentially not
distinct, thus weakening the "embedding" requirement into
"homomorphism" requirement for matching a rule. *)
-let translate_from_precond ~precond ~add ~nondistinct ~emb_rels
+let translate_from_precond ~precond ~add ?(del=[]) ~nondistinct ~emb_rels
~signat ~struc_elems =
let rhs_names = Aux.unique_sorted
(Aux.concat_map (fun (_,arg) -> Array.to_list arg) add) in
@@ -1139,6 +1139,36 @@
List.map (fun args -> "_opt_"^rel, args) tups
with Not_found -> [])
emb_rels in
+ let opt_rhs =
+ Aux.concat_map (fun rel ->
+ try
+ let arity = List.assoc rel signat in
+ let tups =
+ List.map
+ Array.of_list
+ (*Aux.array_map_of_list Formula.var_str*)
+ (Aux.product (
+ Aux.fold_n (fun acc -> struc_elems::acc) [] arity)) in
+ let modified =
+ Aux.assoc_all rel add @ Aux.assoc_all rel del in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf
+ "translate_from_precond: RHS _opt_%s -- modified %s -- \
+ remaining %s\n%!" rel
+ (String.concat "; "
+ (List.map (fun args ->
+ String.concat " " (Array.to_list args)) modified))
+ (String.concat "; "
+ (List.map (fun args ->
+ String.concat " " (Array.to_list args))
+ (Aux.list_diff tups modified)))
+ );
+ (* }}} *)
+ let tups = Aux.list_diff tups modified in
+ List.map (fun args -> "_opt_"^rel, args) tups
+ with Not_found -> [])
+ emb_rels in
let rhs_struc, struc_elems =
List.fold_left (fun (rhs_struc, struc_elems) name ->
let rhs_struc, elem =
@@ -1150,6 +1180,7 @@
(Array.map (fun n -> List.assoc n struc_elems) args)) in
let lhs_struc = rhs_struc in
let rhs_struc = add_rels rhs_struc add in
+ let rhs_struc = add_rels rhs_struc opt_rhs in
let lhs_struc = add_rels lhs_struc posi_s in
let lhs_struc = add_rels lhs_struc opt_s in
let lhs_struc = add_rels lhs_struc
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2011-10-25 21:40:52 UTC (rev 1617)
+++ trunk/Toss/Arena/DiscreteRule.mli 2011-11-01 09:32:09 UTC (rev 1618)
@@ -148,6 +148,7 @@
"homomorphism" requirement for matching a rule. *)
val translate_from_precond :
precond:Formula.formula -> add:(string * string array) list ->
+ ?del:(string * string array) list ->
nondistinct:string array list ->
(* del:(string * string array) list -> *)
emb_rels:string list -> signat:(string * int) list ->
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-10-25 21:40:52 UTC (rev 1617)
+++ trunk/Toss/GGP/GDL.ml 2011-11-01 09:32:09 UTC (rev 1618)
@@ -1526,6 +1526,13 @@
| _ -> [] in
Aux.concat_map aux body
+let pos_state_terms body =
+ let rec aux = function
+ | Pos (True t) -> [t]
+ | Disj ls -> Aux.concat_map aux ls
+ | _ -> [] in
+ Aux.concat_map aux body
+
let rec term_arities =
function
| Func (rel, args) ->
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-10-25 21:40:52 UTC (rev 1617)
+++ trunk/Toss/GGP/GDL.mli 2011-11-01 09:32:09 UTC (rev 1618)
@@ -174,6 +174,7 @@
val term_to_name : ?nested:bool -> term -> string
val state_terms : literal list -> term list
+val pos_state_terms : literal list -> term list
val term_arities : term -> (string * int) list
val atom_str : atom -> string
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-10-25 21:40:52 UTC (rev 1617)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-11-01 09:32:09 UTC (rev 1618)
@@ -91,14 +91,6 @@
literals). *)
let filter_possibly_redundant = ref true
-(** When [require_all_w_does] is true, rule generation is optimized by
- requiring all "next" clauses that match a given "legal/does" term
- -- that have a "does" atom -- be present in a rule. Setting to
- true violates correctness for games like "asteroids" where a
- single "(turn clock)" legal term is used for different headings
- which have different "next" clauses. *)
-let require_all_w_does = ref false
-
(** When true, keep only rule candidates with maximal sets of clauses. *)
let filter_maximal_rules = ref true
@@ -116,7 +108,8 @@
(then ordered in the same way as players),
we call its parameters "fixed variables" as they are provided
externally *)
- rhs_add : (string * string array) list;
+ rule_add : (string * string array) list;
+ rule_del : (string * string array) list;
struc_elems : string list;
(* the elements of LHS/RHS structures, corresponding to the "next"
terms *)
@@ -1200,8 +1193,13 @@
init_state, struc, ground_state_terms, elem_term_map,
term_arities, argpaths
+(* The [Erasure_cl_OK] clauses do not have unfixed variables. The
+ [Erasure_cl_inst] stores the unfixed-variable-dependent part
+ separately, already instantiated. *)
+type cl_type =
+ | Legal_cl | Next_cl | Erasure_cl_OK
+ | Erasure_cl_inst of (term * literal list) list
-
(* substitute a "next" clause with frame info *)
let subst_fnextcl sb (head, frame, body) =
subst sb head, frame, subst_literals sb body
@@ -1304,14 +1302,9 @@
the rewrite rule. *)
List.map (fun (sb, _, n_cls) ->
let n_cls = List.map (fun (head,frame,body) ->
- if List.exists
- (function Pos (Does _) -> true | _ -> false) body
- then
- head, (frame, !require_all_w_does),
+ head, frame,
List.filter
- (function Pos (Does _) -> false | _ -> true) body
- else
- head, (frame, false), body) n_cls in
+ (function Pos (Does _) -> false | _ -> true) body) n_cls in
sb, legal_tup, n_cls) cl_tups in
Aux.concat_map move_clauses legal_tuples
@@ -1325,9 +1318,11 @@
(String.concat ", " (Aux.Strings.elements fixed_vars))
);
(* }}} *)
- let frame_cls =
- Aux.map_some (fun (s, (frame, _), body) ->
- if frame then Some (s, body) else None) next_cls in
+ let frame_cls, move_cl_bodies =
+ Aux.partition_map (fun (s, frame, body) ->
+ if frame then Aux.Left (s, body) else Aux.Right body) next_cls in
+ let move_cl_pos_terms =
+ Aux.concat_map pos_state_terms move_cl_bodies in
(* two passes to ensure coverage and maximality *)
(* Treating fixed-vars as consts, by substituting them with
Const, and later substituting-back Var *)
@@ -1392,40 +1387,50 @@
let nbodies = negate_bodies bodies in
List.map
(fun (nsb, b) ->
- simult_subst f_paths blank (subst nsb s),
- Aux.unique_sorted b)
+ let s = subst nsb s in
+ s, Aux.unique_sorted (Pos (True s) :: b))
nbodies
) frames in
- (* Remove erasure clauses that still have free variables, because
- after negation they have universal interpretation. *)
- let erasure_cls = List.filter
- (fun (s, body) ->
- let cl_vars = clause_vars (("erasure",[|s|]), body) in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "ERASURE: %s with vars %s\nbody: %s\n%!"
- (term_str s)
- (String.concat ", " (Aux.Strings.elements cl_vars))
- (String.concat " " (List.map literal_str body))
- );
- (* }}} *)
- Aux.Strings.is_empty cl_vars)
- (Aux.unique_sorted erasure_cls) in
+
(* Recover fixed variables. *)
let fixed_to_var = List.map
(fun v -> v, Var v) (Aux.Strings.elements fixed_vars) in
- let erasure_cls = List.map
- (subst_consts_clause fixed_to_var)
- (List.map (fun (s,body)->("erasure next",[|s|]),body) erasure_cls) in
- (* Erasure clauses are considered as not having "does" atoms,
- although of course the frame clauses did have "does" atoms. *)
- let erasure_cls =
- List.map (fun ((_,h),body) -> h.(0),false,body) erasure_cls in
+ (* Erasure clauses with unfixed variables need to be instantiated
+ against the body of remaining move clauses -- but after selecting
+ them for rule candidates. *)
+ let erasure_cls = Aux.map_some
+ (fun (s, body) ->
+ let local_ex_vars = term_vars s in
+ let local_uni_vars = Aux.Strings.diff
+ (literals_vars body) local_ex_vars in
+ if Aux.Strings.is_empty local_uni_vars then
+ let body, local_body = List.partition
+ (fun lit -> Aux.Strings.is_empty (literals_vars [lit]))
+ body in
+ let kind =
+ if Aux.Strings.is_empty local_ex_vars then Erasure_cl_OK
+ else
+ let sbs = Aux.map_try
+ (fun t -> unify [] [s] [t]) move_cl_pos_terms in
+ let local = List.map
+ (fun sb -> subst_consts fixed_to_var (subst sb s),
+ subst_consts_literals fixed_to_var
+ (subst_literals sb local_body)) sbs in
+ Erasure_cl_inst local in
+ if kind = Erasure_cl_inst [] then None
+ else
+ Some (
+ subst_consts fixed_to_var s, kind,
+ subst_consts_literals fixed_to_var body)
+ else None)
+ (Aux.unique_sorted erasure_cls) in
+
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "add_erasure_clauses: all erasure clauses --\n%!";
- let print_erasure (s, _, body) =
- Printf.printf "ERASURE: %s <== %s\n%!" (term_str s)
+ let print_erasure (s, kind, body) =
+ Printf.printf "ERASURE: %s %s <== %s\n%!"
+ (if kind = Erasure_cl_OK then " OK " else "inst") (term_str s)
(String.concat " " (List.map literal_str body)) in
List.iter print_erasure erasure_cls; flush stdout;
);
@@ -1443,8 +1448,10 @@
);
(* }}} *)
let next_cls =
- Aux.map_some (fun (s, (frame, required), body) ->
- if not frame then Some (s, required, body) else None) next_cls in
+ Aux.map_some (fun (s, frame, body) ->
+ if not frame then
+ Some (s, Next_cl, body)
+ else None) next_cls in
legal_tup, next_cls @ erasure_cls
@@ -1602,6 +1609,34 @@
let remove_local_vars gvars lits =
List.filter (fun l -> Aux.Strings.subset (literals_vars [l]) gvars) lits
+let split_rule_cand rule_cls =
+ let regular_cls, erasure_cls = Aux.partition_map
+ (function
+ | h, Erasure_cl_OK, body -> Aux.Right (Aux.Left (h, body))
+ | h, Erasure_cl_inst local, body -> Aux.Right (Aux.Right (local, body))
+ | h, _, body -> Aux.Left (h, body))
+ rule_cls in
+ let pos_rhs, conds = List.split regular_cls in
+ let erasure_OK, erasure_local = Aux.partition_choice erasure_cls in
+ let neg_rhs, more_conds = List.split erasure_OK in
+ let cond = List.concat (more_conds @ conds) in
+ let cond_sterms = pos_state_terms cond in
+ let erasure_loc_cls = Aux.concat_map
+ (fun (local, body) ->
+ Aux.map_some
+ (fun (h, loc_body) ->
+ if List.mem h cond_sterms then Some (h, loc_body @ body)
+ else None)
+ local)
+ erasure_local in
+ let more_neg_rhs, more_conds = List.split erasure_loc_cls in
+ let cond = List.concat (more_conds @ conds) in
+ let pos_rhs =
+ Aux.list_remove ignore_rhs (Aux.unique_sorted pos_rhs) in
+ pos_rhs,
+ Aux.unique_sorted (more_neg_rhs @ neg_rhs),
+ Aux.unique_sorted cond
+
(* Assign rule clauses to rule cases, i.e. candidates for Toss
rules. Collect the conditions and RHS state terms together. Frame
clauses are already processed into erasure clauses. Rule clauses
@@ -1646,8 +1681,10 @@
let counter_cls, rule_cls =
split_counter_rule_cls counters num_functors rule_cls in
let required_cls = Aux.map_some
- (fun (h, required, body) ->
- if required then Some (h, body) else None) rule_cls in
+ (fun (h, kind, body) ->
+ if kind = Legal_cl then Some (h, body)
+ else None)
+ rule_cls in
let required_body = Aux.concat_map snd required_cls in
(* {{{ log entry *)
if !debug_level > 3 then (
@@ -1655,9 +1692,8 @@
(literals_str required_body)
);
(* }}} *)
- let unrequired_cls = Aux.map_some
- (fun (h, required, body) ->
- if not required then Some (h, body) else None) rule_cls in
+ let unrequired_cls = List.filter
+ (fun (_, kind, _) -> kind <> Legal_cl) rule_cls in
let forbidden_lits = Aux.unique_sorted
(Aux.concat_map
(fun (_, body) -> Aux.map_some (function
@@ -1666,73 +1702,83 @@
| Neg a -> Some (Pos a)
| _ -> None) body) required_cls) in
let unrequired_cls = List.filter
- (fun (_, body) ->
+ (fun (_, _, body) ->
not (List.exists (fun flit -> List.mem flit body)
forbidden_lits))
unrequired_cls in
- let unrequired_cls = List.filter
- (fun (_, unreq_body) ->
- let static_goal = optimize_goal ~testground
- (keep_rels static_rels (required_body @ unreq_body)) in
+ let filter_goal goal =
+ let static_goal = optimize_goal ~testground
+ (keep_rels static_rels goal) in
(* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf
- "\nrule_cases: checking unrequired %s\nstatic_goal=%s\n%!"
- (String.concat " "(List.map literal_str unreq_body))
- (String.concat " "(List.map literal_str static_goal));
- );
+ if !debug_level > 3 then (
+ Printf.printf
+ "\nrule_cases: checking static_goal=%s\goal=%s\n%!"
+ (String.concat " "(List.map literal_str static_goal))
+ (String.concat " "(List.map literal_str goal));
+ );
(* }}} *)
- let res =
- run_prolog_check_goal static_goal program &&
- let goal = optimize_goal ~testground
- (required_body @ unreq_body) in
+ let res =
+ run_prolog_check_goal static_goal program &&
+ 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))
- );
+ if !debug_level > 3 then (
+ Printf.printf
+ "goal=%s\n%!" (String.concat " "(List.map literal_str goal))
+ );
(* }}} *)
- List.exists
- (fun state ->
+ List.exists
+ (fun state ->
(* {{{ log entry *)
- if !debug_level > 3 then Printf.printf ".%!";
+ if !debug_level > 3 then Printf.printf ".%!";
(* }}} *)
- run_prolog_check_goal goal
- (replace_rel_in_program "true" (state_cls state) program))
- playout_states in
+ run_prolog_check_goal goal
+ (replace_rel_in_program "true" (state_cls state) program))
+ playout_states in
(* {{{ log entry *)
- if !debug_level > 3 then Printf.printf " %B\n%!" res;
+ if !debug_level > 3 then Printf.printf " %B\n%!" res;
(* }}} *)
- res
- )
+ res in
+ let unrequired_cls = Aux.map_some
+ (function
+ | h, Erasure_cl_inst local, cl_body ->
+ let local = List.filter
+ (fun (head, loc_body) ->
+ filter_goal
+ (Pos (True head)::required_body @ loc_body @ cl_body))
+ local in
+ if local = [] then None
+ else Some (h, Erasure_cl_inst local, cl_body)
+ | _, _, cl_body as cl ->
+ if filter_goal (required_body @ cl_body)
+ then Some cl else None)
unrequired_cls in
let req_atoms = List.map
(function Pos a -> a | Neg a -> a | _ -> assert false)
forbidden_lits in
let unreq_atoms = Aux.unique_sorted
(Aux.concat_map
- (fun (_, body) -> Aux.map_some (function
+ (fun (_, _, body) -> Aux.map_some (function
| Pos (Does _) | Neg (Does _) -> None
| Pos a | Neg a -> Some a
| _ -> None) body) unrequired_cls) in
let split_atoms = Aux.list_diff unreq_atoms req_atoms in
if split_atoms = [] then (* single partition *)
- let rule_cls = required_cls @ unrequired_cls in
- let case_rhs, case_conds = List.split rule_cls in
- let case_rhs = Aux.list_remove ignore_rhs case_rhs in
+ let rule_cls = Aux.map_prepend unrequired_cls
+ (fun (h,b) -> h, Legal_cl, b) required_cls in
+ let case_pos_rhs, case_neg_rhs, case_cond =
+ split_rule_cand rule_cls in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "rule_cases: single partition\n%!";
);
(* }}} *)
[Aux.Ints.singleton 0,
- (Aux.unique_sorted case_rhs, counter_cls,
- Aux.unique_sorted (List.concat case_conds))]
+ (case_pos_rhs, case_neg_rhs, counter_cls, case_cond)]
else
let patterns =
let unrequired_cls = Array.of_list unrequired_cls in
List.map (fun a ->
- Array.mapi (fun i (_, body) ->
+ Array.mapi (fun i (_, _, body) ->
if List.mem (Neg a) body then -1
else if List.mem (Pos a) body then 1
else 0
@@ -1751,11 +1797,15 @@
(Aux.array_fprint (fun ch -> Printf.fprintf ch "%+d")) pattern
(String.concat " " (List.map atom_str atoms)) in
List.iter print_pat patterns;
- let print_cl i (h, body) =
- Printf.printf "%d: %s <== %s\n%!" i (term_str h)
+ let print_cl i (h, kind, body) =
+ Printf.printf "%d: (%s) %s <== %s\n%!" i
+ (match kind with Erasure_cl_OK | Erasure_cl_inst _ -> "eras"
+ | _ -> "move")
+ (term_str h)
(String.concat " " (List.map literal_str body)) in
Printf.printf "rule_cases: required cls --\n%!";
- Array.iteri print_cl (Array.of_list required_cls);
+ Array.iteri print_cl (Aux.array_map_of_list
+ (fun (h,b)->h,Legal_cl,b) required_cls);
Printf.printf "rule_cases: split on cls --\n%!";
Array.iteri print_cl (Array.of_list unrequired_cls)
);
@@ -1766,7 +1816,7 @@
let separation_cond =
List.map (fun (a,b) -> if b then Pos a else Neg a) choice in
let case =
- Aux.array_mapi_some (fun i (_, body as cl) ->
+ Aux.array_mapi_some (fun i (_, _, body as cl) ->
if
List.for_all (fun (a,b) ->
if b then (* atom not excluded *)
@@ -1781,14 +1831,12 @@
Aux.ints_of_list ids, separation_cond, cls in
let cases = List.map rule_case choices in
let process_case (ids, separation_cond, case_cls) =
- let case_cls = case_cls @ required_cls in
- let case_rhs, case_conds = List.split case_cls in
- let case_rhs =
- Aux.list_remove ignore_rhs (Aux.unique_sorted case_rhs) in
- let case_conds =
- Aux.unique_sorted (List.concat case_conds) in
+ let case_cls = Aux.map_prepend case_cls
+ (fun (h,b) -> h, Legal_cl, b) required_cls in
+ let case_pos_rhs, case_neg_rhs, case_cond =
+ split_rule_cand case_cls in
let separation_cond =
- remove_local_vars (literals_vars case_conds) separation_cond in
+ remove_local_vars (literals_vars case_cond) separation_cond in
(* {{{ log entry *)
if !debug_level > 3 then (
let cond_upd_str (cond, update) =
@@ -1798,15 +1846,16 @@
counter^": "^String.concat ", "
(List.map cond_upd_str cond_updates) in
Printf.printf
- "\nRCAND:\nsep_cond: %s\nRHS: %s\nCOUNTER_CLs: %s\ncase_conds: %s\n\n%!"
+ "\nRCAND:\nsep_cond: %s\nPOS-RHS: %s\nNEG-RHS: %s\nCOUNTER_CLs: %s\ncase_cond: %s\n\n%!"
(String.concat " " (List.map literal_str separation_cond))
- (String.concat " " (List.map term_str case_rhs))
+ (String.concat " " (List.map term_str case_pos_rhs))
+ (String.concat " " (List.map term_str case_neg_rhs))
(String.concat "; " (List.map counters_str counter_cls))
- (String.concat " " (List.map literal_str case_conds))
+ (String.concat " " (List.map literal_str case_cond))
);
(* }}} *)
let case_cond =
- Aux.unique_sorted (separation_cond @ case_conds) in
+ Aux.unique_sorted (separation_cond @ case_cond) in
let counter_cls = List.map
(fun (f, brs) ->
let brs = List.map
@@ -1816,7 +1865,7 @@
brs in
f, brs)
counter_cls in
- ids, (case_rhs, counter_cls, case_cond) in
+ ids, (case_pos_rhs, case_neg_rhs, counter_cls, case_cond) in
let res = List.map process_case cases in
(* {{{ log entry *)
if !debug_level > 2 then (
@@ -1827,9 +1876,11 @@
counter^": "^String.concat ", "
(List.map cond_upd_str cond_updates) in
Printf.printf "rule_cases: next clauses partitioned into rules\n%!";
- let print_case i (ids, (case_rhs, counter_cls, case_cond)) =
- Printf.printf "\nRCAND: #%d\nRHS: %s\nCOUNTER_CLs: %s\nLHS: %s\n%!" i
- (String.concat " " (List.map term_str case_rhs))
+ let print_case i
+ (ids, (case_pos_rhs, case_neg_rhs, counter_cls, case_cond)) =
+ Printf.printf "\nRCAND: #%d\nPOS-RHS: %s\nNEG-RHS: %s\nCOUNTER_CLs: %s\nLHS: %s\n%!" i
+ (String.concat " " (List.map term_str case_pos_rhs))
+ (String.concat " " (List.map term_str case_neg_rhs))
(String.concat "; " (List.map counters_str counter_cls))
(String.concat " " (List.map literal_str case_cond)) in
Array.iteri print_case (Array.of_list res)
@@ -1838,6 +1889,7 @@
res
+
let process_rule_cands used_vars f_paths next_cls mode
players_wo_env legal_tuples =
let move_tups =
@@ -1850,9 +1902,9 @@
if !debug_level > 2 then (
Printf.printf
"process_rule_cands: move tuples before adding erasure cls--\n%!";
- let nclause_str (rhs, (is_frame, required), body) =
+ let nclause_str (rhs, is_frame, body) =
Printf.printf
- "%s <=fr:%B;req:%B= %s\n%!"(term_str rhs) is_frame required
+ "%s <=fr:%B= %s\n%!"(term_str rhs) is_frame
(String.concat " "(List.map literal_str body)) in
let print_tup i (legal_tup, n_cls) =
Printf.printf "CAND: #%d\nlegal_tup: %s\n%!" i
@@ -1881,30 +1933,30 @@
(fun v -> v, Const v) fixed_vars in
let legal_lits = subst_literals var_to_fixed legal_lits in
let next_cls = List.map (* fix [legal_tup] vars in "next" *)
- (fun (head, req, body) ->
- subst_consts var_to_fixed head, req,
+ (fun (head, kind, body) ->
+ subst_consts var_to_fixed head, kind,
subst_consts_literals var_to_fixed body)
next_cls in
(* Filter-out redundant conditions. Note that unfixed variables in
"next" clauses are local to clauses. *)
let next_cls = List.map
- (fun (head, req, body) ->
+ (fun (head, kind, body) ->
let sb, body = filter_redundant legal_lits body in
- subst sb head, req, subst_literals sb body)
+ subst sb head, kind, subst_literals sb body)
next_cls in
let fixed_to_var = List.map
(fun v -> v, Var v) fixed_vars in
let next_cls = List.map
- (fun (head, req, body) ->
- subst_consts fixed_to_var head, req,
+ (fun (head, kind, body) ->
+ subst_consts fixed_to_var head, kind,
subst_consts_literals fixed_to_var body)
next_cls in
- let legal_cls = List.map (* required clauses *)
- (fun body -> ignore_rhs, true, body) legal_conds in
+ let legal_cls = List.map
+ (fun body -> ignore_rhs, Legal_cl, body) legal_conds in
List.map
- (fun (ids, (case_rhs, updates, case_cond)) ->
- ids, (legal_tup, case_rhs, updates, case_cond))
+ (fun (ids, (pos_rhs, neg_rhs, updates, case_cond)) ->
+ ids, (legal_tup, pos_rhs, neg_rhs, updates, case_cond))
(rule_cases counters num_functors static_rels testground program
playout_states (legal_cls @ next_cls))
@@ -2083,9 +2135,10 @@
let counters_str (counter, cond_updates) =
counter^": "^String.concat ", "
(List.map cond_upd_str cond_updates) in
- let print_rcand i (_, (_, case_rhs, counter_cls, case_cond)) =
- Printf.printf "\nRCAND: #%d\nRHS: %s\nCOUNTER_CLs: %s\nLHS: %s\n%!" i
- (String.concat " " (List.map term_str case_rhs))
+ let print_rcand i (_, (_, pos_rhs, neg_rhs, counter_cls, case_cond)) =
+ Printf.printf "\nRCAND: #%d\nPOS-RHS: %s\nNEG-RHS: %s\nCOUNTER_CLs: %s\nLHS: %s\n%!" i
+ (String.concat " " (List.map term_str pos_rhs))
+ (String.concat " " (List.map term_str neg_rhs))
(String.concat "; " (List.map counters_str counter_cls))
(String.concat " " (List.map literal_str case_cond)) in
let print_rcands (player, rcands) =
@@ -2106,21 +2159,21 @@
playout_states rule_cands =
let check_cands cands =
let cands =
- List.filter (fun (_, (_, _, _, case_conds)) ->
+ List.filter (fun (_, (_, _, _, _, case_cond)) ->
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "check_cands: cond %s%!"
- (String.concat " "(List.map literal_str case_conds))
+ (String.concat " "(List.map literal_str case_cond))
);
(* }}} *)
let res =
- run_prolog_check_goal (keep_rels static_rels case_conds) program
+ run_prolog_check_goal (keep_rels static_rels case_cond) program
&& List.exists
(fun state ->
(* {{{ log entry *)
if !debug_level > 1 then Printf.printf ".%!";
(* }}} *)
- run_prolog_check_goal case_conds
+ run_prolog_check_goal case_cond
(replace_rel_in_program "true" (state_cls state) program))
playout_states in
(* {{{ log entry *)
@@ -2134,10 +2187,11 @@
(Aux.maximal_unique
(fun (s1, _) (s2, _) -> Aux.Ints.subset s1 s2)
cands) in
- let add_rhs_as_lhs (legal_tup, case_rhs, updates, case_cond) =
+ let add_rhs_as_lhs (legal_tup, pos_rhs, neg_rhs, updates, case_cond) =
let case_blanks = List.map
- (fun s -> Pos (True (simult_subst f_paths blank s))) case_rhs in
- legal_tup, case_rhs, updates,
+ (fun s -> Pos (True (simult_subst f_paths blank s)))
+ (pos_rhs @ neg_rhs) in
+ legal_tup, pos_rhs, neg_rhs, updates,
Aux.unique_sorted (case_blanks @ case_cond) in
let process cands = List.map add_rhs_as_lhs (check_cands cands) in
match rule_cands with
@@ -2300,7 +2354,7 @@
let build_toss_rule num_functions transl_data rule_names
framed_fluents f_paths struc fluents
synch_elems synch_precond synch_postcond
- (legal_tuple, case_rhs, counter_cls, case_cond) =
+ (legal_tuple, pos_rhs, neg_rhs, counter_cls, case_cond) =
let rname =
if legal_tuple = [] then term_to_name env_player
else String.concat "_" (List.map term_to_name legal_tuple) in
@@ -2327,7 +2381,7 @@
(Formula.str (Formula.And synch_precond)) (Formula.str case_precond)
);
(* }}} *)
- let rhs_add = Aux.concat_map
+ let extract_tups = Aux.concat_map
(fun sterm ->
let s_subterms =
map_paths (fun path subt -> subt, path)
@@ -2338,15 +2392,15 @@
let vartup = [|term_to_name (blank_out transl_data sterm)|] in
List.map (fun (subt, path) ->
pred_on_path_subterm path subt, vartup)
- s_subterms)
- case_rhs in
- let rhs_add = synch_postcond @ rhs_add in
- (* let rhs_add = if counter_cls = [] then rhs_add else *)
+ s_subterms) in
+ let add = synch_postcond @ extract_tups pos_rhs in
+ (* let add = if counter_cls = [] then add else *)
+ let del = extract_tups neg_rhs in
let signat = Structure.rel_signature struc in
(* we find which rule results should have their old values erased,
in cases not covered by erasure clauses *)
let used_fluents = Aux.concat_map
- (map_paths (fun p subt -> p, subt) f_paths) case_rhs in
+ (map_paths (fun p subt -> p, subt) f_paths) pos_rhs in
let unframed_fluents = List.filter
(fun (p, subt) ->
let f_subts = Aux.assoc_all p framed_fluents in
@@ -2358,7 +2412,7 @@
(fun st -> List.exists
(fun (p,subt) -> try at_path st p = subt with Not_found -> false)
unframed_fluents)
- (Aux.list_diff (state_terms case_cond) case_rhs) in
+ (Aux.list_diff (state_terms case_cond) pos_rhs) in
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf "build_toss_rule: unframed_fluents=%s; unframed_elems=%s\n%!"
@@ -2367,8 +2421,10 @@
(String.concat ", " (List.map term_str unframed_elems))
);
(* }}} *)
+ let all_rhs = pos_rhs @ neg_rhs in
let struc_elems = List.map
- (fun sterm -> term_to_name (blank_out transl_data sterm)) case_rhs in
+ (fun sterm -> term_to_name (blank_out transl_data sterm))
+ all_rhs in
let unframed_elems = List.map
(fun sterm -> term_to_name (blank_out transl_data sterm))
unframed_elems in
@@ -2379,7 +2435,7 @@
(Aux.product [unframed_elems; struc_elems])
@ List.map (fun (x,y) -> [|x; y|]) (Aux.pairs unframed_elems) in
let rulevar_terms = Aux.strmap_of_assoc
- (List.combine struc_elems case_rhs) in
+ (List.combine struc_elems all_rhs) in
let struc_elems = Aux.unique_sorted
(synch_elems @ unfram...
[truncated message content] |
|
From: <luk...@us...> - 2011-11-03 18:40:01
|
Revision: 1619
http://toss.svn.sourceforge.net/toss/?rev=1619&view=rev
Author: lukstafi
Date: 2011-11-03 18:39:52 +0000 (Thu, 03 Nov 2011)
Log Message:
-----------
Formula-based rewrite rule representation is now primary, with parsing and printing (but if parsed from structure-based then printed structure-based). GameSimpl: giving up simplification inside structure-based rewrite rule representations.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/ContinuousRuleParser.mly
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Arena/DiscreteRuleParser.mly
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGame.mli
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Play/MoveTest.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/ReqHandler.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-11-01 09:32:09 UTC (rev 1618)
+++ trunk/Toss/Arena/Arena.ml 2011-11-03 18:39:52 UTC (rev 1619)
@@ -48,7 +48,7 @@
parameters : (string * float) list ;
rule : string ;
next_loc : int ;
- embedding : (int * int) list ;
+ matching : (string * int) list ;
}
(* State of the game and additional information. *)
@@ -85,31 +85,26 @@
(* -------------------- PARSER HELPER ------------------------------ *)
-let emb_of_names (game, state) rname emb_str =
- let lhs =
- (List.assoc rname game.rules
- ).ContinuousRule.discrete.DiscreteRule.lhs_struc in
+let matching_of_names (game, state) rname match_str =
try
- List.map (fun (lhs_e, m_e) ->
- (try Structure.find_elem lhs lhs_e
- with Not_found -> Printf.printf "NF lhs_e=%s\n%!" lhs_e;
- raise Not_found),
+ List.map (fun (lhs_v, m_e) ->
+ lhs_v,
(try Structure.find_elem state.struc m_e
with Not_found -> Printf.printf "NF m_e=%s\n%!" m_e;
raise Not_found))
- emb_str
+ match_str
with Not_found ->
(* {{{ log entry *)
if !debug_level > 0 then (
- Printf.printf "emb_of_names: failed at LHS=\n%s\nSTRUC=\n%s\nEMB=%s\n%!"
- (Structure.str lhs) (Structure.str state.struc)
+ Printf.printf "matching_of_names: failed at STRUC=\n%s\nMATCH=%s\n%!"
+ (Structure.str state.struc)
(String.concat "; "
- (List.map (fun (v,e) ->v^"<-"^e) emb_str))
+ (List.map (fun (v,e) ->v^"<-"^e) match_str))
);
(* }}} *)
failwith ("emb_of_names: could not find " ^
String.concat "; "
- (List.map (fun (v,e) ->v^"<-"^e) emb_str))
+ (List.map (fun (v,e) ->v^"<-"^e) match_str))
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
@@ -192,7 +187,7 @@
(* Helper: Apply a move to a game state, get the new state. *)
let apply_move rules state (m, t) =
let r = List.assoc m.rule rules in
- match ContinuousRule.rewrite_single state.struc state.time m.embedding r
+ match ContinuousRule.rewrite_single state.struc state.time m.matching r
m.mv_time m.parameters with
| Some (new_struc, new_time, _) ->
{ struc = new_struc;
@@ -484,12 +479,8 @@
{game with
rules = List.map (fun (rn, r) ->
rn, {r with ContinuousRule.discrete =
- {r.ContinuousRule.discrete with
- DiscreteRule.lhs_struc =
- f r.ContinuousRule.discrete.DiscreteRule.lhs_struc;
- DiscreteRule.rhs_struc =
- f r.ContinuousRule.discrete.DiscreteRule.rhs_struc;
- }}) game.rules},
+ DiscreteRule.map_to_structures f r.ContinuousRule.discrete}
+ ) game.rules},
{state with
struc = f state.struc}
@@ -501,7 +492,7 @@
let all_fluents game =
let drules =
- List.map (fun r -> (snd r).ContinuousRule.compiled) game.rules in
+ List.map (fun r -> (snd r).ContinuousRule.discrete) game.rules in
DiscreteRule.fluents drules
@@ -633,12 +624,12 @@
| GetRuleCond of string (* Get a rule conditions *)
| SetRuleEmb of string * string list (* Set relations to embed *)
| GetRuleEmb of string (* Get relations to embed *)
- | SetRuleAssoc of string * string * string list (* Set an association *)
+ | SetRuleAssoc of string * string * string (* Set an association *)
| GetRuleAssoc of string * string (* Get an association *)
| GetRuleMatches of string (* Get matches of a rule *)
| ApplyRule of string * (string * string) list * float * (string * float) list
(* Apply rule at match for given time and with params *)
- | ApplyRuleInt of string * (int * int) list * float * (string * float) list
+ | ApplyRuleInt of string * (string * int) list * float * (string * float) list
(* Apply rule at match for given time and with params *)
| GetRuleNames (* Get names of all rules *)
| SetTime of float * float (* Set time step and time *)
@@ -663,10 +654,10 @@
let r = (List.assoc rn state_game.rules) in
let signat = Structure.rel_signature state.struc in
let defs = state_game.defined_rels in
- let (new_r, msg) =
+ let new_r =
ContinuousRule.apply_to_side true f signat defs r in
let new_rules = Aux.replace_assoc rn new_r state_game.rules in
- (({state_game with rules=new_rules}, state), msg)
+ (({state_game with rules=new_rules}, state), "")
with Not_found ->
((state_game, state),
"ERR [Not found] on left location of " ^ rn ^", " ^ err_msg)
@@ -676,10 +667,10 @@
let r = (List.assoc rn state_game.rules) in
let signat = Structure.rel_signature state.struc in
let defs = state_game.defined_rels in
- let (new_r, msg) =
+ let new_r =
ContinuousRule.apply_to_side false f signat defs r in
let new_rules = Aux.replace_assoc rn new_r state_game.rules in
- (({state_game with rules=new_rules}, state), msg)
+ (({state_game with rules=new_rules}, state), "")
with Not_found ->
((state_game, state),
"ERR [Not found] on right location of "^rn^", " ^ err_msg)
@@ -691,7 +682,10 @@
| Left r_name -> (
try
let r = (List.assoc r_name state_game.rules) in
- f r.ContinuousRule.discrete.DiscreteRule.lhs_struc
+ (match r.ContinuousRule.discrete.DiscreteRule.struc_rule
+ with
+ | None -> raise Not_found
+ | Some r -> f r.DiscreteRule.lhs_struc)
with Not_found ->
"ERR [Not found] getting from left location of " ^
r_name ^ ", " ^ err_msg
@@ -699,7 +693,10 @@
| Right r_name ->
try
let r = (List.assoc r_name state_game.rules) in
- f r.ContinuousRule.discrete.DiscreteRule.rhs_struc
+ (match r.ContinuousRule.discrete.DiscreteRule.struc_rule
+ with
+ | None -> raise Not_found
+ | Some r -> f r.DiscreteRule.rhs_struc)
with Not_found ->
"ERR [Not found] getting from right location of " ^
r_name ^ ", " ^ err_msg
@@ -869,12 +866,12 @@
((state_game, state),
String.concat ", " (List.sort compare (List.map ev payoffs)))
| SetLocMoves (i, moves) -> failwith "unsupported for now, concurrency"
- (* if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
- else (
- state_game.graph.(i) <- { state_game.graph.(i) with moves = moves };
- ((state_game, state), "LOC MOVES SET")
- ) *)
+ (* if i < 0 || i > Array.length state_game.graph then
+ ((state_game, state), "ERR location "^string_of_int i^" not found")
+ else (
+ state_game.graph.(i) <- { state_game.graph.(i) with moves = moves };
+ ((state_game, state), "LOC MOVES SET")
+ ) *)
| GetLocMoves (i) ->
if i < 0 || i > Array.length state_game.graph then
((state_game, state), "ERR location "^string_of_int i^" not found")
@@ -938,13 +935,24 @@
let (dyn, upd)=(r.ContinuousRule.dynamics, r.ContinuousRule.update) in
let signat = Structure.rel_signature state.struc in
let defs = state_game.defined_rels in
+ let discr =
+ match d.DiscreteRule.struc_rule with
+ | None ->
+ {d with DiscreteRule.match_formula = pre}
+ | Some rule_src ->
+ DiscreteRule.compile_rule signat defs
+ {rule_src with DiscreteRule.pre = pre} in
let nr = (* TODO: rename lhs_* relations to be consistent with ln *)
- ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in
+ ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
(nr, "RULE COND SET") in
apply_to_rule set_cond r_name (state_game, state) "set rule cond"
| GetRuleCond (r_name) ->
let get_cond r =
- let pre = r.ContinuousRule.discrete.DiscreteRule.pre in
+ let discr = r.ContinuousRule.discrete in
+ let pre =
+ match discr.DiscreteRule.struc_rule with
+ | None -> discr.DiscreteRule.match_formula
+ | Some struc_r -> struc_r.DiscreteRule.pre in
let (inv, post)=(r.ContinuousRule.inv, r.ContinuousRule.post) in
(Formula.str pre)^"; "^ (Formula.str inv) ^"; "^ (Formula.str post) in
((state_game, state),
@@ -952,53 +960,86 @@
| SetRuleEmb (r_name, emb) ->
let set_emb r =
- let d =
- { r.ContinuousRule.discrete with DiscreteRule.emb_rels =emb } in
- let (dyn, upd)=(r.ContinuousRule.dynamics, r.ContinuousRule.update) in
- let pre = r.ContinuousRule.discrete.DiscreteRule.pre
- and inv = r.ContinuousRule.inv
- and post = r.ContinuousRule.post in
- let signat = Structure.rel_signature state.struc in
- let defs = state_game.defined_rels in
- let nr =
- ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in
- (nr, "RULE EMB SET") in
+ let struc_r = r.ContinuousRule.discrete.DiscreteRule.struc_rule in
+ match struc_r with
+ | None ->
+ r,
+ "ERR Set Rule Embedding: formula-based format of " ^
+ r_name
+ | Some struc_r ->
+ let struc_r = {struc_r with DiscreteRule.emb_rels =emb } in
+ let (dyn, upd)=
+ (r.ContinuousRule.dynamics, r.ContinuousRule.update) in
+ let inv = r.ContinuousRule.inv
+ and post = r.ContinuousRule.post in
+ let signat = Structure.rel_signature state.struc in
+ let defs = state_game.defined_rels in
+ let discr = DiscreteRule.compile_rule signat defs struc_r in
+ let nr =
+ ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
+ (nr, "RULE EMB SET") in
apply_to_rule set_emb r_name (state_game, state) "set rule emb"
+
| GetRuleEmb (r_name) ->
let get_emb r =
- String.concat ", " r.ContinuousRule.discrete.DiscreteRule.emb_rels in
+ let struc_r = r.ContinuousRule.discrete.DiscreteRule.struc_rule in
+ match struc_r with
+ | None ->
+ "ERR Get Rule Embedding: formula-based format of " ^
+ r_name
+ | Some struc_r ->
+ String.concat ", " struc_r.DiscreteRule.emb_rels in
((state_game, state),
get_from_rule get_emb r_name state_game "get rule emb")
- | SetRuleAssoc (r_name, r_elem_name, rassoc) ->
+
+ | SetRuleAssoc (r_name, rhs_v, lhs_v) ->
let set_assoc r =
- let lname l = Structure.find_elem (ContinuousRule.lhs r) l in
- let relem =
- Structure.find_elem (ContinuousRule.rhs r) r_elem_name in
- let ra = List.map (fun l -> (relem, lname l)) rassoc in
- let olda = r.ContinuousRule.discrete.DiscreteRule.rule_s in
- let a = ra @ (List.filter (fun (r, l) -> r <> relem) olda) in
- let d =
- { r.ContinuousRule.discrete with DiscreteRule.rule_s = a } in
- let (dyn, upd)=(r.ContinuousRule.dynamics, r.ContinuousRule.update) in
- let pre = r.ContinuousRule.discrete.DiscreteRule.pre
- and inv = r.ContinuousRule.inv
- and post = r.ContinuousRule.post in
+ let discr = r.ContinuousRule.discrete in
let signat = Structure.rel_signature state.struc in
let defs = state_game.defined_rels in
+ let discr =
+ match discr.DiscreteRule.struc_rule with
+ | Some struc_r ->
+ let lhs_e = Structure.find_elem
+ struc_r.DiscreteRule.lhs_struc lhs_v in
+ let rhs_e = Structure.find_elem
+ struc_r.DiscreteRule.rhs_struc rhs_v in
+ let rule_s = Aux.replace_assoc rhs_e lhs_e
+ (List.filter (fun (r, l) -> r <> rhs_e)
+ struc_r.DiscreteRule.rule_s) in
+ DiscreteRule.compile_rule signat defs
+ {struc_r with DiscreteRule.rule_s = rule_s}
+ | None ->
+ let rlmap =
+ match discr.DiscreteRule.rlmap with
+ | None ->
+ List.map (fun v->v,v) discr.DiscreteRule.lhs_vars
+ | Some rlmap -> rlmap in
+ let rlmap =
+ Aux.replace_assoc rhs_v lhs_v rlmap in
+ {discr with DiscreteRule.rlmap = Some rlmap} in
+ let (dyn, upd) =
+ (r.ContinuousRule.dynamics, r.ContinuousRule.update) in
+ let inv = r.ContinuousRule.inv
+ and post = r.ContinuousRule.post in
let nr =
- ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in
- (nr, "RULE ASSOC SET") in
+ ContinuousRule.make_rule defs discr dyn upd ~inv ~post () in
+ (nr, "RULE ASSOC SET")
+ in
apply_to_rule set_assoc r_name (state_game, state) "set rule assoc"
- | GetRuleAssoc (r_name, r_elem_name) ->
+
+ | GetRuleAssoc (r_name, rhs_v) ->
let get_assoc r =
- let assoc = r.ContinuousRule.discrete.DiscreteRule.rule_s in
- let relem =
- Structure.find_elem (ContinuousRule.rhs r) r_elem_name in
- let rassoc = List.filter (fun (r, l) -> r = relem) assoc in
- let l e = Structure.elem_str (ContinuousRule.lhs r) e in
- String.concat ", " (List.map (fun (_, le) -> l le) rassoc) in
+ let assoc = r.ContinuousRule.discrete.DiscreteRule.rlmap in
+ match assoc with
+ (* TODO: the RHS variables could have gotten renamed!
+ Best would be to check if there is struc_rule if
+ [rlmap = None] *)
+ | None -> rhs_v
+ | Some a -> List.assoc rhs_v a in
((state_game, state),
get_from_rule get_assoc r_name state_game "get rule assoc")
+
| GetRuleMatches (r_name) -> (
try
let r = List.assoc r_name state_game.rules in
@@ -1006,21 +1047,20 @@
(* matches are from LHS to model *)
((state_game, state),
String.concat "; " (
- List.map (ContinuousRule.embedding_str r struc) matches))
+ List.map (ContinuousRule.matching_str struc) matches))
with Not_found ->
((state_game, state), "ERR getting "^r_name^" matches, rule not found")
)
+
| ApplyRule (r_name, mtch, t, p) ->
(let try r = List.assoc r_name state_game.rules in
- let lhs_struc = ContinuousRule.lhs r in
- let m = List.map (fun (l, s) ->
- Structure.find_elem lhs_struc l,
+ let m = List.map (fun (l, s) -> l,
Structure.find_elem state.struc s) mtch in
match ContinuousRule.rewrite_single struc state.time m r t p with
| Some (new_struc, new_time, shifts) ->
let val_str ((f, e), tl) =
let ts t = string_of_float (Term.term_val t) in
- (* we've moved to using element names in Term *)
+ (* we've moved to using element names in Term *)
f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in
let shifts_s = String.concat "; " (List.map val_str shifts) in
((state_game, {state with struc = new_struc; time = new_time}),
@@ -1030,6 +1070,7 @@
with Not_found ->
((state_game, state), "ERR applying "^r_name^", rule not found")
)
+
| ApplyRuleInt (r_name, mtch, t, p) ->
(let try r = List.assoc r_name state_game.rules in
match ContinuousRule.rewrite_single struc state.time mtch r t p with
@@ -1046,6 +1087,7 @@
with Not_found ->
((state_game, state), "ERR applying " ^ r_name ^ ", rule not found")
)
+
| GetRuleNames -> ((state_game, state),
String.concat "; " (fst (List.split state_game.rules)))
| SetTime (tstep, t) ->
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-11-01 09:32:09 UTC (rev 1618)
+++ trunk/Toss/Arena/Arena.mli 2011-11-03 18:39:52 UTC (rev 1619)
@@ -42,7 +42,7 @@
parameters : (string * float) list ;
rule : string ;
next_loc : int ;
- embedding : (int * int) list ;
+ matching : (string * int) list ;
}
@@ -61,8 +61,9 @@
(** Translate from names to elements to get rule embedding. *)
-val emb_of_names :
- game * game_state -> string -> (string * string) list -> (int * int) list
+val matching_of_names :
+ game * game_state -> string -> (string * string) list ->
+ (string * int) list
(** Rules with which a player with given number can move. *)
val rules_for_player : int -> game -> string list
@@ -220,12 +221,12 @@
| GetRuleCond of string (** Get a rule conditions *)
| SetRuleEmb of string * string list (** Set relations to embed *)
| GetRuleEmb of string (** Get relations to embed *)
- | SetRuleAssoc of string * string * string list (** Set an association *)
+ | SetRuleAssoc of string * string * string (** Set an r-l rule_s pair *)
| GetRuleAssoc of string * string (** Get an association *)
| GetRuleMatches of string (** Get matches of a rule *)
| ApplyRule of string * (string * string) list * float * (string * float) list
(** Apply rule at match for given time and with params *)
- | ApplyRuleInt of string * (int * int) list * float * (string * float) list
+ | ApplyRuleInt of string * (string * int) list * float * (string * float) list
| GetRuleNames (** Get names of rules *)
| SetTime of float * float (** Set time step and time *)
| GetTime (** Get time step and time *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-11-01 09:32:09 UTC (rev 1618)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-11-03 18:39:52 UTC (rev 1619)
@@ -89,9 +89,9 @@
| OPENSQ RULE_SPEC? r = id_int COMMA? t = FLOAT COMMA?
p = separated_list (COMMA, separated_pair (ID, COLON, FLOAT))
RARR LOC_MOD? l = INT EMB
- emb = separated_list (COMMA, separated_pair (INT, COLON, INT)) CLOSESQ
+ emb = separated_list (COMMA, separated_pair (ID, COLON, INT)) CLOSESQ
f = FLOAT?
- { ({mv_time = t; parameters = p; rule = r; next_loc = l; embedding = emb;},
+ { ({mv_time = t; parameters = p; rule = r; next_loc = l; matching = emb;},
f) }
| OPENSQ error
{ Lexer.report_parsing_error $startpos $endpos
@@ -247,8 +247,8 @@
{ GetRuleDyn (r, fn, elem) }
| SET_CMD RULE_SPEC ASSOC
r=id_int rhs_elem=id_int
- lhs_elems = separated_list (COMMA, id_int)
- { SetRuleAssoc (r, rhs_elem, lhs_elems) }
+ lhs_elem=id_int
+ { SetRuleAssoc (r, rhs_elem, lhs_elem) }
| SET_CMD DYNAMICS t0=FLOAT t1=FLOAT { SetTime (t0, t1) }
| GET_CMD DYNAMICS { GetTime }
| GET_CMD RULE_SPEC ASSOC r=id_int rhs_elem=id_int
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2011-11-01 09:32:09 UTC (rev 1618)
+++ trunk/Toss/Arena/ArenaTest.ml 2011-11-03 18:39:52 UTC (rev 1619)
@@ -18,7 +18,7 @@
(fun () ->
let rule_a =
- "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] with [c <- a, d <- b] pre true inv true post true" in
+ "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] with [c <- a, d <- b] inv true post true" in
let s = "SET RULE rule_a " ^ rule_a in
let (gs, _) = Arena.handle_request Arena.empty_state (req_of_str s) in
let (_, msg) = Arena.handle_request gs (req_of_str "GET RULE rule_a") in
@@ -26,7 +26,7 @@
rule_a msg;
let rule_e =
- "[ | | ] -> [ | | ] with [] pre true inv true post true" in
+ "[ | | ] -> [ | | ] with [] inv true post true" in
let s =
"SET RULE e " ^ rule_e in
let (gs,_) =
@@ -36,12 +36,12 @@
rule_e msg;
let rule_1 =
- "[ 1 | | vx { 1->0. }; vy { 1->0. }; x { 1->-15.4 }; y { 1->-50.6 } ] -> [ 1, 2 | | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-14.3, 2->6.6 }; y { 1->-77., 2->2.2 } ] with [1 <- 1] update :x(1) = 1 pre true inv true post true "in
+ "[ 1 | | vx { 1->0. }; vy { 1->0. }; x { 1->-15.4 }; y { 1->-50.6 } ] -> [ 1, 2 | | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-14.3, 2->6.6 }; y { 1->-77., 2->2.2 } ] with [1 <- 1] update :x(1) = 1 inv true post true "in
let rule_1_res =
"[1 | | vx {1->0.}; vy {1->0.}; x {1->-15.4}; y {1->-50.6}] -> [1, 2 | | vx {1->0., 2->0.}; vy {1->0., 2->0.}; x {1->-14.3, 2->6.6}; y {1->-77., 2->2.2}] with [1 <- 1]
update
:x(1) = 1.
- pre true inv true post true" in
+ inv true post true" in
let s = "SET RULE 1 " ^ rule_1 in
let (gs,_) = Arena.handle_request Arena.empty_state (req_of_str s) in
let (_, msg) = Arena.handle_request gs (req_of_str "GET RULE 1") in
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2011-11-01 09:32:09 UTC (rev 1618)
+++ trunk/Toss/Arena/ContinuousRule.ml 2011-11-03 18:39:52 UTC (rev 1619)
@@ -12,7 +12,6 @@
(* Specification of a continuous rewriting rule, as in modelling document. *)
type rule = {
discrete : DiscreteRule.rule; (* The discrete part *)
- compiled : DiscreteRule.rule_obj ; (* Compiled discrete part *)
dynamics : ((string * string) * Term.term) list; (* Equation system calD *)
update : ((string * string) * Formula.real_expr) list;
(* Update equations calT *)
@@ -21,24 +20,17 @@
post : Formula.formula; (* Postcondition for application *)
}
-(* Create a continuous rule given a discrete rule and other params. *)
-let make_rule signat defs discr dynamics update ?(pre=Formula.And [])
+(* Create a continuous rule given a discrete rule and other
+ params. Substitute (inline) defined relations. *)
+let make_rule defs discrete dynamics update
?(inv=Formula.And []) ?(post=Formula.And []) () =
(* note that replacing not required for [pre]: [compile_rule] does it *)
- let cpre = FormulaSubst.subst_rels defs pre in
- let cinv = FormulaSubst.subst_rels defs inv in
- let cpost = FormulaSubst.subst_rels defs post in
- let discrete = { discr with DiscreteRule.pre = cpre } in
- (* we use [discrete] instead of [discr] because parser does not
- insert precondition into discr! *)
- let obj = DiscreteRule.compile_rule signat defs discrete in
- { discrete = discrete;
- compiled = obj ;
- dynamics = dynamics ;
- update = update ;
- inv = cinv ;
- post = cpost ;
- }
+ let discrete = DiscreteRule.map_to_formulas
+ (FormulaSubst.subst_rels defs) discrete in
+ 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; }
@@ -47,34 +39,40 @@
(* Apply [f] to left (if [to_left]) or right side of the given named rule.
Return the new rule and an additional result which [f] returns. *)
let apply_to_side to_left f signat defs r =
- let struc = if to_left then r.discrete.DiscreteRule.lhs_struc else
- r.discrete.DiscreteRule.rhs_struc in
- let (res_struc, res) = f struc in
- let discr = if to_left then
- { r.discrete with DiscreteRule.lhs_struc = res_struc }
- else
- { r.discrete with DiscreteRule.rhs_struc = res_struc } in
- (make_rule signat defs discr r.dynamics r.update
- ~pre:r.discrete.DiscreteRule.pre ~inv:r.inv ~post:r.post (), res)
+ match r.discrete.DiscreteRule.struc_rule with
+ | None -> r
+ | Some struc_r ->
+ let struc =
+ if to_left
+ then struc_r.DiscreteRule.lhs_struc
+ else struc_r.DiscreteRule.rhs_struc in
+ let (res_struc, res) = f struc in
+ let struc_r = if to_left then
+ { struc_r with DiscreteRule.lhs_struc = res_struc }
+ else
+ { struc_r with DiscreteRule.rhs_struc = res_struc } in
+ let discrete = DiscreteRule.compile_rule signat defs struc_r in
+ {r with discrete}
-let lhs r = r.discrete.DiscreteRule.lhs_struc
-let rhs r = r.discrete.DiscreteRule.rhs_struc
+let lhs r =
+ match r.discrete.DiscreteRule.struc_rule with
+ | None -> None
+ | Some r -> Some r.DiscreteRule.lhs_struc
+let rhs r =
+ match r.discrete.DiscreteRule.struc_rule with
+ | None -> None
+ | Some r -> Some r.DiscreteRule.rhs_struc
+
let map_to_formulas f r =
{r with
- discrete = {r.discrete with DiscreteRule.pre =
- f r.discrete.DiscreteRule.pre};
- compiled = {r.compiled with DiscreteRule.lhs_form =
- f r.compiled.DiscreteRule.lhs_form};
+ discrete = DiscreteRule.map_to_formulas f r.discrete;
inv = f r.inv;
post = f r.post;
}
let fold_over_formulas f r acc =
- let acc =
- f r.discrete.DiscreteRule.pre acc in
- let acc =
- f r.compiled.DiscreteRule.lhs_form acc in
+ let acc = DiscreteRule.fold_over_formulas f r.discrete acc in
let acc = f r.inv acc in
let acc = f r.post acc in
acc
@@ -84,8 +82,8 @@
(* Find all matches of [r] in [struc] which satisfy [r]'s precondition. *)
let matches struc r =
- let matchings = DiscreteRule.find_matchings struc r.compiled in
- DiscreteRule.enumerate_matchings struc r.compiled matchings
+ let matchings = DiscreteRule.find_matchings struc r.discrete in
+ DiscreteRule.enumerate_matchings struc r.discrete matchings
(* -------------------------- REWRITING ------------------------------------ *)
@@ -100,8 +98,6 @@
let rewrite_single_nocheck struc cur_time m r t params =
let time = ref cur_time in
if !debug_level > 1 then print_endline ("ct: " ^ (string_of_float !time));
- let left_elname le =
- Structure.elem_str r.discrete.DiscreteRule.lhs_struc le in
let p_vars, p_vals = List.split params in
let subst_params tm =
List.hd
@@ -114,14 +110,19 @@
let init_vals =
let get_val f a =
(* LHS is embedded in the model *)
- let e = Structure.find_elem r.discrete.DiscreteRule.lhs_struc a in
- Structure.fun_val struc f (List.assoc e m) in
+ (let try e = List.assoc a m in
+ Structure.fun_val struc f e
+ with Not_found ->
+ failwith
+ ("rewrite_single_nocheck: get_val: could not find "^a^
+ " in matched "^String.concat "," (List.map fst m))
+ ) in
List.map (fun ((f, a),_) -> Term.Const (get_val f a)) dyn in
let step vals t0 =
Term.rk4_step "t" t0 (Term.Const !time_step) dyn vals in
(* add the trace of the embedding to the structure, for invariants *)
let apm s (le, se) =
- Structure.add_rel s ("_lhs_" ^ (left_elname le)) [|se|] in
+ Structure.add_rel s ("_lhs_" ^ le) [|se|] in
let cur_struc = ref (List.fold_left apm struc m) in
(* the last structure for which the invariant holds, or the initial
structure if the invariant doesn't hold for it *)
@@ -133,8 +134,7 @@
let is_inv s = Solver.M.check s r.inv in
let lhs_to_model ((f, a), _) =
(* dynamics refer to elements by LHS matches *)
- let e = Structure.find_elem r.discrete.DiscreteRule.lhs_struc a in
- (f, List.assoc e m) in
+ (f, List.assoc a m) in
let upd_struct st =
let vals =
List.combine (List.map lhs_to_model dyn)
@@ -176,18 +176,18 @@
(* we don't need to use val_map because !last_struc contains the
evolved values *)
let asg = AssignmentSet.fo_assgn_of_list
- (List.map (fun (e, a) ->
- `FO (left_elname e), a) m) in
+ (List.map (fun (v, a) -> `FO v, a) m) in
let upd_vals = List.map
(fun (lhs,expr) -> lhs, Solver.M.get_real_val ~asg expr !last_struc)
upd in
(* we pass the evolved structure to discrete rewriting, so that
function values can be copied to new elements in case they are
not updated later *)
- let ns = DiscreteRule.rewrite_single !last_struc m r.compiled in
+ let ns = DiscreteRule.rewrite_single !last_struc m r.discrete in
let set_val struc ((f, e), v) =
let e_rel =
- (* DiscreteRule adds RHS element names to rewritten result *)
+ (* DiscreteRule adds RHS element names to rewritten result,
+ unless the rule is optimized (RHS renamed to use LHS names) *)
Structure.rel_graph ("_right_" ^ e) struc in
let elem = (Structure.Tuples.choose e_rel).(0) in
Structure.add_fun struc f (elem, v) in
@@ -230,11 +230,10 @@
if r.update = [] then "" else "\nupdate\n" ^ (
Formula.eq_str r.update
) ^ "\n" in
- let pre_str = " pre " ^ (Formula.str r.discrete.D...
[truncated message content] |
|
From: <luk...@us...> - 2011-11-05 14:15:28
|
Revision: 1620
http://toss.svn.sourceforge.net/toss/?rev=1620&view=rev
Author: lukstafi
Date: 2011-11-05 14:15:19 +0000 (Sat, 05 Nov 2011)
Log Message:
-----------
GDL translation: fixes to unframed fluent and erasure clauses treatment; regenerated tests. Discrete rule formula-based representation moved to ELEMS, RELS keywords.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRuleParser.mly
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss
trunk/Toss/GGP/tests/2player_normal_form_joint-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_joint-simpl.toss
trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss
trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss
trunk/Toss/GGP/tests/breakthrough-raw.toss
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect4-raw.toss
trunk/Toss/GGP/tests/connect4-simpl.toss
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
trunk/Toss/GGP/tests/tictactoe-other-raw.toss
trunk/Toss/GGP/tests/tictactoe-other-simpl.toss
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
trunk/Toss/Solver/RealQuantElim/Poly.ml
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-11-05 14:15:19 UTC (rev 1620)
@@ -101,6 +101,10 @@
game_defs:
| RULE_SPEC rname = id_int COLON r = rule_expr
{ DefRule (rname, r) }
+ | RULE_SPEC error
+ { Lexer.report_parsing_error
+ $startpos $endpos
+ "Syntax error in rule specification of game definition." }
| LOC_MOD l = location
{ DefLoc l }
| PLAYERS_MOD pnames = separated_list (COMMA, id_int)
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-11-05 14:15:19 UTC (rev 1620)
@@ -1313,12 +1313,12 @@
let add_elems = Aux.list_diff r.rhs_vars r.lhs_vars in
let elem_del_part =
if del_elems = [] then ""
- else "ELEM "^String.concat ", " del_elems in
+ else "ELEMS "^String.concat ", " del_elems in
let elem_add_part =
if add_elems = [] then ""
else match r.rlmap with
- | None -> "ELEM "^String.concat ", " add_elems
- | Some rlmap -> "ELEM "^String.concat ", "
+ | None -> "ELEMS "^String.concat ", " add_elems
+ | Some rlmap -> "ELEMS "^String.concat ", "
(List.map
(fun v ->
if List.mem_assoc v rlmap && List.assoc v rlmap <> v
@@ -1327,10 +1327,10 @@
add_elems) in
let rel_del_part =
if r.del_tuples = [] then ""
- else "REL "^str_tuples r.del_tuples in
+ else "RELS "^str_tuples r.del_tuples in
let rel_add_part =
if r.add_tuples = [] then ""
- else "REL "^str_tuples r.add_tuples in
+ else "RELS "^str_tuples r.add_tuples in
let del_part =
if elem_del_part = "" && rel_del_part = ""
then ""
@@ -1354,16 +1354,16 @@
let add_elems = Aux.list_diff r.rhs_vars r.lhs_vars in
let elem_del_part () =
if del_elems = [] then ()
- else Format.fprintf f "@[<1>ELEM@ %a@]"
+ else Format.fprintf f "@[<1>ELEMS@ %a@]"
(Aux.fprint_sep_list "," Format.pp_print_string) del_elems in
let elem_add_part () =
if add_elems = [] then ()
else match r.rlmap with
| None ->
- Format.fprintf f "@[<1>ELEM@ %a@]"
+ Format.fprintf f "@[<1>ELEMS@ %a@]"
(Aux.fprint_sep_list "," Format.pp_print_string) del_elems
| Some rlmap ->
- Format.fprintf f "@[<1>ELEM@ %a@]"
+ Format.fprintf f "@[<1>ELEMS@ %a@]"
(Aux.fprint_sep_list "," Format.pp_print_string)
(List.map
(fun v ->
@@ -1374,13 +1374,13 @@
let rel_del_part () =
if r.del_tuples = [] then ()
else (
- Format.fprintf f "@[<1>REL@ ";
+ Format.fprintf f "@[<1>RELS@ ";
str_tuples r.del_tuples;
Format.fprintf f "@]") in
let rel_add_part () =
if r.add_tuples = [] then ()
else (
- Format.fprintf f "@[<1>REL@ ";
+ Format.fprintf f "@[<1>RELS@ ";
str_tuples r.add_tuples;
Format.fprintf f "@]") in
let del_part () =
Modified: trunk/Toss/Arena/DiscreteRuleParser.mly
===================================================================
--- trunk/Toss/Arena/DiscreteRuleParser.mly 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/Arena/DiscreteRuleParser.mly 2011-11-05 14:15:19 UTC (rev 1620)
@@ -20,8 +20,8 @@
{ rel, tup }
del_vars_and_rel_tuples:
- | elems = option (preceded (ELEM_MOD, separated_list (COMMA, ID)))
- rel_tups = option (preceded (REL_MOD, separated_list (COMMA, rel_atom)))
+ | elems = option (preceded (ELEMS_MOD, separated_list (COMMA, ID)))
+ rel_tups = option (preceded (RELS_MOD, separated_list (COMMA, rel_atom)))
{ (match elems with None -> [] | Some l->l),
(match rel_tups with None -> [] | Some l->l) }
@@ -30,8 +30,8 @@
{ rhs, lhs }
add_vars_and_rel_tuples:
- | elems = option (preceded (ELEM_MOD, separated_list (COMMA, var_or_asgn)))
- rel_tups = option (preceded (REL_MOD, separated_list (COMMA, rel_atom)))
+ | elems = option (preceded (ELEMS_MOD, separated_list (COMMA, var_or_asgn)))
+ rel_tups = option (preceded (RELS_MOD, separated_list (COMMA, rel_atom)))
{ (match elems with None -> [] | Some l->l),
(match rel_tups with None -> [] | Some l->l) }
@@ -67,6 +67,9 @@
DiscreteRule.compile_formula_rule signat defs phi del_part
add_part pre
}
+ | MATCH error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error after the discrete rewrite rule MATCH keyword" }
parse_discrete_rule:
discrete_rule_expr EOF { $1 };
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2011-11-05 14:15:19 UTC (rev 1620)
@@ -48,7 +48,7 @@
"formula-based: simple" >::
(fun () ->
let s =
- "MATCH Q(a) DEL REL Q(a) ADD REL P(A)" in
+ "MATCH Q(a) DEL RELS Q(a) ADD RELS P(A)" in
let r = rule_of_str ["Q",1;"P",1] s in
assert_equal ~printer:(fun x->x) s (rule_str r)
);
@@ -56,20 +56,20 @@
"formula-based: elem manip" >::
(fun () ->
let s =
- "MATCH (Q(a) and R(a, b)) DEL ELEM b REL Q(a) ADD ELEM c REL R(a, c)" in
+ "MATCH (Q(a) and R(a, b)) DEL ELEMS b RELS Q(a) ADD ELEMS c RELS R(a, c)" in
let r = rule_of_str ["Q",1;"P",1] s in
assert_equal ~msg:"replace" ~printer:(fun x->x) s (rule_str r);
let s =
- "MATCH Q(a) and R(a, b) DEL ELEM b REL Q(a) ADD ELEM c REL R(a, c)" in
+ "MATCH Q(a) and R(a, b) DEL ELEMS b RELS Q(a) ADD ELEMS c RELS R(a, c)" in
let r = rule_of_str ["Q",1;"P",1] s in
assert_equal ~msg:"sprint replace" ~printer:(fun x->x) s (sprint_rule r);
let s =
- "MATCH (Q(a) and R(a, b)) DEL REL Q(a) ADD ELEM c <- b REL Q(c)" in
+ "MATCH (Q(a) and R(a, b)) DEL RELS Q(a) ADD ELEMS c <- b RELS Q(c)" in
let r = rule_of_str ["Q",1;"P",1] s in
assert_equal ~msg:"clone" ~printer:(fun x->x) s (rule_str r);
let s =
- "MATCH Q(a) and R(a, b) DEL REL Q(a) ADD ELEM c <- b REL Q(c)" in
+ "MATCH Q(a) and R(a, b) DEL RELS Q(a) ADD ELEMS c <- b RELS Q(c)" in
let r = rule_of_str ["Q",1;"P",1] s in
assert_equal ~msg:"sprint clone" ~printer:(fun x->x) s (sprint_rule r);
);
@@ -88,11 +88,38 @@
let s="MATCH
D(c, c) and D(c, a) and D(c, b) and D(b, a) and D(b, b) and P(c) and P(b) and
Q(a) and Q(b) and R(c, c) and R(a, c) and R(a, b) and R(b, c) and R(b, b)
- DEL ELEM b REL Q(a), Q(c) ADD REL D(c, b), D(c, c), P(b), R(c, c)" in
+ DEL ELEMS b RELS Q(a), Q(c) ADD RELS D(c, b), D(c, c), P(b), R(c, c)" in
let r = rule_of_str ["D",2;"R",2;"Q",1;"P",1] s in
assert_equal ~printer:(fun x->x) s (sprint_rule r);
);
+ "formula-based: GDL breakthrough" >::
+ (fun () ->
+ let signat = ["R",2;"index__cellholds_1",1;
+ "control__BLANK_",1;"cellempty",1;
+ "cellholds_2white",1;"control_0white",1;
+ "cellholds_2black",1;"control_0black",1;
+ "terminal",0] in
+ let s =
+ "MATCH
+ R(cellholds_x_y__BLANK_, cellholds_x_y0__BLANK_) and
+ index__cellholds_1(cellholds_x_y0__BLANK_) and
+ index__cellholds_1(cellholds_x_y__BLANK_) and
+ control__BLANK_(control__BLANK_) and cellempty(cellholds_x_y0__BLANK_) and
+ cellholds_2white(cellholds_x_y__BLANK_) and control_0white(control__BLANK_) and
+ not terminal()
+ DEL
+ RELS cellholds_2black(cellholds_x_y__BLANK_),
+ cellholds_2black(cellholds_x_y0__BLANK_),
+ cellholds_2white(cellholds_x_y__BLANK_),
+ cellholds_2white(cellholds_x_y0__BLANK_), control_0white(control__BLANK_)
+ ADD
+ RELS cellholds_2white(cellholds_x_y0__BLANK_),
+ control_0black(control__BLANK_)" in
+ let r = rule_of_str signat s in
+ assert_equal ~printer:(fun x->x) s (sprint_rule r);
+ );
+
"rewrite: compile_rule" >::
(fun () ->
@@ -103,10 +130,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = [];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = [];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -122,10 +149,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"Q"];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"Q"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -142,10 +169,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"Q"];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"Q"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -161,10 +188,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"R"];
- pre = Formula.And [];
- rule_s = [1,1; 2,2; 3,2]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"R"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,2; 3,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -186,10 +213,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = [];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = [];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -205,10 +232,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"Q"];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"Q"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -225,10 +252,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"Q"];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"Q"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -244,10 +271,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"R"];
- pre = Formula.And [];
- rule_s = [1,1; 2,2; 3,2]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"R"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,2; 3,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -269,10 +296,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = [];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = [];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -289,10 +316,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"Q"];
- pre = Formula.And [];
- rule_s = [1,1; 2,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"Q"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -313,10 +340,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = [];
- pre = Formula.And [];
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = [];
+ pre = Formula.And [];
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -332,10 +359,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P";"Q"];
- pre = Formula.And [];
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P";"Q"];
+ pre = Formula.And [];
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -356,10 +383,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = [];
- pre = Formula.And [];
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = [];
+ pre = Formula.And [];
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -376,10 +403,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P"];
- pre = Formula.And [];
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P"];
+ pre = Formula.And [];
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -401,10 +428,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = [];
- pre = Formula.And [];
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = [];
+ pre = Formula.And [];
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -427,7 +454,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = Formula.And [];
+ pre = Formula.And [];
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -447,8 +474,8 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["C"];
- pre = Formula.And [];
- rule_s = [1,1; 2,2]} in
+ pre = Formula.And [];
+ rule_s = [1,1; 2,2]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -473,7 +500,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["P"];
- pre = Formula.And [];
+ pre = Formula.And [];
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -513,7 +540,7 @@
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = ["C"];
- pre = Formula.And [];
+ pre = Formula.And [];
rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
@@ -535,10 +562,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["R"];
- pre = Formula.And [];
- rule_s = [1,1; 2,2]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["R"];
+ pre = Formula.And [];
+ rule_s = [1,1; 2,2]} in
let embs = find_matchings model rule_obj in
assert_raises
~msg:"inserting a two element into a single element structure"
@@ -560,10 +587,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P"];
- pre = formula_of_str "not C(a)";
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P"];
+ pre = formula_of_str "not C(a)";
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
assert_raises
~msg:"with renaming, precondition should not be met"
@@ -578,10 +605,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P"];
- pre = formula_of_str "not C(a)";
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P"];
+ pre = formula_of_str "not C(a)";
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
@@ -591,7 +618,7 @@
"[e, f | C (e); P (e); Q (f); _del_P (f); _new_Q (f); _right_a (f) | ]"
(Structure.str nmodel);
- (* without renaming *)
+ (* without renaming *)
let model =
struc_of_str "[ | P{e;f}; Q:1{}; C{e} | ]" in
@@ -601,10 +628,10 @@
let signat = Structure.rel_signature model in
let rule_obj = compile_rule signat []
{lhs_struc = lhs_struc;
- rhs_struc = rhs_struc;
- emb_rels = ["P"];
- pre = formula_of_str "not C(a)";
- rule_s = [1,1]} in
+ rhs_struc = rhs_struc;
+ emb_rels = ["P"];
+ pre = formula_of_str "not C(a)";
+ rule_s = [1,1]} in
let embs = find_matchings model rule_obj in
let emb = choose_match model rule_obj embs in
let nmodel =
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/Formula/Lexer.mll 2011-11-05 14:15:19 UTC (rev 1620)
@@ -66,7 +66,9 @@
| LET_CMD
| EVAL_CMD
| ELEM_MOD
+ | ELEMS_MOD
| REL_MOD
+ | RELS_MOD
| ALLOF_MOD
| SIG_MOD
| FUN_MOD
@@ -208,7 +210,9 @@
| "let" { LET_CMD }
| "EVAL" { EVAL_CMD }
| "ELEM" { ELEM_MOD }
+ | "ELEMS" { ELEMS_MOD }
| "REL" { REL_MOD }
+ | "RELS" { RELS_MOD }
| "ALLOF" { ALLOF_MOD }
| "SIGNATURE" { SIG_MOD }
| "FUN" { FUN_MOD }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/Formula/Tokens.mly 2011-11-05 14:15:19 UTC (rev 1620)
@@ -10,7 +10,7 @@
%token IN 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 REL_MOD ALLOF_MOD SIG_MOD FUN_MOD DATA_MOD LOC_MOD TIMEOUT_MOD TIME_MOD PLAYER_MOD PLAYERS_MOD
+%token ELEM_MOD ELEMS_MOD REL_MOD RELS_MOD ALLOF_MOD SIG_MOD FUN_MOD DATA_MOD LOC_MOD TIMEOUT_MOD TIME_MOD PLAYER_MOD PLAYERS_MOD
%token MODEL_SPEC RULE_SPEC STATE_SPEC LEFT_SPEC RIGHT_SPEC CLASS LFP GFP EOF
/* List in order of increasing precedence. */
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-11-03 18:39:52 UTC (rev 1619)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-11-05 14:15:19 UTC (rev 1620)
@@ -1196,10 +1196,27 @@
(* The [Erasure_cl_OK] clauses do not have unfixed variables. The
[Erasure_cl_inst] stores the unfixed-variable-dependent part
separately, already instantiated. *)
-type cl_type =
+type cl_kind =
| Legal_cl | Next_cl | Erasure_cl_OK
| Erasure_cl_inst of (term * literal list) list
+let subst_cl_kind sb = function
+ | Erasure_cl_inst local ->
+ Erasure_cl_inst
+ (List.map
+ (fun (h, body) -> subst sb h, subst_literals sb body) local)
+ | kind -> kind
+
+let cl_kind_str = function
+ | Legal_cl -> "Legal_cl"
+ | Next_cl -> "Next_cl"
+ | Erasure_cl_OK -> "Era_OK"
+ | Erasure_cl_inst local ->
+ "Era_inst{" ^
+ String.concat "; "
+ (List.map (fun (h, body) -> term_str h ^"<-"^ literals_str body)
+ local) ^ "}"
+
(* substitute a "next" clause with frame info *)
let subst_fnextcl sb (head, frame, body) =
subst sb head, frame, subst_literals sb body
@@ -1312,17 +1329,20 @@
let add_erasure_clauses f_paths (legal_tup, next_cls) =
let fixed_vars = terms_vars (Aux.array_map_of_list fst legal_tup) in
check_timeout "TranslateGame: add_erasure_clauses: start";
+ let legal_cl_bodies = List.map snd legal_tup in
+ let frame_cls, move_cl_bodies =
+ Aux.partition_map (fun (s, frame, body) ->
+ if frame then Aux.Left (s, body) else Aux.Right body) next_cls in
+ let cl_pos_terms =
+ Aux.concat_map pos_state_terms (legal_cl_bodies @ move_cl_bodies) in
(* {{{ log entry *)
if !debug_level > 2 then (
- Printf.printf "add_erasure_clauses: fixed_vars=%s\n%!"
+ Printf.printf
+ "\nadd_erasure_clauses: fixed_vars=%s; cl_pos_terms=%s\n%!"
(String.concat ", " (Aux.Strings.elements fixed_vars))
+ (String.concat ", " (List.map term_str cl_pos_terms))
);
(* }}} *)
- let frame_cls, move_cl_bodies =
- Aux.partition_map (fun (s, frame, body) ->
- if frame then Aux.Left (s, body) else Aux.Right body) next_cls in
- let move_cl_pos_terms =
- Aux.concat_map pos_state_terms move_cl_bodies in
(* two passes to ensure coverage and maximality *)
(* Treating fixed-vars as consts, by substituting them with
Const, and later substituting-back Var *)
@@ -1387,8 +1407,8 @@
let nbodies = negate_bodies bodies in
List.map
(fun (nsb, b) ->
- let s = subst nsb s in
- s, Aux.unique_sorted (Pos (True s) :: b))
+ let s = subst nsb s in (* b already substituted *)
+ s, Aux.unique_sorted b)
nbodies
) frames in
@@ -1403,6 +1423,15 @@
let local_ex_vars = term_vars s in
let local_uni_vars = Aux.Strings.diff
(literals_vars body) local_ex_vars in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "ERASURE: ex=%s; uni=%s; %s <== %s\n%!"
+ (String.concat "," (Aux.Strings.elements local_ex_vars))
+ (String.concat "," (Aux.Strings.elements local_uni_vars))
+ (term_str s)
+ (String.concat " " (List.map literal_str body))
+ );
+ (* }}} *)
if Aux.Strings.is_empty local_uni_vars then
let body, local_body = List.partition
(fun lit -> Aux.Strings.is_empty (literals_vars [lit]))
@@ -1411,11 +1440,17 @@
if Aux.Strings.is_empty local_ex_vars then Erasure_cl_OK
else
let sbs = Aux.map_try
- (fun t -> unify [] [s] [t]) move_cl_pos_terms in
+ (fun t -> unify [] [s] [t]) cl_pos_terms in
let local = List.map
(fun sb -> subst_consts fixed_to_var (subst sb s),
subst_consts_literals fixed_to_var
(subst_literals sb local_body)) sbs in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "(local sbs = %s)\n%!"
+ (String.concat "; " (List.map sb_str sbs))
+ );
+ (* }}} *)
Erasure_cl_inst local in
if kind = Erasure_cl_inst [] then None
else
@@ -1427,7 +1462,7 @@
(* {{{ log entry *)
if !debug_level > 2 then (
- Printf.printf "add_erasure_clauses: all erasure clauses --\n%!";
+ Printf.printf "\nadd_erasure_clauses: all filtered erasure clauses --\n%!";
let print_erasure (s, kind, body) =
Printf.printf "ERASURE: %s %s <== %s\n%!"
(if kind = Erasure_cl_OK then " OK " else "inst") (term_str s)
@@ -1589,10 +1624,10 @@
let legal_lits_enc = Aux.map_try encode_lit legal_lits in
(* {{{ log entry *)
if !debug_level > 3 then (
- Printf.printf "filter_redundant:\nlegal_lits=%s\nbody=%s\n\n%!"
+ Printf.printf "filter_redundant:\nlegal_lits=%s\nbody=%s\n%!"
(rel_atoms_str legal_lits_enc) (literals_str body)
);
- (* }}} *)
+ (* }}} *)
let sbs, keep_parts = Aux.partition_map
(fun part ->
try
@@ -1604,7 +1639,14 @@
Aux.Left sb
with Not_found -> Aux.Right part)
parts in
- List.concat sbs, List.concat keep_parts
+ let sb = List.concat sbs and keep = List.concat keep_parts in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "sb=%s; keep=%s\n\n%!"
+ (sb_str sb) (literals_str keep)
+ );
+ (* }}} *)
+ sb, keep
let remove_local_vars gvars lits =
List.filter (fun l -> Aux.Strings.subset (literals_vars [l]) gvars) lits
@@ -1621,10 +1663,22 @@
let neg_rhs, more_conds = List.split erasure_OK in
let cond = List.concat (more_conds @ conds) in
let cond_sterms = pos_state_terms cond in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "erasure-cond_sterms: %s\n%!"
+ (String.concat ", " (List.map term_str cond_sterms))
+ );
+ (* }}} *)
let erasure_loc_cls = Aux.concat_map
(fun (local, body) ->
Aux.map_some
(fun (h, loc_body) ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "erasure-local-cand: %s\n%!"
+ (term_str h)
+ );
+ (* }}} *)
if List.mem h cond_sterms then Some (h, loc_body @ body)
else None)
local)
@@ -1860,7 +1914,8 @@
(fun (f, brs) ->
let brs = List.map
(fun (cond, update) ->
- let sb, cond = filter_redundant case_cond cond in
+ let sb, cond = filter_redundant case_cond cond in
+ (* TODO: we should pbbly apply [sb] to the whole candidate *)
subst_literals sb cond, update)
brs in
f, brs)
@@ -1942,8 +1997,18 @@
let next_cls = List.map
(fun (head, kind, body) ->
let sb, body = filter_redundant legal_lits body in
- subst sb head, kind, subst_literals sb body)
+ subst sb head, subst_cl_kind sb kind, subst_literals sb body)
next_cls in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ let print_cl (head, kind, body) =
+ Printf.printf
+ "legal-filtered-next-cl: head=%s; kind=%s; body=%s\n%!"
+ (term_str head) (cl_kind_str kind) (li...
[truncated message content] |
|
From: <luk...@us...> - 2011-11-06 22:11:55
|
Revision: 1622
http://toss.svn.sourceforge.net/toss/?rev=1622&view=rev
Author: lukaszkaiser
Date: 2011-11-06 22:11:48 +0000 (Sun, 06 Nov 2011)
Log Message:
-----------
Towards more general distinguishing of sets of structures: adding a module and starting guarded types work.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Makefile
trunk/Toss/Solver/WL.ml
Added Paths:
-----------
trunk/Toss/Solver/Distinguish.ml
trunk/Toss/Solver/Distinguish.mli
trunk/Toss/Solver/DistinguishTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-05 17:01:26 UTC (rev 1621)
+++ trunk/Toss/Formula/Aux.ml 2011-11-06 22:11:48 UTC (rev 1622)
@@ -361,9 +361,8 @@
| _ -> acc in
List.rev (aux n [] l)
-let rec range ?(from=1) k =
- if from>=k then [k]
- else from :: range ~from:(from+1) k
+let rec range ?(from=0) k =
+ if from >= k then [] else from :: range ~from:(from+1) k
let array_map_some f a =
let r = Array.map f a in
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-11-05 17:01:26 UTC (rev 1621)
+++ trunk/Toss/Formula/Aux.mli 2011-11-06 22:11:48 UTC (rev 1622)
@@ -68,7 +68,7 @@
val map_reduce :
('a -> 'b * 'c) -> ('d -> 'c -> 'd) -> 'd -> 'a list -> ('b * 'd) list
-(** Collects elements by key, in a list sorted by key. Same as
+(** Collects elements by key (returns a list sorted by key). Same as
[map_reduce (fun x -> x) (fun y x->x::y) []]. *)
val collect : ('a * 'b) list -> ('a * 'b list) list
@@ -217,7 +217,7 @@
contain enough values. *)
val take_n : int -> 'a list -> 'a list
-(** Returns an int list from from to k.*)
+(** Returns an int list from [from] (default 0) to k-1.*)
val range: ?from : int -> int -> int list
(** Make an array from an association from indices to values. The
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-11-05 17:01:26 UTC (rev 1621)
+++ trunk/Toss/Server/Tests.ml 2011-11-06 22:11:48 UTC (rev 1622)
@@ -18,6 +18,7 @@
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
"ClassTest", [ClassTest.tests; ClassTest.bigtests];
"WLTest", [WLTest.tests; WLTest.bigtests];
+ "DistinguishTest", [DistinguishTest.tests; DistinguishTest.bigtests];
]
let arena_tests = "Arena", [
Added: trunk/Toss/Solver/Distinguish.ml
===================================================================
--- trunk/Toss/Solver/Distinguish.ml (rev 0)
+++ trunk/Toss/Solver/Distinguish.ml 2011-11-06 22:11:48 UTC (rev 1622)
@@ -0,0 +1,180 @@
+open Formula
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i)
+
+(* 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 - *)
+
+(* 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)))
+
+
+
+(* - Guards and Guarded Types - *)
+
+(* Generate all guarded substitutions of [tuple] with the guards.
+ 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. *)
+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]. *)
+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 =
+ 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 (guards, subst_tuples) = List.split (
+ List.rev_map (fun (_, vs, t, _, f) -> (vs,f), t) (guards struc tuple)) in
+ let (guards, subst_tuples) =
+ (Aux.unique_sorted guards, Aux.unique_sorted subst_tuples) in
+ let guarded_tups (_, f) =
+ List.filter (fun tup -> check struc tup f) subst_tuples in
+ let guards_with_tups = List.map (fun g -> (g, guarded_tups g)) guards in
+ let nextf = And (List.map next_gtype guards_with_tups) in
+ Formula.flatten_sort (And [guarded_type struc (qr-1) tuple; nextf])
+
+(* 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
+ Aux.unique_sorted (List.rev_map (guarded_type struc 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 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 -> Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
+ | Not f -> 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
+
+
+let distinguish_by_type ?(skip_outer_exists=false) ~qr ~k sPos sNeg=
+ let types s = guarded_types 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 fail_neg = List.filter fails_neg (Aux.unique_sorted candidates) in
+ let phis = List.sort Formula.compare (Aux.unique_sorted fail_neg) 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
+ if dtypes = [] then None else
+ let is_ok f = fails_neg f && succ_pos [f] in
+ let mintp = greedy_remove is_ok (Or dtypes) in
+ let fv = FormulaSubst.free_vars (Or dtypes) in
+ let t= FormulaOps.rename_quant_avoiding fv mintp in
+ if skip_outer_exists then Some t else
+ Some (Ex (List.sort Formula.compare_vars fv, t))
+
+let distinguish ?(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_by_type ~skip_outer_exists ~qr ~k strucs1 strucs2 with
+ | Some f -> f
+ | None -> diff (qr+1) k
+ ) in
+ diff 0 1
Added: trunk/Toss/Solver/Distinguish.mli
===================================================================
--- trunk/Toss/Solver/Distinguish.mli (rev 0)
+++ trunk/Toss/Solver/Distinguish.mli 2011-11-06 22:11:48 UTC (rev 1622)
@@ -0,0 +1,48 @@
+(** Distinguish sets of structures by formulas. *)
+
+(** {2 Atoms} *)
+
+(** 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
+
+
+(** {2 Guards and Guarded Types} *)
+
+(** Generate all guarded substitutions of [tuple] with the guards.
+ 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} *)
+
+val distinguish_by_type: ?skip_outer_exists: bool -> qr: int -> k: int ->
+ 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} *)
+
+val set_debug_level: int -> unit
Added: trunk/Toss/Solver/DistinguishTest.ml
===================================================================
--- trunk/Toss/Solver/DistinguishTest.ml (rev 0)
+++ trunk/Toss/Solver/DistinguishTest.ml 2011-11-06 22:11:48 UTC (rev 1622)
@@ -0,0 +1,280 @@
+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|]));
+ );
+
+ "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 (guarded_type struc 1 [|1; 2|]); (* no guards *)
+ formula_eq lits (guarded_type struc 2 [|1; 2|]); (* no guards *)
+
+ let struc = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ formula_eq lits (guarded_type struc 0 [|1; 2|]);
+ formula_eq (lits ^ " 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(x1, x0) or (not R(x0, x0) and not R(x0,x1)" ^
+ " and not x0 = x1 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_by_type" >::
+ (fun () ->
+ let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_option_eq "None"
+ (Distinguish.distinguish_by_type ~qr:2 ~k:1 [struc1] [struc2]);
+ formula_option_eq "None" (* we use guarded types - so None here *)
+ (Distinguish.distinguish_by_type ~qr:0 ~k:2 [struc1] [struc2]);
+ formula_option_eq "None" (* we use guarded types - so None here *)
+ (Distinguish.distinguish_by_type ~qr:0 ~k:3 [struc1] [struc2]);
+ formula_option_eq "R(x0, x1) and ex x2 R(x1, x2)"
+ (Distinguish.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
+ [struc1] [struc2]);
+
+ let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
+ let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
+ formula_option_eq "ex x0 P(x0)"
+ (Distinguish.distinguish_by_type ~qr:0 ~k:1 [struc1] [struc2]);
+ );
+
+ "distinguish" >::
+ (fun () ->
+ let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
+ let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
+ formula_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x1, x2))"
+ (Distinguish.distinguish [struc1] [struc2]);
+
+ let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
+ let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
+ formula_eq "ex x0 P(x0)" (Distinguish.distinguish [struc1] [struc2]);
+ );
+]
+
+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 (*"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]);
+ );
+
+ "breakthrough" >::
+ (fun () ->
+ let struc1 = struc_of_string "[ | | ] \"
+ ... ... ... ...
+ ... W.. ...B ...
+ ... ... ... ...
+ ... ... ... B..
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+ ... ... ... ...
+ ...W ... ... ...
+\"" in
+ let struc2 = struc_of_string "[ | | ] \"
+ ... ... ... ...
+ ... ... ...B ...
+ ... ... ... ...
+ ... ...W ... B..
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... W..
+ ... ... ... ...
+ ...W ... ... ...
+\"" in
+ Distinguish.set_debug_level 1;
+ formula_eq "W(x2) and all x3 not C(x2, x3)"
+ (Distinguish.distinguish ~skip_outer_exists:true [struc1] [struc2]);
+ );
+]
Modified: trunk/Toss/Solver/Makefile
===================================================================
--- trunk/Toss/Solver/Makefile 2011-11-05 17:01:26 UTC (rev 1621)
+++ trunk/Toss/Solver/Makefile 2011-11-06 22:11:48 UTC (rev 1622)
@@ -10,6 +10,7 @@
ClassTest:
PresbTest:
WLTest:
+DistinguishTest:
tests:
make -C .. SolverTestsVerbose
Modified: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-11-05 17:01:26 UTC (rev 1621)
+++ trunk/Toss/Solver/WL.ml 2011-11-06 22:11:48 UTC (rev 1622)
@@ -61,12 +61,13 @@
if check structure tuple variables literal then literal else (Not literal)
) (List.append listOfLiterals (inequalities (Array.to_list variables)))
+let range k = Aux.range ~from:1 (k+1)
(* The n-type from FO^k for the [tuple] in [structure]. *)
let rec ntype structure tuple k_in n =
let m = Array.length tuple in
let k = max k_in m in
- let variables = (List.map (fun i -> "x"^string_of_int(i)) (Aux.range k)) in
+ let variables = (List.map (fun i -> "x"^string_of_int(i)) (range k)) in
if n=0 then
Formula.flatten_sort (And (atoms structure tuple (Array.of_list variables)))
else
@@ -85,7 +86,7 @@
(conj_b_ex_xmplus1_typesN structure tuple k (n-1));
(all_xmplus1_disj_b_typesN structure tuple k (n-1))])
else (* all variables already used, substitute *)
- let indices = Aux.range k in
+ let indices = range k in
let substituted i e = (Aux.array_replace tuple (i-1) e) in
let conj_b_ex_xi_typesN_replace_ai_by_b structure tuple k n i =
And (List.map (fun x ->
@@ -110,7 +111,7 @@
match tuples with
| head::tail ->
let ntyp = (ntype structure head k n) in
- let vars = (List.map (fun i -> "x"^string_of_int i) (Aux.range k)) in
+ let vars = (List.map (fun i -> "x"^string_of_int i) (range k)) in
let check tuple = check structure tuple (Array.of_list vars) ntyp in
let filtered = List.filter (fun t -> not (check t)) tail in
(all_ntypes_ktuples ~acc_types:(ntyp::acc_types)
@@ -133,7 +134,7 @@
let nextTypes ?(min=true) structure tuples variables types =
let conjuncts tuple =
- let indices = Aux.range (Array.length tuple) in
+ let indices = range (Array.length tuple) in
let substituted i e = Aux.array_replace tuple (i-1) e in
let sorted tp = Array.of_list (Aux.unique_sorted (Array.to_list tp)) in
let all_diff i = Array.to_list (Aux.array_mapi_some (
@@ -184,7 +185,7 @@
Array.of_list (List.map Array.of_list (List.filter no_rept (
Aux.all_ntuples (Structure.elements structure) k))) in
let variables =
- Array.map (fun i -> "x"^string_of_int(i)) (Array.of_list (Aux.range k)) in
+ Array.map (fun i -> "x"^string_of_int(i)) (Array.of_list (range k)) in
ntypesSimplified ~min tuples variables structure n k
(* Helper function: remove atoms from a formula if [cond] is still satisfied.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-07 21:57:21
|
Revision: 1623
http://toss.svn.sourceforge.net/toss/?rev=1623&view=rev
Author: lukstafi
Date: 2011-11-07 21:57:12 +0000 (Mon, 07 Nov 2011)
Log Message:
-----------
GDL translation: inlining relations with <does> atoms; eliminating pattern matching (and ground arguments as special case); handling positive <does> literals in erasure clauses (coming from negative <does> literals in frame clauses); small bug fix in erasure clause filtering. Experimental parameter turning off root predicate generation (a prudent way would be to eliminate root predicates whenever possible in GameSimpl).
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/TranslateFormula.ml
trunk/Toss/GGP/TranslateFormula.mli
trunk/Toss/GGP/TranslateGame.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss
trunk/Toss/GGP/tests/2player_normal_form_joint-raw.toss
trunk/Toss/GGP/tests/2player_normal_form_joint-simpl.toss
trunk/Toss/GGP/tests/asteroids-scrambled-raw.toss
trunk/Toss/GGP/tests/asteroids-scrambled-simpl.toss
trunk/Toss/GGP/tests/breakthrough-raw.toss
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect4-raw.toss
trunk/Toss/GGP/tests/connect4-simpl.toss
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/GGP/tests/pacman3p-raw.toss
trunk/Toss/GGP/tests/pacman3p-simpl.toss
trunk/Toss/GGP/tests/tictactoe-other-raw.toss
trunk/Toss/GGP/tests/tictactoe-other-simpl.toss
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/GGP/tests/pawn_whopping-raw.toss
trunk/Toss/GGP/tests/pawn_whopping-simpl.toss
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/Formula/Aux.ml 2011-11-07 21:57:12 UTC (rev 1623)
@@ -145,6 +145,8 @@
let list_inter a b = List.filter (fun e -> List.mem e b) a
+let list_init f n = Array.to_list (Array.init n f)
+
let sorted_inter xs ys =
let rec aux acc = function
| [], _ | _, [] -> acc
@@ -165,6 +167,16 @@
else aux (y::acc) (xs, ys') in
List.rev (aux [] (xs, ys))
+let sorted_multiset_union xs ys =
+ let rec aux acc = function
+ | [], xs | xs, [] -> List.rev_append xs acc
+ | ((x,i as xi)::xs' as xs), ((y,j as yj)::ys' as ys) ->
+ let c = Pervasives.compare x y in
+ if c = 0 then aux ((x,i+j)::acc) (xs', ys')
+ else if c < 0 then aux (xi::acc) (xs', ys)
+ else aux (yj::acc) (xs, ys') in
+ List.rev (aux [] (xs, ys))
+
let rec rev_assoc l x = match l with
[] -> raise Not_found
| (a,b)::l -> if b = x then a else rev_assoc l x
@@ -634,7 +646,13 @@
snd (first_i 0 (fun i -> s^(string_of_int i))
(fun v -> not (Strings.mem v names)))
-let not_conflicting_names s names n =
+let not_conflicting_names ?(truncate=false) s names n =
+ let s =
+ if truncate then
+ let i = ref (String.length s - 1) in
+ while !i > 0 && is_digit s.[!i] do decr i done;
+ String.sub s 0 (!i + 1)
+ else s in
List.rev (snd (List.fold_left (fun (i,res) _ ->
let i', v =
first_i i (fun i -> s^(string_of_int i))
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/Formula/Aux.mli 2011-11-07 21:57:12 UTC (rev 1623)
@@ -93,6 +93,9 @@
(** Intersection: [list_inter a b = List.filter (fun e -> List.mem e b) a]. *)
val list_inter : 'a list -> 'a list -> 'a list
+(** Create a list of given length initialized from the indices. *)
+val list_init : (int -> 'a) -> int -> 'a list
+
(** Set intersection of lists of unique increasing elements (as returned
by {!Aux.unique_sorted}). *)
val sorted_inter : 'a list -> 'a list -> 'a list
@@ -101,6 +104,9 @@
by {!Aux.unique_sorted}). *)
val sorted_merge : 'a list -> 'a list -> 'a list
+val sorted_multiset_union :
+ ('a * int) list -> ('a * int) list -> ('a * int) list
+
(** Return first key with the given value from the key-value pairs,
using structural equality. *)
val rev_assoc : ('a * 'b) list -> 'b -> 'a
@@ -308,6 +314,7 @@
(** Returns [n] strings proloning [s] and not appearing in [names]. *)
val not_conflicting_names :
+ ?truncate:bool ->
string -> Strings.t -> 'a list -> string list
(** Character classes. *)
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/GDL.ml 2011-11-07 21:57:12 UTC (rev 1623)
@@ -96,6 +96,15 @@
and terms_vars args =
Array.fold_left Aux.Strings.union Aux.Strings.empty
(Array.map term_vars args)
+
+let rec count_term_vars = function
+ | Const _ -> []
+ | Var v -> [v,1]
+ | Func (f, args) -> count_terms_vars args
+
+and count_terms_vars args =
+ Array.fold_left Aux.sorted_multiset_union []
+ (Array.map count_term_vars args)
let rec atoms_of_body body =
Aux.concat_map
@@ -141,17 +150,33 @@
(List.map terms_vars
(head_args::List.map snd (body @ neg_body)))
+let count_gdl_rule_vars ((_,head_args), body, neg_body) =
+ List.fold_left Aux.sorted_multiset_union []
+ (List.map count_terms_vars
+ (head_args::List.map snd (body @ neg_body)))
+
let gdl_rules_vars brs =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map gdl_rule_vars brs)
+let count_gdl_rules_vars brs =
+ List.fold_left Aux.sorted_multiset_union []
+ (List.map count_gdl_rule_vars brs)
+
let rels_vars (body : (string * term array) list) =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map (fun (_,args)->terms_vars args) body)
+let count_rels_vars (body : (string * term array) list) =
+ List.fold_left Aux.sorted_multiset_union []
+ (List.map (fun (_,args)->count_terms_vars args) body)
+
let literals_vars body =
rels_vars (List.map rel_of_atom (atoms_of_body body))
+let count_literals_vars body =
+ count_rels_vars (List.map rel_of_atom (atoms_of_body body))
+
let gdl_defs_vars defs =
rels_vars
(Aux.concat_map (fun (hd,body,neg_body) ->
@@ -1026,85 +1051,168 @@
| _ -> assert false) lits
) (flatten_disjs body)
-
-let find_ground_arg rel clauses =
+(* Find an argument which is not a variable in any branch of the [rel]
+ definition: i.e. find a wildcard-free pattern-matching argument. *)
+let find_pattern_arg rel clauses =
match Aux.assoc_all rel (List.map fst clauses) with
| [] -> raise Not_found
| (args::_ as all_args) ->
Aux.array_argfindi
(fun i _ ->
List.for_all (fun args ->
- Aux.Strings.is_empty (term_vars args.(i))) all_args)
+ match args.(i) with Var _ -> false | _ -> true) all_args)
args
-let elim_ground_arg_in_body rel arg grounding (head, body) =
+(* Modify all call-sites of a pattern-matching argument by expanding
+ them (introducing disjunction if possible, otherwise duplicating
+ clauses). [froots] are the root functors of the pattern paired
+ with their arity. *)
+let elim_pattern_arg_in_body rel arg froots (head, body) =
+ let var_count = Aux.sorted_multiset_union
+ (count_terms_vars (snd head)) (count_literals_vars body) in
- let expand_atom args add_lit (sb, (head, body)) =
- (* [short_args] will be subsituted with [sb] inside [r_br] *)
- let short_args = Array.init (Array.length args - 1)
- (fun i -> if i < arg then args.(i) else args.(i+1)) in
- let inst_arg = subst sb args.(arg) in
- Aux.map_try
- (fun ground ->
- let sb = unify sb [ground] [inst_arg] in
- let r_gr = rel ^ "__" ^ term_to_name ground in
- let r_br = head, add_lit (Rel (r_gr, short_args)) body in
- sb, (* subst_clause sb *) r_br)
- grounding in
+ let expand_atom neg_disj args add_lits (sb, ((h_rel, h_args as h), body)) =
+ let args = Array.map (subst sb) args in
+ let single_br, sb_m_args =
+ match args.(arg) with
+ | Func (f, m_args) when List.mem_assoc f froots ->
+ true, [(f, Array.length m_args), [], m_args]
+ | Const f when List.mem_assoc f froots ->
+ true, [(f, 0), [], [| |]]
+ | Var v ->
+ not neg_disj &&
+ (try List.assoc v var_count with Not_found -> 0) < 2,
+ List.map (fun (func, arity as froot) ->
+ let nvars =
+ Aux.not_conflicting_names
+ ~truncate:true "pv" !used_vars
+ (Aux.list_init (fun x->x) arity) in
+ used_vars := Aux.add_strings nvars !used_vars;
+ let m_args = Aux.array_map_of_list (fun v -> Var v) nvars in
+ let t =
+ if arity = 0 then Const func else Func (func, m_args) in
+ froot, [v, t], m_args) froots
+ (* get rid of a clause that calls the relation with a term
+ not covered by pattern matching *)
+ | _ -> false, [] in
+ let make_br ((func, arity), v_sb, m_args) =
+ let exp_args = Array.init (Array.length args - 1 + arity)
+ (fun i ->
+ if i < arg then args.(i)
+ else if i >= arg + arity then args.(i+1-arity)
+ else m_args.(i-arg)) in
+ let r_gr = rel ^ "__" ^ func in
+ v_sb, Rel (r_gr, exp_args) in
+ let brs = List.map make_br sb_m_args in
+ if single_br then
+ let atoms = List.map snd brs in (* sbs are empty or not relevant *)
+ (* [atoms] are already substituted, because [args] are *)
+ [sb, (h, add_lits atoms body)]
+ else List.map
+ (fun (v_sb, atom) ->
+ compose_sb v_sb sb,
+ ((h_rel, Array.map (subst v_sb) h_args),
+ add_lits [atom] (subst_literals v_sb body)))
+ brs in
- let rec expand_literal emb_lit literal (sb, (head, body) as accu) =
+ let rec expand_literal is_disj emb_lits literal (sb, (head, body) as accu) =
match literal with
| Pos (Rel (r, args)) when r=rel ->
- expand_atom args (fun a body -> emb_lit (Pos a) body) accu
+ expand_atom false args
+ (fun atoms body ->
+ match atoms with [atom] -> emb_lits [Pos atom] body
+ | _ -> emb_lits [Disj (List.map (fun a->Pos a) atoms)] body)
+ accu
| Neg (Rel (r, args)) when r=rel ->
- expand_atom args (fun a body -> emb_lit (Neg a) body) accu
- | Pos _ | Neg _ -> [sb, (head, emb_lit literal body)]
+ expand_atom is_disj args
+ (fun atoms body ->
+ emb_lits (List.map (fun a->Neg a) atoms) body)
+ accu
+ | Pos _ | Neg _ ->
+ [sb, (head, emb_lits [subst_literal sb literal] body)]
| Disj disjs ->
- let emb_lit lit body =
- match body with
- | Disj disjs::body -> Disj (lit::disjs)::body
+ let emb_lits lits body =
+ match body, lits with
+ | Disj disjs::body, [Disj lits] ->
+ Disj (lits @ disjs)::body
+ | Disj disjs::body, _ ->
+ Disj (lits @ disjs)::body
| _ -> assert false in
(* unfortunately only works with one level of disjunctions *)
- (* TODO: optimization when splitting clause not necessary *)
- Aux.concat_foldr (expand_literal emb_lit) disjs
+ Aux.concat_foldr (expand_literal true emb_lits) disjs
[sb, (head, Disj []::body)] in
let init = [[], (head, [])] in
let result =
- Aux.concat_foldr (expand_literal (fun l body-> l::body)) body init in
+ Aux.concat_foldr (expand_literal false (fun ls body-> ls @ body))
+ body init in
List.map (fun (sb, cl) -> subst_clause sb cl) result
-let elim_ground_arg new_rels rel arg clauses =
+let elim_pattern_arg new_rels rel arg clauses =
let rel_brs, clauses =
List.partition (fun ((r,_),_) -> r=rel) clauses in
- let grounding = Aux.unique_sorted
- (List.map (fun ((_,args),_) -> args.(arg)) rel_brs) in
+ let froots = Aux.unique_sorted
+ (List.map (fun ((_,args),_) ->
+ match args.(arg) with
+ | Const c -> c, 0
+ | Func (f, m_args) -> f, Array.length m_args
+ | Var _ -> assert false) rel_brs) in
let renamed_brs = List.map
(fun ((_,args), body) ->
- let short_args = Array.init (Array.length args - 1)
- (fun i -> if i < arg then args.(i) else args.(i+1)) in
- let rname = rel ^ "__" ^ term_to_name args.(arg) in
+ let func, m_args, arity =
+ match args.(arg) with
+ | Const c -> c, [| |], 0
+ | Func (f, m_args) -> f, m_args, Array.length m_args
+ | Var _ -> assert false in
+ let exp_args = Array.init (Array.length args - 1 + arity)
+ (fun i ->
+ if i < arg then args.(i)
+ else if i >= arg + arity then args.(i+1-arity)
+ else m_args.(i-arg)) in
+ let rname = rel ^ "__" ^ func in
new_rels := rname:: !new_rels;
- (rname, short_args), body)
+ (rname, exp_args), body)
rel_brs in
- Aux.concat_map (elim_ground_arg_in_body rel arg grounding)
+ Aux.concat_map (elim_pattern_arg_in_body rel arg froots)
(renamed_brs @ clauses)
-let elim_ground_args rels clauses =
+(* Find a relation with a non-wildcard pattern matching argument,
+ eliminate the pattern matching and modify the relation's call sites
+ accordingly. Repeat until no non-wildcard pattern matching
+ remains. *)
+let elim_pattern_args rels clauses =
let new_rels = ref [] and all_rels = ref [] in
let rec aux new_rels all_rels clauses = function
| [] -> clauses
| rel::rels ->
- (let try arg = find_ground_arg rel clauses in
- let clauses = elim_ground_arg new_rels rel arg clauses in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "elim_pattern_args: trying %s\n%!" rel
+ );
+ (* }}} *)
+ (let try arg = find_pattern_arg rel clauses in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "elim_pattern_args: found arg=%d\n%!" arg
+ );
+ (* }}} *)
+ let clauses = elim_pattern_arg new_rels rel arg clauses in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf
+ "elim_pattern_args: rel=%s arg=%d transformed:\n%s\n\n%!"
+ rel arg (clauses_str clauses)
+ );
+ (* }}} *)
aux new_rels all_rels clauses rels
with Not_found ->
all_rels := rel:: !all_rels;
aux new_rels all_rels clauses rels) in
let rec fix clauses =
all_rels := !new_rels @ !all_rels;
+ let more_rels = !new_rels in
new_rels := [];
- let clauses = aux new_rels all_rels clauses rels in
+ let clauses = aux new_rels all_rels clauses (rels @ more_rels) in
if !new_rels <> []
then fix clauses
else
@@ -1115,6 +1223,7 @@
all_rels, clauses in
fix clauses
+
let elim_ground_distinct clauses =
let rec filter_disj = function
| Pos (Distinct ts) when Aux.Strings.is_empty (terms_vars ts) ->
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/GDL.mli 2011-11-07 21:57:12 UTC (rev 1623)
@@ -153,10 +153,11 @@
val func_graph : string -> term list -> term array list
-(** Eliminate arguments of relations that are constant in each
- defining clause. Return the new clauses, and also the new
+(** Eliminate arguments of relations that are defined by non-wildcard
+ pattern matching (i.e. do not have a variable in any of the
+ defining clauses). Return the new clauses, and also the new
relation set. *)
-val elim_ground_args :
+val elim_pattern_args :
string list -> clause list -> string list * clause list
val elim_ground_distinct : clause list -> clause list
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/GDLTest.ml 2011-11-07 21:57:12 UTC (rev 1623)
@@ -290,7 +290,7 @@
(GDL.def_str ("legal", legal_def));
);
- "eliminate ground args simple" >::
+ "eliminate ground args" >::
(fun () ->
let descr = parse_game_descr
"
@@ -338,7 +338,7 @@
(true (cell ?x ?e o)))
" in
let defined_rels, result =
- elim_ground_args ["conn5"; "col"; "row"] descr in
+ elim_pattern_args ["conn5"; "col"; "row"] descr in
let res_s =
(String.concat "\n" (List.map GDL.clause_str result)) in
assert_equal ~printer:(fun x->x)
@@ -391,6 +391,86 @@
(true (cell ?x ?e o)))"
res_s
);
+
+
+ "eliminate pattern matching" >::
+ (fun () ->
+ let descr = parse_game_descr
+ "
+(<= (can_move x (move ?x ?y1 ?x ?y2))
+ (true (cell ?x ?y1 x))
+ (succ ?y1 ?y2)
+ (not (occupied ?x ?y2)))
+(<= (can_move o (move ?x ?y1 ?x ?y2))
+ (true (cell ?x ?y1 o))
+ (succ ?y2 ?y1)
+ (not (occupied ?x ?y2)))
+; First move can be a double.
+(<= (can_move x (move ?x 2 ?x 4))
+ (true (cell ?x 2 x))
+ (not (occupied ?x 3))
+ (not (occupied ?x 4)))
+(<= (can_move o (move ?x 7 ?x 5))
+ (true (cell ?x 7 o))
+ (not (occupied ?x 6))
+ (not (occupied ?x 5)))
+; Capture diagonally
+(<= (can_move x (capture ?x1 ?y1 ?x2 ?y2))
+ (true (cell ?x1 ?y1 x))
+ (true (cell ?x2 ?y2 o))
+ (succ ?y1 ?y2)
+ (or (succ ?x1 ?x2)
+ (succ ?x2 ?x1)))
+(<= (can_move o (capture ?x1 ?y1 ?x2 ?y2))
+ (true (cell ?x1 ?y1 o))
+ (true (cell ?x2 ?y2 x))
+ (succ ?y2 ?y1)
+ (or (succ ?x1 ?x2)
+ (succ ?x2 ?x1)))
+(<= (can_move_somewhere ?p)
+ (can_move ?p ?m))
+" in
+ let defined_rels, result =
+ elim_pattern_args ["can_move"; "can_move_somewhere"] descr in
+ let res_s =
+ (String.concat "\n" (List.map GDL.clause_str result)) in
+ assert_equal ~printer:(fun x->x)
+ "can_move__o__capture, can_move__o__move, can_move__x__capture, can_move__x__move, can_move_somewhere__o, can_move_somewhere__x"
+ (String.concat ", " defined_rels);
+ assert_equal ~printer:(fun x->x)
+ "(<= (can_move__x__move ?x ?y1 ?x ?y2)
+ (true (cell ?x ?y1 x))
+ (succ ?y1 ?y2)
+ (not (occupied ?x ?y2)))
+(<= (can_move__x__move ?x 2 ?x 4)
+ (true (cell ?x 2 x))
+ (not (occupied ?x 3))
+ (not (occupied ?x 4)))
+(<= (can_move__x__capture ?x1 ?y1 ?x2 ?y2)
+ (true (cell ?x1 ?y1 x))
+ (true (cell ?x2 ?y2 o))
+ (succ ?y1 ?y2)
+ (or (succ ?x1 ?x2) (succ ?x2 ?x1)))
+(<= (can_move__o__move ?x ?y1 ?x ?y2)
+ (true (cell ?x ?y1 o))
+ (succ ?y2 ?y1)
+ (not (occupied ?x ?y2)))
+(<= (can_move__o__move ?x 7 ?x 5)
+ (true (cell ?x 7 o))
+ (not (occupied ?x 6))
+ (not (occupied ?x 5)))
+(<= (can_move__o__capture ?x1 ?y1 ?x2 ?y2)
+ (true (cell ?x1 ?y1 o))
+ (true (cell ?x2 ?y2 x))
+ (succ ?y2 ?y1)
+ (or (succ ?x1 ?x2) (succ ?x2 ?x1)))
+(<= (can_move_somewhere__o )
+ (or (can_move__o__capture ?pv0 ?pv1 ?pv2 ?pv3) (can_move__o__move ?pv4 ?pv5 ?pv6 ?pv7)))
+(<= (can_move_somewhere__x )
+ (or (can_move__x__capture ?pv8 ?pv9 ?pv10 ?pv11) (can_move__x__move ?pv12 ?pv13 ?pv14 ?pv15)))"
+ res_s;
+ );
+
]
let bigtests = "GDLBig" >::: [
@@ -423,9 +503,12 @@
]
let a () =
- GDL.debug_level := 5
+ GDL.debug_level := 5;
+ (try
+ ()
+ with e -> print_endline (Printexc.to_string e);
+ flush stdout; flush stderr; raise e);
+ (* failwith "tested"; *)
+ ()
-let a () =
- ()
-
let exec = Aux.run_test_if_target "GDLTest" tests
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-11-07 21:57:12 UTC (rev 1623)
@@ -120,6 +120,9 @@
TODO-FIXME: extend operations (specifically 2) to handle formulas
nested in real expressions; with special treatment for update
expressions in rules (using the compiled precondition as context).
+
+ TODO: Selectively distribute atomic conjuncts over disjunction when it
+ leads to new glueings (point (3)).
*)
open Formula
Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/TranslateFormula.ml 2011-11-07 21:57:12 UTC (rev 1623)
@@ -5,6 +5,12 @@
let debug_level = ref 0
+(* Whether to add root predicates. Note that not adding root
+ predicates [no_root_predicates := true] will violate correctness
+ of some translations. *)
+let no_root_predicates = ref true
+
+
type transl_data = {
f_paths : path_set; (* fluent paths *)
c_paths : path_set; (* coordinate paths *)
@@ -284,11 +290,14 @@
let coord_and_fluent_preds =
List.map (fun (subt, path) ->
Formula.Rel (pred_on_path_subterm path subt, vartup)) s_subterms in
- let root_preds = Aux.map_some
- (fun root ->
- if root = simult_subst data.all_paths blank sterm
- then Some (Formula.Rel (term_to_name root, vartup))
- else None) data.root_reps in
+ let root_preds =
+ if !no_root_predicates then []
+ else
+ Aux.map_some
+ (fun root ->
+ if root = simult_subst data.all_paths blank sterm
+ then Some (Formula.Rel (term_to_name root, vartup))
+ else None) data.root_reps in
coord_and_fluent_preds @ root_preds in
let rec aux = function
| Pos (True sterm) -> transl_sterm sterm
Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/TranslateFormula.mli 2011-11-07 21:57:12 UTC (rev 1623)
@@ -1,5 +1,10 @@
val debug_level : int ref
+(** Whether to add root predicates. Note that not adding root
+ predicates [no_root_predicates := true] will violate correctness of
+ some translations. *)
+val no_root_predicates : bool ref
+
type transl_data = {
f_paths : GDL.path_set; (** fluent paths *)
c_paths : GDL.path_set; (** coordinate paths *)
Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml 2011-11-06 22:11:48 UTC (rev 1622)
+++ trunk/Toss/GGP/TranslateGame.ml 2011-11-07 21:57:12 UTC (rev 1623)
@@ -57,10 +57,6 @@
less fluent paths.) *)
let propose_leaf_f_paths = ref true
-(** Whether to eliminate an argument of a relation when it is ground
- in all clauses defining the relation. *)
-let perform_ground_arg_elim = ref true
-
(** two heuristics for selecting defined relations: select relations
with arity smaller than three; or, select relations that have ground
defining clauses (i.e. defining clauses with empty bodies). *)
@@ -975,6 +971,37 @@
("EQ_", Aux.Left (Array.make 2 c_pathl)) :: argpaths, clauses
+(* Expand the given relations in the given clauses: split the clauses
+ into those defining the relations, those using them and remaining
+ ones, expand the relations, and return the expanded clauses
+ together with the remaining clauses (discard the defining clauses). *)
+let expand_defs_in_clauses expand_rels clauses =
+ let defs = defs_of_rules (Aux.concat_map rules_of_clause clauses) in
+ let exp_defs = List.filter
+ (fun (rel,_) -> List.mem rel expand_rels) defs in
+ let cl_defs = List.filter
+ (fun (rel,brs) -> not (List.mem rel expand_rels) &&
+ List.exists (fun (_, pos, neg) ->
+ List.exists (fun (rel,_) ->
+ List.mem_assoc rel (pos @ neg)) exp_defs) brs) defs in
+ let operated =
+ Aux.map_prepend (List.map fst cl_defs) fst exp_defs in
+ let remaining = List.filter
+ (fun ((rel, _), _) -> not (List.mem rel operated)) clauses in
+ let expanded = List.map
+ (fun (rel,brs) -> rel, expand_definitions exp_defs brs)
+ cl_defs in
+ let pos = function Distinct _ as a -> Neg a | a -> Pos a in
+ let neg = function Distinct _ as a -> Pos a | a -> Neg a in
+ let br_to_clause rel (args, body, neg_body) =
+ (rel, args),
+ List.map (fun a->pos (atom_of_rel a)) body @
+ List.map (fun a->neg (atom_of_rel a)) neg_body in
+ let def_to_clauses (rel, brs) = List.map (br_to_clause rel) brs in
+ let exp_clauses = Aux.concat_map def_to_clauses expanded in
+ exp_clauses @ remaining
+
+
let process_frame_clauses clauses frame_clauses =
(* we need to expand frame clauses so that later local variables will get
eliminated from erasure clauses *)
@@ -999,12 +1026,12 @@
expand_definitions ["does", legal_defs] frame_defs in
let pos = function Distinct _ as a -> Neg a | a -> Pos a in
let neg = function Distinct _ as a -> Pos a | a -> Neg a in
- let def_to_clause (args, body, neg_body) =
+ let br_to_clause (args, body, neg_body) =
("next", args),
List.map (fun a->pos (atom_of_rel a)) body @
List.map (fun a->neg (atom_of_rel a)) neg_body in
- let frame_clauses = List.map def_to_clause exp_frame_defs in
- let lexp_frame_clauses = List.map def_to_clause lexp_frame_defs in
+ let frame_clauses = List.map br_to_clause exp_frame_defs in
+ let lexp_frame_clauses = List.map br_to_clause lexp_frame_defs in
lexp_frame_clauses, frame_clauses
@@ -1318,9 +1345,11 @@
sb, legal_tup, n_cls) cl_tups in
Aux.concat_map move_clauses legal_tuples
-
-let add_erasure_clauses f_paths (legal_tup, next_cls) =
- let fixed_vars = terms_vars (Aux.array_map_of_list fst legal_tup) in
+(* We need to know players to pick the relevant legal term from
+ [legal_tup] when filtering-out "does" atoms. *)
+let add_erasure_clauses f_paths players_wo_env (legal_tup, next_cls) =
+ let legal_t_tup = Aux.array_map_of_list fst legal_tup in
+ let fixed_vars = terms_vars legal_t_tup in
check_timeout "TranslateGame: add_erasure_clauses: start";
let legal_cl_bodies = List.map snd legal_tup in
let frame_cls, move_cl_bodies =
@@ -1409,6 +1438,25 @@
nbodies
) frames in
+ (* Filter-out clauses which contain a non-matching positive "does"
+ atom, while removing the matching "does" atoms. *)
+ let erasure_cls = Aux.map_try
+ (fun (s, body) ->
+ let does_atoms, body = List.partition
+ (function Pos (Does _) -> true | _ -> false)
+ body in
+ let sb = List.fold_left (fun sb ->
+ function
+ | Pos (Does (player, t)) ->
+ let pnum = Aux.array_argfind
+ (fun p->p=player) players_wo_env in
+ unify sb [t] [legal_t_tup.(pnum)]
+ | _ -> assert false)
+ [] does_atoms in
+ if sb = [] then s, body
+ else subst sb s, subst_literals sb body)
+ (Aux.unique_sorted erasure_cls) in
+
(* Recover fixed variables. *)
let fixed_to_var = List.map
(fun v -> v, Var v) (Aux.Strings.elements fixed_vars) in
@@ -1417,7 +1465,7 @@
them for rule candidates. *)
let erasure_cls = Aux.map_some
(fun (s, body) ->
- let local_ex_vars = term_vars s in
+ let local_ex_vars = Aux.Strings.diff (term_vars s) fixed_vars in
let local_uni_vars = Aux.Strings.diff
(literals_vars body) local_ex_vars in
(* {{{ log entry *)
@@ -1455,7 +1503,7 @@
subst_consts fixed_to_var s, kind,
subst_consts_literals fixed_to_var body)
else None)
- (Aux.unique_sorted erasure_cls) in
+ erasure_cls in
(* {{{ log entry *)
if !debug_level > 2 then (
@@ -1966,7 +2014,7 @@
Array.iteri print_tup (Array.of_list move_tups)
);
(* }}} *)
- List.map (add_erasure_clauses f_paths) move_tups
+ List.map (add_erasure_clauses f_paths players_wo_env) move_tups
(* Filter the "next" clauses removing conditions common with legal
@@ -2504,6 +2552,7 @@
let add = Aux.unique_sorted (synch_postcond @ extract_tups pos_rhs) in
(* let add = if counter_cls = [] then add else *)
let del = Aux.unique_sorted (unframed_tups @ extract_tups neg_rhs) in
+ let del = Aux.sorted_diff del add in
let all_rhs = pos_rhs @ neg_rhs in
let struc_elems = List.map
(fun sterm -> term_to_name (blank_out transl_data sterm))
@@ -3091,6 +3140,17 @@
let counters = List.map fst counter_inits in
let goal_cls_w_counters, clauses =
encode_goals_w_counters num_functors counters goal_cls_w_counters clauses in
+ let rec has_does = function
+ | Pos (Does _) | Neg (Does _) -> true
+ | Disj disj -> List.exists has_does disj
+ | _ -> false in
+ let rels_w_does_atoms =
+ (Aux.unique_sorted -| List.map (fst -| fst) -|
+ List.filter (List.exists has_does -| snd))
+ clauses in
+ let clauses = expand_defs_in_clauses
+ (Aux.list_diff rels_w_does_atoms ["next"; "frame next"; "legal"])
+ clauses in
check_timeout "TranslateGame: basic clauses";
let ground_at paths = List.map
(fun p ->
@@ -3115,16 +3175,12 @@
(fun rel -> List.exists (fun ((r,_),b) -> r=rel && b=[]) clauses)
static_rels in
let elim_static_rels, clauses =
- if !perform_ground_arg_elim
- then elim_ground_args elim_static_rels clauses
- else elim_static_rels, clauses in
+ elim_pattern_args elim_static_rels clauses in
let static_rels = elim_static_rels @ nonelim_static_rels in
let nonstatic_rels =
- Aux.list_diff nonstatic_rels ["goal"; "legal"; "next"] in
+ Aux.list_diff nonstatic_rels ["goal"; "legal"; "next"; "frame next"] in
let nonstatic_rels, clauses =
- if !perform_ground_arg_elim
- then elim_ground_args nonstatic_rels clauses
- else nonstatic_rels, clauses in
+ elim_pattern_args nonstatic_rels clauses in
(* eliminate once again since more variables have been instantiated *)
let clauses = elim_ground_distinct clauses in
let nonstatic_...
[truncated message content] |
|
From: <luk...@us...> - 2011-11-08 09:44:59
|
Revision: 1624
http://toss.svn.sourceforge.net/toss/?rev=1624&view=rev
Author: lukstafi
Date: 2011-11-08 09:44:53 +0000 (Tue, 08 Nov 2011)
Log Message:
-----------
Aux: rev_map in map_reduce. GameSimpl: one more TODO.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/GGP/GameSimpl.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-07 21:57:12 UTC (rev 1623)
+++ trunk/Toss/Formula/Aux.ml 2011-11-08 09:44:53 UTC (rev 1624)
@@ -103,9 +103,8 @@
if k0 = kn then k0, vn::vs, l
else kn, [vn], (k0,vs)::l)
(k0, [v0], []) tl in
- List.rev (
- List.map (fun (k,vs) -> k, List.fold_left redf red0 vs)
- ((k0,vs)::l))
+ List.rev_map (fun (k,vs) -> k, List.fold_left redf red0 vs)
+ ((k0,vs)::l)
let collect l =
match List.sort (fun x y -> compare (fst x) (fst y)) l with
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-11-07 21:57:12 UTC (rev 1623)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-11-08 09:44:53 UTC (rev 1624)
@@ -123,6 +123,10 @@
TODO: Selectively distribute atomic conjuncts over disjunction when it
leads to new glueings (point (3)).
+
+ TODO: Glueing (i.e. intersecting relations with co-occurring
+ atoms) for stable relations of varying arity, e.g. glueing a
+ binary relation with a predicate.
*)
open Formula
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-11-10 01:27:07
|
Revision: 1625
http://toss.svn.sourceforge.net/toss/?rev=1625&view=rev
Author: lukaszkaiser
Date: 2011-11-10 01:26:59 +0000 (Thu, 10 Nov 2011)
Log Message:
-----------
Correcting and completing guarded types, merging WL with Distinguish and allowing to set method.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Server/LearnGame.ml
trunk/Toss/Server/LearnGameTest.ml
trunk/Toss/Server/Picture.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/Distinguish.ml
trunk/Toss/Solver/Distinguish.mli
trunk/Toss/Solver/DistinguishTest.ml
Removed Paths:
-------------
trunk/Toss/Solver/WL.ml
trunk/Toss/Solver/WL.mli
trunk/Toss/Solver/WLTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Formula/Aux.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -348,6 +348,10 @@
| [] -> [] in
idemp (List.sort cmp l)
+let all_subsets ?max_size set =
+ let size = match max_size with Some i -> i | None -> List.length set in
+ [] :: (unique_sorted (List.map unique_sorted (all_ntuples set size)))
+
let unique_append l1 l2 =
List.fold_left (fun l2 e ->
if List.mem e l2 then l2 else e::l2) l2 (List.rev l1)
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Formula/Aux.mli 2011-11-10 01:26:59 UTC (rev 1625)
@@ -172,6 +172,9 @@
(** An [n]th cartesian power of the list. Tail recursive. *)
val all_ntuples : '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
+
(** Remove an occurrence of a value (uses structural equality). *)
val remove_one : 'a -> 'a list -> 'a list
Modified: trunk/Toss/Server/LearnGame.ml
===================================================================
--- trunk/Toss/Server/LearnGame.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Server/LearnGame.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -19,7 +19,7 @@
let winFormula winningStates notWinningStates =
- WL.distinguish winningStates notWinningStates
+ Distinguish.distinguish winningStates notWinningStates
let cleanStructure struc =
let funs = List.map fst (Structure.StringMap.bindings (Structure.functions struc)) in
Modified: trunk/Toss/Server/LearnGameTest.ml
===================================================================
--- trunk/Toss/Server/LearnGameTest.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Server/LearnGameTest.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -76,8 +76,8 @@
\"" ;]] in
let res_game =
"PLAYERS 1, 2
-REL Win1() = ex x1, x2 (Q(x2) and R(x2, x1))
-REL Win2() = ex x1, x2 (Q(x2) and R(x1, x2))
+REL Win1() = ex x0, x1 (Q(x1) and R(x1, x0))
+REL Win2() = ex x0, x1 (Q(x1) and R(x0, x1))
RULE Mv1:
[1 | P:1 {}; Q:1 {}; R:2 {} | ] -> [1 | P (1); Q:1 {}; R:2 {} | ]
emb R,Q,P pre not Win2()
@@ -107,7 +107,7 @@
let bigtests = "LearnGame" >::: [
"tic-tac-toe" >::
(fun () ->
- WL.set_debug_level 0; (* set to 1 to get some info printed out *)
+ Distinguish.set_debug_level 0; (* set to 1 to get some info printed out *)
let partylist0 = [
List.map struc_of_string [
"[ | P:1 {}; Q:1 {} | ] \"
Modified: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Server/Picture.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -258,12 +258,6 @@
let tp = postp left crels delems in
if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And tp);
- if !debug_level > -1 then (
- let nofluent_left = Structure.clear_rels left (fun r -> List.mem r drels) in
- let tbl = WL.all_ntypes_simplified nofluent_left 1 2 in
- Format.eprintf "@[%a@]@ \n%!" Formula.fprint
- (Hashtbl.find tbl (Array.of_list delems));
- );
let cut s = List.fold_left Structure.del_elem s
(List.filter (fun e -> not (List.mem e delems)) (Structure.elements s)) in
(cut left, cut right, tp)
@@ -368,7 +362,7 @@
Format.eprintf "@[%a@]@ \n%!" Formula.fprint (Formula.And (basic :: mw));
if !debug_level > -1 then
Format.eprintf "@[%a@]@ \n%!" Formula.fprint
- (Aux.unsome (WL.distinguish_by_type ~qr:1 ~k:2 [right] [wrong]));
+ (Aux.unsome (Distinguish.distinguish_by_type ~qr:1 ~k:2 [right] [wrong]));
Formula.flatten (Formula.Ex (ex_vars, Formula.And (basic :: mw)))
)
Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Server/Tests.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -17,7 +17,6 @@
"AssignmentsTest", [AssignmentsTest.tests];
"SolverTest", [SolverTest.tests; SolverTest.bigtests];
"ClassTest", [ClassTest.tests; ClassTest.bigtests];
- "WLTest", [WLTest.tests; WLTest.bigtests];
"DistinguishTest", [DistinguishTest.tests; DistinguishTest.bigtests];
]
Modified: trunk/Toss/Solver/Distinguish.ml
===================================================================
--- trunk/Toss/Solver/Distinguish.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Solver/Distinguish.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -3,6 +3,10 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i)
+type distinguish_method = Types | Guarded
+
+
+
(* Helper functions to construct variables for indices. *)
let varname i = "x" ^ string_of_int i
let varnames k = List.map varname (Aux.range k)
@@ -19,7 +23,7 @@
Assignments.assignments_of_list elems vars [tuple] in
eval structure formula assignment <> AssignmentSet.Empty
-(* - Atoms - *)
+(* - Atoms and FO Types - *)
(* The list of literals which hold for a tuple on a structure. *)
let atoms struc tuple =
@@ -33,7 +37,26 @@
) (atoms @ (equalities (varnames k)))
+(* 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])
+(* 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)
+
+
(* - Guards and Guarded Types - *)
(* Generate all guarded substitutions of [tuple] with the guards.
@@ -86,19 +109,32 @@
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) =
+ let next_gtype vs (g, ts) =
And [conj_prev_ex vs g ts; all_prev_disj vs g ts] in
- let (guards, subst_tuples) = List.split (
- List.rev_map (fun (_, vs, t, _, f) -> (vs,f), t) (guards struc tuple)) in
- let (guards, subst_tuples) =
- (Aux.unique_sorted guards, Aux.unique_sorted subst_tuples) in
- let guarded_tups (_, f) =
- List.filter (fun tup -> check struc tup f) subst_tuples in
- let guards_with_tups = List.map (fun g -> (g, guarded_tups g)) guards in
- let nextf = And (List.map next_gtype guards_with_tups) 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])
(* All guarded types of rank [qr] of guarded [k]-tuples in [struc]. *)
@@ -136,8 +172,11 @@
| phi -> phi
-let distinguish_by_type ?(skip_outer_exists=false) ~qr ~k sPos sNeg=
- let types s = guarded_types s ~qr ~k in
+let distinguish_by_type ?(how=Guarded) ?(skip_outer_exists=false) ~qr ~k
+ sPos sNeg =
+ 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
@@ -160,12 +199,12 @@
if dtypes = [] then None else
let is_ok f = fails_neg f && succ_pos [f] in
let mintp = greedy_remove is_ok (Or dtypes) in
- let fv = FormulaSubst.free_vars (Or dtypes) in
- let t= FormulaOps.rename_quant_avoiding fv mintp in
+ let fv = FormulaSubst.free_vars mintp in
+ let t = FormulaOps.rename_quant_avoiding fv mintp in
if skip_outer_exists then Some t else
Some (Ex (List.sort Formula.compare_vars fv, t))
-let distinguish ?(skip_outer_exists=false) strucs1 strucs2 =
+let distinguish ?(how=Guarded) ?(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))
@@ -173,7 +212,7 @@
let rec diff qr k =
if qr > k then diff 0 (k+1) else (
if !debug_level > 0 then Printf.printf "distinguish qr %i k %i\n%!" qr k;
- match distinguish_by_type ~skip_outer_exists ~qr ~k strucs1 strucs2 with
+ match distinguish_by_type ~how ~skip_outer_exists ~qr ~k strucs1 strucs2 with
| Some f -> f
| None -> diff (qr+1) k
) in
Modified: trunk/Toss/Solver/Distinguish.mli
===================================================================
--- trunk/Toss/Solver/Distinguish.mli 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Solver/Distinguish.mli 2011-11-10 01:26:59 UTC (rev 1625)
@@ -1,12 +1,21 @@
(** Distinguish sets of structures by formulas. *)
-(** {2 Atoms} *)
+type distinguish_method = Types | Guarded
+
+(** {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.
@@ -36,10 +45,11 @@
(** {2 Distinguishing Structure Sets} *)
-val distinguish_by_type: ?skip_outer_exists: bool -> qr: int -> k: int ->
- Structure.structure list -> Structure.structure list -> Formula.formula option
+val distinguish_by_type: ?how: distinguish_method -> ?skip_outer_exists: bool ->
+ qr: int -> k: int -> Structure.structure list -> Structure.structure list ->
+ Formula.formula option
-val distinguish: ?skip_outer_exists: bool ->
+val distinguish: ?how: distinguish_method -> ?skip_outer_exists: bool ->
Structure.structure list -> Structure.structure list -> Formula.formula
Modified: trunk/Toss/Solver/DistinguishTest.ml
===================================================================
--- trunk/Toss/Solver/DistinguishTest.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Solver/DistinguishTest.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -48,6 +48,45 @@
(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
@@ -121,15 +160,24 @@
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 (guarded_type struc 1 [|1; 2|]); (* no guards *)
- formula_eq lits (guarded_type struc 2 [|1; 2|]); (* no guards *)
+ 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 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(x1, x0) or (not R(x0, x0) and not R(x0,x1)" ^
- " and not x0 = x1 and not R(x1, x1)))")
+ 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|]);
);
@@ -168,9 +216,12 @@
(Distinguish.distinguish_by_type ~qr:2 ~k:1 [struc1] [struc2]);
formula_option_eq "None" (* we use guarded types - so None here *)
(Distinguish.distinguish_by_type ~qr:0 ~k:2 [struc1] [struc2]);
+ formula_option_eq "not R(x0, x1) and not x0 = x1 and not R(x1, x0)"
+ (Distinguish.distinguish_by_type ~how:Types ~skip_outer_exists:true
+ ~qr:0 ~k:2 [struc1] [struc2]);
formula_option_eq "None" (* we use guarded types - so None here *)
(Distinguish.distinguish_by_type ~qr:0 ~k:3 [struc1] [struc2]);
- formula_option_eq "R(x0, x1) and ex x2 R(x1, x2)"
+ formula_option_eq "R(x0, x1) and ex x2 R(x2, x0)"
(Distinguish.distinguish_by_type ~skip_outer_exists:true ~qr:1 ~k:2
[struc1] [struc2]);
@@ -184,12 +235,27 @@
(fun () ->
let struc1 = (struc_of_string "[ | R { (1, 2); (2, 3) } | ]") in
let struc2 = (struc_of_string "[ | R { (1, 2) } | ]") in
- formula_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x1, x2))"
+ formula_eq "ex x0, x1 (R(x0, x1) and ex x2 R(x2, x0))"
(Distinguish.distinguish [struc1] [struc2]);
let struc1 = (struc_of_string "[ | P { (1) }; R:1 {} | ]") in
let struc2 = (struc_of_string "[ | P:1 {}; R { (1) } | ]") in
formula_eq "ex x0 P(x0)" (Distinguish.distinguish [struc1] [struc2]);
+
+ let struc1 = struc_of_string "[ | | ] \"
+ ...
+ ...
+ ...
+ P..
+\"" in
+ let struc2 = struc_of_string "[ | | ] \"
+ ...
+ P..
+ ...
+ ...
+\"" in
+ formula_eq "ex x0, x1 (P(x0) and C(x0, x1))"
+ (Distinguish.distinguish [struc1] [struc2]);
);
]
@@ -233,6 +299,7 @@
"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;
);
"breakthrough" >::
@@ -272,9 +339,9 @@
... ... ... W..
... ... ... ...
...W ... ... ...
-\"" in
- Distinguish.set_debug_level 1;
- formula_eq "W(x2) and all x3 not C(x2, x3)"
+\"" 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)"
(Distinguish.distinguish ~skip_outer_exists:true [struc1] [struc2]);
);
]
Deleted: trunk/Toss/Solver/WL.ml
===================================================================
--- trunk/Toss/Solver/WL.ml 2011-11-08 09:44:53 UTC (rev 1624)
+++ trunk/Toss/Solver/WL.ml 2011-11-10 01:26:59 UTC (rev 1625)
@@ -1,255 +0,0 @@
-open Formula
-
-let debug_level = ref 0
-let set_debug_level i = (debug_level := i)
-
-(* Given an array of lists, i.e. a.(i) is a list, find an array b of the same
- size of sub-lists (b.(i) subset a.(i)) such that if there was an element
- distinguishing a.(i) from a.(j) then one separates b.(i) from b.(j).
- This can be done in many ways (is it NP-complete to get the shortest b?),
- we remove the intersection and after this greedily unused elements if
- the option [greedy_cleanup] is set. *)
-let rec separate ?(cmp = Pervasives.compare) ?(greedy_cleanup = true) a =
- let nonempty_intersect l1 l2 =
- if l1 = [] then l2 else if l2 = [] then l1 else Aux.sorted_inter l1 l2 in
- let no_intersect arr =
- let sorted = Array.map Aux.unique_sorted arr in
- let inter = Array.fold_left nonempty_intersect sorted.(0) sorted in
- Array.map (fun x -> Aux.list_diff x inter) arr in
- let cleanup arr =
- let suffices orig l i = Aux.array_for_alli (
- fun j lst -> j = i || lst = orig ||
- List.exists (fun x -> not (List.mem x a.(j))) l) arr in
- let rec filter orig i acc rest =
- if rest = [] || suffices orig acc i then acc else
- filter orig i ((List.hd rest)::acc) (List.tl rest) in
- Array.mapi (fun i l -> filter l i [] (List.sort cmp l)) arr in
- let rec rec_cleanup arr =
- let new_arr = cleanup arr in
- if new_arr = arr then arr else rec_cleanup new_arr in
- if Array.length a = 0 then a else
- let b = no_intersect a in
- if greedy_cleanup then rec_cleanup b else b
-
-
-(* Call the separate function from above on an array of conjunctions. *)
-let separate_conjs greedy conjs =
- separate ~cmp:Formula.compare ~greedy_cleanup:greedy conjs
-
-
-(* Helper function: check if a formula holds for a tuple on a structure. *)
-let check structure tuple variables 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 assignment = if tuple = [||] then AssignmentSet.Any else
- Assignments.assignments_of_list elems
- (Array.map fo_var_of_string variables) [tuple] in
- eval structure formula assignment <> AssignmentSet.Empty
-
-(* The list of literals which hold for a tuple on a structure,
- i.e. the atomic type of this tuple. *)
-let atoms structure tuple variables_in =
- let variables = (Array.sub variables_in 0 (Array.length tuple)) in
- let rec inequalities vars = match vars with
- head::tail -> List.append (List.map (fun x -> Eq (`FO head,`FO x) ) tail)
- (inequalities tail)
- | _ -> [] in
- let listOfLiterals = FormulaOps.atoms (Structure.rel_signature structure)
- (Array.to_list variables) in
- List.map (fun literal ->
- if check structure tuple variables literal then literal else (Not literal)
- ) (List.append listOfLiterals (inequalities (Array.to_list variables)))
-
-let range k = Aux.range ~from:1 (k+1)
-
-(* The n-type from FO^k for the [tuple] in [structure]. *)
-let rec ntype structure tuple k_in n =
- let m = Array.length tuple in
- let k = max k_in m in
- let variables = (List.map (fun i -> "x"^string_of_int(i)) (range k)) in
- if n=0 then
- Formula.flatten_sort (And (atoms structure tuple (Array.of_list variables)))
- else
- let elements = Structure.elements structure in
- if m < k then (* tuple shorter than variables, append one *)
- let x_new = `FO ("x"^(string_of_int((Array.length tuple)+1))) in
- let conj_b_ex_xmplus1_typesN structure tuple k n =
- And ( List.map (fun x ->
- Ex ([x_new], ntype structure (Array.append tuple [|x|]) k n)
- ) elements) in
- let all_xmplus1_disj_b_typesN structure tuple k n =
- All ([x_new], (Or (List.map (fun x ->
- ntype structure (Array.append tuple [|x|]) k n) elements ) )) in
- Formula.flatten_sort (And [
- (ntype structure tuple k (n-1));
- (conj_b_ex_xmplus1_typesN structure tuple k (n-1));
- (all_xmplus1_disj_b_typesN structure tuple k (n-1))])
- else (* all variables already used, substitute *)
- let indices = range k in
- let substituted i e = (Aux.array_replace tuple (i-1) e) in
- let conj_b_ex_xi_typesN_replace_ai_by_b structure tuple k n i =
- And (List.map (fun x ->
- Ex ([`FO ("x"^(string_of_int i))],
- (ntype structure (substituted i x) k n))
- ) elements) in
- let all_xi_disj_b_typesN_replace_ai_by_b structure tuple k n i=
- All ([`FO ("x"^(string_of_int i))],
- ( Or (List.map (fun x ->
- (ntype structure (substituted i x) k n)) elements ))) in
- Formula.flatten_sort (And [
- (ntype structure tuple k (n-1));
- (And ( (List.map (fun i ->
- (And [(conj_b_ex_xi_typesN_replace_ai_by_b structure tuple k (n-1) i);
- (all_xi_disj_b_typesN_replace_ai_by_b structure tuple k (n-1) i)
- ])) indices )))])
-
-let rec all_ntypes_ktuples ?(acc_types=[]) ?(tuples=None) structure n k =
- let elements = Structure.elements structure in
- let tuples = match tuples with Some tp -> tp | None ->
- List.map Array.of_list (Aux.all_ntuples elements k) in
- match tuples with
- | head::tail ->
- let ntyp = (ntype structure head k n) in
- let vars = (List.map (fun i -> "x"^string_of_int i) (range k)) in
- let check tuple = check structure tuple (Array.of_list vars) ntyp in
- let filtered = List.filter (fun t -> not (check t)) tail in
- (all_ntypes_ktuples ~acc_types:(ntyp::acc_types)
- ~tuples:(Some filtered) structure n k)
- | _ -> acc_types
-
-
-(* --- WITH SIMPLIFICATION --- *)
-
-let atoms_simplified ?(min=true) structure tuples variables =
- let tlist = Array.map (fun tuple ->
- Aux.unique_sorted (atoms structure tuple variables)) tuples in
- let tlistF =
- if min then separate_conjs (Array.length tuples < 80) tlist else tlist in
- let tuplesTable = Hashtbl.create 7 in
- Array.iteri (fun i tuple->
- Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
- ) tuples;
- tuplesTable
-
-let nextTypes ?(min=true) structure tuples variables types =
- let conjuncts tuple =
- let indices = range (Array.length tuple) in
- let substituted i e = Aux.array_replace tuple (i-1) e in
- let sorted tp = Array.of_list (Aux.unique_sorted (Array.to_list tp)) in
- let all_diff i = Array.to_list (Aux.array_mapi_some (
- fun j v -> if j = i then None else
- Some (Not (Eq (fo_var_of_string variables.(i), fo_var_of_string variables.(j))))
- ) variables) in
- let all_eq i = List.map (function Not f-> f | _-> failwith "neq") (all_diff i) in
- let conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i =
- Aux.unique_sorted (Aux.map_some (fun x ->
- let subst = substituted i x in
- if Array.length (sorted subst) < Array.length tuple then None else
- Some (Ex ([`FO ("x"^(string_of_int i))],
- And ( (Hashtbl.find types subst) :: (all_diff (i-1)))))
- ) (Structure.elements structure)) in
- let all_xi_disj_b_typesN_replace_ai_by_b structure tuple i=
- All ([`FO ("x"^(string_of_int i))],
- (Or ((all_eq (i-1)) @ Aux.unique_sorted (Aux.map_some (
- fun x ->
- let subst = substituted i x in
- if Array.length (sorted subst) < Array.length tuple then None
- else Some (Hashtbl.find types (substituted i x))
- ) (Structure.elements structure) )))) in
- ((Hashtbl.find types tuple)::
- (List.flatten (List.map (fun i ->
- (all_xi_disj_b_typesN_replace_ai_by_b structure tuple i)::
- (conj_b_ex_xi_typesN_replace_ai_by_b structure tuple i)
- ) indices ))) in
- let tlist = Array.map conjuncts tuples in
- let tlistF = if min then separate_conjs false tlist else tlist in
- let tuplesTable = Hashtbl.create 7 in
- Array.iteri (fun i tuple->
- Hashtbl.add tuplesTable tuple (Formula.flatten_sort (And (tlistF.(i))))
- ) tuples;
- tuplesTable
-
-let rec ntypesSimplified ?(min=true) ?cur_types tuples variables structure n k =
- let x, types = match cur_types with
- | Some (step, typs) -> (step, typs)
- | None -> (0, atoms_simplified ~min structure tuples variables) in
- if x >= n then types else
- ntypesSimplified
- ~cur_types:(x+1, nextTypes ~min structure tuples variables types)
- tuples variables structure n k
-
-let rec all_ntypes_simplified ?(min=true) structure n k =
- let rec no_rept l = List.length l = List.length (Aux.unique_sorted l) in
- let tuples =
- Array.of_list (List.map Array.of_list (List.filter no_rept (
- Aux.all_ntuples (Structure.elements structure) k))) in
- let variables =
- Array.map (fun i -> "x"^string_of_int(i)) (Array.of_list (range k)) in
- ntypesSimplified ~min tuples variables structure n k
-
-(* Helper function: remove atoms from a formula if [cond] is still satisfied.
- Note that this is just a greedy heuristic, only And/Or and into Ex/All. *)
-let rec greedy_remove cond phi =
- let rec greedy_remove_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 -> Or (greedy_remove_list (fun l -> Or l) [] (List.rev fl))
- | Not f -> 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
-
-
-let distinguish_by_type ?(min=true) ?(skip_outer_exists=false) ~qr ~k sPos sNeg=
- let listht table = Hashtbl.fold (fun x y z -> y :: z) table [] in
- let types s= Aux.unique_sorted (listht (all_ntypes_simplified ~min 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 [||] [||] f) sPos in
- let candidates = List.rev_append (List.concat tpPos)
- (List.map (fun f -> Not f) (List.concat tpNeg)) in
- let fail_neg = List.filter fails_neg (Aux.unique_sorted candidates) in
- let phis = List.sort Formula.co...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X