[Toss-devel-svn] SF.net SVN: toss:[1325] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
From: <luk...@us...> - 2011-02-22 03:24:53
|
Revision: 1325 http://toss.svn.sourceforge.net/toss/?rev=1325&view=rev Author: lukaszkaiser Date: 2011-02-22 03:24:44 +0000 (Tue, 22 Feb 2011) Log Message: ----------- Split Arena.game_state to game * game_state, add GameTree file with abstract game tree types and functions. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/Arena.mli trunk/Toss/Arena/ArenaParser.mly trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/GGP/GDL.ml trunk/Toss/GGP/GDL.mli trunk/Toss/Makefile trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Makefile trunk/Toss/Play/Move.ml trunk/Toss/Play/Move.mli trunk/Toss/Server/Server.ml trunk/Toss/TossTest.ml trunk/Toss/WebClient/Handler.py Added Paths: ----------- trunk/Toss/Play/GameTree.ml trunk/Toss/Play/GameTree.mli trunk/Toss/Play/GameTreeTest.ml Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Arena/Arena.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -32,37 +32,34 @@ graph : location array; num_players : int; player_names : (string * int) list ; + data : (string * string) list ; defined_rels : (string * (string list * Formula.formula * Solver.M.registered_formula)) list ; } (* State of the game and additional information. *) type game_state = { - game : game ; struc : Structure.structure ; time : float ; cur_loc : int ; - data : (string * string) list ; } let empty_state = let emp_struc = Structure.empty_structure () in let zero = Formula.Const 0.0 in - { - game = - {rules=[]; - graph=Array.make 1 - { id = 0; player = 0; payoffs = [|zero|]; - payoffs_pp = - [|Solver.M.register_real_expr zero|]; - moves = [] }; - player_names = ["1", 0] ; - defined_rels = [] ; - num_players=1;}; - struc = emp_struc ; - time = 0.0 ; - cur_loc = 0 ; - data = [] ; + {rules=[]; + graph=Array.make 1 + { id = 0; player = 0; payoffs = [|zero|]; + payoffs_pp = + [|Solver.M.register_real_expr zero|]; + moves = [] }; + player_names = ["1", 0] ; + data = [] ; + defined_rels = [] ; + num_players=1;}, + {struc = emp_struc ; + time = 0.0 ; + cur_loc = 0 ; } @@ -168,13 +165,13 @@ | None -> [], [], [], [], Structure.empty_structure (), 0.0, 0, [] | Some state -> - state.game.rules, Array.to_list state.game.graph, + (fst state).rules, Array.to_list (fst state).graph, List.map fst (List.sort (fun (_,x) (_,y) -> x-y) - state.game.player_names), + (fst state).player_names), List.map (fun (rel, (args, body, _)) ->rel, args, body) - state.game.defined_rels, - state.struc, state.time, - state.cur_loc, state.data in + (fst state).defined_rels, + (snd state).struc, (snd state).time, + (snd state).cur_loc, (fst state).data in (* {{{ log entry *) if !debug_level > 2 then ( printf "process_definition: %d old rules, %d old locs\n%!" @@ -293,13 +290,12 @@ graph = graph; num_players = num_players; player_names = player_names; + data = data; defined_rels = defined_rels - } in { - game = game; + } in game, { struc = state; time = time; cur_loc = cur_loc; - data = data; } @@ -342,19 +338,17 @@ let equational_def_style = ref true let fprint_state ppf - { - game = { - rules = rules; - graph = graph; - num_players = num_players; - player_names = player_names; - defined_rels = defined_rels; - } ; - struc = struc; - time = time; - cur_loc = cur_loc; - data = data; - } = + ({rules = rules; + graph = graph; + num_players = num_players; + player_names = player_names; + data = data; + defined_rels = defined_rels; + }, + {struc = struc; + time = time; + cur_loc = cur_loc; + }) = Format.fprintf ppf "@[<v>"; List.iter (fun (drel, (args, body, _)) -> if !equational_def_style then @@ -389,13 +383,13 @@ fprint_state Format.str_formatter r; Format.flush_str_formatter () -let str game = sprint_state {empty_state with game=game} +let str game = sprint_state (game, snd empty_state) let state_str state = sprint_state state (* -------------------- WHOLE ARENA MANIPULATION -------------------- *) -let add_new_player state pname = - let player = state.game.num_players in +let add_new_player (state_game, state) pname = + let player = state_game.num_players in let zero = Formula.Const 0.0 in let pp_zero = Solver.M.register_real_expr zero in let add_payoff loc = @@ -403,12 +397,12 @@ payoffs = Array.append loc.payoffs [|zero|]; payoffs_pp = Array.append loc.payoffs_pp [|pp_zero|]; } in - let game = {state.game with - num_players = state.game.num_players + 1; - graph = Array.map add_payoff state.game.graph; - player_names = (pname, player)::state.game.player_names; + let game = {state_game with + num_players = state_game.num_players + 1; + graph = Array.map add_payoff state_game.graph; + player_names = (pname, player)::state_game.player_names; } in - {state with game = game}, player + (game, state), player (* ------------------ REQUESTS TO THE ARENA USED IN OPERATION --------------- *) @@ -478,7 +472,7 @@ | GetRuleNames (* Get names of all rules *) | SetTime of float * float (* Set time step and time *) | GetTime (* Get time step and time *) - | SetState of game_state (* Set the full state *) + | SetState of game * game_state (* Set the full state *) | GetModel (* Return the current model*) | GetState (* Return the state *) @@ -487,70 +481,75 @@ (* Apply function [f] to named structure at location [loc] in [state]. Include what [f] returns - changed named structure and string - and return.*) -let apply_to_loc f loc state err_msg = +let apply_to_loc f loc (state_game, state) err_msg = match loc with Struct -> let (new_struc, msg) = f state.struc in - ({ state with struc = new_struc }, msg) + ((state_game, { state with struc = new_struc }), msg) | Left rn -> ( try - let r = (List.assoc rn state.game.rules) in + let r = (List.assoc rn state_game.rules) in let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let (new_r, msg) = ContinuousRule.apply_to_side true f signat defs r in - let new_rules = Aux.replace_assoc rn new_r state.game.rules in - ({ state with game = {state.game with rules=new_rules}}, msg) - with Not_found -> - (state, "ERR [Not found] on left location of " ^ rn ^", " ^ err_msg) + let new_rules = Aux.replace_assoc rn new_r state_game.rules in + (({state_game with rules=new_rules}, state), msg) + with Not_found -> + ((state_game, state), + "ERR [Not found] on left location of " ^ rn ^", " ^ err_msg) ) | Right rn -> try - let r = (List.assoc rn state.game.rules) in + let r = (List.assoc rn state_game.rules) in let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let (new_r, msg) = ContinuousRule.apply_to_side false f signat defs r in - let new_rules = Aux.replace_assoc rn new_r state.game.rules in - ({ state with game = {state.game with rules=new_rules}}, msg) + let new_rules = Aux.replace_assoc rn new_r state_game.rules in + (({state_game with rules=new_rules}, state), msg) with Not_found -> - (state, "ERR [Not found] on right location of "^rn^", " ^ err_msg) - + ((state_game, state), + "ERR [Not found] on right location of "^rn^", " ^ err_msg) + (* Retrieve value of [f] from structure at location [loc] in [state]. *) -let get_from_loc f loc state err_msg = +let get_from_loc f loc (state_game, state) err_msg = match loc with Struct -> f state.struc | Left r_name -> ( try - let r = (List.assoc r_name state.game.rules) in + let r = (List.assoc r_name state_game.rules) in f r.ContinuousRule.discrete.DiscreteRule.lhs_struc with Not_found -> - "ERR [Not found] getting from left location of " ^ r_name ^ ", " ^ err_msg + "ERR [Not found] getting from left location of " ^ + r_name ^ ", " ^ err_msg ) | Right r_name -> try - let r = (List.assoc r_name state.game.rules) in + let r = (List.assoc r_name state_game.rules) in f r.ContinuousRule.discrete.DiscreteRule.rhs_struc with Not_found -> - "ERR [Not found] getting from right location of " ^ r_name ^ ", " ^ err_msg + "ERR [Not found] getting from right location of " ^ + r_name ^ ", " ^ err_msg (* Apply function [f] to named rule [r_name] in [state], insert and return. *) -let apply_to_rule f r_name state err_msg = +let apply_to_rule f r_name (state_game, state) err_msg = try - let r = List.assoc r_name state.game.rules in + let r = List.assoc r_name state_game.rules in let (nr, msg) = f r in - let new_rules = Aux.replace_assoc r_name nr state.game.rules in - ({ state with game = {state.game with rules=new_rules} }, msg) + let new_rules = Aux.replace_assoc r_name nr state_game.rules in + (({state_game with rules=new_rules}, state), msg) with Not_found -> - (state, "ERR [Not found] applying to rule " ^ r_name ^ ": " ^ err_msg) + ((state_game, state), + "ERR [Not found] applying to rule " ^ r_name ^ ": " ^ err_msg) (* Retrieve value of [f] from rule [r] in [state]. *) -let get_from_rule f r state err = - try f (List.assoc r state.game.rules) +let get_from_rule f r state_game err = + try f (List.assoc r state_game.rules) with Not_found -> "ERR [Not found] getting from rule " ^ r ^ ": " ^ err @@ -559,14 +558,14 @@ Structure.sig_str state.struc (* Request Handler *) -let handle_request state req = +let handle_request (state_game, state) req = let struc = state.struc in let add_new_elem struc = let struc, e = Structure.add_new_elem struc () in struc, string_of_int e in match req with AddElem loc -> - apply_to_loc add_new_elem loc state "add elem" + apply_to_loc add_new_elem loc (state_game, state) "add elem" | AddRel (loc, rel, tp) -> let add_rel struc = let struc, tp = @@ -575,191 +574,197 @@ struc, e::tp) tp (struc, []) in let tp = Array.of_list tp in Structure.add_rel struc rel tp, "REL ADDED" in - apply_to_loc add_rel loc state "add rel" + apply_to_loc add_rel loc (state_game, state) "add rel" | DelElem (loc, elem_name) -> let del_elem struc = let el = Structure.find_elem struc elem_name in Structure.del_elem struc el, "ELEM DELETED" in - apply_to_loc del_elem loc state "del elem" + apply_to_loc del_elem loc (state_game, state) "del elem" | DelRel (loc, rel, tp) -> let del_rel struc = let tp = List.map (fun n -> Structure.find_elem struc n) tp in Structure.del_rel struc rel (Array.of_list tp), "REL DELETED" in - apply_to_loc del_rel loc state "del rel" + apply_to_loc del_rel loc (state_game, state) "del rel" | GetRelSignature loc -> - (state, get_from_loc Structure.sig_str loc state "get signature") + ((state_game, state), + get_from_loc Structure.sig_str loc (state_game, state) "get signature") | GetFunSignature loc -> let fun_signature struc = let funs = Structure.f_signature struc in String.concat "; " funs in - (state, get_from_loc fun_signature loc state "get signature") + ((state_game,state), + get_from_loc fun_signature loc (state_game, state) "get signature") | GetAllTuples (loc, rel) -> let tuples struc = let tps = Structure.StringMap.find rel struc.Structure.relations in Structure.rel_str struc rel tps in - (state, get_from_loc tuples loc state "get all tuples") + ((state_game, state), + get_from_loc tuples loc (state_game, state) "get all tuples") | GetAllElems loc -> let elems struc = let els = Structure.Elems.elements struc.Structure.elements in let el_name e = Structure.elem_str struc e in String.concat "; " (List.map el_name els) in - (state, get_from_loc elems loc state "get all elements") + ((state_game, state), + get_from_loc elems loc (state_game, state) "get all elements") | SetFun (loc, funct, el_name, v) -> let set_fun struc = let el = Structure.find_elem struc el_name in Structure.add_fun struc funct (el, v), "FUN SET" in - apply_to_loc set_fun loc state "set fun" + apply_to_loc set_fun loc (state_game, state) "set fun" | GetFun (loc, funct, el_name) -> let get_fun struc = let el = Structure.find_elem struc el_name in string_of_float (Structure.fun_val struc funct el) in - (state, get_from_loc get_fun loc state "get fun") + ((state_game, state), + get_from_loc get_fun loc (state_game, state) "get fun") | SetData (key, v) -> - let ndata = Aux.replace_assoc key v state.data in - ({ state with data = ndata }, "SET DATA") + let ndata = Aux.replace_assoc key v state_game.data in + (({state_game with data = ndata }, state), "SET DATA") | GetData (key) -> ( - try (state, List.assoc key state.data) - with Not_found -> (state, "ERR no data") + try ((state_game, state), List.assoc key state_game.data) + with Not_found -> ((state_game, state), "ERR no data") ) | SetArity (rel, ar) -> if (try Structure.StringMap.find rel struc.Structure.rel_signature = ar with Not_found -> false) - then state, "SET ARITY" + then (state_game, state), "SET ARITY" else let s = Structure.force_add_rel_name rel ar struc in - ({ state with struc = s }, "SET ARITY") + ((state_game, { state with struc = s }), "SET ARITY") | GetArity (rel) -> ( - if rel = "" then (state, sig_str state) else - try (state, string_of_int + if rel = "" then ((state_game, state), sig_str state) else + try ((state_game, state), string_of_int (Structure.StringMap.find rel state.struc.Structure.rel_signature)) with Not_found -> - (state, "ERR relation "^rel^" arity not found") + ((state_game, state), "ERR relation "^rel^" arity not found") ) | RenamePlayer (old_name, new_name) -> let player, player_names = - Aux.pop_assoc old_name state.game.player_names in - {state with game = - {state.game with player_names = - (new_name, player)::player_names}}, - "PLAYER renamed" + Aux.pop_assoc old_name state_game.player_names in + ({state_game with player_names = (new_name, player)::player_names}, + state), "PLAYER renamed" | SetLoc (i) -> - let l = Array.length state.game.graph in + let l = Array.length state_game.graph in if i < 0 || i > l then (* make new location and set there *) let a = Array.make 1 { id = l; player=0; payoffs=[| |]; payoffs_pp=[| |]; moves=[] } in - ({state with game = - {state.game with graph=Array.append state.game.graph a}; - cur_loc = l }, + (({state_game with graph=Array.append state_game.graph a}, + {state with cur_loc = l }), "NEW LOC ADDED AND CUR LOC SET TO " ^ (string_of_int l)) else - ({ state with cur_loc = i }, "CUR LOC SET") - | GetLoc -> - (state, (string_of_int state.cur_loc) ^ " / " ^ - (string_of_int (Array.length state.game.graph))) + ((state_game, { state with cur_loc = i }), "CUR LOC SET") + | GetLoc -> + ((state_game, state), (string_of_int state.cur_loc) ^ " / " ^ + (string_of_int (Array.length state_game.graph))) | SetLocPlayer (i, player) -> - let state, player = - try state, List.assoc player state.game.player_names - with Not_found -> add_new_player state player in - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + let (state_game, state), player = + try (state_game, state), List.assoc player state_game.player_names + with Not_found -> add_new_player (state_game, state) player in + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( - state.game.graph.(i) <- - { state.game.graph.(i) with player = player }; - (state, "LOC PLAYER SET") + state_game.graph.(i) <- + { state_game.graph.(i) with player = player }; + ((state_game, state), "LOC PLAYER SET") ) | GetLocPlayer (i) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") - else (state, Aux.rev_assoc state.game.player_names - state.game.graph.(i).player) + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") + else ((state_game, state), Aux.rev_assoc state_game.player_names + state_game.graph.(i).player) | SetLocPayoff (i, player, payoff) -> - let state, player = - try state, List.assoc player state.game.player_names - with Not_found -> add_new_player state player in - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + let (state_game, state), player = + try (state_game, state), List.assoc player state_game.player_names + with Not_found -> add_new_player (state_game, state) player in + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( let simp_payoff = FormulaOps.tnf_re payoff in - state.game.graph.(i).payoffs.(player) <- simp_payoff; - (state, "LOC PAYOFF SET") + state_game.graph.(i).payoffs.(player) <- simp_payoff; + ((state_game, state), "LOC PAYOFF SET") ) | GetLocPayoff (i, player) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( try - (state, Formula.real_str - state.game.graph.(i).payoffs.(List.assoc player - state.game.player_names)) - with Not_found -> (state, "0.0") + ((state_game, state), Formula.real_str + state_game.graph.(i).payoffs.(List.assoc player + state_game.player_names)) + with Not_found -> ((state_game, state), "0.0") ) | GetCurPayoffs -> let payoffs = Array.to_list (Array.mapi (fun i v->string_of_int i,v) - state.game.graph.(state.cur_loc).payoffs_pp) in + state_game.graph.(state.cur_loc).payoffs_pp) in let ev (p,e) = p^": "^(string_of_float (Solver.M.get_real_val e struc)) in - (state, String.concat ", " (List.sort compare (List.map ev payoffs))) + ((state_game, state), + String.concat ", " (List.sort compare (List.map ev payoffs))) | SetLocMoves (i, moves) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") else ( - state.game.graph.(i) <- { state.game.graph.(i) with moves = moves }; - (state, "LOC MOVES SET") + state_game.graph.(i) <- { state_game.graph.(i) with moves = moves }; + ((state_game, state), "LOC MOVES SET") ) | GetLocMoves (i) -> - if i < 0 || i > Array.length state.game.graph then - (state, "ERR location "^string_of_int i^" not found") - else (state, (String.concat "; " - (List.map move_str state.game.graph.(i).moves))) + if i < 0 || i > Array.length state_game.graph then + ((state_game, state), "ERR location "^string_of_int i^" not found") + else ((state_game, state), + (String.concat "; " (List.map move_str state_game.graph.(i).moves))) | SuggestLocMoves _ -> failwith "handle_req: SuggestLocMoves handled in Server" - | EvalFormula (phi) -> (state, "ERR eval not yet implemented") - | EvalRealExpr (rexpr) -> (state, "ERR eval real not yet implemented") + | EvalFormula (phi) -> ((state_game, state), "ERR eval not yet implemented") + | EvalRealExpr (rexpr) -> + ((state_game, state), "ERR eval real not yet implemented") | SetRule (r_name, r) -> ( try let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let new_rules = Aux.replace_assoc r_name (r signat defs r_name) - state.game.rules in - ({ state with game = {state.game with rules=new_rules} }, "SET RULE") + state_game.rules in + (({state_game with rules=new_rules}, state), "SET RULE") with - Not_found -> - (state, "ERR [Not found] setting rule "^r_name^" failed") + Not_found -> ((state_game, state), + "ERR [Not found] setting rule "^r_name^" failed") ) | GetRule (r_name) -> - let msg = get_from_rule ContinuousRule.str r_name state "get rule" in - (state, msg) + let msg = get_from_rule ContinuousRule.str r_name state_game "get rule" in + ((state_game, state), msg) | SetRuleUpd (r_name, f, elem_name, term) -> let set_upd r = let new_upd = Aux.replace_assoc (f,elem_name) term r.ContinuousRule.update in { r with ContinuousRule.update = new_upd }, "UPDATE SET" in - apply_to_rule set_upd r_name state "set rule upd" + apply_to_rule set_upd r_name (state_game, state) "set rule upd" | GetRuleUpd (r_name, f, elem_name) -> let get_upd r = try let upd = List.assoc (f,elem_name) r.ContinuousRule.update in Term.str upd with Not_found -> "0.0" in - (state, get_from_rule get_upd r_name state "get rule upd") + ((state_game, state), + get_from_rule get_upd r_name state_game "get rule upd") | SetRuleDyn (r_name, f, elem_name, term) -> let set_dyn r = let new_dyn = Aux.replace_assoc (f,elem_name) term r.ContinuousRule.dynamics in { r with ContinuousRule.dynamics = new_dyn },"DYNAMICS SET" in - apply_to_rule set_dyn r_name state "set rule dyn" + apply_to_rule set_dyn r_name (state_game, state) "set rule dyn" | GetRuleDyn (r_name, f, elem_name) -> let get_dyn r = try let dyn = List.assoc (f,elem_name) r.ContinuousRule.dynamics in Term.str dyn with Not_found -> "0.0" in - (state, get_from_rule get_dyn r_name state "get rule dyn") + ((state_game, state), + get_from_rule get_dyn r_name state_game "get rule dyn") | SetRuleCond (r_name, pre, inv, post) -> let set_cond r = let d = r.ContinuousRule.discrete in @@ -767,17 +772,18 @@ let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let nr = (* TODO: rename lhs_* relations to be consistent with ln *) ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in (nr, "RULE COND SET") in - apply_to_rule set_cond r_name state "set rule cond" + apply_to_rule set_cond r_name (state_game, state) "set rule cond" | GetRuleCond (r_name) -> let get_cond r = let pre = r.ContinuousRule.discrete.DiscreteRule.pre in let (inv, post)=(r.ContinuousRule.inv, r.ContinuousRule.post) in (Formula.str pre)^"; "^ (Formula.str inv) ^"; "^ (Formula.str post) in - (state, get_from_rule get_cond r_name state "get rule cond") + ((state_game, state), + get_from_rule get_cond r_name state_game "get rule cond") | SetRuleEmb (r_name, emb) -> let set_emb r = @@ -790,15 +796,16 @@ let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let nr = ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in (nr, "RULE EMB SET") in - apply_to_rule set_emb r_name state "set rule emb" + apply_to_rule set_emb r_name (state_game, state) "set rule emb" | GetRuleEmb (r_name) -> let get_emb r = String.concat ", " r.ContinuousRule.discrete.DiscreteRule.emb_rels in - (state, get_from_rule get_emb r_name state "get rule emb") + ((state_game, state), + get_from_rule get_emb r_name state_game "get rule emb") | SetRuleAssoc (r_name, r_elem_name, rassoc) -> let set_assoc r = let lname l = Structure.find_elem (ContinuousRule.lhs r) l in @@ -816,11 +823,11 @@ let signat = Structure.rel_signature state.struc in let defs = List.map (fun (drel, (args, body, _)) -> drel,(args,body)) - state.game.defined_rels in + state_game.defined_rels in let nr = ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in (nr, "RULE ASSOC SET") in - apply_to_rule set_assoc r_name state "set rule assoc" + apply_to_rule set_assoc r_name (state_game, state) "set rule assoc" | GetRuleAssoc (r_name, r_elem_name) -> let get_assoc r = let assoc = r.ContinuousRule.discrete.DiscreteRule.rule_s in @@ -829,22 +836,23 @@ let rassoc = List.filter (fun (r, l) -> r = relem) assoc in let l e = Structure.elem_str (ContinuousRule.lhs r) e in String.concat ", " (List.map (fun (_, le) -> l le) rassoc) in - (state, get_from_rule get_assoc r_name state "get rule assoc") + ((state_game, state), + get_from_rule get_assoc r_name state_game "get rule assoc") | GetRuleMatches (r_name) -> ( try - let r = List.assoc r_name state.game.rules in + let r = List.assoc r_name state_game.rules in let matches = ContinuousRule.matches_post struc r state.time in (* matches are from LHS to model *) let name (lhs,rhs) = Structure.elem_str (ContinuousRule.lhs r) lhs ^ " -> " ^ Structure.elem_str struc rhs in let mname m = String.concat ", " (List.map name m) in - (state, String.concat "; " (List.map mname matches)) + ((state_game, state), String.concat "; " (List.map mname matches)) with Not_found -> - (state, "ERR getting "^r_name^" matches, rule not found") + ((state_game, state), "ERR getting "^r_name^" matches, rule not found") ) | ApplyRule (r_name, mtch, t, p) -> - (let try r = List.assoc r_name state.game.rules in + (let try r = List.assoc r_name state_game.rules in let lhs_struc = ContinuousRule.lhs r in let m = List.map (fun (l, s) -> Structure.find_elem lhs_struc l, @@ -856,31 +864,38 @@ (* we've moved to using element names in Term *) f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in let shifts_s = String.concat "; " (List.map val_str shifts) in - ({state with struc = new_struc; time = new_time}, shifts_s) - | None -> (state, "ERR applying "^r_name^", postcondition fails") - with Not_found -> (state, "ERR applying "^r_name^", rule not found") + ((state_game, {state with struc = new_struc; time = new_time}), + shifts_s) + | None -> ((state_game, state), + "ERR applying "^r_name^", postcondition fails") + with Not_found -> + ((state_game, state), "ERR applying "^r_name^", rule not found") ) | ApplyRuleInt (r_name, mtch, t, p) -> - (let try r = List.assoc r_name state.game.rules in + (let try r = List.assoc r_name state_game.rules in match ContinuousRule.rewrite_single struc state.time mtch r t p with | Some (new_struc, new_time, shifts) -> - let val_str ((f, e), tl) = - let ts t = string_of_float (Term.term_val t) in - (* we've moved to using element names in Term *) - f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in + let val_str ((f, e), tl) = + let ts t = string_of_float (Term.term_val t) in + (* we've moved to using element names in Term *) + f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in let shifts_s = String.concat "; " (List.map val_str shifts) in - ({state with struc = new_struc; time = new_time}, shifts_s) - | None -> (state, "ERR applying "^r_name^", postcondition fails") - with Not_found -> (state, "ERR applying "^r_name^", rule not found") + ((state_game, {state with struc = new_struc; time = new_time}), + shifts_s) + | None -> ((state_game, state), + "ERR applying " ^ r_name ^ ", postcondition fails") + with Not_found -> + ((state_game, state), "ERR applying " ^ r_name ^ ", rule not found") ) - | GetRuleNames -> (state, String.concat "; " (fst (List.split state.game.rules))) + | GetRuleNames -> ((state_game, state), + String.concat "; " (fst (List.split state_game.rules))) | SetTime (tstep, t) -> ContinuousRule.set_time_step tstep; - ({ state with time = t }, "TIME SET") + ((state_game, { state with time = t }), "TIME SET") | GetTime -> let (ts, t) = (ContinuousRule.get_time_step (), state.time) in - (state, string_of_float (ts) ^ " / " ^ string_of_float (t)) - | SetState s -> - (s, "STATE SET") - | GetModel -> (state, Structure.sprint state.struc) - | GetState -> (state, state_str state) + ((state_game, state), string_of_float (ts) ^ " / " ^ string_of_float (t)) + | SetState (g, s) -> + ((g, s), "STATE SET") + | GetModel -> ((state_game, state), Structure.sprint state.struc) + | GetState -> ((state_game, state), state_str (state_game, state)) Modified: trunk/Toss/Arena/Arena.mli =================================================================== --- trunk/Toss/Arena/Arena.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Arena/Arena.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -28,20 +28,19 @@ graph : location array; num_players : int; player_names : (string * int) list ; + data : (string * string) list ; defined_rels : (string * (string list * Formula.formula * Solver.M.registered_formula)) list ; } (** State of the game. *) type game_state = { - game : game ; struc : Structure.structure ; time : float ; cur_loc : int ; - data : (string * string) list ; } -val empty_state : game_state +val empty_state : game * game_state (** Rules with which a player with given number can move. *) val rules_for_player : int -> game -> string list @@ -57,15 +56,15 @@ val str : game -> string (** Print the whole state: the game, structure, time and aux data. *) -val state_str : game_state -> string +val state_str : game * game_state -> string (** Whether to print relation definitions as equations, or using the C syntax. Defaults to [true]. *) val equational_def_style : bool ref -val fprint_state : Format.formatter -> game_state -> unit -val print_state : game_state -> unit -val sprint_state : game_state -> string +val fprint_state : Format.formatter -> game * game_state -> unit +val print_state : game * game_state -> unit +val sprint_state : game * game_state -> string (** The order of following entries matters: [DefPlayers] adds more players, with consecutive numbers starting from first available; @@ -109,7 +108,7 @@ (** Create a game state, possibly by extending an old state, from a list of definitions (usually corresponding to a ".toss" file.) *) val process_definition : - ?extend_state:game_state -> definition list -> game_state + ?extend_state:game * game_state -> definition list -> game * game_state (** ------------------ REQUESTS TO THE ARENA USED IN OPERATION --------------- *) @@ -178,8 +177,9 @@ | GetRuleNames (** Get names of rules *) | SetTime of float * float (** Set time step and time *) | GetTime (** Get time step and time *) - | SetState of game_state (** Set the full state *) + | SetState of game * game_state (** Set the full state *) | GetModel (** Return the model *) | GetState (** Return the state *) -val handle_request : game_state -> request -> game_state * string +val handle_request : + game * game_state -> request -> (game * game_state) * string Modified: trunk/Toss/Arena/ArenaParser.mly =================================================================== --- trunk/Toss/Arena/ArenaParser.mly 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Arena/ArenaParser.mly 2011-02-22 03:24:44 UTC (rev 1325) @@ -14,8 +14,8 @@ %type <Arena.struct_loc> struct_location %type <(string * int) list -> Arena.location> location %type <Arena.definition> parse_game_defs -%type <Arena.game_state> parse_game_state game_state -%type <Arena.game_state -> Arena.game_state> extend_game_state +%type <Arena.game * Arena.game_state> parse_game_state game_state +%type <Arena.game * Arena.game_state -> Arena.game * Arena.game_state> extend_game_state %% @@ -134,7 +134,7 @@ | SET_CMD SIG_MOD id_int INT { SetArity ($3, $4) } | GET_CMD SIG_MOD { GetArity ("") } | GET_CMD SIG_MOD id_int { GetArity ($3) } - | SET_CMD STATE_SPEC gs=game_state { SetState gs } + | SET_CMD STATE_SPEC gs=game_state { let (g, s) = gs in SetState (g, s) } | GET_CMD STATE_SPEC { GetState } | GET_CMD MODEL_SPEC { GetModel } | ADD_CMD ELEM_MOD struct_location Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Formula/Aux.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -46,6 +46,9 @@ (* {2 Helper functions on lists and other functions lacking from the standard library.} *) + +let random_elem l = List.nth l (Random.int (List.length l)) + let concat_map f l = let rec cmap_f accu = function | [] -> accu Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Formula/Aux.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -30,6 +30,9 @@ (** {2 Helper functions on lists and other functions lacking from the standard library.} *) +(** Random element of a list. *) +val random_elem : 'a list -> 'a + (** Concatenate results of a function. *) val concat_map : ('a -> 'b list) -> 'a list -> 'b list Modified: trunk/Toss/GGP/GDL.ml =================================================================== --- trunk/Toss/GGP/GDL.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/GGP/GDL.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -2845,13 +2845,12 @@ graph = locations; num_players = players_n; player_names = player_names; + data = []; defined_rels = []} in - let result = { - Arena.game = game; - struc = struc; + let result = game, { + Arena.struc = struc; time = 0.; cur_loc = 0; - data = []; } in let playing_as = find_player player_term in let noop_actions = @@ -2897,9 +2896,9 @@ the translated move. *) let translate_incoming_move gdl state actions = - let loc = state.Arena.cur_loc in + let loc = (snd state).Arena.cur_loc in let actions = Array.of_list actions in - let location = state.Arena.game.Arena.graph.(loc) in + let location = (fst state).Arena.graph.(loc) in let player_action = actions.(location.Arena.player) in (* 9a *) let tossrules = @@ -2937,17 +2936,16 @@ let rule = DiscreteRule.translate_from_precond ~precond ~add ~embed:gdl.fluents ~struc_elems in - let rule = - DiscreteRule.compile_rule (Structure.rel_signature state.Arena.struc) - [] rule in + let rule = DiscreteRule.compile_rule + (Structure.rel_signature (snd state).Arena.struc) [] rule in let asgns = - DiscreteRule.find_matchings state.Arena.struc rule in + DiscreteRule.find_matchings (snd state).Arena.struc rule in (* faster *) (* let emb = - DiscreteRule.choose_match state.Arena.struc rule asgns in *) + DiscreteRule.choose_match (snd state).Arena.struc rule asgns in *) (* but we should check whether there's no ambiguity... *) match - DiscreteRule.enumerate_matchings state.Arena.struc rule asgns + DiscreteRule.enumerate_matchings (snd state).Arena.struc rule asgns with | [] -> None | [emb] -> Some (rname, emb) @@ -2980,10 +2978,10 @@ "route" should give the same term. *) let translate_outgoing_move gdl state rname emb = - (* let loc = state.Arena.cur_loc in *) - (* let location = state.Arena.game.Arena.graph.(loc) in *) + (* let loc = (snd state).Arena.cur_loc in *) + (* let location = (fst state).Arena.graph.(loc) in *) let tossrule = Aux.StrMap.find rname gdl.tossrule_data in - let rule = List.assoc rname state.Arena.game.Arena.rules in + let rule = List.assoc rname (fst state).Arena.rules in (* 10d *) let emb = List.map (fun (v, e) -> let vterm = @@ -3001,8 +2999,8 @@ term_str (subst sb tossrule.lead_legal) let our_turn gdl state = - let loc = state.Arena.cur_loc in - gdl.playing_as = state.Arena.game.Arena.graph.(loc).Arena.player + let loc = (snd state).Arena.cur_loc in + gdl.playing_as = (fst state).Arena.graph.(loc).Arena.player let noop_move ?(force=false) gdl state = let loc = state.Arena.cur_loc in @@ -3235,15 +3233,15 @@ | "connect5" -> translate_last_action_gomoku actions | "connect4" -> - translate_last_action_connect4 state.Arena.struc actions + translate_last_action_connect4 (snd state).Arena.struc actions | "breakthrough" -> translate_last_action_breakthrough actions | "pawn_whopping" -> translate_last_action_pawn_whopping actions | game -> failwith ("GDL: manual translation of unknown game "^game) in - let {Arena.rules=rules; graph=graph} = state.Arena.game in - let struc = state.Arena.struc in + let {Arena.rules=rules; graph=graph} = fst state in + let struc = (snd state).Arena.struc in let fn s n = try Structure.find_elem s n with Not_found -> failwith @@ -3262,14 +3260,14 @@ else translate_incoming_move gdl_translation state actions let translate_move_tictactoe rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd 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 Printf.sprintf "(MARK %d %d)" c r let translate_move_gomoku rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd 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 @@ -3277,14 +3275,14 @@ Printf.sprintf "(MARK %c %c)" cs rs let translate_move_connect4 rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in let elem = snd (List.hd emb) in let c, _ = Structure.board_elem_coords (Structure.elem_str struc elem) in Printf.sprintf "(DROP %d)" c let translate_move_breakthrough rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in match emb with | [(_,a); (_,b)] -> let a, b = if rule = "BlackStraight" then a, b else b, a in @@ -3296,7 +3294,7 @@ | _ -> assert false let translate_move_pawn_whopping rule emb new_state = - let struc = new_state.Arena.struc in + let struc = (snd new_state).Arena.struc in match emb with | [(_,a); (_,b)] -> let a, b = Modified: trunk/Toss/GGP/GDL.mli =================================================================== --- trunk/Toss/GGP/GDL.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/GGP/GDL.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -81,7 +81,8 @@ term list * (term list list list * term list list) val translate_game : - term -> game_descr_entry list -> gdl_translation * Arena.game_state + term -> game_descr_entry list -> + gdl_translation * (Arena.game * Arena.game_state) (* DEBUG intermediate *) val defs_of_rules : gdl_rule list -> exp_def list @@ -90,19 +91,18 @@ val initialize_game : term -> game_descr_entry list -> int -> - Arena.game_state * (int * int * float) option * gdl_translation + (Arena.game * Arena.game_state) * (int * int * float) option * gdl_translation val translate_last_action : - gdl_translation -> Arena.game_state -> term list -> + gdl_translation -> Arena.game * Arena.game_state -> term list -> string * DiscreteRule.matching (** Rule name, embedding, game state. *) -val translate_move : - gdl_translation -> Arena.game_state -> string -> (int * int) list -> - string +val translate_move : gdl_translation -> Arena.game * Arena.game_state -> + string -> (int * int) list -> string val our_turn : - gdl_translation -> Arena.game_state -> bool + gdl_translation -> Arena.game * Arena.game_state -> bool val noop_move : ?force:bool -> gdl_translation -> Arena.game_state -> string Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Makefile 2011-02-22 03:24:44 UTC (rev 1325) @@ -120,6 +120,7 @@ Play_tests: \ Play/HeuristicTest \ Play/MoveTest \ + Play/GameTreeTest \ Play/GameTest # GGP tests Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Play/Game.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -72,7 +72,8 @@ let gen_models rules models time moves = let (mv, a) = Move.gen_models rules models time moves in - (mv, Array.map (fun (l, m, t) -> {struc=m; time=t; loc=l}) a) + (mv, Array.map (fun s -> {struc=s.Arena.struc; + time=s.Arena.time; loc=s.Arena.cur_loc}) a) type uctree_node = { @@ -1112,6 +1113,7 @@ {Arena.rules = []; player_names = game.Arena.player_names; defined_rels = game.Arena.defined_rels; + data = game.Arena.data; graph = [| {Arena.id=0; player=gloc.Arena.player; payoffs=heuristics.(gloc.Arena.id); @@ -1165,36 +1167,35 @@ let initialize_default state ?loc ?(effort=default_effort) ~search_method ?horizon ?advr ?(payoffs_already_tnf=false) ?heuristic () = - let {Arena.rules=rules; graph=graph; num_players=num_players} = - state.Arena.game in - let struc = state.Arena.struc in + let {Arena.rules=rules; graph=graph; num_players=num_players} = fst state in + let struc = (snd state).Arena.struc in (* {{{ log entry *) if !debug_level > 0 then printf "\ninitializing game and play\n%!"; (* }}} *) (* TODO: default_heuristic redoes payoff normalization. *) - let game = state.Arena.game in + let game = fst state in let agent = match search_method with | "maximax" -> - default_maximax state.Arena.struc ~depth:effort ?heuristic + default_maximax struc ~depth:effort ?heuristic ?advr ~pruning:false game | "alpha_beta_ord" -> - default_maximax state.Arena.struc ~depth:effort ?heuristic + default_maximax struc ~depth:effort ?heuristic ?advr ~pruning:true game | "uct_random_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~random_playout:true game | "uct_greedy_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~random_playout:false game | "uct_maximax_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~random_playout:false ~playout_mm_depth:1 game | "uct_no_playouts" -> - default_treesearch state.Arena.struc + default_treesearch struc ~iters:effort ?heuristic ?advr ?horizon ~heur_effect:Heuristic_only game | s -> failwith ("Game.initialize: unknown search method "^s) Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Play/Game.mli 2011-02-22 03:24:44 UTC (rev 1325) @@ -174,7 +174,7 @@ Construct a default UCT tree search or plain maximax agent for use with the general {!toss} function. *) val initialize_default : - Arena.game_state -> ?loc:int -> ?effort:int -> + 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 -> Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2011-02-22 01:08:46 UTC (rev 1324) +++ trunk/Toss/Play/GameTest.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -46,10 +46,11 @@ let move_gs_str = Move.move_gs_str_short let update_game ?(defs=false) - (lazy (horizon, adv_ratio, game)) state cur_loc = - let state = - if defs then defstruc_of_str state else struc_of_str state in - horizon, adv_ratio, {game with Arena.struc = state; cur_loc = cur_loc} + (lazy (horizon, adv_ratio, (state_game, state))) new_struc_s new_loc = + let new_struc = + if defs then defstruc_of_str new_struc_s else struc_of_str new_struc_s in + horizon, adv_ratio, + (state_game, {state with Arena.struc = new_struc; cur_loc = new_loc}) let rec binary_to_assoc = function @@ -189,7 +190,7 @@ String.concat ", " (List.map (fun (p,v)->p^": "^string_of_float v) pay) -let try_n_times n state compute_move pred comment = +let try_n_times n (state_game, state) compute_move pred comment = let hist = ref 0 in let failed = ref [] in for i = 1 to n do @@ -218,7 +219,7 @@ try_n_times 5 state compute_move pred msg else let move, _ = compute_move () in - let move_str = move_gs_str state move in + let move_str = move_gs_str (snd state) move in assert_bool (Printf.sprintf "%s: Failed move: %s." msg move_str) (pred move_str) @@ -292,8 +293,7 @@ skip_if true "loading takes long, worked last time"; let _, advr, state = Lazy.force chess_game in - let struc = state.Arena.struc in - let game = state.Arena.game in + let (game, struc) = (fst state, (snd state).Arena.struc) in let play = {Game.game = game; agents= [|Game.Random_move; Game.Random_move|]; @@ -340,17 +340,17 @@ Game.toss ~grid_size:Move.cGRID_SIZE p ps) in assert_equal ~msg:"black wins: suggest" ~printer:(function | Aux.Left (bpos, moves, _, _) -> - "game not over: "^move_gs_str state moves.(bpos) + "game not over: "^move_gs_str (snd state) moves.(bpos) | Aux.Right poffs -> Printf.sprintf "{W: %F; B: %F}" poffs.(0) poffs.(1)) (Aux.Right [| -1.0; 1.0 |]) move_opt; let payoffs = Array.to_list (Array.mapi (fun i v->string_of_int i,v) - state.Arena.game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs_pp) - in + (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs_pp) + in let ev (p,e) = p^": "^(string_of_float - (Solver.M.get_real_val e state.Arena.struc)) in + (Solver.M.get_real_val e (snd state).Arena.struc)) in let answ = String.concat ", " (List.sort compare (List.map ev payoffs)) in assert_equal ~msg:"black wins: direct" ~printer:(fun x->x) @@ -384,11 +384,11 @@ let payoffs = Array.to_list (Array.mapi (fun i v->string_of_int i,v) - state.Arena.game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs_pp) + (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs_pp) in let ev (p,e) = p^": "^(string_of_float - (Solver.M.get_real_val e state.Arena.struc)) in + (Solver.M.get_real_val e (snd state).Arena.struc)) in let answ = String.concat ", " (List.sort compare (List.map ev payoffs)) in assert_equal ~msg:"draw (white no move): direct" ~printer:(fun x->x) @@ -401,7 +401,7 @@ Game.toss ~grid_size:Move.cGRID_SIZE p ps) in assert_equal ~msg:"draw (white no move): suggest" ~printer:(function | Aux.Left (bpos, moves, _, _) -> - "game not over: "^move_gs_str state moves.(bpos) + "game not over: "^ move_gs_str (snd state) moves.(bpos) | Aux.Right poffs -> Printf.sprintf "{W: %F; B: %F}" poffs.(0) poffs.(1)) (Aux.Right [| 0.0; 0.0 |]) move_opt; @@ -411,8 +411,8 @@ (fun () -> let horizon, advr, state = Lazy.force breakthrough_game in - let r = List.assoc "WhiteDiag" state.Arena.game.Arena.rules in - let matches = ContinuousRule.matches state.Arena.struc r in + let r = List.assoc "WhiteDiag" (fst state).Arena.rules in + let matches = ContinuousRule.matches (snd state).Arena.struc r in assert_bool "Diagonal move should be possible." (matches <> []) ); @@ -436,12 +436,12 @@ state_of_str "#TestGame.ml:play with horizon#RULE 1: [ | | ] -> [ 1 | R:2{} | ] emb R with [] LOC 0 {PLAYER 1 PAYOFF {1: 0.0} MOVES [1, t: 1. -- 1.-> 0]} PLAYERS 1 MODEL [ | R:2 {} | ]" in let play = { - Game.game = state.Arena.game; + Game.game = fst state; agents = [| Game.Random_move |]; delta = 1.0; } in let init = - Game.initial_state play state.Arena.struc in + Game.initial_state play (snd state).Arena.struc in let endmodel, _ = Game.play ~grid_size:1 ~horizon:300 play init in assert_equal ~printer:string_of_int 300 @@ -908,17 +908,17 @@ (fun () -> let (horizon, advr, state) = Lazy.force chess_game in - let struc = state.Arena.struc in - let game = state.Arena.game in + let struc = (snd state).Arena.struc in + let game = fst state in (* TODO: default_heuristic redoes payoff normalization. *) (* default_treesearch uses horizon, but default_maximax doesn't *) let play = {Game.game = game; agents= [| - Game.default_maximax state.Arena.struc ~depth:1 + Game.default_maximax (snd state).Arena.struc ~depth:1 ~heuristic:chess_piece_value_heur ~advr ~pruning:true game; - Game.default_maximax state.Arena.struc ~depth:2 + Game.default_maximax (snd state).Arena.struc ~depth:2 ~heuristic:chess_piece_value_heur ~advr ~pruning:true game; |]; Added: trunk/Toss/Play/GameTree.ml =================================================================== --- trunk/Toss/Play/GameTree.ml (rev 0) +++ trunk/Toss/Play/GameTree.ml 2011-02-22 03:24:44 UTC (rev 1325) @@ -0,0 +1,186 @@ +(* Game Tree used for choosing moves. *) + + +(* Abstract game tree, just stores state and move information. *) +type ('a, 'b) abstract_game_tree = + | Terminal of Arena.game_state * int * 'b (* terminal state with player *) + | Leaf of Arena.game_state * int * 'a (* leaf with state, player *) + | Node of Arena.game_state * int * 'a * (* node with state, player, moves *) + (Move.move * ('a, 'b) abstract_game_tree) array + +(* Abstract tree printing function. *) +let rec str_abstract ?(depth=0) str_info str_info_terminal tree = + let s msg state player info_s = + let struc_s = Structure.str state.Arena.struc in + let head_s = Printf.sprintf "Player %d loc %d time %.1f.\n" + player state.Arena.cur_loc state.Arena.time in + let res = "\n" ^ msg ^ head_s ^ struc_s ^ "\n" ^ info_s in + let prefix = if depth=0 then "" else (String.make depth '|') ^ " " in + Str.global_replace (Str.regexp "\n") ("\n" ^ prefix) res in + match tree with + | Terminal (state, player, info) -> + s "Terminal. " state player (str_info_terminal info) + | Leaf (state, player, info) -> s "Leaf. " state player (str_info info) + | Node (state, player, info, children) -> + let next_str (_, t) = + str_abstract ~depth:(depth+1) str_info str_info_terminal t in + let child_s = Array.to_list (Array.map next_str children) in + String.concat "" ((s "Node. " state player (str_info info)) :: child_s) + +(* Number of nodes in the tree. *) +let rec size = function + | Terminal _ | Leaf _ -> 1 + | Node (_, _, _, children) -> + Array.fold_left (fun s (_, c) -> s + (size c)) 1 children + +(* Player in the given node. *) +let player = function + | Terminal (_, player, _) -> player + | Leaf (_, player, _) -> player + | Node (_, player, _, _) -> player + +(* State in the given node. *) +let state = function + | Terminal (state, _, _) -> state + | Leaf (state, _, _) -> state + | Node (state, _, _, _) -> state + + +(* Abstract game tree initialization. *) +let init_abstract game state info_leaf = + let player = game.Arena.graph.(state.Arena.cur_loc).Arena.player in + Leaf (state, player, info_leaf game state player) + + +(* Abstract game tree unfolding function, calls argument functions for work. *) +let rec unfold_abstract ?(depth=0) game + ~info_terminal ~info_leaf ~info_node ~choice = function + | Terminal _ as t -> t + | Leaf (state, player, info) -> + let moves = Move.list_moves game state in + if moves = [||] then + Terminal (state, player, info_terminal depth game state player info) + else + let leaf_of_move leaf_s = + let leaf_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in + Leaf (leaf_s, leaf_pl, info_leaf (depth+1) game leaf_s leaf_pl) in + let children = Array.map (fun (m, s) -> (m, leaf_of_move s)) moves in + Node (state, player,info_node depth game state player children,children) + | Node (state, player, info, children) -> + let n = choice depth game state player info children in + let (move, child) = children.(n) in + let child_unfolded = unfold_abstract ~depth:(depth+1) game + ~info_terminal:info_terminal ~info_leaf:info_leaf ~info_node:info_node + ~choice:choice child in + children.(n) <- (move, child_unfolded); + Node (state, player, info_node depth game state player children, children) + + +(* -------------- TREES WITH PAYOFF AND HEURISTIC DATA --------------- *) + +let cPAYOFF_AS_HEUR = ref 1000. + +(* The general information in a game tree node. *) +type 'a node_info = { + heurs : float array ; (* Heuristic calculated directly or by maximax. *) + info : 'a ; (* Other information. *) +} + +type 'a terminal_info = { + payoffs : float array ; (* Payoffs. *) + heurs_t : float array ; (* Heuristic. *) + info_t : 'a ; (* Other information. *) +} + +type 'a game_tree = ('a node_info, 'a terminal_info) abstract_game_tree + + +(* Game tree printing function. *) +let str f ?(depth=0) tree = + let fas a = String.concat "; " (List.map string_of_float (Array.to_list a)) in + let str_terminal i = "Payoffs: " ^ (fas i.payoffs) ^ + " heurs: " ^ (fas i.heurs_t) ^ " info: " ^ (f i.info_t) in + let str_node i = "Heurs: " ^ (fas i.heurs) ^ " info: " ^ (f i.info) in + str_abstract ~depth:depth str_node str_terminal tree + +(* Get the payoffs / heuristics array of a game tree node. *) +let node_values = function + | Terminal (_, _, i) -> i.payoffs + | Leaf (_, _, i) -> i.heurs + | Node (_, _, i, _) -> i.heurs + +(* Get the stored information of a game tree node. *) +let node_info = function + | Terminal (_, _, i) -> i.info_t + | Leaf (_, _, i) -> i.info + | Node (_, _, i, _) -> i.info + + + +(* Game tree initialization. *) +let info_leaf_f f heurs depth game state player = + let calc re = + Solver.M.get_real_val (Solver.M.register_real_expr re) state.Arena.struc in + { heurs = Array.map calc heurs.(state.Arena.cur_loc); + info = f depth game state } + +let init game state f h = init_abstract game state (info_leaf_f f h 0) + + +(* Game tree unfolding. *) + +let info_terminal_f f depth game state player leaf_info = + let calc re = Solver.M.get_real_val re state.Arena.struc in + let payoffs = + Array.map calc game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs_pp in + { payoffs = payoffs; heurs_t = leaf_info.heurs ; info_t = f depth game state } + +let info_node_f f depth game state player children = + let move_val p mv = (node_values (snd mv)).(p) in + let mval c = move_val player c in + let max_val = ref (mval children.(0)) in + Array.iter (fun c -> max_val := max !max_val (mval c)) children; + let mids = ref [] in (* TODO: use Aux.array_argfind_all_max !!! *) + Array.iteri (fun i c -> if mval c = !max_val then mids := i::!mids) children; + let child = children.(List.hd !mids) in + let pval p = List.fold_left (fun minv i -> + min minv (move_val p children.(i))) (move_val p child) !mids in + let heurs = Array.mapi (fun p _ -> pval p) (node_values (snd child)) in + { heurs = heurs ; info = f depth player heurs children } + +(* Main unfolding function. *) +let unfold game heur ~info_leaf ~info_node ~choice = + unfold_abstract game + ~info_terminal:(info_terminal_f info_leaf) + ~info_leaf:(info_leaf_f info_leaf heur) + ~info_node:(info_node_f info_node) + ~choice:choice + + +(* ------------ MAXIMAX BY DEPTH ------------- *) + +let depth_ready_leaf maxdp dp g s = dp >= maxdp +let depth_ready_node maxdp dp player heurs children = + let mval child = (node_values (snd child)).(player) in + let maxval = heurs.(player) in + Aux.array_existsi (fun _ c -> mval c = maxval && node_info (snd c)) children + +let depth_maximax_choice maxdp dp game state player info children = + let mval child = (node_values (snd child)).(player) in + let (max_val, u... [truncated message content] |