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

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

Revision: 1409
          http://toss.svn.sourceforge.net/toss/?rev=1409&view=rev
Author:   lukaszkaiser
Date:     2011-04-14 01:58:27 +0000 (Thu, 14 Apr 2011)

Log Message:
-----------
More work on PlayTest and GameTree stability.

Modified Paths:
--------------
    trunk/Toss/Formula/Aux.ml
    trunk/Toss/Formula/Aux.mli
    trunk/Toss/Play/GameTree.ml
    trunk/Toss/Play/GameTree.mli
    trunk/Toss/Play/Play.ml
    trunk/Toss/Play/Play.mli
    trunk/Toss/Play/PlayTest.ml
    trunk/Toss/Server/Server.ml

Removed Paths:
-------------
    trunk/Toss/Play/Game.mli

Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Formula/Aux.ml	2011-04-14 01:58:27 UTC (rev 1409)
@@ -211,6 +211,11 @@
   | hd::tl -> hd::(remove_one e tl)
   | [] -> []
 
+let rec remove_last = function
+  | [] -> raise Not_found
+  | [_] -> []
+  | x :: xs -> x :: (remove_last xs)
+
 let rec insert_nth n e = function
   | l when n<=0 -> e::l
   | [] -> raise Not_found

Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Formula/Aux.mli	2011-04-14 01:58:27 UTC (rev 1409)
@@ -136,6 +136,9 @@
 (** Remove an occurrence of a value (uses structural equality). *)
 val remove_one : 'a -> 'a list -> 'a list
 
+(** Remove the last element in a list; raise Not_found for []. *)
+val remove_last : 'a list -> 'a list
+
 (** Insert as [n]th element of a list (counting from zero). Raise
     [Not_found] if the list has less than [n] elements (e.g. inserting
     0th element to empty list is OK). *)

