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

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

Revision: 1519
          http://toss.svn.sourceforge.net/toss/?rev=1519&view=rev
Author:   lukstafi
Date:     2011-07-29 09:53:41 +0000 (Fri, 29 Jul 2011)

Log Message:
-----------
GDL translation work in progress: compilation fixes. Tests do not work yet.

Modified Paths:
--------------
    trunk/Toss/GGP/GDL.ml
    trunk/Toss/GGP/GDL.mli
    trunk/Toss/GGP/TranslateFormula.ml
    trunk/Toss/GGP/TranslateFormula.mli
    trunk/Toss/GGP/TranslateGame.ml
    trunk/Toss/GGP/TranslateGame.mli
    trunk/Toss/GGP/TranslateGameTest.ml
    trunk/Toss/Server/ReqHandler.ml

Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/GDL.ml	2011-07-29 09:53:41 UTC (rev 1519)
@@ -286,8 +286,10 @@
   | Neg atom -> Neg (subst_atom sb atom)
   | Disj disjs -> Disj (List.map (subst_literal sb) disjs)
 
+let rec subst_literals sb = List.map (subst_literal sb)
+
 let subst_clause sb (head, body) =
-  subst_rel sb head, List.map (subst_literal sb) body
+  subst_rel sb head, subst_literals sb body
 
 let rel_atom_str (rel, args) =
   "(" ^ rel ^ " " ^
@@ -675,6 +677,7 @@
 
 let player_vars_of rels =
   Aux.map_some (function
+    | "goal", [|Var v; _|] -> Some v
     | "does", [|Var v; _|] -> Some v
     | "legal", [|Var v; _|] -> Some v
     | _ -> None) rels

Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/GDL.mli	2011-07-29 09:53:41 UTC (rev 1519)
@@ -62,8 +62,12 @@
 
 val unify : substitution -> term list -> term list -> substitution
 val unify_all : substitution -> term list -> substitution
+val rels_unify : rel_atom -> rel_atom -> bool
 val subst : substitution -> term -> term
+val subst_rel : substitution -> rel_atom -> rel_atom
 val subst_rels : substitution -> rel_atom list -> rel_atom list
+val subst_literal : substitution -> literal -> literal
+val subst_literals : substitution -> literal list -> literal list
 val subst_clause : substitution -> clause -> clause
 
 (** {3 Transformations of GDL clauses: inlining, negation.} *)
@@ -77,18 +81,24 @@
     negation of disjunction of given clause bodies. *)
 val negate_bodies : literal list list -> literal list list
 
+(** Rename clauses so that they have disjoint variables. Return a cell
+    storing all variables. *)
+val rename_clauses : clause list -> Aux.Strings.t ref * clause list
+
 val func_graph : string -> term list -> term array list
 
 
+
 (** {3 GDL translation helpers.} *)
 
 val blank : term
 
+val term_str : term -> string
 val term_to_name : ?nested:bool -> term -> string
 
 val state_terms : literal list -> term list
+val term_arities : term -> (string * int) list
 
-
 (** {3 GDL whole-game operations.}
 
     Aggregate playout, player-denoting variable elimination. *)
@@ -107,6 +117,10 @@
     rel_atom list * term list *
     (term array list list * term list list)
 
+val find_cycle : term option list -> term option list
+
+val expand_players : clause list -> clause list
+
 (** {3 Paths and operations involving terms and paths.} *)
 
 (** [simult_subst ps s t] substitutes [s] at all [t] paths that belong

Modified: trunk/Toss/GGP/TranslateFormula.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormula.ml	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateFormula.ml	2011-07-29 09:53:41 UTC (rev 1519)
@@ -291,11 +291,12 @@
             failwith "GGP/TranslateFormula: finding path for defined relation argument undetermined by state terms not implemented yet")
       p_defside p_callside in
     (* now building the translation *)
-    let defvars = Array.mapi (fun i _ ->
-      Formula.fo_var_of_string ("v"^string_of_int i)) arg_paths in
+    let defvars =
+      Array.mapi (fun i _ -> "v"^string_of_int i) arg_paths in
     let defbody (args,(rels_phi,pos_state,neg_state)) s_defside =        
       let arg_eqs = Array.mapi
         (fun i v ->
+          let v = Formula.fo_var_of_string v in
           let in_I = p_defside.(i) <> None in
           if in_I
           then
@@ -324,7 +325,7 @@
       p_defside arg_paths  in
     data.defrel_arg_type :=
       (rel, defrel_arg_type) :: !(data.defrel_arg_type);
-    rel, (defvars, Formula.Or def_disjuncts) in
+    rel, (Array.to_list defvars, Formula.Or def_disjuncts) in
   List.map build_defrel data.defined_rels
 
 

Modified: trunk/Toss/GGP/TranslateFormula.mli
===================================================================
--- trunk/Toss/GGP/TranslateFormula.mli	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateFormula.mli	2011-07-29 09:53:41 UTC (rev 1519)
@@ -13,7 +13,14 @@
   term_arities : (string * int) list;
 }
 
+val blank_out : transl_data -> GDL.term -> GDL.term
+val var_of_term : transl_data -> GDL.term -> Formula.fo_var
+
 val empty_transl_data : transl_data
 
 val translate :
   transl_data -> GDL.literal list list -> Formula.formula
+
+val build_defrels :
+  transl_data -> GDL.clause list ->
+  (string * (string list * Formula.formula)) list

Modified: trunk/Toss/GGP/TranslateGame.ml
===================================================================
--- trunk/Toss/GGP/TranslateGame.ml	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateGame.ml	2011-07-29 09:53:41 UTC (rev 1519)
@@ -3,6 +3,7 @@
 *)
 
 open GDL
