toss-devel-svn Mailing List for Toss (Page 17)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn — Toss development: svn commits
You can subscribe to this list here.
| 2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(25) |
Dec
(62) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2011 |
Jan
(26) |
Feb
(38) |
Mar
(67) |
Apr
(22) |
May
(41) |
Jun
(30) |
Jul
(24) |
Aug
(32) |
Sep
(29) |
Oct
(34) |
Nov
(18) |
Dec
(2) |
| 2012 |
Jan
(19) |
Feb
(25) |
Mar
(16) |
Apr
(2) |
May
(18) |
Jun
(21) |
Jul
(11) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <luk...@us...> - 2011-03-08 11:15:27
|
Revision: 1348
http://toss.svn.sourceforge.net/toss/?rev=1348&view=rev
Author: lukaszkaiser
Date: 2011-03-08 11:15:20 +0000 (Tue, 08 Mar 2011)
Log Message:
-----------
Separate GameTree into GameTree and Play, debug alpha-beta variable depth problems.
Modified Paths:
--------------
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Makefile
trunk/Toss/Server/Server.ml
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Added Paths:
-----------
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Play/PlayTest.ml
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/Play/GameTree.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -170,8 +170,11 @@
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
let is_exact_child c = node_is_exact (snd children.(c)) in
+ let non_leaf c = match snd children.(c) with Leaf _ -> false | _ -> true in
+ let exact_nonleaf c = is_exact_child c && non_leaf c in
{ heurs= heurs;
- heurs_are_exact = List.for_all is_exact_child mids;
+ heurs_are_exact =
+ List.exists non_leaf mids || List.for_all is_exact_child mids;
info = f depth player heurs children }
let choice_f g_heurs choice depth game state player info children_orig =
@@ -228,58 +231,3 @@
let mxs = List.filter (fun (_,c) -> (node_values c).(p)=mx) nonleaves in
let (m, t) = Aux.random_elem mxs in (m, state t)
)
-
-(* ------------ MAXIMAX BY DEPTH ------------- *)
-
-let maxdepth_node dp player heurs children =
- let depths = Array.map (fun child -> (node_info (snd child))) children in
- (Array.fold_left (fun m d -> max m d) 0 depths) + 1
-
-let maximax_depth_choice ab stop_vals dp game cur_state player info children =
- let mval child = (node_values (snd child)).(player), node_info (snd child) in
- let cmp c1 c2 =
- let (v1, d1), (v2, d2) = mval c1, mval c2 in
- if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in
- let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in
- if !debug_level > 2 then
- print_endline (Structure.str (state (snd children.(res))).Arena.struc);
- if ab then (
- let cmp_dpt c1 c2 = (snd (mval c1)) - (snd (mval c2)) in
- let maxdps = Aux.array_argfind_all_max cmp_dpt children in
- let maxd = snd (mval children.(List.hd maxdps)) in
- if snd (mval children.(res)) = maxd - 1 then (
- let maxa = ref (node_values (snd children.(List.hd maxdps))) in
- let big c = fst (mval children.(c)) > !maxa.(player) in
- let upd c = maxa := node_values (snd children.(c)) in
- List.iter (fun c -> if big c then upd c) maxdps;
- stop_vals := Some !maxa
- ) else stop_vals := None
- );
- res
-
-
-(* Maximax by depth unfolding function. Throws Not_found if ready. *)
-let unfold_maximax ?(ab=false) game heur =
- unfold ~ab:ab game heur ~info_leaf:(fun _ _ _ -> 0)
- ~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 || Game.get_timeout () then (
- if !debug_level > 1 && Game.get_timeout () then print_endline "Timeout";
- t
- ) 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
- with Not_found -> t
-
-(* Maximax unfold upto depth and choose move. *)
-let maximax_unfold_choose 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;
- 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 string_of_int u);
- choose_move game u
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/Play/GameTree.mli 2011-03-08 11:15:20 UTC (rev 1348)
@@ -91,18 +91,3 @@
int -> 'a node_info -> (Move.move * 'a game_tree) array -> int) ->
'a game_tree -> 'a game_tree
-
-(** ------------ MAXIMAX BY DEPTH ------------- *)
-
-(** Maximax by depth unfolding function. Throws Not_found if ready. *)
-val unfold_maximax : ?ab:bool -> Arena.game ->
- Formula.real_expr array array -> int game_tree -> int game_tree
-
-
-(** Maximax unfolding upto depth. *)
-val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
- Formula.real_expr array array -> int game_tree -> int game_tree
-
-(** 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
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -67,82 +67,7 @@
assert_equal ~printer:(fun x -> string_of_int x) (GameTree.player u)
g.Arena.graph.((GameTree.state u).Arena.cur_loc).Arena.player;
);
-
- "maximax unfold once, node_info" >::
- (fun () ->
- 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 = GameTree.unfold_maximax g h t in
- (* print_endline (GameTree.str string_of_int u); *)
- assert_equal ~printer:(fun x -> string_of_int x) 1 (GameTree.node_info u);
- );
-
- "maximax unfold upto depth, size" >::
- (fun () ->
- 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 = GameTree.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 = GameTree.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);
- );
-
- "maximax suggest move: Tic-Tac-Toe defense" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
-
- . . .
-
- . P .
-
- . P Q
-\"" in
- let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" ~struc ~loc:1 in
- (* GameTree.set_debug_level 1; *)
- let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
- let (m, ns) = GameTree.maximax_unfold_choose 9 g s h in
- assert_equal ~printer:(fun x -> x) "Circle{1:b3}"
- (Move.move_gs_str_short s m);
- );
]
-let bigtests = "GameTreeBig" >::: [
- "maximax suggest move: Gomoku defense" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... P.. ... ...
- ... ... ... ...
- ... Q..P P..P ...
- ... ... ... ...
- Q ... P..Q ... ...
- ... ... ... ...
- ... 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
- let (g, s) = state_of_file "./examples/Gomoku.toss" ~struc ~loc:1 in
- (* GameTree.set_debug_level 1; *)
- let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
- let (m, ns) = GameTree.maximax_unfold_choose 160 g s h in
- assert_equal ~printer:(fun x -> x) "Circle{1:d8}"
- (Move.move_gs_str_short s m);
- );
-]
-
let exec = Aux.run_test_if_target "GameTreeTest" tests
-
-let execbig = Aux.run_test_if_target "GameTreeTest" bigtests
Modified: trunk/Toss/Play/Makefile
===================================================================
--- trunk/Toss/Play/Makefile 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/Play/Makefile 2011-03-08 11:15:20 UTC (rev 1348)
@@ -12,16 +12,19 @@
HeuristicTest:
MoveTest:
GameTreeTest:
+PlayTest:
GameTest:
HeuristicTestProfile:
MoveTestProfile:
GameTreeTestProfile:
+PlayTestProfile:
GameTestProfile:
HeuristicTestDebug:
MoveTestDebug:
GameTreeTestDebug:
+PlayTestDebug:
GameTestDebug:
tests:
Added: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml (rev 0)
+++ trunk/Toss/Play/Play.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -0,0 +1,62 @@
+(* Module with different play strategies. *)
+
+open GameTree
+
+let debug_level = ref 0
+let set_debug_level i = debug_level := i
+
+
+(* ------------ MAXIMAX BY DEPTH ------------- *)
+
+let maxdepth_node dp player heurs children =
+ let depths = Array.map (fun child -> (node_info (snd child))) children in
+ (Array.fold_left (fun m d -> max m d) 0 depths) + 1
+
+let maximax_depth_choice ab stop_vals dp game cur_state player info children =
+ let mval child = (node_values (snd child)).(player), node_info (snd child) in
+ let cmp c1 c2 =
+ let (v1, d1), (v2, d2) = mval c1, mval c2 in
+ if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in
+ let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in
+ if !debug_level > 2 then
+ print_endline (Structure.str (state (snd children.(res))).Arena.struc);
+ if ab then (
+ let cmp_dpt c1 c2 = (snd (mval c1)) - (snd (mval c2)) in
+ let maxdps = Aux.array_argfind_all_max cmp_dpt children in
+ let maxd = snd (mval children.(List.hd maxdps)) in
+ if snd (mval children.(res)) = maxd - 1 then (
+ let maxa = ref (node_values (snd children.(List.hd maxdps))) in
+ let big c = fst (mval children.(c)) > !maxa.(player) in
+ let upd c = maxa := node_values (snd children.(c)) in
+ List.iter (fun c -> if big c then upd c) maxdps;
+ stop_vals := Some !maxa
+ ) else stop_vals := None
+ );
+ res
+
+
+(* Maximax by depth unfolding function. Throws Not_found if ready. *)
+let unfold_maximax ?(ab=false) game heur =
+ unfold ~ab:ab game heur ~info_leaf:(fun _ _ _ -> 0)
+ ~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 || Game.get_timeout () then (
+ if !debug_level > 1 && Game.get_timeout () then print_endline "Timeout";
+ t
+ ) 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
+ with Not_found -> t
+
+(* Maximax unfold upto depth and choose move. *)
+let maximax_unfold_choose 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;
+ 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 string_of_int u);
+ choose_move game u
Added: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli (rev 0)
+++ trunk/Toss/Play/Play.mli 2011-03-08 11:15:20 UTC (rev 1348)
@@ -0,0 +1,20 @@
+(** Different play strategies. *)
+
+val set_debug_level : int -> unit
+
+
+(** ------------ MAXIMAX BY DEPTH ------------- *)
+
+(** Maximax by depth unfolding function. Throws Not_found if ready. *)
+val unfold_maximax : ?ab:bool -> Arena.game -> Formula.real_expr array array ->
+ int GameTree.game_tree -> int GameTree.game_tree
+
+
+(** Maximax unfolding upto depth. *)
+val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
+ Formula.real_expr array array ->
+ int GameTree.game_tree -> int GameTree.game_tree
+
+(** 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
Added: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml (rev 0)
+++ trunk/Toss/Play/PlayTest.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -0,0 +1,158 @@
+open OUnit
+
+open Play
+
+let debug_level = ref 0
+
+let raw_state_of_file s =
+ if !debug_level > 0 then Printf.printf "Loading file %s...\n%!" s;
+ let f = open_in s in
+ let res =
+ ArenaParser.parse_game_state Lexer.lex
+ (Lexing.from_channel f) in
+ if !debug_level > 0 then Printf.printf "File %s loaded.\n%!" s;
+ res
+
+let struc_of_str s =
+ match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
+ | Arena.StateStruc struc -> struc
+ | _ -> failwith "GameTreeTest:struc_of_str: not a structure"
+
+let state_of_file ?(struc="") ?(time=0.) ?(loc=0) fname =
+ let (g, s) = raw_state_of_file fname in
+ let structure = if struc = "" then s.Arena.struc else struc_of_str struc in
+ (g, { Arena.struc = structure; time = time; cur_loc = loc })
+
+
+let test_maximax ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
+ ~iters gname move_s =
+ let (g, s) = state_of_file ("./examples/"^gname^".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
+ let (m, ns) = Play.maximax_unfold_choose iters g s h in
+ assert_equal ~printer:(fun x -> x) move_s (Move.move_gs_str_short s m)
+
+
+let tests = "Play" >::: [
+ "maximax unfold once, node_info" >::
+ (fun () ->
+ 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 g h t in
+ (* print_endline (GameTree.str string_of_int u); *)
+ assert_equal ~printer:(fun x -> string_of_int x) 1 (GameTree.node_info u);
+ );
+
+ "maximax unfold upto depth, size" >::
+ (fun () ->
+ 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
+ (* 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
+ (* print_endline (GameTree.str string_of_int u1); *)
+ assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u1);
+ );
+
+ "maximax suggest move: Tic-Tac-Toe defense" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+
+ . . .
+
+ . P .
+
+ . P Q
+\"" in
+ test_maximax "Tic-Tac-Toe" ~struc ~loc:1 ~iters:9 "Circle{1:b3}";
+ );
+]
+
+
+let gomoku_tests_big = "Gomoku" >::: [
+ "maximax suggest defense 1" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ...P ... ...
+ ... ... ... ...
+ ... P.. ... ...
+ ... ... ... ...
+ ... Q..P P..P ...
+ ... ... ... ...
+ Q ... P..Q ... ...
+ ... ... ... ...
+ ... 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_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:160 "Circle{1:d8}";
+ );
+
+ "maximax suggest defense 2" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ P.. ... ... ...
+ ... ... ... ...
+ ...P ...Q ...P ...
+ ... ... ... ...
+ Q..P Q..Q Q..P Q..
+ ... ... ... ...
+ P.. P..Q Q..Q Q..P
+ ... ... ... ...
+ P..Q P..P Q.. ...
+ ... ... ... ...
+ ...Q P..Q Q.. P..P
+ ... ... ... ...
+ P ... P..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_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:180 "Circle{1:e1}";
+ );
+
+ "maximax suggest defense 3" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ...P ... ...
+ ... ... ... ...
+ ... Q..Q ... ...
+ ... ... ... ...
+ ... P..P Q..P ...
+ ... ... ... ...
+ ... P..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_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:210 "Circle{1:b6}";
+ );
+]
+
+let bigtests = "PlayBig" >::: [
+ gomoku_tests_big;
+]
+
+
+let exec = Aux.run_test_if_target "PlayTest" tests
+
+let execbig = Aux.run_test_if_target "PlayTest" bigtests
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/Server/Server.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -209,7 +209,7 @@
~struc:(snd !state).Arena.struc
~advr:4. (fst !state));
Aux.unsome !g_heur in
- let (move, _) = GameTree.maximax_unfold_choose effort
+ let (move, _) = Play.maximax_unfold_choose effort
(fst !state) (snd !state) heur in
Game.cancel_timeout ();
Move.move_gs_str !state move
@@ -414,7 +414,7 @@
let heur = match !g_heur with
| Some h -> h
| None -> failwith "no heuristic for gametree!" in
- let (move, _) = GameTree.maximax_unfold_choose 5500
+ let (move, _) = Play.maximax_unfold_choose 5500
(fst !state) (snd !state) heur in
Game.cancel_timeout ();
GDL.translate_move !gdl_transl !state
@@ -513,7 +513,7 @@
) else (
let heur = if pl = 0 then heur1 else heur2 in
ignore (Unix.alarm timeo);
- let (_, s) = GameTree.maximax_unfold_choose depth game !cur_state heur in
+ let (_, s) = Play.maximax_unfold_choose depth game !cur_state heur in
Game.cancel_timeout();
cur_state := s
);
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/TossFullTest.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -10,7 +10,7 @@
let play_tests_big = "Play" >::: [
HeuristicTest.bigtests;
- GameTreeTest.bigtests;
+ PlayTest.bigtests;
GameTest.bigtests;
]
Modified: trunk/Toss/TossTest.ml
===================================================================
--- trunk/Toss/TossTest.ml 2011-03-07 23:33:14 UTC (rev 1347)
+++ trunk/Toss/TossTest.ml 2011-03-08 11:15:20 UTC (rev 1348)
@@ -24,6 +24,7 @@
HeuristicTest.tests;
MoveTest.tests;
GameTreeTest.tests;
+ PlayTest.tests;
GameTest.tests;
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-07 23:33:24
|
Revision: 1347
http://toss.svn.sourceforge.net/toss/?rev=1347&view=rev
Author: lukaszkaiser
Date: 2011-03-07 23:33:14 +0000 (Mon, 07 Mar 2011)
Log Message:
-----------
Debugging GameTree, using timeout in Client.
Modified Paths:
--------------
trunk/Toss/Client/SystemDisplay.py
trunk/Toss/Client/Wrapper.py
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/TossFullTest.ml
Modified: trunk/Toss/Client/SystemDisplay.py
===================================================================
--- trunk/Toss/Client/SystemDisplay.py 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Client/SystemDisplay.py 2011-03-07 23:33:14 UTC (rev 1347)
@@ -43,10 +43,10 @@
suggest_bt = self.toolbar.addAction (QIcon(":/pics/move.svg"),"Hint")
QObject.connect(suggest_bt, SIGNAL("triggered ()"), self.suggest)
- self.__sg_iters = 2
- dp = self.system.get_data("depth")
- if dp != "none": self.__sg_iters = int(dp)
- self.sg_iters_bt = self.toolbar.addAction ("Depth: " +
+ self.__sg_iters = 5
+ #dp = self.system.get_data("depth")
+ #if dp != "none": self.__sg_iters = int(dp)
+ self.sg_iters_bt = self.toolbar.addAction ("Timeout: " +
str(self.__sg_iters))
QObject.connect(self.sg_iters_bt, SIGNAL("triggered ()"),
self.set_sg_iters)
@@ -153,11 +153,11 @@
self.run_iters_bt.setText ("Length: " + str(ri))
def set_sg_iters (self):
- (si, ok) = QInputDialog.getInt (self, "Game Tree Depth to Analyze",
- "Set depth of suggestions: ",
- self.__sg_iters, 1, 10, 1)
+ (si, ok) = QInputDialog.getInt (self, "Hint Timeout",
+ "Set hint timeout (seconds): ",
+ self.__sg_iters, 2, 1000, 1)
self.__sg_iters = si
- self.sg_iters_bt.setText ("Depth: " + str(si))
+ self.sg_iters_bt.setText ("Timeout: " + str(si))
def set_adv_ratio (self):
(ar, ok) = QInputDialog.getInt (self, "Advancement Agresiveness Ratio",
Modified: trunk/Toss/Client/Wrapper.py
===================================================================
--- trunk/Toss/Client/Wrapper.py 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Client/Wrapper.py 2011-03-07 23:33:14 UTC (rev 1347)
@@ -403,7 +403,7 @@
# "EVAL LOC MOVES advancement_ratio location TIMEOUT time_in_sec iters_or_depth_limit method optional_playout_horizon"
# syntax variant 2:
# "EVAL LOC MOVES [{0: heuristic_player_0_loc_0; 1: heuristic_player_1_loc_0}; {0: heuristic_player_0_loc_1; 1: heuristic_player_1_loc_1}] advancement_ratio location TIMEOUT time_in_sec iters_or_depth_limit method optional_playout_horizon"
- m = self.msg ("EVAL LOC MOVES " + str(adv_ratio) + ".0 " + str(loc) +" TIMEOUT 1200 "+ str(no_iters) + " alpha_beta_ord")
+ m = self.msg ("EVAL LOC MOVES " + str(adv_ratio) + ".0 " + str(loc) +" TIMEOUT "+ str(no_iters) + " 50500 alpha_beta_ord")
self.set_time (ts, t)
msg = [s.strip() for s in m.split(';')]
emb = dict()
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Formula/Aux.ml 2011-03-07 23:33:14 UTC (rev 1347)
@@ -336,6 +336,20 @@
done;
!r
+let array_find_all_max cmp a =
+ let n = Array.length a in
+ if n=0 then []
+ else
+ let best = ref (Array.unsafe_get a (n-1)) in
+ let beste = ref [!best] 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; beste := [e])
+ else if res = 0 then beste := e :: !beste
+ done;
+ !beste
+
let array_argfind_all_max cmp a =
let n = Array.length a in
if n=0 then []
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Formula/Aux.mli 2011-03-07 23:33:14 UTC (rev 1347)
@@ -192,6 +192,8 @@
arrays are of different lengths. *)
val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+(** Find all maximal elements in an array. *)
+val array_find_all_max : ('a -> 'a -> int) -> 'a array -> 'a list
(** Find indices of all maximal elements in an array. *)
val array_argfind_all_max : ('a -> 'a -> int) -> 'a array -> int list
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Play/GameTree.ml 2011-03-07 23:33:14 UTC (rev 1347)
@@ -137,7 +137,7 @@
let (heurs, is_calc) =
if ab && issome !last_vals && issome !stop_vals &&
((Aux.unsome !last_vals).(pl) > (Aux.unsome !stop_vals).(pl)) then
- (Aux.unsome !stop_vals, false)
+ (Aux.unsome !last_vals, false)
else (
let resh = Array.map calc heurs.(state.Arena.cur_loc) in
if not (issome !last_vals) then last_vals := Some (resh) else
@@ -202,9 +202,19 @@
| Leaf (state, _, _) ->
Aux.random_elem (Array.to_list (Move.list_moves game state))
| Node (_, p, info, succ) ->
+ let cmp (_, c1) (_, c2) =
+ let nval child = (node_values child).(p) in
+ let (e1, e2) = (node_is_exact c1, node_is_exact c2) in
+ if e1 && not e2 then 1 else if e2 && not e1 then -1 else
+ if nval c1 > nval c2 then 1 else if nval c2> nval c1 then -1 else 0 in
+ let maxs_exact = Aux.array_find_all_max cmp succ in
let mval = info.heurs.(p) in
+ let maxs = if maxs_exact <> [] then maxs_exact else
+ Aux.array_find_all (fun (_,c) -> (node_values c).(p) = mval) succ in
let nonleaf = function Leaf _ -> false | _ -> true in
- let maxs= Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in
+ let move_s (m, n) = Move.move_gs_str_short (state n) m in
+ if !debug_level > 0 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)
else ( (* Do *not* take a shallow leaf if possible. *)
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-03-07 23:33:14 UTC (rev 1347)
@@ -91,10 +91,28 @@
(* print_endline (GameTree.str string_of_int u1); *)
assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u1);
);
+
+ "maximax suggest move: Tic-Tac-Toe defense" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+
+ . . .
+
+ . P .
+
+ . P Q
+\"" in
+ let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" ~struc ~loc:1 in
+ (* GameTree.set_debug_level 1; *)
+ let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
+ let (m, ns) = GameTree.maximax_unfold_choose 9 g s h in
+ assert_equal ~printer:(fun x -> x) "Circle{1:b3}"
+ (Move.move_gs_str_short s m);
+ );
]
let bigtests = "GameTreeBig" >::: [
- "maximax suggest move: Gomoku" >::
+ "maximax suggest move: Gomoku defense" >::
(fun () ->
let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
... ... ... ...
@@ -116,11 +134,9 @@
\" 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
let (g, s) = state_of_file "./examples/Gomoku.toss" ~struc ~loc:1 in
- ignore (Unix.alarm 20);
- GameTree.set_debug_level 1;
+ (* GameTree.set_debug_level 1; *)
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
- let (m, ns) = GameTree.maximax_unfold_choose 200 g s h in
- Game.cancel_timeout ();
+ let (m, ns) = GameTree.maximax_unfold_choose 160 g s h in
assert_equal ~printer:(fun x -> x) "Circle{1:d8}"
(Move.move_gs_str_short s m);
);
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/Server/Server.ml 2011-03-07 23:33:14 UTC (rev 1347)
@@ -4,7 +4,7 @@
let set_debug_level i =
debug_level := i;
if i > 5 then Solver.set_debug_level 1;
- GameTree.set_debug_level 1;
+ if i > 0 then GameTree.set_debug_level 1;
Game.set_debug_level i;
Heuristic.debug_level := i - 3
@@ -193,13 +193,26 @@
play := Some p; play_state := Some ps;
p, ps in
ignore (Unix.alarm timer);
- let res = Game.suggest ~effort p ps in
- Game.cancel_timeout ();
- match res with
- | Some (move, new_state) ->
- play_state := Some new_state;
- Move.move_gs_str !state move
- | None -> "None"
+ if !no_gtree then
+ let res = Game.suggest ~effort p ps in
+ Game.cancel_timeout ();
+ match res with
+ | Some (move, new_state) ->
+ play_state := Some new_state;
+ Move.move_gs_str !state move
+ | None -> "None"
+ else
+ let heur = match !game_modified, !g_heur with
+ | false, Some h -> h
+ | true, _ | _, None ->
+ g_heur := Some (Heuristic.default_heuristic
+ ~struc:(snd !state).Arena.struc
+ ~advr:4. (fst !state));
+ Aux.unsome !g_heur in
+ let (move, _) = GameTree.maximax_unfold_choose effort
+ (fst !state) (snd !state) heur in
+ Game.cancel_timeout ();
+ Move.move_gs_str !state move
)
| Aux.Left (Arena.ApplyRule (r_name, mtch, t, p) as req) -> (
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-03-07 12:43:57 UTC (rev 1346)
+++ trunk/Toss/TossFullTest.ml 2011-03-07 23:33:14 UTC (rev 1347)
@@ -10,6 +10,7 @@
let play_tests_big = "Play" >::: [
HeuristicTest.bigtests;
+ GameTreeTest.bigtests;
GameTest.bigtests;
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-07 12:44:03
|
Revision: 1346
http://toss.svn.sourceforge.net/toss/?rev=1346&view=rev
Author: lukaszkaiser
Date: 2011-03-07 12:43:57 +0000 (Mon, 07 Mar 2011)
Log Message:
-----------
Tracking a GameTree Bug
Modified Paths:
--------------
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-06 06:27:04 UTC (rev 1345)
+++ trunk/Toss/Play/GameTree.ml 2011-03-07 12:43:57 UTC (rev 1346)
@@ -107,7 +107,8 @@
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
+ let str_node i = "Heurs: " ^ (fas i.heurs) ^ " exact: " ^
+ (string_of_bool i.heurs_are_exact) ^ " info: " ^ (f i.info) in
str_abstract ~depth:depth str_node str_terminal tree
(* Get the payoffs / heuristics array of a game tree node. *)
@@ -123,7 +124,12 @@
| Leaf (_, _, i) -> i.info
| Node (_, _, i, _) -> i.info
+let node_is_exact = function
+ | Terminal (_, _, i) -> true
+ | Leaf (_, _, i) -> i.heurs_are_exact
+ | Node (_, _, i, _) -> i.heurs_are_exact
+
(* Game tree initialization. *)
let info_leaf_f ab last_vals stop_vals f heurs depth game state l_pl pl =
let issome = function Some _ -> true | _ -> false in
@@ -131,7 +137,7 @@
let (heurs, is_calc) =
if ab && issome !last_vals && issome !stop_vals &&
((Aux.unsome !last_vals).(pl) > (Aux.unsome !stop_vals).(pl)) then
- (Aux.unsome !last_vals, false)
+ (Aux.unsome !stop_vals, false)
else (
let resh = Array.map calc heurs.(state.Arena.cur_loc) in
if not (issome !last_vals) then last_vals := Some (resh) else
@@ -163,7 +169,10 @@
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; heurs_are_exact = true; info = f depth player heurs children }
+ let is_exact_child c = node_is_exact (snd children.(c)) in
+ { heurs= heurs;
+ heurs_are_exact = List.for_all is_exact_child mids;
+ info = f depth player heurs children }
let choice_f g_heurs choice depth game state player info children_orig =
let update_child_heur (m, c) =
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-03-06 06:27:04 UTC (rev 1345)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-03-07 12:43:57 UTC (rev 1346)
@@ -4,7 +4,7 @@
let debug_level = ref 0
-let state_of_file s =
+let raw_state_of_file s =
if !debug_level > 0 then Printf.printf "Loading file %s...\n%!" s;
let f = open_in s in
let res =
@@ -13,6 +13,17 @@
if !debug_level > 0 then Printf.printf "File %s loaded.\n%!" s;
res
+let struc_of_str s =
+ match ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s) with
+ | Arena.StateStruc struc -> struc
+ | _ -> failwith "GameTreeTest:struc_of_str: not a structure"
+
+let state_of_file ?(struc="") ?(time=0.) ?(loc=0) fname =
+ let (g, s) = raw_state_of_file fname in
+ let structure = if struc = "" then s.Arena.struc else struc_of_str struc in
+ (g, { Arena.struc = structure; time = time; cur_loc = loc })
+
+
let tests = "GameTree" >::: [
"abstract tree init, to string" >::
(fun () ->
@@ -82,5 +93,40 @@
);
]
+let bigtests = "GameTreeBig" >::: [
+ "maximax suggest move: Gomoku" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ...P ... ...
+ ... ... ... ...
+ ... P.. ... ...
+ ... ... ... ...
+ ... Q..P P..P ...
+ ... ... ... ...
+ Q ... P..Q ... ...
+ ... ... ... ...
+ ... 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
+ let (g, s) = state_of_file "./examples/Gomoku.toss" ~struc ~loc:1 in
+ ignore (Unix.alarm 20);
+ GameTree.set_debug_level 1;
+ let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
+ let (m, ns) = GameTree.maximax_unfold_choose 200 g s h in
+ Game.cancel_timeout ();
+ assert_equal ~printer:(fun x -> x) "Circle{1:d8}"
+ (Move.move_gs_str_short s m);
+ );
+]
+
let exec = Aux.run_test_if_target "GameTreeTest" tests
+
+let execbig = Aux.run_test_if_target "GameTreeTest" bigtests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-06 06:27:11
|
Revision: 1345
http://toss.svn.sourceforge.net/toss/?rev=1345&view=rev
Author: lukstafi
Date: 2011-03-06 06:27:04 +0000 (Sun, 06 Mar 2011)
Log Message:
-----------
GDL translation: finally proper handling of negation in formula generation (previous commit fixed handling of negation in definition expansion).
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-03-05 23:01:19 UTC (rev 1344)
+++ trunk/Toss/GGP/GDL.ml 2011-03-06 06:27:04 UTC (rev 1345)
@@ -355,29 +355,23 @@
sets of <mask-path, element variable> they "inhabit". Replace a
static fact relation by relations built over a cartesian product
of <mask-path, element variable> sets derived for each static
- fact's argument by applying corresponding (4a) relations. For a
- negative literal generate result equivalent to a *conjunction* of
- negations of generated atoms, but deferred to (7k) to fall under a
- common disjunction (unless there's only one disjunct).
+ fact's argument by applying corresponding (4a) relations. Only
+ build the relation over positive elements, deferring negated ones
+ to (7k-4a) so that they are included under common
+ disjunction. Relations over elements coming from different
+ negations are not introduced, which agrees with negation-as-failure.
(7i-4c) Include the (4c) relations for "next" and "true" positive
- atoms. Negative atoms are added with (5) relations since they (the
- (5) predicates and the mask-path anchors of (4c)) are under a
- common negation.
+ atoms.
- (7i-4b) Add an appropriate equality relation of (4b) for each case
- of subterm shared by terms corresponding to different element
- variables (regardless if the element terms are in positive or
- negative literals).
+ (7i-4b) (4b) is essentially a special case of (4a). Add an
+ appropriate equality relation of (4b) for each case of subterm
+ shared by terms corresponding to different positive elements.
Implementation: instead of all subterms we currently only consider
subterms that instantiate (ordinary) variables in the mask
corresponding to the "next"/"true" atom.
- Reason for unsoundness: inclusion of negative "true" literals in
- (4b) relations is a necessary "heuristic". Whether to extend it to
- constant subterms (see above) is not clear.
-
(7i0) Heuristic (reason for unsoundness): for "distinct", only
check whether its arguments are syntactically equal.
@@ -394,12 +388,32 @@
variables and fail if they're present.
(7k) Replace the "next" and "true" atoms by the conjunction of
- (4c) and (5) predicates over their corresponding variable. (For
+ (4b), (4c) and (5) predicates over their corresponding variable. (For
negative "true" literals this will be equivalent to a disjunction
of negations of the predicates.) Note that positive static
- relations are already added in (7i-4c). Handle negative literal
- translations of (4a, 4c, 5) together.
+ relations are already added in (7i-4b,4c). Handle negative subformula
+ translations of (4a, 4b, 4c, 5) together.
+ (7k-4a-1) Add to the disjunction a negation of all what (7i-4a)
+ would generate (i.e. for positive facts), but over tuples with at
+ least one of the negated elements of current negation (no elements
+ from other negations).
+
+ (7k-4a-2) For a negative fact generate result equivalent to a
+ *conjunction* of negations of generated atoms if all elements are
+ positive,
+
+ (7k-4a-3) but add a *disjunction* of negations (i.e. a negated
+ conjunction) of tuples with at least one negated element.
+
+ (7k-4c) Include the (4c) relations for "next" and "true" negative
+ atoms.
+
+ (7k-4b) It is essentially a special case of (7k-4a-1). Introduce
+ equivalences as in (7i-4b), but with tuples containing at least
+ one element from the current negation (no elements from other
+ negations).
+
(7l) Build a pre-lattice of branch bodies w.r.t. subsumption,
in a manner similar to (7b). The subsumption test has to say "no"
when there exists a game state where the antecedent holds but the
@@ -1693,55 +1707,37 @@
let translate_branches struc masks playout_terms static_rnames dyn_rels
(brs : exp_def_branch list) =
(* 7i *)
- let state_terms =
+ let pos_state_terms =
List.fold_left (fun acc -> function
- | [next_arg], body, neg_body ->
+ | [next_arg], body, _ ->
let res =
List.fold_left (fun acc -> function
| "true", [true_arg] -> Terms.add true_arg acc
| "true", _ -> assert false
| _ -> acc) acc body in
- let res =
- List.fold_left (fun acc (_, neg_conjs) ->
- List.fold_left (fun acc -> function
- | "true", [true_arg] -> Terms.add true_arg acc
- | "true", _ -> assert false
- | _ -> acc) acc neg_conjs) res neg_body in
if next_arg = Const "_IGNORE_RHS_"
then res
else Terms.add next_arg res
| _ -> assert false
) Terms.empty brs in
- let state_terms = Terms.elements state_terms in
- let uni_gdl_vars =
- List.fold_left (fun acc (_, _, neg_body) ->
- Aux.Strings.union acc
- (List.fold_left Aux.Strings.union Aux.Strings.empty
- (List.map fst neg_body))
- ) Aux.Strings.empty brs in
- let uni_toss_vars =
- Aux.map_some (fun term ->
- if Aux.Strings.is_empty
- (Aux.Strings.inter uni_gdl_vars (term_vars term))
- then None
- else Some (snd (toss_var masks term))) state_terms in
+ let pos_state_terms = Terms.elements pos_state_terms in
(* {{{ log entry *)
if !debug_level > 2 then (
- Printf.printf "state_terms: %s\n%!" (
- String.concat ", " (List.map term_str state_terms))
+ Printf.printf "pos_state_terms: %s\n%!"
+ (String.concat ", " (List.map term_str pos_state_terms))
);
(* }}} *)
- let state_subterms =
+ let pos_state_subterms =
Aux.concat_map (fun term ->
let mask, sb, m_sb, blanked = term_to_blank masks term in
List.map (fun (v,t) -> t, (mask, v, term)) sb
- ) state_terms in
- let conjs_4a rel args =
+ ) pos_state_terms in
+ let pos_conjs_4a (rel, args) =
let ptups = List.map (fun arg ->
- Aux.assoc_all arg state_subterms) args in
+ Aux.assoc_all arg pos_state_subterms) args in
(* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "conjs_4a: of %s = subterms %s\n%!"
+ if !debug_level > 3 then (
+ Printf.printf "pos_conjs_4a: of %s = subterms %s\n%!"
(fact_str (rel,args)) (String.concat "; " (
List.map (fun l -> String.concat ", "
(List.map (fun (_,_,term)->term_str term) l)) ptups))
@@ -1758,24 +1754,48 @@
Formula.Rel (rname, Array.of_list tup)) ptups in
let res = Aux.unique_sorted res in
(* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "conjs_4a: of %s = %s\n%!"
+ if !debug_level > 3 then (
+ Printf.printf "pos_conjs_4a: of %s = %s\n%!"
(fact_str (rel,args)) (Formula.str (Formula.And res))
);
(* }}} *)
res in
+ let neg_conjs_4a neg_state_terms neg_state_subterms (rel, args) =
+ let ptups = List.map (fun arg ->
+ Aux.assoc_all arg pos_state_subterms @
+ Aux.assoc_all arg neg_state_subterms) args in
+ let ptups = Aux.product ptups in
+ let ptups = List.filter (fun tup ->
+ List.exists (fun (_,_,term) -> Terms.mem term neg_state_terms) tup)
+ ptups in
+ let res =
+ List.map (fun ptup ->
+ let rname = rel ^ "__" ^ String.concat "__"
+ (List.map (fun (mask,v,_)->
+ term_to_name mask ^ "_" ^ v) ptup) in
+ let tup = List.map (fun (_,_,term) ->
+ snd (toss_var masks term)) ptup in
+ Formula.Rel (rname, Array.of_list tup)) ptups in
+ let res = Aux.unique_sorted res in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "neg_conjs_4a: of %s = %s\n%!"
+ (fact_str (rel,args)) (Formula.str (Formula.And res))
+ );
+ (* }}} *)
+ res in
(* 7i-4b *)
- let path_subterms =
+ let pos_path_subterms =
Aux.concat_map (fun term ->
let mask, sb, m_sb, blanked = term_to_blank masks term in
Aux.map_some (function
| v, Var t ->
Some ((mask, v), (t, term))
| _ -> None) sb
- ) state_terms in
- let path_subterms = Aux.collect path_subterms in
+ ) pos_state_terms in
+ let pos_path_subterms = Aux.collect pos_path_subterms in
let constrained_vars = ref [] in
- let conjs_4b =
+ let pos_conjs_4b =
Aux.concat_map (fun ((mask, v), terms) ->
let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
let terms = Aux.collect terms in
@@ -1797,8 +1817,34 @@
| v::vs -> List.map (fun w -> [|v; w|]) vs in
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
- ) path_subterms in
- let conjs_4b = Aux.unique_sorted conjs_4b in
+ ) pos_path_subterms in
+ let pos_conjs_4b = Aux.unique_sorted pos_conjs_4b in
+ let neg_conjs_4b nterm =
+ let nmask, nsb, _, _ = term_to_blank masks nterm in
+ let _,ntossvar = toss_var masks nterm in
+ Aux.concat_map (fun ((mask, v), terms) ->
+ if mask <> nmask then []
+ else
+ let nval =
+ try List.assoc v nsb with Not_found -> assert false in
+ match nval with
+ | Var nval ->
+ let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
+ let terms =
+ Aux.assoc_all nval terms in
+ let tossvars = Aux.unique_sorted
+ (List.map (fun t -> snd (toss_var masks t)) terms) in
+ (* these don't get constrained since they'll occur negatively *)
+ let tups =
+ if !equivalences_all_tuples
+ then
+ Aux.concat_map
+ (fun v -> [[|v; ntossvar|]; [|ntossvar; v|]]) tossvars
+ else
+ List.map (fun v -> [|v; ntossvar|]) tossvars in
+ List.map (fun tup -> Formula.Rel (rname, tup)) tups
+ | _ -> []
+ ) pos_path_subterms in
let brs = Aux.map_some (function
| [next_arg],body,neg_body ->
let phi, lvars =
@@ -1813,7 +1859,7 @@
let lvars = ref [svar] in
[phi], lvars in
let conjs =
- Aux.concat_map (fun (rel, args) ->
+ Aux.concat_map (fun (rel, args as fact) ->
if rel = "true" then
(* 7i-4c *)
let true_arg = List.hd args in
@@ -1832,19 +1878,21 @@
then conjs else [phi]
else if List.mem rel static_rnames then
(* 7i-4a *)
- conjs_4a rel args
+ pos_conjs_4a fact
else []
) body in
- (* only to prune early *)
+ (* only to prune early -- we cannot get more than negated
+ relations for positive elements, because stuff related to
+ negative elements is under common negations/disjunctions *)
let neg_conjs =
Aux.concat_map (function
- | _, [rel, args] ->
+ | _, [rel, args as fact] ->
if rel = "true" then []
else if rel = "_DOES_PLACEHOLDER_"
then []
else if List.mem rel static_rnames then
(* 7i-4a *)
- List.map (fun c -> Formula.Not c) (conjs_4a rel args)
+ List.map (fun c -> Formula.Not c) (pos_conjs_4a fact)
else if rel = "distinct" then
(* 7i0 *)
if Aux.not_unique args then [Formula.Or []]
@@ -1860,21 +1908,21 @@
let lvars = (!lvars :> Formula.var list) in
let optim_conjs = List.filter (fun c->
List.for_all (fun v->List.mem v lvars)
- (FormulaOps.free_vars c)) (conjs_4b @ all_conjs) in
+ (FormulaOps.free_vars c)) (pos_conjs_4b @ all_conjs) in
let rphi = Formula.And optim_conjs in
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "evaluating: %s\n%!"
(Formula.str phi)
);
- (* }}} *)
+ (* }}} *)
if Solver.M.check struc rphi
then (
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "holds\n%!"
);
- (* }}} *)
+ (* }}} *)
Some (all_conjs, (next_arg,body,neg_body)))
else None
| _ -> assert false) brs in
@@ -1924,18 +1972,78 @@
else if List.mem rel static_rnames || rel = "_DOES_PLACEHOLDER_"
then []
else if rel = "distinct" then
- (* 7i0 *)
- if Aux.not_unique args then [Formula.Or []]
- else []
+ (* 7i0 *)
+ if Aux.not_unique args then [Formula.Or []]
+ else []
else (
Printf.printf "\nunexpected_dynamic: %s\n%!" rel;
(* dynamic relations have been expanded *)
assert false)
) body in
let neg_conjs =
- Aux.map_some (fun (_, neg_conjs) ->
+ Aux.map_some (fun (local_vs, neg_conjs) ->
+ (* 7k-4a-1 *)
+ let neg_state_terms =
+ List.fold_left (fun acc -> function
+ | "true", [true_arg] -> Terms.add true_arg acc
+ | "true", _ -> assert false
+ | _ -> acc) Terms.empty neg_conjs in
+ let neg_state_terml = Terms.elements neg_state_terms in
+ let uni_toss_vars =
+ Aux.map_some (fun term ->
+ if Aux.Strings.is_empty
+ (Aux.Strings.inter local_vs (term_vars term))
+ then None
+ else Some (snd (toss_var masks term)))
+ neg_state_terml in
+ let neg_state_subterms =
+ Aux.concat_map (fun term ->
+ let mask, sb, m_sb, blanked = term_to_blank masks term in
+ List.map (fun (v,t) -> t, (mask, v, term)) sb
+ ) neg_state_terml in
+ let conjs_4a_1 =
+ Aux.concat_map
+ (fun (rel,_ as fact) ->
+ if rel <> "true" && List.mem rel static_rnames
+ then neg_conjs_4a neg_state_terms neg_state_subterms fact
+ else []) body in
+ (* 7k-4b *)
+ let neg_path_subterms =
+ Aux.concat_map (fun term ->
+ let mask, sb, m_sb, blanked = term_to_blank masks term in
+ Aux.map_some (function
+ | v, Var t ->
+ Some ((mask, v), (t, term))
+ | _ -> None) sb
+ ) (Terms.elements neg_state_terms) in
+ let neg_path_subterms = Aux.collect neg_path_subterms in
+ (* the negative-only part *)
+ let negonly_conjs_4b =
+ Aux.concat_map (fun ((mask, v), terms) ->
+ let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
+ let terms = Aux.collect terms in
+ Aux.concat_map (fun (_,terms) ->
+ let vars = Aux.unique_sorted
+ (List.map (fun t -> snd (toss_var masks t)) terms) in
+ constrained_vars := vars @ !constrained_vars;
+ let tups =
+ if !equivalences_all_tuples
+ then
+ Aux.concat_map (fun v -> Aux.map_some (fun w ->
+ if v=w then None else Some [|v; w|]) vars) vars
+ else
+ match vars with [] -> []
+ | v::vs -> List.map (fun w -> [|v; w|]) vs in
+ List.map (fun tup -> Formula.Rel (rname, tup)) tups
+ ) terms
+ ) neg_path_subterms in
+ let negonly_conjs_4b = Aux.unique_sorted negonly_conjs_4b in
+ (* the mixed part *)
+ let mixed_conjs_4b =
+ Aux.concat_map neg_conjs_4b neg_state_terml in
+ let nconjs_4b = negonly_conjs_4b @ mixed_conjs_4b in
let disjs =
- Aux.map_some (fun (rel, args) ->
+ Aux.concat_map (fun (rel, args as fact) ->
if rel = "true" then
let true_arg = List.hd args in
let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
@@ -1948,6 +2056,7 @@
| v, t as v_sb ->
let rname = term_to_name (subst_one v_sb mask) in
Some (Formula.Rel (rname, [|svar|]))) sb in
+ let conjs_4b = neg_conjs_4b true_arg in
let conjs_5 =
List.map (fun (v,t as v_sb) ->
if t = Const "_BLANK_" then
@@ -1956,68 +2065,49 @@
(* t = Var _ have been expanded *)
let rname = term_to_name (subst_one v_sb mask) in
Formula.Rel (rname, [|svar|])) m_sb in
-
- let conjs = conjs_4c @ conjs_5 in
- let conjs = if conjs = [] then [phi] else conjs in
- Some (Formula.Not (Formula.And conjs))
+ let conjs =
+ conjs_4b @ conjs_4c @ conjs_5 in
+ if conjs = [] then [phi] else conjs
else if rel = "_DOES_PLACEHOLDER_"
- then None
+ then []
else if List.mem rel static_rnames then
- (* 7i-4a *)
- Some (Formula.And (
- List.map (fun c -> Formula.Not c) (conjs_4a rel args)))
+ (* 7i-4a-2-3 *)
+ let conjs_4a_2 =
+ match pos_conjs_4a fact with
+ | [] -> []
+ | [rel_conseq] -> [rel_conseq]
+ | rel_conseqs ->
+ (* negation turns it into a conjunction *)
+ [Formula.Or rel_conseqs] in
+ let conjs_4a_3 =
+ neg_conjs_4a neg_state_terms neg_state_subterms fact in
+ conjs_4a_2 @ conjs_4a_3
else if rel = "distinct" then
(* 7i0 *)
- if Aux.not_unique args then Some (Formula.Or [])
- else None
+ if Aux.not_unique args then [Formula.Or []]
+ else []
else (
(* dynamic relations have been expanded *)
Printf.printf
"translate_game: (7k) unexpected dynamic %s\n%!" rel;
assert false)
) neg_conjs in
- match disjs with
- | [] -> None
- | [disj] -> Some disj
- | _ -> Some (Formula.Or disjs)) neg_body in
+ let res =
+ match conjs_4a_1 @ nconjs_4b @ disjs with
+ | [] -> None
+ | [disj] -> Some disj
+ | disjs -> Some (Formula.And disjs) in
+ Aux.map_option (fun phi ->
+ if uni_toss_vars = [] then Formula.Not phi
+ else Formula.Not (Formula.Ex (
+ (uni_toss_vars :> Formula.var list), phi))) res
+ ) neg_body in
let all_conjs = !static_conjs @ dyn_conjs @ neg_conjs in
(rhs_pos_preds, !static_conjs, all_conjs),
(next_arg, body, neg_body)) brs in
- uni_toss_vars, conjs_4b, brs
+ pos_conjs_4b, brs
-let lift_universal (uni_vars : Formula.fo_var list) conjs =
- let conjs = Aux.unique_sorted
- (Aux.concat_map FormulaOps.flatten_ands conjs) in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "lift_universal: vars %s -- conjs:\n%s\n%!"
- (String.concat ", "
- (List.map Formula.var_str (uni_vars :> Formula.var list)))
- (Formula.sprint (Formula.And conjs))
- );
- (* }}} *)
- let uni_vars = (uni_vars :> Formula.var list) in
- let local, global = List.partition
- (fun phi ->
- let phi_vs = FormulaOps.free_vars phi in
- List.exists (fun v -> List.mem v phi_vs) uni_vars) conjs in
- let used_uni_vars =
- List.filter (fun v -> List.mem v uni_vars)
- (FormulaOps.free_vars (Formula.And local)) in
- let res =
- if local = [] then Formula.And global
- else
- Formula.And (global @ [
- Formula.All (used_uni_vars, Formula.And local)]) in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf "lift_universal: result\n%s\n%!"
- (Formula.sprint res)
- );
- (* }}} *)
- res
-
let translate_game player_term game_descr =
var_support := Aux.Strings.empty;
let player_terms =
@@ -2798,7 +2888,7 @@
[[Const "_IGNORE_RHS_"], [atom], [];
[Const "_IGNORE_RHS_"], [], [Aux.Strings.empty, [atom]]]
) atoms in
- let uni_vars, conjs_4b, brs =
+ let conjs_4b, brs =
translate_branches struc masks element_terms static_rnames
dyn_rels (brs @ synth_brs) in
(* 7l *)
@@ -2927,7 +3017,8 @@
Aux.unique_sorted struc_elems,
Aux.unique_sorted rhs_pos,
static_phis, phis)) cases in
- let cases = Aux.map_some (
+ let cases =
+ Aux.map_some (
fun (var_elems,struc_elems,rhs_pos,static_phis,phis) ->
let rphi = Formula.And static_phis in
(* {{{ log entry *)
@@ -2953,11 +3044,12 @@
Printf.printf "holds\n%!"
);
(* }}} *)
- if res then Some (var_elems, struc_elems, rhs_pos, phis)
+ if res then
+ let precond = Formula.And phis in
+ Some (var_elems, struc_elems, rhs_pos, precond)
else None) cases in
- List.map (fun (var_elems, struc_elems, rhs_pos, conjs) ->
- lead, (var_elems, struc_elems, rhs_pos,
- lift_universal uni_vars conjs)) cases
+ List.map (fun (var_elems, struc_elems, rhs_pos, precond) ->
+ lead, (var_elems, struc_elems, rhs_pos, precond)) cases
) rules_brs
) loc_next_classes in
(* 7n *)
@@ -2970,17 +3062,15 @@
expand_branch_vars masks element_terms
~freshen_unfixed:(Aux.Left true) terminal_brs in
let terminal_brs = List.map snd terminal_brs in
- let terminal_uni_vars, terminal_4b, terminal_brs =
+ let terminal_4b, terminal_brs =
translate_branches struc masks element_terms static_rnames
dyn_rels terminal_brs in
let terminal_disjs = List.map (fun ((_,_,conjs),_) ->
let disj_vars = FormulaOps.free_vars (Formula.And conjs) in
- let disj_vars = Aux.list_diff disj_vars
- (terminal_uni_vars :> Formula.var list) in
let disj_4b =
List.filter (fun a -> List.exists (fun v->List.mem v disj_vars)
(FormulaOps.free_vars a)) terminal_4b in
- let disj = lift_universal terminal_uni_vars (disj_4b @ conjs) in
+ let disj = Formula.And (disj_4b @ conjs) in
if disj_vars = [] then disj else Formula.Ex (disj_vars, disj)
) terminal_brs in
let terminal_phi = Formula.Or terminal_disjs in
@@ -3028,7 +3118,7 @@
(* 8b *)
(* FIXME: should we expand before,
with [~freshen_unfixed:(Aux.Left true)]? *)
- let goal_uni_vars, goal_4b, brs =
+ let goal_4b, brs =
translate_branches struc masks element_terms static_rnames
dyn_rels brs in
let goal_disjs = List.map (fun ((_,_,conjs),_) ->
@@ -3036,7 +3126,7 @@
let disj_4b =
List.filter (fun a -> List.exists (fun v->List.mem v disj_vars)
(FormulaOps.free_vars a)) goal_4b in
- let disj = lift_universal goal_uni_vars (disj_4b @ conjs) in
+ let disj = Formula.And (disj_4b @ conjs) in
let disj_vs = FormulaOps.free_vars disj in
if disj_vs = [] then disj else Formula.Ex (disj_vs, disj)
) brs in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-05 23:01:27
|
Revision: 1344
http://toss.svn.sourceforge.net/toss/?rev=1344&view=rev
Author: lukaszkaiser
Date: 2011-03-05 23:01:19 +0000 (Sat, 05 Mar 2011)
Log Message:
-----------
Separate small (fast) and big (slower) tests.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Play/GameTest.ml
trunk/Toss/Play/HeuristicTest.ml
Added Paths:
-----------
trunk/Toss/TossFullTest.ml
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-03-03 23:47:31 UTC (rev 1343)
+++ trunk/Toss/Makefile 2011-03-05 23:01:19 UTC (rev 1344)
@@ -136,6 +136,7 @@
# All OUnit tests, aggregate
TossTest:
+TossFullTest:
# ------ CLEAN ------
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-03-03 23:47:31 UTC (rev 1343)
+++ trunk/Toss/Play/GameTest.ml 2011-03-05 23:01:19 UTC (rev 1344)
@@ -259,54 +259,6 @@
(move_opt <> None)
);
- "play: chess suggest first move" >::
- (fun () ->
- skip_if true "loading takes long, worked last time";
- let horizon, advr, state =
- Lazy.force chess_game in
- let move_opt = (let p,ps = Game.initialize_default state
- ~advr ?horizon
- ~loc:0 ~effort:1
- ~search_method:"alpha_beta_ord" () in
- Game.suggest p ps) in
- assert_bool "Game is not over yet -- some move expected."
- (move_opt <> None);
- );
-
- "play: checkers suggest first move depth 4" >::
- (fun () ->
- let horizon, advr, state =
- Lazy.force checkers_game in
- let move_opt = (let p,ps = Game.initialize_default state
- ~advr ?horizon
- ~loc:0 ~effort:4
- ~search_method:"alpha_beta_ord" () in
- Game.suggest p ps) in
- assert_bool "Game is not over yet -- some move expected."
- (move_opt <> None);
- );
-
- "play: chess begin random play" >::
- (fun () ->
- skip_if true "loading takes long, worked last time";
- let _, advr, state =
- Lazy.force chess_game in
- let (game, struc) = (fst state, (snd state).Arena.struc) in
- let play =
- {Game.game = game; agents=
- [|Game.Random_move; Game.Random_move|];
- delta = 2.0} in (* FIXME: give/calc delta *)
- let init_state = Game.initial_state play struc in
- (* let endstate,payoff = *)
- ignore (Game.play ~grid_size:Move.cGRID_SIZE
- ~set_timer:360 ~horizon:30 play init_state) (* in *)
- (* nothing to assert -- just check halting without exceptions *)
- (*
- Printf.printf "Chess random play horizon=30 ended in:\n%s\n%!"
- (Structure.sprint endstate)
- *)
- );
-
"breakthrough payoff" >::
(fun () ->
let horizon, advr, state =
@@ -356,55 +308,6 @@
);
- "chess draw" >::
- (fun () ->
- skip_if true "loading takes long, worked last time";
- let horizon, advr, state =
- update_game chess_game
-"[a1, b1, c1, d1, e1, f1, g1, h1, a2, b2, c2, d2, e2, f2, g2, h2, a3, b3, c3, d3, e3, f3, g3, h3, a4, b4, c4, d4, e4, f4, g4, h4, a5, b5, c5, d5, e5, f5, g5, h5, a6, b6, c6, d6, e6, f6, g6, h6, a7, b7, c7, d7, e7, f7, g7, h7, a8, b8, c8, d8, e8, f8, g8, h8 | D1 {(a1, b2); (b1, c2); (c1, d2); (d1, e2); (e1, f2); (f1, g2); (g1, h2); (a2, b3); (b2, a1); (b2, c3); (c2, b1); (c2, d3); (d2, c1); (d2, e3); (e2, d1); (e2, f3); (f2, e1); (f2, g3); (g2, f1); (g2, h3); (h2, g1); (a3, b4); (b3, a2); (b3, c4); (c3, b2); (c3, d4); (d3, c2); (d3, e4); (e3, d2); (e3, f4); (f3, e2); (f3, g4); (g3, f2); (g3, h4); (h3, g2); (a4, b5); (b4, a3); (b4, c5); (c4, b3); (c4, d5); (d4, c3); (d4, e5); (e4, d3); (e4, f5); (f4, e3); (f4, g5); (g4, f3); (g4, h5); (h4, g3); (a5, b6); (b5, a4); (b5, c6); (c5, b4); (c5, d6); (d5, c4); (d5, e6); (e5, d4); (e5, f6); (f5, e4); (f5, g6); (g5, f4); (g5, h6); (h5, g4); (a6, b7); (b6, a5); (b6, c7); (c6, b5); (c6, d7); (d6, c5); (d6, e7); (e6, d5); (e6, f7); (f6, e5); (f6, g7); (g6, f5); (g6, h7); (h6, g5); (a7, b8); (b7, a6); (b7, c8); (c7, b6); (c7, d8); (d7, c6); (d7, e8); (e7, d6); (e7, f8); (f7, e6); (f7, g8); (g7, f6); (g7, h8); (h7, g6); (b8, a7); (c8, b7); (d8, c7); (e8, d7); (f8, e7); (g8, f7); (h8, g7)}; D2 {(b1, a2); (c1, b2); (d1, c2); (e1, d2); (f1, e2); (g1, f2); (h1, g2); (a2, b1); (b2, c1); (b2, a3); (c2, d1); (c2, b3); (d2, e1); (d2, c3); (e2, f1); (e2, d3); (f2, g1); (f2, e3); (g2, h1); (g2, f3); (h2, g3); (a3, b2); (b3, c2); (b3, a4); (c3, d2); (c3, b4); (d3, e2); (d3, c4); (e3, f2); (e3, d4); (f3, g2); (f3, e4); (g3, h2); (g3, f4); (h3, g4); (a4, b3); (b4, c3); (b4, a5); (c4, d3); (c4, b5); (d4, e3); (d4, c5); (e4, f3); (e4, d5); (f4, g3); (f4, e5); (g4, h3); (g4, f5); (h4, g5); (a5, b4); (b5, c4); (b5, a6); (c5, d4); (c5, b6); (d5, e4); (d5, c6); (e5, f4); (e5, d6); (f5, g4); (f5, e6); (g5, h4); (g5, f6); (h5, g6); (a6, b5); (b6, c5); (b6, a7); (c6, d5); (c6, b7); (d6, e5); (d6, c7); (e6, f5); (e6, d7); (f6, g5); (f6, e7); (g6, h5); (g6, f7); (h6, g7); (a7, b6); (b7, c6); (b7, a8); (c7, d6); (c7, b8); (d7, e6); (d7, c8); (e7, f6); (e7, d8); (f7, g6); (f7, e8); (g7, h6); (g7, f8); (h7, g8); (a8, b7); (b8, c7); (c8, d7); (d8, e7); (e8, f7); (f8, g7); (g8, h7)}; bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
- ... ... ... ...
- ... ... +bN ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... bP. ...-bNwK.
- ... ... ... ...
- ...bP ... ... ...
- ... ... ... ...
- bR. ... ...bQ ...
- ... ... ... ...
- ... ...bK ... ...bP
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\"" 0 in
-
- let payoffs = Array.to_list
- (Array.mapi (fun i v->string_of_int i,v)
- (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs)
- in
- let ev (p,e) =
- p^": "^(string_of_float
- (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)
- "0: 0., 1: 0." answ;
-
- let move_opt = (let p,ps = Game.initialize_default state
- ~advr ?horizon
- ~loc:0 ~effort:1
- ~search_method:"alpha_beta_ord" () in
- 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 (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;
-);
-
"matching: breakthrough suggest start" >::
(fun () ->
let horizon, advr, state =
@@ -460,6 +363,107 @@
]
+let misc_tests_big = "misc_big" >::: [
+
+ "play: chess suggest first move" >::
+ (fun () ->
+ skip_if true "loading takes long, worked last time";
+ let horizon, advr, state =
+ Lazy.force chess_game in
+ let move_opt = (let p,ps = Game.initialize_default state
+ ~advr ?horizon
+ ~loc:0 ~effort:1
+ ~search_method:"alpha_beta_ord" () in
+ Game.suggest p ps) in
+ assert_bool "Game is not over yet -- some move expected."
+ (move_opt <> None);
+ );
+
+ "play: checkers suggest first move depth 4" >::
+ (fun () ->
+ let horizon, advr, state =
+ Lazy.force checkers_game in
+ let move_opt = (let p,ps = Game.initialize_default state
+ ~advr ?horizon
+ ~loc:0 ~effort:4
+ ~search_method:"alpha_beta_ord" () in
+ Game.suggest p ps) in
+ assert_bool "Game is not over yet -- some move expected."
+ (move_opt <> None);
+ );
+
+ "play: chess begin random play" >::
+ (fun () ->
+ skip_if true "loading takes long, worked last time";
+ let _, advr, state =
+ Lazy.force chess_game in
+ let (game, struc) = (fst state, (snd state).Arena.struc) in
+ let play =
+ {Game.game = game; agents=
+ [|Game.Random_move; Game.Random_move|];
+ delta = 2.0} in (* FIXME: give/calc delta *)
+ let init_state = Game.initial_state play struc in
+ (* let endstate,payoff = *)
+ ignore (Game.play ~grid_size:Move.cGRID_SIZE
+ ~set_timer:360 ~horizon:30 play init_state) (* in *)
+ (* nothing to assert -- just check halting without exceptions *)
+ (*
+ Printf.printf "Chess random play horizon=30 ended in:\n%s\n%!"
+ (Structure.sprint endstate)
+ *)
+ );
+
+ "chess draw" >::
+ (fun () ->
+ skip_if true "loading takes long, worked last time";
+ let horizon, advr, state =
+ update_game chess_game
+"[a1, b1, c1, d1, e1, f1, g1, h1, a2, b2, c2, d2, e2, f2, g2, h2, a3, b3, c3, d3, e3, f3, g3, h3, a4, b4, c4, d4, e4, f4, g4, h4, a5, b5, c5, d5, e5, f5, g5, h5, a6, b6, c6, d6, e6, f6, g6, h6, a7, b7, c7, d7, e7, f7, g7, h7, a8, b8, c8, d8, e8, f8, g8, h8 | D1 {(a1, b2); (b1, c2); (c1, d2); (d1, e2); (e1, f2); (f1, g2); (g1, h2); (a2, b3); (b2, a1); (b2, c3); (c2, b1); (c2, d3); (d2, c1); (d2, e3); (e2, d1); (e2, f3); (f2, e1); (f2, g3); (g2, f1); (g2, h3); (h2, g1); (a3, b4); (b3, a2); (b3, c4); (c3, b2); (c3, d4); (d3, c2); (d3, e4); (e3, d2); (e3, f4); (f3, e2); (f3, g4); (g3, f2); (g3, h4); (h3, g2); (a4, b5); (b4, a3); (b4, c5); (c4, b3); (c4, d5); (d4, c3); (d4, e5); (e4, d3); (e4, f5); (f4, e3); (f4, g5); (g4, f3); (g4, h5); (h4, g3); (a5, b6); (b5, a4); (b5, c6); (c5, b4); (c5, d6); (d5, c4); (d5, e6); (e5, d4); (e5, f6); (f5, e4); (f5, g6); (g5, f4); (g5, h6); (h5, g4); (a6, b7); (b6, a5); (b6, c7); (c6, b5); (c6, d7); (d6, c5); (d6, e7); (e6, d5); (e6, f7); (f6, e5); (f6, g7); (g6, f5); (g6, h7); (h6, g5); (a7, b8); (b7, a6); (b7, c8); (c7, b6); (c7, d8); (d7, c6); (d7, e8); (e7, d6); (e7, f8); (f7, e6); (f7, g8); (g7, f6); (g7, h8); (h7, g6); (b8, a7); (c8, b7); (d8, c7); (e8, d7); (f8, e7); (g8, f7); (h8, g7)}; D2 {(b1, a2); (c1, b2); (d1, c2); (e1, d2); (f1, e2); (g1, f2); (h1, g2); (a2, b1); (b2, c1); (b2, a3); (c2, d1); (c2, b3); (d2, e1); (d2, c3); (e2, f1); (e2, d3); (f2, g1); (f2, e3); (g2, h1); (g2, f3); (h2, g3); (a3, b2); (b3, c2); (b3, a4); (c3, d2); (c3, b4); (d3, e2); (d3, c4); (e3, f2); (e3, d4); (f3, g2); (f3, e4); (g3, h2); (g3, f4); (h3, g4); (a4, b3); (b4, c3); (b4, a5); (c4, d3); (c4, b5); (d4, e3); (d4, c5); (e4, f3); (e4, d5); (f4, g3); (f4, e5); (g4, h3); (g4, f5); (h4, g5); (a5, b4); (b5, c4); (b5, a6); (c5, d4); (c5, b6); (d5, e4); (d5, c6); (e5, f4); (e5, d6); (f5, g4); (f5, e6); (g5, h4); (g5, f6); (h5, g6); (a6, b5); (b6, c5); (b6, a7); (c6, d5); (c6, b7); (d6, e5); (d6, c7); (e6, f5); (e6, d7); (f6, g5); (f6, e7); (g6, h5); (g6, f7); (h6, g7); (a7, b6); (b7, c6); (b7, a8); (c7, d6); (c7, b8); (d7, e6); (d7, c8); (e7, f6); (e7, d8); (f7, g6); (f7, e8); (g7, h6); (g7, f8); (h7, g8); (a8, b7); (b8, c7); (c8, d7); (d8, e7); (e8, f7); (f8, g7); (g8, h7)}; bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+ ... ... ... ...
+ ... ... +bN ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... bP. ...-bNwK.
+ ... ... ... ...
+ ...bP ... ... ...
+ ... ... ... ...
+ bR. ... ...bQ ...
+ ... ... ... ...
+ ... ...bK ... ...bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\"" 0 in
+
+ let payoffs = Array.to_list
+ (Array.mapi (fun i v->string_of_int i,v)
+ (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs)
+ in
+ let ev (p,e) =
+ p^": "^(string_of_float
+ (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)
+ "0: 0., 1: 0." answ;
+
+ let move_opt = (let p,ps = Game.initialize_default state
+ ~advr ?horizon
+ ~loc:0 ~effort:1
+ ~search_method:"alpha_beta_ord" () in
+ 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 (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;
+);
+
+]
+
let search_tests algo comment randomize effort_easy time_easy effort_medium
time_medium effort_hard time_hard =
let easy_case = compute_try algo randomize effort_easy time_easy
@@ -898,6 +902,10 @@
let tests = "Game" >::: [
misc_tests;
search_tests "alpha_beta_ord" "effort 2 3 4" false 2 120 3 240 4 360;
+]
+
+let bigtests = "GameBig" >::: [
+ misc_tests_big;
search_tests "alpha_beta_ord" "time 8 16 32" false 10 8 10 16 10 32;
]
@@ -945,9 +953,10 @@
);
]
-let a =
- Aux.run_test_if_target "GameTest" tests
+let a = Aux.run_test_if_target "GameTest" tests
+let a = Aux.run_test_if_target "GameTest" bigtests
+
let a () = run_test_tt ~verbose:true experiments
let a () =
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-03-03 23:47:31 UTC (rev 1343)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-03-05 23:01:19 UTC (rev 1344)
@@ -133,113 +133,6 @@
state (formula_of_str "ex y (C(x, y) and F(y))")));
);
- "expanded_description: fenced breakthrough 2 vars" >::
- (fun () ->
- let state =
- struc_of_string
-"[ | | ] \"
-
- F F F F F F F F
- ... ... ... ...
- B B..B B..B B..B B..
- ... ... ... ...
- B..B B..B B..B B..B
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- W W..W W..W W..W W..
- ... ... ... ...
- W..W W..W W..W W..W
-
- F F F F F F F F
-\"" in
- assert_equal ~printer:(fun x->x)
- "ex y7, y6, y5, y4, y3, y2, y1, y0 ((C(y7, y6) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, x) and C(x, y)))"
- (Formula.str (Heuristic.expanded_description 5
- (Aux.strings_of_list ["B"; "W"])
- state (formula_of_str "C(x, y) and F(y)")));
- );
-(*
- "suggest_expansion: tic-tac-toe" >::
- (fun () ->
- let state = struc_of_string
-"[ | P:1 { }; Q:1 { } | ] \"
-
- . . .
-
- . . .
-
- . . .
-\"" in
- (* A single substructure usually has exponentially many
- different descriptions. *)
- assert_bool "Should suggest not expanding tic-tac-toe."
- (not (Heuristic.suggest_expansion
- (formula_of_str winQxyz) state));
- );
-
- "suggest_expansion: breakthrough" >::
- (fun () ->
- let state =
- struc_of_string
-"[ | | ] \"
- ... ... ... ...
- B B..B B..B B..B B..
- ... ... ... ...
- B..B B..B B..B B..B
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- W W..W W..W W..W W..
- ... ... ... ...
- W..W W..W W..W W..W
-\"" in
- (* A single substructure usually has exponentially many
- different descriptions. *)
- assert_bool "Should suggest expanding breakthrough."
- (Heuristic.suggest_expansion
- (formula_of_str "ex x (W(x) and not ex y C(x, y))") state);
- );
-
- "suggest_expansion: gomoku8x8" >::
- (fun () ->
- let state =
- struc_of_string
-"[ | P:1 { }; Q:1 { } | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\"" in
- assert_bool "Should suggest not expanding gomoku."
- (not (Heuristic.suggest_expansion
- (formula_of_str winQvwxyz) state));
- );
-*)
"expanded_form: fenced breakthrough" >::
(fun () ->
let state =
@@ -407,9 +300,123 @@
));
]
+
+let bigtests = "HeuristicBig" >::: [
+ "expanded_description: fenced breakthrough 2 vars" >::
+ (fun () ->
+ let state =
+ struc_of_string
+"[ | | ] \"
+
+ F F F F F F F F
+ ... ... ... ...
+ B B..B B..B B..B B..
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ W..W W..W W..W W..W
+
+ F F F F F F F F
+\"" in
+ assert_equal ~printer:(fun x->x)
+ "ex y7, y6, y5, y4, y3, y2, y1, y0 ((C(y7, y6) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, x) and C(x, y)))"
+ (Formula.str (Heuristic.expanded_description 5
+ (Aux.strings_of_list ["B"; "W"])
+ state (formula_of_str "C(x, y) and F(y)")));
+ );
+(*
+ "suggest_expansion: tic-tac-toe" >::
+ (fun () ->
+ let state = struc_of_string
+"[ | P:1 { }; Q:1 { } | ] \"
+
+ . . .
+
+ . . .
+
+ . . .
+\"" in
+ (* A single substructure usually has exponentially many
+ different descriptions. *)
+ assert_bool "Should suggest not expanding tic-tac-toe."
+ (not (Heuristic.suggest_expansion
+ (formula_of_str winQxyz) state));
+ );
+
+ "suggest_expansion: breakthrough" >::
+ (fun () ->
+ let state =
+ struc_of_string
+"[ | | ] \"
+ ... ... ... ...
+ B B..B B..B B..B B..
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ W..W W..W W..W W..W
+\"" in
+ (* A single substructure usually has exponentially many
+ different descriptions. *)
+ assert_bool "Should suggest expanding breakthrough."
+ (Heuristic.suggest_expansion
+ (formula_of_str "ex x (W(x) and not ex y C(x, y))") state);
+ );
+
+ "suggest_expansion: gomoku8x8" >::
+ (fun () ->
+ let state =
+ struc_of_string
+"[ | P:1 { }; Q:1 { } | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\"" in
+ assert_bool "Should suggest not expanding gomoku."
+ (not (Heuristic.suggest_expansion
+ (formula_of_str winQvwxyz) state));
+ );
+*)
+]
+
+
let a =
Aux.run_test_if_target "HeuristicTest" tests
+let a =
+ Aux.run_test_if_target "HeuristicTest" bigtests
let a () =
match test_filter ["Heuristic:9:of_payoff: monotonic gomoku"]
Added: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml (rev 0)
+++ trunk/Toss/TossFullTest.ml 2011-03-05 23:01:19 UTC (rev 1344)
@@ -0,0 +1,31 @@
+open OUnit
+
+let formula_tests = TossTest.formula_tests
+
+let solver_tests = TossTest.solver_tests
+
+let arena_tests = TossTest.arena_tests
+
+let play_tests = TossTest.play_tests
+
+let play_tests_big = "Play" >::: [
+ HeuristicTest.bigtests;
+ GameTest.bigtests;
+]
+
+let ggp_tests = TossTest.ggp_tests
+
+let server_tests = TossTest.server_tests
+
+let tests = "Toss" >::: [
+ formula_tests;
+ solver_tests;
+ arena_tests;
+ play_tests;
+ play_tests_big;
+ ggp_tests;
+ server_tests;
+]
+
+let a =
+ Aux.run_test_if_target "TossFullTest" tests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-03 23:47:37
|
Revision: 1343
http://toss.svn.sourceforge.net/toss/?rev=1343&view=rev
Author: lukaszkaiser
Date: 2011-03-03 23:47:31 +0000 (Thu, 03 Mar 2011)
Log Message:
-----------
The first correction for variable-depth alpha-beta.
Modified Paths:
--------------
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-03 21:40:00 UTC (rev 1342)
+++ trunk/Toss/Play/GameTree.ml 2011-03-03 23:47:31 UTC (rev 1343)
@@ -88,8 +88,9 @@
(* 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. *)
+ heurs : float array ; (* Heuristic calculated directly or by maximax. *)
+ heurs_are_exact : bool ; (* Whether the heuristics are exact or alpha-beta. *)
+ info : 'a ; (* Other information. *)
}
type 'a terminal_info = {
@@ -127,18 +128,18 @@
let info_leaf_f ab last_vals stop_vals f heurs depth game state l_pl pl =
let issome = function Some _ -> true | _ -> false in
let calc re = Solver.M.get_real_val re state.Arena.struc in
- let heurs =
+ let (heurs, is_calc) =
if ab && issome !last_vals && issome !stop_vals &&
((Aux.unsome !last_vals).(pl) > (Aux.unsome !stop_vals).(pl)) then
- Aux.unsome !last_vals
+ (Aux.unsome !last_vals, false)
else (
let resh = Array.map calc heurs.(state.Arena.cur_loc) in
if not (issome !last_vals) then last_vals := Some (resh) else
if (Aux.unsome !last_vals).(pl) < resh.(pl) then
last_vals := Some (resh);
- resh
+ (resh, true)
) in
- { heurs = heurs; info = f depth game state }
+ { heurs = heurs; heurs_are_exact = is_calc; info = f depth game state }
let init game state f h =
let init_f g s p = info_leaf_f false (ref None) (ref None) f h 0 g s p 0 in
@@ -162,8 +163,21 @@
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 }
+ { heurs= heurs; heurs_are_exact = true; info = f depth player heurs children }
+let choice_f g_heurs choice depth game state player info children_orig =
+ let update_child_heur (m, c) =
+ match c with
+ | Leaf (l_state, l_player, l_info) ->
+ if l_info.heurs_are_exact then (m, c) else
+ let calc re = Solver.M.get_real_val re l_state.Arena.struc in
+ let resh = Array.map calc g_heurs.(l_state.Arena.cur_loc) in
+ let new_info = { l_info with heurs = resh; heurs_are_exact= true } in
+ (m, Leaf (l_state, l_player, new_info))
+ | _ -> (m, c) in
+ let children = Array.map update_child_heur children_orig in
+ choice depth game state player info children
+
(* Main unfolding function. *)
let unfold ?(ab=false) game heur ~info_leaf ~info_node ~choice =
let (last_vals, stop_vals) = (ref None, ref None) in
@@ -171,7 +185,7 @@
~info_terminal:(info_terminal_f info_leaf)
~info_leaf:(info_leaf_f ab last_vals stop_vals info_leaf heur)
~info_node:(info_node_f info_node)
- ~choice:(choice stop_vals)
+ ~choice:(choice_f heur (choice stop_vals))
(* Choose one of the maximizing moves (at random) given a game tree. *)
let choose_move game = function
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-03-03 21:40:00 UTC (rev 1342)
+++ trunk/Toss/Play/GameTree.mli 2011-03-03 23:47:31 UTC (rev 1343)
@@ -49,8 +49,9 @@
(** 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. *)
+ heurs : float array ; (** Heuristic calculated directly or by maximax. *)
+ heurs_are_exact : bool ;(** Whether the heuristics are exact or alpha-beta.*)
+ info : 'a ; (** Other information. *)
}
type 'a terminal_info = {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-03 21:40:07
|
Revision: 1342
http://toss.svn.sourceforge.net/toss/?rev=1342&view=rev
Author: lukstafi
Date: 2011-03-03 21:40:00 +0000 (Thu, 03 Mar 2011)
Log Message:
-----------
GDL translation: progress on negation handling. Aux: tiny helper for below-diagonal pairs of elements. Various test fixes.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/Play/GameTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/ServerGDLTest.in2
trunk/Toss/Server/ServerGDLTest.out2
trunk/Toss/Server/ServerTest.ml
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -754,15 +754,17 @@
let varify_lhs tup =
Array.map (fun e -> `FO (lhs_name_of e)) tup in
(* summing up: the LHS structure embedding plus the precondition *)
- let emb = And [
- And (Aux.concat_map (fun (rel, tups) ->
- List.map (fun tup -> Rel (rel, varify_lhs tup)) tups) lhs_pos_tups);
- And (Aux.concat_map (fun (rel, tups) ->
- List.map (fun tup -> Not (Rel (rel, varify_lhs tup))) tups) lhs_neg_tups);
- And (List.map (function [x;y] -> Not (Eq (`FO x, `FO y))
- | _ -> assert false) lhs_alldif_tups);
- precond
- ] in
+ let emb = And (
+ Aux.concat_map (fun (rel, tups) ->
+ List.map (fun tup -> Rel (rel, varify_lhs tup)) tups)
+ lhs_pos_tups @
+ Aux.concat_map (fun (rel, tups) ->
+ List.map (fun tup -> Not (Rel (rel, varify_lhs tup))) tups)
+ lhs_neg_tups @
+ List.map (function [x;y] -> Not (Eq (`FO x, `FO y))
+ | _ -> assert false) lhs_alldif_tups @
+ FormulaOps.flatten_ands precond
+ ) in
(* Substitute defined relations, expanding their special variants. *)
let transform_new_rel = function
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -665,7 +665,7 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_one_of ~msg:"del defrel"
- ["(O(b) and (not P(b)) and (not Q(b)) and (_del_P(b) or _del_Q(b)))-> (P(b) and (not O(b)))";"((_del_Q(b) or _del_P(b)) and O(b) and (not P(b)) and (not Q(b)))-> (P(b) and (not O(b)))";"((_del_P(b) and O(b) and (not P(b)) and (not Q(b))) or (_del_Q(b) and O(b) and (not P(b)) and (not Q(b))))-> (P(b) and (not O(b)))"]
+ ["(O(b) and (not P(b)) and (not Q(b)) and (_del_P(b) or _del_Q(b)))-> (P(b) and (not O(b)))";"((_del_Q(b) or _del_P(b)) and O(b) and (not P(b)) and (not Q(b)))-> (P(b) and (not O(b)))";"((_del_P(b) and O(b) and (not P(b)) and (not Q(b))) or (_del_Q(b) and O(b) and (not P(b)) and (not Q(b))))-> (P(b) and (not O(b)))";"((_del_P(b) or _del_Q(b)) and O(b) and (not P(b)) and (not Q(b)))-> (P(b) and (not O(b)))"]
(rule_obj_str rule_obj);
let lhs_struc = struc_of_str "[ e | _opt_D (e); _diffthan_P(e) | ]" in
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Formula/Aux.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -178,6 +178,12 @@
concat_map (fun el -> List.map (fun tup -> el::tup) prod) set)
l [[]]
+let rec pairs l =
+ match l with
+ | [] -> []
+ | hd::tl ->
+ List.rev_append (List.map (fun e-> hd, e) tl) (pairs tl)
+
let all_tuples_for args elems =
List.fold_left (fun tups _ ->
concat_map (fun e -> (List.map (fun tup -> e::tup) tups))
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Formula/Aux.mli 2011-03-03 21:40:00 UTC (rev 1342)
@@ -113,6 +113,10 @@
(** Cartesian product of lists. Not tail recursive. *)
val product : 'a list list -> 'a list list
+(** A list of all pairs of elements that preserve the order of
+ elements from the list. *)
+val pairs : 'a list -> ('a * 'a) list
+
(** An [n]th cartesian power of the second list, where [n] is the
length of the first list. Tail recursive. *)
val all_tuples_for : 'a list -> 'b list -> 'b list list
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/GGP/GDL.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -189,11 +189,39 @@
[not (r, args) <=> not exist vars1 (args = params1 /\ body1) /\ ...
/\ not exist vars_n (args = params_n /\ body_n)]
- Currently we do not allow defined dynamic relations with negative
- occurrences to have negative literals (or atoms of defined
- relations with negative part) in any of [body_i]. (The limitation
- can be lifted but it would further complicate the implementation.)
- We therefore allow conjunctions of atoms to be negated (not only
+ (6b1) If the relation has negative subformulas in any of [body_i],
+ we first negate the definition and then expand the negation as in
+ the positive case.
+
+ (6b1a) Eliminate [args = params_i] by substituting-out variables
+ from [params_i] whenever possible.
+
+ Note: the [args] need to be instatiated for the particular
+ solution that is extended (the solution substitution applied).
+
+ (6b1b) We group the positive atoms of body_i together and split
+ the quantifier if each negative subformula and the positive part
+ have disjoint [vars_i] variables; if not, the translation fails;
+ currently, if a negative subformula has free variables in vars_i,
+ the translation also fails.
+
+ (6b1c) So we have two levels of specification-affecting TODOs;
+ working around variables shared between negated subformulas or the
+ positive part -- forbidding pushing quantification inside -- will
+ require major rethinking of implementation; if the quantification
+ can be pushed inside but doesn't disappear around a negated
+ subformula, we will need to extend the universal quantifier
+ handling from only negated to both negated and positive
+ subformulas, which shouldn't be problematic.
+
+ (6b1d) Now push the negation inside the conjunction so that all
+ double negations cancel out (the positive conjuncts are under a
+ single, now negated, quantifier -- see (6b2) about negated
+ conjunctions of atoms). Next we pull the disjunctions out
+ (reducing to DNF-like form), and continue as in the positive case
+ (6a).
+
+ (6b2) We allow conjunctions of atoms to be negated (not only
literals) in a branch. We expand [not (r, args)] (in general, [not
(and (...(r args)...))]) into the conjunction of negations, with
no branch duplication (in general, duplicating the negated
@@ -633,6 +661,12 @@
(* Type shortcuts (mostly for documentation). *)
type gdl_atom = string * term list
type gdl_rule = gdl_atom * gdl_atom list * gdl_atom list
+(* Definition with collected relation branches and negation-local
+ variables found. *)
+type lit_def_branch =
+ term list * gdl_atom list * (Aux.Strings.t * gdl_atom) list
+type lit_def =
+ string * lit_def_branch list
(* Definition with expanded definitions: expansion of a negated
relation brings negated (possibly locally existentially quantified)
conjunctions. *)
@@ -699,13 +733,14 @@
head, pos_body, neg_body) bodies
| Atomic (rel, args) -> [(rel, args), [], []]
-let add_neg_body_vars global_vars neg_body =
+let add_neg_body_vars global_vars neg_body
+ : (Aux.Strings.t * gdl_atom) list =
List.map (fun (_, args as a)->
let local_vs = Aux.Strings.diff (terms_vars args) global_vars in
- local_vs, [a]) neg_body
+ local_vs, a) neg_body
-let defs_of_rules rules
- : (string * exp_def_branch list) list =
+let lit_defs_of_rules rules
+ : (string * lit_def_branch list) list =
Aux.map_reduce
(fun ((drel, params), body, neg_body) ->
let global_vs =
@@ -714,27 +749,36 @@
add_neg_body_vars global_vs neg_body))
(fun x y->y::x) [] rules
-(* Only use [rules_of_defs] when sure that no multi-premise negative
- literal has been expanded. *)
-let rules_of_defs (defs : exp_def list) =
+let rules_of_lit_defs (defs : lit_def list) =
Aux.concat_map (fun (rel, branches) ->
List.map (fun (args, body, neg_body) ->
let neg_body =
- List.map (function _,[a]->a | _ -> assert false) neg_body in
+ List.map snd neg_body in
(rel, args), body, neg_body) branches) defs
+let exp_brs_of_lit_brs brs =
+ List.map (fun (args, body, neg_body) ->
+ let neg_body =
+ List.map (fun (vs,a) -> vs,[a]) neg_body in
+ args, body, neg_body) brs
+
+let exp_defs_of_lit_defs defs : exp_def list =
+ List.map (fun (rel, branches) ->
+ rel, exp_brs_of_lit_brs branches) defs
+
+
(* Stratify either w.r.t. the dependency graph ([~def:true]) or its
subgraph the negation graph ([~def:false]). *)
-let rec stratify ?(def=false) strata (defs : exp_def list) =
+let rec stratify ?(def=false) strata (defs : lit_def list) =
match
List.partition (fun (_, branches) ->
List.for_all (fun (_, body, neg_body) ->
- let neg_bodies = List.concat (List.map snd neg_body) in
+ let neg_body = List.map snd neg_body in
List.for_all (fun (rel1,_) ->
rel1 = "distinct" || rel1 = "true" || rel1 = "does" ||
not (List.mem_assoc rel1 defs))
- (if def then body @ neg_bodies
- else neg_bodies)) branches) defs
+ (if def then body @ neg_body
+ else neg_body)) branches) defs
with
| [], [] ->
(* {{{ log entry *)
@@ -935,6 +979,13 @@
let facts_str facts =
String.concat " " (List.map fact_str facts)
+let neg_lfacts_str negs =
+ String.concat " "
+ (List.map (fun (vs,d) ->
+ let vs = Aux.Strings.elements vs in
+ let q = if vs = [] then ""
+ else "forall "^String.concat ", " vs in
+ q ^ "(not "^fact_str d^")") negs)
let neg_facts_str negs =
String.concat " "
(List.map (fun (vs,d) ->
@@ -947,9 +998,15 @@
"("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
" " ^ neg_facts_str neg_body ^ ")"
-let def_str (rel, branches) =
+let lit_def_str (rel, branches) =
String.concat "\n" (List.map (fun (args, body, neg_body) ->
"("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
+ " " ^ neg_lfacts_str neg_body ^ ")"
+ ) branches)
+
+let exp_def_str (rel, branches) =
+ String.concat "\n" (List.map (fun (args, body, neg_body) ->
+ "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
" " ^ neg_facts_str neg_body ^ ")"
) branches)
(*
@@ -1059,19 +1116,17 @@
instantiate (inst_stratum [] [] base stratum) strata in
instantiate base
- (List.map rules_of_defs (stratify [] (defs_of_rules rules)))
+ (List.map rules_of_lit_defs (stratify [] (lit_defs_of_rules rules)))
let game_description = ref []
let player_terms = ref [| |]
let state_of_file s =
- Printf.printf "GDL: Loading file %s...\n%!" s;
let f = open_in s in
let res =
ArenaParser.parse_game_state Lexer.lex
(Lexing.from_channel f) in
- Printf.printf "GDL: File %s loaded.\n%!" s;
res
(* 6 *)
@@ -1121,12 +1176,61 @@
let freshen_def_branches =
List.map freshen_branch
+(* [args] are the actual, instatiated, arguments. *)
+let negate_def uni_vs args neg_def =
+ (* 6b1a *)
+ let global_vars = terms_vars args in
+ let aux_br (params, body, neg_body) =
+ let sb = unify [] params args in
+ let body = subst_rels sb body in
+ let neg_body = List.map (fun (vs, conjs) ->
+ vs, subst_rels sb conjs) neg_body in
+ let subforms = (Aux.Strings.empty, body) :: neg_body in
+ (* components of [vars_i] by conjuncts *)
+ let sub_fvars = List.map (fun (_, subphi) ->
+ Aux.Strings.diff (rels_vars subphi) global_vars) subforms in
+ let subvars = List.map2 (fun fvs (qvs,_) ->
+ Aux.Strings.diff fvs qvs) sub_fvars subforms in
+ (* 6b1b *)
+ if List.exists (fun (vs1, vs2) ->
+ not (Aux.Strings.is_empty (Aux.Strings.inter vs1 vs2)))
+ (Aux.pairs subvars)
+ then failwith
+ ("GDL.negate_def: variables shared between negated subformulas" ^
+ " -- long term TODO (params: "^terms_str params^")");
+ (if List.exists (fun (fvs, (qvs,_)) ->
+ (* [fvs - qvs] must be a subset of the "vars_i" quantified vars *)
+ not (Aux.Strings.is_empty (Aux.Strings.diff fvs qvs)))
+ (List.tl (List.combine sub_fvars subforms))
+ then
+ let (fvs,(qvs,_)) = List.find (fun (fvs, (qvs,_)) ->
+ not (Aux.Strings.is_empty (Aux.Strings.diff fvs qvs)))
+ (List.tl (List.combine sub_fvars subforms)) in
+ failwith
+ ("GDL.negate_def: universal quantification escapes negation" ^
+ " -- doable TODO (params: "^terms_str params^") (vars: "^
+ String.concat ", " (Aux.Strings.elements
+ (Aux.Strings.diff fvs qvs))^")"));
+ Aux.Right (List.hd sub_fvars, body) ::
+ List.map (fun (_,conjs) -> Aux.Left conjs) neg_body in
+ (* 6b1c *)
+ (* We drop branches whose heads don't match. *)
+ let cnf = Aux.map_try aux_br neg_def in
+ let dnf = Aux.product cnf in
+ List.map (fun conjs ->
+ let pos, neg = Aux.partition_choice conjs in
+ (* since (6b1b), no local universal quantification *)
+ let pos = List.concat pos in
+ pos, neg
+ ) dnf
+
+
(* assumption: [defs] bodies are already clean of defined relations *)
let subst_def_branch (defs : exp_def list)
- (head, body, neg_body as br : exp_def_branch) : exp_def_branch list =
+ (head, body, neg_body as br : lit_def_branch) : exp_def_branch list =
(* {{{ log entry *)
if !debug_level > 4 then (
- Printf.printf "Expanding branch %s\n%!" (def_str ("BRANCH", [br]));
+ Printf.printf "Expanding branch %s\n%!" (lit_def_str ("BRANCH", [br]));
);
(* }}} *)
(* 6a *)
@@ -1137,7 +1241,7 @@
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "Expanding positive %s by %s\n%!" rel
- (def_str (rel, def))
+ (exp_def_str (rel, def))
);
(* }}} *)
Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
@@ -1158,48 +1262,91 @@
subst_rel sb atom::pos_sol, neg_sol, sb) sols))
([[],[],[]]) body in
(* 6b *)
+ let neg_body_flat, neg_body_rec =
+ Aux.partition_map (fun (uni_vs, (neg_rel, neg_args) as neg_lit) ->
+ (let try def =
+ freshen_def_branches (List.assoc neg_rel defs) in
+ if not (List.exists (fun (_,_,negb) -> negb<>[]) def)
+ then Aux.Left (neg_lit, Some def)
+ else (
+ (* {{{ log entry *)
+
+ if !debug_level > 3 then (
+ let _,_,def_neg_body =
+ List.find (fun (_,_,negb) -> negb <> []) def in
+ Printf.printf
+ "expand: found recursive negative %s(%s): neg_body= not %s\n%!"
+ neg_rel (terms_str neg_args)
+ (String.concat " and not "
+ (List.map facts_str (List.map snd def_neg_body)))
+ );
+
+ (* }}} *)
+ Aux.Right (neg_lit, def))
+ with Not_found -> Aux.Left (neg_lit, None))
+ ) neg_body in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding (%s) negative part: flat %s; rec %s\n%!"
+ (terms_str head)
+ (String.concat ", "(List.map (fun ((_,(nr,_)),_) -> nr) neg_body_flat))
+ (String.concat ", "(List.map (fun ((_,(nr,_)),_) -> nr) neg_body_rec))
+ );
+ (* }}} *)
+ (* 6b1 *)
let sols =
- (* no branch duplication, but each negation has its own substitution *)
+ List.fold_left (fun sols ((uni_vs, (rel, args)), neg_def) ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding rec-negative %s by %s\n%!" rel
+ (exp_def_str (rel, neg_def))
+ );
+ (* }}} *)
+ (* we don't keep the substitution from the negated match *)
+ Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ let branches = negate_def uni_vs args neg_def in
+ List.map (fun (dbody, dneg_body) ->
+ dbody @ pos_sol, dneg_body @ neg_sol, sb) branches
+ ) sols)
+ sols neg_body_rec in
+
+ (* 6b2 *)
+ let sols =
List.map (fun (pos_sol, neg_sol, sb) ->
let more_neg_sol =
- Aux.concat_map (fun (uni_vs, neg_conjs) ->
- (* negated subformulas are duplicated instead *)
- List.fold_left (fun neg_sol (rel, args as atom) ->
- (let try def =
- freshen_def_branches (List.assoc rel defs) in
- Aux.concat_map (fun (uni_vs, neg_acc, sb) ->
- let args = List.map (subst sb) args in
- Aux.map_try (fun (dparams, dbody, dneg_body) ->
- if dneg_body <> [] then
- failwith
- ("GDL.subst_def_branch: negation in negatively used" ^
- " defined rels not supported yet, relation "^rel);
- (let sb1 = unify [] dparams args in
- let param_vars = terms_vars dparams in
- let body_vars = rels_vars dbody in
- let dbody = subst_rels sb1 dbody in
- let local_vs =
- Aux.Strings.inter (Aux.Strings.diff body_vars param_vars)
- (rels_vars dbody) in
- let neg_acc = subst_rels sb1 neg_acc in
- Aux.Strings.union uni_vs local_vs,
- dbody @ neg_acc,
- extend_sb sb1 sb)
- ) def) neg_sol
- with Not_found -> (* rel not in defs *)
- List.map (fun (uni_vs, neg_acc, sb) ->
- uni_vs, subst_rel sb atom::neg_acc, sb) neg_sol)
- ) [uni_vs, [], sb] neg_conjs
- ) neg_body in
- let more_neg_sol =
- List.map (fun (uni_vs, neg_conjs,_) -> uni_vs, neg_conjs)
- more_neg_sol in
+ Aux.concat_map (fun ((uni_vs, (rel, args as atom)), def_opt) ->
+ (* negated subformulas are duplicated instead of branches *)
+ match def_opt with
+ | Some def ->
+ let args = List.map (subst sb) args in
+ Aux.map_try (fun (dparams, dbody, _) ->
+ (let sb1 = unify [] dparams args in
+ let param_vars = terms_vars dparams in
+ let body_vars = rels_vars dbody in
+ let dbody = subst_rels sb1 dbody in
+ let local_vs =
+ Aux.Strings.diff body_vars
+ (Aux.Strings.diff param_vars uni_vs) in
+ local_vs, dbody)
+ ) def
+ | None -> (* rel not in defs *)
+ [uni_vs, [atom]]
+ ) neg_body_flat in
List.rev pos_sol, List.rev_append neg_sol more_neg_sol, sb
) sols in
- Aux.map_some (fun (pos_sol, neg_sol, sb) ->
- if List.exists (function _,[] -> true | _ -> false) neg_sol
- then None
- else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols
+ let res =
+ Aux.map_some (fun (pos_sol, neg_sol, sb) ->
+ if List.exists (function _,[] -> true | _ -> false) neg_sol
+ then None
+ else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expansion: res =\n%s\nExpansion done.\n%!"
+ (String.concat "\n"(List.map (branch_str "exp-unkn") res))
+ );
+ (* }}} *)
+ res
(* Stratify and expand all relations in the given set. *)
let expand_def_rules ?(more_defs=[]) rules =
@@ -1218,14 +1365,16 @@
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf "expand_def_rules: step result = %s\nexpand_def_rules: end step\n%!"
- (String.concat "\n" (List.map def_str step))
+ (String.concat "\n" (List.map exp_def_str step))
);
(* }}} *)
loop (base @ step) strata in
- match stratify ~def:true [] (defs_of_rules rules) with
+ match stratify ~def:true [] (lit_defs_of_rules rules) with
| [] -> []
- | [no_defined_rels] when more_defs=[] -> no_defined_rels
- | def_base::def_strata when more_defs=[] -> loop def_base def_strata
+ | [no_defined_rels] when more_defs=[] ->
+ exp_defs_of_lit_defs no_defined_rels
+ | def_base::def_strata when more_defs=[] ->
+ loop (exp_defs_of_lit_defs def_base) def_strata
| def_strata -> loop more_defs def_strata
@@ -1262,6 +1411,11 @@
(List.rev_append more_neg_body neg_body)))
with Not_found -> None
+let subst_legal_rules def_brs brs =
+ Aux.concat_map (fun br ->
+ List.map snd
+ (Aux.map_some (fun def -> subst_legal_rule def br) def_brs)) brs
+
(* 1 *)
(* Collect the aggregate playout, but also the actions available in
@@ -1994,27 +2148,21 @@
| _ -> false) static_rules
) static_rules in
(* {{{ log entry *)
-
if !debug_level > 0 then (
Printf.printf "translate_game: expanded static rules: %s\n%!"
(String.concat ", " (List.map (fun ((r,_),_,_)->r) exp_static_rules));
);
-
(* }}} *)
let static_exp_defs = expand_def_rules exp_static_rules in
- let static_rules =
- if static_exp_defs = [] then static_rules
- else rules_of_defs
- (List.map (fun (rel,branches) ->
- rel, Aux.concat_map (subst_def_branch static_exp_defs) branches)
- (defs_of_rules static_rules)) in
+ let static_rules = Aux.unique_sorted
+ (List.map Aux.fst3 static_rules) in
let exp_defs =
expand_def_rules ~more_defs:static_exp_defs dynamic_rules in
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "translate_game: All expanded dynamic rules:\n%s\n%!"
- (String.concat "\n" (List.map def_str exp_defs))
+ (String.concat "\n" (List.map exp_def_str exp_defs))
);
(* }}} *)
(* 3 *)
@@ -2023,15 +2171,13 @@
let terminal_rules = List.assoc "terminal" exp_defs in
let goal_rules = List.assoc "goal" exp_defs in
(* 3b *)
- let exp_next =
- Aux.concat_map (subst_def_branch ["does", legal_rules]) next_rules in
+ let exp_next = subst_legal_rules legal_rules next_rules in
+
(* {{{ log entry *)
-
if !debug_level > 0 then (
Printf.printf "translate_game: \"next\" rules with \"does\"<-\"legal\":\n%s\n%!"
- (def_str ("next", exp_next))
+ (exp_def_str ("next", exp_next))
);
-
(* }}} *)
(* 3c *)
let masks = List.map (function
@@ -2119,9 +2265,8 @@
| mask, (sb,_)::_ -> List.map (fun (v,_)->mask, v) sb) elements in
(* 4a *)
let static_rels =
- Aux.unique_sorted
- (List.map (fun ((rname,args),_,_) ->
- rname, List.map (fun _ -> ()) args) static_rules) in
+ List.map (fun (rname,args) ->
+ rname, List.map (fun _ -> ()) args) static_rules in
let static_rels =
List.map (fun (rel,args) ->
rel, List.length args,
@@ -2517,7 +2662,9 @@
);
(* }}} *)
(* 7f3 *)
- let erasure_brs : exp_def_branch list = Aux.concat_map
+ (* TODO: minimize the number of branches by keeping
+ negations over conjunctions like in (6b1) *)
+ let erasure_brs : lit_def_branch list = Aux.concat_map
(function
| [next_arg] as next_args,multi_body ->
let mask, _, _, blank_arg = term_to_blank masks next_arg in
@@ -2596,8 +2743,7 @@
List.mem pos neg_conjs) lead_neg_body
) body) &&
not (List.exists (fun (_,neg) ->
- List.for_all
- (fun neg->List.mem neg lead_body) neg
+ List.mem neg lead_body
) neg_body)
then Some ([head], body, neg_body)
else None
@@ -2612,7 +2758,8 @@
(* TODO: (7f5) we ignore the possibility that "lead" is
instantiated by some of erasure substitutions, since
we already ignore non-maximal "legal" classes *)
- lead_head, fixed_brs @ expanded_brs @ erasure_brs
+ lead_head, fixed_brs @ expanded_brs @
+ exp_brs_of_lit_brs erasure_brs
) rules_brs in
(* let rules_inds = Array.of_list rules_brs in *)
rules_brs
@@ -2625,12 +2772,12 @@
List.iter (fun (lead, brs) ->
Printf.printf "Rule-precursor: player %s move %s\n%s\n%!"
(term_str loc_players.(loc)) (term_str lead)
- (def_str ("action", brs))
+ (exp_def_str ("action", brs))
) rules_brs;
) loc_next_classes;
);
(* }}} *)
- let static_rnames = List.map (fun ((srel,_),_,_) -> srel) static_rules in
+ let static_rnames = List.map fst static_rules in
(* 7h *)
let loc_toss_rules =
Array.mapi (fun loc rules_brs ->
@@ -2890,7 +3037,8 @@
List.filter (fun a -> List.exists (fun v->List.mem v disj_vars)
(FormulaOps.free_vars a)) goal_4b in
let disj = lift_universal goal_uni_vars (disj_4b @ conjs) in
- Formula.Ex (FormulaOps.free_vars disj, disj)
+ let disj_vs = FormulaOps.free_vars disj in
+ if disj_vs = [] then disj else Formula.Ex (disj_vs, disj)
) brs in
score, Formula.Or goal_disjs
) goals in
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/GGP/GDL.mli 2011-03-03 21:40:00 UTC (rev 1342)
@@ -85,7 +85,7 @@
gdl_translation * (Arena.game * Arena.game_state)
(* DEBUG intermediate *)
-val defs_of_rules : gdl_rule list -> exp_def list
+(* val exp_defs_of_rules : gdl_rule list -> exp_def list *)
val expand_def_rules :
?more_defs:exp_def list -> gdl_rule list -> exp_def list
@@ -109,4 +109,4 @@
val term_str : term -> string
val fact_str : string * term list -> string
val facts_str : (string * term list) list -> string
-val def_str : exp_def -> string
+val exp_def_str : exp_def -> string
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/GGP/GDLTest.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -73,7 +73,7 @@
((alpha ?X) <= (rho ?X) (not (and (gamma ?X) (rho ?X))))
((zeta ?X) <= (rho ?X) (not (and (gamma ?X))))"
(String.concat "\n"
- (List.map GDL.def_str res));
+ (List.map GDL.exp_def_str res));
);
"connect5" >::
@@ -114,5 +114,5 @@
let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in
let connect5 = load_rules "./GGP/examples/connect5.gdl" in
let tictactoe = load_rules "./GGP/examples/tictactoe.gdl" in
- let gdef = GDL.translate_game (Const "white") breakthrough in
+ let gdef = GDL.translate_game (Const "x") connect5 in
ignore gdef; ignore connect5; ignore breakthrough; ignore tictactoe
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Play/GameTest.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -31,12 +31,10 @@
(Lexing.from_string s)
let state_of_file s =
- Printf.printf "Loading file %s...\n%!" s;
let f = open_in s in
let res =
ArenaParser.parse_game_state Lexer.lex
(Lexing.from_channel f) in
- Printf.printf "File %s loaded.\n%!" s;
res
module StrMap = Structure.StringMap
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Server/Server.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -441,12 +441,10 @@
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;
+ state := s
;;
let heur_val_white1 = ref "";;
Modified: trunk/Toss/Server/ServerGDLTest.in2
===================================================================
--- trunk/Toss/Server/ServerGDLTest.in2 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Server/ServerGDLTest.in2 2011-03-03 21:40:00 UTC (rev 1342)
@@ -32,7 +32,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 (NOOP (MARK 1 1)))
+(PLAY MATCH.3316980891 (NOOP (MARK 2 2)))
POST / HTTP/1.0
Accept: text/delim
@@ -41,7 +41,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 ((MARK 3 2) NOOP))
+(PLAY MATCH.3316980891 ((MARK 1 3) NOOP))
POST / HTTP/1.0
Accept: text/delim
@@ -50,7 +50,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 (NOOP (MARK 2 2)))
+(PLAY MATCH.3316980891 (NOOP (MARK 1 1)))
POST / HTTP/1.0
Accept: text/delim
@@ -59,7 +59,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 ((MARK 3 1) NOOP))
+(PLAY MATCH.3316980891 ((MARK 2 3) NOOP))
POST / HTTP/1.0
Accept: text/delim
Modified: trunk/Toss/Server/ServerGDLTest.out2
===================================================================
--- trunk/Toss/Server/ServerGDLTest.out2 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Server/ServerGDLTest.out2 2011-03-03 21:40:00 UTC (rev 1342)
@@ -12,7 +12,7 @@
Content-type: text/acl
Content-length: 10
-(MARK 1 1)
+(MARK 2 2)
HTTP/1.0 200 OK
Content-type: text/acl
Content-length: 4
@@ -22,7 +22,7 @@
Content-type: text/acl
Content-length: 10
-(MARK 2 2)
+(MARK 1 1)
HTTP/1.0 200 OK
Content-type: text/acl
Content-length: 4
Modified: trunk/Toss/Server/ServerTest.ml
===================================================================
--- trunk/Toss/Server/ServerTest.ml 2011-03-03 18:28:09 UTC (rev 1341)
+++ trunk/Toss/Server/ServerTest.ml 2011-03-03 21:40:00 UTC (rev 1342)
@@ -57,7 +57,7 @@
let out_ch = open_out "./Server/ServerGDLTest.temp" in
Game.deterministic_suggest := true;
let old_effort = !Game.default_effort in
- Game.default_effort := 2;
+ Game.default_effort := 6;
(try while true do
Server.req_handle in_ch out_ch done
with End_of_file -> ());
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-03 18:28:15
|
Revision: 1341
http://toss.svn.sourceforge.net/toss/?rev=1341&view=rev
Author: lukaszkaiser
Date: 2011-03-03 18:28:09 +0000 (Thu, 03 Mar 2011)
Log Message:
-----------
Adapting server to GameTree a bit.
Modified Paths:
--------------
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-03 02:43:07 UTC (rev 1340)
+++ trunk/Toss/Server/Server.ml 2011-03-03 18:28:09 UTC (rev 1341)
@@ -28,7 +28,7 @@
let playclock = ref 0
let g_heur = ref None
-let no_gtree = ref true
+let no_gtree = ref false
let exp_p1_timeout = ref 9000
let exp_p2_timeout = ref 9000
@@ -296,6 +296,9 @@
game_modified := false;
play := Some p; play_state := Some ps;
playclock := playcl;
+ g_heur := Some (Heuristic.default_heuristic
+ ~struc:(snd !state).Arena.struc
+ ~advr:4. (fst !state));
"HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 5"
^ "\r\n\r\nREADY"
@@ -384,7 +387,7 @@
| Some play, Some play_state ->
play, play_state
| _ -> assert false in
- ignore (Unix.alarm (!playclock - time_used - 2));
+ ignore (Unix.alarm (!playclock - time_used - 1));
if !no_gtree then
let res = Game.suggest p ps in
Game.cancel_timeout ();
@@ -397,10 +400,7 @@
else
let heur = match !g_heur with
| Some h -> h
- | None ->
- let h = Heuristic.default_heuristic
- ~struc:(snd !state).Arena.struc ~advr:4. (fst !state) in
- g_heur := Some h; h in
+ | None -> failwith "no heuristic for gametree!" in
let (move, _) = GameTree.maximax_unfold_choose 5500
(fst !state) (snd !state) heur in
Game.cancel_timeout ();
@@ -586,7 +586,7 @@
"black (=second) player heuristic for use by the second player in tests");
("-eto1", Arg.Int (fun i -> exp_p1_timeout := i), "p1 timeout for exper");
("-eto2", Arg.Int (fun i -> exp_p2_timeout := i), "p1 timeout for exper");
- ("-gtree", Arg.Unit (fun () -> no_gtree := false), "use GameTree module");
+ ("-gamemod", Arg.Unit (fun ()-> no_gtree:= false), "use older Game module");
("-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)],
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-03 02:43:14
|
Revision: 1340
http://toss.svn.sourceforge.net/toss/?rev=1340&view=rev
Author: lukaszkaiser
Date: 2011-03-03 02:43:07 +0000 (Thu, 03 Mar 2011)
Log Message:
-----------
Some alpha-beta in GameTree.
Modified Paths:
--------------
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/GameTreeTest.ml
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-02 01:20:52 UTC (rev 1339)
+++ trunk/Toss/Play/GameTree.ml 2011-03-03 02:43:07 UTC (rev 1340)
@@ -68,7 +68,7 @@
else
let leaf_of_move leaf_s =
let l_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in
- let l_info = info_leaf (depth+1) game leaf_s l_pl in
+ let l_info = info_leaf (depth+1) game leaf_s l_pl player in
Leaf (leaf_s, l_pl, l_info) 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)
@@ -111,7 +111,8 @@
(* Get the payoffs / heuristics array of a game tree node. *)
let node_values = function
- | Terminal (_, _, i) -> Array.map (fun p -> !cPAYOFF_AS_HEUR *. p) i.payoffs
+ | Terminal (_, _, i) ->
+ Array.mapi (fun k p -> !cPAYOFF_AS_HEUR *. p +. i.heurs_t.(k)) i.payoffs
| Leaf (_, _, i) -> i.heurs
| Node (_, _, i, _) -> i.heurs
@@ -123,14 +124,25 @@
(* Game tree initialization. *)
-let info_leaf_f f heurs depth game state player =
+let info_leaf_f ab last_vals stop_vals f heurs depth game state l_pl pl =
+ let issome = function Some _ -> true | _ -> false in
let calc re = Solver.M.get_real_val re state.Arena.struc in
- let res =
- { heurs = Array.map calc heurs.(state.Arena.cur_loc);
- info = f depth game state } in
- res
+ let heurs =
+ if ab && issome !last_vals && issome !stop_vals &&
+ ((Aux.unsome !last_vals).(pl) > (Aux.unsome !stop_vals).(pl)) then
+ Aux.unsome !last_vals
+ else (
+ let resh = Array.map calc heurs.(state.Arena.cur_loc) in
+ if not (issome !last_vals) then last_vals := Some (resh) else
+ if (Aux.unsome !last_vals).(pl) < resh.(pl) then
+ last_vals := Some (resh);
+ resh
+ ) in
+ { heurs = heurs; info = f depth game state }
-let init game state f h = init_abstract game state (info_leaf_f f h 0)
+let init game state f h =
+ let init_f g s p = info_leaf_f false (ref None) (ref None) f h 0 g s p 0 in
+ init_abstract game state init_f
(* Game tree unfolding. *)
@@ -143,24 +155,23 @@
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 cmp c1 c2 = if move_val player c1 > move_val player c2 then 1
+ else if move_val player c2 > move_val player c1 then -1 else 0 in
+ let mids = Aux.array_argfind_all_max cmp children in
+ 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
+ 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 =
+let unfold ?(ab=false) game heur ~info_leaf ~info_node ~choice =
+ let (last_vals, stop_vals) = (ref None, ref None) in
unfold_abstract game
~info_terminal:(info_terminal_f info_leaf)
- ~info_leaf:(info_leaf_f info_leaf heur)
+ ~info_leaf:(info_leaf_f ab last_vals stop_vals info_leaf heur)
~info_node:(info_node_f info_node)
- ~choice:choice
+ ~choice:(choice stop_vals)
(* Choose one of the maximizing moves (at random) given a game tree. *)
let choose_move game = function
@@ -169,17 +180,29 @@
Aux.random_elem (Array.to_list (Move.list_moves game state))
| Node (_, p, info, succ) ->
let mval = info.heurs.(p) in
- let max = Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in
- let (m, t) = Aux.random_elem max in (m, state t)
+ let nonleaf = function Leaf _ -> false | _ -> true in
+ let maxs= Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in
+ if List.exists (fun x -> nonleaf (snd x)) maxs then
+ let (m, t) = Aux.random_elem maxs in (m, state t)
+ 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)
+ 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)
+ )
-
(* ------------ MAXIMAX BY DEPTH ------------- *)
let maxdepth_node dp player heurs children =
let depths = Array.map (fun child -> (node_info (snd child))) children in
(Array.fold_left (fun m d -> max m d) 0 depths) + 1
-let maximax_depth_choice dp game cur_state player info children =
+let maximax_depth_choice ab stop_vals dp game cur_state player info children =
let mval child = (node_values (snd child)).(player), node_info (snd child) in
let cmp c1 c2 =
let (v1, d1), (v2, d2) = mval c1, mval c2 in
@@ -187,29 +210,43 @@
let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in
if !debug_level > 2 then
print_endline (Structure.str (state (snd children.(res))).Arena.struc);
+ if ab then (
+ let cmp_dpt c1 c2 = (snd (mval c1)) - (snd (mval c2)) in
+ let maxdps = Aux.array_argfind_all_max cmp_dpt children in
+ let maxd = snd (mval children.(List.hd maxdps)) in
+ if snd (mval children.(res)) = maxd - 1 then (
+ let maxa = ref (node_values (snd children.(List.hd maxdps))) in
+ let big c = fst (mval children.(c)) > !maxa.(player) in
+ let upd c = maxa := node_values (snd children.(c)) in
+ List.iter (fun c -> if big c then upd c) maxdps;
+ stop_vals := Some !maxa
+ ) else stop_vals := None
+ );
res
(* Maximax by depth unfolding function. Throws Not_found if ready. *)
-let unfold_maximax game heur =
- unfold game heur ~info_leaf:(fun _ _ _ -> 0)
- ~info_node:(maxdepth_node) ~choice:(maximax_depth_choice)
+let unfold_maximax ?(ab=false) game heur =
+ unfold ~ab:ab game heur ~info_leaf:(fun _ _ _ -> 0)
+ ~info_node:(maxdepth_node) ~choice:(maximax_depth_choice ab)
(* Maximax unfolding upto depth. *)
-let rec unfold_maximax_upto count game heur t =
+let rec unfold_maximax_upto ?(ab=false) count game heur t =
if count = 0 || Game.get_timeout () then (
if !debug_level > 1 && Game.get_timeout () then print_endline "Timeout";
t
) else
try
- let u = unfold_maximax game heur t in
+ let u = unfold_maximax ~ab:ab game heur t in
if !debug_level > 0 then Printf.printf "%d,%!" (size u);
- unfold_maximax_upto (count-1) game heur u
+ unfold_maximax_upto ~ab:ab (count-1) game heur u
with Not_found -> t
(* Maximax unfold upto depth and choose move. *)
let maximax_unfold_choose 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;
let t = init game state (fun _ _ _ -> 0) heur in
- let u = unfold_maximax_upto count game heur t in
+ let u = unfold_maximax_upto ~ab count game heur t in
if !debug_level > 1 then print_endline (str string_of_int u);
choose_move game u
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-03-02 01:20:52 UTC (rev 1339)
+++ trunk/Toss/Play/GameTree.mli 2011-03-03 02:43:07 UTC (rev 1340)
@@ -33,7 +33,7 @@
(** Abstract game tree unfolding function, calls argument functions for work. *)
val unfold_abstract : ?depth:int -> Arena.game ->
info_terminal : (int -> Arena.game -> Arena.game_state -> int -> 'a -> 'b) ->
- info_leaf : (int -> Arena.game -> Arena.game_state -> int -> 'a) ->
+ info_leaf : (int -> Arena.game -> Arena.game_state -> int -> int -> 'a) ->
info_node : (int -> Arena.game -> Arena.game_state -> int ->
(Move.move * ('a, 'b) abstract_game_tree) array -> 'a) ->
choice : (int -> Arena.game -> Arena.game_state -> int -> 'a ->
@@ -82,24 +82,24 @@
Formula.real_expr array array -> 'a game_tree
(** Game tree unfolding. *)
-val unfold : Arena.game -> Formula.real_expr array array ->
+val unfold : ?ab:bool -> Arena.game -> Formula.real_expr array array ->
info_leaf : (int -> Arena.game -> Arena.game_state -> 'a) ->
info_node : (int -> int -> float array ->
(Move.move * 'a game_tree) array -> 'a) ->
- choice : (int -> Arena.game -> Arena.game_state -> int -> 'a node_info ->
- (Move.move * 'a game_tree) array -> int) ->
+ choice : (float array option ref -> int -> Arena.game -> Arena.game_state ->
+ int -> 'a node_info -> (Move.move * 'a game_tree) array -> int) ->
'a game_tree -> 'a game_tree
(** ------------ MAXIMAX BY DEPTH ------------- *)
(** Maximax by depth unfolding function. Throws Not_found if ready. *)
-val unfold_maximax : Arena.game ->
+val unfold_maximax : ?ab:bool -> Arena.game ->
Formula.real_expr array array -> int game_tree -> int game_tree
(** Maximax unfolding upto depth. *)
-val unfold_maximax_upto : int -> Arena.game ->
+val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
Formula.real_expr array array -> int game_tree -> int game_tree
(** Maximax unfold upto depth and choose move. *)
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-03-02 01:20:52 UTC (rev 1339)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-03-03 02:43:07 UTC (rev 1340)
@@ -29,7 +29,7 @@
"\t \n\t. . . \n" ^
"\t \n\t. . . \n" ^
"\t \n\t. . . \n" ^ "\"\n5")
- (GameTree.str_abstract string_of_int string_of_int t)
+ (GameTree.str_abstract string_of_int string_of_int t);
);
"abstract unfold, size" >::
@@ -37,11 +37,11 @@
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in
let i_t = (fun _ _ _ _ _ -> 0) in
- let i_l = (fun _ _ _ _ -> 1) in
+ let i_l = (fun _ _ _ _ _ -> 1) in
let (i_n, ch) = (fun _ _ _ _ _ -> 2), (fun _ _ _ _ _ _ -> 0) in
let u = GameTree.unfold_abstract g i_t i_l i_n ch t in
(* print_endline (GameTree.str_abstract string_of_int string_of_int u);*)
- assert_equal ~printer:(fun x -> string_of_int x) 10 (GameTree.size u)
+ assert_equal ~printer:(fun x -> string_of_int x) 10 (GameTree.size u);
);
"game tree unfold, state, player" >::
@@ -50,11 +50,11 @@
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
let t = GameTree.init g s (fun _ _ _ -> 0) h in
let i_l, i_n = (fun _ _ _ -> 0), (fun _ _ _ _ -> 1) in
- let ch = (fun _ _ _ _ _ _ -> 0) in
+ let ch = (fun _ _ _ _ _ _ _ -> 0) in
let u = GameTree.unfold g h i_l i_n ch t in
(* print_endline (GameTree.str string_of_int u); *)
assert_equal ~printer:(fun x -> string_of_int x) (GameTree.player u)
- g.Arena.graph.((GameTree.state u).Arena.cur_loc).Arena.player
+ g.Arena.graph.((GameTree.state u).Arena.cur_loc).Arena.player;
);
"maximax unfold once, node_info" >::
@@ -64,7 +64,7 @@
let t = GameTree.init g s (fun _ _ _ -> 0) h in
let u = GameTree.unfold_maximax g h t in
(* print_endline (GameTree.str string_of_int u); *)
- assert_equal ~printer:(fun x -> string_of_int x) 1 (GameTree.node_info u)
+ assert_equal ~printer:(fun x -> string_of_int x) 1 (GameTree.node_info u);
);
"maximax unfold upto depth, size" >::
@@ -74,7 +74,11 @@
let t = GameTree.init g s (fun _ _ _ -> 0) h in
let u = GameTree.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)
+ assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u);
+
+ let u1 = GameTree.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);
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-02 01:21:00
|
Revision: 1339
http://toss.svn.sourceforge.net/toss/?rev=1339&view=rev
Author: lukaszkaiser
Date: 2011-03-02 01:20:52 +0000 (Wed, 02 Mar 2011)
Log Message:
-----------
Simplify solver interface and adapt to it.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/ContinuousRule.mli
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/Play/Game.ml
trunk/Toss/Play/GameTest.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/Class.ml
trunk/Toss/Solver/Class.mli
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/PresbTest.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/Arena.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -22,7 +22,6 @@
id : int ;
player : int ;
payoffs : Formula.real_expr array ;
- payoffs_pp : Solver.M.registered_real_expr array ;
moves : (label * int) list ;
}
@@ -33,8 +32,7 @@
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
- defined_rels : (string * (string list * Formula.formula *
- Solver.M.registered_formula)) list ;
+ defined_rels : (string * (string list * Formula.formula)) list ;
}
(* State of the game and additional information. *)
@@ -47,12 +45,8 @@
let empty_state =
let emp_struc = Structure.empty_structure () in
let zero = Formula.Const 0.0 in
- {rules=[];
- graph=Array.make 1
- { id = 0; player = 0; payoffs = [|zero|];
- payoffs_pp =
- [|Solver.M.register_real_expr zero|];
- moves = [] };
+ {rules = [];
+ graph = Array.make 1 { id = 0; player = 0; payoffs = [|zero|]; moves = [] };
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
@@ -76,8 +70,7 @@
(* 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
- (Solver.M.register_formula def_phi) in
+ let def_asg = Solver.M.evaluate struc def_phi in
match def_asg with
| AssignmentSet.Empty ->
Structure.add_rel_name r_name (List.length vars) struc
@@ -148,11 +141,7 @@
let zero = Formula.Const 0.0 in
let payoffs =
array_of_players zero player_names payoffs in
- let payoffs_pp =
- Array.map Solver.M.register_real_expr payoffs in
- { id = id; player = player;
- payoffs = payoffs; payoffs_pp = payoffs_pp;
- moves = moves }
+ { id = id; player = player; payoffs = payoffs; moves = moves }
open Printf
@@ -168,8 +157,8 @@
(fst state).rules, Array.to_list (fst state).graph,
List.map fst (List.sort (fun (_,x) (_,y) -> x-y)
(fst state).player_names),
- List.map (fun (rel, (args, body, _)) ->rel, args, body)
- (fst state).defined_rels,
+ List.map (fun (rel, (args, body)) -> rel, args, body)
+ (fst state).defined_rels,
(snd state).struc, (snd state).time,
(snd state).cur_loc, (fst state).data in
(* {{{ log entry *)
@@ -219,10 +208,6 @@
let defined_rels = old_defined_rels @ List.rev defined_rels in
let def_rels_pure =
List.map (fun (rel, args, body) -> (rel, (args, body))) defined_rels in
- let defined_rels =
- List.map (fun (rel, args, body) ->
- rel, (args, body, Solver.M.register_formula body))
- defined_rels in
let player_names =
Array.to_list (Array.mapi (fun i pname->pname, i)
(Array.of_list players)) in
@@ -247,21 +232,13 @@
if old_locs = [] then old_locs
else
let zero = Formula.Const 0.0 in
- let pp_zero = Solver.M.register_real_expr zero in
let add_payoffs loc =
let more = num_players - Array.length loc.payoffs in
- {loc with
- payoffs =
- Array.append loc.payoffs (Array.make more zero);
- payoffs_pp =
- Array.append loc.payoffs_pp (Array.make more pp_zero);
- } in
+ {loc with payoffs = Array.append loc.payoffs (Array.make more zero);} in
List.map add_payoffs old_locs in
let add_def_rel loc =
let ps = Array.map (FormulaOps.subst_rels_expr def_rels_pure) loc.payoffs in
- let reg_ps =
- Array.map Solver.M.register_real_expr ps in
- { loc with payoffs = ps; payoffs_pp = reg_ps } in
+ { loc with payoffs = ps; } in
(* {{{ log entry *)
if !debug_level > 2 then (
printf "process_definition: parsing locations (registering payoffs)...%!";
@@ -291,7 +268,7 @@
num_players = num_players;
player_names = player_names;
data = data;
- defined_rels = defined_rels
+ defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
} in game, {
struc = state;
time = time;
@@ -350,7 +327,7 @@
cur_loc = cur_loc;
}) =
Format.fprintf ppf "@[<v>";
- List.iter (fun (drel, (args, body, _)) ->
+ List.iter (fun (drel, (args, body)) ->
if !equational_def_style then
Format.fprintf ppf "@[<1>REL@ %s@,(@[<1>%a@])@ =@ @[<1>%a@]"
drel (Aux.fprint_sep_list "," Format.pp_print_string) args
@@ -391,12 +368,8 @@
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 =
- {loc with
- payoffs = Array.append loc.payoffs [|zero|];
- payoffs_pp = Array.append loc.payoffs_pp [|pp_zero|];
- } in
+ {loc with payoffs = Array.append loc.payoffs [|zero|]; } in
let game = {state_game with
num_players = state_game.num_players + 1;
graph = Array.map add_payoff state_game.graph;
@@ -490,9 +463,7 @@
try
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
+ let defs = 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
@@ -505,9 +476,7 @@
try
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
+ let defs = 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
@@ -649,7 +618,7 @@
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
+ { id = l; player=0; payoffs=[| |]; moves=[] } in
(({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))
@@ -698,7 +667,7 @@
| 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) in
let ev (p,e) =
p^": "^(string_of_float (Solver.M.get_real_val e struc)) in
((state_game, state),
@@ -723,9 +692,7 @@
| 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
+ let defs = state_game.defined_rels in
let new_rules =
Aux.replace_assoc r_name (r signat defs r_name)
state_game.rules in
@@ -770,9 +737,7 @@
let d = r.ContinuousRule.discrete in
let (dyn, upd)=(r.ContinuousRule.dynamics, r.ContinuousRule.update) 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
+ let defs = 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
@@ -794,9 +759,7 @@
and inv = r.ContinuousRule.inv
and post = r.ContinuousRule.post 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
+ let defs = state_game.defined_rels in
let nr =
ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in
(nr, "RULE EMB SET") in
@@ -821,9 +784,7 @@
and inv = r.ContinuousRule.inv
and post = r.ContinuousRule.post 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
+ let defs = state_game.defined_rels in
let nr =
ContinuousRule.make_rule signat defs d dyn upd ~pre ~inv ~post () in
(nr, "RULE ASSOC SET") in
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/Arena.mli 2011-03-02 01:20:52 UTC (rev 1339)
@@ -17,7 +17,6 @@
id : int ;
player : int ;
payoffs : Formula.real_expr array ;
- payoffs_pp : Solver.M.registered_real_expr array ;
moves : (label * int) list ;
}
@@ -29,8 +28,7 @@
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
- defined_rels : (string * (string list * Formula.formula *
- Solver.M.registered_formula)) list ;
+ defined_rels : (string * (string list * Formula.formula)) list ;
}
(** State of the game. *)
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/ContinuousRule.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -17,11 +17,7 @@
update : ((string * string) * Term.term) list; (* Update equations calT *)
(* Note that, for efficiency, the precondition is part of DiscreteRule. *)
inv : Formula.formula; (* Invariant for the evolution *)
- inv_pp : Solver.M.registered_formula;
- (* Optimized invariant *)
post : Formula.formula; (* Postcondition for application *)
- post_pp : Solver.M.registered_formula;
-(* Optimized postcondition *)
}
(* Create a continuous rule given a discrete rule and other params. *)
@@ -32,19 +28,15 @@
let cinv = FormulaOps.subst_rels defs inv in
let cpost = FormulaOps.subst_rels defs post in
let discrete = { discr with DiscreteRule.pre = cpre } in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defs in
(* we use [discrete] instead of [discr] because parser does not
insert precondition into discr! *)
- let obj = DiscreteRule.compile_rule signat defrels discrete in
+ let obj = DiscreteRule.compile_rule signat defs discrete in
{ discrete = discrete;
compiled = obj ;
dynamics = dynamics ;
update = update ;
inv = cinv ;
- inv_pp = Solver.M.register_formula cinv;
post = cpost ;
- post_pp = Solver.M.register_formula cpost;
}
@@ -114,7 +106,7 @@
let all_vals = ref [] in
let end_time = !time +. t -. (0.01 *. !time_step) in (*TODO: 1% is decimals!*)
if !debug_level > 1 then print_endline ("et: " ^ (string_of_float end_time));
- let is_inv s = Solver.M.check_formula s r.inv_pp in
+ let is_inv s = Solver.M.check s r.inv in
let lhs_to_model ((f, a), _) =
(* dynamics refer to elements by LHS matches *)
let e = Structure.find_elem r.discrete.DiscreteRule.lhs_struc a in
@@ -176,7 +168,7 @@
let is_ok m =
let (res_struc, _, _) =
rewrite_single_nocheck struc cur_time m r 1. [] in
- Solver.M.check_formula res_struc r.post_pp in
+ Solver.M.check res_struc r.post in
if r.post = Formula.And [] then matches struc r else
List.filter is_ok (matches struc r)
@@ -186,7 +178,7 @@
let (res_struc, _, _ as res_struc_n_shifts) =
rewrite_single_nocheck struc cur_time m r t params in
if r.post = Formula.And [] ||
- Solver.M.check_formula res_struc r.post_pp
+ Solver.M.check res_struc r.post
then Some res_struc_n_shifts
else None
Modified: trunk/Toss/Arena/ContinuousRule.mli
===================================================================
--- trunk/Toss/Arena/ContinuousRule.mli 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/ContinuousRule.mli 2011-03-02 01:20:52 UTC (rev 1339)
@@ -15,10 +15,8 @@
update : ((string * string) * Term.term) list; (** Update equations calT *)
(** Note that, for efficiency, the precondition is part of DiscreteRule. *)
inv : Formula.formula; (** Invariant for the evolution *)
- inv_pp : Solver.M.registered_formula;
(** Optimized invariant *)
post : Formula.formula; (** Postcondition for application *)
- post_pp : Solver.M.registered_formula;
(** Optimized postcondition *)
}
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -36,7 +36,6 @@
lhs_elem_inv_names : elem_inv_names;
lhs_elem_vars : string list;
lhs_form : Formula.formula;
- lhs_form_pp : Solver.M.registered_formula;
(* gets instantiated in the model *)
(* the precondition [pre] is compiled as part of [lhs_form] *)
rhs_elem_names : elem_names;
@@ -173,7 +172,7 @@
(* Find all embeddings of a rule. Does not guarantee that rewriting
will succeed for all of them. *)
let find_matchings model rule_obj =
- Solver.M.evaluate model rule_obj.lhs_form_pp
+ Solver.M.evaluate model rule_obj.lhs_form
(* Convert assignment to an embedding of the LHS structure. *)
let assignment_to_embedding rule_obj asgn =
@@ -561,10 +560,10 @@
not (List.mem_assoc rel defined_rels)) signat in
let expand_def_rels rel =
if List.mem_assoc rel defined_rels then
- let args, _, rphi = List.assoc rel defined_rels in
+ let args, rphi = List.assoc rel defined_rels in
List.map fst (List.filter (fun (rel, ar) ->
let selector = Structure.free_for_rel rel ar in
- let res = Solver.M.check_formula selector rphi in
+ let res = Solver.M.check selector rphi in
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf "compile_rule.expand_def_rels: %s on %s = %b\n%!"
@@ -577,7 +576,7 @@
let expand_defrel_tups (drel, tups) =
if List.mem_assoc drel defined_rels
then
- let args, _, rphi = List.assoc drel defined_rels in
+ let args, rphi = List.assoc drel defined_rels in
let arg_tup = Array.of_list args in
map_some (fun (brel, ar) ->
let selector = Structure.free_for_rel brel ar in
@@ -586,7 +585,7 @@
(* {{{ log entry *)
if !debug_level > 3 && asgn<>AssignmentSet.Empty then (
Printf.printf "compile_rule.expand_defrel_tups: %s {%s} over\
- %s = %s\n%!" drel (Solver.M.formula_str rphi) (Structure.str selector)
+ %s = %s\n%!" drel (Formula.str rphi) (Structure.str selector)
(AssignmentSet.str asgn)
);
(* }}} *)
@@ -766,8 +765,6 @@
] in
(* Substitute defined relations, expanding their special variants. *)
- let defs = List.map (fun (rel, (args, body, _)) -> rel,(args,body))
- defined_rels in
let transform_new_rel = function
| Rel (rn, tup) when List.mem rn base_emb_rels ->
Rel ("_new_"^rn, tup)
@@ -779,12 +776,12 @@
let defined_new_rels =
List.map (fun (drel, (args,body)) ->
"_new_"^drel, (args, FormulaOps.map_to_atoms transform_new_rel body))
- defs in
+ defined_rels in
let defined_del_rels =
List.map (fun (drel, (args,body)) ->
"_del_"^drel, (args, FormulaOps.map_to_atoms transform_del_rel body))
- defs in
- let defs = defs @ defined_new_rels @ defined_del_rels in
+ defined_rels in
+ let defs = defined_rels @ defined_new_rels @ defined_del_rels in
let emb = FormulaOps.subst_rels defs emb in
(* RHS *)
@@ -854,10 +851,6 @@
Printf.printf "compile_rule: embedding formula = %s\n%!"
(Formula.sprint emb)
);
- (* }}} *)
- let lhs_form_pp =
- Solver.M.register_formula emb in
-(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "compile_rule: done.\n%!";
);
@@ -867,7 +860,6 @@
lhs_elem_inv_names = lhs_elem_inv_names;
lhs_elem_vars = lhs_elem_vars;
lhs_form = emb;
- lhs_form_pp = lhs_form_pp;
rhs_elem_names = rule_src.rhs_struc.Structure.names;
rhs_elem_vars = rhs_elem_vars;
rhs_pos_tuples = rhs_pos_tuples;
@@ -995,7 +987,7 @@
List.map (fun tup->Not (Rel (r,Array.map (fun v->`FO v) tup)))
tups)
obj.rhs_neg_tuples in
- Solver.M.formula_str obj.lhs_form_pp ^ "-> " ^
+ Formula.str obj.lhs_form ^ "-> " ^
Formula.str (And (plits @ nlits))
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/DiscreteRule.mli 2011-03-02 01:20:52 UTC (rev 1339)
@@ -31,7 +31,6 @@
lhs_elem_inv_names : elem_inv_names;
lhs_elem_vars : string list;
lhs_form : Formula.formula;
- lhs_form_pp : Solver.M.registered_formula;
(* gets instantiated in the model *)
(* the precondition [pre] is compiled as part of [lhs_form] *)
rhs_elem_names : elem_names;
@@ -106,8 +105,7 @@
in the RHS, it is still not removed by a rewrite. *)
val compile_rule :
(string * int) list ->
- (string *
- (string list * Formula.formula * Solver.M.registered_formula))
+ (string * (string list * Formula.formula))
list -> rule -> rule_obj
(** Relations that can explicitly change state by rewriting (i.e. not
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -583,8 +583,6 @@
let rhs_struc = struc_of_str "[ b | _opt_D (b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
@@ -599,8 +597,6 @@
let rhs_struc = struc_of_str "[ b | _opt_D (b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
@@ -615,8 +611,6 @@
let rhs_struc = struc_of_str "[ b | _opt_D (b); O(b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
@@ -631,8 +625,6 @@
let rhs_struc = struc_of_str "[ b | O(b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
@@ -652,8 +644,6 @@
let rhs_struc = struc_of_str "[ b | _opt_O (b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
@@ -668,8 +658,6 @@
let rhs_struc = struc_of_str "[ b | P (b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
@@ -684,8 +672,6 @@
let rhs_struc = struc_of_str "[ b | O(b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
let defrels = ["D", (["a"], formula_of_str "P(a) or Q(a)")] in
- let defrels = List.map (fun (rel,(args,body)) ->
- rel, (args, body, Solver.M.register_formula body)) defrels in
let rule_obj = compile_rule signat defrels
{lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/GGP/GDL.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -1707,15 +1707,14 @@
let optim_conjs = List.filter (fun c->
List.for_all (fun v->List.mem v lvars)
(FormulaOps.free_vars c)) (conjs_4b @ all_conjs) in
- let rphi = Solver.M.register_formula
- (Formula.And optim_conjs) in
+ let rphi = Formula.And optim_conjs in
(* {{{ log entry *)
if !debug_level > 4 then (
Printf.printf "evaluating: %s\n%!"
(Formula.str phi)
);
(* }}} *)
- if Solver.M.check_formula struc rphi
+ if Solver.M.check struc rphi
then (
(* {{{ log entry *)
if !debug_level > 4 then (
@@ -2783,8 +2782,7 @@
static_phis, phis)) cases in
let cases = Aux.map_some (
fun (var_elems,struc_elems,rhs_pos,static_phis,phis) ->
- let phi = Formula.And static_phis in
- let rphi = Solver.M.register_formula phi in
+ let rphi = Formula.And static_phis in
(* {{{ log entry *)
if !debug_level > 4 then (
(* do not print, because it generates too many
@@ -2793,16 +2791,16 @@
(*
let assgn = Solver.M.evaluate struc rphi in
let avars = List.map Formula.var_str
- (FormulaOps.free_vars phi) in
+ (FormulaOps.free_vars rphi) in
let atups =
AssignmentSet.tuples struc.Structure.elements
avars assgn in *)
Printf.printf "evaluating: %s\n%!"
- (Formula.str phi)
+ (Formula.str rphi)
(* (List.length atups) *)
);
(* }}} *)
- let res = Solver.M.check_formula struc rphi in
+ let res = Solver.M.check struc rphi in
(* {{{ log entry *)
if !debug_level > 4 && res then (
Printf.printf "holds\n%!"
@@ -2955,14 +2953,6 @@
let payoffs = Aux.array_from_assoc
(List.map (fun (player, payoff) -> find_player player, payoff)
payoffs) in
- let payoffs_pp =
- Array.map (fun pay ->
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "Registering payoff %s...\n%!" (Formula.real_str pay)
- );
- (* }}} *)
- Solver.M.register_real_expr pay) payoffs in
let tossrule_data = ref Aux.StrMap.empty in
let fluents = Aux.concat_map snd dyn_rels in
(* {{{ log entry *)
@@ -3047,7 +3037,6 @@
Arena.id = loc;
player = find_player loc_players.(loc);
payoffs = payoffs;
- payoffs_pp = payoffs_pp;
moves = labels} in
rules, location
) loc_toss_rules in
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Play/Game.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -503,7 +503,7 @@
let subloc = evgame.ev_game.Arena.graph.(evgame.ev_location) in
if subloc.Arena.moves = [] then (* optimization *)
Array.map (fun expr ->
- Solver.M.get_real_val expr model) subloc.Arena.payoffs_pp
+ Solver.M.get_real_val expr model) subloc.Arena.payoffs
else
let state =
{game_state={Arena.cur_loc=evgame.ev_location; struc=model; time=time};
@@ -548,7 +548,7 @@
let payoff =
Array.map (fun expr ->
Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs_pp in
+ loc.Arena.payoffs in
Aux.Right payoff
else
let agent = agents.(loc.Arena.player) in
@@ -578,7 +578,7 @@
let payoff =
Array.map (fun expr ->
Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs_pp in
+ loc.Arena.payoffs in
Aux.Right payoff
| Some state ->
(* [pos] refers to unfiltered array! use only to extract
@@ -645,7 +645,7 @@
Array.map (fun expr ->
100000. *.
Solver.M.get_real_val expr model)
- location.Arena.payoffs_pp (* see [let payoff] above *)
+ location.Arena.payoffs (* see [let payoff] above *)
(* *
play_evgame grid_size model time subgames.(loc)
* *)
@@ -671,7 +671,7 @@
Array.map (fun expr ->
100000. *.
Solver.M.get_real_val expr model)
- location.Arena.payoffs_pp
+ location.Arena.payoffs
(* *
play_evgame grid_size model time subgames.(loc)
* *)
@@ -747,7 +747,7 @@
let payoff =
Array.map (fun expr ->
Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs_pp in
+ loc.Arena.payoffs in
Aux.Right payoff
else
let cur_depth = ref 0 in
@@ -894,7 +894,7 @@
let payoff =
Array.map (fun expr ->
Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs_pp in
+ loc.Arena.payoffs in
Aux.Right payoff
else
let descriptions =
@@ -1039,7 +1039,7 @@
let payoff =
Array.map (fun expr ->
Solver.M.get_real_val expr state.Arena.struc)
- location.Arena.payoffs_pp in
+ location.Arena.payoffs in
let upscore = score_payoff payoff in
upscore, Terminal (state, upscore, heuristic, payoff)
@@ -1050,7 +1050,7 @@
let payoff =
Array.map (fun expr ->
Solver.M.get_real_val expr state.Arena.struc)
- location.Arena.payoffs_pp in
+ location.Arena.payoffs in
let upscore = score_payoff payoff in
upscore, Terminal (state, upscore, heuristic, payoff)
else
@@ -1102,7 +1102,7 @@
node_subtrees=subtrees; node_bestheur=bestheur;
})
-let evgame_of_heuristic heuristics heuristics_pp game =
+let evgame_of_heuristic heuristics game =
let evgame gloc =
{ev_game =
{Arena.rules = [];
@@ -1112,7 +1112,7 @@
graph = [|
{Arena.id=0; player=gloc.Arena.player;
payoffs=heuristics.(gloc.Arena.id);
- payoffs_pp=heuristics_pp.(gloc.Arena.id); moves=[]} |];
+ moves=[]} |];
num_players = game.Arena.num_players};
ev_agents = [| |]; ev_delta = 0.0; ev_location = 0;
ev_horizon = Some 0; ev_memory = [| |]} in
@@ -1130,10 +1130,8 @@
let heuristics = match heuristic with Some h -> h
| None ->
default_heuristic ~struc ?advr game in
- let heuristics_pp =
- Array.map (Array.map Solver.M.register_real_expr) heuristics in
let heur_evgame =
- evgame_of_heuristic heuristics heuristics_pp game in
+ evgame_of_heuristic heuristics game in
let playout_agents =
if not (random_playout || heur_effect = Heuristic_only) then
Array.map (fun _ ->
@@ -1153,10 +1151,8 @@
let heuristics = match heuristic with Some h -> h
| None ->
default_heuristic ~struc ?advr game in
- let heuristics_pp =
- Array.map (Array.map Solver.M.register_real_expr) heuristics in
let heur_evgame =
- evgame_of_heuristic heuristics heuristics_pp game in
+ evgame_of_heuristic heuristics game in
Maximax_evgame (heur_evgame, false, depth, pruning)
let initialize_default state ?loc ?effort
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Play/GameTest.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -346,7 +346,7 @@
(Aux.Right [| -1.0; 1.0 |]) move_opt;
let payoffs = Array.to_list
(Array.mapi (fun i v->string_of_int i,v)
- (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs_pp)
+ (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs)
in
let ev (p,e) =
p^": "^(string_of_float
@@ -384,7 +384,7 @@
let payoffs = Array.to_list
(Array.mapi (fun i v->string_of_int i,v)
- (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs_pp)
+ (fst state).Arena.graph.((snd state).Arena.cur_loc).Arena.payoffs)
in
let ev (p,e) =
p^": "^(string_of_float
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Play/GameTree.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -124,8 +124,7 @@
(* 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
+ let calc re = Solver.M.get_real_val re state.Arena.struc in
let res =
{ heurs = Array.map calc heurs.(state.Arena.cur_loc);
info = f depth game state } in
@@ -139,7 +138,7 @@
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
+ Array.map calc game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs in
{ payoffs = payoffs; heurs_t = leaf_info.heurs ; info_t = f depth game state }
let info_node_f f depth game state player children =
@@ -198,7 +197,10 @@
(* Maximax unfolding upto depth. *)
let rec unfold_maximax_upto count game heur t =
- if count = 0 || Game.get_timeout () then t else
+ if count = 0 || Game.get_timeout () then (
+ if !debug_level > 1 && Game.get_timeout () then print_endline "Timeout";
+ t
+ ) else
try
let u = unfold_maximax game heur t in
if !debug_level > 0 then Printf.printf "%d,%!" (size u);
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Play/Heuristic.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -348,7 +348,6 @@
let expanded_descr max_alt_descr elems rels struc
all_vars xvars xsubsts =
- let solver = Solver.new_solver () in
let alt_descr = ref 0 in
let max_arity =
find_max (-) (List.map (fun (_,tups) ->
@@ -485,10 +484,7 @@
flush stdout) in
let new_substs = map_some (fun atom ->
(* g *)
- let assgns =
- Solver.evaluate_partial_aset solver
- ~formula:(Solver.register_formula solver atom)
- struc path_assgns in
+ let assgns = Solver.M.evaluate_partial struc path_assgns atom in
let _ = if !debug_level > 3 then (printf "yxvars=%s\n"
(String.concat ", "(List.map var_str yxvars)); flush stdout) in
let substs = AssignmentSet.fo_assgn_to_list elems yxvars assgns in
@@ -600,8 +596,7 @@
List.map Formula.to_fo (FormulaOps.free_vars phi) in
if vars = [] then Or []
else
- let aset = Solver.M.evaluate struc
- (Solver.M.register_formula phi) in
+ let aset = Solver.M.evaluate struc phi in
let substs =
AssignmentSet.fo_assgn_to_list elems vars aset in
(* sort substitutions; TODO: optimizable *)
@@ -651,8 +646,7 @@
(* }}} *)
let substs =
AssignmentSet.fo_assgn_to_list elems vars
- (Solver.M.evaluate struc
- (Solver.M.register_formula phi)) in
+ (Solver.M.evaluate struc phi) in
(* sort substitutions; TODO: optimizable *)
let substs = trunc_to_vars vars substs in
let all_vars = add_strings (List.map var_str vars) all_vars in
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Server/Server.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -30,7 +30,10 @@
let g_heur = ref None
let no_gtree = ref true
+let exp_p1_timeout = ref 9000
+let exp_p2_timeout = ref 9000
+
(* -------------------- GENERAL SERVER AND REQUEST HANDLER ------------------ *)
exception Host_not_found
@@ -485,25 +488,29 @@
let pl =game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.player in
let depth = if pl = 0 then depth1 else if pl = 1 then depth2 else
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
if depth < 12 then (
+ ignore (Unix.alarm timeo);
match Game.suggest ~effort:depth play (init_pl !cur_state) with
- | None -> Game.set_debug_level 0; failwith "no suggestion"
+ | None ->
+ Game.cancel_timeout ();
+ failwith "no suggestion"
| Some (mv, _) ->
- Game.set_debug_level 0;
+ Game.cancel_timeout ();
let (_, new_state) = Move.make_move mv (game, !cur_state) in
cur_state := new_state;
) else (
let heur = if pl = 0 then heur1 else heur2 in
- GameTree.set_debug_level 1;
+ ignore (Unix.alarm timeo);
let (_, s) = GameTree.maximax_unfold_choose depth game !cur_state heur in
- GameTree.set_debug_level 0;
+ Game.cancel_timeout();
cur_state := s
);
print_endline ("State: " ^ (Structure.str !cur_state.Arena.struc));
print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter));
Solver.eval_counter := 0;
done;
- let payoffs = game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.payoffs_pp in
+ let payoffs = game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.payoffs in
Array.map (fun p -> Solver.M.get_real_val p (!cur_state).Arena.struc) payoffs
;;
@@ -577,6 +584,8 @@
"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");
+ ("-eto1", Arg.Int (fun i -> exp_p1_timeout := i), "p1 timeout for exper");
+ ("-eto2", Arg.Int (fun i -> exp_p2_timeout := i), "p1 timeout for exper");
("-gtree", Arg.Unit (fun () -> no_gtree := false), "use GameTree module");
("-experiment",
Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i);
Modified: trunk/Toss/Solver/Class.ml
===================================================================
--- trunk/Toss/Solver/Class.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/Class.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -64,10 +64,8 @@
- each exists X (phi) by exists "A:c:X" "B:d:X" (phi), x in X-> x in X1 or X2
- dually the forall quantifiers
- each resulting atom, say R(A:c:x, B:d:y), as given in WITH reldefs. *)
-let split solver phi = function
- Struct s ->
- let phi_i = Solver.register_formula solver phi in
- if Solver.check solver phi_i s then And [] else Or []
+let split phi = function
+ | Struct s -> if Solver.M.check s phi then And [] else Or []
| Sum (ids_l, rels_l) ->
let prefixes s = List.map (fun (i, _) -> s ^ ":" ^ i) ids_l in
let replace_in s = function
@@ -199,27 +197,25 @@
(* Split formula and perform first simplification steps. *)
-let split_simplify solver ?(get_ids=false) phi = function
- Struct s ->
- let phi_i = Solver.register_formula solver phi in
- if Solver.check solver phi_i s then And [] else Or []
+let split_simplify ?(get_ids=false) phi = function
+ | Struct s -> if Solver.M.check s phi then And [] else Or []
| Sum (ids_l, rels_r) as cdef ->
- let split_phi = split solver phi cdef in
+ let split_phi = split phi cdef in
let (summand_ids, _) = List.split ids_l in
flatten_sort (map_to_atoms (simplify_atom summand_ids) split_phi)
(* Compute a decomposition of a formula on a given class definition. *)
-let decompose solver ?(get_ids=false) phi_in = function
+let decompose ?(get_ids=false) phi_in = function
Struct s as cdef ->
if !debug_level > 0 then print_endline ("Deciding " ^ (Formula.str phi_in) ^ " on struct");
- [[("", split solver phi_in cdef)]]
+ [[("", split phi_in cdef)]]
| Sum (ids_l, rels_r) as cdef ->
let phi = class_tnf (simplify phi_in) in
if !debug_level > 0 then
print_endline ("Decomposing " ^ (Formula.str phi) ^ " on " ^ (struct_sum_str cdef));
let phi_fv = free_vars phi in
- let split_phi = split solver (Ex (phi_fv, phi)) cdef in
+ let split_phi = split (Ex (phi_fv, phi)) cdef in
let (summand_ids, _) = List.split ids_l in
let simp_split_phi = map_to_atoms (simplify_atom summand_ids) split_phi in
match List.rev_map simplify (to_dnf (class_tnf (simplify (simp_split_phi)))) with
@@ -256,7 +252,7 @@
List.sort (fun x y -> (lsize x) - (lsize y)) x
(* Model-checking function. *)
-let rec check_raw solver mem cid cls in_psi =
+let rec check_raw mem cid cls in_psi =
let rec check_r = function
And [f] | Or [f] -> check_r f
| Or (flist) -> List.exists check_r flist
@@ -268,7 +264,7 @@
if !debug_level > 1 then
print_endline (" CHECK EX: " ^ (Formula.str (Ex ([v], phi))));
if is_fo v then (
- let res = fo_game solver mem [] cid cls v phi in
+ let res = fo_game mem [] cid cls v phi in
if !debug_level > 1 then
print_endline (" CHECK EX: " ^ (Formula.str (Ex ([v], phi))) ^
" is " ^ (if res then "true" else "false") ^
@@ -276,7 +272,7 @@
res
)
else if is_mso v then (
- let res = wmso_game solver mem [] cid cls (var_str v) phi in
+ let res = wmso_game mem [] cid cls (var_str v) phi in
if !debug_level > 1 then
print_endline (" CHECK EX: " ^ (Formula.str (Ex ([v], phi))) ^
" is " ^ (if res then "true" else "false") ^
@@ -294,54 +290,54 @@
": " ^ (Formula.str psi));
res
-and fo_game sv mem hist cid cls v phi_in =
+and fo_game mem hist cid cls v phi_in =
let (fmem, _) = mem in
- let phi = unsentence sv mem cid cls (class_tnf (simplify phi_in)) in
+ let phi = unsentence mem cid cls (class_tnf (simplify phi_in)) in
try List.assoc (cid, phi) !fmem with Not_found ->
if phi = Or [] || List.mem (phi, cid) hist then false else (
if !debug_level > 0 then print_endline (" FO game: " ^ (Formula.str phi));
let play_on (ci, psi) = (* If v still there, play game, else qr--, check *)
if List.mem v (free_vars psi) then
- fo_game sv mem ((phi, cid) :: hist) ci cls v psi
- else check_raw sv mem ci cls psi in
+ fo_game mem ((phi, cid) :: hist) ci cls v psi
+ else check_raw mem ci cls psi in
if cid = "" then
if phi = And [] then true else if phi = Or [] then false else
failwith "empty class id but non-trivial formula (fo)"
else
let struc_eq = List.hd (List.assoc cid cls) in (* Only SINGLE structures*)
- let decomp = decompose sv phi struc_eq in
+ let decomp = decompose phi struc_eq in
let res = List.exists (List.for_all play_on) (g_sort cls decomp) in
fmem := ((cid, phi), res) :: !fmem;
res
)
-and wmso_game sv mem hist cid cls v_str phi_in =
+and wmso_game mem hist cid cls v_str phi_in =
let (_, wmem) = mem in
- let phi = unsentence sv mem cid cls (class_tnf (simplify phi_in)) in
+ let phi = unsentence mem cid cls (class_tnf (simplify phi_in)) in
try List.assoc (cid, phi) !wmem with Not_found ->
if phi = Or [] || List.mem (phi, cid) hist then false else (
if !debug_level > 0 then print_endline (" WMSO game: "^ (Formula.str phi));
- if check_raw sv mem cid cls (assign_emptyset v_str phi) then true else
+ if check_raw mem cid cls (assign_emptyset v_str phi) then true else
if cid = "" then
if phi = And [] then true else if phi = Or [] then false else
failwith "empty class id but non-trivial formula (wmso)"
else
- let play_on (ci,psi)= wmso_game sv mem ((phi, cid) :: hist) ci cls v_str psi in
+ let play_on (ci,psi)= wmso_game mem ((phi, cid) :: hist) ci cls v_str psi in
let struc_eq = List.hd (List.assoc cid cls) in (*Only SINGLE structs*)
- let decomp = decompose sv phi struc_eq in
+ let decomp = decompose phi struc_eq in
let res = List.exists (List.for_all play_on) (g_sort cls decomp) in
wmem := ((cid, phi), res) :: !wmem;
res
)
-and unsentence sv mem cid cls = function
- Or [f] -> unsentence sv mem cid cls f
+and unsentence mem cid cls = function
+ Or [f] -> unsentence mem cid cls f
| And fl ->
let (sentences, other) = List.partition (fun f -> free_vars f = []) fl in
- if List.for_all (check_raw sv mem cid cls) sentences then
+ if List.for_all (check_raw mem cid cls) sentences then
And other
else Or []
| f -> f
-let check solver cid cls in_psi =
- check_raw solver (ref [], ref []) cid cls in_psi
+let check cid cls in_psi =
+ check_raw (ref [], ref []) cid cls in_psi
Modified: trunk/Toss/Solver/Class.mli
===================================================================
--- trunk/Toss/Solver/Class.mli 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/Class.mli 2011-03-02 01:20:52 UTC (rev 1339)
@@ -37,11 +37,11 @@
- each exists X (phi) by exists "A:c:X" "B:d:X" (phi), x in X-> x in X1 or X2
- dually the forall quantifiers
- each resulting atom, say R(A:c:x, B:d:y), as given in WITH reldefs. *)
-val split : Solver.solver -> Formula.formula -> struct_sum -> Formula.formula
+val split : Formula.formula -> struct_sum -> Formula.formula
(** Split the formula as above and simplify by replacing trivially true
or false atoms such as L(x:R) ... *)
-val split_simplify : Solver.solver -> ?get_ids : bool ->
+val split_simplify : ?get_ids : bool ->
Formula.formula -> struct_sum -> Formula.formula
@@ -49,12 +49,11 @@
(** Compute a decomposition of a formula on a given class definition. *)
-val decompose : Solver.solver -> ?get_ids : bool ->
+val decompose : ?get_ids : bool ->
Formula.formula -> struct_sum -> (string * Formula.formula) list list
(** {2 WMSO model checking on inductive structures} *)
-val check : Solver.solver -> string -> structure_class ->
- Formula.formula -> bool
+val check : string -> structure_class -> Formula.formula -> bool
Modified: trunk/Toss/Solver/ClassTest.ml
===================================================================
--- trunk/Toss/Solver/ClassTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/ClassTest.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -94,13 +94,13 @@
let test_split phi_s cs =
let f = formula_of_string phi_s in
- let split_f s = Class.split (Solver.new_solver ()) f s in
+ let split_f s = Class.split f s in
test_sum ("Split of " ^ phi_s) split_f Formula.str cs
;;
let test_split_simplify phi_s cs =
let f = formula_of_string phi_s in
- let split_f s = Class.split_simplify (Solver.new_solver ()) f s in
+ let split_f s = Class.split_simplify f s in
test_sum ("Simplified Split of " ^ phi_s) split_f Formula.str cs
;;
@@ -131,7 +131,7 @@
let test_decompose ids phi_s cs =
let f = formula_of_string phi_s in
- let decompose_f s = Class.decompose ~get_ids:ids (Solver.new_solver ()) f s in
+ let decompose_f s = Class.decompose ~get_ids:ids f s in
let decomp_lit_str (cid, phi) = "some " ^ cid ^ " |= " ^ (Formula.str phi) in
let decomp_tuple_str cj =
"(" ^ String.concat " and " (List.map decomp_lit_str cj) ^ ")" in
@@ -184,7 +184,7 @@
let test_check phi_s id cs =
let (f, c) = (formula_of_string phi_s, class_of_string cs) in
print_endline ("Checking " ^ (Formula.str f) ^ " on " ^ id);
- print_endline (string_of_bool (Class.check (Solver.new_solver()) id c f));
+ print_endline (string_of_bool (Class.check id c f));
print_endline "";
;;
Modified: trunk/Toss/Solver/PresbTest.ml
===================================================================
--- trunk/Toss/Solver/PresbTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/PresbTest.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -81,7 +81,7 @@
let test_check phi_s id cs =
let (f, c) = (formula_of_string phi_s, class_of_string cs) in
print_endline ("Checking " ^ (Formula.str f) ^ " on " ^ id);
- print_endline (string_of_bool (Class.check (Solver.new_solver()) id c f));
+ print_endline (string_of_bool (Class.check id c f));
print_endline "";
;;
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/Solver.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -57,7 +57,7 @@
Hashtbl.add solver.formulas_check id (check_form psi);
(psi, id)
-let register_formula solver phi =
+let register_formula_s solver phi =
try
let res = Hashtbl.find solver.reg_formulas phi in
if !debug_level > 0 then print_endline ("DirectFound " ^ (str phi));
@@ -223,7 +223,16 @@
FO (v, List.rev asg_list) in
process_vars [] (List.sort Formula.compare_vars (fo_vars_real p))
+let eval_counter = ref 0
+(* Evaluate with assignment, no cache. *)
+let evaluate_partial_aset solver ~formula struc fo_aset =
+ let elems =
+ ref (Set (Elems.cardinal struc.elements, struc.elements)) in
+ let phi = Hashtbl.find solver.formulas_eval formula in
+ incr eval_counter;
+ eval struc elems fo_aset phi
+
(* Helper: find assoc and remove. *)
let rec assoc_del (x : Formula.formula) = function
| [] -> raise Not_found
@@ -232,8 +241,6 @@
let (b, nl) = assoc_del x l in
(b, pair :: nl)
-let eval_counter = ref 0
-
let diffrels_struc s1 s2 =
if Structure.equal { s1 with relations = StringMap.empty; }
{ s2 with relations = StringMap.empty; } then
@@ -441,7 +448,6 @@
Hashtbl.add !re_cache_results re (re_val, re_rels re);
re_val
-
(* Evaluate i-th formula on j-th structure. *)
let evaluate solver ~formula struc =
let phi = Hashtbl.find solver.formulas_eval formula in
@@ -458,37 +464,23 @@
if !debug_level > 1 then print_endline ("Check " ^ (str phi)) else ();
check_formula phi
-let evaluate_partial_aset solver ~formula struc fo_aset = (* not memoized *)
- let elems =
- ref (Set (Elems.cardinal struc.elements, struc.elements)) in
- let phi = Hashtbl.find solver.formulas_eval formula in
- incr eval_counter;
- eval struc elems fo_aset phi
(* Interface to {!SolverIntf}. *)
module M = struct
- type registered_formula = int
- type registered_real_expr = Formula.real_expr
let solver = new_solver ()
- let register_formula phi =
- register_formula solver phi
- let register_real_expr expr = expr (* TODO? *)
- let evaluate struc formula = evaluate solver ~formula struc
- let evaluate_partial struc intpr formula = (* not memoized *)
- let make_fo_asg asg (v, e) = FO (v, [(e, asg)]) in
- let fo_aset = List.fold_left make_fo_asg Any intpr in
- let elems =
- ref (Set (Elems.cardinal struc.elements, struc.elements)) in
- let phi = Hashtbl.find solver.formulas_eval formula in
- incr eval_counter;
- eval struc elems fo_aset phi
+ let evaluate struc phi =
+ evaluate solver ~formula:(register_formula_s solver phi) struc
+ let evaluate_real = evaluate_real
+ let evaluate_partial struc intpr phi =
+ evaluate_partial_aset solver ~formula:(register_formula_s solver phi)
+ struc intpr
- let check_formula struc formula =
- check solver ~formula struc
+ let check struc phi =
+ check solver ~formula:(register_formula_s solver phi) struc
let get_real_val re struc = get_real_val_cache solver struc re
let formula_str phi =
- let phi = Hashtbl.find solver.formulas_check phi in
+ (* let phi = Hashtbl.find solver.formulas_check phi in *)
Formula.str phi
let real_str expr =
Formula.real_str expr
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/Solver.mli 2011-03-02 01:20:52 UTC (rev 1339)
@@ -1,68 +1,40 @@
(** Solver for checking if formulas hold on structures. *)
-type solver
+(** {1 Interface} *)
-val new_solver : unit -> solver
-val register_formula : solver -> Formula.formula -> int
-val get_formula : solver -> int -> Formula.formula
-(** {2 Evaluation} *)
+(** Interface to the solver. *)
+module M : sig
+ (** Check the formula on the structure. *)
+ val check : Structure.structure -> Formula.formula -> bool
-type cachetbl =
- (Formula.formula, Assignments.assignment_set * string list option) Hashtbl.t
+ (** Evaluate the formula on the structure. *)
+ val evaluate : Structure.structure ->
+ Formula.formula -> AssignmentSet.assignment_set
-val eval_counter : int ref
-val get_cache : unit -> Structure.structure * cachetbl
-val set_cache : Structure.structure * cachetbl -> unit
+ (** Evaluate the formula on the structure and join with given assignment. *)
+ val evaluate_partial : Structure.structure -> AssignmentSet.assignment_set ->
+ Formula.formula -> AssignmentSet.assignment_set
-(** Evaluate i-th formula on j-th structure. *)
-val evaluate : solver -> formula:int -> Structure.structure ->
- Assignments.assignment_set
+ (** Evaluate real expressions. Result is represented as assignments with
+ real-valued polynomials using variable [rvar] to represent [expr].
+ We assume that [rvar] does not occur in [expr]. *)
+ val evaluate_real : string -> Formula.real_expr -> Structure.structure ->
+ Assignments.assignment_set
-(** Check if i-th formula holds on j-th structure. *)
-val check : solver -> formula:int -> Structure.structure -> bool
+ (** Get the value of a real expression without free variables. *)
+ val get_real_val : Formula.real_expr -> Structure.structure -> float
+end
-(** Evaluate real expressions. Result is represented as assignments with
- real-valued polynomials using variable [rvar] to represent [expr].
- We assume that [rvar] does not occur in [expr]. *)
-val evaluate_real : string -> Formula.real_expr -> Structure.structure ->
- Assignments.assignment_set
-(** Fast function to get a value of a real expression without free variables. *)
-val get_real_val : solver -> Assignments.assignment_set ->
- Formula.real_expr -> Structure.structure -> float
-
-(** Evaluate a formula and intersect its assignments with the given set. *)
-val evaluate_partial_aset :
- solver -> formula:int -> Structure.structure ->
- AssignmentSet.assignment_set ->
- AssignmentSet.assignment_set
-
-
(** {2 Debugging} *)
-
(** Debugging information. At level 0 nothing is printed out. *)
val set_debug_level : int -> unit
-(** Interface to {!SolverIntf}. *)
-module M : sig
- type registered_formula
- type registered_real_expr
- val register_formula :
- Formula.formula -> registered_formula
- val register_real_expr :
- Formula.real_expr -> registered_real_expr
- val evaluate : Structure.structure ->
- registered_formula -> AssignmentSet.assignment_set
- val evaluate_partial :
- Structure.structure -> (Formula.fo_var * int) list ->
- registered_formula -> AssignmentSet.assignment_set
- val check_formula : Structure.structure ->
- registered_formula -> bool
- val get_real_val : registered_real_expr -> Structure.structure -> float
- val formula_str : registered_formula -> string
- val real_str : registered_real_expr -> string
-end
+(** Counter of internal formula evaluations for profiling. *)
+val eval_counter : int ref
+
+
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
+++ trunk/Toss/Solver/SolverTest.ml 2011-03-02 01:20:52 UTC (rev 1339)
@@ -1,4 +1,4 @@
-open Solver ;;
+open Solver.M ;;
open OUnit ;;
Solver.set_debug_level 0 ;;
@@ -22,9 +22,8 @@
let res = ref "" in
backtrace (
let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in
- let solver = new_solver () in
- let f = register_formula solver phi in
- res := AssignmentSet.str (evaluate solver f struc);
+ (* let solver = new_solver () in *)
+ res := AssignmentSet.str (evaluate struc phi);
);
assert_equal ~printer:(fun x -> x) aset_s !res
;;
@@ -38,7 +37,7 @@
let real_val_eq struc_s expr_s x =
let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in
assert_equal ~printer:(fun x -> string_of_float x)
- x (get_real_val (new_solver ()) AssignmentSet.Any expr struc)
+ x (get_real_val expr struc)
;;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-01 02:15:14
|
Revision: 1338
http://toss.svn.sourceforge.net/toss/?rev=1338&view=rev
Author: lukaszkaiser
Date: 2011-03-01 02:15:08 +0000 (Tue, 01 Mar 2011)
Log Message:
-----------
Correcting FormulaOps.tnf_fv bug found during GDL translation, real_expr cache in Solver.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Server/ServerTest.ml
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-02-28 22:04:19 UTC (rev 1337)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-03-01 02:15:08 UTC (rev 1338)
@@ -147,6 +147,9 @@
let map_to_atoms_full f g phi =
map_to_literals (function Not (x) -> Not (f x) | x -> f x) g phi
+let map_to_atoms_full_re f g re =
+ map_to_literals_expr (function Not (x) -> Not (f x) | x -> f x) g re
+
let map_to_atoms f phi =
map_to_literals (function Not (x) -> Not (f x) | x -> f x) (fun x -> x) phi
@@ -919,27 +922,30 @@
| [] -> []
| [f] -> [order_by_fv_phi acc_fv f]
| l ->
- let cross x = List.exists (fun v -> List.mem v acc_fv) (free_vars x) in
+ let cross x =
+ let fv = free_vars x in
+ fv = [] || List.exists (fun v -> List.mem v acc_fv) fv in
let (cf, o) = List.partition cross l in
- if cf = [] then
+ if cf = [] then (
let new_fv = free_vars (List.hd l) in
order_by_fv new_fv l
- else
+ ) else (
let new_fv = acc_fv @ (free_vars_fo (And cf)) in
(List.map (order_by_fv_phi acc_fv) cf) @ (order_by_fv new_fv o)
+ )
and order_by_fv_phi acc_fv = function
| And fl ->
let is_pred = function Rel (_, [|_|]) -> true | _ -> false in
let (p, np) = List.partition is_pred fl in
let res = And (order_by_fv acc_fv (p @ np)) in
- if !debug_level > 0 then print_endline ("fvordered and: " ^ (str res));
+ if !debug_level > 1 then print_endline ("fvordered and: " ^ (str res));
res
| Or fl ->
let is_pred = function Rel (_, [|_|]) -> true | _ -> false in
let (p, np) = List.partition is_pred fl in
let res = Or (order_by_fv acc_fv (p @ np)) in
- if !debug_level > 0 then print_endline ("fvordered or: " ^ (str res));
+ if !debug_level > 1 then print_endline ("fvordered or: " ^ (str res));
res
| Ex (vs, phi) -> Ex (vs, order_by_fv_phi acc_fv phi)
| All (vs, phi) -> All (vs, order_by_fv_phi acc_fv phi)
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-02-28 22:04:19 UTC (rev 1337)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-03-01 02:15:08 UTC (rev 1338)
@@ -29,6 +29,8 @@
(** Map [f] to all atoms in the given formula. *)
val map_to_atoms_full : (formula -> formula) -> (real_expr -> real_expr) ->
formula -> formula
+val map_to_atoms_full_re : (formula -> formula) -> (real_expr -> real_expr) ->
+ real_expr -> real_expr
val map_to_atoms : (formula -> formula) -> formula -> formula
val map_to_atoms_expr : (formula -> formula) -> real_expr -> real_expr
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-02-28 22:04:19 UTC (rev 1337)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
@@ -114,6 +114,20 @@
((not P(x) and not Q(x)) <-> RT(p, r)) )";
);
+ "tnf fv" >::
+ (fun () ->
+ let tnffv_eq phi1 phi2 = formula_eq id phi2 FormulaOps.tnf_fv phi1 in
+ tnffv_eq "P(x) and (P(x) or Q(x))" "P(x)";
+ tnffv_eq ("ex x_3_3, x_2_2, x_1_1 (" ^
+ "(R_1_Y_MV1(x_1_1) and R_2_Y_MV1(x_2_2) and R_3_Y_MV1(x_3_3) " ^
+ "and R_X_1_MV1(x_1_1) and R_X_2_MV1(x_2_2) and R_X_3_MV1(x_3_3) " ^
+ "and R_X_Y_XP(x_1_1) and R_X_Y_XP(x_2_2) and R_X_Y_XP(x_3_3)))")
+ ("ex x_1_1 ((R_1_Y_MV1(x_1_1) and R_X_1_MV1(x_1_1) and " ^
+ "R_X_Y_XP(x_1_1))) and ex x_2_2 ((R_2_Y_MV1(x_2_2) and " ^
+ "R_X_2_MV1(x_2_2) and R_X_Y_XP(x_2_2))) and ex x_3_3 (" ^
+ "(R_3_Y_MV1(x_3_3) and R_X_3_MV1(x_3_3) and R_X_Y_XP(x_3_3)))")
+ );
+
"subst free and all" >::
(fun () ->
let subst phi = FormulaOps.subst_vars [("x", "a"); ("y", "b")] phi in
Modified: trunk/Toss/Server/ServerTest.ml
===================================================================
--- trunk/Toss/Server/ServerTest.ml 2011-02-28 22:04:19 UTC (rev 1337)
+++ trunk/Toss/Server/ServerTest.ml 2011-03-01 02:15:08 UTC (rev 1338)
@@ -47,7 +47,8 @@
"ServerGDLTest.in GDL Tic-Tac-Toe automatic" >::
(fun () ->
- todo "real soon now...";
+ (* todo "real soon now..."; *)
+ (* Solver.set_debug_level 2; *)
let old_det_suggest = !Game.deterministic_suggest in
Game.deterministic_suggest := true;
let old_translation = !GDL.manual_translation in
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-02-28 22:04:19 UTC (rev 1337)
+++ trunk/Toss/Solver/Solver.ml 2011-03-01 02:15:08 UTC (rev 1338)
@@ -15,6 +15,7 @@
let cache_struc = ref (empty_structure ())
let cache_results = ref (Hashtbl.create 15)
+let re_cache_results = ref (Hashtbl.create 15)
let get_cache () = (!cache_struc, Hashtbl.copy !cache_results)
let set_cache (struc, res) = cache_struc := struc; cache_results := res
@@ -47,8 +48,8 @@
if !debug_level > 0 then print_endline ("Found " ^ (str phi));
(Hashtbl.find solver.formulas_eval res, res)
with Not_found ->
+ if !debug_level > 0 then print_endline ("Entered " ^ (str phi));
let psi = FormulaOps.tnf_fv phi in
- if !debug_level > 0 then print_endline ("Entered " ^ (str phi));
if !debug_level > 0 then print_endline ("Registering " ^ (str psi));
let id = Hashtbl.length solver.formulas_eval + 1 in
Hashtbl.add solver.reg_formulas phi id;
@@ -263,26 +264,50 @@
Some rs
with Not_found -> None
+let re_rels re =
+ let rels = ref [] in
+ let app_rel = function Rel (s, _) as r -> rels := s :: !rels; r | x -> x in
+ let app_re = function Fun _ -> raise Not_found | x -> x in
+ try
+ let _ = FormulaOps.map_to_atoms_full_re app_rel app_re re in
+ let rs = Aux.unique_sorted !rels in
+ if !debug_level > 1 then
+ print_endline ("FR: " ^ (Formula.real_str re) ^ " " ^
+ (String.concat ", " rs));
+ Some rs
+ with Not_found -> None
+
+
+let update_cache struc =
+ if not (Structure.equal !cache_struc struc) then
+ match diffrels_struc struc !cache_struc with
+ | None ->
+ cache_struc := struc;
+ Hashtbl.clear !cache_results;
+ Hashtbl.clear !re_cache_results;
+ | Some rs ->
+ cache_struc := struc;
+ let is_bad (_, prs_opt) =
+ match prs_opt with
+ | None -> true
+ | Some prs -> List.exists (fun r -> List.mem r rs) prs in
+ let ok = ref [] in
+ Hashtbl.iter (fun p r -> if is_bad r then () else ok := (p, r)::!ok)
+ !cache_results;
+ Hashtbl.clear !cache_results;
+ List.iter (fun (p, r) -> Hashtbl.add !cache_results p r) !ok;
+ let ok_re = ref [] in
+ Hashtbl.iter
+ (fun p r -> if is_bad r then () else ok_re := (p, r)::!ok_re)
+ !re_cache_results;
+ Hashtbl.clear !re_cache_results;
+ List.iter (fun (p, r) -> Hashtbl.add !re_cache_results p r) !ok_re
+
+
(* Eval with very basic caching. *)
let eval_m struc phi =
if phi = And [] then Any else (
- if not (Structure.equal !cache_struc struc) then (
- match diffrels_struc struc !cache_struc with
- | None ->
- cache_struc := struc;
- Hashtbl.clear !cache_results;
- | Some rs ->
- cache_struc := struc;
- let is_bad (_, prs_opt) =
- match prs_opt with
- | None -> true
- | Some prs -> List.exists (fun r -> List.mem r rs) prs in
- let ok = ref [] in
- Hashtbl.iter (fun p r -> if is_bad r then () else ok := (p, r)::!ok)
- !cache_results;
- Hashtbl.clear !cache_results;
- List.iter (fun (p, r) -> Hashtbl.add !cache_results p r) !ok
- );
+ update_cache struc;
try
let (res, _) = Hashtbl.find !cache_results phi in
if !debug_level > 1 then (
@@ -396,7 +421,27 @@
AssignmentSet.str ev_assgn) in
get_rval (join asg (evaluate_real "#" expr struc))
+let rec get_real_val_cache solver struc = function
+ | Const c -> c
+ | Plus (e1, e2) ->
+ (get_real_val_cache solver struc e1) +. (get_real_val_cache solver struc e2)
+ | Times (e1, e2) ->
+ (get_real_val_cache solver struc e1) *. (get_real_val_cache solver struc e2)
+ | re ->
+ update_cache struc;
+ try
+ let (res, _) = Hashtbl.find !re_cache_results re in
+ if !debug_level > 1 then (
+ print_endline ("found in re cache: " ^ (Formula.real_str re));
+ );
+ res
+ with Not_found ->
+ if !debug_level > 0 then print_endline ("Get real val " ^ (real_str re));
+ let re_val = get_real_val solver Any re struc in
+ Hashtbl.add !re_cache_results re (re_val, re_rels re);
+ re_val
+
(* Evaluate i-th formula on j-th structure. *)
let evaluate solver ~formula struc =
let phi = Hashtbl.find solver.formulas_eval formula in
@@ -441,7 +486,7 @@
let check_formula struc formula =
check solver ~formula struc
- let get_real_val = get_real_val solver Any
+ let get_real_val re struc = get_real_val_cache solver struc re
let formula_str phi =
let phi = Hashtbl.find solver.formulas_check phi in
Formula.str phi
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-28 22:04:26
|
Revision: 1337
http://toss.svn.sourceforge.net/toss/?rev=1337&view=rev
Author: lukstafi
Date: 2011-02-28 22:04:19 +0000 (Mon, 28 Feb 2011)
Log Message:
-----------
GDL trasnlation: affine shift of payoffs; handle GDL relation <distinct> (somewhat ignoring it); action translation bug fixes. Aux: optional nicer fresh names; update_assoc bug fix. DiscreteRule: translation from precond (for GDL) bug fix; more logging. Game: settable default effort; random move bug fix.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/Play/Game.ml
trunk/Toss/Play/Game.mli
trunk/Toss/Server/ServerGDLTest.in
trunk/Toss/Server/ServerGDLTest.out
trunk/Toss/Server/ServerTest.ml
Added Paths:
-----------
trunk/Toss/Server/ServerGDLTest.in2
trunk/Toss/Server/ServerGDLTest.out2
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -459,11 +459,11 @@
let ldmap = List.map find_fst_name matching in
match rlmap with
| None ->
- (* [ldmap = rmmap] *)
+ (* [ldmap = rmmap] *)
rewrite_nonstruct model ldmap rule_obj.rhs_pos_tuples
- rule_obj.rhs_neg_tuples rule_obj.rhs_elem_names
+ rule_obj.rhs_neg_tuples rule_obj.rhs_elem_names
| Some rlmap ->
- rewrite_emb model ldmap rlmap rule_obj
+ rewrite_emb model ldmap rlmap rule_obj
(** {2 Building a rule.} *)
@@ -530,7 +530,7 @@
(or "keep") the tuple if R is present on the RHS
- when both _opt_R and R are present over a single tuple, or when
- _opt_R is only present on the RHS, is an error (or unspecified)
+ _opt_R is only present on the RHS, it is an error (or unspecified)
Another set of special relations is used to compactly specify which
optional relations should be considered as present. The special
@@ -563,7 +563,15 @@
if List.mem_assoc rel defined_rels then
let args, _, rphi = List.assoc rel defined_rels in
List.map fst (List.filter (fun (rel, ar) ->
- Solver.M.check_formula (Structure.free_for_rel rel ar) rphi
+ let selector = Structure.free_for_rel rel ar in
+ let res = Solver.M.check_formula selector rphi in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "compile_rule.expand_def_rels: %s on %s = %b\n%!"
+ rel (Structure.str selector) res
+ );
+ (* }}} *)
+ res
) signat)
else [rel] in
let expand_defrel_tups (drel, tups) =
@@ -575,6 +583,13 @@
let selector = Structure.free_for_rel brel ar in
let asgn =
Solver.M.evaluate selector rphi in
+ (* {{{ log entry *)
+ if !debug_level > 3 && asgn<>AssignmentSet.Empty then (
+ Printf.printf "compile_rule.expand_defrel_tups: %s {%s} over\
+ %s = %s\n%!" drel (Solver.M.formula_str rphi) (Structure.str selector)
+ (AssignmentSet.str asgn)
+ );
+ (* }}} *)
let btup = Array.init ar (fun i->i+1) in
(* [selector] has only [btup] with its elements *)
let selvars =
@@ -929,7 +944,7 @@
lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
emb_rels = emb_rels;
- rule_s = [];
+ rule_s = List.map (fun (_,i) ->i,i) struc_elems;
pre = precond;
}
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -705,6 +705,6 @@
let a () = DiscreteRule.debug_level := 7
let a () =
- match (test_filter ["DiscreteRule:4:rewrite: compile_rule integers"] tests) with
+ match (test_filter ["DiscreteRule:13:compile_rule: defined relations"] tests) with
| Some tests -> ignore (run_test_tt ~verbose:true tests)
| None -> ()
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Formula/Aux.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -144,9 +144,9 @@
else aux (pair :: acc) l in
aux [] l
-let rec update_assoc k v0 f l =
+let update_assoc k v0 f l =
let rec aux acc = function
- | [] -> [k, f v0]
+ | [] -> List.rev_append acc [k, f v0]
| (a, b as pair) :: l ->
if compare a k = 0 then List.rev_append acc ((k, f b)::l)
else aux (pair :: acc) l in
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Formula/AuxTest.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -112,9 +112,16 @@
(fun () -> Aux.pop_assq g
["B","f";"G", "T0"; "C","B"; "F","Ts"]);
+ assert_equal ~msg:"update_assoc: two-level path"
+ [(7, [('b', ["ha"])])]
+ (Aux.update_assoc 7 [] (Aux.update_assoc 'b' [] (Aux.cons "ha")) []);
+
assert_equal ~msg:"update_assoc: two-level trie"
- [(7, [('b', ["ha"])])]
- (Aux.update_assoc 7 [] (Aux.update_assoc 'b' [] (Aux.cons "ha")) [])
+ [(1, [("a", [4; 4]); ("b", [4])]); (2, [("b", [4])])]
+ (List.fold_left (fun acc (path,t) ->
+ Aux.update_assoc t []
+ (Aux.update_assoc path [] (Aux.cons 4)) acc
+ ) [] ["a",1; "b",2; "b",1; "a",1])
);
"unsome, map_try" >::
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/GGP/GDL.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -350,6 +350,9 @@
(4b) relations is a necessary "heuristic". Whether to extend it to
constant subterms (see above) is not clear.
+ (7i0) Heuristic (reason for unsoundness): for "distinct", only
+ check whether its arguments are syntactically equal.
+
(7i1) Remove branches that are unsatisfiable by their static
relations (4a), (4b) and (positive) (4c) alone.
@@ -429,12 +432,20 @@
variables (both static and dynamic) using (6); fail if a goal
value cannot be determined.
- (8a) The payoff formula is the sum of "goal" value times the
- characterisic function of the corresponding "goal" bodies. We do
- not translate the body if the value is zero (we drop the zero goal
- branches from the definition). For each goal value we collect
- bodies to form a disjunction.
+ (8a) Filter-out goal branches that are contradictory with the
+ terminal condition (using resolution on the GDL
+ side). Implementation TODO.
+ (8b) For each goal value we collect bodies to form a disjunction.
+
+ (8c) The payoff formula is the sum of "goal" value times the
+ characterisic function of the corresponding "goal" bodies. To
+ simplify the result, we find the longest formula, and center the
+ payoff around it: for the goal value V_i if i-th formula phi_i and
+ phi_K being the longest formula, we translate the payoff into "K +
+ (V_1 - V_K) :(phi_1) + ... (V_n - V_K) :(phi_n)" thus removing
+ phi_K from translation.
+
(9) To translate an incoming action, we:
(9a) find the "lead legal" term to which the "does move" ground
@@ -488,6 +499,10 @@
(** Expand static relations that do not have ground facts and have
arity above the threshold. *)
let expand_arity_above = ref 0
+(** Generate all tuples for equivalences, to faciliate further
+ transformations of formulas in the game definition (outside of
+ translation). *)
+let equivalences_all_tuples = ref false
type term =
| Const of string
@@ -796,18 +811,20 @@
(* 3d *)
(* Match the first argument as term against the second argument as
pattern. Allow nonlinear (object) variables. *)
-let rec match_meta sb m_sb terms1 terms2 =
+let rec match_meta ?(ignore_meta=false) sb m_sb terms1 terms2 =
match terms1, terms2 with
| [], [] -> sb, m_sb
| (Const _ (* | Var _ *) as a)::terms1,
(Const _ (* | Var _ *) as b)::terms2
- when a=b -> match_meta sb m_sb terms1 terms2
+ when a=b -> match_meta ~ignore_meta sb m_sb terms1 terms2
| Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
- match_meta sb m_sb (args1 @ terms1) (args2 @ terms2)
+ match_meta ~ignore_meta sb m_sb (args1 @ terms1) (args2 @ terms2)
| term::terms1, MVar x::terms2 ->
(* we don't substitute because metavariables are linear *)
- match_meta sb ((x, term)::m_sb) terms1 terms2
- | MVar _::_, _ -> raise Not_found
+ match_meta ~ignore_meta sb ((x, term)::m_sb) terms1 terms2
+ | MVar _::terms1, _::terms2 ->
+ if ignore_meta then match_meta ~ignore_meta sb m_sb terms1 terms2
+ else raise Not_found
| term::terms1, Var x::terms2 ->
let sb1 = x, term in
let sb =
@@ -815,7 +832,7 @@
if List.assoc x sb = term then sb
else raise Not_found
else sb1::sb in
- match_meta sb m_sb terms1 terms2
+ match_meta ~ignore_meta sb m_sb terms1 terms2
| _ ->
(* {{{ log entry *)
if !debug_level > 4 then (
@@ -872,17 +889,27 @@
| Func (f, args) ->
Func (f, List.map (subst sb) args)
-let unify_rels (rel1, args1) (rel2, args2) =
- if rel1 = rel2 then unify [] args1 args2
- else raise Not_found
+let extend_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb
+let rec unify_all sb = function
+ | [] | [_] -> sb
+ | t1::t2::tl ->
+ let t1 = subst sb t1 in
+ let t2 = subst sb t2 in
+ let sb = unify sb [t1] [t2] in
+ unify_all sb ((subst sb t2)::tl)
+
+
let unifies term1 term2 =
try ignore (unify [] [term1] [term2]); true
with Not_found -> false
+let unify_rels (rel1, args1) (rel2, args2) =
+ if rel1 = rel2 then unify [] args1 args2
+ else raise Not_found
+
let subst_rel sb (rel, args) = rel, List.map (subst sb) args
let subst_rels sb body = List.map (subst_rel sb) body
-let extend_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb
let compose_sb sb1 sb2 =
let vars1, terms1 = List.split sb1 in
@@ -1359,7 +1386,7 @@
let find_cycle cands =
(* {{{ log entry *)
- if !debug_level > -1 then (
+ if !debug_level > 0 then (
Printf.printf "GDL.find_cycle: %s\n%!" (String.concat ", " (
List.map (function Some c -> term_str c | None -> "None") cands))
);
@@ -1509,7 +1536,6 @@
List.map (fun (sb, br) -> sb, freshen_branch br) brs
| _ -> brs
-
let translate_branches struc masks playout_terms static_rnames dyn_rels
(brs : exp_def_branch list) =
(* 7i *)
@@ -1603,9 +1629,18 @@
let vars = Aux.unique_sorted
(List.map (fun t -> snd (toss_var masks t)) terms) in
constrained_vars := vars @ !constrained_vars;
- (* (4b) are equivalences, so we just build a "star" *)
- let tups = match vars with [] -> []
- | v::vs -> List.map (fun w -> [|v; w|]) vs in
+ let tups =
+ if !equivalences_all_tuples
+ then
+ (* generating more relations to faciliate "contraction" of
+ co-occurring relations in GameSimpl, which will also clean
+ the redundant atoms *)
+ Aux.concat_map (fun v -> Aux.map_some (fun w ->
+ if v=w then None else Some [|v; w|]) vars) vars
+ else
+ (* (4b) are equivalences, so we just build a "star" *)
+ match vars with [] -> []
+ | v::vs -> List.map (fun w -> [|v; w|]) vs in
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
) path_subterms in
@@ -1654,11 +1689,17 @@
else if rel = "_DOES_PLACEHOLDER_"
then []
else if List.mem rel static_rnames then
- (* 7i-4a *)
+ (* 7i-4a *)
List.map (fun c -> Formula.Not c) (conjs_4a rel args)
- else
- (* dynamic relations have been expanded *)
- assert false
+ else if rel = "distinct" then
+ (* 7i0 *)
+ if Aux.not_unique args then [Formula.Or []]
+ else []
+ else (
+ (* dynamic relations have been expanded *)
+ Printf.printf
+ "translate_game: (7i) unexpected dynamic %s\n%!" rel;
+ assert false)
| _ -> []) neg_body in
let all_conjs = phi @ conjs @ neg_conjs in
let phi = Formula.And all_conjs in
@@ -1729,6 +1770,10 @@
) m_sb
else if List.mem rel static_rnames || rel = "_DOES_PLACEHOLDER_"
then []
+ else if rel = "distinct" then
+ (* 7i0 *)
+ if Aux.not_unique args then [Formula.Or []]
+ else []
else (
Printf.printf "\nunexpected_dynamic: %s\n%!" rel;
(* dynamic relations have been expanded *)
@@ -1768,9 +1813,15 @@
(* 7i-4a *)
Some (Formula.And (
List.map (fun c -> Formula.Not c) (conjs_4a rel args)))
- else
+ else if rel = "distinct" then
+ (* 7i0 *)
+ if Aux.not_unique args then Some (Formula.Or [])
+ else None
+ else (
(* dynamic relations have been expanded *)
- assert false
+ Printf.printf
+ "translate_game: (7k) unexpected dynamic %s\n%!" rel;
+ assert false)
) neg_conjs in
match disjs with
| [] -> None
@@ -1832,10 +1883,6 @@
let static_rules, dynamic_rules, static_base, init_state,
(agg_actions, agg_states) =
aggregate_playout player_terms 30 rules in
- (* (8) -- drop zero goal branches, "first round" *)
- let dynamic_rules = List.filter
- (function ("goal", [_; Const "0"]), _, _ -> false | _ -> true)
- dynamic_rules in
let element_terms : term list =
List.fold_left (fun acc st -> Aux.unique_sorted (st @ acc)) []
agg_states in
@@ -2480,8 +2527,6 @@
Printf.printf "Blanking-out of %s by %s\n%!"
(term_str next_arg) (term_str mask)
);
- (* }}} *)
- (* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "Frame multibody:\n%s\n%!"
( String.concat "\n" (List.map (
@@ -2828,12 +2873,14 @@
List.map (fun (player, goal_brs) -> player, Aux.collect goal_brs)
(Aux.collect goal_brs) in
let payoffs = List.map (fun (player, goals) ->
- let payoff = List.fold_left (fun sum (score, brs) ->
+ let payoff = List.map (fun (score, brs) ->
let score =
match score with
| Const pay ->
(try float_of_string pay with _ -> assert false)
| _ -> assert false in
+ (* 8a: TODO *)
+ (* 8b *)
(* FIXME: should we expand before,
with [~freshen_unfixed:(Aux.Left true)]? *)
let goal_uni_vars, goal_4b, brs =
@@ -2847,10 +2894,34 @@
let disj = lift_universal goal_uni_vars (disj_4b @ conjs) in
Formula.Ex (FormulaOps.free_vars disj, disj)
) brs in
- let guard = Formula.Or goal_disjs in
- Formula.Plus (sum, Formula.Times (
- Formula.Const score, Formula.Char guard))
- ) (Formula.Const 0.) goals in
+ score, Formula.Or goal_disjs
+ ) goals in
+ (* 8c *)
+ let sized =
+ List.map (fun (score,phi) -> FormulaOps.size phi, score) payoff in
+ let cmp (s1,v1) (s2,v2) =
+ if s2-s1 = 0 then Pervasives.compare v1 v2 else s2-s1 in
+ let base_score =
+ match List.sort cmp sized with [] -> 0.
+ | (_, score)::_ -> score in
+ let payoff = match payoff with
+ | [score, guard] ->
+ Formula.Times (
+ Formula.Const score, Formula.Char guard)
+ | scores ->
+ List.fold_left (fun sum (score, guard) ->
+ if score = base_score then (
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf
+ "translate_game: (8) dropping score %f guard:\n%s\n\n%!"
+ score (Formula.sprint guard)
+ );
+ (* }}} *)
+ sum)
+ else Formula.Plus (sum, Formula.Times (
+ Formula.Const (score -. base_score), Formula.Char guard)))
+ (Formula.Const base_score) scores in
player, payoff
) player_goals in
@@ -2912,14 +2983,27 @@
let fixvar_elemvars =
List.fold_left (fun acc (evar,elem) ->
let mask, sb, m_sb, blank = term_to_blank masks elem in
- List.fold_left (fun acc (path,t) ->
- match t with
- | Var v ->
- Aux.update_assoc v []
- (Aux.update_assoc mask []
- (Aux.update_assoc path [] (Aux.cons evar))) acc
- | _ -> acc
- ) acc sb
+ let res =
+ List.fold_left (fun acc (path,t) ->
+ match t with
+ | Var v ->
+ Aux.update_assoc v []
+ (Aux.update_assoc mask []
+ (Aux.update_assoc path [] (Aux.cons evar))) acc
+ | _ -> acc
+ ) acc sb in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "fixvars: elem=%s; sb=%s\n%!"
+ (term_str elem)
+ (String.concat "; "
+ (List.map (fun (v,ts)-> v^": "^
+ String.concat ", "
+ (List.map (fun (t,_)->term_str t) ts)
+ ) res))
+ );
+ (* }}} *)
+ res
) [] var_elems in
tossrule_data :=
Aux.StrMap.add rname {
@@ -3049,12 +3133,28 @@
match tossrules with
| [lead, tossrules] -> lead, tossrules
| _ -> assert false in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.translate_incoming_move: action=%s; lead=%s\n%!"
+ (term_str player_action) (term_str lead)
+ );
+ (* }}} *)
(* 9c *)
let fixed_inst, _ =
match_meta [] [] [player_action] [lead] in
+ let struc = (snd state).Arena.struc in
let candidates = Aux.map_some (
fun (rname, precond, add, struc_elems, fixvar_elemvars) ->
(* 9d *)
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "fixvar_elemvars: %s\n%!"
+ (String.concat "; "
+ (List.map (fun (v,ts)->v^": "^
+ String.concat ", " (List.map (fun (t,_)->term_str t) ts))
+ fixvar_elemvars))
+ );
+ (* }}} *)
let anchors = Aux.concat_map (fun (v,t) ->
let elemvars = List.assoc v fixvar_elemvars in
Aux.concat_map (fun (mask, pevs) ->
@@ -3067,30 +3167,52 @@
pevs) elemvars
) fixed_inst in
let precond = Formula.And (anchors @ [precond]) in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "GDL.translate_incoming_move: trying precond=\n%s\n...%!"
+ (Formula.sprint precond)
+ );
+ (* }}} *)
let rule =
DiscreteRule.translate_from_precond ~precond ~add
~embed:gdl.fluents ~struc_elems in
+ let lhs_struc = rule.DiscreteRule.lhs_struc in
let rule = DiscreteRule.compile_rule
- (Structure.rel_signature (snd state).Arena.struc) [] rule in
+ (Structure.rel_signature struc) [] rule in
let asgns =
- DiscreteRule.find_matchings (snd state).Arena.struc rule in
+ DiscreteRule.find_matchings struc rule in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "found %s\n%!" (AssignmentSet.str asgns)
+ );
+ (* }}} *)
(* faster *)
(* let emb =
DiscreteRule.choose_match (snd state).Arena.struc rule asgns in *)
(* but we should check whether there's no ambiguity... *)
match
- DiscreteRule.enumerate_matchings (snd state).Arena.struc rule asgns
+ DiscreteRule.enumerate_matchings struc rule asgns
with
| [] -> None
- | [emb] -> Some (rname, emb)
+ | [emb] -> Some (rname, emb, lhs_struc)
| _ -> failwith
("GDL.translate_incoming_move: match ambiguity for rule "^rname)
) tossrules in
match candidates with
- | [rname, emb] -> rname, emb
+ | [rname, emb, lhs_struc] ->
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.translate_incoming_move: rname=%s; emb=%s\n...%!"
+ rname
+ (String.concat ", " (List.map (fun (v,e) ->
+ Structure.elem_str lhs_struc v ^ ": " ^
+ Structure.elem_str struc e) emb))
+ );
+ (* }}} *)
+ rname, emb
| _ -> failwith
("GDL.translate_incoming_move: ambiguity among rules "^
- String.concat ", " (List.map fst candidates))
+ String.concat ", " (List.map Aux.fst3 candidates))
(*
@@ -3116,6 +3238,20 @@
(* let location = (fst state).Arena.graph.(loc) in *)
let tossrule = Aux.StrMap.find rname gdl.tossrule_data in
let rule = List.assoc rname (fst state).Arena.rules in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.translate_outgoing_move: rname=%s; emb={%s}\n%!"
+ rname (String.concat ", "(List.map (fun (v, e)->
+ let vname =
+ DiscreteRule.elemvar_of_elem
+ rule.ContinuousRule.compiled.DiscreteRule.lhs_elem_inv_names v in
+ let ename = Structure.elem_str (snd state).Arena.struc e in
+ if ename = "control__blank_" then
+ Structure.print (snd state).Arena.struc;
+ vname ^ ": " ^ ename
+ ) emb))
+ );
+ (* }}} *)
(* 10d *)
let emb = List.map (fun (v, e) ->
let vterm =
@@ -3123,14 +3259,27 @@
rule.ContinuousRule.compiled.DiscreteRule.lhs_elem_inv_names v in
Aux.StrMap.find vterm tossrule.elemvars,
Aux.IntMap.find e gdl.t_elements) emb in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "outgoing-emb={%s}\n%!"
+ (String.concat ", "(List.map (fun (vt, et)->
+ term_str vt ^ ": " ^ term_str et) emb))
+ );
+ (* }}} *)
let sb =
try
List.fold_left (fun sb (v_term, e_term) ->
- fst (match_meta sb [] [e_term] [v_term])) [] emb
+ fst (match_meta ~ignore_meta:true sb [] [e_term] [v_term])) [] emb
with Not_found -> failwith
("GDL.translate_outgoing_move: inconsistent match for rule "
^rname) in
- term_str (subst sb tossrule.lead_legal)
+ let res = term_str (subst sb tossrule.lead_legal) in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.translate_outgoing_move: result = %s\n%!" res
+ );
+ (* }}} *)
+ res
let our_turn gdl state =
let loc = (snd state).Arena.cur_loc in
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/GGP/GDLTest.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -114,5 +114,5 @@
let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in
let connect5 = load_rules "./GGP/examples/connect5.gdl" in
let tictactoe = load_rules "./GGP/examples/tictactoe.gdl" in
- let gdef = GDL.translate_game (Const "x") connect5 in
+ let gdef = GDL.translate_game (Const "white") breakthrough in
ignore gdef; ignore connect5; ignore breakthrough; ignore tictactoe
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Play/Game.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -3,7 +3,7 @@
open Printf
(* Default effort overshoots to let timeout handle stopping. *)
-let default_effort = 2 (* 10 *)
+let default_effort = ref 10
let debug_level = ref 0
let set_debug_level i = (debug_level := i)
@@ -530,7 +530,9 @@
to follow the best move (or both). Also return the accrued
computation as updated "memory" for the current state.
- Use [Random_move] for other agents if their "effort" is set to zero. *)
+ Uses [Random_move] for other agents if their "effort" is set to
+ zero. Do not use [Random_move] or [effort=0] when the table of
+ moves is used for more than extracting the move selected! *)
and toss ~grid_size ?(just_payoffs=false)
({game={Arena.rules=rules; graph=graph; num_players=num_players;
defined_rels=defined_rels};
@@ -579,9 +581,10 @@
loc.Arena.payoffs_pp in
Aux.Right payoff
| Some state ->
- (* FIXME: [pos] refers to unfiltered array! *)
+ (* [pos] refers to unfiltered array! use only to extract
+ | the move from the returned array *)
Aux.Left
- (!pos, moves, memory,
+ (!pos mod mlen, moves, memory,
{game_state = state;
memory = update_memory ~num_players state !pos memory}))
@@ -1156,9 +1159,11 @@
evgame_of_heuristic heuristics heuristics_pp game in
Maximax_evgame (heur_evgame, false, depth, pruning)
-let initialize_default state ?loc ?(effort=default_effort)
+let initialize_default state ?loc ?effort
~search_method ?horizon
?advr ?(payoffs_already_tnf=false) ?heuristic () =
+ let effort = match effort with
+ | None -> !default_effort | Some e -> e in
let {Arena.rules=rules; graph=graph; num_players=num_players} = fst state in
let struc = (snd state).Arena.struc in
(* {{{ log entry *)
@@ -1229,8 +1234,9 @@
(* {{{ log entry *)
if !debug_level > 1 then
- printf "suggest: pos %d\n%!" bpos;
-
+ printf "suggest: pos %d out of %d -- %s\n%!" bpos
+ (Array.length moves)
+ (Move.move_gs_str (play.game, play_state.game_state) moves.(bpos));
(* }}} *)
Some (moves.(bpos), {play_state with memory=memory})
| Aux.Right payoffs -> None)
Modified: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Play/Game.mli 2011-02-28 22:04:19 UTC (rev 1337)
@@ -1,5 +1,8 @@
(** 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
Modified: trunk/Toss/Server/ServerGDLTest.in
===================================================================
--- trunk/Toss/Server/ServerGDLTest.in 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Server/ServerGDLTest.in 2011-02-28 22:04:19 UTC (rev 1337)
@@ -3,9 +3,9 @@
Sender: GAMEMASTER
Receiver: GAMEPLAYER
Content-type: text/acl
-Content-length: 1721
+Content-length: 1652
-(START MATCH.3316980891 XPLAYER ((ROLE XPLAYER) (ROLE OPLAYER) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL XPLAYER)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL XPLAYER)) (TRUE (CONTROL OPLAYER))) (<= (NEXT (CONTROL OPLAYER)) (TRUE (CONTROL XPLAYER))) (<= (ROW ?X ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= (GOAL ?PLAYER 0) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) OPEN) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30)
+(START MATCH.3316980891 OPLAYER ((ROLE XPLAYER) (ROLE OPLAYER) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL XPLAYER)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL XPLAYER)) (TRUE (CONTROL OPLAYER))) (<= (NEXT (CONTROL OPLAYER)) (TRUE (CONTROL XPLAYER))) (<= (ROW ?X ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30)
POST / HTTP/1.0
Accept: text/delim
@@ -23,7 +23,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 ((MARK 2 2) NOOP))
+(PLAY MATCH.3316980891 ((MARK 1 2) NOOP))
POST / HTTP/1.0
Accept: text/delim
@@ -32,7 +32,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 (NOOP (MARK 3 1)))
+(PLAY MATCH.3316980891 (NOOP (MARK 2 2)))
POST / HTTP/1.0
Accept: text/delim
@@ -41,7 +41,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 ((MARK 1 1) NOOP))
+(PLAY MATCH.3316980891 ((MARK 3 2) NOOP))
POST / HTTP/1.0
Accept: text/delim
@@ -50,7 +50,7 @@
Content-type: text/acl
Content-length: 41
-(PLAY MATCH.3316980891 (NOOP (MARK 3 2)))
+(PLAY MATCH.3316980891 (NOOP (MARK 1 1)))
POST / HTTP/1.0
Accept: text/delim
@@ -59,4 +59,13 @@
Content-type: text/acl
Content-length: 41
-(STOP MATCH.3316980891 ((MARK 3 3) NOOP))
+(PLAY MATCH.3316980891 ((MARK 3 1) NOOP))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(STOP MATCH.3316980891 (NOOP (MARK 3 3)))
Added: trunk/Toss/Server/ServerGDLTest.in2
===================================================================
--- trunk/Toss/Server/ServerGDLTest.in2 (rev 0)
+++ trunk/Toss/Server/ServerGDLTest.in2 2011-02-28 22:04:19 UTC (rev 1337)
@@ -0,0 +1,71 @@
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 1652
+
+(START MATCH.3316980891 OPLAYER ((ROLE XPLAYER) (ROLE OPLAYER) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL XPLAYER)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL XPLAYER)) (TRUE (CONTROL OPLAYER))) (<= (NEXT (CONTROL OPLAYER)) (TRUE (CONTROL XPLAYER))) (<= (ROW ?X ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30)
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 27
+
+(PLAY MATCH.3316980891 NIL)
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 ((MARK 1 2) NOOP))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 (NOOP (MARK 1 1)))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 ((MARK 3 2) NOOP))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 (NOOP (MARK 2 2)))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(PLAY MATCH.3316980891 ((MARK 3 1) NOOP))
+
+POST / HTTP/1.0
+Accept: text/delim
+Sender: GAMEMASTER
+Receiver: GAMEPLAYER
+Content-type: text/acl
+Content-length: 41
+
+(STOP MATCH.3316980891 (NOOP (MARK 3 3)))
Modified: trunk/Toss/Server/ServerGDLTest.out
===================================================================
--- trunk/Toss/Server/ServerGDLTest.out 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Server/ServerGDLTest.out 2011-02-28 22:04:19 UTC (rev 1337)
@@ -5,6 +5,11 @@
READY
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)
Added: trunk/Toss/Server/ServerGDLTest.out2
===================================================================
--- trunk/Toss/Server/ServerGDLTest.out2 (rev 0)
+++ trunk/Toss/Server/ServerGDLTest.out2 2011-02-28 22:04:19 UTC (rev 1337)
@@ -0,0 +1,41 @@
+HTTP/1.0 200 OK
+Content-type: text/acl
+Content-length: 5
+
+READY
+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
+
+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
+
+NOOP
+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
+
+DONE
+ERR processing completed -- EOF
Modified: trunk/Toss/Server/ServerTest.ml
===================================================================
--- trunk/Toss/Server/ServerTest.ml 2011-02-28 19:19:18 UTC (rev 1336)
+++ trunk/Toss/Server/ServerTest.ml 2011-02-28 22:04:19 UTC (rev 1337)
@@ -52,11 +52,11 @@
Game.deterministic_suggest := true;
let old_translation = !GDL.manual_translation in
GDL.manual_translation := false;
- let in_ch = open_in "./Server/ServerGDLTest.in" in
+ let in_ch = open_in "./Server/ServerGDLTest.in2" in
let out_ch = open_out "./Server/ServerGDLTest.temp" in
- GDL.debug_level := 4;
- Server.set_debug_level 6;
Game.deterministic_suggest := true;
+ let old_effort = !Game.default_effort in
+ Game.default_effort := 2;
(try while true do
Server.req_handle in_ch out_ch done
with End_of_file -> ());
@@ -65,11 +65,12 @@
let result =
Aux.input_file (open_in "./Server/ServerGDLTest.temp") in
let target =
- Aux.input_file (open_in "./Server/ServerGDLTest.out") in
+ Aux.input_file (open_in "./Server/ServerGDLTest.out2") in
Sys.remove "./Server/ServerGDLTest.temp";
assert_equal ~printer:(fun x->x)
(strip_spaces target) (strip_spaces result);
- GDL.manual_translation := old_translation
+ GDL.manual_translation := old_translation;
+ Game.default_effort := old_effort
);
]
@@ -79,6 +80,11 @@
Aux.run_test_if_target "ServerTest" tests
let a () =
+ GDL.debug_level := 4;
+ (* Server.set_debug_level 6 *)
+ Game.set_debug_level 2
+
+let a () =
match test_filter
["server:2:ServerGDLTest.in GDL Tic-Tac-Toe automatic"]
tests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-28 19:19:24
|
Revision: 1336
http://toss.svn.sourceforge.net/toss/?rev=1336&view=rev
Author: lukaszkaiser
Date: 2011-02-28 19:19:18 +0000 (Mon, 28 Feb 2011)
Log Message:
-----------
Correct solver cache bug.
Modified Paths:
--------------
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-02-28 01:18:17 UTC (rev 1335)
+++ trunk/Toss/Solver/Solver.ml 2011-02-28 19:19:18 UTC (rev 1336)
@@ -236,16 +236,19 @@
let diffrels_struc s1 s2 =
if Structure.equal { s1 with relations = StringMap.empty; }
{ s2 with relations = StringMap.empty; } then
- let is_eq_in2 rel tp =
+ let is_eq_in map rel tp =
try
- Structure.Tuples.equal (Structure.StringMap.find rel s2.relations) tp
+ Structure.Tuples.equal (Structure.StringMap.find rel map) tp
with Not_found -> false in
+ let is_eq_in1, is_eq_in2 = is_eq_in s1.relations, is_eq_in s2.relations in
let diffrels = ref [] in
- let appdiff r tp = if not (is_eq_in2 r tp) then diffrels := r::!diffrels in
- Structure.StringMap.iter appdiff s1.relations;
+ let appdiff1 r tp = if not (is_eq_in1 r tp) then diffrels := r::!diffrels in
+ let appdiff2 r tp = if not (is_eq_in2 r tp) then diffrels := r::!diffrels in
+ Structure.StringMap.iter appdiff1 s2.relations;
+ Structure.StringMap.iter appdiff2 s1.relations;
if !debug_level > 1 then
print_endline ("SOME DIFF: " ^ (String.concat ", " !diffrels));
- Some (!diffrels)
+ Some (Aux.unique_sorted !diffrels)
else None
let phi_rels phi =
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-28 01:18:23
|
Revision: 1335
http://toss.svn.sourceforge.net/toss/?rev=1335&view=rev
Author: lukaszkaiser
Date: 2011-02-28 01:18:17 +0000 (Mon, 28 Feb 2011)
Log Message:
-----------
Better cache in Solver, other small corrections.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
trunk/Toss/Solver/Structure.ml
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-02-28 01:18:17 UTC (rev 1335)
@@ -121,34 +121,37 @@
(* Map [f] to all literals (i.e. atoms or not(atom)'s) in the given
formula. Preserves order of subformulas. *)
-let rec map_to_literals f = function
+let rec map_to_literals f g = function
Rel _ | Eq _ | In _ as x -> f x
| Not (Rel _) | Not (Eq _) | Not (In _) as x -> f x
- | Not (RealExpr (r, s)) -> Not (RealExpr (map_to_literals_expr f r, s))
- | Not phi -> Not (map_to_literals f phi)
- | Or flist -> Or (List.map (map_to_literals f) flist)
- | And flist -> And (List.map (map_to_literals f) flist)
- | Ex (vs, phi) -> Ex (vs, map_to_literals f phi)
- | All (vs, phi) -> All (vs, map_to_literals f phi)
- | RealExpr (r, s) -> RealExpr (map_to_literals_expr f r, s)
+ | Not (RealExpr (r, s)) -> Not (RealExpr (map_to_literals_expr f g r, s))
+ | Not phi -> Not (map_to_literals f g phi)
+ | Or flist -> Or (List.map (map_to_literals f g) flist)
+ | And flist -> And (List.map (map_to_literals f g) flist)
+ | Ex (vs, phi) -> Ex (vs, map_to_literals f g phi)
+ | All (vs, phi) -> All (vs, map_to_literals f g phi)
+ | RealExpr (r, s) -> RealExpr (map_to_literals_expr f g r, s)
-and map_to_literals_expr f = function
- | RVar _ | Const _ | Fun _ as x -> x
+and map_to_literals_expr f g = function
+ | RVar _ | Const _ | Fun _ as x -> g x
| Times (r1, r2) ->
- Times (map_to_literals_expr f r1, map_to_literals_expr f r2)
+ Times (map_to_literals_expr f g r1, map_to_literals_expr f g r2)
| Plus (r1, r2) ->
- Plus (map_to_literals_expr f r1, map_to_literals_expr f r2)
- | Char (phi) -> Char (map_to_literals f phi)
+ Plus (map_to_literals_expr f g r1, map_to_literals_expr f g r2)
+ | Char (phi) -> Char (map_to_literals f g phi)
| Sum (vs, phi, r) ->
- Sum (vs, map_to_literals f phi, map_to_literals_expr f r)
+ Sum (vs, map_to_literals f g phi, map_to_literals_expr f g r)
(* Map [f] to all atoms in the given formula. *)
+let map_to_atoms_full f g phi =
+ map_to_literals (function Not (x) -> Not (f x) | x -> f x) g phi
+
let map_to_atoms f phi =
- map_to_literals (function Not (x) -> Not (f x) | x -> f x) phi
+ map_to_literals (function Not (x) -> Not (f x) | x -> f x) (fun x -> x) phi
let map_to_atoms_expr f r =
- map_to_literals_expr (function Not (x) -> Not (f x) | x -> f x) r
+ map_to_literals_expr (function Not (x) -> Not (f x) | x -> f x) (fun x -> x) r
(* Map [f] to all variables occurring in the formula. Preserves order
of subformulas. *)
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-02-28 01:18:17 UTC (rev 1335)
@@ -21,10 +21,14 @@
(** Map [f] to all literals (i.e. atoms or not(atom)'s) in the given
formula. Preserves order of subformulas. *)
-val map_to_literals : (formula -> formula) -> formula -> formula
-val map_to_literals_expr : (formula -> formula) -> real_expr -> real_expr
+val map_to_literals : (formula -> formula) -> (real_expr -> real_expr) ->
+ formula -> formula
+val map_to_literals_expr : (formula -> formula) -> (real_expr -> real_expr) ->
+ real_expr -> real_expr
(** Map [f] to all atoms in the given formula. *)
+val map_to_atoms_full : (formula -> formula) -> (real_expr -> real_expr) ->
+ formula -> formula
val map_to_atoms : (formula -> formula) -> formula -> formula
val map_to_atoms_expr : (formula -> formula) -> real_expr -> real_expr
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Play/GameTree.ml 2011-02-28 01:18:17 UTC (rev 1335)
@@ -6,8 +6,8 @@
(* 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 * Solver.cachetbl * 'a
- (* leaf with state, player, cache and info *)
+ | Leaf of Arena.game_state * int * 'a
+ (* leaf with state, player, and info *)
| Node of Arena.game_state * int * 'a *
(Move.move * ('a, 'b) abstract_game_tree) array
(* node with state, player, moves and info *)
@@ -24,7 +24,7 @@
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)
+ | 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
@@ -40,37 +40,36 @@
(* Player in the given node. *)
let player = function
| Terminal (_, player, _) -> player
- | Leaf (_, player, _, _) -> player
+ | Leaf (_, player, _) -> player
| Node (_, player, _, _) -> player
(* State in the given node. *)
let state = function
| Terminal (state, _, _) -> state
- | Leaf (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
- let info, cache = info_leaf game state player in
- Leaf (state, player, cache, info)
+ let info = info_leaf game state player in
+ Leaf (state, player, info)
(* 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 _ -> raise Not_found
- | Leaf (state, player, cache, info) ->
- Solver.set_cache (state.Arena.struc, cache);
+ | 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 l_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in
- let l_info, cache = info_leaf (depth+1) game leaf_s l_pl in
- Leaf (leaf_s, l_pl, cache, l_info) in
+ let l_info = info_leaf (depth+1) game leaf_s l_pl in
+ Leaf (leaf_s, l_pl, l_info) 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) ->
@@ -113,13 +112,13 @@
(* Get the payoffs / heuristics array of a game tree node. *)
let node_values = function
| Terminal (_, _, i) -> Array.map (fun p -> !cPAYOFF_AS_HEUR *. p) i.payoffs
- | Leaf (_, _, _, i) -> i.heurs
+ | 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
+ | Leaf (_, _, i) -> i.info
| Node (_, _, i, _) -> i.info
@@ -130,7 +129,7 @@
let res =
{ heurs = Array.map calc heurs.(state.Arena.cur_loc);
info = f depth game state } in
- (res, snd (Solver.get_cache ()))
+ res
let init game state f h = init_abstract game state (info_leaf_f f h 0)
@@ -167,7 +166,7 @@
(* Choose one of the maximizing moves (at random) given a game tree. *)
let choose_move game = function
| Terminal _ -> raise Not_found
- | Leaf (state, _, _, _) ->
+ | Leaf (state, _, _) ->
Aux.random_elem (Array.to_list (Move.list_moves game state))
| Node (_, p, info, succ) ->
let mval = info.heurs.(p) in
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Play/GameTree.mli 2011-02-28 01:18:17 UTC (rev 1335)
@@ -5,8 +5,8 @@
(** 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 * Solver.cachetbl * 'a
- (** leaf with state, player, moves and info *)
+ | Leaf of Arena.game_state * int * 'a
+ (** leaf with state, player, and info *)
| Node of Arena.game_state * int * 'a *
(Move.move * ('a, 'b) abstract_game_tree) array
(** node with state, player, moves *)
@@ -27,14 +27,13 @@
(** Abstract initialization function. *)
val init_abstract : Arena.game -> Arena.game_state ->
- (Arena.game -> Arena.game_state -> int -> 'a * Solver.cachetbl) ->
+ (Arena.game -> Arena.game_state -> int -> 'a) ->
('a, 'b) abstract_game_tree
(** Abstract game tree unfolding function, calls argument functions for work. *)
val unfold_abstract : ?depth:int -> Arena.game ->
info_terminal : (int -> Arena.game -> Arena.game_state -> int -> 'a -> 'b) ->
- info_leaf : (int -> Arena.game -> Arena.game_state -> int ->
- 'a * Solver.cachetbl) ->
+ info_leaf : (int -> Arena.game -> Arena.game_state -> int -> 'a) ->
info_node : (int -> Arena.game -> Arena.game_state -> int ->
(Move.move * ('a, 'b) abstract_game_tree) array -> 'a) ->
choice : (int -> Arena.game -> Arena.game_state -> int -> 'a ->
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-02-28 01:18:17 UTC (rev 1335)
@@ -17,13 +17,13 @@
"abstract tree init, to string" >::
(fun () ->
let s = {Arena.struc=Structure.empty_structure(); cur_loc=0; time=0.} in
- let t = Leaf (s, 1, Hashtbl.create 1, 5) in
+ let t = Leaf (s, 1, 5) in
assert_equal ~printer:(fun x -> x)
"\n|| Leaf. Player 1 loc 0 time 0.0.\n|| [ | | ]\n|| 5"
(GameTree.str_abstract ~depth:2 string_of_int string_of_int t);
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
- let t = GameTree.init_abstract g s (fun _ _ _ -> 5, Hashtbl.create 1) in
+ let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in
assert_equal ~printer:(fun x -> x)
("\nLeaf. Player 0 loc 0 time 0.0.\n[ | P:1 {}; Q:1 {} | ] \"\n" ^
"\t \n\t. . . \n" ^
@@ -35,9 +35,9 @@
"abstract unfold, size" >::
(fun () ->
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
- let t = GameTree.init_abstract g s (fun _ _ _ -> 5, Hashtbl.create 1) in
+ let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in
let i_t = (fun _ _ _ _ _ -> 0) in
- let i_l = (fun _ _ _ _ -> 1, Hashtbl.create 1) in
+ let i_l = (fun _ _ _ _ -> 1) in
let (i_n, ch) = (fun _ _ _ _ _ -> 2), (fun _ _ _ _ _ _ -> 0) in
let u = GameTree.unfold_abstract g i_t i_l i_n ch t in
(* print_endline (GameTree.str_abstract string_of_int string_of_int u);*)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Solver/Solver.ml 2011-02-28 01:18:17 UTC (rev 1335)
@@ -10,7 +10,8 @@
(* CACHE *)
-type cachetbl = (Formula.formula, Assignments.assignment_set) Hashtbl.t
+type cachetbl =
+ (Formula.formula, Assignments.assignment_set * string list option) Hashtbl.t
let cache_struc = ref (empty_structure ())
let cache_results = ref (Hashtbl.create 15)
@@ -232,20 +233,55 @@
let eval_counter = ref 0
+let diffrels_struc s1 s2 =
+ if Structure.equal { s1 with relations = StringMap.empty; }
+ { s2 with relations = StringMap.empty; } then
+ let is_eq_in2 rel tp =
+ try
+ Structure.Tuples.equal (Structure.StringMap.find rel s2.relations) tp
+ with Not_found -> false in
+ let diffrels = ref [] in
+ let appdiff r tp = if not (is_eq_in2 r tp) then diffrels := r::!diffrels in
+ Structure.StringMap.iter appdiff s1.relations;
+ if !debug_level > 1 then
+ print_endline ("SOME DIFF: " ^ (String.concat ", " !diffrels));
+ Some (!diffrels)
+ else None
+
+let phi_rels phi =
+ let rels = ref [] in
+ let app_rel = function Rel (s, _) as r -> rels := s :: !rels; r | x -> x in
+ let app_re = function Fun _ -> raise Not_found | x -> x in
+ try
+ let _ = FormulaOps.map_to_atoms_full app_rel app_re phi in
+ let rs = Aux.unique_sorted !rels in
+ if !debug_level > 1 then
+ print_endline ("F: " ^ (Formula.str phi) ^" "^ (String.concat ", " rs));
+ Some rs
+ with Not_found -> None
+
(* Eval with very basic caching. *)
let eval_m struc phi =
- if phi = And [] then Any else
- if !cache_struc != struc then (
- let els = Set (Elems.cardinal struc.elements, struc.elements) in
- let asg = eval struc (ref els) Any phi in
- incr eval_counter;
- cache_struc := struc;
- Hashtbl.clear !cache_results;
- Hashtbl.add !cache_results phi asg;
- asg
- ) else
+ if phi = And [] then Any else (
+ if not (Structure.equal !cache_struc struc) then (
+ match diffrels_struc struc !cache_struc with
+ | None ->
+ cache_struc := struc;
+ Hashtbl.clear !cache_results;
+ | Some rs ->
+ cache_struc := struc;
+ let is_bad (_, prs_opt) =
+ match prs_opt with
+ | None -> true
+ | Some prs -> List.exists (fun r -> List.mem r rs) prs in
+ let ok = ref [] in
+ Hashtbl.iter (fun p r -> if is_bad r then () else ok := (p, r)::!ok)
+ !cache_results;
+ Hashtbl.clear !cache_results;
+ List.iter (fun (p, r) -> Hashtbl.add !cache_results p r) !ok
+ );
try
- let res = Hashtbl.find !cache_results phi in
+ let (res, _) = Hashtbl.find !cache_results phi in
if !debug_level > 1 then (
print_endline ("found in cache: " ^ (Formula.str phi));
);
@@ -255,8 +291,9 @@
let els = Set (Elems.cardinal struc.elements, struc.elements) in
let asg = eval struc (ref els) Any phi in
incr eval_counter;
- Hashtbl.add !cache_results phi asg;
+ Hashtbl.add !cache_results phi (asg, phi_rels phi);
asg
+ )
(* Helper function, assignment of tuple. *)
let asg_of_tuple struc vars tuple =
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Solver/Solver.mli 2011-02-28 01:18:17 UTC (rev 1335)
@@ -8,7 +8,8 @@
(** {2 Evaluation} *)
-type cachetbl = (Formula.formula, Assignments.assignment_set) Hashtbl.t
+type cachetbl =
+ (Formula.formula, Assignments.assignment_set * string list option) Hashtbl.t
val eval_counter : int ref
val get_cache : unit -> Structure.structure * cachetbl
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2011-02-26 12:52:28 UTC (rev 1334)
+++ trunk/Toss/Solver/Structure.ml 2011-02-28 01:18:17 UTC (rev 1335)
@@ -41,9 +41,9 @@
let compare s1 s2 =
if s1 == s2 then 0 else
- let c = Elems.compare s1.elements s2.elements in
+ let c = StringMap.compare Tuples.compare s1.relations s2.relations in
if c <> 0 then c else
- let d = StringMap.compare Tuples.compare s1.relations s2.relations in
+ let d = Elems.compare s1.elements s2.elements in
if d <> 0 then d else
StringMap.compare (IntMap.compare Pervasives.compare)
s1.functions s2.functions
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-26 12:52:34
|
Revision: 1334
http://toss.svn.sourceforge.net/toss/?rev=1334&view=rev
Author: lukstafi
Date: 2011-02-26 12:52:28 +0000 (Sat, 26 Feb 2011)
Log Message:
-----------
GDL translation: better frame/erasure generation (fix). Aux: cleaner fresh names (optional).
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDLTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-02-25 00:02:36 UTC (rev 1333)
+++ trunk/Toss/Formula/Aux.ml 2011-02-26 12:52:28 UTC (rev 1334)
@@ -406,6 +406,13 @@
else fold_n f (f accu) (n-1)
+(* Character classes. *)
+let is_uppercase c = c >= 'A' && c <= 'Z'
+let is_lowercase c = c >= 'a' && c <= 'z'
+let is_digit c = c >= '0' && c <= '9'
+let is_letter c = is_uppercase c || is_lowercase c
+let is_alphanum c = is_letter c || is_digit c
+
(* Return the result of the first index [i] that passes the
given test, and [i+1]. *)
let rec first_i n gen test =
@@ -418,7 +425,13 @@
snd (first_i 1 (fun i->basename^(string_of_int i)^suffix)
(fun fname->not (Sys.file_exists fname)))
-let not_conflicting_name names s =
+let not_conflicting_name ?(truncate=false) names s =
+ let s =
+ if truncate then
+ let i = ref (String.length s - 1) in
+ while !i > 0 && is_digit s.[!i] do decr i done;
+ String.sub s 0 (!i + 1)
+ else s in
if not (Strings.mem s names) then s
else
snd (first_i 0 (fun i -> s^(string_of_int i))
@@ -431,13 +444,6 @@
(fun v -> not (Strings.mem v names)) in
i', v::res) (0,[]) n))
-(* Character classes. *)
-let is_uppercase c = c >= 'A' && c <= 'Z'
-let is_lowercase c = c >= 'a' && c <= 'z'
-let is_digit c = c >= '0' && c <= '9'
-let is_letter c = is_uppercase c || is_lowercase c
-let is_alphanum c = is_letter c || is_digit c
-
(* Printing. *)
let list_fprint e_printf outchan l =
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-02-25 00:02:36 UTC (rev 1333)
+++ trunk/Toss/Formula/Aux.mli 2011-02-26 12:52:28 UTC (rev 1334)
@@ -217,8 +217,9 @@
(** Generate a fresh filename of the form [base ^ n ^ suffix]. *)
val new_filename : string -> string -> string
-(** Returns a string proloning [s] and not appearing in [names]. *)
-val not_conflicting_name : Strings.t -> string -> string
+(** Returns a string proloning [s] and not appearing in [names]. If
+ [truncate] is true, remove numbers from the end of [s]. *)
+val not_conflicting_name : ?truncate:bool -> Strings.t -> string -> string
(** Returns [n] strings proloning [s] and not appearing in [names]. *)
val not_conflicting_names :
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-25 00:02:36 UTC (rev 1333)
+++ trunk/Toss/GGP/GDL.ml 2011-02-26 12:52:28 UTC (rev 1334)
@@ -258,7 +258,7 @@
discard non-maximal equivalence classes, because negation (7e) is
not implemented, and with negation it would still be preferable to
have exhaustiveness check so as to not generate spurious
- (unapplicable) rules.
+ (unapplicable) rules. TODO: rethink, compare with (7f2).
(7e) Associate negation of equalities specific to the unifiers
strictly less general than the equivalence class with it, so that
@@ -281,9 +281,6 @@
manner as in (7b) and (7d) for the "legal" term), disjoin bodies
in each class (a "multi-body"), then:
- implementation TODO: currently, we only use maximal equivalence
- classes (see note at 7d)
-
(7f3) negate the multi-body, push negation inside (using de Morgan
laws etc.), split into separate "erasure" branch for each
disjunct, place the original "next" atom but with meta-variable
@@ -804,7 +801,7 @@
| [], [] -> sb, m_sb
| (Const _ (* | Var _ *) as a)::terms1,
(Const _ (* | Var _ *) as b)::terms2
- when a=b -> match_meta sb m_sb terms1 terms2
+ when a=b -> match_meta sb m_sb terms1 terms2
| Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
match_meta sb m_sb (args1 @ terms1) (args2 @ terms2)
| term::terms1, MVar x::terms2 ->
@@ -817,9 +814,17 @@
if List.mem_assoc x sb then
if List.assoc x sb = term then sb
else raise Not_found
- else sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb in
+ else sb1::sb in
match_meta sb m_sb terms1 terms2
- | _ -> raise Not_found
+ | _ ->
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "match_meta: unmatched (%s) against pattern (%s)\n%!"
+ (String.concat ", " (List.map term_str terms1))
+ (String.concat ", " (List.map term_str terms2))
+ );
+ (* }}} *)
+ raise Not_found
(* 3c1 *)
@@ -1055,14 +1060,14 @@
| Var x ->
if List.mem_assoc x !sb then Var (List.assoc x !sb)
else
- let x1 = Aux.not_conflicting_name !var_support x in
+ let x1 = Aux.not_conflicting_name ~truncate:true !var_support x in
var_support := Aux.Strings.add x1 !var_support;
sb := (x,x1)::!sb;
Var x1
| MVar x ->
if List.mem_assoc x !sb then MVar (List.assoc x !sb)
else
- let x1 = Aux.not_conflicting_name !var_support x in
+ let x1 = Aux.not_conflicting_name ~truncate:true !var_support x in
var_support := Aux.Strings.add x1 !var_support;
sb := (x,x1)::!sb;
MVar x1
@@ -1076,7 +1081,7 @@
List.map (fun x ->
if List.mem_assoc x !sb then List.assoc x !sb
else
- let x1 = Aux.not_conflicting_name !var_support x in
+ let x1 = Aux.not_conflicting_name ~truncate:true !var_support x in
var_support := Aux.Strings.add x1 !var_support;
sb := (x,x1)::!sb; x1
) (Aux.Strings.elements vs) in
@@ -1781,7 +1786,7 @@
let conjs = Aux.unique_sorted
(Aux.concat_map FormulaOps.flatten_ands conjs) in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "lift_universal: vars %s -- conjs:\n%s\n%!"
(String.concat ", "
(List.map Formula.var_str (uni_vars :> Formula.var list)))
@@ -1802,7 +1807,7 @@
Formula.And (global @ [
Formula.All (used_uni_vars, Formula.And local)]) in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "lift_universal: result\n%s\n%!"
(Formula.sprint res)
);
@@ -2426,25 +2431,45 @@
not (Aux.Strings.mem v fixed_vars)) sb
with Not_found -> false in
let frames =
- Aux.maximal leq3 frame_brs in
- let frames =
- List.map (fun repr ->
- List.filter (fun cl->leq3 cl repr) frame_brs)
- frames in
+ Aux.unique_sorted
+ (List.map (fun repr ->
+ List.filter (fun cl->leq3 cl repr) frame_brs)
+ frame_brs) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "frames: heads partitioning =\n%s\n%!"
+ (String.concat "\n"
+ (List.map (fun l ->
+ String.concat ", "
+ (List.map (function [head],_,_->term_str head
+ | _ -> assert false) l)) frames))
+ );
+ (* }}} *)
(* collect and rename multi-bodies *)
let frames = List.map (function
| [] -> assert false
| [head, body, neg_body] -> head, [body, neg_body]
- | (head, body, neg_body)::f_brs ->
+ | f_brs ->
+ let repr_head =
+ match Aux.maximal leq3 f_brs with
+ | [head, _, _] -> head
+ | _ -> assert false in
let multi_body = List.map
(fun (head2, body2, neg_body2) ->
- let sb, _ = match_meta [] [] head head2 in
+ let sb, _ = match_meta [] [] repr_head head2 in
subst_rels sb body2,
List.map (fun (uni_vs,neg) ->
uni_vs, subst_rels sb neg) neg_body2
) f_brs in
- head, (body, neg_body)::multi_body
+ repr_head, multi_body
) frames in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "frames: heads = %s\n%!"
+ (String.concat ", " (List.map (function [h],_ ->term_str h
+ | _ -> assert false) frames))
+ );
+ (* }}} *)
(* 7f3 *)
let erasure_brs : exp_def_branch list = Aux.concat_map
(function
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-02-25 00:02:36 UTC (rev 1333)
+++ trunk/Toss/GGP/GDLTest.ml 2011-02-26 12:52:28 UTC (rev 1334)
@@ -113,5 +113,6 @@
DiscreteRule.debug_level := 4;
let breakthrough = load_rules "./GGP/examples/breakthrough.gdl" in
let connect5 = load_rules "./GGP/examples/connect5.gdl" in
+ let tictactoe = load_rules "./GGP/examples/tictactoe.gdl" in
let gdef = GDL.translate_game (Const "x") connect5 in
- ignore gdef; ignore connect5; ignore breakthrough
+ ignore gdef; ignore connect5; ignore breakthrough; ignore tictactoe
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-25 00:02:44
|
Revision: 1333
http://toss.svn.sourceforge.net/toss/?rev=1333&view=rev
Author: lukaszkaiser
Date: 2011-02-25 00:02:36 +0000 (Fri, 25 Feb 2011)
Log Message:
-----------
Small debugging improvements.
Modified Paths:
--------------
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-02-24 22:57:56 UTC (rev 1332)
+++ trunk/Toss/Play/Heuristic.ml 2011-02-25 00:02:36 UTC (rev 1333)
@@ -1028,6 +1028,10 @@
let heurs = Array.map (fun f ->
Formula.Plus (Formula.Times (Formula.Const (2.), f),
Formula.Times (Formula.Const (-1.), sum_all))) sums in
+ if !debug_level > 0 then (
+ let hlist = List.map Formula.real_str (Array.to_list heurs) in
+ print_endline ("FLHEUR: " ^ (String.concat "; " hlist))
+ );
Array.map (fun _ -> heurs) game.Arena.graph
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-02-24 22:57:56 UTC (rev 1332)
+++ trunk/Toss/Server/Server.ml 2011-02-25 00:02:36 UTC (rev 1333)
@@ -3,6 +3,7 @@
let debug_level = ref 0
let set_debug_level i =
debug_level := i;
+ if i > 5 then Solver.set_debug_level 1;
GameTree.set_debug_level 1;
Game.set_debug_level i;
Heuristic.debug_level := i - 3
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-24 22:58:02
|
Revision: 1332
http://toss.svn.sourceforge.net/toss/?rev=1332&view=rev
Author: lukaszkaiser
Date: 2011-02-24 22:57:56 +0000 (Thu, 24 Feb 2011)
Log Message:
-----------
Make automatic translation default, backtrace on GGP tests.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/Makefile
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-24 22:05:29 UTC (rev 1331)
+++ trunk/Toss/GGP/GDL.ml 2011-02-24 22:57:56 UTC (rev 1332)
@@ -3123,7 +3123,7 @@
-let manual_translation = ref true
+let manual_translation = ref false
let manual_game = ref "tictactoe"
let top_exec_path = ref "." (* path to top Toss directory *)
let tictactoe_descr = ref None
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-02-24 22:05:29 UTC (rev 1331)
+++ trunk/Toss/GGP/Makefile 2011-02-24 22:57:56 UTC (rev 1332)
@@ -16,12 +16,12 @@
GDLTestDebug:
%.black: examples/%.gdl ../TossServer
- ../TossServer -gdl unset -v &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -vv &
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
%.white: examples/%.gdl ../TossServer
- ../TossServer -gdl unset -v &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -vv &
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-24 22:05:37
|
Revision: 1331
http://toss.svn.sourceforge.net/toss/?rev=1331&view=rev
Author: lukstafi
Date: 2011-02-24 22:05:29 +0000 (Thu, 24 Feb 2011)
Log Message:
-----------
GDL translation: less redundancy in generated formulas.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-24 21:59:41 UTC (rev 1330)
+++ trunk/Toss/GGP/GDL.ml 2011-02-24 22:05:29 UTC (rev 1331)
@@ -126,8 +126,10 @@
for all element terms in element's equivalence class.)
(4c) (Anchor predicates.) Add a predicate for being derived from a
- mask. For each mask-path pointing to a constant in some of the
- elements and that constant, introduce a new predicate with
+ mask (which is applied in (7i-4c) only if not adding mask-path
+ predicates, fact or equivalence relations from which it can be
+ inferred). For each mask-path pointing to a constant in some of
+ the elements and that constant, introduce a new predicate with
semantics: "matches the mask and has the constant at the path
position".
@@ -1409,11 +1411,13 @@
(term_str a) (term_str b);
assert false
+(*
let triang_matrix elems =
let rec aux acc = function
| [] -> acc
| hd::tl -> aux (List.map (fun e->[|hd; e|]) tl @ acc) tl in
aux [] elems
+*)
let term_to_blank masks next_arg =
let mask_cands =
@@ -1585,13 +1589,18 @@
| _ -> None) sb
) state_terms in
let path_subterms = Aux.collect path_subterms in
+ let constrained_vars = ref [] in
let conjs_4b =
Aux.concat_map (fun ((mask, v), terms) ->
let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
let terms = Aux.collect terms in
Aux.concat_map (fun (_,terms) ->
- let vars = List.map (fun t -> snd (toss_var masks t)) terms in
- let tups = triang_matrix (Aux.unique_sorted vars) in
+ let vars = Aux.unique_sorted
+ (List.map (fun t -> snd (toss_var masks t)) terms) in
+ constrained_vars := vars @ !constrained_vars;
+ (* (4b) are equivalences, so we just build a "star" *)
+ let tups = match vars with [] -> []
+ | v::vs -> List.map (fun w -> [|v; w|]) vs in
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
) path_subterms in
@@ -1604,9 +1613,11 @@
let mask, sb, m_sb, blanked = term_to_blank masks next_arg in
let rname = term_to_name mask in
let _, svar = toss_var masks next_arg in
- let phi = Formula.Rel (rname, [|svar|]) in
- let lvars = ref [svar] in
- [phi], lvars in
+ if List.mem svar !constrained_vars then [], ref []
+ else
+ let phi = Formula.Rel (rname, [|svar|]) in
+ let lvars = ref [svar] in
+ [phi], lvars in
let conjs =
Aux.concat_map (fun (rel, args) ->
if rel = "true" then
@@ -1623,7 +1634,8 @@
| v, t as v_sb ->
let rname = term_to_name (subst_one v_sb mask) in
Some (Formula.Rel (rname, [|svar|]))) sb in
- phi::conjs
+ if conjs <> [] || List.mem svar !constrained_vars
+ then conjs else [phi]
else if List.mem rel static_rnames then
(* 7i-4a *)
conjs_4a rel args
@@ -1652,23 +1664,10 @@
let rphi = Solver.M.register_formula
(Formula.And optim_conjs) in
(* {{{ log entry *)
-
if !debug_level > 4 then (
- (* do not print, because it generates too many
- answers -- too little constraints per number of
- variables when considering a single branch *)
- (*
- let assgn = Solver.M.evaluate struc rphi in
- let avars = List.map Formula.var_str
- (FormulaOps.free_vars phi) in
- let atups =
- AssignmentSet.tuples struc.Structure.elements
- avars assgn in *)
Printf.printf "evaluating: %s\n%!"
(Formula.str phi)
- (* (List.length atups) *)
);
-
(* }}} *)
if Solver.M.check_formula struc rphi
then (
@@ -1706,14 +1705,16 @@
let rname = term_to_name (subst_one v_sb mask) in
Some (rname, [|rhs_elem|])
) m_sb in
+ let static_conjs = ref static_conjs in
let dyn_conjs =
Aux.concat_map (fun (rel, args) ->
if rel = "true" then
- (* 7i-4c *)
let true_arg = List.hd args in
let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
let _, svar = toss_var masks true_arg in
-
+ let mask_rname = term_to_name mask in
+ let mask_phi = Formula.Rel (mask_rname, [|svar|]) in
+ static_conjs := Aux.list_remove mask_phi !static_conjs;
Aux.map_some (fun (v,t as v_sb) ->
if t = Const "_BLANK_" then
(* None *) assert false
@@ -1753,8 +1754,9 @@
let rname = term_to_name (subst_one v_sb mask) in
Formula.Rel (rname, [|svar|])) m_sb in
- (* FIXME: make sure it's the right semantics *)
- Some (Formula.Not (Formula.And (phi :: conjs_4c @ conjs_5)))
+ let conjs = conjs_4c @ conjs_5 in
+ let conjs = if conjs = [] then [phi] else conjs in
+ Some (Formula.Not (Formula.And conjs))
else if rel = "_DOES_PLACEHOLDER_"
then None
else if List.mem rel static_rnames then
@@ -1769,8 +1771,8 @@
| [] -> None
| [disj] -> Some disj
| _ -> Some (Formula.Or disjs)) neg_body in
- let all_conjs = static_conjs @ dyn_conjs @ neg_conjs in
- (rhs_pos_preds, static_conjs, all_conjs),
+ let all_conjs = !static_conjs @ dyn_conjs @ neg_conjs in
+ (rhs_pos_preds, !static_conjs, all_conjs),
(next_arg, body, neg_body)) brs in
uni_toss_vars, conjs_4b, brs
@@ -2758,12 +2760,14 @@
dyn_rels terminal_brs in
let terminal_disjs = List.map (fun ((_,_,conjs),_) ->
let disj_vars = FormulaOps.free_vars (Formula.And conjs) in
+ let disj_vars = Aux.list_diff disj_vars
+ (terminal_uni_vars :> Formula.var list) in
let disj_4b =
List.filter (fun a -> List.exists (fun v->List.mem v disj_vars)
(FormulaOps.free_vars a)) terminal_4b in
- Formula.Ex (disj_vars,
- lift_universal terminal_uni_vars
- (disj_4b @ conjs))) terminal_brs in
+ let disj = lift_universal terminal_uni_vars (disj_4b @ conjs) in
+ if disj_vars = [] then disj else Formula.Ex (disj_vars, disj)
+ ) terminal_brs in
let terminal_phi = Formula.Or terminal_disjs in
(* let fluents = Aux.strings_of_list
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-24 21:59:47
|
Revision: 1330
http://toss.svn.sourceforge.net/toss/?rev=1330&view=rev
Author: lukaszkaiser
Date: 2011-02-24 21:59:41 +0000 (Thu, 24 Feb 2011)
Log Message:
-----------
Heuristic.is_constant_sum
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/Heuristic.mli
trunk/Toss/Play/HeuristicTest.ml
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-02-24 17:08:59 UTC (rev 1329)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-02-24 21:59:41 UTC (rev 1330)
@@ -562,7 +562,7 @@
(* Recursively simplify a formula *)
-let simplify ?(do_pnf=false) phi =
+let rec simplify ?(do_pnf=false) ?(do_re=true) phi =
let do_simplify phi =
let (ids, rev_ids, free_id) = (Hashtbl.create 7, Hashtbl.create 7, ref 1) in
let boolean_phi = BoolFormula.bool_formula_of_formula_arg phi (ids, rev_ids, free_id) in
@@ -571,7 +571,11 @@
(*print_endline("Simplified to: " ^ str simplified_phi);*)
simplified_phi in
let rec simplify_subformulas = function
- Rel _ | Eq _ | In _ | RealExpr _ as atom -> atom
+ Rel _ | Eq _ | In _ as atom -> atom
+ | RealExpr (re, sgn) as rx ->
+ if do_re then
+ RealExpr (simplify_re ~do_pnf ~do_formula:true re, sgn)
+ else rx
| Not psi -> do_simplify (Not (simplify_subformulas psi))
| And (flist) -> do_simplify (And (List.rev_map simplify_subformulas flist))
| Or (flist) -> do_simplify (Or (List.rev_map simplify_subformulas flist))
@@ -602,6 +606,42 @@
) else
simplified_prenex_phi
+and simplify_re ?(do_pnf=false) ?(do_formula=true) = function
+ | RVar _ | Const _ | Fun _ as atom -> atom
+ | Char phi ->
+ if do_formula then Char (simplify ~do_pnf ~do_re:true phi) else Char phi
+ | Sum (l, phi, re) ->
+ let re_simp = simplify_re ~do_pnf ~do_formula re in
+ if do_formula then
+ Sum (l, simplify ~do_pnf ~do_re:true phi, re_simp)
+ else Sum (l, phi, re_simp)
+ | Plus _ | Times (Const _, _) | Times (_, Const _) as x ->
+ let rec get_linear = function
+ | Plus (p, q) -> List.rev_append (get_linear p) (get_linear q)
+ | Times (Const c, p) | Times (p, Const c) ->
+ List.map (fun (f, x) -> (c *. f, x)) (get_linear p)
+ | Const c -> [(c, Const 1.)]
+ | x -> [(1., x)] in
+ let one (c, x) = if c = 1. then x else if c = 0. then Const 0. else
+ if x = Const 1. then Const c else Times (Const c, x) in
+ let rec collect_linear = function
+ | [] -> Const 0.
+ | [x] -> one x
+ | (c, x) :: ls when c = 0. -> collect_linear ls
+ | (c, x) :: (d, y) :: ls when x = y ->
+ collect_linear ((c +. d, x) :: ls)
+ | x :: y :: ls -> Plus (one x, collect_linear (y :: ls)) in
+ let l = get_linear x in
+ let cmp (c, x) (d, y) =
+ let x = Pervasives.compare x y in
+ if x <> 0 then x else if c > d then 1 else if d > c then -1 else 0 in
+ let s = List.map (fun (c, r) -> (c, simplify_re ~do_pnf ~do_formula r)) l in
+ collect_linear (List.sort cmp s)
+ | Times (p, q) ->
+ let simp_p = simplify_re ~do_pnf ~do_formula p in
+ let simp_q = simplify_re ~do_pnf ~do_formula q in
+ if simp_p = p && simp_q = q then Times (p, q) else
+ simplify_re ~do_pnf ~do_formula (Times (simp_p, simp_q))
(* Flatten "and"s and "or"s in a formula -- i.e. associativity. *)
let rec flatten_formula phi =
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-02-24 17:08:59 UTC (rev 1329)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-02-24 21:59:41 UTC (rev 1330)
@@ -67,8 +67,12 @@
(** {2 Simplification} *)
(** Recursively simplify a formula *)
-val simplify : ?do_pnf : bool -> formula -> formula
+val simplify : ?do_pnf : bool -> ?do_re : bool -> formula -> formula
+(** Recursively simplify a real expr *)
+val simplify_re : ?do_pnf: bool -> ?do_formula: bool -> real_expr -> real_expr
+
+
val pnf : formula -> formula
(** Flatten "and"s and "or"s in a formula -- i.e. associativity. *)
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-02-24 17:08:59 UTC (rev 1329)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-02-24 21:59:41 UTC (rev 1330)
@@ -7,12 +7,21 @@
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
;;
+let real_expr_of_string s =
+ FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)
+;;
+
let formula_eq f1 phi1 f2 phi2 =
assert_equal ~printer:(fun x -> Formula.str x)
(Formula.flatten (f1 (formula_of_string phi1)))
(Formula.flatten (f2 (formula_of_string phi2)))
;;
+let real_expr_eq f1 re1 f2 re2 =
+ assert_equal ~printer:(fun x -> Formula.real_str x)
+ (f1 (real_expr_of_string re1)) (f2 (real_expr_of_string re2))
+;;
+
let id x = x ;;
let tests = "FormulaOps" >::: [
@@ -222,6 +231,15 @@
and all s (((s in X2) or (s in S)))))";
);
+ "simplify_re" >::
+ (fun () ->
+ let simp_eq re1 re2 = real_expr_eq id re2 FormulaOps.simplify_re re1 in
+ simp_eq ":f(x) - :f(x)" "0";
+ simp_eq ":f(x) + 3 * :f(x)" "4 * :f(x)";
+ simp_eq " 3 + 4 * 5 - 12" "11";
+ simp_eq ":(ex x R(x)) - :(ex x R(x))" "0";
+ );
+
"prenex" >::
(fun () ->
let prenex_eq phi1 phi2 = formula_eq id phi2 FormulaOps.pnf phi1 in
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-02-24 17:08:59 UTC (rev 1329)
+++ trunk/Toss/Play/Heuristic.ml 2011-02-24 21:59:41 UTC (rev 1330)
@@ -1037,3 +1037,12 @@
let default_heuristic ?struc ?advr g =
mix_heur (default_heuristic_old ?struc ?advr g) 0.2 (fluents_heuristic g)
+
+let is_constant_sum_one heur_arr =
+ let is_const r1 r2 =
+ let simp = FormulaOps.simplify_re (Plus (r1, r2)) in
+ match simp with | Const _ -> true | _ -> false in
+ Array.length heur_arr = 2 && is_const heur_arr.(0) heur_arr.(1)
+
+let is_constant_sum harr =
+ not (Aux.array_existsi (fun _ h -> not (is_constant_sum_one h)) harr)
Modified: trunk/Toss/Play/Heuristic.mli
===================================================================
--- trunk/Toss/Play/Heuristic.mli 2011-02-24 17:08:59 UTC (rev 1329)
+++ trunk/Toss/Play/Heuristic.mli 2011-02-24 21:59:41 UTC (rev 1330)
@@ -105,3 +105,6 @@
Arena.game -> Formula.real_expr array array
val fluents_heuristic : Arena.game -> Formula.real_expr array array
+
+val is_constant_sum_one : Formula.real_expr array -> bool
+val is_constant_sum : Formula.real_expr array array -> bool
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-02-24 17:08:59 UTC (rev 1329)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-02-24 21:59:41 UTC (rev 1330)
@@ -393,6 +393,18 @@
(default_heuristic 3. rules
(real_of_str (":("^winPvwxyz^") - :("^winQvwxyz^")")))));
));
+
+ "is_constant_sum: monotonic gomoku" >::
+ (fun () -> backtrace (
+ let rules = [
+ rule_of_str sigPQ "[a|P:1 {}; Q:1 {}|] -> [|Q:1 {}; P(a)|] emb P, Q";
+ rule_of_str sigPQ "[a|P:1 {}; Q:1 {}|] -> [|P:1 {}; Q(a)|] emb P, Q"] in
+ let h = default_heuristic 2. rules
+ (real_of_str (":("^winPvwxyz^") - :("^winQvwxyz^")")) in
+ assert_equal ~printer:(fun x -> string_of_bool x) true
+ (Heuristic.is_constant_sum_one
+ [|h; Formula.Times (Formula.Const (-1.), h)|])
+ ));
]
let a =
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-24 17:09:05
|
Revision: 1329
http://toss.svn.sourceforge.net/toss/?rev=1329&view=rev
Author: lukstafi
Date: 2011-02-24 17:08:59 +0000 (Thu, 24 Feb 2011)
Log Message:
-----------
GDL translation: remaining uses of expansion of unfixed variables.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-24 02:15:08 UTC (rev 1328)
+++ trunk/Toss/GGP/GDL.ml 2011-02-24 17:08:59 UTC (rev 1329)
@@ -357,12 +357,11 @@
(7j) Identify variables in "next" & "true" terms that are
at-or-below meta-variables in the corresponding mask. (Most of
such variables should be already removed as belonging to "frame"
- branches.) Expand them by duplicating given branch for all
- instantiations (all (5) predicates derived from the considered
- position). (Note that since branches do not have unfixed variables
- anymore, we do not rename variables during duplication.)
+ branches.) Such fixed variables should be expanded by duplicating
+ the whole set of branches together with the "lead legal" term.
- Implementation: TODO.
+ Implementation: TODO; currently, we check for such fixed
+ variables and fail if they're present.
(7k) Replace the "next" and "true" atoms by the conjunction of
(4c) and (5) predicates over their corresponding variable. (For
@@ -411,7 +410,7 @@
the disjointness conditions and the terminal condition.)
(7n1) Prior to translation, expand all variables under
- meta-variables in "terminal" branches, as in (7j). Implementation TODO.
+ meta-variables in "terminal" branches, as in (7j).
The rewrite rule is generated by joining the derived conjunctions
from "next" atoms as RHS, and from bodies as the
@@ -1433,7 +1432,76 @@
let mask, _, _, blank = term_to_blank masks term in
mask, Formula.fo_var_of_string (String.lowercase (term_to_name blank))
-let translate_branches struc masks static_rnames dyn_rels
+
+(* Expand branch variables. If [freshen_unfixed=Right fixed], expand
+ all variables that don't belong to [fixed]. If
+ [freshen_unfixed=Left freshen], then expand all variables below
+ meta-variables of masks. If [freshen] is true, rename other
+ (i.e. non-expanded) variables while duplicating branches. (When
+ [freshen] is false, all remaining variables should be fixed.)
+
+ With each branch, also return the instantiation used to derive it???
+
+ As in the expansion of relation definitions, branches are
+ duplicated for instantiations of positive literals, and
+ additionally of heads. For instantiations of atoms in negated
+ subformulas, the subformulas are duplicated within a branch, with
+ instantiations kept local to the subformula. Final substitution is
+ re-applied to catch up with later instantiations. *)
+let expand_branch_vars masks playout_terms ~freshen_unfixed brs =
+ let expand sb arg =
+ let arg = subst sb arg in
+ let is_inst_var =
+ match freshen_unfixed with
+ | Aux.Left _ ->
+ let mask, sb, m_sb, blank = term_to_blank masks arg in
+ let ivars = Aux.concat_map (fun (_,t) ->
+ Aux.Strings.elements (term_vars t)) m_sb in
+ (fun v -> List.mem v ivars)
+ | Aux.Right fixed -> fun v -> not (List.mem v fixed) in
+ Aux.unique_sorted
+ (Aux.map_try (fun term ->
+ let sb1, _ = match_meta [] [] [term] [arg] in
+ let sb1 = List.sort Pervasives.compare
+ (List.filter (fun (v,_)->is_inst_var v) sb1) in
+ extend_sb sb1 sb, subst sb1 arg
+ ) playout_terms) in
+ let expand_rel atom (sb, acc) =
+ match atom with
+ | "true", [arg] ->
+ List.map (fun (sb,arg) -> sb, ("true",[arg])::acc) (expand sb arg)
+ | rel, args -> [sb, (rel, List.map (subst sb) args)::acc] in
+ let expand_neg sb (vs, neg_conj) =
+ let neg_conjs =
+ Aux.concat_foldr expand_rel neg_conj [sb, []] in
+ List.map (fun (sb, neg_conj) ->
+ let vs = List.filter (fun v -> not (List.mem_assoc v sb))
+ (Aux.Strings.elements vs) in
+ Aux.strings_of_list vs, neg_conj
+ ) neg_conjs in
+ let brs =
+ Aux.concat_map (function ([head],body,neg_body) ->
+ Aux.concat_map (fun (sb,head) ->
+ let bodies = Aux.concat_foldr expand_rel body [sb, []] in
+ Aux.map_some (fun (sb, body) ->
+ let head = subst sb head in
+ let body = List.map (subst_rel sb) body in
+ let neg_body =
+ Aux.concat_map (expand_neg sb) neg_body in
+ if List.exists (function _, [] -> true | _ -> false)
+ neg_body then None
+ (* need to pack head into a list for [freshen_branch] *)
+ else Some (sb, ([head], body, neg_body))) bodies)
+ (if head = Const "_IGNORE_RHS_" then [[], head]
+ else expand [] head)
+ | _ -> assert false) brs in
+ match freshen_unfixed with
+ | Aux.Left true ->
+ List.map (fun (sb, br) -> sb, freshen_branch br) brs
+ | _ -> brs
+
+
+let translate_branches struc masks playout_terms static_rnames dyn_rels
(brs : exp_def_branch list) =
(* 7i *)
let state_terms =
@@ -1612,8 +1680,16 @@
Some (all_conjs, (next_arg,body,neg_body)))
else None
| _ -> assert false) brs in
- (* 7j: TODO *)
-
+ (* 7j *)
+ let check_brs =
+ expand_branch_vars masks playout_terms
+ ~freshen_unfixed:(Aux.Left false)
+ (List.map (fun (_,(head,body,neg_body))->
+ [head], body, neg_body) brs) in
+ if List.exists (fun (sb,_)-> sb <> []) check_brs
+ then failwith
+ ("GDL.translate_game: expanding variables resulting in "^
+ "duplicating Toss rules not implemented yet");
(* 7k *)
let brs =
List.map (fun (static_conjs, (next_arg,body,neg_body)) ->
@@ -1731,73 +1807,6 @@
(* }}} *)
res
-(* Expand branch variables. If [freshen_unfixed=Right fixed], expand
- all variables that don't belong to [fixed]. If
- [freshen_unfixed=Left freshen], then expand all variables below
- meta-variables of masks. If [freshen] is true, rename other
- (i.e. non-expanded) variables while duplicating branches. (When
- [freshen] is false, all remaining variables should be fixed.)
-
- With each branch, also return the instantiation used to derive it???
-
- As in the expansion of relation definitions, branches are
- duplicated for instantiations of positive literals, and
- additionally of heads. For instantiations of atoms in negated
- subformulas, the subformulas are duplicated within a branch, with
- instantiations kept local to the subformula. Final substitution is
- re-applied to catch up with later instantiations. *)
-let expand_branch_vars masks playout_terms ~freshen_unfixed brs =
- let expand sb arg =
- let arg = subst sb arg in
- let is_inst_var =
- match freshen_unfixed with
- | Aux.Left _ ->
- let mask, sb, m_sb, blank = term_to_blank masks arg in
- let ivars = Aux.concat_map (fun (_,t) ->
- Aux.Strings.elements (term_vars t)) m_sb in
- (fun v -> List.mem v ivars)
- | Aux.Right fixed -> fun v -> not (List.mem v fixed) in
- Aux.unique_sorted
- (Aux.map_try (fun term ->
- let sb1, _ = match_meta [] [] [term] [arg] in
- let sb1 = List.sort Pervasives.compare
- (List.filter (fun (v,_)->is_inst_var v) sb1) in
- extend_sb sb1 sb, subst sb1 arg
- ) playout_terms) in
- let expand_rel atom (sb, acc) =
- match atom with
- | "true", [arg] ->
- List.map (fun (sb,arg) -> sb, ("true",[arg])::acc) (expand sb arg)
- | rel, args -> [sb, (rel, List.map (subst sb) args)::acc] in
- let expand_neg sb (vs, neg_conj) =
- let neg_conjs =
- Aux.concat_foldr expand_rel neg_conj [sb, []] in
- List.map (fun (sb, neg_conj) ->
- let vs = List.filter (fun v -> not (List.mem_assoc v sb))
- (Aux.Strings.elements vs) in
- Aux.strings_of_list vs, neg_conj
- ) neg_conjs in
- let brs =
- Aux.concat_map (function ([head],body,neg_body) ->
- Aux.concat_map (fun (sb,head) ->
- let bodies = Aux.concat_foldr expand_rel body [sb, []] in
- Aux.map_some (fun (sb, body) ->
- let head = subst sb head in
- let body = List.map (subst_rel sb) body in
- let neg_body =
- Aux.concat_map (expand_neg sb) neg_body in
- if List.exists (function _, [] -> true | _ -> false)
- neg_body then None
- (* need to pack head into a list for [freshen_branch] *)
- else Some ((* sb, *)([head], body, neg_body))) bodies)
- (if head = Const "_IGNORE_RHS_" then [[], head]
- else expand [] head)
- | _ -> assert false) brs in
- match freshen_unfixed with
- | Aux.Left true ->
- List.map (fun ((* sb, *) br) -> (* sb, *) freshen_branch br) brs
- | _ -> brs
-
let translate_game player_term game_descr =
var_support := Aux.Strings.empty;
let player_terms =
@@ -2401,10 +2410,12 @@
) frame_brs in
let unfixed_brs =
to_expand @ more_to_expand in
- if unfixed_brs <> [] then failwith
- ("GDL.translate_game: parametric non-frame actions "^
- "not implemented yet (7g):\n" ^
- def_str ("action",unfixed_brs));
+ (* 7g1 *)
+ let expanded_brs =
+ expand_branch_vars masks element_terms
+ ~freshen_unfixed:(Aux.Right (Aux.Strings.elements fixed_vars))
+ unfixed_brs in
+ let expanded_brs = List.map snd expanded_brs in
(* 7f2 *)
let leq3 (head1, _, _) (head2, _, _) =
try
@@ -2525,18 +2536,17 @@
head, Aux.unique_sorted body,
Aux.unique_sorted neg_body) erasures) in
erasures
- (* TODO: (7g) *)
+ (* TODO: (7g2) *)
| _ -> assert false) frames in
(* TODO: (7f5) we ignore the possibility that "lead" is
instantiated by some of erasure substitutions, since
we already ignore non-maximal "legal" classes *)
- lead_head, fixed_brs @ erasure_brs
+ lead_head, fixed_brs @ expanded_brs @ erasure_brs
) rules_brs in
(* let rules_inds = Array.of_list rules_brs in *)
rules_brs
) joint_legal_branches
) loc_joint_legal in
- (* 7g: (7g1) and (7g2) TODO *)
(* {{{ log entry *)
if !debug_level > 1 then (
Array.iteri (fun loc rules_brs ->
@@ -2571,8 +2581,8 @@
[Const "_IGNORE_RHS_"], [], [Aux.Strings.empty, [atom]]]
) atoms in
let uni_vars, conjs_4b, brs =
- translate_branches struc masks static_rnames dyn_rels
- (brs @ synth_brs) in
+ translate_branches struc masks element_terms static_rnames
+ dyn_rels (brs @ synth_brs) in
(* 7l *)
let brs = Array.of_list brs in (* indexing branches *)
let full_set = Aux.ints_of_list
@@ -2742,8 +2752,10 @@
let terminal_brs =
expand_branch_vars masks element_terms
~freshen_unfixed:(Aux.Left true) terminal_brs in
+ let terminal_brs = List.map snd terminal_brs in
let terminal_uni_vars, terminal_4b, terminal_brs =
- translate_branches struc masks static_rnames dyn_rels terminal_brs in
+ translate_branches struc masks element_terms static_rnames
+ dyn_rels terminal_brs in
let terminal_disjs = List.map (fun ((_,_,conjs),_) ->
let disj_vars = FormulaOps.free_vars (Formula.And conjs) in
let disj_4b =
@@ -2793,8 +2805,11 @@
| Const pay ->
(try float_of_string pay with _ -> assert false)
| _ -> assert false in
+ (* FIXME: should we expand before,
+ with [~freshen_unfixed:(Aux.Left true)]? *)
let goal_uni_vars, goal_4b, brs =
- translate_branches struc masks static_rnames dyn_rels brs in
+ translate_branches struc masks element_terms static_rnames
+ dyn_rels brs in
let goal_disjs = List.map (fun ((_,_,conjs),_) ->
let disj_vars = FormulaOps.free_vars (Formula.And conjs) in
let disj_4b =
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-24 02:15:14
|
Revision: 1328
http://toss.svn.sourceforge.net/toss/?rev=1328&view=rev
Author: lukstafi
Date: 2011-02-24 02:15:08 +0000 (Thu, 24 Feb 2011)
Log Message:
-----------
GDL translation: expansion of inconvenient variables (applied to terminal condition, to be applied at two more sites). GDLParser: more consistent lower-casing of keywords. ServerGDLTest: Tic-Tac-Toe definition bug fix. Aux: concat_foldr for backtracking-monad-like computations.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDLParser.mly
trunk/Toss/Server/ServerGDLTest.in
trunk/Toss/Server/ServerTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/Formula/Aux.ml 2011-02-24 02:15:08 UTC (rev 1328)
@@ -72,13 +72,16 @@
let map_reduce mapf redf red0 l =
match List.sort (fun x y -> compare (fst x) (fst y))
(List.map mapf l) with
- | [] -> []
- | (k0, v0)::tl ->
- let k0, vs, l = List.fold_left (fun (k0, vs, l) (kn, vn) ->
- if k0 = kn then k0, vn::vs, l else kn, [vn], (k0,vs)::l)
- (k0, [v0], []) tl in
- List.rev (List.map (fun (k,vs) -> k, List.fold_left redf red0 vs)
- ((k0,vs)::l))
+ | [] -> []
+ | (k0, v0)::tl ->
+ let k0, vs, l =
+ List.fold_left (fun (k0, vs, l) (kn, vn) ->
+ if k0 = kn then k0, vn::vs, l
+ else kn, [vn], (k0,vs)::l)
+ (k0, [v0], []) tl in
+ List.rev (
+ List.map (fun (k,vs) -> k, List.fold_left redf red0 vs)
+ ((k0,vs)::l))
let collect l =
match List.sort (fun x y -> compare (fst x) (fst y)) l with
@@ -90,6 +93,11 @@
(k0, [v0], []) tl in
List.rev ((k0,List.rev vs)::l)
+let rec concat_foldr f l init =
+ match l with
+ | [] -> init
+ | a::l -> concat_map (f a) (concat_foldr f l init)
+
let list_remove v l = List.filter (fun w->v<>w) l
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/Formula/Aux.mli 2011-02-24 02:15:08 UTC (rev 1328)
@@ -53,6 +53,10 @@
[map_reduce (fun x -> x) (fun y x->x::y) []]. *)
val collect : ('a * 'b) list -> ('a * 'b list) list
+(** Another very useful function from the list monad family:
+ [concat_foldr f (a::l) init = concat_map (f a) (concat_foldr f l init)] *)
+val concat_foldr : ('a -> 'b -> 'b list) -> 'a list -> 'b list -> 'b list
+
(** Remove all elements equal to the argument, using structural
inequality. *)
val list_remove : 'a -> 'a list -> 'a list
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/Formula/AuxTest.ml 2011-02-24 02:15:08 UTC (rev 1328)
@@ -133,7 +133,7 @@
(Aux.map_try f [`A;`B;`C;`D]);
);
- "product, all_tuples_for" >::
+ "product, all_tuples_for, concat_foldr" >::
(fun () ->
let print_llist l = String.concat "; "
(List.map (String.concat ", ") l) in
@@ -152,6 +152,14 @@
assert_equal ~printer:print_llist
[["a"; "a"; "a"]; ["a"; "a"; "b"]; ["a"; "b"; "a"]; ["a"; "b"; "b"]; ["b"; "a"; "a"]; ["b"; "a"; "b"]; ["b"; "b"; "a"]; ["b"; "b"; "b"]]
(Aux.all_tuples_for [();(); ()] ["a";"b"]);
+
+ assert_equal ~printer:print_llist
+ [["a1"; "b"; "c"; "a1"; "d"]; ["a2"; "b"; "c"; "a1"; "d"];
+ ["a1"; "b"; "c"; "a2"; "d"]; ["a2"; "b"; "c"; "a2"; "d"]]
+ (Aux.concat_foldr (function
+ | "a" ->
+ (fun acc -> List.map (fun x->x::acc) ["a1"; "a2"])
+ | x -> (fun acc -> [x::acc])) ["a"; "b"; "c"; "a"; "d"] [[]])
);
"list_remove, remove_one" >::
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/GGP/GDL.ml 2011-02-24 02:15:08 UTC (rev 1328)
@@ -816,7 +816,7 @@
if List.mem_assoc x sb then
if List.assoc x sb = term then sb
else raise Not_found
- else sb1::sb in
+ else sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb in
match_meta sb m_sb terms1 terms2
| _ -> raise Not_found
@@ -1043,26 +1043,43 @@
(* 6 *)
-(* Need a global access so that the count can be reset between
+(* Need a global access so that the support can be reset between
different translations. (Generalization uses a local [fresh_count]
state.) *)
-let freshen_count = ref 0
+let var_support = ref Aux.Strings.empty
-(* TODO: do proper elegant renaming... *)
let freshen_branch (args, body, neg_body) =
- incr freshen_count;
+ let sb = ref [] in
let rec map_vnames = function
- | Var x -> Var (x^string_of_int !freshen_count)
- | MVar x -> MVar (x^string_of_int !freshen_count)
+ | Var x ->
+ if List.mem_assoc x !sb then Var (List.assoc x !sb)
+ else
+ let x1 = Aux.not_conflicting_name !var_support x in
+ var_support := Aux.Strings.add x1 !var_support;
+ sb := (x,x1)::!sb;
+ Var x1
+ | MVar x ->
+ if List.mem_assoc x !sb then MVar (List.assoc x !sb)
+ else
+ let x1 = Aux.not_conflicting_name !var_support x in
+ var_support := Aux.Strings.add x1 !var_support;
+ sb := (x,x1)::!sb;
+ MVar x1
| Const _ as t -> t
| Func (f, args) ->
Func (f, List.map map_vnames args) in
let map_rel (rel, args) =
rel, List.map map_vnames args in
let map_neg (vs, atoms) =
- Aux.strings_of_list
- (List.map (fun x-> x^string_of_int !freshen_count)
- (Aux.Strings.elements vs)),
+ let vs =
+ List.map (fun x ->
+ if List.mem_assoc x !sb then List.assoc x !sb
+ else
+ let x1 = Aux.not_conflicting_name !var_support x in
+ var_support := Aux.Strings.add x1 !var_support;
+ sb := (x,x1)::!sb; x1
+ ) (Aux.Strings.elements vs) in
+ Aux.strings_of_list vs,
List.map map_rel atoms in
List.map map_vnames args,
List.map map_rel body,
@@ -1714,8 +1731,75 @@
(* }}} *)
res
+(* Expand branch variables. If [freshen_unfixed=Right fixed], expand
+ all variables that don't belong to [fixed]. If
+ [freshen_unfixed=Left freshen], then expand all variables below
+ meta-variables of masks. If [freshen] is true, rename other
+ (i.e. non-expanded) variables while duplicating branches. (When
+ [freshen] is false, all remaining variables should be fixed.)
+
+ With each branch, also return the instantiation used to derive it???
+
+ As in the expansion of relation definitions, branches are
+ duplicated for instantiations of positive literals, and
+ additionally of heads. For instantiations of atoms in negated
+ subformulas, the subformulas are duplicated within a branch, with
+ instantiations kept local to the subformula. Final substitution is
+ re-applied to catch up with later instantiations. *)
+let expand_branch_vars masks playout_terms ~freshen_unfixed brs =
+ let expand sb arg =
+ let arg = subst sb arg in
+ let is_inst_var =
+ match freshen_unfixed with
+ | Aux.Left _ ->
+ let mask, sb, m_sb, blank = term_to_blank masks arg in
+ let ivars = Aux.concat_map (fun (_,t) ->
+ Aux.Strings.elements (term_vars t)) m_sb in
+ (fun v -> List.mem v ivars)
+ | Aux.Right fixed -> fun v -> not (List.mem v fixed) in
+ Aux.unique_sorted
+ (Aux.map_try (fun term ->
+ let sb1, _ = match_meta [] [] [term] [arg] in
+ let sb1 = List.sort Pervasives.compare
+ (List.filter (fun (v,_)->is_inst_var v) sb1) in
+ extend_sb sb1 sb, subst sb1 arg
+ ) playout_terms) in
+ let expand_rel atom (sb, acc) =
+ match atom with
+ | "true", [arg] ->
+ List.map (fun (sb,arg) -> sb, ("true",[arg])::acc) (expand sb arg)
+ | rel, args -> [sb, (rel, List.map (subst sb) args)::acc] in
+ let expand_neg sb (vs, neg_conj) =
+ let neg_conjs =
+ Aux.concat_foldr expand_rel neg_conj [sb, []] in
+ List.map (fun (sb, neg_conj) ->
+ let vs = List.filter (fun v -> not (List.mem_assoc v sb))
+ (Aux.Strings.elements vs) in
+ Aux.strings_of_list vs, neg_conj
+ ) neg_conjs in
+ let brs =
+ Aux.concat_map (function ([head],body,neg_body) ->
+ Aux.concat_map (fun (sb,head) ->
+ let bodies = Aux.concat_foldr expand_rel body [sb, []] in
+ Aux.map_some (fun (sb, body) ->
+ let head = subst sb head in
+ let body = List.map (subst_rel sb) body in
+ let neg_body =
+ Aux.concat_map (expand_neg sb) neg_body in
+ if List.exists (function _, [] -> true | _ -> false)
+ neg_body then None
+ (* need to pack head into a list for [freshen_branch] *)
+ else Some ((* sb, *)([head], body, neg_body))) bodies)
+ (if head = Const "_IGNORE_RHS_" then [[], head]
+ else expand [] head)
+ | _ -> assert false) brs in
+ match freshen_unfixed with
+ | Aux.Left true ->
+ List.map (fun ((* sb, *) br) -> (* sb, *) freshen_branch br) brs
+ | _ -> brs
+
let translate_game player_term game_descr =
- freshen_count := 0;
+ var_support := Aux.Strings.empty;
let player_terms =
Array.of_list
(Aux.map_some (function Role p -> Some p | _ -> None) game_descr) in
@@ -1811,6 +1895,8 @@
done;
loc_noops in
(* 6 *)
+ (* TODO: perhaps simplify by using [Aux.concat_foldr], as in
+ [expand_branch_vars] above. *)
let expand_roles rules =
Aux.concat_map (fun (head, body, neg_body as br) ->
let roles, body =
@@ -2652,6 +2738,10 @@
List.map (function
| [], body, neg_body -> [Const "_IGNORE_RHS_"], body, neg_body
| _ -> assert false) terminal_rules in
+ (* 7n1 *)
+ let terminal_brs =
+ expand_branch_vars masks element_terms
+ ~freshen_unfixed:(Aux.Left true) terminal_brs in
let terminal_uni_vars, terminal_4b, terminal_brs =
translate_branches struc masks static_rnames dyn_rels terminal_brs in
let terminal_disjs = List.map (fun ((_,_,conjs),_) ->
Modified: trunk/Toss/GGP/GDLParser.mly
===================================================================
--- trunk/Toss/GGP/GDLParser.mly 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/GGP/GDLParser.mly 2011-02-24 02:15:08 UTC (rev 1328)
@@ -35,7 +35,9 @@
"GDL: Syntax error in term." }
atom:
-| r=WORD { Rel (r, []) }
+| r=WORD {
+ if r="TERMINAL" then Rel ("terminal", [])
+ else Rel (r, []) }
| sexp=delimited (OPEN, list (term), CLOSE)
{ match sexp with
| (Const "distinct" | Const "DISTINCT")::args ->
@@ -44,6 +46,18 @@
Currently arg
| [(Const "does" | Const "DOES"); player; action] ->
Does (player, action)
+ | (Const "role" | Const "ROLE")::player ->
+ Rel ("role", player)
+ | (Const "init" | Const "INIT")::state ->
+ Rel ("init", state)
+ | (Const "next" | Const "NEXT")::state ->
+ Rel ("next", state)
+ | (Const "terminal" | Const "TERMINAL")::no_arg ->
+ Rel ("terminal", no_arg)
+ | (Const "legal" | Const "LEGAL")::args ->
+ Rel ("legal", args)
+ | (Const "goal" | Const "GOAL")::args ->
+ Rel ("goal", args)
| Const r::args -> Rel (r, args)
| _ -> raise (Lexer.Parsing_error "GDL atom: not a constant head")
}
@@ -59,26 +73,26 @@
game_descr_entry:
| OPEN REVIMPL head=atom body=list (literal) CLOSE
{ match head with
- | Rel ("next", [t]) | Rel ("NEXT", [t]) -> Next (t, body)
- | Rel ("next", _) | Rel ("NEXT", _) ->
+ | Rel ("next", [t]) -> Next (t, body)
+ | Rel ("next", _) ->
raise (Lexer.Parsing_error "GDL next: not unary")
- | Rel ("init", [arg]) | Rel ("INIT", [arg]) -> Initial (arg, body)
- | Rel ("init", _) | Rel ("INIT", _) ->
+ | Rel ("init", [arg]) -> Initial (arg, body)
+ | Rel ("init", _) ->
raise (Lexer.Parsing_error "GDL init: not unary")
- | Rel ("terminal", []) | Rel ("TERMINAL", []) -> Terminal body
- | Rel ("terminal", _) | Rel ("TERMINAL", _) ->
+ | Rel ("terminal", []) -> Terminal body
+ | Rel ("terminal", _) ->
raise (Lexer.Parsing_error "GDL terminal: not nullary")
- | Rel ("legal", [t1; t2]) | Rel ("LEGAL", [t1; t2]) ->
+ | Rel ("legal", [t1; t2]) ->
Legal (t1, t2, body)
- | Rel ("legal", _) | Rel ("LEGAL", _) ->
+ | Rel ("legal", _) ->
raise (Lexer.Parsing_error "GDL legal: not binary")
- | Rel ("goal", [t; Const gv]) | Rel ("GOAL", [t; Const gv]) ->
+ | Rel ("goal", [t; Const gv]) ->
(try
let gv = int_of_string gv in
Goal (t, gv, body)
with Failure _ | Invalid_argument _ ->
raise (Lexer.Parsing_error "GDL goal: value not a constant int"))
- | Rel ("goal", [t; Var gv]) | Rel ("GOAL", [t; Var gv]) ->
+ | Rel ("goal", [t; Var gv]) ->
(try
GoalPattern (t, gv, body)
with Failure _ | Invalid_argument _ ->
@@ -96,10 +110,10 @@
}
| a=atom
{ match a with
- | (Rel ("init", [arg]) | Rel ("INIT", [arg])) -> Initial (arg, [])
- | (Rel ("init", _) | Rel ("INIT", _)) ->
+ | (Rel ("init", [arg])) -> Initial (arg, [])
+ | (Rel ("init", _)) ->
raise (Lexer.Parsing_error "GDL init: not unary")
- | (Rel ("role", [arg]) | Rel ("ROLE", [arg])) -> Role arg
+ | (Rel ("role", [arg])) -> Role arg
| (Rel ("role", _) | Rel ("ROLE", _)) ->
raise (Lexer.Parsing_error "GDL role: not unary")
| Rel (r, args) -> Atomic (r, args)
Modified: trunk/Toss/Server/ServerGDLTest.in
===================================================================
--- trunk/Toss/Server/ServerGDLTest.in 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/Server/ServerGDLTest.in 2011-02-24 02:15:08 UTC (rev 1328)
@@ -3,9 +3,9 @@
Sender: GAMEMASTER
Receiver: GAMEPLAYER
Content-type: text/acl
-Content-length: 1661
+Content-length: 1721
-(START MATCH.3316980891 XPLAYER ((ROLE XPLAYER) (ROLE OPLAYER) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL XPLAYER)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL XPLAYER)) (TRUE (CONTROL OPLAYER))) (<= (NEXT (CONTROL OPLAYER)) (TRUE (CONTROL XPLAYER))) (<= (ROW ?X ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= (GOAL ?PLAYER 0) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) OPEN) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30)
+(START MATCH.3316980891 XPLAYER ((ROLE XPLAYER) (ROLE OPLAYER) (INIT (CELL 1 1 B)) (INIT (CELL 1 2 B)) (INIT (CELL 1 3 B)) (INIT (CELL 2 1 B)) (INIT (CELL 2 2 B)) (INIT (CELL 2 3 B)) (INIT (CELL 3 1 B)) (INIT (CELL 3 2 B)) (INIT (CELL 3 3 B)) (INIT (CONTROL XPLAYER)) (<= (NEXT (CELL ?X ?Y ?PLAYER)) (DOES ?PLAYER (MARK ?X ?Y))) (<= (NEXT (CELL ?X ?Y ?MARK)) (TRUE (CELL ?X ?Y ?MARK)) (DOES ?PLAYER (MARK ?M ?N)) (DISTINCTCELL ?X ?Y ?M ?N)) (<= (NEXT (CONTROL XPLAYER)) (TRUE (CONTROL OPLAYER))) (<= (NEXT (CONTROL OPLAYER)) (TRUE (CONTROL XPLAYER))) (<= (ROW ?X ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL ?X 1 ?PLAYER)) (TRUE (CELL ?X 2 ?PLAYER)) (TRUE (CELL ?X 3 ?PLAYER))) (<= (COLUMN ?Y ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 ?Y ?PLAYER)) (TRUE (CELL 2 ?Y ?PLAYER)) (TRUE (CELL 3 ?Y ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 1 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 3 ?PLAYER))) (<= (DIAGONAL ?PLAYER) (ROLE ?PLAYER) (TRUE (CELL 1 3 ?PLAYER)) (TRUE (CELL 2 2 ?PLAYER)) (TRUE (CELL 3 1 ?PLAYER))) (<= (LINE ?PLAYER) (ROW ?X ?PLAYER)) (<= (LINE ?PLAYER) (COLUMN ?Y ?PLAYER)) (<= (LINE ?PLAYER) (DIAGONAL ?PLAYER)) (<= OPEN (TRUE (CELL ?X ?Y B))) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?X ?M)) (<= (DISTINCTCELL ?X ?Y ?M ?N) (DISTINCT ?Y ?N)) (<= (LEGAL ?PLAYER (MARK ?X ?Y)) (TRUE (CELL ?X ?Y B)) (TRUE (CONTROL ?PLAYER))) (<= (LEGAL ?PLAYER NOOP) (NOT (TRUE (CONTROL ?PLAYER)))) (<= (GOAL ?PLAYER 100) (LINE ?PLAYER)) (<= (GOAL ?PLAYER 50) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) (NOT OPEN)) (<= (GOAL ?PLAYER1 0) (LINE ?PLAYER2) (DISTINCT ?PLAYER1 ?PLAYER2)) (<= (GOAL ?PLAYER 0) (NOT (LINE XPLAYER)) (NOT (LINE OPLAYER)) OPEN) (<= TERMINAL (LINE ?PLAYER)) (<= TERMINAL (NOT OPEN))) 30 30)
POST / HTTP/1.0
Accept: text/delim
Modified: trunk/Toss/Server/ServerTest.ml
===================================================================
--- trunk/Toss/Server/ServerTest.ml 2011-02-24 01:47:56 UTC (rev 1327)
+++ trunk/Toss/Server/ServerTest.ml 2011-02-24 02:15:08 UTC (rev 1328)
@@ -47,7 +47,7 @@
"ServerGDLTest.in GDL Tic-Tac-Toe automatic" >::
(fun () ->
- todo "Expanding meta-variables is still in GDL.ml's TODO.";
+ todo "real soon now...";
let old_det_suggest = !Game.deterministic_suggest in
Game.deterministic_suggest := true;
let old_translation = !GDL.manual_translation in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-24 01:48:03
|
Revision: 1327
http://toss.svn.sourceforge.net/toss/?rev=1327&view=rev
Author: lukaszkaiser
Date: 2011-02-24 01:47:56 +0000 (Thu, 24 Feb 2011)
Log Message:
-----------
GameTree experiments.
Modified Paths:
--------------
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-02-23 01:53:43 UTC (rev 1326)
+++ trunk/Toss/Play/GameTree.ml 2011-02-24 01:47:56 UTC (rev 1327)
@@ -1,13 +1,16 @@
(* Game Tree used for choosing moves. *)
let debug_level = ref 0
+let set_debug_level i = debug_level := i
(* 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 *)
+ | Leaf of Arena.game_state * int * Solver.cachetbl * 'a
+ (* leaf with state, player, cache and info *)
+ | Node of Arena.game_state * int * 'a *
(Move.move * ('a, 'b) abstract_game_tree) array
+ (* node with state, player, moves and info *)
(* Abstract tree printing function. *)
let rec str_abstract ?(depth=0) str_info str_info_terminal tree =
@@ -21,7 +24,7 @@
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)
+ | 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
@@ -37,34 +40,37 @@
(* Player in the given node. *)
let player = function
| Terminal (_, player, _) -> player
- | Leaf (_, player, _) -> player
+ | Leaf (_, player, _, _) -> player
| Node (_, player, _, _) -> player
(* State in the given node. *)
let state = function
| Terminal (state, _, _) -> state
- | Leaf (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)
+ let info, cache = info_leaf game state player in
+ Leaf (state, player, cache, info)
(* 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 _ -> raise Not_found
- | Leaf (state, player, info) ->
+ | Leaf (state, player, cache, info) ->
+ Solver.set_cache (state.Arena.struc, cache);
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 l_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in
+ let l_info, cache = info_leaf (depth+1) game leaf_s l_pl in
+ Leaf (leaf_s, l_pl, cache, l_info) 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) ->
@@ -106,14 +112,14 @@
(* Get the payoffs / heuristics array of a game tree node. *)
let node_values = function
- | Terminal (_, _, i) -> i.payoffs
- | Leaf (_, _, i) -> i.heurs
+ | Terminal (_, _, i) -> Array.map (fun p -> !cPAYOFF_AS_HEUR *. p) 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
+ | Leaf (_, _, _, i) -> i.info
| Node (_, _, i, _) -> i.info
@@ -121,8 +127,10 @@
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 res =
+ { heurs = Array.map calc heurs.(state.Arena.cur_loc);
+ info = f depth game state } in
+ (res, snd (Solver.get_cache ()))
let init game state f h = init_abstract game state (info_leaf_f f h 0)
@@ -159,12 +167,12 @@
(* Choose one of the maximizing moves (at random) given a game tree. *)
let choose_move game = function
| Terminal _ -> raise Not_found
- | Leaf (state, _, _) ->
- fst (Aux.random_elem (Array.to_list (Move.list_moves game state)))
+ | Leaf (state, _, _, _) ->
+ Aux.random_elem (Array.to_list (Move.list_moves game state))
| Node (_, p, info, succ) ->
let mval = info.heurs.(p) in
let max = Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in
- let (m, _) = Aux.random_elem max in m
+ let (m, t) = Aux.random_elem max in (m, state t)
(* ------------ MAXIMAX BY DEPTH ------------- *)
@@ -177,10 +185,9 @@
let mval child = (node_values (snd child)).(player), node_info (snd child) in
let cmp c1 c2 =
let (v1, d1), (v2, d2) = mval c1, mval c2 in
- if d1 > 4*(d2+1) then -1 else if d2 > 4*(d1+1) then 1 else
- if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in
+ if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in
let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in
- if !debug_level > 0 then
+ if !debug_level > 2 then
print_endline (Structure.str (state (snd children.(res))).Arena.struc);
res
@@ -192,8 +199,16 @@
(* Maximax unfolding upto depth. *)
let rec unfold_maximax_upto count game heur t =
- if count = 0 then t else
+ if count = 0 || Game.get_timeout () then t else
try
let u = unfold_maximax game heur t in
+ if !debug_level > 0 then Printf.printf "%d,%!" (size u);
unfold_maximax_upto (count-1) game heur u
with Not_found -> t
+
+(* Maximax unfold upto depth and choose move. *)
+let maximax_unfold_choose count game state heur =
+ let t = init game state (fun _ _ _ -> 0) heur in
+ let u = unfold_maximax_upto count game heur t in
+ if !debug_level > 1 then print_endline (str string_of_int u);
+ choose_move game u
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-02-23 01:53:43 UTC (rev 1326)
+++ trunk/Toss/Play/GameTree.mli 2011-02-24 01:47:56 UTC (rev 1327)
@@ -1,9 +1,12 @@
(** Game Tree used for choosing moves. *)
+val set_debug_level : int -> unit
+
(** 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 *)
+ | Leaf of Arena.game_state * int * Solver.cachetbl * 'a
+ (** leaf with state, player, moves and info *)
| Node of Arena.game_state * int * 'a *
(Move.move * ('a, 'b) abstract_game_tree) array
(** node with state, player, moves *)
@@ -24,12 +27,14 @@
(** Abstract initialization function. *)
val init_abstract : Arena.game -> Arena.game_state ->
- (Arena.game -> Arena.game_state -> int -> 'a) -> ('a, 'b) abstract_game_tree
+ (Arena.game -> Arena.game_state -> int -> 'a * Solver.cachetbl) ->
+ ('a, 'b) abstract_game_tree
(** Abstract game tree unfolding function, calls argument functions for work. *)
val unfold_abstract : ?depth:int -> Arena.game ->
info_terminal : (int -> Arena.game -> Arena.game_state -> int -> 'a -> 'b) ->
- info_leaf : (int -> Arena.game -> Arena.game_state -> int -> 'a) ->
+ info_leaf : (int -> Arena.game -> Arena.game_state -> int ->
+ 'a * Solver.cachetbl) ->
info_node : (int -> Arena.game -> Arena.game_state -> int ->
(Move.move * ('a, 'b) abstract_game_tree) array -> 'a) ->
choice : (int -> Arena.game -> Arena.game_state -> int -> 'a ->
@@ -69,7 +74,7 @@
(** Choose one of the maximizing moves (at random) given a game tree. *)
-val choose_move : Arena.game -> 'a game_tree -> Move.move
+val choose_move : Arena.game -> 'a game_tree -> Move.move * Arena.game_state
(** Game tree initialization. *)
@@ -97,3 +102,7 @@
(** Maximax unfolding upto depth. *)
val unfold_maximax_upto : int -> Arena.game ->
Formula.real_expr array array -> int game_tree -> int game_tree
+
+(** 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
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-02-23 01:53:43 UTC (rev 1326)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-02-24 01:47:56 UTC (rev 1327)
@@ -17,13 +17,13 @@
"abstract tree init, to string" >::
(fun () ->
let s = {Arena.struc=Structure.empty_structure(); cur_loc=0; time=0.} in
- let t = Leaf (s, 1, 5) in
+ let t = Leaf (s, 1, Hashtbl.create 1, 5) in
assert_equal ~printer:(fun x -> x)
"\n|| Leaf. Player 1 loc 0 time 0.0.\n|| [ | | ]\n|| 5"
(GameTree.str_abstract ~depth:2 string_of_int string_of_int t);
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
- let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in
+ let t = GameTree.init_abstract g s (fun _ _ _ -> 5, Hashtbl.create 1) in
assert_equal ~printer:(fun x -> x)
("\nLeaf. Player 0 loc 0 time 0.0.\n[ | P:1 {}; Q:1 {} | ] \"\n" ^
"\t \n\t. . . \n" ^
@@ -35,8 +35,9 @@
"abstract unfold, size" >::
(fun () ->
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
- let t = GameTree.init_abstract g s (fun _ _ _ -> 5) in
- let (i_t, i_l) = (fun _ _ _ _ _ -> 0), (fun _ _ _ _ -> 1) in
+ let t = GameTree.init_abstract g s (fun _ _ _ -> 5, Hashtbl.create 1) in
+ let i_t = (fun _ _ _ _ _ -> 0) in
+ let i_l = (fun _ _ _ _ -> 1, Hashtbl.create 1) in
let (i_n, ch) = (fun _ _ _ _ _ -> 2), (fun _ _ _ _ _ _ -> 0) in
let u = GameTree.unfold_abstract g i_t i_l i_n ch t in
(* print_endline (GameTree.str_abstract string_of_int string_of_int u);*)
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-02-23 01:53:43 UTC (rev 1326)
+++ trunk/Toss/Server/Server.ml 2011-02-24 01:47:56 UTC (rev 1327)
@@ -3,6 +3,7 @@
let debug_level = ref 0
let set_debug_level i =
debug_level := i;
+ GameTree.set_debug_level 1;
Game.set_debug_level i;
Heuristic.debug_level := i - 3
@@ -25,6 +26,10 @@
let dtimeout = ref (-1)
let playclock = ref 0
+let g_heur = ref None
+let no_gtree = ref true
+
+
(* -------------------- GENERAL SERVER AND REQUEST HANDLER ------------------ *)
exception Host_not_found
@@ -376,14 +381,27 @@
play, play_state
| _ -> assert false in
ignore (Unix.alarm (!playclock - time_used - 2));
- let res = Game.suggest p ps in
- Game.cancel_timeout ();
- match res with
- | Some (move, new_state) ->
- (* Do not change state yet! *)
- GDL.translate_move !gdl_transl !state
- move.Move.rule move.Move.embedding
- | None -> GDL.noop_move ~force:true !gdl_transl (snd !state)
+ if !no_gtree then
+ let res = Game.suggest p ps in
+ Game.cancel_timeout ();
+ match res with
+ | Some (move, _) ->
+ (* Do not change state yet! *)
+ GDL.translate_move !gdl_transl !state
+ move.Move.rule move.Move.embedding
+ | None -> GDL.noop_move ~force:true !gdl_transl (snd !state)
+ else
+ let heur = match !g_heur with
+ | Some h -> h
+ | None ->
+ let h = Heuristic.default_heuristic
+ ~struc:(snd !state).Arena.struc ~advr:4. (fst !state) in
+ g_heur := Some h; h in
+ let (move, _) = GameTree.maximax_unfold_choose 5500
+ (fst !state) (snd !state) heur in
+ Game.cancel_timeout ();
+ GDL.translate_move !gdl_transl !state
+ move.Move.rule move.Move.embedding
) else (
Gc.compact ();
GDL.noop_move !gdl_transl (snd !state)
@@ -453,9 +471,43 @@
print_heur_arr harr;) heur
;;
+let do_play game state depth1 depth2 advr heur1 heur2 =
+ let play = {Game.game = game; agents=
+ [| Game.default_maximax state.Arena.struc ~depth:depth1
+ ~heuristic:heur1 ~advr ~pruning:true game;
+ Game.default_maximax state.Arena.struc ~depth:depth2
+ ~heuristic:heur2 ~advr ~pruning:true game;
+ |]; delta = 2.0} in (* FIXME: give/calc delta *)
+ let init_pl s = Game.initial_state ~loc:s.Arena.cur_loc play s.Arena.struc in
+ let cur_state = ref state in
+ while Array.length (Move.list_moves game !cur_state) > 0 do
+ let pl =game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.player in
+ let depth = if pl = 0 then depth1 else if pl = 1 then depth2 else
+ failwith "only 2-player games supported in experiments for now" in
+ if depth < 12 then (
+ match Game.suggest ~effort:depth play (init_pl !cur_state) with
+ | None -> Game.set_debug_level 0; failwith "no suggestion"
+ | Some (mv, _) ->
+ Game.set_debug_level 0;
+ let (_, new_state) = Move.make_move mv (game, !cur_state) in
+ cur_state := new_state;
+ ) else (
+ let heur = if pl = 0 then heur1 else heur2 in
+ GameTree.set_debug_level 1;
+ let (_, s) = GameTree.maximax_unfold_choose depth game !cur_state heur in
+ GameTree.set_debug_level 0;
+ cur_state := s
+ );
+ print_endline ("State: " ^ (Structure.str !cur_state.Arena.struc));
+ print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter));
+ Solver.eval_counter := 0;
+ done;
+ let payoffs = game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.payoffs_pp in
+ Array.map (fun p -> Solver.M.get_real_val p (!cur_state).Arena.struc) payoffs
+;;
+
let run_test n depth1 depth2 =
- let (horizon, advr) = (Some 400, 2.0) in
- let struc = (snd !state).Arena.struc in
+ let advr = 2.0 in
let game = fst !state in
let heur1 =
if (!heur_val_white1 = "MIX" || !heur_val_black1 = "MIX") then
@@ -480,21 +532,12 @@
Heuristic.default_heuristic_old ~struc:(snd !state).Arena.struc
~advr:advr game in
if !debug_level > 0 then (print_heur "1" heur1; print_heur "2" heur2);
- let play = {Game.game = game; agents=
- [| Game.default_maximax (snd !state).Arena.struc ~depth:depth1
- ~heuristic:heur1 ~advr ~pruning:true game;
- Game.default_maximax (snd !state).Arena.struc ~depth:depth2
- ~heuristic:heur2 ~advr ~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:Move.cGRID_SIZE ~set_timer:3600
- ?horizon play init_state in
+ let payoff = do_play game (snd !state) depth1 depth2 advr heur1 heur2 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);
@@ -533,6 +576,7 @@
"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");
+ ("-gtree", Arg.Unit (fun () -> no_gtree := false), "use GameTree module");
("-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)],
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-02-23 01:53:43 UTC (rev 1326)
+++ trunk/Toss/Solver/Solver.ml 2011-02-24 01:47:56 UTC (rev 1327)
@@ -10,9 +10,15 @@
(* CACHE *)
+type cachetbl = (Formula.formula, Assignments.assignment_set) Hashtbl.t
+
let cache_struc = ref (empty_structure ())
-let cache_results = Hashtbl.create 15;
+let cache_results = ref (Hashtbl.create 15)
+let get_cache () = (!cache_struc, Hashtbl.copy !cache_results)
+let set_cache (struc, res) = cache_struc := struc; cache_results := res
+
+
(* ----------------------- BASIC TYPE DEFINITION -------------------------- *)
@@ -224,19 +230,22 @@
let (b, nl) = assoc_del x l in
(b, pair :: nl)
+let eval_counter = ref 0
+
(* Eval with very basic caching. *)
let eval_m struc phi =
if phi = And [] then Any else
if !cache_struc != struc then (
let els = Set (Elems.cardinal struc.elements, struc.elements) in
let asg = eval struc (ref els) Any phi in
+ incr eval_counter;
cache_struc := struc;
- Hashtbl.clear cache_results;
- Hashtbl.add cache_results phi asg;
+ Hashtbl.clear !cache_results;
+ Hashtbl.add !cache_results phi asg;
asg
) else
try
- let res = Hashtbl.find cache_results phi in
+ let res = Hashtbl.find !cache_results phi in
if !debug_level > 1 then (
print_endline ("found in cache: " ^ (Formula.str phi));
);
@@ -245,7 +254,8 @@
if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi));
let els = Set (Elems.cardinal struc.elements, struc.elements) in
let asg = eval struc (ref els) Any phi in
- Hashtbl.add cache_results phi asg;
+ incr eval_counter;
+ Hashtbl.add !cache_results phi asg;
asg
(* Helper function, assignment of tuple. *)
@@ -367,6 +377,7 @@
let elems =
ref (Set (Elems.cardinal struc.elements, struc.elements)) in
let phi = Hashtbl.find solver.formulas_eval formula in
+ incr eval_counter;
eval struc elems fo_aset phi
(* Interface to {!SolverIntf}. *)
@@ -385,6 +396,7 @@
let elems =
ref (Set (Elems.cardinal struc.elements, struc.elements)) in
let phi = Hashtbl.find solver.formulas_eval formula in
+ incr eval_counter;
eval struc elems fo_aset phi
let check_formula struc formula =
Modified: trunk/Toss/Solver/Solver.mli
===================================================================
--- trunk/Toss/Solver/Solver.mli 2011-02-23 01:53:43 UTC (rev 1326)
+++ trunk/Toss/Solver/Solver.mli 2011-02-24 01:47:56 UTC (rev 1327)
@@ -6,10 +6,15 @@
val register_formula : solver -> Formula.formula -> int
val get_formula : solver -> int -> Formula.formula
-
(** {2 Evaluation} *)
+type cachetbl = (Formula.formula, Assignments.assignment_set) Hashtbl.t
+val eval_counter : int ref
+val get_cache : unit -> Structure.structure * cachetbl
+val set_cache : Structure.structure * cachetbl -> unit
+
+
(** Evaluate i-th formula on j-th structure. *)
val evaluate : solver -> formula:int -> Structure.structure ->
Assignments.assignment_set
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-02-23 01:53:50
|
Revision: 1326
http://toss.svn.sourceforge.net/toss/?rev=1326&view=rev
Author: lukaszkaiser
Date: 2011-02-23 01:53:43 +0000 (Wed, 23 Feb 2011)
Log Message:
-----------
Remove Game.game_state (= Arena.game_state now), add Move.make_move and haev fun with GameTree.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Play/Game.ml
trunk/Toss/Play/Game.mli
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Formula/Aux.ml 2011-02-23 01:53:43 UTC (rev 1326)
@@ -47,7 +47,8 @@
(* {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 random_elem l =
+ if l = [] then raise Not_found else List.nth l (Random.int (List.length l))
let concat_map f l =
let rec cmap_f accu = function
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/Game.ml 2011-02-23 01:53:43 UTC (rev 1326)
@@ -63,21 +63,9 @@
Array.map (fun payoff ->
(0.5 +. 1./.((float_of_int n) +. 2.)) *. payoff) payoffs
-(* Analogous to {!Arena.game_state}, but without the game component. *)
-type game_state = {
- struc : Structure.structure ; (* structure state *)
- time : float ; (* current time in game *)
- loc : int ; (* positin in the game graph *)
-}
-let gen_models rules models time moves =
- let (mv, a) = Move.gen_models rules models time moves in
- (mv, Array.map (fun s -> {struc=s.Arena.struc;
- time=s.Arena.time; loc=s.Arena.cur_loc}) a)
-
-
type uctree_node = {
- node_state : game_state ;
+ node_state : Arena.game_state ;
node_stats : score ; (* playout statistic *)
node_heuristic : f_table ; (* heuristic table *)
node_bestheur : int ; (* the subtree from which
@@ -93,12 +81,12 @@
result in the same array of moves). *)
and uctree =
| Node of uctree_node
- | Leaf of game_state * score * f_table * Structure.structure
+ | Leaf of Arena.game_state * score * f_table * Structure.structure
(* once played leaf: state, time, location, score, heuristic, game-end *)
- | Tip of game_state * f_table
+ | Tip of Arena.game_state * f_table
(* unplayed leaf, with heuristic value (evaluation game
result) *)
- | Terminal of game_state * score * f_table * f_table
+ | Terminal of Arena.game_state * score * f_table * f_table
(* the score, the cache of the actual payoff table and the
heuristic *)
| TEmpty (* to be expanded in any context *)
@@ -190,7 +178,7 @@
(* The evolving state of a play. *)
type play_state = {
- game_state : game_state ;
+ game_state : Arena.game_state ;
memory : memory array ; (* player-specific history *)
}
@@ -292,17 +280,17 @@
| TEmpty -> 0
let uctree_location = function
- | Node node -> node.node_state.loc
- | Leaf (s,_,_,_) -> s.loc
- | Tip (s,_) -> s.loc
- | Terminal (s,_,_,_) -> s.loc
+ | Node node -> node.node_state.Arena.cur_loc
+ | Leaf (s,_,_,_) -> s.Arena.cur_loc
+ | Tip (s,_) -> s.Arena.cur_loc
+ | Terminal (s,_,_,_) -> s.Arena.cur_loc
| _ -> failwith "uctree_location: empty tree"
let uctree_model = function
- | Node node -> node.node_state.struc
- | Leaf (m,_,_,_) -> m.struc
- | Tip (m,_) -> m.struc
- | Terminal (m,_,_,_) -> m.struc
+ | Node node -> node.node_state.Arena.struc
+ | Leaf (m,_,_,_) -> m.Arena.struc
+ | Tip (m,_) -> m.Arena.struc
+ | Terminal (m,_,_,_) -> m.Arena.struc
| _ -> failwith "uctree_model: empty tree"
let uctree_state = function
@@ -333,7 +321,7 @@
| Node node -> node.node_endstate
| Leaf (_,_,_,r) -> r
| Tip _ -> failwith "uctree_endgame: Tip"
- | Terminal (r,_,_,_) -> r.struc
+ | Terminal (r,_,_,_) -> r.Arena.struc
| TEmpty -> failwith "uctree_endgame: TEmpty"
@@ -410,14 +398,14 @@
let player_memory = Array.map
(function Tree_search _ -> UCTree TEmpty | _ -> No_memory) agents in
{
- game_state = {loc = loc; time = 0.0; struc = model};
+ game_state = {Arena.cur_loc = loc; time = 0.0; struc = model};
memory = player_memory;
}
(* TODO: [num_players] not used (remove if not needed). *)
let update_memory_single num_players state pos = function
| No_memory -> No_memory
- | State_history history -> State_history (state.struc::history)
+ | State_history history -> State_history (state.Arena.struc::history)
| UCTree (Node node) ->
UCTree node.node_subtrees.(pos)
| UCTree _ -> UCTree TEmpty
@@ -518,7 +506,7 @@
Solver.M.get_real_val expr model) subloc.Arena.payoffs_pp
else
let state =
- {game_state={loc=evgame.ev_location; struc=model; time=time};
+ {game_state={Arena.cur_loc=evgame.ev_location; struc=model; time=time};
memory=evgame.ev_memory} in
let subplay =
{game=evgame.ev_game; agents=evgame.ev_agents; delta=evgame.ev_delta} in
@@ -530,7 +518,7 @@
(* Generate evgame scores for possible moves. *)
and gen_scores grid_size subgames moves models loc =
Array.mapi (fun pos mv ->
- let {struc=model; time=time} = models.(pos) in
+ let {Arena.struc=model; time=time} = models.(pos) in
play_evgame grid_size model time subgames.(mv.Move.next_loc)
) moves
@@ -548,16 +536,16 @@
defined_rels=defined_rels};
agents=agents; delta=delta} as play_def)
{game_state=state; memory=memory} =
- let loc = graph.(state.loc) in
+ let loc = graph.(state.Arena.cur_loc) in
let moves =
if just_payoffs then [| |]
- else Move.gen_moves grid_size rules state.struc loc in
+ else Move.gen_moves grid_size rules state.Arena.struc loc in
(* Don't forget to check after generating models as well --
postconditions! *)
if moves = [| |] then
let payoff =
Array.map (fun expr ->
- Solver.M.get_real_val expr state.struc)
+ Solver.M.get_real_val expr state.Arena.struc)
loc.Arena.payoffs_pp in
Aux.Right payoff
else
@@ -578,8 +566,8 @@
Aux.map_option
(fun (model, time, _) ->
(* ignoring shifts, i.e. animation steps *)
- {loc=mv.Move.next_loc; struc=model; time=time})
- (ContinuousRule.rewrite_single state.struc state.time
+ {Arena.cur_loc=mv.Move.next_loc; struc=model; time=time})
+ (ContinuousRule.rewrite_single state.Arena.struc state.Arena.time
mv.Move.embedding rule mv.Move.mv_time mv.Move.parameters);
incr pos
done;
@@ -587,7 +575,7 @@
| None ->
let payoff =
Array.map (fun expr ->
- Solver.M.get_real_val expr state.struc)
+ Solver.M.get_real_val expr state.Arena.struc)
loc.Arena.payoffs_pp in
Aux.Right payoff
| Some state ->
@@ -615,7 +603,7 @@
calls, with optional alpha-beta pruning *)
(* [betas] are used imperatively *)
let rec maximax_tree pre_heur prev_player betas depth
- {loc=loc; struc=model; time=time} =
+ {Arena.cur_loc = loc; struc=model; time=time} =
(* {{{ log entry *)
incr nodes_count;
size_count := !size_count + Array.length moves;
@@ -669,7 +657,7 @@
else if !timeout then
Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
else
- let moves, models = gen_models rules model time moves in
+ let moves, models = Move.gen_models rules model time moves in
let n = Array.length models in
if !timeout then
Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
@@ -750,11 +738,12 @@
aux alphas 0 in
let betas = Array.make num_players infinity in
let player = loc.Arena.player in
- let moves, models = gen_models rules state.struc state.time moves in
+ let moves, models =
+ Move.gen_models rules state.Arena.struc state.Arena.time moves in
if models = [| |] then
let payoff =
Array.map (fun expr ->
- Solver.M.get_real_val expr state.struc)
+ Solver.M.get_real_val expr state.Arena.struc)
loc.Arena.payoffs_pp in
Aux.Right payoff
else
@@ -795,7 +784,7 @@
!cur_depth;
Array.iteri (fun i score ->
Printf.printf "Structure:%s -- score %F\n"
- (Structure.str models.(i).struc) score.(player)) scores
+ (Structure.str models.(i).Arena.struc) score.(player)) scores
);
(* }}} *)
done;
@@ -811,7 +800,7 @@
if !debug_level > 1 && (depth > 1 || !debug_level > 3)
then
Printf.printf "moving to state\n%s\n%!"
- (Structure.str state.struc);
+ (Structure.str state.Arena.struc);
(* }}} *)
Aux.Left
(best, moves, memory,
@@ -879,7 +868,7 @@
(* {{{ log entry *)
if !debug_level > 1 then
Printf.printf "moving to state\n%s\n%!"
- (Structure.str state.struc);
+ (Structure.str state.Arena.struc);
(* }}} *)
memory.(loc.Arena.player) <- (UCTree (Node node));
Aux.Left
@@ -896,16 +885,17 @@
(* {{{ log entry *)
if !debug_level > 3 then printf "toss: external\n";
(* }}} *)
- let moves, models = gen_models rules state.struc state.time moves in
+ let moves, models =
+ Move.gen_models rules state.Arena.struc state.Arena.time moves in
if models = [| |] then
let payoff =
Array.map (fun expr ->
- Solver.M.get_real_val expr state.struc)
+ Solver.M.get_real_val expr state.Arena.struc)
loc.Arena.payoffs_pp in
Aux.Right payoff
else
let descriptions =
- Array.map (fun m -> Structure.str m.struc) models in
+ Array.map (fun m -> Structure.str m.Arena.struc) models in
let best = callback descriptions in
let state = models.(best) in
Aux.Left
@@ -939,7 +929,8 @@
| Aux.Left (_,_,_,state) ->
(* {{{ log entry *)
if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then
- printf "step-state:\n%s\n%!" (Structure.str state.game_state.struc);
+ printf "step-state:\n%s\n%!"
+ (Structure.str state.game_state.Arena.struc);
(* }}} *)
play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state
| Aux.Right payoff ->
@@ -948,7 +939,7 @@
printf "payoff-state:\n%a\n%!"
(Aux.array_fprint (fun f pv->fprintf f "%F" pv)) payoff;
(* }}} *)
- state.game_state.struc, discount plys payoff
+ state.game_state.Arena.struc, discount plys payoff
(* Walk up the tree selecting the optimal estimates route, and update
@@ -966,7 +957,7 @@
node_heuristic=heuristic; node_bestheur=old_bestheur;
node_endstate=endmodel; node_subtrees=subtrees
} ->
- let player = graph.(game_state.loc).Arena.player in
+ let player = graph.(game_state.Arena.cur_loc).Arena.player in
(* compute UCBs and update the best subtree *)
let ucb_scores = Array.map (fun subtree ->
let heuristic = uctree_heuristic subtree in
@@ -1006,13 +997,13 @@
}
| Leaf (game_state, score, heuristic, endmodel) ->
- let player = graph.(game_state.loc).Arena.player in
+ let player = graph.(game_state.Arena.cur_loc).Arena.player in
expand_uctree grid_size play_def game_state ~score subgames
evgame_horizon params.heur_effect heuristic params.horizon
params.cooperative player
| Tip (game_state, heuristic) ->
- let player = graph.(game_state.loc).Arena.player in
+ let player = graph.(game_state.Arena.cur_loc).Arena.player in
expand_uctree grid_size play_def game_state subgames evgame_horizon
params.heur_effect heuristic params.horizon params.cooperative
player
@@ -1039,22 +1030,23 @@
delta=delta} as play_def)
state ?score subgames evgame_horizon heur_effect heuristic
horizon cooperative player =
- let location = graph.(state.loc) in
- let moves = Move.gen_moves grid_size rules state.struc location in
+ let location = graph.(state.Arena.cur_loc) in
+ let moves = Move.gen_moves grid_size rules state.Arena.struc location in
if moves = [| |] then
let payoff =
Array.map (fun expr ->
- Solver.M.get_real_val expr state.struc)
+ Solver.M.get_real_val expr state.Arena.struc)
location.Arena.payoffs_pp in
let upscore = score_payoff payoff in
upscore, Terminal (state, upscore, heuristic, payoff)
else
- let moves, models = gen_models rules state.struc state.time moves in
+ let moves, models =
+ Move.gen_models rules state.Arena.struc state.Arena.time moves in
if models = [| |] then
let payoff =
Array.map (fun expr ->
- Solver.M.get_real_val expr state.struc)
+ Solver.M.get_real_val expr state.Arena.struc)
location.Arena.payoffs_pp in
let upscore = score_payoff payoff in
upscore, Terminal (state, upscore, heuristic, payoff)
@@ -1085,11 +1077,11 @@
| None -> upscore
| Some score -> add_score score upscore in
subtrees.(best) <-
- Leaf (next_state, upscore, heuristics.(best), next_state.struc);
+ Leaf (next_state, upscore, heuristics.(best), next_state.Arena.struc);
(upscore,
Node {
node_state=next_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=next_state.struc;
+ node_heuristic=heuristic; node_endstate=next_state.Arena.struc;
node_subtrees=subtrees; node_bestheur=bestheur;
})
else
Modified: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/Game.mli 2011-02-23 01:53:43 UTC (rev 1326)
@@ -85,16 +85,9 @@
structures and return the position of the desired state; for
interacting with external players only *)
-(** Analogous to {!Arena.game_state}. *)
-type game_state = {
- struc : Structure.structure ; (** structure state *)
- time : float ; (** current time in game *)
- loc : int ; (** positin in the game graph *)
-}
-
(** The evolving state of a play. *)
type play_state = {
- game_state : game_state ;
+ game_state : Arena.game_state ;
memory : memory array ; (** player-specific history *)
}
@@ -134,7 +127,7 @@
(** 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 -> game_state -> int ->
+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
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/GameTree.ml 2011-02-23 01:53:43 UTC (rev 1326)
@@ -1,5 +1,6 @@
(* Game Tree used for choosing moves. *)
+let debug_level = ref 0
(* Abstract game tree, just stores state and move information. *)
type ('a, 'b) abstract_game_tree =
@@ -55,7 +56,7 @@
(* 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
+ | Terminal _ -> raise Not_found
| Leaf (state, player, info) ->
let moves = Move.list_moves game state in
if moves = [||] then
@@ -116,7 +117,6 @@
| Node (_, _, i, _) -> i.info
-
(* Game tree initialization. *)
let info_leaf_f f heurs depth game state player =
let calc re =
@@ -156,31 +156,44 @@
~info_node:(info_node_f info_node)
~choice:choice
+(* Choose one of the maximizing moves (at random) given a game tree. *)
+let choose_move game = function
+ | Terminal _ -> raise Not_found
+ | Leaf (state, _, _) ->
+ fst (Aux.random_elem (Array.to_list (Move.list_moves game state)))
+ | Node (_, p, info, succ) ->
+ let mval = info.heurs.(p) in
+ let max = Aux.array_find_all (fun (_,c) -> (node_values c).(p)=mval) succ in
+ let (m, _) = Aux.random_elem max in m
+
(* ------------ 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 maxdepth_node dp player heurs children =
+ let depths = Array.map (fun child -> (node_info (snd child))) children in
+ (Array.fold_left (fun m d -> max m d) 0 depths) + 1
-let depth_maximax_choice maxdp dp game state player info children =
- let mval child = (node_values (snd child)).(player) in
- let (max_val, unready) = (info.heurs.(player), ref []) in
- Array.iteri (fun i c -> if not (node_info (snd c)) then
- unready:= i::!unready) children; (* TODO: reordering, alpha-beta *)
- if !unready = [] then raise Not_found else List.hd !unready
+let maximax_depth_choice dp game cur_state player info children =
+ let mval child = (node_values (snd child)).(player), node_info (snd child) in
+ let cmp c1 c2 =
+ let (v1, d1), (v2, d2) = mval c1, mval c2 in
+ if d1 > 4*(d2+1) then -1 else if d2 > 4*(d1+1) then 1 else
+ if v1 > v2 then 1 else if v2 > v1 then -1 else d1 - d2 in
+ let res = Aux.random_elem (Aux.array_argfind_all_max cmp children) in
+ if !debug_level > 0 then
+ print_endline (Structure.str (state (snd children.(res))).Arena.struc);
+ res
(* Maximax by depth unfolding function. Throws Not_found if ready. *)
-let unfold_maximax_depth dp game heur =
- unfold game heur ~info_leaf:(depth_ready_leaf dp)
- ~info_node:(depth_ready_node dp) ~choice:(depth_maximax_choice dp)
+let unfold_maximax game heur =
+ unfold game heur ~info_leaf:(fun _ _ _ -> 0)
+ ~info_node:(maxdepth_node) ~choice:(maximax_depth_choice)
(* Maximax unfolding upto depth. *)
-let rec unfold_maximax_upto dp game heur t =
- try
- let u = unfold_maximax_depth dp game heur t in
- unfold_maximax_upto dp game heur u
- with Not_found -> t
+let rec unfold_maximax_upto count game heur t =
+ if count = 0 then t else
+ try
+ let u = unfold_maximax game heur t in
+ unfold_maximax_upto (count-1) game heur u
+ with Not_found -> t
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/GameTree.mli 2011-02-23 01:53:43 UTC (rev 1326)
@@ -68,6 +68,10 @@
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
+
+
(** Game tree initialization. *)
val init : Arena.game -> Arena.game_state ->
(int -> Arena.game -> Arena.game_state -> 'a) ->
@@ -86,10 +90,10 @@
(** ------------ MAXIMAX BY DEPTH ------------- *)
(** Maximax by depth unfolding function. Throws Not_found if ready. *)
-val unfold_maximax_depth : int -> Arena.game ->
- Formula.real_expr array array -> bool game_tree -> bool game_tree
+val unfold_maximax : Arena.game ->
+ Formula.real_expr array array -> int game_tree -> int game_tree
(** Maximax unfolding upto depth. *)
val unfold_maximax_upto : int -> Arena.game ->
- Formula.real_expr array array -> bool game_tree -> bool game_tree
+ Formula.real_expr array array -> int game_tree -> int game_tree
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-02-23 01:53:43 UTC (rev 1326)
@@ -60,21 +60,20 @@
(fun () ->
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 _ _ _ -> false) h in
- let u = GameTree.unfold_maximax_depth 1 g h t in
- (* print_endline (GameTree.str string_of_bool u); *)
- assert_equal ~printer:(fun x -> string_of_bool x) true
- (GameTree.node_info u)
+ let t = GameTree.init g s (fun _ _ _ -> 0) h in
+ let u = GameTree.unfold_maximax g h t in
+ (* print_endline (GameTree.str string_of_int u); *)
+ assert_equal ~printer:(fun x -> string_of_int x) 1 (GameTree.node_info u)
);
"maximax unfold upto depth, size" >::
(fun () ->
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 _ _ _ -> false) h in
- let u = GameTree.unfold_maximax_upto 2 g h t in
- (* print_endline (GameTree.str string_of_bool u); *)
- assert_equal ~printer:(fun x -> string_of_int x) 82 (GameTree.size u)
+ let t = GameTree.init g s (fun _ _ _ -> 0) h in
+ let u = GameTree.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)
);
]
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/Move.ml 2011-02-23 01:53:43 UTC (rev 1326)
@@ -14,7 +14,13 @@
embedding : (int * int) list ;
}
+(* Make a move in a game. *)
+let make_move m (game, state) =
+ let req = Arena.ApplyRuleInt (m.rule, m.embedding, m.mv_time, m.parameters) in
+ let (new_game, new_state), _ = Arena.handle_request (game, state) req in
+ (new_game, { new_state with Arena.cur_loc = m.next_loc })
+
(* Print a move as string.
TODO: perhaps find a nicer syntax? See {!TestGame.move_str}. *)
let move_str rules struc move =
Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Play/Move.mli 2011-02-23 01:53:43 UTC (rev 1326)
@@ -17,7 +17,11 @@
val move_gs_str_short : Arena.game_state -> move -> string
+(** Make a move in a game. *)
+val make_move : move ->
+ Arena.game * Arena.game_state -> Arena.game * Arena.game_state
+
(** Default number of sample points per parameter in tree search.
TODO: fixed for now. *)
val cGRID_SIZE : int
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-02-22 03:24:44 UTC (rev 1325)
+++ trunk/Toss/Server/Server.ml 2011-02-23 01:53:43 UTC (rev 1326)
@@ -245,17 +245,17 @@
| Some play, Some {Game.memory=memory; game_state=pstate} ->
Game.update_memory
~num_players:play.Game.game.Arena.num_players
- {Game.struc=old_struc;
+ {Arena.struc=old_struc;
time = (snd !state).Arena.time;
- loc = (snd !state).Arena.cur_loc} pos memory
+ cur_loc = (snd !state).Arena.cur_loc} pos memory
| _ -> failwith "req_handle: impossible" 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 = {
- Game.struc = (snd new_state).Arena.struc;
- loc = moves.(pos).Move.next_loc;
+ Arena.struc = (snd new_state).Arena.struc;
+ cur_loc = moves.(pos).Move.next_loc;
time = (snd new_state).Arena.time;
} in
play_state := Some {
@@ -341,17 +341,17 @@
| Some play, Some {Game.memory=memory; game_state=pstate} ->
Game.update_memory
~num_players:play.Game.game.Arena.num_players
- {Game.struc=old_struc;
+ {Arena.struc=old_struc;
time = (snd !state).Arena.time;
- loc = (snd !state).Arena.cur_loc} pos memory
+ cur_loc = (snd !state).Arena.cur_loc} pos memory
| _ -> failwith "req_handle: impossible" 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 = {
- Game.struc = (snd new_state).Arena.struc;
- loc = moves.(pos).Move.next_loc;
+ Arena.struc = (snd new_state).Arena.struc;
+ cur_loc = moves.(pos).Move.next_loc;
time = (snd new_state).Arena.time;
} in
play_state := Some {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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] |
|
From: <luk...@us...> - 2011-02-22 01:08:55
|
Revision: 1324
http://toss.svn.sourceforge.net/toss/?rev=1324&view=rev
Author: lukstafi
Date: 2011-02-22 01:08:46 +0000 (Tue, 22 Feb 2011)
Log Message:
-----------
GDL translation related major commit. Heuristic adv-ratio separate monotonic and non-monotonic defaults, default effort parameter. All-upper/all-lower case insensitive KIF keywords. List-related helper functions.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Arena/DiscreteRule.mli
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/KIFLexer.mll
trunk/Toss/Play/Game.ml
trunk/Toss/Play/Game.mli
trunk/Toss/Play/GameTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/Heuristic.mli
trunk/Toss/Server/Server.ml
trunk/Toss/Server/ServerTest.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Solver.mli
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Arena/Arena.ml 2011-02-22 01:08:46 UTC (rev 1324)
@@ -473,6 +473,8 @@
| GetRuleMatches of string (* Get matches of a rule *)
| ApplyRule of string * (string * string) list * float * (string * float) list
(* Apply rule at match for given time and with params *)
+ | ApplyRuleInt of string * (int * int) list * float * (string * float) list
+ (* Apply rule at match for given time and with params *)
| GetRuleNames (* Get names of all rules *)
| SetTime of float * float (* Set time step and time *)
| GetTime (* Get time step and time *)
@@ -858,6 +860,19 @@
| None -> (state, "ERR applying "^r_name^", postcondition fails")
with Not_found -> (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
+ 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 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")
+ )
| GetRuleNames -> (state, String.concat "; " (fst (List.split state.game.rules)))
| SetTime (tstep, t) ->
ContinuousRule.set_time_step tstep;
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Arena/Arena.mli 2011-02-22 01:08:46 UTC (rev 1324)
@@ -174,6 +174,7 @@
| GetRuleMatches of string (** Get matches of a rule *)
| ApplyRule of string * (string * string) list * float * (string * float) list
(** Apply rule at match for given time and with params *)
+ | ApplyRuleInt of string * (int * int) list * float * (string * float) list
| GetRuleNames (** Get names of rules *)
| SetTime of float * float (** Set time step and time *)
| GetTime (** Get time step and time *)
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-02-22 01:08:46 UTC (rev 1324)
@@ -176,7 +176,7 @@
Solver.M.evaluate model rule_obj.lhs_form_pp
(* Convert assignment to an embedding of the LHS structure. *)
-let assignment_to_embedding rule_obj assgn =
+let assignment_to_embedding rule_obj asgn =
List.map (fun (var,e) ->
try
elem_of_elemvar rule_obj.lhs_elem_names var, e
@@ -184,7 +184,7 @@
failwith (
"assignment_to_embedding: inconsistent rule_obj at variable "
^ var))
- assgn
+ asgn
(* Choose an arbitrary embedding of a rule from the matchings returned
by {!find_matchings} for the same structure and rewrite rule. Does
@@ -192,10 +192,10 @@
let choose_match model rule_obj matches =
let elem = Structure.Elems.choose model.Structure.elements in
let default = List.map (fun v->v,elem) rule_obj.lhs_elem_vars in
- let assgn = AssignmentSet.choose_fo default matches in
- assignment_to_embedding rule_obj assgn
+ let asgn = AssignmentSet.choose_fo default matches in
+ assignment_to_embedding rule_obj asgn
-let rec enumerate_assgns all_elems vars = function
+let rec enumerate_asgns all_elems vars = function
| AssignmentSet.Any ->
(* let all_elems = Structure.Elems.elements all_elems in *)
let elems = List.map (fun _ -> all_elems) vars in
@@ -207,19 +207,19 @@
let vars = list_remove v vars in
concat_map (fun (e,sub)->
List.map (fun tl->(v,e)::tl)
- (enumerate_assgns all_elems vars sub)) els
+ (enumerate_asgns all_elems vars sub)) els
| AssignmentSet.MSO (_, els) ->
concat_map (fun (e,sub)->
- enumerate_assgns all_elems vars sub) els
+ enumerate_asgns all_elems vars sub) els
| AssignmentSet.Real _ -> failwith "real matches unsupported"
(* Enumerate matchings returned by {!find_matchings} for the same
structure and rewrite rule. *)
let enumerate_matchings model rule matches =
let all_elems = Structure.Elems.elements model.Structure.elements in
- let assgns =
- enumerate_assgns all_elems rule.lhs_elem_vars matches in
- List.map (assignment_to_embedding rule) assgns
+ let asgns =
+ enumerate_asgns all_elems rule.lhs_elem_vars matches in
+ List.map (assignment_to_embedding rule) asgns
(* Helpers for special relations. *)
let orig_rel_of rel =
@@ -573,12 +573,12 @@
let arg_tup = Array.of_list args in
map_some (fun (brel, ar) ->
let selector = Structure.free_for_rel brel ar in
- let assgn =
+ let asgn =
Solver.M.evaluate selector rphi in
let btup = Array.init ar (fun i->i+1) in
(* [selector] has only [btup] with its elements *)
let selvars =
- enumerate_assgns (Array.to_list btup) args assgn in
+ enumerate_asgns (Array.to_list btup) args asgn in
(* inverse image of [tups] *)
let btups =
concat_map (fun tup ->
@@ -781,17 +781,17 @@
let rhs_opt_rels, rhs_rels, _ =
compile_opt_rels rhs_rels in
if List.exists (fun (drel, _) -> List.mem_assoc drel rhs_rels)
- defined_rels
+ defined_rels
then failwith
("Non-optional defined relation(s) "^
String.concat ", " (Aux.map_some (fun (drel,_) ->
if List.mem_assoc drel rhs_rels then Some drel else None)
defined_rels)
- ^" on RHS.");
+ ^" on RHS.");
(* if the rule is optimized for "nonstructural" rewriting, elements
are already renamed; raises Not_found when adding elements *)
let mapf_rn = if rlmap = None then fun x->x else
- Array.map (fun e-> List.assoc e rule_src.rule_s) in
+ Array.map (fun e-> List.assoc e rule_src.rule_s) in
(* a tuple is positive when it (possibly) has to be added: it does
not occur on the LHS *)
let rhs_pos_tuples =
@@ -799,13 +799,13 @@
rel, List.filter (fun tup ->
try
not (List.mem (mapf_rn tup)
- (try List.assoc rel lhs_pos_expanded with Not_found -> []))
+ (try List.assoc rel lhs_pos_expanded with Not_found -> []))
with Not_found -> true (* new element: has to be added *)
) tups)
rhs_rels in
let rhs_all_tups n =
List.map Array.of_list (Aux.product
- (Aux.fold_n (fun acc -> rhs_elems::acc) [] n)) in
+ (Aux.fold_n (fun acc -> rhs_elems::acc) [] n)) in
(* a tuple is negative when it has to be removed: it is in $\tau_e$
and in the LHS, but it does not occur on the RHS even optionally *)
let rhs_neg_tuples =
@@ -813,16 +813,16 @@
rel, List.filter (fun tup ->
try
(List.mem (mapf_rn tup)
- (try List.assoc rel lhs_pos_expanded with Not_found -> [])
- ||
- List.mem (mapf_rn tup)
- (try List.assoc rel lhs_opt_rels with Not_found -> []))
+ (try List.assoc rel lhs_pos_expanded with Not_found -> [])
+ ||
+ List.mem (mapf_rn tup)
+ (try List.assoc rel lhs_opt_rels with Not_found -> []))
&&
not (
(List.mem tup
- (try List.assoc rel rhs_rels with Not_found -> [])
- || List.mem tup
- (try List.assoc rel rhs_opt_rels with Not_found -> []))
+ (try List.assoc rel rhs_rels with Not_found -> [])
+ || List.mem tup
+ (try List.assoc rel rhs_opt_rels with Not_found -> []))
)
with Not_found -> false (* adding element: can't be negative *)
) (rhs_all_tups (List.assoc rel signat)))
@@ -834,8 +834,19 @@
rel, List.map (fun tup -> Array.map rhs_name_of tup) tups)
rhs_neg_tuples in
(* Optimizing the embedding formula. *)
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "compile_rule: embedding formula = %s\n%!"
+ (Formula.sprint emb)
+ );
+ (* }}} *)
let lhs_form_pp =
Solver.M.register_formula emb in
+(* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "compile_rule: done.\n%!";
+ );
+ (* }}} *)
{
lhs_elem_names = lhs_elem_names;
lhs_elem_inv_names = lhs_elem_inv_names;
@@ -865,13 +876,17 @@
List.map fst rels1 @ List.map fst rels2
@ acc)[] rules
-let translate_from_precond ~precond ~add ~del =
- let diff a b = List.filter (fun e -> not (List.mem e b)) a in
- let del = diff del add in
+(* Build a rule by translating the "add" list into the RHS structure
+ directly, and separating out from a precondition the LHS structure
+ over the [struc_vars] variables. All relations are
+ considered embedded. (Obviously, not all rules can be generated in
+ this way.) *)
+let translate_from_precond ~precond ~add ~embed ~struc_elems =
let rhs_names = Aux.unique_sorted
- (Aux.concat_map (fun (_,arg) -> Array.to_list arg) (add @ del)) in
+ (Aux.concat_map (fun (_,arg) -> Array.to_list arg) add) in
+ assert (Aux.list_diff rhs_names struc_elems = []);
let rewritable args =
- Aux.array_for_all (fun v -> List.mem (Formula.var_str v) rhs_names)
+ Aux.array_for_all (fun v -> List.mem (Formula.var_str v) struc_elems)
args in
let conjs = FormulaOps.flatten_ands precond in
let literals, conjs = Aux.partition_map (function
@@ -881,40 +896,35 @@
Left (Right (rel,args))
| phi -> Right phi) conjs in
let posi, nega = Aux.partition_choice literals in
+ (* FIXME: TODO: check and at least warn when [nega] is smaller than
+ the complement of [posi] over embedded rels *)
let precond = Formula.And conjs in
let fvars = FormulaOps.free_vars precond in
let local_vars =
List.filter (fun v->
- not (List.mem (Formula.var_str v) rhs_names)) fvars in
+ not (List.mem (Formula.var_str v) struc_elems)) fvars in
let precond =
if local_vars = [] then precond
else Formula.Ex (local_vars, precond) in
- let emb_rels = Aux.unique_sorted
- (List.map fst (add @ del) @ List.map fst nega) in
+ let emb_rels = Aux.list_inter embed
+ (Aux.unique_sorted
+ (List.map fst add @ List.map fst (posi @ nega))) in
let posi_s =
List.map (fun (rel, args) -> rel, Array.map Formula.var_str args)
posi in
- let nega_s =
- List.map (fun (rel, args) -> rel, Array.map Formula.var_str args)
- nega in
- let posi_emb =
- List.filter (fun (rel,_) -> List.mem rel emb_rels) posi_s in
- let del = List.filter (fun d -> not (List.mem d nega_s)) del in
- let rhs_struc, rhs_names =
- List.fold_left (fun (rhs_struc, rhs_names) name ->
+ let rhs_struc, struc_elems =
+ List.fold_left (fun (rhs_struc, struc_elems) name ->
let rhs_struc, elem =
Structure.add_new_elem rhs_struc ~name () in
- rhs_struc, (name, elem)::rhs_names)
- (Structure.empty_structure (), []) rhs_names in
+ rhs_struc, (name, elem)::struc_elems)
+ (Structure.empty_structure (), []) struc_elems in
let add_rels = List.fold_left (fun struc (rel, args) ->
Structure.add_rel struc rel
- (Array.map (fun n -> List.assoc n rhs_names) args)) in
+ (Array.map (fun n -> List.assoc n struc_elems) args)) in
let lhs_struc = rhs_struc in
- let rhs_struc = add_rels rhs_struc (add @ diff posi_emb del) in
+ let rhs_struc = add_rels rhs_struc add in
let lhs_struc = add_rels lhs_struc posi_s in
- let lhs_struc = add_rels lhs_struc
- (List.map (fun (rel,args) -> "_opt_"^rel, args)
- (diff del (posi_emb @ nega_s))) in
+ (* no relations are optional, righ? *)
{
lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
Modified: trunk/Toss/Arena/DiscreteRule.mli
===================================================================
--- trunk/Toss/Arena/DiscreteRule.mli 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Arena/DiscreteRule.mli 2011-02-22 01:08:46 UTC (rev 1324)
@@ -41,6 +41,7 @@
rlmap : (string * string) list option; (* rule_s on variables (?) *)
}
+val elemvar_of_elem : elem_inv_names -> int -> string
(* We call fluents the relations that can be modified by a rule. *)
val fluents : rule_obj -> string list
@@ -116,7 +117,7 @@
val translate_from_precond :
precond:Formula.formula -> add:(string * string array) list ->
- del:(string * string array) list -> rule
+ embed:string list -> struc_elems:string list -> rule
(** {2 Printing.} *)
val matching_str : matching -> string
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Formula/Aux.ml 2011-02-22 01:08:46 UTC (rev 1324)
@@ -18,6 +18,24 @@
let ints_of_list nvs =
add_ints nvs Ints.empty
+module StrMap = Map.Make
+ (struct type t = string let compare = String.compare end)
+let rec strmap_of_assoc =
+ function
+ | [] -> StrMap.empty
+ | (k,v)::tl -> StrMap.add k v (strmap_of_assoc tl)
+let strmap_filter p m =
+ StrMap.fold (fun k v acc -> if p k v then (k,v)::acc else acc) m []
+
+module IntMap = Map.Make
+ (struct type t = int let compare x y = x - y end)
+let rec intmap_of_assoc =
+ function
+ | [] -> IntMap.empty
+ | (k,v)::tl -> IntMap.add k v (intmap_of_assoc tl)
+let intmap_filter p m =
+ IntMap.fold (fun k v acc -> if p k v then (k,v)::acc else acc) m []
+
let is_digit c =
(c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') ||
(c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9')
@@ -71,6 +89,10 @@
let list_remove v l = List.filter (fun w->v<>w) l
+let list_diff a b = List.filter (fun e -> not (List.mem e b)) a
+
+let list_inter a b = List.filter (fun e -> List.mem e b) a
+
let rec rev_assoc l x = match l with
[] -> raise Not_found
| (a,b)::l -> if b = x then a else rev_assoc l x
@@ -110,6 +132,16 @@
else aux (pair :: acc) l in
aux [] l
+let rec update_assoc k v0 f l =
+ let rec aux acc = function
+ | [] -> [k, f v0]
+ | (a, b as pair) :: l ->
+ if compare a k = 0 then List.rev_append acc ((k, f b)::l)
+ else aux (pair :: acc) l in
+ aux [] l
+
+let cons e l = e::l
+
let unsome = function
| Some v -> v
| None -> raise (Invalid_argument "unsome")
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Formula/Aux.mli 2011-02-22 01:08:46 UTC (rev 1324)
@@ -11,6 +11,16 @@
val add_ints : int list -> Ints.t -> Ints.t
val ints_of_list : int list -> Ints.t
+module StrMap : Map.S with type key = string
+val strmap_of_assoc : (string * 'a) list -> 'a StrMap.t
+val strmap_filter :
+ (string -> 'a -> bool) -> 'a StrMap.t -> (string * 'a) list
+
+module IntMap : Map.S with type key = int
+val intmap_of_assoc : (int * 'a) list -> 'a IntMap.t
+val intmap_filter :
+ (int -> 'a -> bool) -> 'a IntMap.t -> (int * 'a) list
+
val is_digit : char -> bool
val fst3 : 'a * 'b * 'c -> 'a
@@ -44,6 +54,12 @@
inequality. *)
val list_remove : 'a -> 'a list -> 'a list
+(** Difference: [List.filter (fun e -> not (List.mem e b)) a]. *)
+val list_diff : 'a list -> 'a list -> 'a list
+
+(** Intersection: [list_inter a b = List.filter (fun e -> List.mem e b) a]. *)
+val list_inter : 'a list -> 'a list -> 'a list
+
(** Return first key with the given value from the key-value pairs,
using structural equality. *)
val rev_assoc : ('a * 'b) list -> 'b -> 'a
@@ -56,16 +72,24 @@
val assoc_all : 'a -> ('a * 'b) list -> 'b list
(** Replace the value of a first occurrence of a key, or place it at
- the end of the assoc list. *)
+ the end of the assoc list. Not tail-recursive. *)
val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list
(** Find the value associated with the first occurrence of the key and
- remove them from the list. Uses structural equality. *)
+ remove them from the list. Uses structural equality. Tail-recursive. *)
val pop_assoc : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list
-(** As {!Aux.pop_assoc}, but uses physical equality. *)
+(** As {!Aux.pop_assoc}, but uses physical equality. Tail-recursive. *)
val pop_assq : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list
+(** Update the value associated with the first occurrence of the key,
+ if no key is present update the given default "zero"
+ value. Tail-recursive. *)
+val update_assoc : 'a -> 'b -> ('b -> 'b) -> ('a * 'b) list -> ('a * 'b) list
+
+(** [cons e l = e::l]. *)
+val cons : 'a -> 'a list -> 'a list
+
(** unConstructors. *)
val unsome : 'a option -> 'a
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/Formula/AuxTest.ml 2011-02-22 01:08:46 UTC (rev 1324)
@@ -77,7 +77,7 @@
);
- "replace_assoc, pop_assoc, pop_assq" >::
+ "replace_assoc, pop_assoc, pop_assq, update_assoc" >::
(fun () ->
assert_equal ~printer:(print_alist (fun x -> x))
["B","f";"C","B"; "G","replaced"; "G", "T"]
@@ -111,6 +111,10 @@
Not_found
(fun () -> Aux.pop_assq g
["B","f";"G", "T0"; "C","B"; "F","Ts"]);
+
+ assert_equal ~msg:"update_assoc: two-level trie"
+ [(7, [('b', ["ha"])])]
+ (Aux.update_assoc 7 [] (Aux.update_assoc 'b' [] (Aux.cons "ha")) [])
);
"unsome, map_try" >::
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-02-19 17:22:41 UTC (rev 1323)
+++ trunk/Toss/GGP/GDL.ml 2011-02-22 01:08:46 UTC (rev 1324)
@@ -11,7 +11,8 @@
(1) Aggregate playout: generate successive states as if all moves
legal in the previous state were performed. Do not check the
- termination predicate.
+ termination predicate. To avoid ungrounded player variables, add
+ "role" filter to "legal" rules.
(1a) Reason for unsoundness: "legal" or "next" preconditions can
depend negatively on state, preventing further moves in the
@@ -35,6 +36,13 @@
(2) Arena graph: currently, only a simple cycle is allowed. The
succession of players is determined from the aggregate playout.
+ In case of problems, it should be relatively easy to expand the
+ translation to use a single location per player, and for rules to
+ determine which player is active after the rule takes effect
+ (i.e. the target location.) Once Toss has a good system for
+ simultaneous moves, we can simplify by translating into a single
+ location game, obsoleting this "chapter".
+
(2a) We need to recognize which player actually makes a move in a
state. For this we need to locate the "noop" arguments to "legal"
and "does" relations. A noop action in a location is the only
@@ -206,7 +214,7 @@
(7a) We translate each branch of the "legal" relation definition
as one or more rewrite rules. Currently, we base availability of
rules in a location on the player in the location and noop actions
- of other players in it, compared to the the "legal" definition
+ of other players in it, compared to the "legal" definition
branch (currently, we do not allow simultaneous moves). If the
branch of "legal" definition has a variable for a player, it is
instantiated for each player in the game, and the variable
@@ -293,6 +301,13 @@
(7g) Instantiate remaining unfixed variables. Implementation TODO.
+ (7g1) Duplicate non-frame rules with unfixed variables for each
+ instantiation of the unfixed variables warranted by the aggregate
+ playout. (Perhaps can be done "symbolically" to avoid explosion.)
+
+ (7g2) Then, add instantiations of frame rules for each case their
+ head term unifies with one from all the non-frame rules.
+
(7h) Introduce a new element variable for each class of "next" and
"true" terms equal modulo mask (i.e. there is a mask matching them
and they differ only at-or-below metavariables). (Remember the
@@ -401,7 +416,9 @@
The rewrite rule is generated by joining the derived conjunctions
from "next" atoms as RHS, and from bodies as the
precondition. Exactly the RHS variables are listed in the LHS
- (other variables are existentially closed in the precondition).
+ (other variables are existentially closed in the
+ precondition). All the relations that appear in either LHS or RHS
+ are considered embedded.
(7o) After the rules are translated, perform an aggregated playout
of the Toss variant of the game. Remove the rules that were never
@@ -420,8 +437,51 @@
branches from the definition). For each goal value we collect
bodies to form a disjunction.
-()
+ (9) To translate an incoming action, we:
+ (9a) find the "lead legal" term to which the "does move" ground
+ term of the current player matches;
+
+ (9b) earlier, remember which Toss variables of a rule contain which
+ fixed variables at which positions in their masks;
+
+ (9c) find anchor predicates corresponding to instantiations of the
+ "lead legal" variables, anchoring positions found by (9b) "fixed
+ var" - "mask + mask var" correspondence;
+
+ (9d) build a conjunction of anchor predicates over variables that
+ contain the fixed variable which is "instantiated" by the anchor
+ of the corresponding position, as established by (9c);
+
+ (9e) conjoin the (9d) with the "matching" formula of a rule, and
+ evaluate the result for all rules (of the located "lead legal"
+ class); only a single rule should have a match, and only a single
+ assignment should be returned; this rule with this assignment is
+ the translated move.
+
+ (10) To translate an outgoing action, we:
+
+ (10a) associate the rule with its corresponding data: the "lead
+ legal" term, the fixed variables corresponding to rule elements,
+ ...
+
+ (10b) earlier, return/store the mapping from an element to the
+ mask and subsitution that define the element;
+
+ (10c) earlier, for each rule store a mapping from fixed variables
+ to rule variables and the mask variables that in the rule variable
+ are instantiated by the fixed variables;
+
+ (10d) to determine how to instantiate the fixed variables in the
+ "lead legal" term, find the (10b) substitutions of assigned
+ elements and (10c) mask variables for fixed variables; compose the
+ maps to get fixed variable to GDL ground term mapping, each
+ "route" should give the same term.
+
+ Implementation TODO: once the LHS-RHS structures are removed from
+ the backbone and formula registration is removed, some
+ simplifications can be done in (9) and (10).
+
*)
let debug_level = ref 0
@@ -467,6 +527,47 @@
| Stop of string * term list
(* game ends here: match id, actions on previous step *)
+type tossrule_data = {
+ lead_legal : term;
+ (* the "legal"/"does" term of the player that performs the move, we
+ call its parameters "fixed variables" as they are provided externally *)
+ precond : Formula.formula;
+ (* the LHS match condition (the LHS structure and the precondition) *)
+ rhs_add : (string * string array) list;
+ (* the elements of LHS/RHS structures, corresponding to the "next"
+ terms *)
+ struc_elems : string list;
+ fixvar_elemvars :
+ (string * (term * (string * string list) list) list) list;
+ (* "state" terms indexed by variables that they contain, together
+ with the mask-path of the variable *)
+ elemvars : term Aux.StrMap.t;
+(* "state" terms indexed by Toss variable names they generate *)
+}
+
+type gdl_translation = {
+ anchor_terms :
+ (term * (string * (term * string) list) list) list;
+ (* mask path (i.e. mask+var) and a ground term to anchor predicate *)
+ tossrule_data : tossrule_data Aux.StrMap.t;
+ (* rule name to rule translation data *)
+ t_elements : term Aux.IntMap.t;
+ (* element terms (with metavariables only) *)
+ playing_as : int;
+ (* "active" player *)
+ noop_actions : term option array;
+ (* NOOP actions of "active" player indexed by locations *)
+ fluents : string list;
+}
+
+let empty_gdl_translation =
+ {anchor_terms = [];
+ tossrule_data = Aux.StrMap.empty;
+ t_elements = Aux.IntMap.empty;
+ playing_as = 0;
+ noop_actions = [||];
+ fluents = []}
+
let rec term_str = function
| Const c -> c
| Var v -> "?"^v
@@ -836,6 +937,7 @@
(* TODO: optimize by using rel-indexing (also in [aggregate_playout]).
TODO: optimize by using constant-time append data structure. *)
+(* Variables still left after saturation have universal interpretation! *)
let saturate base rules =
let instantiate_one tot_base cur_base irules =
@@ -927,7 +1029,6 @@
(List.map rules_of_defs (stratify [] (defs_of_rules rules)))
-let playing_as = ref (Const "uninitialized")
let game_description = ref []
let player_terms = ref [| |]
@@ -1115,17 +1216,39 @@
(* Collect the aggregate playout, but also the actions available in
the state. *)
+exception Playout_over
let aggregate_ply players static current rules =
let base =
Aux.map_prepend static (fun term -> "true", [term]) current in
let base = saturate (base @ static) rules in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "GDL.aggregate_ply: updated base -- %s\n%!"
+ (String.concat " " (List.map fact_str base))
+ );
+ (* }}} *)
let does = Aux.map_some (fun (rel, args) ->
if rel = "legal" then Some ("does", args) else None) base in
if (* no move *)
Aux.array_existsi (fun _ player ->
- List.for_all (function _, (actor::_) -> player <> actor | _ -> true)
+ List.for_all (function
+ |_, (Var _::_) -> false
+ | _, (actor::_) -> player <> actor | _ -> true)
does) players
- then raise Not_found
+ then (
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ let players_nomove =
+ Aux.array_find_all (fun player ->
+ List.for_all (function _, (actor::_) -> player <> actor
+ | _ -> true)
+ does) players in
+ Printf.printf
+ "GDL.aggregate_ply: playout over due to no move for %s\n%!"
+ (String.concat ", " (List.map term_str players_nomove))
+ );
+ (* }}} *)
+ raise Playout_over)
else
let step = saturate (does @ base) rules in
let step = Aux.map_some (function ("next", [arg]) -> Some arg
@@ -1136,7 +1259,13 @@
Aux.array_existsi (fun _ player -> arg=player) players -> true
| term -> List.mem term current
) step
- then raise Not_found
+ then (
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "GDL.aggregate_ply: playout over due to fixpoint\n%!";
+ );
+ (* }}} *)
+ raise Playout_over)
else
List.map snd does, step
@@ -1161,13 +1290,14 @@
(fun ((rel,_),_,_) -> List.mem rel static_rels) rules in
let static_base = saturate [] static_rules in
let state_rules =
- (* 1a *)
- if !aggregate_drop_negative then
- List.map (function
- | ("legal", _ as head), body, _ -> head, body, []
- | ("does", _ as head), body, _ -> head, body, []
- | rule -> rule) dynamic_rules
- else dynamic_rules in
+ (* 1, 1a *)
+ List.map (function
+ | ("legal", [player; _] as head), body, neg_body ->
+ head, ("role", [player])::body,
+ if !aggregate_drop_negative then [] else neg_body
+ | ("does", _ (* as head *)), body, _ -> assert false
+ (* head, body, [] *)
+ | rule -> rule) dynamic_rules in
let rec loop actions_accu state_accu step state =
(* {{{ log entry *)
if !debug_level > 0 then (
@@ -1177,17 +1307,17 @@
(let try actions, next =
aggregate_ply players static_base state state_rules in
(* {{{ log entry *)
- if !debug_level > 0 then (
- Printf.printf "aggregate_playout: state %s\n%!"
- (String.concat " " (List.map term_str next))
- );
+ if !debug_level > 0 then (
+ Printf.printf "aggregate_playout: state %s\n%!"
+ (String.concat " " (List.map term_str next))
+ );
(* }}} *)
- if step < horizon then
- loop (actions::actions_accu) (state::state_accu) (step+1) next
- else
- List.rev (actions::actions_accu),
- List.rev (next::state::state_accu)
- with Not_found ->
+ if step < horizon then
+ loop (actions::actions_accu) (state::state_accu) (step+1) next
+ else
+ List.rev (actions::actions_accu),
+ List.rev (next::state::state_accu)
+ with Playout_over ->
List.rev actions_accu, List.rev (state::state_accu)) in
(* FIXME: this is identity, right? remove *)
let init_base = saturate static_base state_rules in
@@ -1205,6 +1335,12 @@
let find_cycle cands =
+ (* {{{ log entry *)
+ if !debug_level > -1 then (
+ Printf.printf "GDL.find_cycle: %s\n%!" (String.concat ", " (
+ List.map (function Some c -> term_str c | None -> "None") cands))
+ );
+ (* }}} *)
let rec loop cycle trav pref rem path =
if cycle = [] then
let ini = [List.hd path] in
@@ -1270,12 +1406,15 @@
) masks in
let mask, sb, m_sb = match mask_cands with
| [mask, (sb, m_sb)] -> mask, sb, m_sb
- | _ -> assert false in
+ | _ ->
+ Printf.printf "GDL.term_to_blank: bad state term %s\n%!"
+ (term_str next_arg);
+ assert false in
mask, sb, m_sb, blank_out (next_arg, mask)
let toss_var masks term =
let mask, _, _, blank = term_to_blank masks term in
- mask, Formula.fo_var_of_string (term_to_name blank)
+ mask, Formula.fo_var_of_string (String.lowercase (term_to_name blank))
let translate_branches struc masks static_rnames dyn_rels
(brs : exp_def_branch list) =
@@ -1356,7 +1495,8 @@
Aux.concat_map (fun term ->
let mask, sb, m_sb, blanked = term_to_blank masks term in
Aux.map_some (function
- | v, Var t -> Some ((mask, v), (t, term))
+ | v, Var t ->
+ Some ((mask, v), (t, term))
| _ -> None) sb
) state_terms in
let path_subterms = Aux.collect path_subterms in
@@ -1460,21 +1600,19 @@
(* 7k *)
let brs =
List.map (fun (static_conjs, (next_arg,body,neg_body)) ->
- let rhs_pos_preds, rhs_possneg_preds =
- if next_arg = Const "_IGNORE_RHS_" then [], []
+ let rhs_pos_preds =
+ if next_arg = Const "_IGNORE_RHS_" then []
else
let mask, sb, m_sb, blanked = term_to_blank masks next_arg in
let rhs_elem =
- (* Formula.fo_var_of_string *) (term_to_name blanked) in
- Aux.partition_map (fun (v,t as v_sb) ->
- if t = Const "_BLANK_" then
- let neg_rels = List.assoc (mask, v) dyn_rels in
- Aux.Right (List.map (fun rel->rel, [|rhs_elem|]) neg_rels)
+ (* Formula.fo_var_of_string *)
+ (String.lowercase (term_to_name blanked)) in
+ Aux.map_some (fun (v,t as v_sb) ->
+ if t = Const "_BLANK_" then None
else
let rname = term_to_name (subst_one v_sb mask) in
- Aux.Left (rname, [|rhs_elem|])
+ Some (rname, [|rhs_elem|])
) m_sb in
- let rhs_possneg_preds = List.flatten rhs_possneg_preds in
let dyn_conjs =
Aux.concat_map (fun (rel, args) ->
if rel = "true" then
@@ -1483,22 +1621,13 @@
let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
let _, svar = toss_var masks true_arg in
- let lhs_pos_preds, lhs_possneg_preds =
- Aux.partition_map (fun (v,t as v_sb) ->
- if t = Const "_BLANK_" then
- (*
- let neg_rels = List.assoc (mask, v) dyn_rels in
- Aux.Right (List.map (fun rel->
- Formula.Rel (rel, [|svar|])) neg_rels)
- *) assert false
- else
- let rname = term_to_name (subst_one v_sb mask) in
- Aux.Left (Formula.Rel (rname, [|svar|]))
- ) m_sb in
- (*
- let lhs_possneg_preds = List.flatten lhs_possneg_preds in
- *)
- lhs_pos_preds
+ Aux.map_some (fun (v,t as v_sb) ->
+ if t = Const "_BLANK_" then
+ (* None *) assert false
+ else
+ let rname = term_to_name (subst_one v_sb mask) in
+ Some (Formula.Rel (rname, [|svar|]))
+ ) m_sb
else if List.mem rel static_rnames || rel = "_DOES_PLACEHOLDER_"
then []
else (
@@ -1548,7 +1677,7 @@
| [disj] -> Some disj
| _ -> Some (Formula.Or disjs)) neg_body in
let all_conjs = static_conjs @ dyn_conjs @ neg_conjs in
- (rhs_pos_preds, rhs_possneg_preds, static_conjs, all_conjs),
+ (rhs_pos_preds, static_conjs, all_conjs),
(next_arg, body, neg_body)) brs in
uni_toss_vars, conjs_4b, brs
@@ -1585,14 +1714,20 @@
(* }}} *)
res
-let translate_game game_descr =
+let translate_game player_term game_descr =
freshen_count := 0;
let player_terms =
Array.of_list
(Aux.map_some (function Role p -> Some p | _ -> None) game_descr) in
let players_n = Array.length player_terms in
let find_player player =
- Aux.array_argfind (fun p->p=player) player_terms in
+ try
+ Aux.array_argfind (fun p->p=player) player_terms
+ with Not_found -> failwith
+ (Printf.sprintf
+ "GDL.initialize_game: player %s not found among %s"
+ (term_str player) (String.concat ", " (
+ Array.to_list (Array.map term_str player_terms)))) in
let rules = Aux.concat_map rules_of_entry game_descr in
let static_rules, dynamic_rules, static_base, init_state,
(agg_actions, agg_states) =
@@ -1802,15 +1937,15 @@
(mask, if List.mem sb sbs then sbs else sb::sbs)::elements
) [] element_terms in
let struc = Structure.empty_structure () in
- let struc, elements =
- List.fold_left (fun (struc, elements) (mask, sbs) ->
+ let struc, elements, t_elements =
+ List.fold_left (fun (struc, elements, t_elements) (mask, sbs) ->
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "mask-elements:";
);
(* }}} *)
- let struc, m_elements =
- List.fold_left (fun (struc, m_elements) sb ->
+ let struc, m_elements, t_elements =
+ List.fold_left (fun (struc, m_elements, t_elements) sb ->
let e_term = subst sb mask in
(* {{{ log entry *)
if !debug_level > 2 then (
@@ -1819,15 +1954,16 @@
(* }}} *)
let struc, elem =
Structure.add_new_elem struc ~name:(term_to_name e_term) () in
- struc, (sb, elem)::m_elements
- ) (struc, []) sbs in
+ struc, (sb, elem)::m_elements,
+ Aux.IntMap.add elem e_term t_elements
+ ) (struc, [], t_elements) sbs in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf "\n%!";
);
(* }}} *)
- struc, (mask, m_elements)::elements
- ) (struc, []) elements in
+ struc, (mask, m_elements)::elements, t_elements
+ ) (struc, [], Aux.IntMap.empty) elements in
(* 4 *)
(* currently, position paths are approximated by variables
(non-variable positions are ignored) *)
@@ -1849,10 +1985,12 @@
List.fold_left (fun struc (brel, arity, path_tups) ->
let brel_tups = List.assoc brel static_base in
(* {{{ log entry *)
+
if !debug_level > 0 then (
Printf.printf "Translating static relation %s with %d tuples:\n%s\n%!"
brel (List.length brel_tups) (tuples_str brel_tups);
);
+
(* }}} *)
List.fold_left (fun struc ptup ->
let rname = brel ^ "__" ^ String.concat "__"
@@ -1910,10 +2048,12 @@
Structure.add_rel_name rname 2 struc in
let elems = List.assoc mask elements in
(* {{{ log entry *)
+
if !debug_level > 0 then (
Printf.printf "Adding static EQ relation %s over %d elements.\n%!"
rname (List.length elems);
);
+
(* }}} *)
let elem_tups =
List.fold_left (fun tups (sb1, e1) ->
@@ -1946,19 +2086,25 @@
Structure.add_rel_name rname 1 struc in
let elems = List.assoc mask elements in
(* {{{ log entry *)
+
if !debug_level > 0 then (
Printf.printf "Adding mask anchor predicate %s over %d elements.\n%!"
rname (List.length elems);
);
+
(* }}} *)
let elem_tups =
List.map (fun (sb, e) -> [|e|]) elems in
Structure.unsafe_add_rels struc rname elem_tups
) struc masks in
+ let anchor_terms = ref [] in
let struc = List.fold_left (fun struc (mask, elems) ->
List.fold_left (fun struc (sb, elem) ->
List.fold_left (fun struc (v,t as v_sb) ->
let rname = term_to_name (subst_one v_sb mask) in
+ anchor_terms := Aux.update_assoc mask []
+ (Aux.update_assoc v [] (Aux.update_assoc t "" (fun _ ->rname)))
+ !anchor_terms;
Structure.add_rel struc rname [|elem|]) struc sb) struc elems
) struc elements in
@@ -2304,6 +2450,7 @@
rules_brs
) joint_legal_branches
) loc_joint_legal in
+ (* 7g: (7g1) and (7g2) TODO *)
(* {{{ log entry *)
if !debug_level > 1 then (
Array.iteri (fun loc rules_brs ->
@@ -2340,7 +2487,6 @@
let uni_vars, conjs_4b, brs =
translate_branches struc masks static_rnames dyn_rels
(brs @ synth_brs) in
-
(* 7l *)
let brs = Array.of_list brs in (* indexing branches *)
let full_set = Aux.ints_of_list
@@ -2407,6 +2553,7 @@
Aux.array_existsi (fun ply states ->
if ply mod loc_n = loc then (
(* {{{ log entry *)
+
if !debug_level > 4 then (
let posi =
Aux.map_some (function
@@ -2416,6 +2563,7 @@
"Checking branch at states:\n%s\npositives:\n%s\n"
(terms_str states) (terms_str posi)
);
+
(* }}} *)
let res =
List.for_all (function
@@ -2433,51 +2581,70 @@
let cases = Aux.map_try (fun c_brs ->
let c_brs = List.map (Array.get brs) c_brs in
List.fold_left (fun
- (rhs_pos_acc, rhs_neg_acc, static_conjs_acc, conjs_acc)
- ((rhs_pos, rhs_neg, static_conjs, conjs),
- (_,body,_)) ->
+ (var_elems, struc_elems, rhs_pos_acc,
+ static_conjs_acc, conjs_acc)
+ ((rhs_pos, static_conjs, conjs),
+ (next_arg,body,_)) ->
if not (check_branch body)
then raise Not_found;
- rhs_pos @ rhs_pos_acc, rhs_neg @ rhs_neg_acc,
- static_conjs @ static_conjs_acc, conjs @ conjs_acc)
- ([],[],conjs_4b,conjs_4b) c_brs
+ let nsvar =
+ if next_arg = Const "_IGNORE_RHS_"
+ then []
+ else [Formula.var_str (snd (toss_var masks next_arg)),
+ next_arg] in
+ let var_elems =
+ List.fold_left (fun acc -> function
+ | "true", [true_arg] ->
+ let _, svar = toss_var masks true_arg in
+ (Formula.var_str svar, true_arg)::acc
+ | _ -> acc)
+ (nsvar @ var_elems) body in
+ var_elems, List.map fst nsvar @ struc_elems,
+ rhs_pos @ rhs_pos_acc,
+ static_conjs @ static_conjs_acc, conjs @ conjs_acc)
+ ([],[],[],conjs_4b,conjs_4b) c_brs
) cases in
(* 7m *)
- let cases = Aux.map_some (fun (rhs_pos,rhs_neg,static_phis,phis) ->
- if rhs_pos = [] && rhs_neg = [] then None
- else Some (
- Aux.unique_sorted rhs_pos, Aux.unique_sorted rhs_neg,
- static_phis, phis)) cases in
- let cases = Aux.map_some (fun (rhs_pos,rhs_neg,static_phis,phis) ->
- let phi = Formula.And static_phis in
- let rphi = Solver.M.register_formula phi in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- (* do not print, because it generates too many
- answers -- too little constraints per number of
- variables when considering a single branch *)
- (*
- let assgn = Solver.M.evaluate struc rphi in
- let avars = List.map Formula.var_str
- (FormulaOps.free_vars phi) in
- let atups =
- AssignmentSet.tuples struc.Structure.elements
- avars assgn in *)
- Printf.printf "evaluating: %s\n%!"
- (Formula.str phi)
- (* (List.length atups) *)
- );
- (* }}} *)
- let res = Solver.M.check_formula struc rphi in
- (* {{{ log entry *)
- if !debug_level > 4 && res then (
- Printf.printf "holds\n%!"
- );
- (* }}} *)
- if res then Some (rhs_pos, rhs_neg, phis)
- else None) cases in
- List.map (fun (rhs_pos, rhs_neg, conjs) ->
- lead, (rhs_pos, rhs_neg, lift_universal uni_vars conjs)) cases
+ let cases = Aux.map_some (
+ fun (var_elems,struc_elems,rhs_pos,static_phis,phis) ->
+ if rhs_pos = [] then None
+ else Some (
+ Aux.unique_sorted var_elems,
+ Aux.unique_sorted struc_elems,
+ Aux.unique_sorted rhs_pos,
+ static_phis, phis)) cases in
+ let cases = Aux.map_some (
+ fun (var_elems,struc_elems,rhs_pos,static_phis,phis) ->
+ let phi = Formula.And static_phis in
+ let rphi = Solver.M.register_formula phi in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ (* do not print, because it generates too many
+ answers -- too little constraints per number of
+ variables when considering a single branch *)
+ (*
+ let assgn = Solver.M.evaluate struc rphi in
+ let avars = List.map Formula.var_str
+ (FormulaOps.free_vars phi) in
+ let atups =
+ AssignmentSet.tuples struc.Structure.elements
+ avars assgn in *)
+ Printf.printf "evaluating: %s\n%!"
+ (Formula.str phi)
+ (* (List.length atups) *)
+ );
+ (* }}} *)
+ let res = Solver.M.check_formula struc rphi in
+ (* {{{ log entry *)
+ if !debug_level > 4 && res then (
+ Printf.printf "holds\n%!"
+ );
+ (* }}} *)
+ if res then Some (var_elems, struc_elems, rhs_pos, phis)
+ else None) cases in
+ List.map (fun (var_elems, struc_elems, rhs_pos, conjs) ->
+ lead, (var_elems, struc_elems, rhs_pos,
+ lift_universal uni_vars conjs)) cases
) rules_brs
) loc_next_classes in
(* 7n *)
@@ -2487,7 +2654,7 @@
| _ -> assert false) terminal_rules in
let terminal_uni_vars, terminal_4b, terminal_brs =
translate_branches struc masks static_rnames dyn_rels terminal_brs in
- let terminal_disjs = List.map (fun ((_,_,_,conjs),_) ->
+ let terminal_disjs = List.map (fun ((_,_,conjs),_) ->
let disj_vars = FormulaOps.free_vars (Formula.And conjs) in
let disj_4b =
List.filter (fun a -> List.exists (fun v->List.mem v disj_vars)
@@ -2497,8 +2664,8 @@
(disj_4b @ conjs))) terminal_brs in
let terminal_phi = Formula.Or terminal_disjs in
- let fluents = Aux.strings_of_list
- (Aux.concat_map (fun (_,drels) -> drels) dyn_rels) in
+ (* let fluents = Aux.strings_of_list
+ (Aux.concat_map (fun (_,drels) -> drels) dyn_rels) in *)
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "GDL.translate_game: terminal condition -- %s\n%!"
@@ -2538,13 +2705,14 @@
| _ -> assert false in
let goal_uni_vars, goal_4b, brs =
translate_branches struc masks static_rnames dyn_rels brs in
- let goal_disjs = List.map (fun ((_,_,_,conjs),_) ->
+ let goal_disjs = List.map (fun ((_,_,conjs),_) ->
let disj_vars = FormulaOps.free_vars (Formula.And conjs) in
let disj_4b =
List.filter (fun a -> List.exists (fun v->List.mem v disj_vars)
(FormulaOps.free_vars a)) goal_4b in
- lift_universal goal_uni_vars
- (disj_4b @ conjs)) brs in
+ let disj = lift_universal goal_uni_vars (disj_4b @ conjs) in
+ Formula.Ex (FormulaOps.free_vars disj, disj)
+ ) brs in
let guard = Formula.Or goal_disjs in
Formula.Plus (sum, Formula.Times (
Formula.Const score, Formula.Char guard))
@@ -2563,47 +2731,97 @@
(* }}} *)
(* {{{ log entry *)
+
if !debug_level > 1 then (
Array.iteri (fun loc rules_brs ->
Printf.printf "Rule translations for loc %d:\n%!" loc;
- List.iter (fun (lead, (rhs_pos,rhs_neg,precond)) ->
+ List.iter (fun (lead, (_,_,rhs_pos,precond)) ->
Printf.printf
- "Rule-translation: player %s move %s precond:\n%s\naction:\nADD %s... DEL %s\n%!"
+ "Rule-translation: player %s move %s precond:\n%s\naction:\nADD %s\n%!"
(term_str loc_players.(loc)) (term_str lead)
(Formula.sprint precond)
(String.concat "; " (List.map proto_rel_str rhs_pos))
- (String.concat "; " (List.map proto_rel_str rhs_neg))
) rules_brs;
) loc_toss_rules;
);
+
(* }}} *)
let signature = Structure.rel_signature struc in
let payoffs = Aux.array_from_assoc
(List.map (fun (player, payoff) -> find_player player, payoff)
payoffs) in
let payoffs_pp =
- Array.map (fun pay -> Solver.M.register_real_expr pay) payoffs in
+ Array.map (fun pay ->
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "Registering payoff %s...\n%!" (Formula.real_str pay)
+ );
+ (* }}} *)
+ Solver.M.register_real_expr pay) payoffs in
+ let tossrule_data = ref Aux.StrMap.empty in
+ let fluents = Aux.concat_map snd dyn_rels in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "fluents: %s\n%!" (String.concat ", " fluents)
+ );
+ (* }}} *)
let rules_and_locations =
let rnames = ref Aux.Strings.empty in
Array.mapi (fun loc rules_brs ->
let labelled_rules =
- List.map (fun (lead, (rhs_pos,rhs_neg,precond)) ->
+ List.map (fun (lead, (var_elems,struc_elems,rhs_pos,precond)) ->
let precond =
Formula.And [precond; Formula.Not terminal_phi] in
let rname = Aux.not_conflicting_name !rnames
((term_to_name lead) ^ "_" ^ string_of_int loc) in
rnames := Aux.Strings.add rname !rnames;
+ let fixvar_elemvars =
+ List.fold_left (fun acc (evar,elem) ->
+ let mask, sb, m_sb, blank = term_to_blank masks elem in
+ List.fold_left (fun acc (path,t) ->
+ match t with
+ | Var v ->
+ Aux.update_assoc v []
+ (Aux.update_assoc mask []
+ (Aux.update_assoc path [] (Aux.cons evar))) acc
+ | _ -> acc
+ ) acc sb
+ ) [] var_elems in
+ tossrule_data :=
+ Aux.StrMap.add rname {
+ lead_legal = lead; precond = precond;
+ fixvar_elemvars = fixvar_elemvars;
+ rhs_add = rhs_pos; struc_elems = struc_elems;
+ elemvars = Aux.strmap_of_assoc var_elems}
+ !tossrule_data;
let next_loc = (loc + 1) mod loc_n in
let label = {
Arena.rule = rname;
time_in = 0.1, 0.1; parameters_in = []
}, next_loc in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "Translating rule %s into LHS/RHS structures...\n%!"
+ rname
+ );
+ (* }}} *)
let discrete =
DiscreteRule.translate_from_precond ~precond
- ~add:rhs_pos ~del:rhs_neg in
+ ~add:rhs_pos ~embed:fluents ~struc_elems in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "Making rule %s of:\n%s\n%!" rname
+ (DiscreteRule.sprint_rule discrete)
+ );
+ (* }}} *)
let rule =
ContinuousRule.make_rule signature [] discrete
[] [] ~pre:discrete.DiscreteRule.pre () in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "Rule %s done.\n%!" rname
+ );
+ (* }}} *)
label, (rname, rule)
) rules_brs in
let labels, rules = List.split labelled_rules in
@@ -2635,18 +2853,169 @@
cur_loc = 0;
data = [];
} in
+ let playing_as = find_player player_term in
+ let noop_actions =
+ Array.mapi (fun loc noops->
+ match noops.(playing_as) with
+ | Some ([lead_term], _, _) -> Some lead_term
+ | Some ([_; lead_term], _, _) -> Some lead_term
+ | _ -> None
+ ) loc_noop_legal in
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "\n\nGDL.translate_game:\n%s\n%!"
(Arena.sprint_state result)
);
(* }}} *)
- result
+ {anchor_terms = !anchor_terms;
+ tossrule_data = !tossrule_data;
+ t_elements = t_elements;
+ playing_as = playing_as;
+ noop_actions = noop_actions;
+ fluents = fluents;
+ }, result
+(*
+ (9a) find the "lead legal" term to which the "does move" ground
+ term of the current player matches;
-let player_name_terms = ref [|Const "uninit"|]
+ (9b) earlier, remember which Toss variables of a rule contain which
+ fixed variables at which positions in their masks;
+ (9c) find anchor predicates corresponding to instantiations of the
+ "lead legal" variables, anchoring positions found by (9b) "fixed
+ var" - "mask + mask var" correspondence;
+ (9d) build a conjunction of anchor predicates over variables that
+ contain the fixed variable which is "instantiated" by the anchor
+ of the corresponding position, as established by (9c);
+
+ (9e) conjoin the (9d) with the "matching" formula of a rule, and
+ evaluate the result for all rules (of the located "lead legal"
+ class); only a single rule should have a match, and only a single
+ assignment should be returned; this rule with this assignment is
+ the translated move.
+ *)
+let translate_incoming_move gdl state actions =
+ let loc = state.Arena.cur_loc in
+ let actions = Array.of_list actions in
+ let location = state.Arena.game.Arena.graph.(loc) in
+ let player_action = actions.(location.Arena.player) in
+ (* 9a *)
+ let tossrules =
+ Aux.strmap_filter (fun _ rdata ->
+ try ignore (match_meta [] [] [player_action] [rdata.lead_legal]); true
+ with Not_found -> false
+ ) gdl.tossrule_data in
+ let tossrules = Aux.collect
+ (List.map (fun (rname, rdata) ->
+ rdata.lead_legal,
+ (rname, rdata.precond, rdata.rhs_add, rdata.struc_elems,
+ rdata.fixvar_elemvars)) tossrules) in
+ let lead, tossrules =
+ match tossrules with
+ | [lead, tossrules] -> lead, tossrules
+ | _ -> assert false in
+ (* 9c *)
+ let fixed_inst, _ =
+ match_meta [] [] [player_action] [lead] in
+ let candidates = Aux.map_some (
+ fun (rname, precond, add, struc_elems, fixvar_elemvars) ->
+ (* 9d *)
+ let anchors = Aux.concat_map (fun (v,t) ->
+ let elemvars = List.assoc v fixvar_elemvars in
+ Aux.concat_map (fun (mask, pevs) ->
+ Aux.concat_map (fun (path, evs) ->
+ let pred = List.assoc t
+ (List.assoc path (List.assoc mask gdl.anchor_terms)) in
+ List.map (fun ev->
+ Formula.Rel (pred, [|Formula.fo_var_of_string
+ (String.lowercase ev)|])) evs)
+ pevs) elemvars
+ ) fixed_inst in
+ let precond = Formula.And (anchors @ [precond]) in
+ 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 asgns =
+ DiscreteRule.find_matchings state.Arena.struc rule in
+ (* faster *)
+ (* let emb =
+ DiscreteRule.choose_match state.Arena.struc rule asgns in *)
+ (* but we should check whether there's no ambiguity... *)
+ match
+ DiscreteRule.enumerate_matchings state.Arena.struc rule asgns
+ with
+ | [] -> None
+ | [emb] -> Some (rname, emb)
+ | _ -> failwith
+ ("GDL.translate_incoming_move: match ambiguity for rule "^rname)
+ ) tossrules in
+ match candidates with
+ | [rname, emb] -> rname, emb
+ | _ -> failwith
+ ("GDL.translate_incoming_move: ambiguity among rules "^
+ String.concat ", " (List.map fst candidates))
+
+
+(*
+ (10a) associate the rule with its corresponding data: the "lead
+ legal" term, the fixed variables corresponding to rule elements,
+ ...
+
+ (10b) earlier, return/store the mapping from an element to the
+ mask and subsitution that define the element;
+
+ (10c) earlier, for each rule store a mapping from fixed variables
+ to rule variables and the mask variables that in the rule variable
+ are instantiated by the fixed variables;
+
+ (10d) to determine how to instantiate the fixed variables in the
+ "lead legal" term, find the (10b) substitutions of assigned
+ elements and (10c) mask variables for fixed variables; compose the
+ maps to get fixed variable to GDL ground term mapping, each
+ "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 tossrule = Aux.StrMap.find rname gdl.tossrule_data in
+ let rule = List.assoc rname state.Arena.game.Arena.rules in
+ (* 10d *)
+ let emb = List.map (fun (v, e) ->
+ let vterm =
+ DiscreteRule.elemvar_of_elem
+ rule.ContinuousRule.compiled.DiscreteRule.lhs_elem_inv_names v in
+ Aux.StrMap.find vterm tossrule.elemvars,
+ Aux.IntMap.find e gdl.t_elements) emb in
+ let sb =
+ try
+ List.fold_left (fun sb (v_term, e_term) ->
+ fst (match_meta sb [] [e_term] [v_term])) [] emb
+ with Not_found -> failwith
+ ("GDL.translate_outgoing_move: inconsistent match for rule "
+ ^rname) in
+ 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 noop_move ?(force=false) gdl state =
+ let loc = state.Arena.cur_loc in
+ match gdl.noop_actions.(loc) with
+ | Some t -> term_str t
+ | None when force ->
+ term_str (Aux.array_map_some (fun x->x) gdl.noop_actions).(0)
+ | None -> failwith
+ ("GDL.noop_move: no NOOP move for active player at location "
+ ^string_of_int loc)
+
+
+
let manual_translation = ref true
let manual_game = ref "tictactoe"
let top_exec_path = ref "." (* path to top Toss directory *)
@@ -2657,54 +3026,59 @@
let pawn_whopping_descr = ref None
-let initialize_game_tictactoe state player game_descr startcl =
- state := state_of_file (!top_exec_path ^ "/examples/Tic-Tac-Toe.toss");
- playing_as := player;
+let initialize_game_tictactoe player game_descr startcl =
+ let state =
+ state_of_file (!top_exec_path ^ "/examples/Tic-Tac-Toe.toss") in
game_description := game_descr;
- player_name_terms := [|Const "XPLAYER"; Const "OPLAYER"|];
- let effort, horizon, heur_adv_ratio =
+ let pterms = [|Const "XPLAYER"; Const "OPLAYER"|] in
+ let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in
+ let (* effort, horizon, heur_adv_ratio *) params =
6, 100, 4.0 in
- effort, horizon, heur_adv_ratio
+ pterms, noops, state, Some params
-let initialize_game_gomoku state player game_descr startcl =
- state := state_of_file (!top_exec_path ^ "/examples/Gomoku.toss");
- playing_as := player;
+let initialize_game_gomoku player game_descr startcl =
+ let state =
+ state_of_file (!top_exec_path ^ "/examples/Gomoku.toss") in
game_description := game_descr;
- player_name_terms := [|Const "X"; Const "O"|];
+ let pterms = [|Const "X"; Const "O"|] in
+ let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in
Heuristic.use_monotonic := true;
- let effort, horizon, heur_adv_ratio =
+ let (* effort, horizon, heur_adv_ratio *) params =
4, 100, 4.0 in
- effort, horizon, heur_adv_ratio
+ pterms, noops, state, Some params
-let initialize_game_connect4 state player game_descr startcl =
- state := state_of_file (!top_exec_path ^ "/examples/Connect4.toss");
- playing_as := player;
+let initialize_game_connect4 player game_descr startcl =
+ let state =
+ state_of_file (!top_exec_path ^ "/examples/Connect4.toss") in
game_description := game_descr;
- player_name_terms := [|Const "WHITE"; Const "RED"|];
+ let pterms = [|Const "WHITE"; Const "RED"|] in
+ let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in
Heuristic.use_monotonic := false;
- let effort, horizon, heur_adv_ratio =
+ let (* effort, horizon, heur_adv_ratio *) params =
10, 100, 4.0 in
- effort, horizon, heur_adv_ratio
+ pterms, noops, state, Some params
-let initialize_game_breakthrough state player game_descr startcl =
- state := state_of_file (!top_exec_path ^ "/examples/Breakthrough.toss");
- playing_as := player;
+let initialize_game_breakthrough player game_descr startcl =
+ let state =
+ state_of_file (!top_exec_path ^ "/examples/Breakthrough.toss") in
game_description := game_descr;
- player_name_terms := [|Const "WHITE"; Const "BLACK"|];
- let effort, horizon, heur_adv_ratio =
+ let pterms = [|Const "WHITE"; Const "BLACK"|] in
+ let noops = [|Some (Const "NOOP"); Some (Const "NOOP")|] in
+ let (* effort, horizon, heur_adv_ratio *) params =
6, 100, 4.0 in
- effort, horizon, heur_adv_ratio
+ pterms, noops, state, Some params
-let initialize_game_pawn_whopping state player game_d...
[truncated message content] |
