[Toss-devel-svn] SF.net SVN: toss:[1359] trunk/Toss

[<luk...@us...>]

Revision: 1359
          http://toss.svn.sourceforge.net/toss/?rev=1359&view=rev
Author:   lukstafi
Date:     2011-03-14 11:11:08 +0000 (Mon, 14 Mar 2011)

Log Message:
-----------
Removed printing of empty relations in rule LHS and RHS structures as these are required to share signature with the model. Comparison of games modulo numbering of elements in structures, flattening of formulas, etc., display the first difference met.

Modified Paths:
--------------
    trunk/Toss/Arena/Arena.ml
    trunk/Toss/Arena/Arena.mli
    trunk/Toss/Arena/ContinuousRule.ml
    trunk/Toss/Arena/ContinuousRule.mli
    trunk/Toss/Arena/ContinuousRuleTest.ml
    trunk/Toss/Arena/DiscreteRule.ml
    trunk/Toss/Arena/DiscreteRule.mli
    trunk/Toss/Arena/DiscreteRuleTest.ml
    trunk/Toss/GGP/GDL.ml
    trunk/Toss/GGP/GDLTest.ml
    trunk/Toss/GGP/GameSimplTest.ml
    trunk/Toss/Solver/Solver.ml
    trunk/Toss/Solver/Structure.ml
    trunk/Toss/Solver/Structure.mli
    trunk/Toss/Solver/StructureTest.ml
    trunk/Toss/caml_extensions/pa_backtrace.ml
    trunk/Toss/examples/rewriting_example.toss

Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/Arena.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -347,7 +347,8 @@
   Array.iter (fun loc ->
     Format.fprintf ppf "@[<1>LOC %d@ {@,@[<1>@,%a@]@,}@]@ "
       loc.id (fprint_loc_body struc player_names) loc) graph;
-  Format.fprintf ppf "@[<1>MODEL@ %a@]@ "  Structure.fprint struc;
+  Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
+    (Structure.fprint ~show_empty:true) struc;
   if cur_loc <> 0 then
     Format.fprintf ppf "@[<1>STATE LOC@ %d@]@ " cur_loc;
   if time <> 0. then
@@ -391,6 +392,58 @@
       drel, (args, f def)) game.defined_rels;
   }
 
+(* Compare two (game, state) pairs and explain the first difference
+   met. Formulas and expressions are compared for syntactical
+   equality. Players need to be given in the same order. Data is ignored. *)
+exception Diff_result of string
+
+let compare_diff ?(cmp_funs=(=)) (g1,s1) (g2,s2) =
+  try
+    let eq, msg =
+      Structure.compare_diff ~cmp_funs s1.struc s2.struc in
+    if not eq then raise (Diff_result ("Game state models differ: "^msg));
+    if not (cmp_funs s1.time s2.time) then raise
+      (Diff_result (
+        Printf.sprintf "Game state times %F and %F differ" s1.time s2.time));
+    if s1.cur_loc <> s2.cur_loc then raise
+      (Diff_result (
+        Printf.sprintf "Game state locations %d and %d differ"
+          s1.cur_loc s2.cur_loc));
+    let rules =
+      try List.combine (List.sort Pervasives.compare g1.rules)
+            (List.sort Pervasives.compare g2.rules)
+      with Invalid_argument _ -> raise (
+        Diff_result "Games have different number of rules") in
+    List.iter (fun ((rn1,r1),(rn2,r2))->
+      if rn1 < rn2 then
+        raise (Diff_result ("Second game lacks rule "^rn1));
+      if rn2 < rn1 then
+        raise (Diff_result ("First game lacks rule "^rn2));
+      let eq, msg =
+        ContinuousRule.compare_diff ~cmp_funs r1 r2 in
+      if not eq then raise (Diff_result (
+        "Games differ at rule "^rn1^": "^ msg))
+    ) rules;
+    let cmp_pn (_,i) (_,j) = i-j in
+    let pnames1 = List.sort cmp_pn g1.player_names in
+    let pnames2 = List.sort cmp_pn g2.player_names in
+    if pnames1 <> pnames2 then
+      raise (Diff_result "Game players are given in different order.");
+    let norm_loc loc =
+      {loc with
+        moves = List.sort Pervasives.compare loc.moves;
+        payoffs = Array.map (
+          FormulaOps.map_to_formulas_expr FormulaOps.flatten_formula)
+          loc.payoffs} in
+    if Array.map norm_loc g1.graph <> Array.map norm_loc g2.graph
+    then raise (Diff_result "Games have different graphs");
+    if List.sort Pervasives.compare g1.defined_rels <>
+      List.sort Pervasives.compare g2.defined_rels
+    then raise (Diff_result "Games have different defined relations");
+    true, "equal"
+  with Diff_result expl -> false, expl
+
+
 (* ------------------ REQUESTS TO THE ARENA USED IN OPERATION --------------- *)
 
 (* Location of a structure: either arena or left or right-hand side of a rule *)

Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/Arena.mli	2011-03-14 11:11:08 UTC (rev 1359)
@@ -111,6 +111,15 @@
 val map_to_formulas : (Formula.formula -> Formula.formula) -> game -> game
 
 
+(** Compare two (game, state) pairs and explain the first difference
+    met. Formulas and expressions are compared for syntactical
+    equality. Players need to be given in the same order. Data is
+    ignored. *)
+val compare_diff :
+  ?cmp_funs:(float -> float -> bool) ->
+  game * game_state -> game * game_state -> bool * string
+
+
 (** {2 Requests to the Arena used in Operation} *)
 
 (** Location of a structure: either arena or left or right-hand side of a rule *)

Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/ContinuousRule.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -239,3 +239,25 @@
   ignore (Format.flush_str_formatter ());
   fprint Format.str_formatter r;
   Format.flush_str_formatter ()
+
+
+(* Compare two rules and explain the first difference
+   met. Formulas and expressions are compared for structural equality. *)
+exception Diff_result of string
+
+let compare_diff ?(cmp_funs=(=)) r1 r2 =
+  try
+    let eq, msg =
+      DiscreteRule.compare_diff ~cmp_funs r1.discrete r2.discrete in
+    if not eq then raise (Diff_result msg);
+    if List.sort Pervasives.compare r1.dynamics <>
+      List.sort Pervasives.compare r2.dynamics
+    then raise (Diff_result "Rule dynamics differ");
+    if List.sort Pervasives.compare r1.update <>
+      List.sort Pervasives.compare r2.update
+    then raise (Diff_result "Rule update functions differ");
+    if r1.inv <> r2.inv then raise (Diff_result "Rule invariants differ");
+    if r1.post <> r2.post then
+      raise (Diff_result "Rule postconditions differ");
+    true, "equal"
+  with Diff_result expl -> false, expl

Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/ContinuousRule.mli	2011-03-14 11:11:08 UTC (rev 1359)
@@ -88,3 +88,9 @@
   (int * int) list -> rule -> float -> (string * float) list ->
   (Structure.structure *
      float * ((string * string) * Term.term list) list) option
+
+(** Compare two rules and explain the first difference
+   met. Formulas and expressions are compared for structural equality. *)
+val compare_diff :
+  ?cmp_funs:(float -> float -> bool) ->
+  rule -> rule -> bool * string

Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -128,6 +128,42 @@
 
     );
 
+  "compare_diff" >::
+  (fun () ->
+    let discr =
+      "[a, b | R (a, b) | ] -> [c, d | R (c, d) | ] emb R with [c <- a, d <- b] " in
+    let s = discr ^ " pre true inv true post true" in
+    let signat = ["R", 2] in
+    let r1 = rule_of_str s signat [] "rule1" in
+    let r2 = rule_of_str s signat [] "rule2" in
+    assert_equal ~printer:(fun (_,x)->x) ~msg:"1. no continuous"
+      (true,"equal")
+      (ContinuousRule.compare_diff r1 r2);
+
+    let upd_eq = "  f(c) = 2. * f(a);\n  f(d) = f(b)\n" in
+    let s = discr ^ "\nupdate\n" ^ upd_eq ^ " pre true inv true post true" in
+    let r1 = rule_of_str s signat [] "rule2" in
+    let upd_eq = "  f(c) = 3. * f(a);\n  f(d) = f(b)\n" in
+    let s = discr ^ "\nupdate\n" ^ upd_eq ^ " pre true inv true post true" in
+    let r2 = rule_of_str s signat [] "rule3" in
+    assert_equal ~printer:(fun (_,x)->x) ~msg:"2. update"
+      (false,"Rule update functions differ")
+      (ContinuousRule.compare_diff r1 r2);
+
+    let upd_eq = "  f(c) = 2. * f(a);\n  f(d) = f(b)\n" in
+    let dyn_eq = "  f(a)' = (2. * f(a)) + t;\n  f(b)' = f(b)" in
+    let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
+      " pre true inv true post true" in
+    let r1 = rule_of_str s signat [] "rule4" in
+    let dyn_eq = "  f(a)' = (3. * f(a)) + t;\n  f(b)' = f(b)" in
+    let s = discr ^ "\ndynamics\n" ^ dyn_eq ^ "\nupdate\n" ^ upd_eq ^
+      " pre true inv true post true" in
+    let r2 = rule_of_str s signat [] "rule5" in
+    assert_equal ~printer:(fun (_,x)->x) ~msg:"3. dynamics"
+      (false,"Rule dynamics differ")
+      (ContinuousRule.compare_diff r1 r2);
+  );
+
 ]
 
 let a =

Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/DiscreteRule.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -933,7 +933,7 @@
   let opt_s =
     Aux.concat_map (fun rel ->
       try
-        let arity = signat rel in
+        let arity = List.assoc rel signat in
         let tups =
           List.map
             Array.of_list
@@ -965,7 +965,7 @@
       let rhs_struc, elem =
         Structure.add_new_elem rhs_struc ~name () in
       rhs_struc, (name, elem)::struc_elems)
-      (Structure.empty_structure (), []) struc_elems in
+      (Structure.empty_with_signat signat, []) struc_elems in
   let add_rels = List.fold_left (fun struc (rel, args) ->
     Structure.add_rel struc rel
       (Array.map (fun n -> List.assoc n struc_elems) args)) in
@@ -1040,8 +1040,8 @@
 
 let fprint_rule f r =
   Format.fprintf f "@[<1>%a@ ->@ %a"
-    Structure.fprint r.lhs_struc
-    Structure.fprint r.rhs_struc;
+    (Structure.fprint ~show_empty:false) r.lhs_struc
+    (Structure.fprint ~show_empty:false) r.rhs_struc;
   if r.emb_rels <> [] then
     Format.fprintf f "@ @[<1>emb@ %a@]"
       (Aux.fprint_sep_list "," Format.pp_print_string) r.emb_rels;
@@ -1089,3 +1089,58 @@
           rhs.Structure.elements []
     | Some rs ->
       List.map (fun (re,le) -> r_elem re, l_elem le) rs
+
+
+(* Compare two rules and explain the first difference
+   met. Preconditions are compared for structural equality. *)
+exception Diff_result of string
+
+let compare_diff ?(cmp_funs=(=)) r1 r2 =
+  try
+    let eq, msg =
+      Structure.compare_diff ~cmp_funs r1.lhs_struc r2.lhs_struc in
+    if not eq then raise (Diff_result (
+      "Rule LHS structures differ: "^msg));
+    let eq, msg =
+      Structure.compare_diff ~cmp_funs r1.rhs_struc r2.rhs_struc in
+    if not eq then raise (Diff_result (
+      "Rule RHS structures differ: "^msg));
+    let pre1 = FormulaOps.flatten_formula r1.pre in
+    let pre2 = FormulaOps.flatten_formula r2.pre in
+    if pre1 <> pre2 then raise (Diff_result (
+      Printf.sprintf "Rule preconditions differ:\n%s\n =/=\n%s"
+        (Formula.sprint pre1) (Formula.sprint pre2)));
+    let embs1 = Aux.list_diff r1.emb_rels r2.emb_rels in
+    if embs1 <> [] then raise (
+      Diff_result ("Relation "^List.hd embs1^
+                      " is embedded only in the first rule"));
+    let embs2 = Aux.list_diff r1.emb_rels r2.emb_rels in
+    if embs2 <> [] then raise (
+      Diff_result ("Relation "^List.hd embs2^
+                      " is embedded only in the second rule"));
+    (* enough to check that "the diagram commutes" in one direction... *)
+    List.iter (fun (rhs_e,lhs_e) ->
+      let lhs_n = Structure.elem_str r1.lhs_struc lhs_e in
+      let rhs_n = Structure.elem_str r1.rhs_struc rhs_e in
+      let rhs_e2 = Structure.find_elem r2.rhs_struc rhs_n in
+      (let try lhs_e2 = List.assoc rhs_e2 r2.rule_s in
+       let lhs_n2 = Structure.elem_str r2.lhs_struc lhs_e2 in
+       if lhs_n <> lhs_n2 then raise (Diff_result (
+         Printf.sprintf
+           "RHS element %s is mapped to LHS %s instead of %s in the second rule"
+           rhs_n lhs_n2 lhs_n))
+        with Not_found -> raise (Diff_result (
+          Printf.sprintf "Element %s is fresh only in the second rule"
+            rhs_n)))
+    ) r1.rule_s;
+    (* if we check the domain *)
+    List.iter (fun (rhs_e2,lhs_e2) ->
+      let rhs_n2 = Structure.elem_str r2.rhs_struc rhs_e2 in
+      let rhs_e1 = Structure.find_elem r1.rhs_struc rhs_n2 in
+      if not (List.mem_assoc rhs_e1 r1.rule_s)
+      then raise (Diff_result (
+        Printf.sprintf "RHS element %s is fresh only in the first rule"
+          rhs_n2))
+    ) r2.rule_s;
+    true, "equal"
+  with Diff_result expl -> false, expl

Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/DiscreteRule.mli	2011-03-14 11:11:08 UTC (rev 1359)
@@ -131,7 +131,7 @@
 val translate_from_precond :
   precond:Formula.formula -> add:(string * string array) list ->
   (* del:(string * string array) list -> *)
-  emb_rels:string list -> signat:(string -> int) ->
+  emb_rels:string list -> signat:(string * int) list ->
   struc_elems:string list -> rule
 
 (** {2 Printing.} *)
@@ -152,3 +152,9 @@
 val build_rule_s :
   ?rule_s:(string * string) list ->
   Structure.structure -> Structure.structure -> (int * int) list
+
+(** Compare two rules and explain the first difference
+    met. Preconditions are compared for structural equality. *)
+val compare_diff :
+  ?cmp_funs:(float -> float -> bool) ->
+  rule -> rule -> bool * string

Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -36,11 +36,11 @@
   "sprint: simple" >::
     (fun () ->
       let s=
-        "[a | P:1 {}; Q (a) | ] -> [b | P (b); Q:1 {} | ] emb Q with [b <- a]" in
+        "[a | Q (a) | ] -> [b | P (b) | ] emb Q with [b <- a]" in
       let r = rule_of_str ["Q",1;"P",1] s in
       assert_equal s ~printer:(fun x->x) (sprint_rule r);
 
-      let s="[a | P:1 {}; Q (a) | ] -> [a | P (a); Q:1 {} | ]" in
+      let s="[a | Q (a) | ] -> [a | P (a) | ]" in
       let r = rule_of_str ["Q",1;"P",1] s in
       assert_equal ~printer:(fun x->x) s (sprint_rule r);
     );
@@ -51,7 +51,7 @@
    D {(c, c); (c, a); (c, b); (b, a); (b, b)}; P {c; b}; Q {a; b};
    R {(c, c); (a, c); (a, b); (b, c); (b, b)}
   | f {b->3., a->2., c->4.}; g {a->1., c->5.}
- ] -> [b, c | D {(c, b); (c, c)}; P (b); Q:1 {}; R (c, c) | ] emb Q
+ ] -> [b, c | D {(c, b); (c, c)}; P (b); R (c, c) | ] emb Q
  with [c <- c, b <- a]" in
       let r = rule_of_str ["D",2;"R",2;"Q",1;"P",1] s in
       assert_equal ~printer:(fun x->x) s (sprint_rule r);
@@ -683,6 +683,44 @@
 	(rule_obj_str rule_obj);
 
     ); 
+
+  "compare_diff" >::
+    (fun () ->
+      let r1 = rule_of_str ["Q",1;"P",1]
+        "[a | P:1 {}; Q (a) | ] -> [b | P (b); Q:1 {} | ] emb Q with [b <- a]" in
+      let r2 = rule_of_str ["Q",1;"P",1]
+        "[a | Q (a) | ] -> [b | P (b) | ] emb Q with [b <- a]" in
+      assert_equal ~printer:(fun (_,x)->x)
+        (true,"equal")
+        (DiscreteRule.compare_diff r1 r2);
+
+      let r1 = rule_of_str ["Q",1;"P",1]
+        "[a | P (a); Q (a) | ] -> [b | P (b) | ] emb Q with [b <- a]" in
+      let r2 = rule_of_str ["Q",1;"P",1]
+        "[a | Q (a) | ] -> [b | P (b) | ] emb Q with [b <- a]" in
+      assert_equal ~printer:(fun (_,x)->x)
+        (false,"Rule LHS structures differ: Relation tuple P(a) not found in the second structure")
+        (DiscreteRule.compare_diff r1 r2);
+
+      let r1 = rule_of_str ["Q",1;"P",1]
+        "[a | Q (a) | ] -> [b | P (b) | ] emb Q with [b <- a]" in
+      let r2 = rule_of_str ["Q",1;"P",1]
+        "[a | Q (a) | ] -> [b | P (b) | ] emb P with [b <- a]" in
+      assert_equal ~printer:(fun (_,x)->x)
+        (false,"Relation Q is embedded only in the first rule")
+        (DiscreteRule.compare_diff r1 r2);
+
+      let r1 = rule_of_str ["Q",1;"P",1]
+        "[a,b | Q (a); P(b) | ] -> [b | P (b) | ] emb Q with [b <- a]" in
+      let r2 = rule_of_str ["Q",1;"P",1]
+        "[a,b | Q (a); P(b) | ] -> [b | P (b) | ] emb Q with [b <- b]" in
+      assert_equal ~printer:(fun (_,x)->x)
+        (false,
+         "RHS element b is mapped to LHS b instead of a in the second rule")
+        (DiscreteRule.compare_diff r1 r2);
+      
+    );
+
 ]
 
 let a =

Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/GGP/GDL.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -3382,8 +3382,7 @@
               rname
           );
           (* }}} *)
-          let signat rel =
-            Structure.StringMap.find rel struc.Structure.rel_signature in
+          let signat = Structure.rel_signature struc in
           let discrete =
             DiscreteRule.translate_from_precond ~precond
               ~add:rhs_pos ~emb_rels:fluents ~signat ~struc_elems in
@@ -3432,7 +3431,7 @@
   } in
      (* {{{ log entry *)
      (* *
-  let file = open_out "./GGP/tests/connect5-raw.toss" in
+  let file = open_out "./GGP/tests/breakthrough-raw.toss" in
   output_string file (Arena.state_str result);
   close_out file;
   * *)
@@ -3452,7 +3451,7 @@
     ) loc_noop_legal in
      (* {{{ log entry *)
      (* *
-  let file = open_out "./GGP/tests/connect5-simpl.toss" in
+  let file = open_out "./GGP/tests/breakthrough-simpl.toss" in
   output_string file (Arena.state_str result);
   close_out file;
   * *)
@@ -3550,8 +3549,7 @@
           (Formula.sprint precond)
       );
       (* }}} *)
-      let signat rel =
-        Structure.StringMap.find rel struc.Structure.rel_signature in
+      let signat = Structure.rel_signature struc in
       let rule =
         DiscreteRule.translate_from_precond ~precond ~add
           ~emb_rels:gdl.fluents ~signat ~struc_elems in

Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/GGP/GDLTest.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -5,6 +5,13 @@
   GDLParser.parse_game_description KIFLexer.lex
     (Lexing.from_string s)
 
+let state_of_file s =
+  let f = open_in s in
+  let res =
+    ArenaParser.parse_game_state Lexer.lex
+      (Lexing.from_channel f) in
+  res
+
 let load_rules fname =
   let f = open_in fname in
   let descr =
@@ -83,15 +90,16 @@
     (fun () ->
       let connect5 = load_rules "./GGP/examples/connect5.gdl" in
       let _, res = GDL.translate_game (Const "x") connect5 in
-      let goalf = open_in "./GGP/tests/connect5-simpl.toss" in
+      let goal = state_of_file "./GGP/tests/connect5-simpl.toss" in
       let resf = open_out "./GGP/tests/connect5-temp.toss" in
-      let goal_str = Aux.input_file goalf in
       let res_str = Arena.state_str res in
       output_string resf res_str;
-      close_in goalf; close_out resf;
-      assert_equal
-        ~msg:"GGP/examples/connect5.gdl to GGP/tests/connect5-simpl.toss, see GGP/tests/connect5-temp.toss"
-        goal_str res_str;
+      close_out resf;
+      let eq, msg = Arena.compare_diff goal res in
+      assert_bool
+        ("GGP/examples/connect5.gdl to GGP/tests/connect5-simpl.toss, \
+          see GGP/tests/connect5-temp.toss: "^msg)
+        eq;
       Sys.remove "./GGP/tests/connect5-temp.toss"
     );
   
@@ -99,15 +107,17 @@
     (fun () ->
       let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in
       let _, res = GDL.translate_game (Const "white") breakthrough in
-      let goalf = open_in "./GGP/tests/breakthrough-simpl.toss" in
+      let goal = state_of_file "./GGP/tests/breakthrough-simpl.toss" in
       let resf = open_out "./GGP/tests/breakthrough-temp.toss" in
-      let goal_str = Aux.input_file goalf in
       let res_str = Arena.state_str res in
       output_string resf res_str;
-      close_in goalf; close_out resf;
-      assert_equal
-        ~msg:"GGP/examples/breakthrough.gdl to GGP/tests/breakthrough-simpl.toss, see GGP/tests/breakthrough-temp.toss"
-        goal_str res_str;
+      close_out resf;
+      let eq, msg = Arena.compare_diff goal res in
+      assert_bool
+        ("GGP/examples/breakthrough.gdl to \
+          GGP/tests/breakthrough-simpl.toss, see
+          GGP/tests/breakthrough-temp.toss: "^msg)
+        eq;
       Sys.remove "./GGP/tests/breakthrough-temp.toss"
     );
 
@@ -136,5 +146,5 @@
   let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in
   let connect5 = load_rules "./GGP/examples/connect5.gdl" in
   let tictactoe = load_rules "./GGP/examples/tictactoe.gdl" in
-  let gdl_def, toss_def = GDL.translate_game (Const "x") connect5 in
+  let gdl_def, toss_def = GDL.translate_game (Const "white") breakthrough in
   ignore gdl_def; ignore connect5; ignore breakthrough; ignore tictactoe

Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/GGP/GameSimplTest.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -14,15 +14,16 @@
     (fun () ->
       let connect5 = state_of_file "./GGP/tests/connect5-raw.toss" in
       let res = GameSimpl.simplify connect5 in
-      let goalf = open_in "./GGP/tests/connect5-simpl.toss" in
+      let goal = state_of_file "./GGP/tests/connect5-simpl.toss" in
       let resf = open_out "./GGP/tests/connect5-temp.toss" in
-      let goal_str = Aux.input_file goalf in
       let res_str = Arena.state_str res in
       output_string resf res_str;
-      close_in goalf; close_out resf;
-      assert_equal
-        ~msg:"tests/connect5-raw.toss to tests/connect5-simpl.toss, see GGP/tests/connect5-temp.toss"
-        goal_str 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"
     );
   
@@ -30,15 +31,16 @@
     (fun () ->
       let breakthrough = state_of_file "./GGP/tests/breakthrough-raw.toss" in
       let res = GameSimpl.simplify breakthrough in
-      let goalf = open_in "./GGP/tests/breakthrough-simpl.toss" in
+      let goal = state_of_file "./GGP/tests/breakthrough-simpl.toss" in
       let resf = open_out "./GGP/tests/breakthrough-temp.toss" in
-      let goal_str = Aux.input_file goalf in
       let res_str = Arena.state_str res in
       output_string resf res_str;
-      close_in goalf; close_out resf;
-      assert_equal
-        ~msg:"tests/breakthrough-raw.toss to tests/breakthrough-simpl.toss, see GGP/tests/breakthrough-temp.toss"
-        goal_str 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/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Solver/Solver.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -142,8 +142,9 @@
 	  if List.exists (fun v -> List.mem v aset_vars) vl then 
 	    let asg_s = AssignmentSet.str aset in
 	    let form_s = Formula.str (Ex (vl, phi)) in
-	    let msg_s = "solver: multiple vars?\n  "^ asg_s ^ "\n  "^ form_s in
-	    (* failwith msg_s *) Any
+	    (*let msg_s =
+              "solver: multiple vars?\n  "^ asg_s ^ "\n  "^ form_s in
+	    failwith msg_s *) Any
 	  else aset in
         let phi_asgn = eval model elems in_aset phi in
         report (join aset (project_list elems phi_asgn vl))
@@ -153,8 +154,9 @@
 	  if List.exists (fun v -> List.mem v aset_vars) vl then 
 	    let asg_s = AssignmentSet.str aset in
 	    let form_s = Formula.str (Ex (vl, phi)) in
-	    let msg_s = "solver: multiple vars?\n  "^ asg_s ^ "\n  "^ form_s in
-	    (* failwith msg_s *) Any
+	    (*let msg_s =
+              "solver: multiple vars?\n  "^ asg_s ^ "\n  "^ form_s in
+	    failwith msg_s *) Any
 	  else aset in
         let phi_asgn = eval model elems in_aset phi in
         report (join aset (universal_list elems phi_asgn vl))

Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Solver/Structure.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -483,13 +483,15 @@
 
 (* Print the structure [struc] as string, in extensive form (not using
    condensed representations like boards). *)
-let ext_str struc = 
+let ext_str ?(show_empty=true) struc = 
   let elem_s = 
     String.concat ", "
       (List.map (elem_str struc) (Elems.elements struc.elements)) in
   let (rel_s, fun_s) = (ref "", ref "") in
     StringMap.iter
-      (fun rn ts -> rel_s := !rel_s ^ "; " ^ rel_str struc rn ts)
+      (fun rn ts ->
+        if show_empty || not (Tuples.is_empty ts) then
+          rel_s := !rel_s ^ "; " ^ rel_str struc rn ts)
       struc.relations;
     StringMap.iter
       (fun fn vals -> fun_s := !fun_s ^ "; " ^ fun_str struc fn vals)
@@ -998,9 +1000,9 @@
           board ^ "\"",
         gc_elems !ret
 
-let str struc =
+let str ?(show_empty=true) struc =
   let board, struc = board_to_string struc in
-  ext_str struc ^ (if board = "" then "" else " " ^ board)
+  ext_str ~show_empty struc ^ (if board = "" then "" else " " ^ board)
 
 let fprint_rel ?(print_arity=true) struc f (rel_name, ts) =
   if print_arity && Tuples.is_empty ts then
@@ -1023,9 +1025,12 @@
   Format.fprintf f "@[<1>%s@ {@,@[<1>%a@]@,}@]" fun_name
     (Aux.fprint_sep_list "," update) elements
 
-let fprint_ext_structure f struc =
+let fprint_ext_structure ~show_empty f struc =
   let rels =
-    StringMap.fold (fun k v acc -> (k,v)::acc) struc.relations [] in
+    StringMap.fold (fun k v acc ->
+      if show_empty || not (Tuples.is_empty v) then
+        (k,v)::acc
+      else acc) struc.relations [] in
   let funs =
     StringMap.fold (fun k v acc -> (k,v)::acc) struc.functions [] in
   let rels = List.rev rels and funs = List.rev funs in
@@ -1037,19 +1042,20 @@
     (Aux.fprint_sep_list ";" (fprint_rel struc)) rels
     (Aux.fprint_sep_list ";" (fprint_fun struc)) funs
 
-let fprint f struc =
+let fprint ~show_empty f struc =
   let board, struc = board_to_string struc in
-  if board = "" then fprint_ext_structure f struc
+  if board = "" then fprint_ext_structure ~show_empty f struc
   else
     (* no line break after the closing bracket to stress that it is
        the same structure; no formatter breaks inside the board *)
     Format.fprintf f "%a @[<h 1>%s@]"
-      fprint_ext_structure struc board
+      (fprint_ext_structure ~show_empty) struc board
 
-let print struc = fprint Format.std_formatter struc
-let sprint struc =
+let print ?(show_empty=true) struc =
+  fprint ~show_empty Format.std_formatter struc
+let sprint ?(show_empty=true) struc =
   ignore (Format.flush_str_formatter ());
-  Format.fprintf Format.str_formatter "%a" fprint struc;
+  Format.fprintf Format.str_formatter "%a" (fprint ~show_empty) struc;
   Format.flush_str_formatter ()
     
 let board_elem_coords name =
@@ -1066,6 +1072,56 @@
     "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in
   Char.escaped col_index.[col-1] ^ string_of_int row
 
+(* Compare two structures and explain the first difference met. *)
+exception Diff_result of string
+let contained_in cmp_funs s1 s2 other =
+  let map_elem e1 =
+    let name = elem_str s1 e1 in
+    try find_elem s2 name
+    with Not_found -> raise (Diff_result (
+      "Element "^name^" not found in the "^other^" structure")) in
+  Elems.iter (fun e -> ignore (map_elem e)) s1.elements;
+  StringMap.iter (fun rel tups ->
+    (let try tups2 = StringMap.find rel s2.relations in
+     Tuples.iter (fun tup ->
+       let tup2 = Array.map map_elem tup in
+       if not (Tuples.mem tup2 tups2)
+       then raise (Diff_result (
+         Printf.sprintf
+           "Relation tuple %s(%s) not found in the %s structure"
+           rel (String.concat ", "
+                  (List.map (elem_str s1) (Array.to_list tup)))
+           other))
+     ) tups
+     with Not_found -> raise (Diff_result (
+       "Relation "^rel^" not found in the "^other^" structure"))
+    )) s1.relations;
+  StringMap.iter (fun fn vals ->
+    (let try vals2 = StringMap.find fn s2.functions in
+     IntMap.iter (fun e v ->
+       let v2 = IntMap.find (map_elem e) vals2 in
+       try
+         if not (cmp_funs v v2)
+         then raise (Diff_result (
+           Printf.sprintf
+             "Function %s(%s)->%F is %F instead in the %s structure"
+             fn (elem_str s1 e) v v2 other))
+       with Not_found -> raise (Diff_result (
+         Printf.sprintf
+           "Function %s(%s) not found in the second structure"
+           fn (elem_str s1 e)))
+     ) vals
+     with Not_found -> raise (Diff_result (
+       "Function "^fn^" not found in the "^other^" structure"))
+    )) s1.functions
+
+let compare_diff ?(cmp_funs=(=)) s1 s2 =
+  try
+    contained_in cmp_funs s1 s2 "second";
+    contained_in cmp_funs s2 s1 "first";
+    true, "equal"
+  with Diff_result expl -> false, expl
+
 (* -------------------- PARSER HELPERS -------------------- *)
 
 let is_uppercase c = c >= 'A' && c <= 'Z'

Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Solver/Structure.mli	2011-03-14 11:11:08 UTC (rev 1359)
@@ -82,11 +82,12 @@
 val sig_str : structure -> string
 
 (** Print the structure [struc] as string, in extensive form (not using
-   condensed representations like boards). *)
-val ext_str : structure -> string
+    condensed representations like boards). If [show_empty] is false,
+    do not print the signatures of empty relations. *)
+val ext_str : ?show_empty:bool -> structure -> string
 
 (** Print the structure [struc] as string. *)
-val str : structure -> string
+val str : ?show_empty:bool -> structure -> string
 
 
 val fprint_rel :
@@ -97,14 +98,14 @@
   structure -> Format.formatter -> string * float IntMap.t -> unit
 
 val fprint_ext_structure :
-  Format.formatter -> structure -> unit
+  show_empty:bool -> Format.formatter -> structure -> unit
 
 val fprint :
-  Format.formatter -> structure -> unit
+  show_empty:bool -> Format.formatter -> structure -> unit
 
-val print : structure -> unit
+val print : ?show_empty:bool -> structure -> unit
 
-val sprint : structure -> string
+val sprint : ?show_empty:bool -> structure -> string
 
 (** Coordinates, column first, of a board element name. Raises
     [Not_found] if the name is not of proper format. *)
@@ -114,6 +115,11 @@
     [Not_found] if the coordinates are out of bounds. *)
 val board_coords_name : int * int -> string
 
