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

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

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.