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

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

Revision: 1320
          http://toss.svn.sourceforge.net/toss/?rev=1320&view=rev
Author:   lukaszkaiser
Date:     2011-02-13 23:17:36 +0000 (Sun, 13 Feb 2011)

Log Message:
-----------
Fluents heuristic, ability to run experiments from server.

Modified Paths:
--------------
    trunk/Toss/Arena/Arena.ml
    trunk/Toss/Arena/Arena.mli
    trunk/Toss/Arena/DiscreteRule.ml
    trunk/Toss/Arena/DiscreteRule.mli
    trunk/Toss/Play/Game.ml
    trunk/Toss/Play/Game.mli
    trunk/Toss/Server/Server.ml

Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Arena/Arena.ml	2011-02-13 23:17:36 UTC (rev 1320)
@@ -69,6 +69,14 @@
 
 (* -------------------- PARSER HELPER ------------------------------ *)
 
+(* Rules with which a player with given number can move. *)
+let rules_for_player player_no game =
+  let rules_of_loc l = 
+    if l.player = player_no then
+      Some (List.map (fun (lab, _) -> lab.rule) l.moves)
+    else None in
+  List.concat (Aux.map_some rules_of_loc (Array.to_list game.graph))
+
 (* Add a defined relation to a structure. *)
 let add_def_rel_single struc (r_name, vars, def_phi) =
   let def_asg = Solver.M.evaluate struc 

Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Arena/Arena.mli	2011-02-13 23:17:36 UTC (rev 1320)
@@ -43,6 +43,9 @@
 
 val empty_state : game_state
 
+(** Rules with which a player with given number can move. *)
+val rules_for_player : int -> game -> string list
+
 val add_def_rels : Structure.structure ->
   (string * string list * Formula.formula) list -> Structure.structure
 

Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Arena/DiscreteRule.ml	2011-02-13 23:17:36 UTC (rev 1320)
@@ -47,7 +47,15 @@
 }
    
 (* We call fluents the relations that can be modified by a rule. *)
-let fluents r =
+let fluents_make ?(only_pos=false) f r =
+  let fl_make (s, tp) = 
+    if tp = [] then None else
+      Some (f s (Array.length (List.hd tp))) in
+  if only_pos then
+    Aux.map_some fl_make r.rhs_pos_tuples
+  else Aux.map_some fl_make (r.rhs_pos_tuples @ r.rhs_neg_tuples)
+
+let fluents r = 
   let map_rels =
     Aux.map_some (fun (rel,tups)->if tups=[] then None else Some rel) in
   map_rels r.rhs_pos_tuples @ map_rels r.rhs_neg_tuples

Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Arena/DiscreteRule.mli	2011-02-13 23:17:36 UTC (rev 1320)
@@ -44,6 +44,8 @@
 
 (* We call fluents the relations that can be modified by a rule. *)
 val fluents : rule_obj -> string list
+val fluents_make : ?only_pos : bool -> (string -> int -> 'a) ->
+  rule_obj -> 'a list
    
 (* A relation is monotonic if it cannot remove tuples. *)
 val monotonic : rule_obj -> bool

Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Play/Game.ml	2011-02-13 23:17:36 UTC (rev 1320)
@@ -287,6 +287,28 @@
       res)
     node.Arena.payoffs) graph
 
+let fluents_heuristic game = 
+  let (no_players, rules) = (game.Arena.num_players, game.Arena.rules) in
+  let pl_rules = Array.mapi
+    (fun i _ -> Arena.rules_for_player i game) (Array.create no_players 1) in
+  let pos_fluents_of_rule rname =
+    let drule = (List.assoc rname rules).ContinuousRule.compiled in
+    let list_upto_one s i =
+      let vx = Formula.fo_var_of_string "x" in
+      if i = 0 then Formula.Const (0.) else if i = 1 then
+	  Formula.Sum ([vx], Formula.Rel (s, [|vx|]), Formula.Const (1.))
+	else Formula.Const (0.) in
+    DiscreteRule.fluents_make ~only_pos:true list_upto_one drule in
+  let pl_fluents = Array.map (Aux.concat_map pos_fluents_of_rule) pl_rules in
+  let sums = Array.map (fun fl -> 
+    List.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.))
+      (Aux.unique_sorted fl)) pl_fluents in
+  let sum_all =
+    Array.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) sums in
+  let heurs = Array.map (fun f -> 
+    Formula.Plus (Formula.Times (Formula.Const (2.), f),
+		  Formula.Times (Formula.Const (-1.), sum_all))) sums in
+  Array.map (fun _ -> heurs) game.Arena.graph
 
 (* The UCB1-TUNED estimate, modified to extend to the zero- and
    one-observation cases. *)
