[Toss-devel-svn] SF.net SVN: toss:[1320] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
From: <luk...@us...> - 2011-02-13 23:17:43
|
Revision: 1320 http://toss.svn.sourceforge.net/toss/?rev=1320&view=rev Author: lukaszkaiser Date: 2011-02-13 23:17:36 +0000 (Sun, 13 Feb 2011) Log Message: ----------- Fluents heuristic, ability to run experiments from server. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/Arena.mli trunk/Toss/Arena/DiscreteRule.ml trunk/Toss/Arena/DiscreteRule.mli trunk/Toss/Play/Game.ml trunk/Toss/Play/Game.mli trunk/Toss/Server/Server.ml Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/Arena.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -69,6 +69,14 @@ (* -------------------- PARSER HELPER ------------------------------ *) +(* Rules with which a player with given number can move. *) +let rules_for_player player_no game = + let rules_of_loc l = + if l.player = player_no then + Some (List.map (fun (lab, _) -> lab.rule) l.moves) + else None in + List.concat (Aux.map_some rules_of_loc (Array.to_list game.graph)) + (* Add a defined relation to a structure. *) let add_def_rel_single struc (r_name, vars, def_phi) = let def_asg = Solver.M.evaluate struc Modified: trunk/Toss/Arena/Arena.mli =================================================================== --- trunk/Toss/Arena/Arena.mli 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/Arena.mli 2011-02-13 23:17:36 UTC (rev 1320) @@ -43,6 +43,9 @@ val empty_state : game_state +(** Rules with which a player with given number can move. *) +val rules_for_player : int -> game -> string list + val add_def_rels : Structure.structure -> (string * string list * Formula.formula) list -> Structure.structure Modified: trunk/Toss/Arena/DiscreteRule.ml =================================================================== --- trunk/Toss/Arena/DiscreteRule.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/DiscreteRule.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -47,7 +47,15 @@ } (* We call fluents the relations that can be modified by a rule. *) -let fluents r = +let fluents_make ?(only_pos=false) f r = + let fl_make (s, tp) = + if tp = [] then None else + Some (f s (Array.length (List.hd tp))) in + if only_pos then + Aux.map_some fl_make r.rhs_pos_tuples + else Aux.map_some fl_make (r.rhs_pos_tuples @ r.rhs_neg_tuples) + +let fluents r = let map_rels = Aux.map_some (fun (rel,tups)->if tups=[] then None else Some rel) in map_rels r.rhs_pos_tuples @ map_rels r.rhs_neg_tuples Modified: trunk/Toss/Arena/DiscreteRule.mli =================================================================== --- trunk/Toss/Arena/DiscreteRule.mli 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Arena/DiscreteRule.mli 2011-02-13 23:17:36 UTC (rev 1320) @@ -44,6 +44,8 @@ (* We call fluents the relations that can be modified by a rule. *) val fluents : rule_obj -> string list +val fluents_make : ?only_pos : bool -> (string -> int -> 'a) -> + rule_obj -> 'a list (* A relation is monotonic if it cannot remove tuples. *) val monotonic : rule_obj -> bool Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Play/Game.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -287,6 +287,28 @@ res) node.Arena.payoffs) graph +let fluents_heuristic game = + let (no_players, rules) = (game.Arena.num_players, game.Arena.rules) in + let pl_rules = Array.mapi + (fun i _ -> Arena.rules_for_player i game) (Array.create no_players 1) in + let pos_fluents_of_rule rname = + let drule = (List.assoc rname rules).ContinuousRule.compiled in + let list_upto_one s i = + let vx = Formula.fo_var_of_string "x" in + if i = 0 then Formula.Const (0.) else if i = 1 then + Formula.Sum ([vx], Formula.Rel (s, [|vx|]), Formula.Const (1.)) + else Formula.Const (0.) in + DiscreteRule.fluents_make ~only_pos:true list_upto_one drule in + let pl_fluents = Array.map (Aux.concat_map pos_fluents_of_rule) pl_rules in + let sums = Array.map (fun fl -> + List.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) + (Aux.unique_sorted fl)) pl_fluents in + let sum_all = + Array.fold_left (fun s n-> Formula.Plus (n, s)) (Formula.Const (0.)) sums in + let heurs = Array.map (fun f -> + Formula.Plus (Formula.Times (Formula.Const (2.), f), + Formula.Times (Formula.Const (-1.), sum_all))) sums in + Array.map (fun _ -> heurs) game.Arena.graph (* The UCB1-TUNED estimate, modified to extend to the zero- and one-observation cases. *) @@ -1072,7 +1094,7 @@ match res with | Aux.Left (_,_,_,state) -> (* {{{ log entry *) - if !debug_level > 5 || (!debug_level > 1 && set_timer <> None) then + if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then printf "step-state:\n%s\n%!" (Structure.str state.game_state.struc); (* }}} *) play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state Modified: trunk/Toss/Play/Game.mli =================================================================== --- trunk/Toss/Play/Game.mli 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Play/Game.mli 2011-02-13 23:17:36 UTC (rev 1320) @@ -213,7 +213,13 @@ val suggest : ?effort:int -> play -> play_state -> (move * play_state) option +(** Various constructed heuristics. *) +val default_heuristic : ?struc:Structure.structure -> float -> + Arena.game -> Formula.real_expr array array +val fluents_heuristic : Arena.game -> Formula.real_expr array array + + (* ------------------------- DEBUGGING ------------------------------------- *) (** Debugging information. At level 0 nothing is printed out. Modified: trunk/Toss/Server/Server.ml =================================================================== --- trunk/Toss/Server/Server.ml 2011-02-13 17:46:00 UTC (rev 1319) +++ trunk/Toss/Server/Server.ml 2011-02-13 23:17:36 UTC (rev 1320) @@ -268,7 +268,7 @@ | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) -> (* GDL will store the player and the game in its state. *) - Random.init 1234; (* for repeatablity *) + Random.self_init (); (* Random.init 1234; for repeatablity *) let effort, horizon, heur_adv_ratio = GDL.initialize_game state player game_descr startcl in (* TODO: handle timer (startclock) in Game.initialize_default*) @@ -490,6 +490,96 @@ output_string out_ch ("ERR internal error -- see server stdout\n") +let set_state_from_file fn = + Printf.printf "Loading file %s...\n%!" fn; + let f = open_in fn in + let s = ArenaParser.parse_game_state Lexer.lex (Lexing.from_channel f) in + Printf.printf "File %s loaded.\n%!" fn; + game_modified := true; + state := s; +;; + +let heur_val_white1 = ref "";; +let heur_val_black1 = ref "";; +let heur_val_white2 = ref "";; +let heur_val_black2 = ref "";; + +let heur_of_vals white_val black_val = + let real_expr_of_str s = + FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s) in + let white_heur = + real_expr_of_str ("("^white_val^") - ("^black_val^")") in + let black_heur = + real_expr_of_str ("("^black_val^") - ("^white_val^")") in + let heuristic = [|white_heur; black_heur|] in + Array.make (Array.length !state.Arena.game.Arena.graph) heuristic +;; + +let print_heur pl heur = + print_endline ("\nAll-Heuristics for player " ^ pl); + let print_heur_arr = Array.iteri (fun i heur -> + print_endline ("\n for player " ^ (string_of_int i)); + print_endline (" " ^ Formula.sprint_real heur);) in + Array.iteri (fun i harr -> + print_endline ("\nHeuristic for location " ^ (string_of_int i)); + print_heur_arr harr;) heur +;; + +let add_heur h1 factor h2 = + Array.mapi (fun i a -> Array.mapi (fun j p -> + Formula.Plus (p, Formula.Times (Formula.Const factor, h2.(i).(j)))) a) h1 +;; + +let run_test n depth1 depth2 = + let (horizon, heur_adv_ratio) = (Some 400, 2.0) in + let struc = !state.Arena.struc in + let game = !state.Arena.game in + let heur1 = + if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then + let dh = + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + add_heur dh 0.2 (Game.fluents_heuristic game) + else if (!heur_val_white1 = "FLUENT" || !heur_val_black1 = "FLUENT") then + Game.fluents_heuristic game + else if (!heur_val_white1 <> "" && !heur_val_black1 <> "") then + heur_of_vals !heur_val_white1 !heur_val_black1 + else + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + let heur2 = + if (!heur_val_white2 = "MIX" || !heur_val_black2 = "MIX") then + let dh = + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + add_heur dh 0.2 (Game.fluents_heuristic game) + else if (!heur_val_white2 = "FLUENT" || !heur_val_black2 = "FLUENT") then + Game.fluents_heuristic game + else if (!heur_val_white2 <> "" && !heur_val_black2 <> "") then + heur_of_vals !heur_val_white2 !heur_val_black2 + else + Game.default_heuristic ~struc:!state.Arena.struc heur_adv_ratio game in + if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2); + let play = {Game.game = game; agents= + [| Game.default_maximax !state.Arena.struc ~depth:depth1 + ~heuristic:heur1 ~heur_adv_ratio ~pruning:true game; + Game.default_maximax !state.Arena.struc ~depth:depth2 + ~heuristic:heur2 ~heur_adv_ratio ~pruning:true game; + |]; delta = 2.0} in (* FIXME: give/calc delta *) + let init_state = Game.initial_state play struc in + Game.set_debug_level 1; + let (aggr_payoff_w, aggr_payoff_b) = (ref 0., ref 0.) in + Printf.printf "Experiment -- running test!\n"; + for i = 1 to n do ( + Random.self_init (); + Printf.printf "Experiment: Game nr %d of %d\n%!" i n; + let _,payoff = Game.play ~grid_size:Game.cGRID_SIZE ~set_timer:3600 + ?horizon play init_state in + Printf.printf "Game %d payoffs %f, %f\n" i payoff.(0) payoff.(1); + aggr_payoff_w := !aggr_payoff_w +. payoff.(0); + aggr_payoff_b := !aggr_payoff_b +. payoff.(1); + Printf.printf "Aggregate payoffs %f, %f\n" !aggr_payoff_w !aggr_payoff_b; + ) done; +;; + + (* ----------------------- START SERVER WHEN CALLED ------------------------- *) let main () = @@ -498,6 +588,7 @@ Gc.minor_heap_size = 80*1024; (* 2*std, opt ~= L2 cache/proc *) Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) }; let (server, port) = (ref "localhost", ref 8110) in + let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in let opts = [ ("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose"); ("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose"); @@ -506,12 +597,27 @@ ("-gdl", Arg.String (fun s -> GDL.manual_game := s; GDL.manual_translation := true), " GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)"); + ("-f", Arg.String (fun s -> set_state_from_file s), " open file"); ("-nm", Arg.Unit (fun () -> Game.use_monotonic := false), " turn monotonicity off"); ("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)"); ("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)"); + ("-heur-white-1", Arg.String (fun s -> heur_val_white1 := s), + "white (=first) player heuristic for use by the first player in tests"); + ("-heur-black-1", Arg.String (fun s -> heur_val_black1 := s), + "black (=second) player heuristic for use by the first player in tests"); + ("-heur-white-2", Arg.String (fun s -> heur_val_white2 := s), + "white (=first) player heuristic for use by the second player in tests"); + ("-heur-black-2", Arg.String (fun s -> heur_val_black2 := s), + "black (=second) player heuristic for use by the second player in tests"); + ("-experiment", + Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i); + Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)], + "run experiment on the open file [i] times with depth [d1, d2]") ] in Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following."; - try + if !experiment then + run_test !e_len !e_d1 !e_d2 + else try start_server req_handle !port !server with Host_not_found -> print_endline "The host you specified was not found." ;; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |