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

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

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__BLANK_", "cell_1_1__BLANK_";
+          "control__BLANK_", "control__BLANK_"]
+        ~loc1_noop:"noop" ~loc1_move:"(mark 1 1)";
   (* failwith "tested"; *)
   ()
 
@@ -399,15 +409,16 @@
     DiscreteRule.debug_level := discreterule_dl);
   TranslateGame.generate_test_case := None
 
-let a () =
+let a =
   (* regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer"; *)
+  (* regenerate ~debug:false ~game_name:"tictactoe-other" ~player:"xPLAYER"; *)
   (* regenerate ~debug:false ~game_name:"connect5" ~player:"x"; *)
   (* regenerate ~debug:false ~game_name:"breakthrough" ~player:"white"; *)
   (* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
   (* regenerate ~debug:false ~game_name:"connect4" ~player:"white"; *)
-  (* regenerate ~debug:false ~game_name:"2player_normal_form_2010" ~player:"row"; *)
-  regenerate ~debug:true ~game_name:"pacman3p" ~player:"pacman";
-  (* failwith "generated"; *)
+  regenerate ~debug:false ~game_name:"2player_normal_form_2010" ~player:"row";
+  (* regenerate ~debug:true ~game_name:"pacman3p" ~player:"pacman"; *)
+  failwith "generated";
   ()
 
 let translate_file fname timeout =

Modified: trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss	2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/tests/2player_normal_form_2010-raw.toss	2011-10-20 19:22:44 UTC (rev 1607)
@@ -46,7 +46,7 @@
      (did__BLANK___BLANK_(did__BLANK__m1) and val___BLANK_(val__r1) and
       val___BLANK_(val__r2) and reward(did__BLANK__m1, did__BLANK__m2,
       val__r1, val__r2)))
-RULE Environment:
+RULE environment:
  [synch_control_ |
     _opt_did_0column (synch_control_); _opt_did_0row (synch_control_);
     column__SYNC (synch_control_); row__SYNC (synch_control_);
@@ -55,7 +55,7 @@
   ] -> [synch_control_ |  | ]
   emb row__SYNC, column__SYNC, did_0column, did_0row
 LOC 0 {
-  PLAYER environment { PAYOFF 0. MOVES [Environment -> 0] }
+  PLAYER environment { PAYOFF 0. MOVES [environment -> 0] }
   PLAYER row {
   PAYOFF
    10. *

Modified: trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss	2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/GGP/tests/2player_normal_form_2010-simpl.toss	2011-10-20 19:22:44 UTC (rev 1607)
@@ -44,7 +44,7 @@
      (did__BLANK___BLANK_(did__BLANK__m1) and val___BLANK_(val__r1) and
       val___BLANK_(val__r2) and reward(did__BLANK__m1, did__BLANK__m2,
       val__r1, val__r2)))
-RULE Environment:
+RULE environment:
  [synch_control_ |
     _opt_did_0column (synch_control_); _opt_did_0row (synch_control_);
     column__SYNC (synch_control_); row__SYNC (synch_control_);
@@ -53,7 +53,7 @@
   ] -> [synch_control_ |  | ]
   emb column__SYNC, did_0column, did_0row, row__SYNC
 LOC 0 {
-  PLAYER environment { PAYOFF 0. MOVES [Environment -> 0] }
+  PLAYER environment { PAYOFF 0. MOVES [environment -> 0] }
   PLAYER row {
   PAYOFF
    10. *

Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml	2011-10-19 22:58:56 UTC (rev 1606)
+++ trunk/Toss/Solver/Solver.ml	2011-10-20 19:22:44 UTC (rev 1607)
@@ -240,13 +240,8 @@
         let e = List.assoc v assgn in
           Poly.Const (Structure.fun_val model s e)
        with Not_found ->
-         Printf.printf "eval_expr: Fun=%s; v=%s; %!" s (var_str v);
-         let e = List.assoc v assgn in
-         Printf.printf "e=%d; e name=%s; %!" e
-           (Structure.elem_name model e);
-         Printf.printf "fun_val=%f\n%!" (Structure.fun_val model s e);
-         failwith "solver error"
-      )
+         (* TODO: handling partial functions, remove this comment if OK *)
+         Poly.Const nan)
     | Char phi -> (
         let make_fo_asg asg (v, e) = FO (v, [(e, asg)]) in
         let fo_aset = List.fold_left make_fo_asg Any assgn in

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