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

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

Revision: 1392
          http://toss.svn.sourceforge.net/toss/?rev=1392&view=rev
Author:   lukstafi
Date:     2011-03-25 20:12:20 +0000 (Fri, 25 Mar 2011)

Log Message:
-----------
More logging. Heuristic: optional force-competitive reduces the default_heuristic_old to zero-sum (off by default, but currently always set on when playing GDL).

Modified Paths:
--------------
    trunk/Toss/Arena/Arena.ml
    trunk/Toss/Arena/Arena.mli
    trunk/Toss/Arena/ContinuousRule.ml
    trunk/Toss/Arena/ContinuousRule.mli
    trunk/Toss/Arena/DiscreteRule.ml
    trunk/Toss/Arena/DiscreteRule.mli
    trunk/Toss/GGP/GDL.ml
    trunk/Toss/Play/Heuristic.ml
    trunk/Toss/Play/Heuristic.mli
    trunk/Toss/Server/Server.ml

Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Arena/Arena.ml	2011-03-25 20:12:20 UTC (rev 1392)
@@ -322,7 +322,7 @@
   
 let equational_def_style = ref true
 
-let fprint_state ppf
+let fprint_state_full print_compiled_rules ppf
     ({rules = rules;
      graph = graph;
      num_players = num_players;
@@ -356,7 +356,7 @@
       data;
   List.iter (fun (rname, r) ->
     Format.fprintf ppf "@[<1>RULE %s:@ %a@]@ " rname
-      ContinuousRule.fprint r) rules;
+      (ContinuousRule.fprint_full print_compiled_rules) r) rules;
   Array.iter (fun loc ->
     Format.fprintf ppf "@[<1>LOC %d@ {@,@[<1>@,%a@]@,}@]@ "
       loc.id (fprint_loc_body struc player_names) loc) graph;
@@ -368,12 +368,19 @@
     Format.fprintf ppf "@[<1>TIME@ %F@]@ " time;
   Format.fprintf ppf "@]"
 
+let fprint_state = fprint_state_full false
+
 let print_state r = fprint_state Format.std_formatter r
 let sprint_state r =
   ignore (Format.flush_str_formatter ());
   fprint_state Format.str_formatter r;
   Format.flush_str_formatter ()
 
+let sprint_state_full r =
+  ignore (Format.flush_str_formatter ());
+  fprint_state_full true Format.str_formatter r;
+  Format.flush_str_formatter ()
+
 let str game = sprint_state (game, snd empty_state)
 let state_str state = sprint_state state
 

Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Arena/Arena.mli	2011-03-25 20:12:20 UTC (rev 1392)
@@ -64,9 +64,13 @@
    syntax. Defaults to [true]. *)
 val equational_def_style : bool ref
 
+val fprint_state_full :
+  bool -> Format.formatter -> game * game_state -> unit
 val fprint_state : Format.formatter -> game * game_state -> unit
 val print_state : game * game_state -> unit
 val sprint_state : game * game_state -> string
+(** For the rules of the game, also print their compiled forms. *)
+val sprint_state_full : game * game_state -> string
 
 (** The order of following entries matters: [DefPlayers] adds more
    players, with consecutive numbers starting from first available;

Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Arena/ContinuousRule.ml	2011-03-25 20:12:20 UTC (rev 1392)
@@ -227,7 +227,7 @@
 let has_update r = r.update <> []
   (* List.exists (fun ((f, a), t) -> t <> Term.FVar (f,a)) r.update *)
 
-let fprint f r =
+let fprint_full print_compiled f r =
   Format.fprintf f "@[<1>%a" DiscreteRule.fprint_rule r.discrete;
   if has_dynamics r then
     Format.fprintf f "@ @[<hv>dynamics@ %a@]"
@@ -235,6 +235,9 @@
   if has_update r then
     Format.fprintf f "@ @[<hv>update@ %a@]"
       (Term.fprint_eqs ~diff:false) r.update;
+  if print_compiled then
+    Format.fprintf f "@ @[<1>compiled@ %a@]"
+      DiscreteRule.fprint_rule_obj r.compiled;
   if r.discrete.DiscreteRule.pre <> Formula.And [] then
     Format.fprintf f "@ @[<1>pre@ %a@]" Formula.fprint
       r.discrete.DiscreteRule.pre;
@@ -244,6 +247,8 @@
     Format.fprintf f "@ @[<1>post@ %a@]" Formula.fprint r.post;
   Format.fprintf f "@]"
 
+let fprint = fprint_full false
+
 let print r = fprint Format.std_formatter r
 let sprint r =
   ignore (Format.flush_str_formatter ());

Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Arena/ContinuousRule.mli	2011-03-25 20:12:20 UTC (rev 1392)
@@ -36,6 +36,7 @@
 (** Print a rule to string. *)
 val str : rule -> string
 
+val fprint_full : bool -> Format.formatter -> rule -> unit
 val fprint : Format.formatter -> rule -> unit
 val print : rule -> unit
 val sprint : rule -> string

Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Arena/DiscreteRule.ml	2011-03-25 20:12:20 UTC (rev 1392)
@@ -1155,7 +1155,19 @@
   Formula.str obj.lhs_form ^  "-> " ^
     Formula.str (And (plits @ nlits))
 
+let fprint_rule_obj f obj =
+  let plits = Aux.concat_map (fun (r, tups) ->
+    List.map (fun tup->Rel (r,Array.map (fun v->`FO v) tup)) tups)
+    obj.rhs_pos_tuples in
+  let nlits = Aux.concat_map (fun (r, tups) ->
+    List.map (fun tup->Not (Rel (r,Array.map (fun v->`FO v) tup)))
+      tups)
+    obj.rhs_neg_tuples in
+  Format.fprintf f "@[<1>%a@ ->@ %a@]"
+    Formula.fprint obj.lhs_form
+    Formula.fprint (And (plits @ nlits))
 