Deleted: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Game.mli	2011-04-14 01:58:27 UTC (rev 1409)
@@ -1,196 +0,0 @@
-(** Game-related definitions. The UCTS algorithm. *)
-
-(** Default effort used in {!Game.initialize_default} when not
-    otherwise specified. *)
-val default_effort : int ref
-
-(** A global "hurry up!" switch triggered by the timer alarm. *)
-val get_timeout : unit -> bool
-val cancel_timeout : unit -> unit
-
-(** History stored for a play, including caching of computations for
-    further use. *)
-type memory
-    
-(** Effect that heuristics have on the MCTS algorithm. *)
-type mcts_heur_effect =
-  | Heuristic_local of float            (** TODO: not implemented *)
-      (** each tree node only considers the heuristic of its state,
-          the parameter is the influence of the heuristic on the tree
-          traversal, there is no influence on the actual choice *)
-  | Heuristic_mixed of float * float
-      (** a node stores a heuristic maximaxed from the leaf states of
-          the subtree, [MaximaxMixed (trav, select)] has [trav]
-          the influence on the tree traversal, [select] the influence
-          on the actual choice *)
-  | Heuristic_select of float
-      (** a node stores a heuristic maximaxed from the leaf states of
-          the subtree, the parameter is the influence on the tree
-          traversal, the actual choice is based on the heuristic alone
-          and not the Monte-Carlo payoff estimates *)
-  | Heuristic_only
-      (** a node stores a heuristic maximaxed from the leaf states of
-          the subtree, which completely replaces the role of the
-          Monte-Carlo payoff estimates from the standard UCT algorithm *)
-      
-
-
-(** Parameters of the Upper Confidence Bounds-based Monte Carlo Tree
-    Search. Cooperative (competitive) mode means that of actions with
-    equal value for a given player, the one with highest (lowest) sum
-    of values is chosen. *)
-type uct_params = {
-  cUCB : float ;   (** coefficient of the confidence bound component *)
-  constK : float ;                   (** smoothening *)
-  iters : int ;                      (** tree updates per move *)
-  horizon : int option ;             (** limit on the playout length *)
-  heur_effect : mcts_heur_effect ;   (** maximaxed vs local heuristic *)
-  cooperative : bool ;               (** cooperative vs competitive *)
-  cLCB : float option ; (** cautious action picking; if present, use
-                            lower confidence bound with given
-                            coefficient for action selection *)
-}  
-
-
-(** An evaluation game is a set of games specific to locations, each
-    game is used to assess the value of its location. It contains the
-    same data as {!play} plus {!play_state} (for initial state) below,
-    only without the [model] and [time] fields, and with some general
-    playout parameters. *)
-type evgame_loc = {
-  ev_game : Arena.game;
-  ev_agents : agent array;
-  ev_delta : float;
-  ev_location : int;
-  ev_memory : memory array;
-  ev_horizon : int option;
-}
-and evaluation_game = evgame_loc array
-
-(** How does a player pick moves. *)
-and agent =
-  | Random_move
-      (** select a random move; avoids rewriting all matches and
-          calling evaluation games *)
-  | Maximax_evgame of evaluation_game * bool * int * bool
-  (** select a move according to evaluation games played in each leaf
-      state; in a cooperative/competitive way (see {!uct_params});
-      expand the full game subtree to the given depth and propagate
-      evaluation game results from leaves by taking
-      cooperative/competitive best move for location's player; optional
-      alpha-beta-like pruning with move reordering based on
-      afterstate heuristic value *)
-  | Tree_search of evaluation_game * int option * uct_params * agent array
-      (** Monte-Carlo tree search; uses the evaluation game to compute
-          heuristic values for use within the tree *)
-  | External of (string array -> int)
-      (** take an array of string representations of resulting
-          structures and return the position of the desired state; for
-          interacting with external players only *)
-
-(** The evolving state of a play. *)
-type play_state = {
-  game_state : Arena.game_state ;
-  memory : memory array ;               (** player-specific history *)
-}
-
-(** Data defining a play (without the initial play state). *)
-type play = {
-  game : Arena.game ;                   (** the game played *)
-  agents : agent array ;                (** location.id-indexed *)
-  delta : float ;                       (** expected width of payoffs *)
-}
-
-(** Initial state of the game given a play definition and initial
-    structure, assuming the game starts in location at position 0 of
-    {!Arena.game}. *)
-val initial_state : ?loc:int -> play -> Structure.structure -> play_state
-
-val default_params : uct_params
-
-(** An UCT-based agent that uses either random playouts (when
-    [random_playout] is set to true) or the same location-dependent
-    heuristic as an evaluation game as given for the inside-tree
-    (including unevaluated tips) calculation. *)
-val default_treesearch : Structure.structure ->
-  iters:int -> ?heuristic:Formula.real_expr array array ->
-  ?advr:float ->
-  ?random_playout:bool -> ?playout_mm_depth:int ->
-  ?heur_effect:mcts_heur_effect -> ?horizon:int ->
-  Arena.game -> agent
-
-
-(** Plain limited depth maximax tree search. *)
-val default_maximax : Structure.structure -> depth:int ->
-  ?heuristic:Formula.real_expr array array ->
-  ?advr:float -> ?pruning:bool ->
-  Arena.game -> agent
-
-
-(** Update "memory" assuming that the position given corresponds to a
-    move selected, as generated by {!gen_moves}. With tree search,
-    selects the corresponding subtree of a tree. *)
-val update_memory : num_players:int -> Arena.game_state -> int ->
-  memory array -> memory array
-
-(** Make a move in a play, or compute the payoff table when the game
-    ended. Return the move chosen and the moves considered. One can
-    use only the {!move} to suggest a move, or only the updated
-    {!play_state} to follow a move (or both). Note that some
-    computations are cached across play states, but that memory is not
-    stored in the suggested move. If [just_payoffs] is given true,
-    just compute the payoff table without computing available
-    moves. *)
-val toss :
-  grid_size:int -> ?just_payoffs:bool ->
-  play -> play_state ->
-  (int * Move.move array * memory array * play_state,
-   float array) Aux.choice
-
-(** Play a play, by applying {!toss}, till the end. Return the final
-    structure and its payoff. Discretize continuous move parameters
-    using [grid_size] nodes per parameter. Limit the length of a play
-    that started [plys] ago to no more than [horizon] steps
-    overall.
-
-    The [set_timer] should be only provided for standalone plays. For
-    suggestions, the timer is set by {!Server}. It limits time per
-    move, given in seconds. *)
-val play :
-  grid_size:int -> ?set_timer:int -> ?horizon:int -> ?plys:int ->
-  play -> play_state -> Structure.structure * float array
-
-(** Initialize a play. Optionally, take heuristics for use as simple
-    evaluation games -- if not given, heuristics are derived from
-    payoffs by {!Heuristic.of_payoff}. Moves suggested using given
-    search method ("maximax", "alpha_beta", "alpha_beta_ord",
-    "uct_random_playouts",
-    "uct_greedy_playouts", "uct_maximax_playouts", "uct_no_playouts").
-
-    Construct a default UCT tree search or plain maximax agent for use
-    with the general {!toss} function. *)
-val initialize_default :
-  Arena.game * Arena.game_state -> ?loc:int -> ?effort:int ->
-  search_method:string -> ?horizon:int -> ?advr:float ->
-  ?payoffs_already_tnf:bool ->
-  ?heuristic:Formula.real_expr array array ->
-  unit -> play * play_state
-
-(** Suggest a (currently, single) move for a state, return the same
-    state but with accrued computation (i.e. bigger stored search
-    trees). *)
-val suggest : ?effort:int ->
-  play -> play_state -> (Move.move * play_state) option
-
-
-(* ------------------------- DEBUGGING ------------------------------------- *)
-
-(** Debugging information. At level 0 nothing is printed out.
-    At level 1, we print only the number of iterations which passed.
-    If > 1, print the updated gametree at each move using
-    treesearch. *)
-val set_debug_level : int -> unit
-
-(** If true, do not randomize the final choice of move. Useful mostly
-    for debugging. *)
-val deterministic_suggest : bool ref

Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/GameTree.ml	2011-04-14 01:58:27 UTC (rev 1409)
@@ -220,10 +220,9 @@
     ~choice:(choice_f heur (choice stop_vals))
 
 (* Choose one of the maximizing moves (at random) given a game tree. *)
-let choose_move game = function
+let choose_moves game = function
   | Terminal _ -> raise Not_found
-  | Leaf (state, _, _) -> 
-    Aux.random_elem (Array.to_list (Move.list_moves game state))
+  | Leaf (state, _, _) -> Array.to_list (Move.list_moves game state)
   | Node (_, p, info, succ) ->
     let cmp (_, c1) (_, c2) = 
       let nval child = (node_values child).(p) in
@@ -236,19 +235,19 @@
 	Aux.array_find_all (fun (_,c) -> (node_values c).(p) = mval) succ in
     let nonleaf = function Leaf _ -> false | _ -> true in
     let move_s (m, n) = Move.move_gs_str_short (state n) m in
-    if !debug_level > 0 then print_endline 
+    if !debug_level > 2 then print_endline 
       ("\nBest Moves: " ^ (String.concat ", " (List.map move_s maxs)));
     if List.exists (fun x -> nonleaf (snd x)) maxs then (
-      let (m, t) = Aux.random_elem maxs in (m, state t)
+      List.map (fun (m, t) -> (m, state t)) maxs
     ) else ( (* Do *not* take a shallow leaf if possible. *)
       let nonleaves = Aux.array_find_all (fun (_,c) -> nonleaf c) succ in
       if nonleaves = [] then (
-	let (m, t) = Aux.random_elem maxs in (m, state t)
+	List.map (fun (m, t) -> (m, state t)) maxs
       ) else (
 	let upd_max mv (_, c) = max mv (node_values c).(p) in
 	let sx = (node_values (snd (List.hd nonleaves))).(p) in
 	let mx = List.fold_left upd_max sx nonleaves in
 	let mxs = List.filter (fun (_,c) -> (node_values c).(p)=mx) nonleaves in
-	let (m, t) = Aux.random_elem mxs in (m, state t)
+	List.map (fun (m, t) -> (m, state t)) mxs
       )
     )

Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/GameTree.mli	2011-04-14 01:58:27 UTC (rev 1409)
@@ -76,8 +76,9 @@
 val node_info : 'a game_tree -> 'a
 
 
-(** Choose one of the maximizing moves (at random) given a game tree. *)
-val choose_move : Arena.game -> 'a game_tree -> Move.move * Arena.game_state
+(** Choose all maximizing moves given a game tree. *)
+val choose_moves : Arena.game -> 'a game_tree ->
+  (Move.move * Arena.game_state) list
 
 
 (** Game tree initialization. *)

Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Play.ml	2011-04-14 01:58:27 UTC (rev 1409)
@@ -46,31 +46,50 @@
     ~info_node:(maxdepth_node) ~choice:(maximax_depth_choice ab)
 
 (* Maximax unfolding upto depth. *)
-let rec unfold_maximax_upto ?(ab=false) count game heur t =
-  if count = 0 || timed_out () then t else  
+let rec unfold_maximax_upto ?(ab=false) count game heur (t, pmvs) =
+  let mvs = (choose_moves game t) :: pmvs in
+  if count = 0 || timed_out () then (t, mvs) else  
     try
       let u = unfold_maximax ~ab:ab game heur t in
       if !debug_level > 0 then Printf.printf "%d,%!" (size u);
-      unfold_maximax_upto ~ab:ab (count-1) game heur u
+      if !debug_level > 1 then (
+	let move_s (m, n) = Move.move_gs_str_short n m in
+	let mstr = String.concat ", " (List.map move_s (List.hd mvs)) in
+	Printf.printf "(%s),%!" mstr
+      );
+      unfold_maximax_upto ~ab:ab (count-1) game heur (u, mvs)
     with 
-      | Not_found -> t 
+      | Not_found -> (t, mvs) 
       | Aux.Timeout msg ->
 	if !debug_level > 0 then 
-	  if !debug_level > 0 then Printf.printf "Timeout %f (%s)%!" 
+	  Printf.printf "Timeout %f (%s)%!" 
 	    (Unix.gettimeofday() -. !timeout) msg;
-	t
+	(t, mvs)
 
 (* Maximax unfold upto depth and choose move. *)
-let maximax_unfold_choose count game state heur =
+let maximax_unfold_choose ?(check_stable=3) count game state heur =
   let ab = Heuristic.is_constant_sum heur in (* TODO: payoffs as well! *)
   if !debug_level > 0 then Printf.printf "Using Alpha-Beta: %B\n%!" ab;
   if !debug_level > 3 then 
     Array.iter (fun h -> Array.iter Formula.print_real h) heur;
   let t = init game state (fun _ _ _ -> 0) heur in
-  let u = unfold_maximax_upto ~ab count game heur t in
-  if !debug_level > 1 then 
-    print_endline (str ~upto:1 ~struc:false string_of_int u);
-  choose_move game u
+  try
+    let (u, mvs) = unfold_maximax_upto ~ab count game heur (t, []) in
+    let nbr_to_check = min (2*check_stable + 1) (List.length mvs / 3) in
+    let last_mvs = Aux.take_n (max 1 nbr_to_check) mvs in
+    if !debug_level = 2 then 
+      print_endline (str ~upto:1 ~struc:false string_of_int u);
+    if !debug_level > 2 then
+      print_endline (str ~upto:(!debug_level-1) string_of_int u);
+    let rec ord_sub = function
+      | ([], _) -> true
+      | (x :: xs, []) -> false
+      | (x :: xs, y :: ys) when x = y -> ord_sub (xs, ys)
+      | (x :: xs, y :: ys) -> ord_sub (x :: xs, ys) in
+    let nbr mv = List.length (List.filter (fun m -> ord_sub (mv,m)) last_mvs) in
+    let mvs_votes = List.map (fun m -> (m, nbr m)) last_mvs in
+    fst (List.hd (List.stable_sort (fun (_, i) (_, j) -> j - i) mvs_votes))
+  with Not_found -> []
 
 
 (* -------------------- UCT ------------------ *)
@@ -117,8 +136,8 @@
   if parent_sc.score_obs = 0 then failwith
     "ucb1_tuned: parent has no observations";
   let cHEUR = match params.heur_effect with
-    | (c, _) when not lower_bound -> c
-    | (_, c) when lower_bound -> c in
+    | (_, c) when lower_bound -> c
+    | (c, _) -> c in
   let i2f = float_of_int in
   let tot = i2f parent_sc.score_obs in
   let vari = score.variation_table.(player) in

Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Play.mli	2011-04-14 01:58:27 UTC (rev 1409)
@@ -13,11 +13,13 @@
   int GameTree.game_tree -> int GameTree.game_tree
   
 
-(** Maximax unfolding upto depth. *)
+(** Maximax unfolding upto depth, keep previous moves for stability. *)
 val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
   Formula.real_expr array array ->
-  int GameTree.game_tree -> int GameTree.game_tree
+    int GameTree.game_tree * (Move.move * Arena.game_state) list list ->
+      int GameTree.game_tree * (Move.move * Arena.game_state) list list
 
 (** Maximax unfold upto depth and choose move. *)
-val maximax_unfold_choose : int -> Arena.game -> Arena.game_state ->
-  Formula.real_expr array array -> Move.move * Arena.game_state
+val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
+  Arena.game_state -> Formula.real_expr array array ->
+    (Move.move * Arena.game_state) list

Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/PlayTest.ml	2011-04-14 01:58:27 UTC (rev 1409)
@@ -25,24 +25,27 @@
 
 
 let test_maximax ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0) 
-    ~iters gname ?(msg="") ?(nomove=false) check_fun =
-  let (g, s) = state_of_file ("./examples/"^gname^".toss") ~struc ~time ~loc in
+    ~iters ~game ?(msg="") ?(nomove=false) cond =
+  let (g, s) = state_of_file ("./examples/"^game^".toss") ~struc ~time ~loc in
   GameTree.set_debug_level debug;
   Play.set_debug_level debug;
   let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr g in
-  try 
-    let (m, ns) = Play.maximax_unfold_choose iters g s h in
-    let move_str = Move.move_gs_str_short s m in
-    assert_bool
-      (Printf.sprintf "%s: Failed move: %s." msg move_str) (check_fun move_str)
-  with Not_found ->
-    if nomove then assert_bool "No Move: Test Passed" true else
-      assert_bool "No Move: Test Failed!" false
+  let res_mvs = Play.maximax_unfold_choose iters g s h in
+  if res_mvs <> [] then
+    List.iter (fun (m, ns) ->
+      let move_str = Move.move_gs_str_short s m in
+      assert_bool
+	(Printf.sprintf "%s: Failed move: %s." msg move_str) (cond move_str)
+    ) res_mvs
+  else if nomove then 
+    assert_bool "No Move: Test Passed" true 
+  else
+    assert_bool "No Move: Test Failed!" false
 
-let test_algo algo ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0) 
-    ~iters gname ?(msg="") ?(nomove=false) check_fun =
+let test_algo algo ~game ~iters ?(advr=4.) ?(debug=0)
+    ?(struc="") ?(time=0.) ?(loc=0) ?(nomove=false) ?(msg="") cond =
   if algo = "Maximax" then
-    test_maximax ~debug ~advr ~struc ~time ~loc ~iters gname ~nomove check_fun
+    test_maximax ~debug ~advr ~struc ~time ~loc ~iters ~game ~nomove ~msg cond
   else failwith "Unsupported play algorithm"
 
 
@@ -68,27 +71,21 @@
       let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
       let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
       let t = GameTree.init g s (fun _ _ _ -> 0) h in
-      let u = Play.unfold_maximax_upto 50 g h t in
+      let (u, _) = Play.unfold_maximax_upto 50 g h (t, []) in
       (* print_endline (GameTree.str string_of_int u); *)
       assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u);
 
-      let u1 = Play.unfold_maximax_upto ~ab:true 50 g h t in
+      let (u1, _) = Play.unfold_maximax_upto ~ab:true 50 g h (t, []) in
       (* print_endline (GameTree.str string_of_int u1); *)
       assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u1);
     );
 
-  "checkers suggest first move 5 iters" >::
-    (fun () ->
-      test_maximax "Checkers" ~debug:0 ~iters:5
-	~msg:"make any first move in checkers after 5 iters" (fun s -> true)
-    );
 ]
 
 
 let tictactoe_tests algo iters = 
-  let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
-    test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters 
-      "Tic-Tac-Toe" ~msg check_f in
+  let test_do ?(iters=iters) =
+    test_algo algo ~game:"Tic-Tac-Toe" ~iters ~advr:5. in
   ("Tic-Tac-Toe (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
 
     "basic defense" >::
@@ -192,9 +189,8 @@
   ]
 
 let breakthrough_tests algo iters = 
-  let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
-    test_algo algo ~debug:0 ~advr:2. ~struc ~time ~loc ~iters 
-      "Breakthrough" ~msg check_f in
+  let test_do ?(iters=iters) =
+    test_algo algo ~game:"Breakthrough" ~iters ~advr:2. in
   ("Breakthrough (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
 
     "avoid endgame" >::
@@ -325,119 +321,16 @@
 
 
 let gomoku8x8_tests algo iters = 
-  let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
-    test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters 
-      "Gomoku" ~msg check_f in
+  let test_do ?(iters=iters) =
+    test_algo algo ~game:"Gomoku" ~iters ~advr:5. in
   ("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
 
-    "avoid endgame 1" >::
+    "simple attack" >::
       (fun () ->
 	let struc = "MODEL [ |  | ] \"
 	   ...   ...   ...   ...
 	   ...   ...   ...   ...
 	...   ...   ...   ...   
-	...   ...   ...   ...   
-	   ...   ...   ...   ...
-	   ...   ...P  ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-	   ...   ...   ...   ...
-	   Q..   P..P  ...   ...
-	...   ...   ...   ...   
-	...Q  ...   ...   ...   
-	   ...   ...   ...   ...
-	   Q..   ...   ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
-        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-	test_do ~struc ~loc:0 ~msg:"P should block"
-          (fun mov_s -> "Cross{1:b5}" = mov_s)
-      );
-
-    "avoid endgame 2" >::
-      (fun () ->
-	let struc = "MODEL [ |  | ] \"
-	   ...   ...   ...   ...
-	   ...   ...   ...   ...
-	...   ...   ...   ...   
-	...   Q..Q  Q..   ...   
-	   ...   ...   ...   ...
-	   ...   ...P  ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-	   ...   ...   ...   ...
-	   ...   P..P  ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-	   ...   ...   ...   ...
-	   ...   ...   ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
-        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-	test_do ~struc ~loc:0 ~msg:"P should block with line"
-          (fun mov_s -> "Cross{1:f7}" = mov_s);
-      );
-
-
-    "block gameover" >::
-      (fun () ->
-	let struc = "MODEL [ |  | ] \"
-	   ...   ...   ...   ...
-	   ...   ...   ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-	   ...   ...   ...   ...
-	   ...   P..   ...   ...
-	...   ...   ...   ...   
-	...   ...P  P..Q  ...   
-	   ...   ...   ...   ...
-	   ...   P..P  ...Q  ...
-	...   ...   ...   ...   
-	...Q  Q..Q  Q..P  ...   
-	   ...   ...   ...   ...
-	   ...   ...   ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
-        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-	test_do ~struc ~loc:0 ~msg:"P should block"
-          (fun mov_s -> "Cross{1:a3}" = mov_s);
-      );
-
-
-    "more pieces" >::
-      (fun () ->
-	let struc = "MODEL [ |  | ] \"
-	   ...   ...   ...   ...
-	P  ...   ...   ...   ...
-	...   ...   ...   ...   
-	...   ...   ...   ...   
-	   ...   ...   ...   ...
-	   ...P  Q..Q  Q..   ...
-	...   ...   ...   ...   
-	...Q  Q..Q  P..P  ...   
-	   ...   ...   ...   ...
-	   Q..Q  P..Q  P..   ...
-	...   ...   ...   ...   
-	...P  Q..P  ...P  ...   
-	   ...   ...   ...   ...
-	   ...P  ...   P..   ...
-	...   ...   ...   ...   
-	...   ...   ...Q  ...   
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
-        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-	test_do ~struc ~loc:0 ~msg:"P should block the open line"
-          (fun mov_s -> "Cross{1:e7}" = mov_s);
-      );
-
-    "attack" >::
-      (fun () ->
-	let struc = "MODEL [ |  | ] \"
-	   ...   ...   ...   ...
-	   ...   ...   ...   ...
-	...   ...   ...   ...   
 	...   ...Q  ...   ...   
 	   ...   ...   ...   ...
 	   ...   P..Q  P..   ...
@@ -456,13 +349,13 @@
 	test_do ~struc ~loc:0 ~msg:"P should attack the diagonal"
           (fun mov_s -> "Cross{1:d4}" = mov_s);
       );
+
   ]
 
 
 let connect4_tests algo iters = 
-  let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
-    test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters 
-      "Connect4" ~msg check_f in
+  let test_do ?(iters=iters) = 
+    test_algo algo ~game:"Connect4" ~iters ~advr:5. ~debug:0 in
   ("Connect4 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
 
     "simple attack" >::
@@ -507,7 +400,7 @@
           (fun mov_s -> "Cross{1:f3}" <> mov_s);
       );
 
-    "endgame" >::
+    (Printf.sprintf "endgame (%i iters)" (30*iters)) >::
       (fun () ->
 	let struc = "MODEL [ |  | ] \"
 	                     
@@ -524,73 +417,152 @@
 	P  P  P  Q  Q  .  .  
 \" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
         DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-	test_do ~struc ~loc:0 ~msg:"P should defend"
+	test_do ~iters:(30*iters) ~struc ~loc:0 ~msg:"P should defend"
           (fun mov_s -> "Cross{1:e2}" = mov_s);
       );
   ]
 
 