+open TranslateFormula
 
 (** Translate stable relations that otherwise would be translated as
     structure relations, but have arity above the threshold, as
@@ -25,9 +26,12 @@
 let env_player = Const "ENVIRONMENT"
 
 type tossrule_data = {
-  legal_tuple : term;
-  (* the "legal"/"does" term of the player that performs the move, we
-     call its parameters "fixed variables" as they are provided externally *)
+  legal_tuple : term array;
+  (* the "legal"/"does" term of the player that performs the move
+     (when a singleton) or the players that participate in the move
+     (then ordered in the same way as players),
+     we call its parameters "fixed variables" as they are provided
+     externally *)
   precond : Formula.formula;
   (* the LHS match condition (the LHS structure and the precondition) *)
   rhs_add : (string * string array) list;
@@ -60,8 +64,7 @@
   is_concurrent : bool;
   transl_data : TranslateFormula.transl_data;
   (* mostly the same data as above, but packed for formula translation *)
-  element_terms : term Aux.IntMap.t;
-  (* term representatives of structure elements *)
+  fluents : string list;
 }
 
 let empty_gdl_translation = {
@@ -74,7 +77,7 @@
   playing_as = 0;
   is_concurrent = false;
   transl_data = TranslateFormula.empty_transl_data;
-  element_terms = Aux.IntMap.empty;
+  fluents = [];
 }
 
 let our_turn gdl state = true
@@ -190,9 +193,12 @@
   let frame_clauses, move_clauses, f_paths =
     fluent_paths_and_frames clauses in
   let next_clauses =
-    List.map (fun ((_,s_C),body_C) -> s_C, true, body_C) frame_clauses
-    @ List.map (fun ((_,s_C),body_C) -> s_C, false, body_C)
-      move_clauses in
+    List.map (function
+      | (_,[|s_C|]),body_C -> s_C, true, body_C
+      | _ -> assert false) frame_clauses
+    @ List.map (function
+      | (_,[|s_C|]),body_C -> s_C, false, body_C
+      | _ -> assert false) move_clauses in
   let arities =
     ("EQ_", 2)::
       Aux.unique_sorted
@@ -219,8 +225,6 @@
       List.assoc rel arities <= !defined_arity_above) stable_rels in
   let struc_rels = "EQ_"::struc_rels in
   let defined_rels = defined_rels @ nonstable_rels in
-  let elem_term_map = Aux.strmap_of_assoc
-    (List.map (fun e -> term_to_name e, e) element_reps) in
   let struc =
     List.fold_left (fun struc rel ->
       let arity = List.assoc rel arities in
@@ -269,23 +273,70 @@
         else struc
       ) struc element_reps
     ) struc mask_reps in
+  (*
+  let elem_term_map = Aux.strmap_of_assoc
+    (List.map (fun e -> term_to_name e, e) element_reps) in
+  *)
+  let elem_term_map = Aux.intmap_of_assoc
+    (List.map (fun e ->
+      Structure.find_elem struc (term_to_name e), e) element_reps) in
   next_clauses, f_paths, m_paths, mask_reps, defined_rels,
   !stable_rels, !fluents,
   stable_base, init_state, struc, agg_actions, elem_term_map
 
+(* substitute a "next" clause with frame info *)
+let subst_fnextcl sb (head, frame, body) =
+  subst sb head, frame, subst_literals sb body
 
+(* substitute a "legal" or "next" clause (with only a legal/state term
+   in the head) *)
+let subst_ln_cl sb (head, body) =
+  subst sb head, subst_literals sb body
+
+
+(* Callgraph for creating "move tuples" and Toss rules.
+
+   (1) [create_init_struc] prepares [next_cls], segregated into frame
+   clauses and normal clauses, with head term extracted.
+
+   (2) [move_tuples] selects maximal tuples of [next_cls] such that
+   their "legal"/"does" terms unify.
+
+   (3) [add_erasure_clauses] converts frame into erasure clauses, and
+   adds the result to non-frame clauses (without framing
+   information).
+
+   (4) [process_rule_cands] calls [move_tuples], applies the unifier,
+   and calls [add_erasure_clauses].
+
+   (5) [rule_cases] distributes clauses from a move tuple to
+   disjointly cover all applicability conditions. Then it collects all
+   head terms and conflates the bodies to produce a rule
+   candidate. Legality conditions are not passed to [rule_cases].
+
+   (6) [turnbased_rule_cases], [concurrent_rule_cases] and
+   [general_int_rule_cases] call [rule_cases], add legal terms and
+   legality conditions to the result when appropriate (the
+   environment does not have legality conditions). Rules for players
+   as well as for the environment (when not turn-based) are built.
+
+   (7) [create_rule_cands] calls the right routine of (6).
+
+*)
+
+
 (* Find the rule clauses $\ol{\calC},\ol{\calN}$. Do not remove the
    "does" atoms from clauses. Also handles as special cases:
    "concurrent" case with selecting clauses for only one player, and
    "environment" case for selecting clauses not dependent on any
-   player. *)
+   player. Preserve legal clauses into the output tuples. *)
 let move_tuples used_vars next_cls mode players legal_tuples =
   (* computing the $d_i(\calN)$ for each $\calN$ *)
   let fresh_x_f () =
     let x_f = Aux.not_conflicting_name !used_vars "x_f" in
     used_vars := Aux.Strings.add x_f !used_vars;
     Var x_f in
