[Toss-devel-svn] SF.net SVN: toss:[1264] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
From: <luk...@us...> - 2010-12-20 00:15:06
|
Revision: 1264 http://toss.svn.sourceforge.net/toss/?rev=1264&view=rev Author: lukstafi Date: 2010-12-20 00:14:59 +0000 (Mon, 20 Dec 2010) Log Message: ----------- Order of argfind_max bug fix. Deterministic suggest setting (currently only ON for the GDL test). GDL suggestions only for played turn. Modified Paths: -------------- trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/AuxTest.ml trunk/Toss/Play/GDL.ml trunk/Toss/Play/GDL.mli trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Server.ml trunk/Toss/Play/ServerGDLTest.in trunk/Toss/Play/ServerGDLTest.out Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Formula/Aux.ml 2010-12-20 00:14:59 UTC (rev 1264) @@ -236,9 +236,9 @@ let n = Array.length a in if n=0 then [] else - let best = ref (Array.unsafe_get a 0) - and besti = ref [0] in - for i = 1 to n-1 do + let best = ref (Array.unsafe_get a (n-1)) + and besti = ref [n-1] in + for i = n-2 downto 0 do let e = Array.unsafe_get a i in let res = cmp e !best in if res > 0 then (best := e; besti := [i]) Modified: trunk/Toss/Formula/AuxTest.ml =================================================================== --- trunk/Toss/Formula/AuxTest.ml 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Formula/AuxTest.ml 2010-12-20 00:14:59 UTC (rev 1264) @@ -268,7 +268,7 @@ ); - "array_argfind, array_find_all, array_argfind_all" >:: + "array_argfind, array_find_all, array_argfind_all, array_argfind_all_max" >:: (fun () -> assert_equal ~printer:string_of_int 2 @@ -317,6 +317,13 @@ [] (Aux.array_argfind_all (fun e->e.[0]='e') [|"a";"c"; "b"|]); + + assert_equal + ~printer:(fun l->String.concat "; " (List.map string_of_int l)) + ~msg:"argfind_all_max" + [3;6] + (Aux.array_argfind_all_max (-) + [|2;3;2;5;3;4;5;1|]); ); "array_for_all, array_for_all2" >:: Modified: trunk/Toss/Play/GDL.ml =================================================================== --- trunk/Toss/Play/GDL.ml 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/GDL.ml 2010-12-20 00:14:59 UTC (rev 1264) @@ -42,9 +42,9 @@ let compile_game_descr entries = entries -let client_player = ref (Const "uninitialized") +let playing_as = ref (Const "uninitialized") let game_description = ref [] -let game_state = ref (ref Arena.empty_state) +let player_name_terms = ref [| |] let state_of_file s = Printf.printf "GDL: Loading file %s...\n%!" s; @@ -56,31 +56,38 @@ res let initialize_game state player game_descr startcl = - game_state := state; - state := state_of_file "./examples/Tic-Tac-Toe.toss"; - - client_player := player; + playing_as := player; game_description := game_descr; + player_name_terms := [|Const "X"; Const "O"|]; let effort, horizon, heur_adv_ratio = 2, 100, 4.0 in effort, horizon, heur_adv_ratio let translate_last_action actions = - if actions = [] then - (* start of game -- Server will handle this answer as NOOP *) - "", [] - else - (* FIXME: really translate *) - "Cross", ["a1","a1"] + match actions with + | [] -> + (* start of game -- Server will handle this answer as NOOP *) + "", [] + | [Func ("MARK", [Const col; Const row]); Const "NOOP"] -> + "Cross", ["a1", + Structure.board_coords_name + (int_of_string col, int_of_string row)] + | [ Const "NOOP"; Func ("MARK", [Const col; Const row])] -> + "Circle", ["a1", + Structure.board_coords_name + (int_of_string col, int_of_string row)] + | _ -> assert false +let our_turn state = + let loc = state.Arena.cur_loc in + let loc_player = + state.Arena.game.Arena.graph.(loc).Arena.player in + !player_name_terms.(loc_player) = !playing_as + let translate_move rule emb new_state = let struc = new_state.Arena.struc in let elem = snd (List.hd emb) in let c, r = Structure.board_elem_coords (Structure.elem_str struc elem) in - let mark = Printf.sprintf "(MARK %d %d)" c r in - match rule with - | "Cross" -> "(" ^ mark ^ " NOOP)" - | "Circle" -> "(NOOP " ^ mark ^ ")" - | _ -> assert false + Printf.sprintf "(MARK %d %d)" c r Modified: trunk/Toss/Play/GDL.mli =================================================================== --- trunk/Toss/Play/GDL.mli 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/GDL.mli 2010-12-20 00:14:59 UTC (rev 1264) @@ -31,11 +31,11 @@ type request = | Start of string * term * game_description * int * int - (* prepare game: match id, role, game, startclock, playclock *) + (** prepare game: match id, role, game, startclock, playclock *) | Play of string * term list - (* request a move: match id, actions on previous step *) + (** request a move: match id, actions on previous step *) | Stop of string * term list - (* game ends here: match id, actions on previous step *) + (** game ends here: match id, actions on previous step *) val compile_game_descr : game_descr_entry list -> game_description @@ -46,6 +46,9 @@ val translate_last_action : term list -> string * (string * string) list -(* Rule name, embedding, game state. *) +(** Whether the current player is the one being played as. *) +val our_turn : Arena.game_state -> bool + +(** Rule name, embedding, game state. *) val translate_move : string -> (int * int) list -> Arena.game_state -> string Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/Game.ml 2010-12-20 00:14:59 UTC (rev 1264) @@ -10,6 +10,8 @@ let debug_level = ref 0 let set_debug_level i = (debug_level := i) +let deterministic_suggest = ref false + (* A global "hurry up!" switch triggered by the timer alarm. *) let timeout = ref false let get_timeout () = !timeout @@ -497,7 +499,7 @@ if rel < 0 then find best acc tl else if rel = 0 then find best (hd::acc) tl else find hd [hd] tl - | [] -> acc in + | [] -> List.rev acc in match l with | [] -> invalid_arg "find_all_max: empty list" | hd::tl -> find hd [hd] tl @@ -509,7 +511,8 @@ measure [subt_sizes]. Return a best position (randomized if multiple are optimal) and a best scores table (averaged if multiple are optimal). *) -let find_best_score cooperative player scores subt_sizes = +let find_best_score ?(use_det_setting=false) cooperative player + scores subt_sizes = (* find a new best score *) let my_scores = Array.map (fun s->s.(player)) scores in let bestsc = Aux.array_argfind_all_max compare my_scores in @@ -532,6 +535,9 @@ match bestsc with | [] -> failwith "impossible" | [bestsc,_] -> scores.(bestsc), bestsc + | (bsc,_)::(bsc2,_)::_ + when use_det_setting && !deterministic_suggest -> + scores.(bsc), bsc | _ -> (* pick ones from biggest subtrees *) let bestsc = @@ -823,7 +829,7 @@ let scores = Array.map (maximax_tree player betas (depth-1)) models in let _, best = - find_best_score cooperative player scores + find_best_score ~use_det_setting:true cooperative player scores (Array.map (fun _ -> 1) scores) in let state = models.(best) in (* {{{ log entry *) @@ -895,7 +901,8 @@ (uctree_score ~num_players subtree)) node.node_subtrees in let _, best = - find_best_score params.cooperative loc.Arena.player + find_best_score ~use_det_setting:true + params.cooperative loc.Arena.player scores (Array.map uctree_size node.node_subtrees) in let state = uctree_state node.node_subtrees.(best) in (* {{{ log entry *) Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/Game.mli 2010-12-20 00:14:59 UTC (rev 1264) @@ -221,3 +221,7 @@ 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/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/GameTest.ml 2010-12-20 00:14:59 UTC (rev 1264) @@ -564,17 +564,20 @@ "server: ServerGDLTest.in GDL Tic-Tac-Toe" >:: (fun () -> + let old_det_suggest = !Game.deterministic_suggest in + Game.deterministic_suggest := true; let in_ch = open_in "./Play/ServerGDLTest.in" in let out_ch = open_out "./Play/ServerGDLTest.temp" in (try while true do Server.req_handle in_ch out_ch done with End_of_file -> ()); close_in in_ch; close_out out_ch; + Game.deterministic_suggest := old_det_suggest; let result = Aux.input_file (open_in "./Play/ServerGDLTest.temp") in let target = Aux.input_file (open_in "./Play/ServerGDLTest.out") in - Sys.remove "./Play/ServerTest.temp"; + Sys.remove "./Play/ServerGDLTest.temp"; assert_equal ~printer:(fun x->x) target result ); Modified: trunk/Toss/Play/Server.ml =================================================================== --- trunk/Toss/Play/Server.ml 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/Server.ml 2010-12-20 00:14:59 UTC (rev 1264) @@ -152,6 +152,7 @@ let req = req_of_str line in let resp = match req with + | Aux.Left (Arena.SuggestLocMoves (loc, timer, effort, how, horizon, heuristic, heur_adv_ratio)) -> ( @@ -241,8 +242,9 @@ time = !state.Arena.time; loc = !state.Arena.cur_loc} pos memory | _ -> failwith "req_handle: impossible" in - state := new_state; (* Rewriting doesn't handle location update. *) + state := + {new_state with Arena.cur_loc = moves.(pos).Game.next_loc}; let new_game_state = { Game.struc = new_state.Arena.struc; loc = moves.(pos).Game.next_loc; @@ -282,157 +284,175 @@ GDL.translate_last_action actions in if r_name <> "" then ( - let {Arena.rules=rules; graph=graph} = !state.Arena.game in - let struc = !state.Arena.struc in - let fn s n = Structure.find_elem s n in - let r = List.assoc r_name rules in - let lhs = - r.ContinuousRule.discrete.DiscreteRule.lhs_struc in - let m = - List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in - let moves = - Game.gen_moves Game.cGRID_SIZE rules - !state.Arena.struc graph.(!state.Arena.cur_loc) in - let pos = - (try - for i = 0 to Array.length moves - 1 do + let {Arena.rules=rules; graph=graph} = !state.Arena.game in + let struc = !state.Arena.struc in + let fn s n = Structure.find_elem s n in + let r = List.assoc r_name rules in + let lhs = + r.ContinuousRule.discrete.DiscreteRule.lhs_struc in + let m = + List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in + let moves = + Game.gen_moves Game.cGRID_SIZE rules + !state.Arena.struc graph.(!state.Arena.cur_loc) in + let pos = + (try + for i = 0 to Array.length moves - 1 do (* FIXME: handle time and params! *) - let mov = moves.(i) in + let mov = moves.(i) in (* {{{ log entry *) - if !debug_level > 1 then ( - Printf.printf "GDL: considering move %s\n%!" - (Game.move_gs_str !state mov) - ); + if !debug_level > 3 then ( + Printf.printf "GDL: for %s considering move %s\n%!" + r_name (Game.move_gs_str !state mov) + ); (* }}} *) - if - r_name = mov.Game.rule && + if + r_name = mov.Game.rule && (* t = mov.Game.time && *) (* something wrong with this: List.for_all (fun (pn, pv) -> pv = List.assoc pn mov.Game.parameters) p && *) - List.for_all (fun (e, f) -> - f = List.assoc e mov.Game.embedding) m + List.for_all (fun (e, f) -> + f = List.assoc e mov.Game.embedding) m (* TODO: handle location matching *) - then ( - expected_location := mov.Game.next_loc; - let _ = if !debug_level > 2 then - Printf.printf "expected_location = %d\n%!" - !expected_location in - raise (Found i)) - done; + then ( + expected_location := mov.Game.next_loc; + let _ = if !debug_level > 2 then + Printf.printf "expected_location = %d\n%!" + !expected_location in + raise (Found i)) + done; (* TODO: if not due to only time or params mismatch, block or warn about invalid rule application *) - - failwith - "Server GDL Play request: action mismatched with play state" - with Found pos -> pos) in - let old_struc = !state.Arena.struc in - let req = Arena.ApplyRule (r_name, mtch, 0.1, []) in - let (new_state, resp) = Arena.handle_request !state req in - let memory = match !play, !play_state with - | Some play, Some {Game.memory=memory; game_state=pstate} -> - Game.update_memory - ~num_players:play.Game.game.Arena.num_players - {Game.struc=old_struc; - time = !state.Arena.time; - loc = !state.Arena.cur_loc} pos memory - | _ -> failwith "req_handle: impossible" in - state := new_state; + + failwith + "Server GDL Play request: action mismatched with play state" + with Found pos -> pos) in + let old_struc = !state.Arena.struc in + let req = Arena.ApplyRule (r_name, mtch, 0.1, []) in + let (new_state, resp) = Arena.handle_request !state req in + let memory = match !play, !play_state with + | Some play, Some {Game.memory=memory; game_state=pstate} -> + Game.update_memory + ~num_players:play.Game.game.Arena.num_players + {Game.struc=old_struc; + time = !state.Arena.time; + loc = !state.Arena.cur_loc} pos memory + | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) - let new_game_state = { - Game.struc = new_state.Arena.struc; - loc = moves.(pos).Game.next_loc; - time = new_state.Arena.time; - } in - play_state := Some { - Game.game_state = new_game_state; - memory = memory; - }); - - let time_used = - time_started - (int_of_float (ceil (Sys.time ()))) in - let p, ps = - match !play, !play_state with - | Some play, Some play_state -> - play, play_state - | _ -> assert false in - ignore (Unix.alarm (!playclock - time_used)); - let res = Game.suggest p ps in - Game.cancel_timeout (); - let mov_msg = - match res with - | Some (move, new_state) -> - play_state := Some new_state; - GDL.translate_move move.Game.rule move.Game.embedding - !state - | None -> "NOOP" in - let msg_len = String.length mov_msg in - "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: " - ^ string_of_int msg_len ^ "\r\n\r\n" ^ mov_msg + state := + {new_state with Arena.cur_loc = moves.(pos).Game.next_loc}; + let new_game_state = { + Game.struc = new_state.Arena.struc; + loc = moves.(pos).Game.next_loc; + time = new_state.Arena.time; + } in + play_state := Some { + Game.game_state = new_game_state; + memory = memory; + }); + if GDL.our_turn !state + then + let time_used = + time_started - (int_of_float (ceil (Sys.time ()))) in + let p, ps = + match !play, !play_state with + | Some play, Some play_state -> + play, play_state + | _ -> assert false in + ignore (Unix.alarm (!playclock - time_used)); + let res = Game.suggest p ps in + Game.cancel_timeout (); + let mov_msg = + match res with + | Some (move, new_state) -> + (* Do not change state yet! *) + GDL.translate_move move.Game.rule move.Game.embedding + !state + | None -> "NOOP" in + let msg_len = String.length mov_msg in + "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: " + ^ string_of_int msg_len ^ "\r\n\r\n" ^ mov_msg + else + "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: " + ^ "4\r\n\r\nNOOP" + + | Aux.Right (GDL.Stop (_, actions)) -> + let time_started = int_of_float (Sys.time ()) in let r_name, mtch = GDL.translate_last_action actions in - let {Arena.rules=rules; graph=graph} = !state.Arena.game in - let struc = !state.Arena.struc in - let fn s n = Structure.find_elem s n in - let r = List.assoc r_name rules in - let lhs = - r.ContinuousRule.discrete.DiscreteRule.lhs_struc in - let m = - List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in - let moves = - Game.gen_moves Game.cGRID_SIZE rules - !state.Arena.struc graph.(!state.Arena.cur_loc) in - let pos = - (try - for i = 0 to Array.length moves - 1 do + if r_name <> "" then ( + let {Arena.rules=rules; graph=graph} = !state.Arena.game in + let struc = !state.Arena.struc in + let fn s n = Structure.find_elem s n in + let r = List.assoc r_name rules in + let lhs = + r.ContinuousRule.discrete.DiscreteRule.lhs_struc in + let m = + List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in + let moves = + Game.gen_moves Game.cGRID_SIZE rules + !state.Arena.struc graph.(!state.Arena.cur_loc) in + let pos = + (try + for i = 0 to Array.length moves - 1 do (* FIXME: handle time and params! *) - let mov = moves.(i) in - if - r_name = mov.Game.rule && + let mov = moves.(i) in + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "GDL: for %s considering move %s\n%!" + r_name (Game.move_gs_str !state mov) + ); + (* }}} *) + if + r_name = mov.Game.rule && (* t = mov.Game.time && *) (* something wrong with this: List.for_all (fun (pn, pv) -> pv = List.assoc pn mov.Game.parameters) p && *) - List.for_all (fun (e, f) -> - f = List.assoc e mov.Game.embedding) m + List.for_all (fun (e, f) -> + f = List.assoc e mov.Game.embedding) m (* TODO: handle location matching *) - then ( - expected_location := mov.Game.next_loc; - let _ = if !debug_level > 2 then - Printf.printf "expected_location = %d\n%!" - !expected_location in - raise (Found i)) - done; + then ( + expected_location := mov.Game.next_loc; + let _ = if !debug_level > 2 then + Printf.printf "expected_location = %d\n%!" + !expected_location in + raise (Found i)) + done; (* TODO: if not due to only time or params mismatch, block or warn about invalid rule application *) - failwith - "Server GDL Play request: action mismatched with play state" - with Found pos -> pos) in - let old_struc = !state.Arena.struc in - let req = Arena.ApplyRule (r_name, mtch, 0.1, []) in - let (new_state, resp) = Arena.handle_request !state req in - let memory = match !play, !play_state with - | Some play, Some {Game.memory=memory; game_state=pstate} -> - Game.update_memory - ~num_players:play.Game.game.Arena.num_players - {Game.struc=old_struc; - time = !state.Arena.time; - loc = !state.Arena.cur_loc} pos memory - | _ -> failwith "req_handle: impossible" in - state := new_state; + + failwith + "Server GDL Stop request: action mismatched with play state" + with Found pos -> pos) in + let old_struc = !state.Arena.struc in + let req = Arena.ApplyRule (r_name, mtch, 0.1, []) in + let (new_state, resp) = Arena.handle_request !state req in + let memory = match !play, !play_state with + | Some play, Some {Game.memory=memory; game_state=pstate} -> + Game.update_memory + ~num_players:play.Game.game.Arena.num_players + {Game.struc=old_struc; + time = !state.Arena.time; + loc = !state.Arena.cur_loc} pos memory + | _ -> failwith "req_handle: impossible" in (* Rewriting doesn't handle location update. *) - let new_game_state = { - Game.struc = new_state.Arena.struc; - loc = moves.(pos).Game.next_loc; - time = new_state.Arena.time; - } in - play_state := Some { - Game.game_state = new_game_state; - memory = memory; - }; + state := + {new_state with Arena.cur_loc = moves.(pos).Game.next_loc}; + let new_game_state = { + Game.struc = new_state.Arena.struc; + loc = moves.(pos).Game.next_loc; + time = new_state.Arena.time; + } in + play_state := Some { + Game.game_state = new_game_state; + memory = memory; + }); + "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 4" ^ "\r\n\r\nDONE" Modified: trunk/Toss/Play/ServerGDLTest.in =================================================================== --- trunk/Toss/Play/ServerGDLTest.in 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/ServerGDLTest.in 2010-12-20 00:14:59 UTC (rev 1264) @@ -32,7 +32,7 @@ Content-type: text/acl Content-length: 41 -(PLAY MATCH.3316980891 (NOOP (MARK 1 1))) +(PLAY MATCH.3316980891 (NOOP (MARK 3 1))) POST / HTTP/1.0 Accept: text/delim @@ -41,7 +41,7 @@ Content-type: text/acl Content-length: 41 -(PLAY MATCH.3316980891 ((MARK 2 2) NOOP)) +(PLAY MATCH.3316980891 ((MARK 2 1) NOOP)) POST / HTTP/1.0 Accept: text/delim @@ -50,7 +50,7 @@ Content-type: text/acl Content-length: 41 -(PLAY MATCH.3316980891 (NOOP (MARK 1 2))) +(PLAY MATCH.3316980891 (NOOP (MARK 2 3))) POST / HTTP/1.0 Accept: text/delim @@ -59,4 +59,13 @@ Content-type: text/acl Content-length: 41 -(STOP MATCH.3316980891 ((MARK 1 1) NOOP)) +(PLAY MATCH.3316980891 ((MARK 3 3) NOOP)) + +POST / HTTP/1.0 +Accept: text/delim +Sender: GAMEMASTER +Receiver: GAMEPLAYER +Content-type: text/acl +Content-length: 41 + +(STOP MATCH.3316980891 (NOOP (MARK 1 1))) Modified: trunk/Toss/Play/ServerGDLTest.out =================================================================== --- trunk/Toss/Play/ServerGDLTest.out 2010-12-19 22:43:09 UTC (rev 1263) +++ trunk/Toss/Play/ServerGDLTest.out 2010-12-20 00:14:59 UTC (rev 1264) @@ -1,36 +1,41 @@ -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 5 - +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 5 + READY -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 10 - +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 10 + (MARK 2 2) -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 4 - +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 4 + NOOP -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 10 - -(MARK 2 2) -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 4 - +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 10 + +(MARK 2 1) +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 4 + NOOP -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 10 - -(MARK 1 1) -HTTP/1.0 200 OK -Content-type: text/acl -Content-length: 4 - +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 10 + +(MARK 3 3) +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 4 + +NOOP +HTTP/1.0 200 OK +Content-type: text/acl +Content-length: 4 + DONE ERR processing completed -- EOF This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |