toss-devel-svn Mailing List for Toss (Page 10)

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Revision: 1524
          http://toss.svn.sourceforge.net/toss/?rev=1524&view=rev
Author:   lukstafi
Date:     2011-08-04 03:58:35 +0000 (Thu, 04 Aug 2011)

Log Message:
-----------
GDL translation bugfixing: detect turn based games using random playouts (minor commit).

Modified Paths:
--------------
    trunk/Toss/GGP/GDL.ml
    trunk/Toss/GGP/GDLTest.ml
    trunk/Toss/GGP/TranslateGame.ml
    trunk/Toss/GGP/TranslateGameTest.ml
    trunk/Toss/www/reference/reference.tex

Modified: trunk/Toss/GGP/GDL.ml
===================================================================

--- trunk/Toss/GGP/GDL.ml	2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/GDL.ml	2011-08-04 03:58:35 UTC (rev 1524)
@@ -577,14 +577,15 @@
     raise Playout_over)
   else
     let step = saturate (does @ base) rules in
-    let step = Aux.map_some (function ("next", [|arg|]) -> Some arg
-      | _ -> None) step in
+    let step_state = Aux.map_some
+      (function ("next", [|arg|]) -> Some arg
+        | _ -> None) step in
     if !playout_fixpoint &&           (* fixpoint reached *)
       List.for_all (function
         | Func (_,[|arg|]) when
             Aux.array_existsi (fun _ player -> arg=player) players -> true
         | term -> List.mem term current
-      ) step
+      ) step_state
     then (
       (* {{{ log entry *)
       if !debug_level > 0 then (
@@ -592,8 +593,17 @@
       );
       (* }}} *)
       raise Playout_over)
+    else if not aggregate &&            (* terminal position reached *)
+        List.mem_assoc "terminal" step
+    then (
+      (* {{{ log entry *)
+      if !debug_level > 0 then (
+        Printf.printf "GDL.ply: playout over due to terminal position\n%!";
+      );
+      (* }}} *)
+      raise Playout_over)
     else
-      List.map snd does, step
+      List.map snd does, step_state
 
 (* Besides the playout, also return the separation of rules
    into static and dynamic. Note that the list of playout states is

Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml	2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/GDLTest.ml	2011-08-04 03:58:35 UTC (rev 1524)
@@ -23,7 +23,7 @@
   let descr =
     GDLParser.parse_game_description KIFLexer.lex
       (Lexing.from_channel f) in
-  (* List.map GDL.rule_of_entry *) descr
+  descr
 
 let emb_str (game, state) (rname, emb) =
   let r = List.assoc rname game.Arena.rules in
@@ -104,7 +104,7 @@
            (List.map GDL.rel_atom_str res));
     );
 
-  "playout" >::
+  "playout simple" >::
     (fun () ->
       let descr = parse_game_descr
         "
@@ -156,6 +156,27 @@
 (does o (mark b a)) (does x noop)"])
     ); 
 
+  "playout connect5" >::
+    (fun () ->
+      let descr = load_rules ("./GGP/examples/connect5.gdl") in
+
+      let _, _, _, _, (rand_actions, _) =
+        GDL.playout ~aggregate:false [|GDL.Const "x"; GDL.Const "o"|]
+          10 (Aux.concat_map GDL.rules_of_clause descr) in
+      let noop_actions = Aux.take_n 9
+        (List.map
+           (Aux.map_some
+              (function [|player; Const "noop"|] -> Some player
+                | _ -> None)) rand_actions) in
+      let res =
+        String.concat "; "
+          (List.map (fun pacts -> String.concat ", "
+            (List.map term_str pacts)) noop_actions) in
+      assert_equal ~msg:"connect5 noop moves by players"
+         ~printer:(fun x->x)
+        "o; x; o; x; o; x; o; x; o" res;
+    ); 
+
 ]
 
 let exec = Aux.run_test_if_target "GDLTest" tests

Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml	2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/TranslateGame.ml	2011-08-04 03:58:35 UTC (rev 1524)
@@ -283,6 +283,7 @@
   let elem_term_map = Aux.intmap_of_assoc
     (List.map (fun e ->
       Structure.find_elem struc (term_to_name e), e) element_reps) in
+  players, rules,
   next_clauses, f_paths, m_paths, mask_reps, defined_rels,
   !stable_rels, !fluents,
   stable_base, init_state, struc, agg_actions, elem_term_map
@@ -629,73 +630,90 @@
 (* Check if game is turn based and return the player cycle if it is,
    otherwise rise [Not_turn_based]. Also return the [noop] actions
    for players in the locations. *)
-let check_turn_based players agg_actions =
-  let noop_cands = List.map (fun actions ->
-    let actions = Aux.map_reduce
-      (function [|player; action|] -> player, action
-        | _ -> assert false) (fun y x->x::y) [] actions in
-    List.map (function
-      | player, [Const _ as noop] -> player, Some noop
-      | player, _ -> player, None) actions
-  ) agg_actions in
-  let control_cands = List.map (fun noop_cands ->
-    List.fold_left (fun accu -> function
-      | player, None ->
-        if accu = None then Some player
-        else raise Not_turn_based
-      | _, Some _ -> accu) None noop_cands) noop_cands in
-  let noop_cands = List.map Aux.collect noop_cands in
+let check_turn_based players rules =
+  let check_one_playout () =
+    let _, _, _, _, (playout_actions, _) =
+      playout ~aggregate:false players !agg_playout_horizon rules in
+    let noop_cands = List.map (fun actions ->
+      let actions = Aux.map_reduce
+        (function [|player; action|] -> player, action
+          | _ -> assert false) (fun y x->x::y) [] actions in
+      List.map (function
+        | player, [Const _ as noop] -> player, Some noop
+        | player, _ -> player, None) actions
+    ) playout_actions in
+    let control_cands = List.map (fun noop_cands ->
+      List.fold_left (fun accu -> function
+        | player, None ->
+          if accu = None then Some player
+          else raise Not_turn_based
+        | _, Some _ -> accu) None noop_cands) noop_cands in
+    let noop_cands = List.map Aux.collect noop_cands in
   (* 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
-        | player, [noop] -> Aux.Right (player, noop)
-        | player, more_actions -> Aux.Left player) noops in
-    match ccand, nccands with
-      | None, [player] -> Some player, noops
-      | Some _, [] -> ccand, noops
-      | _ -> raise Not_turn_based
-  ) control_cands noop_cands in
-  let control_cands, noop_cands =
-    List.split control_noop_cands in
+    let control_noop_cands = List.map2 (fun ccand noops ->
+      let nccands, noops = Aux.partition_map
+        (function player, [] -> assert false
+          | player, [noop] -> Aux.Right (player, noop)
+          | player, more_actions -> Aux.Left player) noops in
+      match ccand, nccands with
+        | None, [player] -> Some player, noops
+        | Some _, [] -> ccand, noops
+        | _ -> raise Not_turn_based
+    ) control_cands noop_cands in
+    let control_cands, noop_cands =
+      List.split control_noop_cands in
+    (* {{{ log entry *)
+    if !debug_level > 1 then (
+      Printf.printf "check_turn_based: control player cands %s\n%!"
+        (String.concat " "
+           (List.map (function Some t->term_str t | None->"None")
+              control_cands))
+    );
+    (* }}} *)
   (* 2b *)
-  let loc_players = find_cycle control_cands in
+    let loc_players = find_cycle control_cands in
   (* {{{ 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))
-  );
+    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
+    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 *)
-  let loc_noops =
-    let i = ref 0 in
-    let noops = ref noop_cands in
-    let loc_noops = Array.make_matrix loc_n players_n None in
-    while !noops <> [] do
-      List.iter (function _, None -> ()
-        | player, (Some _ as noop) ->
-          let p_i = find_player player in
-          if loc_noops.(!i).(p_i) = None
-          then loc_noops.(!i).(p_i) <- noop
-          else if loc_noops.(!i).(p_i) <> noop
+    let loc_noops =
+      let i = ref 0 in
+      let noops = ref noop_cands in
+      let loc_noops = Array.make_matrix loc_n players_n None in
+      while !noops <> [] do
+        List.iter (function _, None -> ()
+          | player, (Some _ as noop) ->
+            let p_i = find_player player in
+            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 *)
-          then raise Not_turn_based)
-        (List.hd !noops);
-      incr i; if !i = loc_n then i := 0;
-      noops := List.tl !noops
-    done;
-    loc_noops in
-  loc_players, loc_noops
+            then raise Not_turn_based)
+          (List.hd !noops);
+        incr i; if !i = loc_n then i := 0;
+        noops := List.tl !noops
+      done;
+      loc_noops in
+    loc_players, loc_noops in
+  (* doing the playouts "a couple" = 3 times *)
+  let data1 = check_one_playout () in
+  let data2 = check_one_playout () in
+  let data3 = check_one_playout () in
+  if data1 = data2 && data1 = data3 then data1
+  else raise Not_turn_based
 
 
 let build_toss_rule transl_data rule_names struc fluents
@@ -946,17 +964,13 @@
 let translate_game ~playing_as clauses =
   let clauses = expand_players clauses in
   let used_vars, clauses = rename_clauses clauses in
-  let next_cls, f_paths, m_paths, mask_reps, defined_rels,
+  let players, rules,
+    next_cls, f_paths, m_paths, mask_reps, defined_rels,
     stable_rels, fluents,
     stable_base, init_state, struc, agg_actions, elem_term_map =
     create_init_struc clauses in
-  let players = Array.of_list
-    (Aux.map_some (function
-      | ("role", [|player|]), _ -> Some player
-      | _ -> None
-    ) clauses) in
   let turn_data =
-    try Some (check_turn_based players agg_actions)
+    try Some (check_turn_based players rules)
     with Not_turn_based -> None in
   let rule_cands, is_concurrent =
     create_rule_cands (turn_data <> None) used_vars next_cls clauses in

Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml	2011-08-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/GGP/TranslateGameTest.ml	2011-08-04 03:58:35 UTC (rev 1524)
@@ -23,7 +23,7 @@
   let descr =
     GDLParser.parse_game_description KIFLexer.lex
       (Lexing.from_channel f) in
-  (* List.map GDL.rule_of_entry *) descr
+  descr
 
 let emb_str (game, state) (rname, emb) =
   let r = List.assoc rname game.Arena.rules in
@@ -171,7 +171,7 @@
 ]
 
 let a () =
-  (* GDL.debug_level := 5; *)
+  (* 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-03 14:57:48 UTC (rev 1523)
+++ trunk/Toss/www/reference/reference.tex	2011-08-04 03:58:35 UTC (rev 1524)
@@ -2110,16 +2110,16 @@
 attempting a complex analysis to detect as many turn-based games as
 possible, we recognize some cases where in all states, all players but
 one have a single legal move that is a constant (term of size
-one). Such move is conventionally called \texttt{noop}. We simply
-check what moves are available to players in the states of the
-aggregate playout. Due to the character of aggregate playout, we only
-handle the case where the alternation of control forms a cycle
-(players do not need to strictly alternate, for example a
-single-player game is also a turn-based game, as another example in a
-three-player game the first player may intersperse the moves of second
-and third player). We build a corresponding cyclic graph of Toss
-locations. We limit the turn-based translation to the case where all
-rule clauses have exactly one \texttt{does} atom (\ie can be
+one). Such move is conventionally called \texttt{noop}. In the current
+implementation we simply check what moves are available to players in
+the states of a couple of random playouts, so the detection is
+unsound. We only handle the case where the alternation of control
+forms a cycle (players do not need to strictly alternate, for example
+a single-player game is also a turn-based game, as another example in
+a three-player game the first player may intersperse the moves of
+second and third player). We build a corresponding cyclic graph of
+Toss locations. We limit the turn-based translation to the case where
+all rule clauses have exactly one \texttt{does} atom (\ie can be
 attributed to exactly one of the players).
 
 \subsubsection{Concurrent Moves Games} \label{par-concurrent-moves}


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




2010	Jan	Feb	Mar	Apr	May	Jun	Jul	Aug	Sep	Oct	Nov (25)	Dec (62)
2011	Jan (26)	Feb (38)	Mar (67)	Apr (22)	May (41)	Jun (30)	Jul (24)	Aug (32)	Sep (29)	Oct (34)	Nov (18)	Dec (2)
2012	Jan (19)	Feb (25)	Mar (16)	Apr (2)	May (18)	Jun (21)	Jul (11)	Aug	Sep	Oct	Nov	Dec

toss-devel-svn Mailing List for Toss (Page 10)

toss-devel-svn — Toss development: svn commits