-  let does_facts (_,body) =
+  let does_facts (_,_,body) =
     List.fold_right (fun p (sb, dis) ->
       let djs =
         (* FIXME: check if "negative true" is properly handled *)
@@ -304,7 +355,7 @@
   let next_cls =
     if mode = `Environment
     then
-      Aux.map_some (fun (_,body as cl) ->
+      Aux.map_some (fun (_,_,body as cl) ->
         if List.exists
           (function Pos (Does _) | Neg (Does _) -> true | _ -> false) body
         then None
@@ -313,13 +364,14 @@
     else
       Aux.map_try (fun cl ->
         let sb, ds = does_facts cl in
-        subst_clause sb cl, ds) next_cls in
+        subst_fnextcl sb cl, ds) next_cls in
   (* selecting $\ol{\calC},\ol{\calN}$ clauses with
      $\sigma_{\ol{\calC},\ol{\calN}}$ applied *)
   let tup_unifies ts1 ts2 =
     try ignore (unify [] ts1 ts2); true
     with Not_found -> false in
-  let move_clauses cs =
+  let move_clauses legal_tup =
+    let cs = List.map fst legal_tup in
     (* bag of next clauses for each legal tuple *)
     let next_clauses =
       List.filter (fun (n_cl, ds) -> tup_unifies cs ds) next_cls in
@@ -355,7 +407,8 @@
            (sb, tup_ds, n_cl::n_cls)
           with Not_found -> cl_tup
       ) cl_tup next_clauses in
-    List.map maximality cl_tups in
+    let cl_tups = List.map maximality cl_tups in
+    List.map (fun (sb, _, n_cls) -> sb, legal_tup, n_cls) cl_tups in
   Aux.concat_map move_clauses legal_tuples
 
 
@@ -395,7 +448,7 @@
   let frames = List.map maximality frames in
   let frames =
     List.map (fun (sb, s, bodies) ->
-      s, List.map (subst_rels sb) bodies) frames in
+      s, List.map (subst_literals sb) bodies) frames in
   let erasure_cls =
     Aux.concat_map (fun (s, bodies) ->
       let nbodies = negate_bodies bodies in
@@ -408,7 +461,8 @@
 
 
 (* Assign rule clauses to rule cases, i.e. candidates for
-   Toss rules. Collect the conditions and RHS state terms together. *)
+   Toss rules. Collect the conditions and RHS state terms together.
+   Frame clauses are already processed into erasure clauses. *)
 let rule_cases next_cls =
   let atoms = Aux.concat_map
     (fun (_, body) -> Aux.map_some (function
@@ -419,7 +473,7 @@
   let patterns =
     let next_cls = Array.of_list next_cls in
     List.map (fun a ->
-      Array.map (fun i (_, body) ->
+      Array.mapi (fun i (_, body) ->
         if List.mem (Neg a) body then -1
         else if List.mem (Pos a) body then 1
         else 0
@@ -427,8 +481,8 @@
       a) atoms in
   let patterns = Aux.collect patterns in
   let patterns = List.filter (fun (pat, _) ->
-    Array.exists (fun v-> v < 1) pat &&
-      Array.exists (fun v-> v > -1) pat) patterns in
+    Aux.array_existsi (fun _ v-> v < 1) pat &&
+      Aux.array_existsi (fun _ v-> v > -1) pat) patterns in
   let pos_choice = List.map (fun _ -> true) patterns in
   let neg_choice = List.map (fun _ -> false) patterns in
   let choices = Aux.product [pos_choice; neg_choice] in
@@ -448,34 +502,63 @@
           ) choice patterns
       ) next_cls in
     let case_rhs, case_conds = List.split case_cls in
-    case_cls, case_rhs, separation_cond @ case_conds in
+    case_cls, case_rhs, separation_cond @ List.concat 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)
+let process_rule_cands used_vars next_cls mode players legal_tuples =
+  let move_tups =
+    move_tuples used_vars next_cls mode players legal_tuples in
+  let move_tups =
+    List.map (fun (sb, legal_tup, n_cls) ->
+      List.map (subst_ln_cl sb) legal_tup,
+      List.map (subst_fnextcl sb) n_cls) move_tups in
+  List.map add_erasure_clauses move_tups
 
+
+let add_legal_cond (legal_tup, next_cls) =
+  let legal_tup, legal_cond = List.split legal_tup in
+  let legal_cond = List.concat legal_cond in
+  List.map (fun (case_cls, case_rhs, case_cond) ->
+    legal_tup, case_rhs, case_cond @ legal_cond
+  ) (rule_cases next_cls)
+
+
+let turnbased_rule_cases used_vars next_cls players legal_by_player =
+  let legal_tuples = Aux.product legal_by_player in
+  let move_tups =
+    process_rule_cands
+      used_vars next_cls `General players legal_tuples in
+  let rules = Aux.concat_map add_legal_cond move_tups in
+  (* we do not look for the players -- for turn-based case, it's done
+     while building game graph *)
+  Aux.Left rules
+
+
 (* 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 concurrent_rule_cases used_vars next_cls players legal_by_player =
+  let env_pl_tups =
+    env_player,
+    process_rule_cands used_vars next_cls `Environment [] [[]] in
+  let player_rules =
+    List.map2 (fun player legal_cls ->
+    (* [process_rule_cands] works with players tuples, so we "cheat" *)
+      let legal_tuples = List.map (fun cl -> [cl]) legal_cls in
+      let move_tups =
+        process_rule_cands
+          used_vars next_cls `Concurrent [player] legal_tuples in
+      player, move_tups
+    ) players legal_by_player in
+  let player_rules = List.map
+    (fun (player, move_tups) ->
+      player, Aux.concat_map add_legal_cond move_tups)
+    (player_rules @ [env_pl_tups]) in
+  Aux.Right player_rules
 
-let general_int_rule_cases (legal_tup, next_cls) =
+let general_int_rule_cases used_vars next_cls players legal_by_player =
   failwith "General Interaction Games not implemented yet"
 
+
 (* Generate rule candidates (they need to be filtered before finishing
    the translation of Toss rules): returns the "legal" terms tuple
    (ordered by players), the right-hand-sides, and the conditions
@@ -489,52 +572,35 @@
 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
+      | ("role", [|player|]), _ -> Some player
       | _ -> None
     ) 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) ->