+
 let fprint_matching f matching =
   let matched f (lhs,rhs) = Format.fprintf f "%d->%d" lhs rhs in
   Format.fprintf f "[@,@[%a@]@,]"

Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Arena/DiscreteRule.mli	2011-03-25 20:12:20 UTC (rev 1392)
@@ -157,6 +157,9 @@
 val fprint_rule :
   Format.formatter -> rule -> unit
 
+val fprint_rule_obj :
+  Format.formatter -> rule_obj -> unit
+
 val print_rule : rule -> unit
 
 val sprint_rule : rule -> string

Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/GGP/GDL.ml	2011-03-25 20:12:20 UTC (rev 1392)
@@ -3506,7 +3506,7 @@
   );
   if !debug_level > 1 then (
     Printf.printf "\n\nGDL.translate_game: after simplification --\n%s\n%!"
-      (Arena.sprint_state result)
+      (Arena.sprint_state_full result)
   );
   (* }}} *)
   {anchor_terms = !anchor_terms;

Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Play/Heuristic.ml	2011-03-25 20:12:20 UTC (rev 1392)
@@ -254,8 +254,12 @@
 
 let debug_level = ref 0
 
+(* Irrespective of the shape of payoffs, take the difference of
+   heuristics as the final heuristic for each player (in
+   {!Heuristic.default_heuristic_old}). *)
+let force_competitive = ref false
 (* TODO: not exporting these in the API as global variables? *)
-let default_nonmonot_adv_ratio = 2.0
+let default_nonmonot_adv_ratio = 4.0
 let default_monot_adv_ratio = 4.0
 let suggest_expansion_coef = 0.5
 
@@ -1078,15 +1082,20 @@
   let moves = match struc with | None -> [||] | Some strc ->
     Move.gen_moves Move.cGRID_SIZE rules strc graph.(0) in
   let monotonic = !use_monotonic && (Array.length moves > 60 ||
-    Aux.Strings.is_empty (Aux.Strings.inter all_poff_rels indef_frels)) in
+                                       Aux.Strings.is_empty (Aux.Strings.inter all_poff_rels indef_frels)) in
   (* {{{ log entry *)
-  if !debug_level > 1 then (
+  if !debug_level > 0 then (
     Printf.printf
       "default_heuristic_old: monotonic=%b; posi_frels=%s; nega_frels=%s;\
-  indef_frels=%s\n%!"
+  indef_frels=%s; adv_ratio=%s\n%!"
       monotonic (String.concat ", " (Aux.Strings.elements posi_frels))
       (String.concat ", " (Aux.Strings.elements nega_frels))
       (String.concat ", " (Aux.Strings.elements indef_frels))
+      (match advr with
+        | None -> "None "^ string_of_float (
+          if monotonic then default_monot_adv_ratio
+          else default_nonmonot_adv_ratio)
+        | Some r -> "Some "^ string_of_float r)
   );
   (* }}} *)
   let advr =
@@ -1105,30 +1114,45 @@
       Some (DiscreteRule.fluent_preconds drules signat
               posi_frels nega_frels indef_frels)
     else None in
-  Array.mapi (fun i node -> Array.map
-    (fun payoff ->
-      (* {{{ log entry *)
-      if !debug_level > (* 5 *) 1 then (
-        Printf.printf
-          "default_heuristic: Computing for loc %d of payoff %s...\n%!"
-          i (Formula.sprint_real payoff);
-      );
-      if !debug_level = 5 then (
-        Printf.printf
-          "default_heuristic: Computing for loc %d\n%!" i;
-      );
-      (* }}} *)
-      let res =
-        of_payoff ?struc ?fluent_preconds advr ~posi_frels ~nega_frels
-          frels payoff in
-      (* {{{ log entry *)
-      if !debug_level > (* 6 *) 1 then (
-        Printf.printf "default_heuristic: %s\n%!"
-          (Formula.sprint_real res)
-      );
-    (* }}} *)
-      res)
-    node.Arena.payoffs) graph
+  Array.mapi (fun i node ->
+    let res = Array.map
+      (fun payoff ->
+        (* {{{ log entry *)
+        if !debug_level > (* 5 *) 1 then (
+          Printf.printf
+            "default_heuristic: Computing for loc %d of payoff %s...\n%!"
+            i (Formula.sprint_real payoff);
+        );
+        if !debug_level = 5 then (
+          Printf.printf
+            "default_heuristic: Computing for loc %d\n%!" i;
+        );
+        (* }}} *)
+        let res =
+          of_payoff ?struc ?fluent_preconds advr ~posi_frels ~nega_frels
+            frels payoff in
+        (* {{{ log entry *)
+        if !debug_level > (* 6 *) 1 then (
+          Printf.printf "default_heuristic: %s\n%!"
+            (Formula.sprint_real res)
+        );
+        (* }}} *)
+        res)
+      node.Arena.payoffs in
+    if !force_competitive && Array.length res > 1
+    then
+      Array.mapi (fun p v ->
+        let opponents = ref None in
+        for i = 0 to Array.length res - 1 do
+          if i <> p then (
+            if !opponents = None then opponents := Some res.(i)
+            else opponents :=
+              Some (Plus (Aux.unsome !opponents, res.(i))))
+        done;
+        Plus (v, Times (Const (-1.), Aux.unsome !opponents))      
+      ) res
+    else res
+  ) graph
 
 let fluents_heuristic game = 
   let (no_players, rules) = (game.Arena.num_players, game.Arena.rules) in
@@ -1163,7 +1187,18 @@
     Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1
 
 let default_heuristic ?struc ?advr g =
-  mix_heur (default_heuristic_old ?struc ?advr g) 0.2 (fluents_heuristic g)
+  let res =
+    mix_heur (default_heuristic_old ?struc ?advr g) 0.2
+      (fluents_heuristic g) in
+  if !debug_level > 1 then (
+    print_endline "HEURISTIC MATRIX:";
+    Array.iteri (fun loc poffs ->
+      Array.iteri (fun player poff ->
+        Printf.printf "LOC %d, player %d:\n%s\n%!"
+          loc player (Formula.sprint_real poff)
+      ) poffs ) res;
+  );
+  res
 
 let is_constant_sum_one heur_arr =
   let is_const r1 r2 = 

Modified: trunk/Toss/Play/Heuristic.mli
===================================================================
--- trunk/Toss/Play/Heuristic.mli	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Play/Heuristic.mli	2011-03-25 20:12:20 UTC (rev 1392)
@@ -59,6 +59,11 @@
 
 val debug_level : int ref
 
+(** Irrespective of the shape of payoffs, take the difference of
+    heuristics as the final heuristic for each player (in
+    {!Heuristic.default_heuristic_old}). *)
+val force_competitive : bool ref
+
 (** Returns a disjunction of existentially quantified conjunctions of
     atoms each disjunct being equivalent to the given formula in the
     given model. Testing purposes mostly. *)

Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml	2011-03-25 17:06:20 UTC (rev 1391)
+++ trunk/Toss/Server/Server.ml	2011-03-25 20:12:20 UTC (rev 1392)
@@ -205,10 +205,9 @@
 	    let heur = match !game_modified, !g_heur with
 	      | false, Some h -> h
 	      | true, _ | _, None -> 
-		let adr = match advr with Some a -> a | None -> 4. in
 		g_heur := Some (Heuristic.default_heuristic 
 				  ~struc:(snd !state).Arena.struc 
-				  ~advr:adr (fst !state));
+				  ?advr (fst !state));
 		Aux.unsome !g_heur in
 	    let (move, _) = Play.maximax_unfold_choose effort
 	      (fst !state) (snd !state) heur in
@@ -297,6 +296,8 @@
 
         | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) ->
           Random.self_init (); (* Random.init 1234; for repeatablity *)
+          let old_force_competitive = !Heuristic.force_competitive in
+          Heuristic.force_competitive := true;
           let new_state, params, new_gdl_transl =
             GDL.initialize_game player game_descr startcl in
           state := new_state; gdl_transl := new_gdl_transl;
@@ -313,7 +314,8 @@
           playclock := playcl;
           g_heur := Some (Heuristic.default_heuristic
 			    ~struc:(snd !state).Arena.struc 
-			    ~advr:4. (fst !state));
+			    ?advr (fst !state));
+          Heuristic.force_competitive := old_force_competitive;          
           "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 5"
           ^ "\r\n\r\nREADY"
 


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