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

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

Revision: 1525
          http://toss.svn.sourceforge.net/toss/?rev=1525&view=rev
Author:   lukstafi
Date:     2011-08-04 16:40:12 +0000 (Thu, 04 Aug 2011)

Log Message:
-----------
GDL translation fixing: bug expanding player variables.

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/TranslateGame.ml
    trunk/Toss/GGP/TranslateGame.mli
    trunk/Toss/GGP/TranslateGameTest.ml
    trunk/Toss/www/reference/reference.tex

Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/Formula/Aux.ml	2011-08-04 16:40:12 UTC (rev 1525)
@@ -193,6 +193,11 @@
         fold_left_try f (f accu a) l
       with Not_found -> fold_left_try f accu l
 
+let rec power dom img =
+  List.fold_right (fun v sbs ->
+    concat_map (fun e -> List.map (fun sb -> (v,e)::sb) sbs) img)
+    dom [[]]
+
 let product l =
   List.fold_right (fun set prod ->
     concat_map (fun el -> List.map (fun tup -> el::tup) prod) set)

Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/Formula/Aux.mli	2011-08-04 16:40:12 UTC (rev 1525)
@@ -125,6 +125,10 @@
     [Not_found]. *)
 val fold_left_try : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
 
+(** [power dom img] generates all functions with domain [dom] and
+    image [img], as graphs. *)
+val power : 'a list -> 'b list -> ('a * 'b) list list
+
 (** Cartesian product of lists. Not tail recursive. *)
 val product : 'a list list -> 'a list list
 

Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/GDL.ml	2011-08-04 16:40:12 UTC (rev 1525)
@@ -313,10 +313,7 @@
       " " ^ neg_rel_atoms_str neg_body ^ ")"
 
 let def_str (rel, branches) =
-  String.concat "\n" (List.map (fun (args, body, neg_body) ->
-    "("^ rel_atom_str (rel, args) ^ " <= " ^ rel_atoms_str body ^
-      " " ^ neg_rel_atoms_str neg_body)
-  branches)
+  String.concat "\n" (List.map (branch_str rel) branches)
 
 let sb_str sb =
   String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
@@ -718,7 +715,8 @@
     | "legal", [|Var v; _|] -> Some v
     | _ -> None) rels
 
