[Toss-devel-svn] SF.net SVN: toss:[1510] trunk/Toss/GGP/TranslateGame.ml

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

Revision: 1510
          http://toss.svn.sourceforge.net/toss/?rev=1510&view=rev
Author:   lukstafi
Date:     2011-07-13 09:54:19 +0000 (Wed, 13 Jul 2011)

Log Message:
-----------
GDL translation work in progress. Does not compile yet.

Modified Paths:
--------------
    trunk/Toss/GGP/TranslateGame.ml

Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml	2011-07-10 19:47:57 UTC (rev 1509)
+++ trunk/Toss/GGP/TranslateGame.ml	2011-07-13 09:54:19 UTC (rev 1510)
@@ -226,10 +226,11 @@
       ) struc element_reps
     ) struc maks_reps in
   next_clauses, f_paths, m_paths, mask_reps, defined_rels,
-  stable_base, init_state, struc, elem_term_map
+  stable_base, init_state, struc, agg_actions, elem_term_map
 
 
-(* Find the rule clauses $\ol{\calC},\ol{\calN}$. *)
+(* Find the rule clauses $\ol{\calC},\ol{\calN}$. Do not remove the
+   "does" atoms from clauses. *)
 let move_tuples used_vars next_cls legal_tuples =
   (* computing the $d_i(\calN)$ for each $\calN$ *)
   let fresh_x_f () =
@@ -346,9 +347,9 @@
   legal_tup, next_cls @ erasure_cls
 
 
-(* Assign rule clauses to rule cases, i.e. candidates for Toss
-   rules. Collect the conditions and RHS state terms together. *)
-let rule_cases (legal_tup, next_cls) =
+(* Assign rule clauses to rule cases, i.e. candidates for
+   Toss rules. Collect the conditions and RHS state terms together. *)
+let rule_cases next_cls =
   let atoms = Aux.concat_map
     (fun (_, body) -> Aux.map_some (function
       | Pos (Rel _ as a) | Neg (Rel _ as a) -> Some a
@@ -387,18 +388,37 @@
           ) choice patterns
       ) next_cls in
     let case_rhs, case_conds = List.split case_cls in
-    case_rhs, separation_cond @ case_conds in
-  let legal_tup, legal_cond = List.split legal_tup in
-  let legal_cond = List.concat legal_cond in
-  List.map (fun choice ->
-    let case_rhs, case_conds = rule_case choice in
-    let case_conds = case_conds @ legal_cond in
-    legal_tup, case_rhs, case_conds) choices
+    case_cls, case_rhs, separation_cond @ case_conds in
+  List.map rule_case choices
 
 
+let nonint_rule_cases (legal_tup, next_cls) =
+    let legal_tup, legal_cond = List.split legal_tup in
+    let legal_cond = List.combine legal_cond in
+    List.map (fun (case_rhs, case_cond) ->
+      legal_tup, case_rhs, case_cond @ legal_cond
+    ) (rule_cases next_cls)
+
+(* If "Concurrent Moves" case, divide rule clauses among players. *)
+let concurrent_rule_cases players (legal_tup, next_cls) =
+  Array.mapi (fun i player ->
+    let legal_head, legal_cond = legal_tup.(i) in
+    let cls = List.filter
+      (fun (_,cl_body) -> List.exists (
+        function Does (p, _) when p=player -> true | _ -> false)
+        cl_body)
+      next_cls in
+    List.map (fun (case_rhs, case_cond) ->
+      legal_head, case_rhs, case_cond @ legal_cond
+    ) (rule_cases cls)
+  ) players
+
+let general_int_rule_cases (legal_tup, next_cls) =
+  failwith "General Interaction Games not implemented yet"
+
 (* The candidates need to be filtered before finishing the
    translation of Toss rules. *)
-let create_rule_cands used_vars next_cls clauses =
+let create_rule_cands is_turn_based used_vars next_cls clauses =
   let players = (* Array.of_list *)
     Aux.map_some (function
       | ("role", [player]), _ -> Some player
@@ -406,6 +426,13 @@
     ) clauses in
   let legal_cls =
     List.filter (fun ((rel,_),_) -> rel="legal") clauses in
+  let is_concurrent = not is_turn_based &&
+    List.for_all
+    (fun (_, body) ->
+      List.length
+        (List.filter (function Does _ -> true | _ -> false) body)
+      <= 1)
+    next_cls in
   (* let next_cls =
      List.filter (fun ((rel,_),_) -> rel="next") clauses in *)
   (* constructing $(\calC_1,...,\calC_n)$ tuples *)
@@ -415,14 +442,26 @@
         | ("legal",[lp; l]), body when lp = p -> Some (l, body)
         | _ -> None) legal_cls
     ) players in