+    (fun (_, _, body) ->
       List.length
-        (List.filter (function Does _ -> true | _ -> false) body)
+        (List.filter
+           (function Pos (Does _) | Neg (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 *)
   let legal_by_player =
     List.map (fun p ->
       Aux.map_some (function
-        | ("legal",[lp; l]), body when lp = p -> Some (l, body)
+        | ("legal",[|lp; l|]), body when lp = p -> Some (l, body)
         | _ -> None) legal_cls
     ) players in
-  let process_rule_cands mode players legal_tuples =
-    let move_tups =
-      move_tuples used_vars next_cls mode players 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 `Concurrent [player] legal_tuples in
-    player, Aux.concat_map nonint_rule_cases (move_tups @ env_tups) in
-  if is_concurrent then
-    let env_tups =
-      env_player, process_rule_cands `Environment [] [[]] in
-    Right
-      (List.map2 concurrent_rule_cands players legal_by_player @ env_tups)
-  else
-    let legal_tuples = Aux.product legal_by_player in
-    let move_tups = process_rule_cands `General players legal_tuples in
-    if is_turn_based then
-      Left (Aux.concat_map nonint_rule_cases move_tups)
+  let result =
+    if is_concurrent then
+      concurrent_rule_cases used_vars next_cls players legal_by_player
+    else if is_turn_based then
+      turnbased_rule_cases used_vars next_cls players legal_by_player
     else
-      Left (Aux.concat_map general_int_rule_cases move_tups)
+      general_int_rule_cases used_vars next_cls players legal_by_player
+  in
+  result, is_concurrent
 
 
 let filter_rule_cands stable_base defined_rels rule_cands =
@@ -547,13 +613,13 @@
         not (List.exists (rels_unify a) stable_base)
     | _ -> true in
   let check_cands cands =
-    List.filter (fun (_, _, _, case_conds) ->
+    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)
+    | Aux.Left cands -> Aux.Left (check_cands cands)
+    | Aux.Right cands ->
+      Aux.Right (List.map (fun (p,cands) -> p, check_cands cands) cands)
 
 
 exception Not_turn_based
@@ -563,7 +629,7 @@
 let check_turn_based players agg_actions =
   let noop_cands = List.map (fun actions ->
     let actions = Aux.map_reduce
-      (function [player; action] -> player, action
+      (function [|player; action|] -> player, action
         | _ -> assert false) (fun y x->x::y) [] actions in
     List.map (function
       | player, [Const _ as noop] -> player, Some noop
@@ -603,6 +669,8 @@
     (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
@@ -630,54 +698,56 @@
 let build_toss_rule transl_data rule_names struc fluents
     synch_precond synch_postcond (legal_tuple, case_rhs, case_cond) =
   let rname =
-    Aux.not_conflicting_name rule_names
+    Aux.not_conflicting_name !rule_names
       (String.concat "_" (List.map term_to_name legal_tuple)) in
   rule_names := Aux.Strings.add rname !rule_names;
   let label =
     {Arena.rule = rname; time_in = 0.1, 0.1; parameters_in = []} in
   let precond =
-    synch_precond @ TranslateFormula.translate transl_data case_cond in
+    Formula.And
+      (synch_precond @
+         (* singleton disjunct, i.e. no disjunction *)
+         [TranslateFormula.translate transl_data [case_cond]]) in
   let rhs_add = Aux.concat_map
-    (function _, [sterm] ->
+    (fun sterm ->
       let s_subterms =
-        map_paths (fun path subt -> subt, path) transl_data.f_paths sterm in
+        map_paths (fun path subt -> subt, path)
+          transl_data.TranslateFormula.f_paths sterm in
       let s_subterms = List.filter
         (fun (subt, _) -> subt <> blank) s_subterms in
-      let vartup = [|TranslateFormula.var_of_term data sterm|] in
+      (* same as [TranslateFormula.var_of_term], but only the name *)
+      let vartup = [|term_to_name (blank_out transl_data sterm)|] in
       List.map (fun (subt, path) ->
         pred_on_path_subterm path subt, vartup)
-        s_subterms
-      | _ -> assert false)
+        s_subterms)
     case_rhs in
   let rhs_add = synch_postcond @ rhs_add in
   let signat = Structure.rel_signature struc in
+  let struc_elems = List.map
+    (fun sterm -> term_to_name (blank_out transl_data sterm))
+    case_rhs in
   let discrete =
     DiscreteRule.translate_from_precond ~precond
       ~add:rhs_add ~emb_rels:fluents ~signat ~struc_elems in
   let rule =
-    ContinuousRule.make_rule signature [] discrete
+    ContinuousRule.make_rule signat [] discrete
       [] [] ~pre:discrete.DiscreteRule.pre () in
-  let struc_elem_terms = List.map
-    (function _, [sterm] -> sterm | _ -> assert false)
-    case_rhs in
-  let struc_elems = List.map
-    (fun sterm -> Formula.var_str (TranslateFormula.var_of_term data sterm))
-    struc_elem_terms in
-  let elemvars = Aux.strmap_of_assoc
-    (List.combine struc_elems struc_elem_terms) in
-  let fixvar_terms = List.map
+  let rulevar_terms = Aux.strmap_of_assoc
+    (List.combine struc_elems case_rhs) in
+  let fixvar_terms = Aux.concat_map
     (fun sterm -> map_paths
       (fun path -> function Var v -> v, (sterm, path)
         | _ -> assert false)
-      (term_paths (function Var _ -> true | _ -> false) sterm))
-    struc_elem_terms in
+      (term_paths (function Var _ -> true | _ -> false) sterm) sterm)
+    case_rhs in
+  let fixvar_terms = Aux.collect fixvar_terms in
   let tossrule_data = {
-    legal_tuple = legal_tuple;
+    legal_tuple = Array.of_list legal_tuple;
     precond = precond;
     rhs_add = rhs_add;
     struc_elems = struc_elems;
     fixvar_terms = fixvar_terms;
-    elemvars = elemvars;
+    rulevar_terms = rulevar_terms;
   } in
   ((rname, tossrule_data), label), (rname, rule)
 
@@ -695,7 +765,7 @@
       let loc_rules = Aux.map_some
         (fun (legal_tup, _, _ as rcand) ->
           let legal_tup = Array.of_list legal_tup in
-          if Array.for_alli
+          if Aux.array_for_alli
             (fun pl noop -> pl = player_num ||
                 Some legal_tup.(pl) = noop)
             loc_noops.(loc)
@@ -711,7 +781,7 @@
       Array.mapi
         (fun pl_num payoff ->
           {Arena.payoff = payoff;
-           view = [];
+           view = Formula.And [], [];   (* FIXME: ? *)
            heur = [];
            moves = if pl_num = player_num then pl_moves else []})
         player_payoffs)
@@ -723,49 +793,57 @@
 let loc_graph_general_int =
   failwith "GDL: General Interaction Games not implemented yet"
 
-(* Remember that "environment" is the last player -- also in payoffs
-   list. [rule_cands] is a player-indexed array. [players] are all
-   player terms, excluding "environment". *)
+(* "environment" will the last player -- also in payoffs
+   array. [players] are all player terms, excluding "environment"! *)
 let loc_graph_concurrent players
     player_payoffs struc build_rule fluents rule_cands =
   (* finding or creating the control predicate *)
+  let num_players = Array.length players in
   let control_pred, control_e, struc =
     try
       let control_pred, _ =
         List.find (fun (rel, ar) -> ar = 1 &&
-            Structure.Tuples.cardinal (Structure.find_rel rel struc) = 1)
+            Structure.Tuples.cardinal (Structure.rel_find rel struc) = 1)
           (Structure.rel_signature struc) in
-      let etup = Structure.Tuples.choose_elem
-        (Structure.find_rel control_pred struc) in
+      let etup = Structure.Tuples.choose
+        (Structure.rel_find control_pred struc) in
       control_pred, etup.(0), struc
     with Not_found ->
       let struc, control_e =
         Structure.add_new_elem struc ~name:sControl () in
-      let struc = Structure.add_rel struc [|control_e|] in
+      let struc = Structure.add_rel struc sControl [|control_e|] in
       sControl, control_e, struc in
   (* adding synchronization to rules and putting it all together *)
   let player_pred pl = term_to_name pl ^ "__SYNC" in
-  let struc = List.fold_left
+  let struc = Array.fold_left
     (fun struc player ->
-      Structure.add_rel_name (player_pred player) 1) players in
+      Structure.add_rel_name (player_pred player) 1 struc) struc players in
+  let control_vn = Structure.elem_name struc control_e in
   let control_v =
-    Formula.fo_var_of_string (Structure.elem_name struc control_e) in
+    Formula.fo_var_of_string control_vn in
   let player_marker pl =
     [player_pred pl, [|control_v|]; control_pred, [|control_v|]] in
-  let fluents = List.map player_pred players @ fluents in
+  let player_marker_rhs pl =
+    [player_pred pl, [|control_vn|]; control_pred, [|control_vn|]] in
+  let lplayers = Array.to_list players in
+  let fluents = List.map player_pred lplayers @ fluents in
   let all_players_precond =
     (List.map (fun (rel,tup) -> Formula.Rel (rel,tup)))
-    (Aux.concat_map player_marker players) in
+    (Aux.concat_map player_marker lplayers) in
   let rules = ref [] in
   let tossr_data = ref [] in
-  let player_moves = Array.mapi
-    (fun pl_num (pl, p_rules) ->
+  let players_with_env = Array.of_list
+    (Array.to_list players @ [env_player]) in
+  let player_moves = List.map
+    (fun (pl, p_rules) ->
+      let pl_num =
+        Aux.array_argfind (fun x -> x = pl) players_with_env in
       let p_rules = List.map
         (fun rcand ->
           if pl_num = num_players then  (* environment *)
             build_rule struc fluents all_players_precond [] rcand
           else
-            build_rule struc fluents [] (player_marker pl) rcand)
+            build_rule struc fluents [] (player_marker_rhs pl) rcand)
         p_rules in
       (* we need to build first before adding [player_cond] because
          of how formula translation works *)
@@ -773,14 +851,15 @@
       let p_rdata, labels = List.split p_rdata in
       rules := !rules @ p_rules;
       tossr_data := !tossr_data @ p_rdata;
-      List.map (fun l -> l, (loc + 1) mod loc_n))
+      pl_num, List.map (fun l -> l, 0) labels)
     rule_cands in
+  let player_moves = Aux.array_from_assoc player_moves in
   let graph =
     [|
       Aux.array_map2
         (fun payoff moves ->
           {Arena.payoff = payoff;
-           view = [];
+           view = Formula.And [], [];   (* FIXME: ? *)
            heur = [];
            moves = moves})
         player_payoffs player_moves
@@ -788,20 +867,98 @@
   (graph, !rules, !tossr_data), struc
   
 
+(* We assume that clauses for different goal values are disjoint, for
+   non-disjoint we sum each component. *)
+let compute_payoffs transl_data players clauses =
+  (* TODO: we should expand non-constant value expressions... *)
+  let goal_cls = Aux.map_some
+    (function (("goal",[|player; value|]), body) ->
+      Some (player,(value,body)) | _ -> None) clauses in
+  let goal_cls =
+    List.map (fun (player, goal_brs) -> player, Aux.collect goal_brs)
+      (Aux.collect goal_cls) in
+  let player_goals = Array.map
+    (fun player ->
+      try List.assoc player goal_cls
+      with Not_found -> failwith
+        ("TranslateGame.compute_payoffs: no goal provided for player "
+         ^ term_to_name player))
+    players in
+  (* Translate the goal conditions. *)
+  let payoffs = Array.map
+    (fun goals -> List.map
+      (fun (score, disjs) ->
+        let score =
+          match score with
+            | Const pay ->
+              (try float_of_string pay with _ -> assert false)
+            | _ -> failwith
+              ("TranslateGame.compute_payoffs: non-constant " ^
+                  "goal values not implemented yet") in
+        let goal_phi = translate transl_data disjs in
+        let phi_vars = FormulaOps.free_vars goal_phi in
+        score,
+        if phi_vars = [] then goal_phi
+        else Formula.Ex (phi_vars, goal_phi))
+      goals)
+    player_goals in
+  (* Offset the values to remove the most inconvenient goal
+     condition. *)
+  let payoffs = Array.map
+    (fun payoff ->
+      let sized =
+        List.map (fun (score,phi) -> GameSimpl.niceness phi, score)
+          payoff in
+      (* Sort in increasing niceness -- to remove the least nice. *)
+      let base_score =
+        match List.sort Pervasives.compare sized with [] -> 0.
+          | (_, score)::_ -> score in
+      match payoff with
+        | [score, guard] ->
+          Formula.Times (
+            Formula.Const score, Formula.Char guard)
+        | scores ->
+          List.fold_left (fun sum (score, guard) ->
+            if score = base_score then (
+              (* {{{ log entry *)
+              if !debug_level > 2 then (
+                Printf.printf
+                  "translate_game: (8) dropping score %f guard:\n%s\n\n%!"
+                  score (Formula.sprint guard)
+              );
+              (* }}} *)
+              sum)
+            else
+              let guarded = Formula.Times (
+                Formula.Const (score -. base_score), Formula.Char guard) in
+              if sum = Formula.Const 0. then guarded
+              else Formula.Plus (sum, guarded))
+            (Formula.Const base_score) scores
+    ) payoffs in
+  payoffs
 
-let translate_game clauses =
+
+(* [playing_as] is only used for building move translation data, the
+   translation is independent of the selected player. *)
+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,
     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)
     with Not_turn_based -> None in
+  let rule_cands, is_concurrent =
+    create_rule_cands (turn_data <> None) used_vars next_cls clauses 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
+    filter_rule_cands stable_base defined_rels rule_cands in
   let all_state_terms =
     Aux.concat_map state_terms (List.map snd clauses) in
   let term_arities = Aux.unique_sorted
@@ -809,35 +966,34 @@
   let transl_data = {
     TranslateFormula.f_paths = f_paths;
     m_paths = m_paths;
-    all_paths = path_union f_paths m_paths;
+    all_paths = paths_union f_paths m_paths;
     mask_reps = mask_reps;
     defined_rels = defined_rels;
     defrel_arg_type = ref [];           (* built in TranslateFormula *)
     term_arities = term_arities;
   } in
-  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 defined_rels = TranslateFormula.build_defrels transl_data clauses in
   let player_names = Array.to_list
     (Array.mapi (fun i p -> term_to_name p, i) players) in
   (* possibly update the structure with a control element and predicate *)
+  let rule_names = ref Aux.Strings.empty in
+  let payoffs = compute_payoffs transl_data players clauses in
   let (graph, rules, tossrule_data), struc =
     match turn_data, rule_cands with
-      | Some (loc_players, loc_noops), Left cands ->
+      | Some (loc_players, loc_noops), Aux.Left cands ->
         let build_rule =
           build_toss_rule transl_data rule_names struc fluents [] [] in
-        loc_graph_turn_based players loc_players loc_noops build_rule
-          cands, struc
-      | None, Left cands ->
-        loc_graph_general_int
-      | None, Right cands ->
+        loc_graph_turn_based player_names payoffs
+          loc_players loc_noops build_rule
+          cands,
+        struc
+      | None, Aux.Right cands when is_concurrent ->
         let build_rule =
           build_toss_rule transl_data rule_names in
-        loc_graph_concurrent players player_payoffs struc build_rule
-          fluents rule_cands
+        loc_graph_concurrent players payoffs struc build_rule
+          fluents cands
+      | None, Aux.Right cands ->
+        loc_graph_general_int
       | _ -> assert false
   in
   let game = {
@@ -850,6 +1006,8 @@
     defined_rels = defined_rels;
   } in
   let tossrule_data = Aux.strmap_of_assoc tossrule_data in
+  let playing_as =
+    Aux.array_argfind (fun x -> x = playing_as) players in
   let gdl_translation = {
       (* map between structure elements and their term representations;
          the reverse direction is by using element names *)
@@ -858,6 +1016,11 @@
     m_paths = m_paths;
     masks = mask_reps;
     tossrule_data = tossrule_data;
+    turnbased_noops = Aux.map_option snd turn_data;
+    playing_as = playing_as;
+    is_concurrent = is_concurrent;
+    transl_data = transl_data;
+    fluents = fluents;
   } in
   gdl_translation,
   (game, {Arena.struc = struc; time = 0.; cur_loc = 0})
@@ -871,12 +1034,17 @@
    a non-noop action. [move] is the instance of a "legal" term,
    performed by [player] (a number). Returns an option, since it can
    be called for multiple candidate rules. *)
-let translate_incoming_single_action data rdata state player move rname =
-  let fixed_inst, _ =
-    unify [] [move] [rdata.legal_tuple.(player)] in
+let translate_incoming_single_action
+    fluents data rdata state player move rname =
+  let legal_term =
+    if Array.length rdata.legal_tuple > 1
+    then rdata.legal_tuple.(player)
+    else rdata.legal_tuple.(0) in
+  let fixed_inst = unify [] [move] [legal_term] in
+  let struc = (snd state).Arena.struc in
   let anchors = Aux.concat_map (fun (v,t) ->
     let state_terms = List.assoc v rdata.fixvar_terms in
-    Aux.concat_map
+    List.map
       (fun (sterm, path) -> 
         let pred = pred_on_path_subterm path t in
         Formula.Rel (pred, [|TranslateFormula.var_of_term data sterm|]))
@@ -895,7 +1063,7 @@
   let signat = Structure.rel_signature struc in
   let rule =
     DiscreteRule.translate_from_precond ~precond ~add:rdata.rhs_add
-      ~emb_rels:gdl.fluents ~signat ~struc_elems:rdata.struc_elems in
+      ~emb_rels:fluents ~signat ~struc_elems:rdata.struc_elems in
   let lhs_struc = rule.DiscreteRule.lhs_struc in
   let rule = DiscreteRule.compile_rule signat [] rule in
   let asgns =
@@ -928,12 +1096,15 @@
   let struc = (snd state).Arena.struc in
   let tossrules =
     Aux.strmap_filter (fun  _ rdata ->
-      try ignore (match_meta [] [] [move]
-                    [rdata.legal_tuple.(loc_player)]); true
+      let legal_term =
+        if Array.length rdata.legal_tuple > 1
+        then rdata.legal_tuple.(loc_player)
+        else rdata.legal_tuple.(0) in
+      try ignore (unify [] [move] [legal_term]); true
       with Not_found -> false
     ) gdl.tossrule_data in
   let candidates = Aux.map_some (fun (rname, rdata) ->
-    translate_incoming_single_action gdl.transl_data rdata state
+    translate_incoming_single_action gdl.fluents gdl.transl_data rdata state
       loc_player move rname    
   ) tossrules in
   match candidates with
@@ -949,8 +1120,8 @@
             Structure.elem_str lhs_struc v ^ ": " ^
               Structure.elem_str struc e) emb))
       );
-      (* }}} *)
-        loc_player, rname, emb
+        (* }}} *)
+      loc_player, (rname, emb)
     | _ ->
       (* {{{ log entry *)
       if !debug_level > 0 then (
@@ -980,13 +1151,13 @@
     (fun player move ->
       let tossrules =
         Aux.strmap_filter (fun  _ rdata ->
-          try ignore (match_meta [] [] [move]
+          try ignore (unify [] [move]
                         [rdata.legal_tuple.(player)]); true
           with Not_found -> false
         ) gdl.tossrule_data in
       let candidates = Aux.map_some (fun (rname, rdata) ->
-        translate_incoming_single_action gdl.transl_data rdata state
-          player move rname    
+        translate_incoming_single_action gdl.fluents gdl.transl_data
+          rdata state player move rname    
       ) tossrules in
       match candidates with
         | [] ->
@@ -1003,7 +1174,7 @@
               Structure.elem_str struc e) emb))
       );
       (* }}} *)
-        player, rname, emb
+        player, (rname, emb)
         | _ ->
       (* {{{ log entry *)
       if !debug_level > 0 then (
@@ -1031,7 +1202,7 @@
 
 let translate_incoming_move gdl state actions =
   if actions = []                       (* start of game -- do nothing *)
-  then "", []
+  then []
   else
     match gdl.turnbased_noops with
       | Some noops ->
@@ -1070,7 +1241,7 @@
       rule.ContinuousRule.compiled.DiscreteRule.lhs_elem_inv_names
       lhs_e in
     Aux.StrMap.find v tossrule.rulevar_terms,
-    Aux.IntMap.find struc_e gdl.element_terms) emb in
+    Aux.IntMap.find struc_e gdl.elem_term_map) emb in
   (* {{{ log entry *)
   if !debug_level > 2 then (
     Printf.printf "outgoing-emb={%s}\n%!"
@@ -1085,7 +1256,11 @@
     with Not_found -> failwith
       ("GDL.translate_outgoing_move: inconsistent match for rule "
        ^rname) in
-  let res = term_str (subst sb tossrule.legal_tuple.(gdl.playing_as)) in
+  let legal_term =
+    if Array.length tossrule.legal_tuple > 1
+    then tossrule.legal_tuple.(gdl.playing_as)
+    else tossrule.legal_tuple.(0) in
+  let res = term_str (subst sb legal_term) in
   (* {{{ log entry *)
   if !debug_level > 0 then (
     Printf.printf "GDL.translate_outgoing_move: result = %s\n%!" res

Modified: trunk/Toss/GGP/TranslateGame.mli
===================================================================
--- trunk/Toss/GGP/TranslateGame.mli	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateGame.mli	2011-07-29 09:53:41 UTC (rev 1519)
@@ -1,29 +1,63 @@
+
 type tossrule_data = {
-  legal_tuple : GDL.term;
-  (* the "legal"/"does" term of the player that performs the move, we
-     call its parameters "fixed variables" as they are provided externally *)
+  legal_tuple : GDL.term array;
+  (* the "legal"/"does" term of the player that performs the move
+     (when a singleton) or the players that participate in the move
+     (then ordered in the same way as players),
+     we call its parameters "fixed variables" as they are provided
+     externally *)
   precond : Formula.formula;
   (* the LHS match condition (the LHS structure and the precondition) *)
   rhs_add : (string * string array) list;
+  struc_elems : string list;
   (* the elements of LHS/RHS structures, corresponding to the "next"
      terms *)
-  struc_elems : string list;
   fixvar_terms : (string * (GDL.term * GDL.path) list) list;
+  (* "state" terms indexed by GDL variables that they contain, together
+     with the path to the variable; in [(term * path) list], terms
+     can repeat *)
   rulevar_terms : GDL.term Aux.StrMap.t;
+(* "state" terms indexed by Toss variable names they generate *)
 }
 
 (** Data to be used when translating moves. *)
-type gdl_translation
+type gdl_translation = {
+  (* map between structure elements and their term representations;
+     the reverse direction is by using element names *)
+  elem_term_map : GDL.term Aux.IntMap.t;
+  f_paths : GDL.path_set;
+  m_paths : GDL.path_set;
+  masks : GDL.term list;
+  tossrule_data : tossrule_data Aux.StrMap.t;
+  (* rule name to rule translation data *)
+  turnbased_noops : GDL.term option array array option;
+  (* in case of a turn-based translation, for each location and each
+     player, the player's noop move (if any) for the location *)
+  playing_as : int;
+  (* "active" player *)
+  is_concurrent : bool;
+  transl_data : TranslateFormula.transl_data;
+  (* mostly the same data as above, but packed for formula translation *)
+  fluents : string list;
+}
 
 val empty_gdl_translation : gdl_translation
 
+(* [playing_as] is only used for building move translation data, the
+   game translation is independent of the selected player (a dummy
+   term can be provided). *)
 val translate_game :
-  GDL.clause list -> gdl_translation * (Arena.game * Arena.game_state)
+  playing_as:GDL.term -> GDL.clause list ->
+  gdl_translation * (Arena.game * Arena.game_state)
 
-val translate_incoming_move : 
-  gdl_translation -> (Arena.game * Arena.game_state) -> GDL.term list ->
-  string * (int * int) list
 
+(* Return a list of rewrites to apply, as triples: player number,
+   rule name, rule matching. *)
+val translate_incoming_move :
+  gdl_translation ->
+  Arena.game * Arena.game_state ->
+  GDL.term list -> (int * (string * DiscreteRule.matching)) list
+
 val translate_outgoing_move : gdl_translation -> 
   (Arena.game * Arena.game_state) -> string -> (int * int) list -> string
 

Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/GGP/TranslateGameTest.ml	2011-07-29 09:53:41 UTC (rev 1519)
@@ -43,11 +43,13 @@
           aux turn playout in
   aux players playout
 
-let game_test_case ~game_name ~player ~loc0_rule_name ~loc0_emb
+let game_test_case ~game_name ~player ~own_plnum ~opponent_plnum
+    ~loc0_rule_name ~loc0_emb
     ~loc0_move ~loc0_noop ~loc1 ~loc1_rule_name ~loc1_emb ~loc1_noop
     ~loc1_move =
   let game = load_rules ("./GGP/examples/"^game_name^".gdl") in
-  let gdl, res = TranslateGame.translate_game (*Const player*) game in
+  let gdl, res =
+    TranslateGame.translate_game ~playing_as:(Const player) game in
   let goal_name =
     (*if !GDL.prune_rulecands_at = GDL.Never
       then game_name^"-simpl-unpruned.toss"
@@ -71,9 +73,10 @@
   let transl =
     TranslateGame.translate_outgoing_move gdl res rname emb in
   assert_equal ~printer:(fun x->x) loc0_move transl;
-  let move =
+  let moves =
     TranslateGame.translate_incoming_move gdl res
       [pte loc0_move; pte loc0_noop] in
+  let move = List.assoc own_plnum moves in
   assert_equal ~msg:"own incoming move" ~printer:(emb_str res)
     (norm_move (rname, emb)) (norm_move move);
   let req = Arena.ApplyRuleInt (rname, emb, 0.1, []) in
@@ -82,9 +85,10 @@
   let rname = loc1_rule_name in
   let emb =
     Arena.emb_of_names res rname loc1_emb in
-  let move =
+  let moves =
     TranslateGame.translate_incoming_move gdl res
       [pte loc1_noop; pte loc1_move] in
+  let move = List.assoc opponent_plnum moves in
   assert_equal ~msg:"opponent incoming move"
     ~printer:(emb_str res)
     (norm_move (rname, emb)) (norm_move move)
@@ -115,6 +119,7 @@
   "tictactoe" >::
     (fun () ->
       game_test_case ~game_name:"tictactoe" ~player:"xplayer"
+    ~own_plnum:0 ~opponent_plnum:1
         ~loc0_rule_name:"mark_x64_y19_0"
         ~loc0_emb:[
           "cell_x64_y19__blank_", "cell_2_2_MV1";
@@ -133,6 +138,7 @@
   "connect5" >::
     (fun () ->
       game_test_case ~game_name:"connect5" ~player:"x"
+        ~own_plnum:0 ~opponent_plnum:1
         ~loc0_rule_name:"mark_x161_y162_0"
         ~loc0_emb:[
           "cell_x161_y162__blank_", "cell_e_f_MV1";
@@ -148,6 +154,7 @@
   "breakthrough" >::
     (fun () ->
       game_test_case ~game_name:"breakthrough" ~player:"white"
+        ~own_plnum:0 ~opponent_plnum:1
         ~loc0_rule_name:"move_x239_y257_x238_y256_0"
         ~loc0_emb:[
           "cellholds_x239_y257__blank_", "cellholds_2_2_MV1";
@@ -170,6 +177,7 @@
       (* TODO: finish adapting the test after game is
          cleanly translated. *)
       game_test_case ~game_name:"connect4" ~player:"white"
+        ~own_plnum:0 ~opponent_plnum:1
         ~loc0_rule_name:"drop_???_0"
         ~loc0_emb:[
           "cell_x_y__blank_", "cell_2_1_MV1";

Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml	2011-07-26 21:50:38 UTC (rev 1518)
+++ trunk/Toss/Server/ReqHandler.ml	2011-07-29 09:53:41 UTC (rev 1519)
@@ -51,6 +51,33 @@
 
 exception Found of int
 
+
+(* The player applying the rewrite seems not to be used. *)
+let apply_rewrite state (player, (r_name, mtch)) =
+  if r_name <> "" then (
+    let {Arena.rules=rules; graph=graph} = fst state in
+    let mv_loc = select_moving graph.((snd state).Arena.cur_loc) in
+    let moves =
+      Move.gen_moves Move.cGRID_SIZE rules
+        (snd state).Arena.struc mv_loc in
+    let pos = (
+      try
+        for i = 0 to Array.length moves - 1 do
+          let mov = moves.(i) in
+          if r_name = mov.Move.rule && List.for_all 
+	    (fun (e, f) -> f = List.assoc e mov.Move.embedding) mtch then
+	    raise (Found i)
+        done;
+        failwith "GDL Play request: action mismatched with play state"
+      with Found pos -> pos) in
+    let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
+    let (new_state_noloc, resp) = Arena.handle_request state req in
+    let new_loc = moves.(pos).Move.next_loc in
+    (fst new_state_noloc,
+     {snd new_state_noloc with Arena.cur_loc = new_loc})
+  ) else state
+
+
 let req_handle (g_heur, game_modified, state, gdl_transl, playclock) = function 
   | Aux.Left (Arena.SuggestLocMoves
                 (loc, timer, effort, _, _, heuristic, advr)) -> (
@@ -84,7 +111,7 @@
     let old_force_competitive = !Heuristic.force_competitive in
     Heuristic.force_competitive := true;
     let new_gdl_transl, new_state =
-      TranslateGame.translate_game game_descr in
+      TranslateGame.translate_game ~playing_as:player game_descr in
     let effort, horizon, advr = (None, None, None) in
     let new_heur =
       Heuristic.default_heuristic ~struc:(snd new_state).Arena.struc 
@@ -97,32 +124,10 @@
   | Aux.Right (GDL.Play (_,actions)) | Aux.Right (GDL.Stop (_,actions)) as rq ->
     let time_started = Unix.gettimeofday () in
 
-    let r_name, mtch =
+    let rewrites =
       TranslateGame.translate_incoming_move gdl_transl state actions in
 
-    let state =
-      if r_name <> "" then (
-	let {Arena.rules=rules; graph=graph} = fst state in
-	let mv_loc = select_moving graph.((snd state).Arena.cur_loc) in
-	let moves =
-          Move.gen_moves Move.cGRID_SIZE rules
-            (snd state).Arena.struc mv_loc in
-	let pos = (
-	  try
-            for i = 0 to Array.length moves - 1 do
-              let mov = moves.(i) in
-              if r_name = mov.Move.rule && List.for_all 
-		(fun (e, f) -> f = List.assoc e mov.Move.embedding) mtch then
-		raise (Found i)
-            done;
-            failwith "GDL Play request: action mismatched with play state"
-	  with Found pos -> pos) in
-	let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
-	let (new_state_noloc, resp) = Arena.handle_request state req in
-	let new_loc = moves.(pos).Move.next_loc in
-	(fst new_state_noloc,
-	 {snd new_state_noloc with Arena.cur_loc = new_loc})
-      ) else state in
+    let state = List.fold_left apply_rewrite state rewrites in
 
     let resp =
       if (match rq with 


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