@@ -1072,7 +1094,7 @@
   match res with
     | Aux.Left (_,_,_,state) ->
       (* {{{ log entry *)
-      if !debug_level > 5 || (!debug_level > 1 && set_timer <> None) then
+      if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then
         printf "step-state:\n%s\n%!" (Structure.str state.game_state.struc);
       (* }}} *)
       play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state

Modified: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Play/Game.mli	2011-02-13 23:17:36 UTC (rev 1320)
@@ -213,7 +213,13 @@
 val suggest : ?effort:int ->
   play -> play_state -> (move * play_state) option
 
+(** Various constructed heuristics. *)
+val default_heuristic : ?struc:Structure.structure -> float ->
+  Arena.game -> Formula.real_expr array array
 
+val fluents_heuristic : Arena.game -> Formula.real_expr array array
+
+
 (* ------------------------- DEBUGGING ------------------------------------- *)
 
 (** Debugging information. At level 0 nothing is printed out.

Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml	2011-02-13 17:46:00 UTC (rev 1319)
+++ trunk/Toss/Server/Server.ml	2011-02-13 23:17:36 UTC (rev 1320)
@@ -268,7 +268,7 @@
 
         | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) ->
           (* GDL will store the player and the game in its state. *)
-          Random.init 1234; (* for repeatablity *)
+          Random.self_init (); (* Random.init 1234; for repeatablity *)
           let effort, horizon, heur_adv_ratio =
             GDL.initialize_game state player game_descr startcl in
           (* TODO: handle timer (startclock) in Game.initialize_default*)
@@ -490,6 +490,96 @@
       output_string out_ch ("ERR internal error -- see server stdout\n")
 
 