+let checkers_tests algo iters = 
+  let test_do ?(iters=iters) =
+    test_algo algo ~game:"Checkers" ~iters ~advr:2. in
+  ("Checkers (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+    "any first move" >::
+      (fun () ->
+        test_do ~msg:"make any first move" (fun s -> true) 
+      );
+  ]
+
+
+
 let tests = "Play" >::: [
   basic_tests;
-  tictactoe_tests "Maximax" 3;
-  breakthrough_tests "Maximax" 5;
+  tictactoe_tests "Maximax" 4;
+  breakthrough_tests "Maximax" 6;
   gomoku8x8_tests "Maximax" 4;
-  connect4_tests "Maximax" 7;
+  connect4_tests "Maximax" 4;
+  checkers_tests "Maximax" 4;
 ]
 
 
 
 (* ----------------- BIG TESTS ------------- *)
 
-let chess_tests_big = "ChessBig" >::: [
 
-  "random first move" >::
-    (fun () ->
-      test_maximax "Chess" ~debug:0 ~iters:0 
-	~msg:"make any first move in chess" (fun s -> true)
-    );
-  
-  "first move 1 iter" >::
-    (fun () ->
-      test_maximax "Chess" ~debug:0 ~iters:1 
-	~msg:"make a selected first move in chess" (fun s -> true)
-    );
+let gomoku8x8_tests_big algo iters = 
+  let test_do ?(iters=iters) =
+    test_algo algo ~game:"Gomoku" ~advr:5. ~iters in
+  ("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
 
-  "detect draw" >::
-    (fun () ->
-      let struc = 
-"MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+    "avoid endgame 1" >::
+      (fun () ->
+	let struc = "MODEL [ |  | ] \"
 	   ...   ...   ...   ...
-	   ...   ...   +bN   ...
+	   ...   ...   ...   ...
 	...   ...   ...   ...   
 	...   ...   ...   ...   
 	   ...   ...   ...   ...
-	   ...   bP.   ...-bNwK.
+	   ...   ...P  ...   ...
 	...   ...   ...   ...   
-	...bP ...   ...   ...   
+	...   ...   ...   ...   
 	   ...   ...   ...   ...
-	   bR.   ...   ...bQ ...
+	   Q..   P..P  ...   ...
 	...   ...   ...   ...   
-	...   ...bK ...   ...bP 
+	...Q  ...   ...   ...   
 	   ...   ...   ...   ...
+	   Q..   ...   ...   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:0 ~msg:"P should block"
+          (fun mov_s -> "Cross{1:b5}" = mov_s)
+      );
+
+    "avoid endgame 2" >::
+      (fun () ->
+	let struc = "MODEL [ |  | ] \"
 	   ...   ...   ...   ...
+	   ...   ...   ...   ...
 	...   ...   ...   ...   
+	...   Q..Q  Q..   ...   
+	   ...   ...   ...   ...
+	   ...   ...P  ...   ...
 	...   ...   ...   ...   
-\" with
-D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
-D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
-      test_maximax "Chess" ~debug:0 ~iters:1 ~struc
-	~msg:"detect draw in chess" ~nomove:true (fun _ -> false)
-    );
-]
+	...   ...   ...   ...   
+	   ...   ...   ...   ...
+	   ...   P..P  ...   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+	   ...   ...   ...   ...
+	   ...   ...   ...   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:0 ~msg:"P should block with line"
+          (fun mov_s -> "Cross{1:f7}" = mov_s);
+      );
 
-let gomoku_tests_big = "GomokuBig" >::: [
-  "maximax suggest defense 1" >::
-    (fun () ->
-      let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+
+    "block gameover" >::
+      (fun () ->
+	let struc = "MODEL [ |  | ] \"
 	   ...   ...   ...   ...
 	   ...   ...   ...   ...
 	...   ...   ...   ...   
+	...   ...   ...   ...   
+	   ...   ...   ...   ...
+	   ...   P..   ...   ...
+	...   ...   ...   ...   
+	...   ...P  P..Q  ...   
+	   ...   ...   ...   ...
+	   ...   P..P  ...Q  ...
+	...   ...   ...   ...   
+	...Q  Q..Q  Q..P  ...   
+	   ...   ...   ...   ...
+	   ...   ...   ...   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:0 ~msg:"P should block"
+          (fun mov_s -> "Cross{1:a3}" = mov_s);
+      );
+
+
+    "more pieces" >::
+      (fun () ->
+	let struc = "MODEL [ |  | ] \"
+	   ...   ...   ...   ...
+	P  ...   ...   ...   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+	   ...   ...   ...   ...
+	   ...P  Q..Q  Q..   ...
+	...   ...   ...   ...   
+	...Q  Q..Q  P..P  ...   
+	   ...   ...   ...   ...
+	   Q..Q  P..Q  P..   ...
+	...   ...   ...   ...   
+	...P  Q..P  ...P  ...   
+	   ...   ...   ...   ...
+	   ...P  ...   P..   ...
+	...   ...   ...   ...   
+	...   ...   ...Q  ...   
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:0 ~msg:"P should block the open line"
+          (fun mov_s -> "Cross{1:e7}" = mov_s);
+      );
+
+    "defense 1" >::
+      (fun () ->
+	let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+	   ...   ...   ...   ...
+	   ...   ...   ...   ...
+	...   ...   ...   ...   
 	...   ...P  ...   ...   
 	   ...   ...   ...   ...
 	   ...   P..   ...   ...
@@ -605,14 +577,14 @@
 	...   ...   ...   ...   
 	...   ...   ...   ...   
 \" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
-       DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-      test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:160 
-	(fun s -> s = "Circle{1:d8}");
-    );
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:1 ~msg:"Q should defend"
+	  (fun s -> s = "Circle{1:d8}");
+      );
 
-  "maximax suggest defense 2" >::
-    (fun () ->
-      let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+    "defense 2" >::
+      (fun () ->
+	let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
 	   ...   ...   ...   ...
 	   P..   ...   ...   ...
 	...   ...   ...   ...   
@@ -630,14 +602,14 @@
 	...   ...   ...   ...   
 	...   ...   ...   ...   
 \" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
-       DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-      test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:180 
-	(fun s -> s = "Circle{1:e1}");
-    );
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:1 ~msg:"Q should defend"
+	  (fun s -> s = "Circle{1:e1}");
+      );
 
-  "maximax suggest defense 3" >::
-    (fun () ->
-      let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+    "stability under iterations (long)" >::
+      (fun () ->
+	let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
 	   ...   ...   ...   ...
 	   ...   ...   ...   ...
 	...   ...   ...   ...   
@@ -655,16 +627,92 @@
 	...   ...   ...   ...   
 	...   ...   ...   ...   
 \" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
-       DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
-      test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:210
-	(fun s -> s = "Circle{1:b6}");
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:1 ~iters:212 ~debug:0 ~msg:"Q should defend"
+	  (fun s -> s = "Circle{1:b6}");
+      );
+
+  ]
+
+
+
+let connect4_tests_big algo (i_from, i_to, i_step) = 
+  let test_do = test_algo algo ~game:"Connect4" ~advr:5. ~debug:0 in
+  let rec range f t s = if t < f then [] else f :: (range (f+s) t s) in
+  let create_tests test_create_f =
+    (Printf.sprintf "Connect4 (%s %i-%i by %i)" algo i_from i_to i_step) >:::
+      (List.concat (List.map test_create_f (range i_from i_to i_step))) in
+  let make_test i = 
+    [(Printf.sprintf "endgame (%i)" i) >::
+      (fun () ->
+	let struc = "MODEL [ |  | ] \"
+	                     
+	.  .  .  .  .  .  .  
+	                     
+	.  .  .  .  .  .  .  
+	                     
+	Q  .  .  .  .  .  .  
+	                     
+	P  .  .  .  .  .  .  
+	                     
+	P  .  +Q Q  .  .  .  
+	                     
+	P  P  P  Q  Q  .  .  
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+        DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+	test_do ~struc ~loc:0 ~iters:i ~msg:"P should defend"
+          (fun mov_s -> "Cross{1:e2}" = mov_s);
+      );] in
+  create_tests make_test
+
+
+let chess_tests_big algo iters = 
+  let test_do ?(iters=iters) =
+    test_algo algo ~game:"Chess" ~advr:2. ~iters in
+  ("Chess (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+    "random first move" >::
+      (fun () ->
+	test_do ~iters:0 ~msg:"make a random first move" (fun s -> true)
+      );
+  
+    "select any first move" >::
+      (fun () ->
+	test_do ~msg:"make any selected first move" (fun s -> true)
+      );
+
+    "detect draw" >::
+      (fun () ->
+	let struc = 
+	  "MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+	   ...   ...   ...   ...
+	   ...   ...   +bN   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+	   ...   ...   ...   ...
+	   ...   bP.   ...-bNwK.
+	...   ...   ...   ...   
+	...bP ...   ...   ...   
+	   ...   ...   ...   ...
+	   bR.   ...   ...bQ ...
+	...   ...   ...   ...   
+	...   ...bK ...   ...bP 
+	   ...   ...   ...   ...
+	   ...   ...   ...   ...
+	...   ...   ...   ...   
+	...   ...   ...   ...   
+\" with
+D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
+D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
+	test_do ~struc ~msg:"detect draw" ~nomove:true (fun _ -> false)
     );
 ]
 
 
 let bigtests = "PlayBig" >::: [
-  chess_tests_big;
-  gomoku_tests_big;
+  connect4_tests_big "Maximax" (100, 300, 10);
+  gomoku8x8_tests_big "Maximax" 6;
+  chess_tests_big "Maximax" 1;
 ]
 
 

Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml	2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Server/Server.ml	2011-04-14 01:58:27 UTC (rev 1409)
@@ -130,8 +130,9 @@
 				~struc:(snd !state).Arena.struc 
 				?advr (fst !state));
 	      Aux.unsome !g_heur in
-	  let (move, _) = Play.maximax_unfold_choose effort
-	    (fst !state) (snd !state) heur in
+	  let (move, _) = 
+	    Aux.random_elem (Play.maximax_unfold_choose effort
+			       (fst !state) (snd !state) heur) in
           Play.cancel_timeout ();
 	  Move.move_gs_str !state move
         )
@@ -178,17 +179,11 @@
                 Printf.printf "ApplyRule: mismatched with play state!\n%!";
               state := new_state; resp
             with Found pos ->
-              let old_struc = (snd !state).Arena.struc in
               let (new_state, resp) = Arena.handle_request !state req in
               (* Rewriting doesn't handle location update. *)
 	      let new_loc = moves.(pos).Move.next_loc in
               state := (fst new_state, 
 			{snd new_state with Arena.cur_loc = new_loc});
-              let new_game_state = {
-                Arena.struc = (snd new_state).Arena.struc;
-                cur_loc = moves.(pos).Move.next_loc;
-                time = (snd new_state).Arena.time;
-              } in
               resp
         )
 
@@ -258,7 +253,6 @@
                  failwith
                    "Server GDL Play request: action mismatched with play state"
                with Found pos -> pos) in
-            let old_struc = (snd !state).Arena.struc in
             let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
             let (new_state, resp) = Arena.handle_request !state req in
             (* Rewriting doesn't handle location update. *)
@@ -280,8 +274,9 @@
 		  let heur = match !g_heur with
 		    | Some h -> h
 		    | None -> failwith "no heuristic for gametree!" in
-		  let (move, _) = Play.maximax_unfold_choose 5500
-		    (fst !state) (snd !state) heur in
+		  let (move, _) = 
+		    Aux.random_elem (Play.maximax_unfold_choose 5500
+				       (fst !state) (snd !state) heur) in
 		  GDL.translate_move !gdl_transl !state
 		    move.Move.rule move.Move.embedding
 		) else (
@@ -359,7 +354,10 @@
 	failwith "only 2-player games supported in experiments for now" in
     let timeo = if pl = 0 then !exp_p1_timeout else !exp_p2_timeout in
     let heur = if pl = 0 then heur1 else heur2 in
-    let (_, s) = Play.maximax_unfold_choose depth game !cur_state heur in
+    Play.set_timeout (float timeo);
+    let (_, s) = 
+      Aux.random_elem (Play.maximax_unfold_choose depth game !cur_state heur) in
+    Play.cancel_timeout ();
     cur_state := s;
     print_endline ("State: " ^ (Structure.str !cur_state.Arena.struc));
     print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter));


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