-  let legal_tuples = Aux.product legal_by_player in
-  let move_tups = move_tuples used_vars next_cls legal_tuples in
-  let move_tups =
-    List.map (fun (sb, legal_tup, n_cls) ->
-      List.map (subst sb) legal_tup,
-      List.map (subst_clause sb) n_cls) move_tups in
-  let move_tups = List.map add_erasure_clauses move_tups in
-  Aux.concat_map rule_cases move_tups
+  let process_rule_cands legal_tuples =
+    let move_tups = move_tuples used_vars next_cls legal_tuples in
+    let move_tups =
+      List.map (fun (sb, legal_tup, n_cls) ->
+        List.map (subst sb) legal_tup,
+        List.map (subst_clause sb) n_cls) move_tups in
+    List.map add_erasure_clauses move_tups in
+  let concurrent_rule_cands player legal_cls =
+    let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
+    let move_tups = process_rule_cands legal_tuples in
+    player, Aux.concat_map nonint_rule_cases move_tups
+  if is_concurrent then
+    Right (List.map2 concurrent_rule_cands players legal_by_player)
+  else
+    let legal_tuples = Aux.product legal_by_player in
+    let move_tups = process_rule_cands legal_tuples in
+    if is_turn_based then
+      Left (Aux.concat_map nonint_rule_cases move_tups)
+    else
+      Left (Aux.concat_map general_int_rule_cases move_tups)
 
 
 let filter_rule_cands stable_base defined_rels rule_cands =
@@ -434,18 +473,109 @@
       List.mem rel defined_rels ||
         not (List.exists (rels_unify a) stable_base)
     | _ -> true in
-  List.filter (fun (_, _, case_conds) ->
-    List.for_all check_atom case_conds
-  ) rule_cands
+  let check_cands cands =
+    List.filter (fun (_, _, _, case_conds) ->
+      List.for_all check_atom case_conds
+    ) cands in
+  match rule_cands with
+    | Left cands -> Left (check_cands cands)
+    | Right cands ->
+      Right (List.map (fun (p,cands) -> p, check_cands cands) cands)
 
 
+exception Not_turn_based
+(* 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
+  (* 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
+  (* 2b *)
+  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))
+  );
+  (* }}} *)
+  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 find_player_locs player =
+    Aux.array_argfind_all (fun p->p=player) loc_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
+          (* 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
+
+
+let loc_graph_turn_based loc_players loc_noops rule_cands =
+
+  
+let loc_graph_general_int =
+  failwith "GDL: General Interaction Games not implemented yet"
+
+let loc_graph_concurrent =
+()
+
 let translate_game 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,
-    stable_base, init_state, struc, elem_term_map =
+    stable_base, init_state, struc, agg_actions, elem_term_map =
     create_init_struc clauses in
-  let rule_cands = create_rule_cands used_vars next_cls clauses in
+  let turn_data =
+    try Some (check_turn_based players agg_actions)
+    with Not_turn_based -> None in
+  let rule_cands =
+    create_rule_cands (turn_data <> None) used_vars next_cls clauses in
   let rule_cands = filter_rule_cands stable_base rule_cands in
   let all_state_terms =
     Aux.concat_map state_terms (List.map snd clauses) in
@@ -460,18 +590,42 @@
     defrel_arg_type = ref [];           (* built in TranslateFormula *)
     term_arities = term_arities;
   } in
-
-  let game = assert false
+  let defined_rels = build_defrels transl_data clauses in
+  let players = Array.of_list
+    (Aux.map_some (function
+      | ("role", [player]), _ -> Some player
+      | _ -> None
+     ) clauses) in
+  let player_names = Array.to_list
+    (Array.mapi (fun i p -> term_to_name p, i) players) in
+  let graph (*: player_loc array array*) =
+    match turn_data, rule_cands with
+      | Some (loc_players, loc_noops), Left cands ->
+        loc_graph_turn_based loc_players loc_noops cands
+      | None, Left cands ->
+        loc_graph_general_int
+      | None, Right cands
+        loc_graph_concurrent
+      | _ -> assert false
   in
+  let game = {
+    Arena.rules = rules;
+    patterns = [];
+    graph = graph;
+    num_players = Array.length players;
+    player_names = player_names;
+    data      = [];
+    defined_rels = defined_rels;
+  } in
   let gdl_translation = {
-  (* map between structure elements and their term representations;
-     the reverse direction is by using element names *)
+      (* map between structure elements and their term representations;
+         the reverse direction is by using element names *)
     elem_term_map = elem_term_map;
     f_paths = f_paths;
     m_paths = m_paths;
     masks = mask_reps;
     tossrule_data = tossrule_data;
-  (* rule name to rule translation data *)
+    (* rule name to rule translation data *)
   } in
   gdl_translation,
   (game, {Arena.struc = struc; time = 0.; cur_loc = 0})


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