+let set_state_from_file fn =
+  Printf.printf "Loading file %s...\n%!" fn;
+  let f = open_in fn in
+  let s = ArenaParser.parse_game_state Lexer.lex (Lexing.from_channel f) in
+  Printf.printf "File %s loaded.\n%!" fn;
+  game_modified := true;
+  state := s;
+;;
+
+let heur_val_white1 = ref "";;
+let heur_val_black1 = ref "";;
+let heur_val_white2 = ref "";;
+let heur_val_black2 = ref "";;
+
+let heur_of_vals white_val black_val =
+  let real_expr_of_str s = 
+    FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s) in
+  let white_heur =
+    real_expr_of_str ("("^white_val^") - ("^black_val^")") in
+  let black_heur =
+    real_expr_of_str ("("^black_val^") - ("^white_val^")") in
+  let heuristic = [|white_heur; black_heur|] in
+  Array.make (Array.length !state.Arena.game.Arena.graph) heuristic
+;;
+
+let print_heur pl heur =
+  print_endline ("\nAll-Heuristics for player " ^ pl);
+  let print_heur_arr = Array.iteri (fun i heur ->
+    print_endline ("\n    for player " ^ (string_of_int i));
+    print_endline ("    " ^ Formula.sprint_real heur);) in
+  Array.iteri (fun i harr ->
+    print_endline ("\nHeuristic for location " ^ (string_of_int i));
+    print_heur_arr harr;) heur
+;;
+
+let add_heur h1 factor h2 =
+  Array.mapi (fun i a -> Array.mapi (fun j p ->
+    Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1
+;;
+
+let run_test n depth1 depth2 =
+  let (horizon, heur_adv_ratio) = (Some 400, 2.0) in
+  let struc = !state.Arena.struc in
+  let game = !state.Arena.game in
+  let heur1 =
+    if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then
+      let dh = 
+	Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in
+      add_heur dh 0.2 (Game.fluents_heuristic game)
+    else if (!heur_val_white1 = "FLUENT" || !heur_val_black1 = "FLUENT") then
+      Game.fluents_heuristic game
+    else if (!heur_val_white1 <> "" && !heur_val_black1 <> "") then
+      heur_of_vals !heur_val_white1 !heur_val_black1
+    else
+      Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in
+  let heur2 =
+    if (!heur_val_white2 = "MIX" || !heur_val_black2 = "MIX") then
+      let dh = 
+	Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in
+      add_heur dh 0.2 (Game.fluents_heuristic game)
+    else if (!heur_val_white2 = "FLUENT" || !heur_val_black2 = "FLUENT") then
+      Game.fluents_heuristic game
+    else if (!heur_val_white2 <> "" && !heur_val_black2 <> "") then
+      heur_of_vals !heur_val_white2 !heur_val_black2
+    else
+      Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in
+  if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2);
+  let play = {Game.game = game; agents=
+      [| Game.default_maximax !state.Arena.struc ~depth:depth1
+          ~heuristic:heur1 ~heur_adv_ratio ~pruning:true game;
+         Game.default_maximax !state.Arena.struc ~depth:depth2
+           ~heuristic:heur2 ~heur_adv_ratio ~pruning:true game;
+      |]; delta = 2.0} in           (* FIXME: give/calc delta *)
+  let init_state = Game.initial_state play struc in
+  Game.set_debug_level 1;
+  let (aggr_payoff_w, aggr_payoff_b) = (ref 0., ref 0.) in
+  Printf.printf "Experiment -- running test!\n";
+  for i = 1 to n do (
+    Random.self_init ();
+    Printf.printf "Experiment: Game nr %d of %d\n%!" i n;
+    let _,payoff = Game.play ~grid_size:Game.cGRID_SIZE ~set_timer:3600
+      ?horizon play init_state in
+    Printf.printf "Game %d payoffs %f, %f\n" i payoff.(0) payoff.(1);
+    aggr_payoff_w := !aggr_payoff_w +. payoff.(0);
+    aggr_payoff_b := !aggr_payoff_b +. payoff.(1);
+    Printf.printf "Aggregate payoffs %f, %f\n" !aggr_payoff_w !aggr_payoff_b;
+  ) done;
+;;
+
+
 (* ----------------------- START SERVER WHEN CALLED ------------------------- *)
 
 let main () =
@@ -498,6 +588,7 @@
              Gc.minor_heap_size = 80*1024; (* 2*std, opt ~= L2 cache/proc *)
              Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
   let (server, port) = (ref "localhost", ref 8110) in
+  let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
   let opts = [
     ("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose");
     ("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose");
@@ -506,12 +597,27 @@
     ("-gdl", Arg.String (fun s ->
       GDL.manual_game := s; GDL.manual_translation := true),
      " GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)");
+    ("-f", Arg.String (fun s -> set_state_from_file s), " open file");
     ("-nm", Arg.Unit (fun () -> Game.use_monotonic := false), " turn monotonicity off");
     ("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)");
     ("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)");
+    ("-heur-white-1", Arg.String (fun s -> heur_val_white1 := s), 
+     "white (=first) player heuristic for use by the first player in tests");
+    ("-heur-black-1", Arg.String (fun s -> heur_val_black1 := s), 
+     "black (=second) player heuristic for use by the first player in tests");
+    ("-heur-white-2", Arg.String (fun s -> heur_val_white2 := s), 
+     "white (=first) player heuristic for use by the second player in tests");
+    ("-heur-black-2", Arg.String (fun s -> heur_val_black2 := s), 
+     "black (=second) player heuristic for use by the second player in tests");
+    ("-experiment", 
+     Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i);
+		Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)],
+     "run experiment on the open file [i] times with depth [d1, d2]")
   ] in  
   Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
-  try
+  if !experiment then
+    run_test !e_len !e_d1 !e_d2
+  else try
     start_server req_handle !port !server
   with Host_not_found -> print_endline "The host you specified was not found."
 ;;


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