-
+(* Expand players, and also remove the "role" atoms since they become
+   redundant. *)
 let expand_players clauses =
   let players =
     Aux.map_some (function
@@ -731,8 +729,7 @@
       player_vars_of (List.map rel_of_atom (atoms_of_clause clause)) in
     if plvars = [] then [clause]
     else
-      let sbs = List.map (fun v ->
-        List.map (fun pl -> v, pl) players) plvars in
+      let sbs = Aux.power plvars players in
       List.map (fun sb -> subst_clause sb clause) sbs in
   Aux.concat_map exp_clause clauses
 

Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/GDL.mli	2011-08-04 16:40:12 UTC (rev 1525)
@@ -104,6 +104,7 @@
 val term_arities : term -> (string * int) list
 
 val rel_atom_str : rel_atom -> string
+val def_str : string * def_branch list -> string
 
 (** {3 GDL whole-game operations.}
 

Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/GDLTest.ml	2011-08-04 16:40:12 UTC (rev 1525)
@@ -156,13 +156,28 @@
 (does o (mark b a)) (does x noop)"])
     ); 
 
+  "expand players connect5" >::
+    (fun () ->
+      let descr = load_rules ("./GGP/examples/connect5.gdl") in
+      let clauses = expand_players descr in
+      let legal_def = List.assoc "legal"
+        (GDL.defs_of_rules
+           (Aux.concat_map GDL.rules_of_clause clauses)) in
+      assert_equal ~msg:"expanded legal branches" ~printer:(fun x->x)
+        "((legal x (mark ?x ?y)) <= (true (control x)) (true (cell ?x ?y b)) )
+((legal o (mark ?x ?y)) <= (true (control o)) (true (cell ?x ?y b)) )
+((legal x noop) <= (role x) (not (true (control x))))
+((legal o noop) <= (role o) (not (true (control o))))"
+        (GDL.def_str ("legal", legal_def));
+    );
+
   "playout connect5" >::
     (fun () ->
       let descr = load_rules ("./GGP/examples/connect5.gdl") in
-
+      let clauses = expand_players descr in
       let _, _, _, _, (rand_actions, _) =
         GDL.playout ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
-          10 (Aux.concat_map GDL.rules_of_clause descr) in
+          10 (Aux.concat_map GDL.rules_of_clause clauses) in
       let noop_actions = Aux.take_n 9
         (List.map
            (Aux.map_some

Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/TranslateGame.ml	2011-08-04 16:40:12 UTC (rev 1525)
@@ -20,8 +20,8 @@
     [nonerasing_frame_wave] is set to [true].) *)
 let nonerasing_frame_wave = ref true
 
-(** Limit on the number of steps for aggregate playout. *)
-let agg_playout_horizon = ref 30
+(** Limit on the number of steps for aggregate and random playouts. *)
+let playout_horizon = ref 30
 
 (** Use "true" atoms while computing rule cases. *)
 let split_on_state_atoms = ref false
@@ -188,7 +188,7 @@
   let rules = Aux.concat_map rules_of_clause clauses in
   let stable_rel_defs, nonstable_rel_defs,
     stable_base, init_state, (agg_actions, agg_states) =
-    playout ~aggregate:true players !agg_playout_horizon rules in
+    playout ~aggregate:true players !playout_horizon rules in
   let stable_rels = Aux.unique_sorted
     (List.map (fun ((rel,_),_,_)->rel) stable_rel_defs) in
   let nonstable_rels = Aux.unique_sorted
@@ -632,8 +632,25 @@
    for players in the locations. *)
 let check_turn_based players rules =
   let check_one_playout () =
-    let _, _, _, _, (playout_actions, _) =
-      playout ~aggregate:false players !agg_playout_horizon rules in
+    (* {{{ log entry *)
+    if !debug_level > 2 then (
+      Printf.printf "check_turn_based: starting check_one_playout\n"
+    );
+    (* }}} *)
+    let _, _, _, _, (playout_actions, playout_states) =
+      playout ~aggregate:false players !playout_horizon rules in
+    (* {{{ log entry *)
+    if !debug_level > 3 then (
+      let actions = List.map
+        (List.map (fun a->"does", a)) playout_actions in      
+      let res =
+        String.concat ";\n" (List.map (fun step -> String.concat " "
+          (List.map GDL.rel_atom_str step)) actions) in
+      Printf.printf
+        "check_turn_based: no of states: %d, playout actions:\n%s\n%!"
+        (List.length playout_states) res
+    );
+    (* }}} *)
     let noop_cands = List.map (fun actions ->
       let actions = Aux.map_reduce
         (function [|player; action|] -> player, action
@@ -648,8 +665,16 @@
           if accu = None then Some player
           else raise Not_turn_based
         | _, Some _ -> accu) None noop_cands) noop_cands in
+    (* {{{ log entry *)
+    if !debug_level > 1 then (
+      Printf.printf "check_turn_based: control player pre-cands:\n%s\n%!"
+        (String.concat " "
+           (List.map (function Some t->term_str t | None->"None")
+              control_cands))
+    );
+    (* }}} *)
     let noop_cands = List.map Aux.collect noop_cands in
-  (* throw in players with (multiple) constant actions *)
+    (* throw in players with (multiple) constant actions *)
     let control_noop_cands = List.map2 (fun ccand noops ->
       let nccands, noops = Aux.partition_map
         (function player, [] -> assert false
@@ -664,29 +689,29 @@
       List.split control_noop_cands in
     (* {{{ log entry *)
     if !debug_level > 1 then (
-      Printf.printf "check_turn_based: control player cands %s\n%!"
+      Printf.printf "check_turn_based: control player cands:\n%s\n%!"
         (String.concat " "
            (List.map (function Some t->term_str t | None->"None")
               control_cands))
     );
     (* }}} *)
-  (* 2b *)
+    (* 2b *)
     let loc_players = find_cycle control_cands in
-  (* {{{ log entry *)
+    (* {{{ log entry *)
     if !debug_level > 0 then (
       Printf.printf "check_turn_based: location players %s\n%!"
         (String.concat " "
            (List.map (function Some t->term_str t | None->"None")
               loc_players))
     );
-  (* }}} *)
+    (* }}} *)
     let loc_players = Array.of_list
       (List.map (function Some p -> p | None -> players.(0))
          loc_players) in
     let loc_n = Array.length loc_players in
     let players_n = Array.length players in
     let find_player p = Aux.array_argfind (fun x -> x = p) players in
-  (* noop actions of a player in a location *)
+    (* noop actions of a player in a location *)
     let loc_noops =
       let i = ref 0 in
       let noops = ref noop_cands in
@@ -698,9 +723,9 @@
             if loc_noops.(!i).(p_i) = None
             then loc_noops.(!i).(p_i) <- noop
             else if loc_noops.(!i).(p_i) <> noop
-          (* moves are not simultaneous, but different [noop] actions
-             are used by the same player -- can be resolved by
-             introducing separate locations for each noop case *)
+            (* moves are not simultaneous, but different [noop] actions
+               are used by the same player -- can be resolved by
+               introducing separate locations for each noop case *)
             then raise Not_turn_based)
           (List.hd !noops);
         incr i; if !i = loc_n then i := 0;

Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/TranslateGame.mli	2011-08-04 16:40:12 UTC (rev 1525)
@@ -1,6 +1,9 @@
 (** Local level of logging. *)
 val debug_level : int ref
 
+(** Limit on plys for both aggregate and random playouts. *)
+val playout_horizon : int 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-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/GGP/TranslateGameTest.ml	2011-08-04 16:40:12 UTC (rev 1525)
@@ -171,7 +171,7 @@
 ]
 
 let a () =
-  (* GDL.debug_level := 2; *)
+  GDL.debug_level := 2;
   TranslateGame.debug_level := 4;
   GameSimpl.debug_level := 4;
   (* DiscreteRule.debug_level := 4; *)

Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex	2011-08-04 03:58:35 UTC (rev 1524)
+++ trunk/Toss/www/reference/reference.tex	2011-08-04 16:40:12 UTC (rev 1525)
@@ -1764,11 +1764,13 @@
 We determine which clauses are frame clauses prior to partitioning
 into the rule clauses and computing the substitution
 $\sigma_{\ol{\calC},\ol{\calN}}$ -- at the point where fluent paths
-are computed. It is unclear which wave clauses should be considered
-frame clauses -- we optimistically assume that all wave clauses not
-depending on player actions (\ie not containing \texttt{does}) are
-frame clauses (and in the current implementation we ignore frame-wave
-clauses as they do not provide useful erasure clauses).
+are computed. It is difficult to establish which wave clauses should
+be considered frame clauses. In the current implementation, we
+optimistically assume that all wave clauses not depending on player
+actions (\ie not containing \texttt{does}) are frame clauses (and
+currently we ignore frame-wave clauses as they do not provide useful
+erasure clauses). In the future, we might perform deeper checking as
+to which wave clauses are frame clauses.
 
 From the frame clauses in $\sigma_{\ol{\calC}, \ol{\calN}}(\calN_1), \dots,
 \sigma_{\ol{\calC}, \ol{\calN}}(\calN_m)$, we select subsets $J$


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