+(** Compare two structures and explain the first difference met. *)
+val compare_diff :
+  ?cmp_funs:(float -> float -> bool) ->
+  structure -> structure -> bool * string
+
 (** {2 Adding elements possibly with string names} *)
 
 

Modified: trunk/Toss/Solver/StructureTest.ml
===================================================================
--- trunk/Toss/Solver/StructureTest.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/Solver/StructureTest.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -379,6 +379,50 @@
 ]"
 
     );
+
+  "compare_diff" >::
+    (fun () ->
+      assert_equal ~printer:(fun (_,x)->x)
+        (true, "equal")
+        (compare_diff
+           (struc_of_string "[a,b | R(a,b) | ]")
+           (struc_of_string "[a,b | R(a,b) | ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (true, "equal")
+        (compare_diff
+           (struc_of_string "[a,b,c | R(a,b) | f {a->2.}; g{b->3.} ]")
+           (struc_of_string "[a,b,c | R(a,b) | f {a->2.}; g{b->3.} ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (false, "Relation tuple R(a, b) not found in the second structure")
+        (compare_diff
+           (struc_of_string "[a,b | R(a,b) | ]")
+           (struc_of_string "[a,b | R(b,a) | ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (false, "Function g(b)->3. is 4. instead in the second structure")
+        (compare_diff
+           (struc_of_string "[a,b,c | R(a,b) | f {a->2.}; g{b->3.} ]")
+           (struc_of_string "[a,b,c | R(a,b) | f {a->2.}; g{b->4.} ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (false, "Relation R not found in the second structure")
+        (compare_diff
+           (struc_of_string "[a,b | R(a,b) | ]")
+           (struc_of_string "[a,b | C(a,b) | ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (false, "Element b not found in the second structure")
+        (compare_diff
+           (struc_of_string "[a,b | P(a) | ]")
+           (struc_of_string "[a | P(a) | ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (false, "Relation C not found in the first structure")
+        (compare_diff
+           (struc_of_string "[a,b | R(a,b) | ]")
+           (struc_of_string "[a,b | R(a,b); C(a,b) | ]"));
+      assert_equal ~printer:(fun (_,x)->x)
+        (false, "Relation tuple R(a, c) not found in the first structure")
+        (compare_diff
+           (struc_of_string "[a,b,c | R(a,b) | ]")
+           (struc_of_string "[a,b,c | R{(a,b); (a,c)} | ]"));
+    );
 ]
 
 

Modified: trunk/Toss/caml_extensions/pa_backtrace.ml
===================================================================
--- trunk/Toss/caml_extensions/pa_backtrace.ml	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/caml_extensions/pa_backtrace.ml	2011-03-14 11:11:08 UTC (rev 1359)
@@ -16,10 +16,10 @@
       [ "backtrace"; "("; e = expr ; ")" ->
           <:expr< (try $e$ with exn ->
 		       ( print_endline "Backtracing exception:";
-			 List.map print_endline 
+			 List.iter print_endline 
 		           (Str.split (Str.regexp_string "\\\\n") (Printexc.to_string exn));
                          print_endline "Exception backtrace:";
-			 List.map print_endline 
+			 List.iter print_endline 
 		           (Str.split (Str.regexp_string "\\\\n") (Printexc.get_backtrace ()));
 			 raise exn )
                   ) >>

Modified: trunk/Toss/examples/rewriting_example.toss
===================================================================
--- trunk/Toss/examples/rewriting_example.toss	2011-03-14 03:24:33 UTC (rev 1358)
+++ trunk/Toss/examples/rewriting_example.toss	2011-03-14 11:11:08 UTC (rev 1359)
@@ -1,6 +1,6 @@
 PLAYERS 1, 2
 RULE Rewrite:
- [1, 2 | R (1, 2); S:2 {} |
+ [1, 2 | R (1, 2) |
     vx {2->0., 1->0.}; vy {2->0., 1->0.}; x {2->12.1, 1->-56.1};
     y {2->-16.5, 1->-19.8}
   ] ->


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.