toss-devel-svn Mailing List for Toss (Page 19)
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-01-31 23:15:01
|
Revision: 1298
http://toss.svn.sourceforge.net/toss/?rev=1298&view=rev
Author: lukstafi
Date: 2011-01-31 23:14:55 +0000 (Mon, 31 Jan 2011)
Log Message:
-----------
Iterative deepening in alpha-beta (without building the tree on the heap).
Modified Paths:
--------------
trunk/Toss/Play/Game.ml
trunk/Toss/Play/GameTest.ml
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-01-31 20:52:54 UTC (rev 1297)
+++ trunk/Toss/Play/Game.ml 2011-01-31 23:14:55 UTC (rev 1298)
@@ -785,11 +785,14 @@
let models =
gen_models rules defined_rels model time moves in
let n = Array.length models in
- if n = 0 then begin
- (* terminal position, but we need to return heuristic
- for consistency: heuristics are not bound by payoffs *)
+ if n = 0 then begin (* terminal after postconditions *)
let res =
- play_evgame grid_size model time subgames.(loc) in
+ (* play_evgame grid_size model time subgames.(loc) *)
+ Array.map (fun expr ->
+ 100000. *.
+ Solver.M.get_real_val expr state.struc)
+ location.Arena.payoffs_pp (* see [let payoff] above *)
+ in
(* {{{ log entry *)
if !debug_level > 4 then (
let player = graph.(loc).Arena.player in
@@ -864,8 +867,21 @@
loc.Arena.payoffs_pp in
Aux.Right payoff
else
+ let cur_depth = ref 0 in
let scores =
- Array.map (maximax_tree None player betas (depth-1)) models in
+ Array.map (maximax_tree None player betas !cur_depth) models in
+ while not !timeout && !cur_depth < depth do
+ (* FIXME: is using common betas OK? *)
+ let index =
+ Array.init (Array.length models) (fun i->i) in
+ Array.sort (fun j i-> compare
+ scores.(i).(player) scores.(j).(player)) index;
+ Array.iter (fun i ->
+ scores.(i) <-
+ maximax_tree None player betas !cur_depth models.(i))
+ index;
+ incr cur_depth
+ done;
let _, best =
find_best_score ~use_det_setting:true cooperative player scores
(Array.map (fun _ -> 1) scores) in
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-01-31 20:52:54 UTC (rev 1297)
+++ trunk/Toss/Play/GameTest.ml 2011-01-31 23:14:55 UTC (rev 1298)
@@ -130,6 +130,9 @@
let gomoku19x19_game =
lazy (None, 4.0, state_of_file "./examples/Gomoku19x19.toss")
+let connect4_game =
+ lazy (None, 4.0, state_of_file "./examples/Connect4.toss")
+
let breakthrough_heur_adv adv_ratio =
let expanded_win1 =
"ex y1, y2, y3, y4, y5, y6, y7, y8 (C(y1, y2) and C(y2, y3) and C(y3, y4) and C(y4, y5) and C(y5, y6) and C(y6, y7) and C(y7, y8) and W(y8))" in
@@ -800,6 +803,29 @@
(fun mov_s -> "Cross{1:d4}" = mov_s);
);
+ "connect4 endgame" >::
+ (fun () ->
+ let state = update_game connect4_game
+"[ | |
+ ] \"
+
+ . . . . . . .
+
+ . . . . . . .
+
+ Q . . . . . .
+
+ P . . . . . .
+
+ P . +Q Q . . .
+
+ P P P Q Q . .
+\"" 0 in
+ medium_case state 0 "should defend"
+ (fun mov_s -> "Cross{1:e2}" = mov_s);
+);
+
+
]
let tests = "Game" >::: [
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-31 20:53:00
|
Revision: 1297
http://toss.svn.sourceforge.net/toss/?rev=1297&view=rev
Author: lukstafi
Date: 2011-01-31 20:52:54 +0000 (Mon, 31 Jan 2011)
Log Message:
-----------
Terminal payoffs in alpha-beta hack. Minor progress in GDL translation.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/Play/Game.ml
trunk/Toss/Play/GameTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-01-31 18:22:02 UTC (rev 1296)
+++ trunk/Toss/Formula/Aux.ml 2011-01-31 20:52:54 UTC (rev 1297)
@@ -11,6 +11,13 @@
let strings_of_list nvs =
add_strings nvs Strings.empty
+module Ints = Set.Make
+ (struct type t = int let compare x y = x - y end)
+let add_ints nvs vs =
+ List.fold_left (fun vs nv -> Ints.add nv vs) vs nvs
+let ints_of_list nvs =
+ add_ints nvs Ints.empty
+
let is_digit c =
(c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') ||
(c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9')
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-01-31 18:22:02 UTC (rev 1296)
+++ trunk/Toss/Formula/Aux.mli 2011-01-31 20:52:54 UTC (rev 1297)
@@ -7,6 +7,10 @@
val add_strings : string list -> Strings.t -> Strings.t
val strings_of_list : string list -> Strings.t
+module Ints : Set.S with type elt = int
+val add_ints : int list -> Ints.t -> Ints.t
+val ints_of_list : int list -> Ints.t
+
val is_digit : char -> bool
val fst3 : 'a * 'b * 'c -> 'a
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-31 18:22:02 UTC (rev 1296)
+++ trunk/Toss/GGP/GDL.ml 2011-01-31 20:52:54 UTC (rev 1297)
@@ -478,6 +478,8 @@
module Terms = Set.Make (
struct type t = term let compare = Pervasives.compare end)
+module Atoms = Set.Make (
+ struct type t = string * term list let compare = Pervasives.compare end)
(*
let branch_vars (args, body, neg_body) =
@@ -1931,10 +1933,39 @@
Some (phi, br))
else None
| _ -> assert false) brs in
- (* to be continued... *)
+ (* 7j: TODO *)
+ (* 7k: TODO *)
+ (* 7l *)
+ let atoms =
+ List.fold_left (fun acc (_,(_,body,neg_body))->
+ List.fold_right Atoms.add body
+ (List.fold_right (List.fold_right Atoms.add)
+ neg_body acc)
+ ) Atoms.empty brs in
+ let atoms = Atoms.elements atoms in
+ let brs = Array.of_list brs in (* indexing branches *)
+ let table = List.map (fun atom ->
+ let positives = Array.mapi (fun i (_,(_,body,_)) ->
+ if List.mem atom body then Some i else None) brs in
+ let positives = Aux.map_some (fun x->x)
+ (Array.to_list positives) in
+ let negatives = Array.mapi (fun i (_,(_,_,neg_body)) ->
+ if List.exists (List.mem atom) neg_body then Some i
+ else None) brs in
+ let negatives = Aux.map_some (fun x->x)
+ (Array.to_list negatives) in
+ [Aux.Ints.empty; Aux.Ints.empty] (* TODO *)
+ ) atoms in
+ let cases = Aux.product table in
+ let full_set = Aux.ints_of_list
+ (Array.to_list (Array.mapi (fun i _ -> i) brs)) in
+ let cases =
+ List.map (List.fold_left Aux.Ints.inter full_set) cases in
+
[lead, brs]
) rules_brs
) loc_next_classes in
+ (*
(* {{{ log entry *)
if !debug_level > 1 then (
Array.iteri (fun loc rules_brs ->
@@ -1948,6 +1979,7 @@
) loc_toss_rules;
);
(* }}} *)
+ *)
struc
(*
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-01-31 18:22:02 UTC (rev 1296)
+++ trunk/Toss/Play/Game.ml 2011-01-31 20:52:54 UTC (rev 1297)
@@ -727,15 +727,17 @@
| Maximax_evgame (subgames, cooperative, depth, use_pruning) ->
(* {{{ log entry *)
+
let nodes_count = ref 0 in
let size_count = ref 1 in
let depth0 = depth in
let debug_playclock = ref 0. in
if !debug_level > 1 && depth > 1 || !debug_level > 3
then (
- printf "toss: %s%s ev game, timer started...\n%!"
+ printf "toss: %s ev game, timer started...\n%!"
(if use_pruning then "alpha_beta_ord" else "maximax");
debug_playclock := Sys.time ());
+
(* }}} *)
(* full tree search of limited depth by plain recursive
calls, with optional alpha-beta pruning *)
@@ -767,12 +769,17 @@
printf ", leaf %d heur: %F %!" player res.(player)
);
(* }}} *)
- res
+ res
) else
let location = graph.(loc) in
let moves =
gen_moves grid_size rules model location in
- if moves = [| |] || !timeout then (* terminal position *)
+ if moves = [| |] then (* terminal position *)
+ Array.map (fun expr ->
+ 100000. *.
+ Solver.M.get_real_val expr state.struc)
+ location.Arena.payoffs_pp (* see [let payoff] above *)
+ else if !timeout then
play_evgame grid_size model time subgames.(loc)
else
let models =
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-01-31 18:22:02 UTC (rev 1296)
+++ trunk/Toss/Play/GameTest.ml 2011-01-31 20:52:54 UTC (rev 1297)
@@ -857,11 +857,11 @@
let a () = run_test_tt ~verbose:true experiments
let a () =
- Server.set_debug_level 1
+ Game.set_debug_level 1
let a () =
match test_filter
- ["Game:0:misc:1:server: ServerGDLTest.in GDL Tic-Tac-Toe"]
+ [""]
tests
with
| Some tests -> ignore (run_test_tt ~verbose:true tests)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-31 18:22:08
|
Revision: 1296
http://toss.svn.sourceforge.net/toss/?rev=1296&view=rev
Author: lukaszkaiser
Date: 2011-01-31 18:22:02 +0000 (Mon, 31 Jan 2011)
Log Message:
-----------
Lower depths again.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/Makefile
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-31 01:29:45 UTC (rev 1295)
+++ trunk/Toss/GGP/GDL.ml 2011-01-31 18:22:02 UTC (rev 1296)
@@ -2001,7 +2001,7 @@
player_name_terms := [|Const "WHITE"; Const "RED"|];
Game.use_monotonic := false;
let effort, horizon, heur_adv_ratio =
- 8, 100, 4.0 in
+ 6, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game_breakthrough state player game_descr startcl =
@@ -2010,7 +2010,7 @@
game_description := game_descr;
player_name_terms := [|Const "WHITE"; Const "BLACK"|];
let effort, horizon, heur_adv_ratio =
- 4, 100, 2.0 in
+ 3, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game_pawn_whopping state player game_descr startcl =
@@ -2019,7 +2019,7 @@
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
let effort, horizon, heur_adv_ratio =
- 6, 100, 2.0 in
+ 4, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game state player game_descr startcl =
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-01-31 01:29:45 UTC (rev 1295)
+++ trunk/Toss/GGP/Makefile 2011-01-31 18:22:02 UTC (rev 1296)
@@ -17,12 +17,12 @@
%.black: examples/%.gdl ../TossServer
../TossServer -gdl unset -v &
- java -jar gamecontroller-cli.jar play $< 120 90 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
+ java -jar gamecontroller-cli.jar play $< 600 180 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
%.white: examples/%.gdl ../TossServer
../TossServer -gdl unset -v &
- java -jar gamecontroller-cli.jar play $< 120 90 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
+ java -jar gamecontroller-cli.jar play $< 600 180 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
tests:
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-31 01:29:51
|
Revision: 1295
http://toss.svn.sourceforge.net/toss/?rev=1295&view=rev
Author: lukaszkaiser
Date: 2011-01-31 01:29:45 +0000 (Mon, 31 Jan 2011)
Log Message:
-----------
Try increased depth.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-30 20:30:02 UTC (rev 1294)
+++ trunk/Toss/GGP/GDL.ml 2011-01-31 01:29:45 UTC (rev 1295)
@@ -2001,7 +2001,7 @@
player_name_terms := [|Const "WHITE"; Const "RED"|];
Game.use_monotonic := false;
let effort, horizon, heur_adv_ratio =
- 6, 100, 4.0 in
+ 8, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_breakthrough state player game_descr startcl =
@@ -2010,7 +2010,7 @@
game_description := game_descr;
player_name_terms := [|Const "WHITE"; Const "BLACK"|];
let effort, horizon, heur_adv_ratio =
- 3, 100, 2.0 in
+ 4, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game_pawn_whopping state player game_descr startcl =
@@ -2019,7 +2019,7 @@
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
let effort, horizon, heur_adv_ratio =
- 5, 100, 2.0 in
+ 6, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game state player game_descr startcl =
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-01-30 20:30:02 UTC (rev 1294)
+++ trunk/Toss/Server/Server.ml 2011-01-31 01:29:45 UTC (rev 1295)
@@ -494,7 +494,7 @@
let main () =
Gc.set { (Gc.get()) with
Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 64*1024; (* 2*std, opt ~= L2 cache/proc *)
+ Gc.minor_heap_size = 80*1024; (* 2*std, opt ~= L2 cache/proc *)
Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
let (server, port) = (ref "localhost", ref 8110) in
let opts = [
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 20:30:08
|
Revision: 1294
http://toss.svn.sourceforge.net/toss/?rev=1294&view=rev
Author: lukaszkaiser
Date: 2011-01-30 20:30:02 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
Use non-monotone heuristic for connect4, other small corrections.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/Play/Game.ml
trunk/Toss/examples/Connect4.toss
trunk/Toss/examples/PawnWhopping.toss
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-30 14:40:55 UTC (rev 1293)
+++ trunk/Toss/GGP/GDL.ml 2011-01-30 20:30:02 UTC (rev 1294)
@@ -1989,6 +1989,7 @@
playing_as := player;
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
+ Game.use_monotonic := true;
let effort, horizon, heur_adv_ratio =
2, 100, 4.0 in
effort, horizon, heur_adv_ratio
@@ -1998,8 +1999,9 @@
playing_as := player;
game_description := game_descr;
player_name_terms := [|Const "WHITE"; Const "RED"|];
+ Game.use_monotonic := false;
let effort, horizon, heur_adv_ratio =
- 5, 100, 4.0 in
+ 6, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_breakthrough state player game_descr startcl =
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-01-30 14:40:55 UTC (rev 1293)
+++ trunk/Toss/Play/Game.ml 2011-01-30 20:30:02 UTC (rev 1294)
@@ -21,7 +21,7 @@
(* {{{ log entry *)
if !debug_level > 0 then (
if !timeout then
- Printf.printf "Computation finished during timeout.\n%!"
+ Printf.printf "Computation finished by timeout.\n%!"
else
Printf.printf "Computation finished with %d seconds left.\n%!"
remaining
Modified: trunk/Toss/examples/Connect4.toss
===================================================================
--- trunk/Toss/examples/Connect4.toss 2011-01-30 14:40:55 UTC (rev 1293)
+++ trunk/Toss/examples/Connect4.toss 2011-01-30 20:30:02 UTC (rev 1294)
@@ -1,5 +1,5 @@
PLAYERS 1, 2
-DATA r1: circle, r2: line, adv_ratio: 4, depth: 1
+DATA r1: circle, r2: line, adv_ratio: 4, depth: 6
REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v)
Modified: trunk/Toss/examples/PawnWhopping.toss
===================================================================
--- trunk/Toss/examples/PawnWhopping.toss 2011-01-30 14:40:55 UTC (rev 1293)
+++ trunk/Toss/examples/PawnWhopping.toss 2011-01-30 20:30:02 UTC (rev 1294)
@@ -1,5 +1,5 @@
PLAYERS 1, 2
-DATA depth: 2, adv_ratio: 2
+DATA depth: 4, adv_ratio: 2
REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
REL IsFirst(x) = not ex z C(z, x)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 14:41:01
|
Revision: 1293
http://toss.svn.sourceforge.net/toss/?rev=1293&view=rev
Author: lukaszkaiser
Date: 2011-01-30 14:40:55 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
Back to sane depth for gomoku.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/Makefile
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-30 13:53:05 UTC (rev 1292)
+++ trunk/Toss/GGP/GDL.ml 2011-01-30 14:40:55 UTC (rev 1293)
@@ -1,3 +1,4 @@
+
(** {2 Game Description Language.}
Type definitions, helper functions, game specification
@@ -1989,7 +1990,7 @@
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
let effort, horizon, heur_adv_ratio =
- 3, 100, 4.0 in
+ 2, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_connect4 state player game_descr startcl =
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-01-30 13:53:05 UTC (rev 1292)
+++ trunk/Toss/GGP/Makefile 2011-01-30 14:40:55 UTC (rev 1293)
@@ -17,12 +17,12 @@
%.black: examples/%.gdl ../TossServer
../TossServer -gdl unset -v &
- java -jar gamecontroller-cli.jar play $< 120 30 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
+ java -jar gamecontroller-cli.jar play $< 120 90 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
%.white: examples/%.gdl ../TossServer
../TossServer -gdl unset -v &
- java -jar gamecontroller-cli.jar play $< 120 30 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
+ java -jar gamecontroller-cli.jar play $< 120 90 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
tests:
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 13:53:11
|
Revision: 1292
http://toss.svn.sourceforge.net/toss/?rev=1292&view=rev
Author: lukaszkaiser
Date: 2011-01-30 13:53:05 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
One-up all depths.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-30 03:13:54 UTC (rev 1291)
+++ trunk/Toss/GGP/GDL.ml 2011-01-30 13:53:05 UTC (rev 1292)
@@ -1980,7 +1980,7 @@
game_description := game_descr;
player_name_terms := [|Const "XPLAYER"; Const "OPLAYER"|];
let effort, horizon, heur_adv_ratio =
- 4, 100, 4.0 in
+ 5, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_gomoku state player game_descr startcl =
@@ -1989,7 +1989,7 @@
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
let effort, horizon, heur_adv_ratio =
- 2, 100, 4.0 in
+ 3, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_connect4 state player game_descr startcl =
@@ -1998,7 +1998,7 @@
game_description := game_descr;
player_name_terms := [|Const "WHITE"; Const "RED"|];
let effort, horizon, heur_adv_ratio =
- 4, 100, 4.0 in
+ 5, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_breakthrough state player game_descr startcl =
@@ -2016,7 +2016,7 @@
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
let effort, horizon, heur_adv_ratio =
- 4, 100, 2.0 in
+ 5, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game state player game_descr startcl =
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 03:14:00
|
Revision: 1291
http://toss.svn.sourceforge.net/toss/?rev=1291&view=rev
Author: lukaszkaiser
Date: 2011-01-30 03:13:54 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
Increase debug for heuristic a bit, add -vv switch.
Modified Paths:
--------------
trunk/Toss/Play/Game.ml
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-01-30 02:54:00 UTC (rev 1290)
+++ trunk/Toss/Play/Game.ml 2011-01-30 03:13:54 UTC (rev 1291)
@@ -265,7 +265,7 @@
Array.mapi (fun i node -> Array.map
(fun payoff ->
(* {{{ log entry *)
- if !debug_level > (* 5 *) 0 then (
+ if !debug_level > (* 5 *) 1 then (
Printf.printf
"default_heuristic: Computing for loc %d of payoff %s...\n%!"
i (Formula.sprint_real payoff);
@@ -279,7 +279,7 @@
Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio
frels payoff in
(* {{{ log entry *)
- if !debug_level > (* 6 *) 0 then (
+ if !debug_level > (* 6 *) 1 then (
Printf.printf "default_heuristic: %s\n%!"
(Formula.sprint_real res)
);
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-01-30 02:54:00 UTC (rev 1290)
+++ trunk/Toss/Server/Server.ml 2011-01-30 03:13:54 UTC (rev 1291)
@@ -499,6 +499,7 @@
let (server, port) = (ref "localhost", ref 8110) in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose");
+ ("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose");
("-d", Arg.Int (fun i -> set_debug_level i), " Toss server debug log level");
("-s", Arg.String (fun s -> (server := s)), " server (default: localhost)");
("-gdl", Arg.String (fun s ->
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 02:54:06
|
Revision: 1290
http://toss.svn.sourceforge.net/toss/?rev=1290&view=rev
Author: lukstafi
Date: 2011-01-30 02:54:00 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
Display heuristics at lower logging level. Optionally turn off monotonicity check.
Modified Paths:
--------------
trunk/Toss/Play/Game.ml
trunk/Toss/Play/Game.mli
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-01-30 02:27:25 UTC (rev 1289)
+++ trunk/Toss/Play/Game.ml 2011-01-30 02:54:00 UTC (rev 1290)
@@ -11,6 +11,7 @@
let set_debug_level i = (debug_level := i)
let deterministic_suggest = ref false
+let use_monotonic = ref true
(* A global "hurry up!" switch triggered by the timer alarm. *)
let timeout = ref false
@@ -248,7 +249,8 @@
List.map (fun r -> (snd r).ContinuousRule.compiled) rules in
let fluents = Aux.concat_map DiscreteRule.fluents drules in
let frels = Aux.strings_of_list fluents in
- let monotonic = List.for_all DiscreteRule.monotonic drules in
+ let monotonic = !use_monotonic &&
+ List.for_all DiscreteRule.monotonic drules in
let signat_struc =
match struc with Some struc -> struc
| None ->
@@ -263,7 +265,7 @@
Array.mapi (fun i node -> Array.map
(fun payoff ->
(* {{{ log entry *)
- if !debug_level > 5 then (
+ if !debug_level > (* 5 *) 0 then (
Printf.printf
"default_heuristic: Computing for loc %d of payoff %s...\n%!"
i (Formula.sprint_real payoff);
@@ -273,8 +275,16 @@
"default_heuristic: Computing for loc %d\n%!" i;
);
(* }}} *)
- Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio
- frels payoff)
+ let res =
+ Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio
+ frels payoff in
+ (* {{{ log entry *)
+ if !debug_level > (* 6 *) 0 then (
+ Printf.printf "default_heuristic: %s\n%!"
+ (Formula.sprint_real res)
+ );
+ (* }}} *)
+ res)
node.Arena.payoffs) graph
Modified: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli 2011-01-30 02:27:25 UTC (rev 1289)
+++ trunk/Toss/Play/Game.mli 2011-01-30 02:54:00 UTC (rev 1290)
@@ -4,8 +4,8 @@
(** A global "hurry up!" switch triggered by the timer alarm. *)
val get_timeout : unit -> bool
val cancel_timeout : unit -> unit
+val use_monotonic : bool ref
-
(** History stored for a play, including caching of computations for
further use. *)
type memory
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-01-30 02:27:25 UTC (rev 1289)
+++ trunk/Toss/Server/Server.ml 2011-01-30 02:54:00 UTC (rev 1290)
@@ -503,7 +503,8 @@
("-s", Arg.String (fun s -> (server := s)), " server (default: localhost)");
("-gdl", Arg.String (fun s ->
GDL.manual_game := s; GDL.manual_translation := true),
- " GDL game for manual (i.e. hard-coded) translation (tictactoe, gomoku, breakthrough)");
+ " GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)");
+ ("-nm", Arg.Unit (fun () -> Game.use_monotonic := false), " turn monotonicity off");
("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)");
("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)");
] in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 02:27:32
|
Revision: 1289
http://toss.svn.sourceforge.net/toss/?rev=1289&view=rev
Author: lukaszkaiser
Date: 2011-01-30 02:27:25 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
Correcting translation, tests and gdl for pawn whopping.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/Makefile
trunk/Toss/GGP/examples/pawn_whopping.gdl
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-30 00:49:08 UTC (rev 1288)
+++ trunk/Toss/GGP/GDL.ml 2011-01-30 02:27:25 UTC (rev 1289)
@@ -1980,7 +1980,7 @@
game_description := game_descr;
player_name_terms := [|Const "XPLAYER"; Const "OPLAYER"|];
let effort, horizon, heur_adv_ratio =
- 2, 100, 4.0 in
+ 4, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_gomoku state player game_descr startcl =
@@ -1998,7 +1998,7 @@
game_description := game_descr;
player_name_terms := [|Const "WHITE"; Const "RED"|];
let effort, horizon, heur_adv_ratio =
- 2, 100, 4.0 in
+ 4, 100, 4.0 in
effort, horizon, heur_adv_ratio
let initialize_game_breakthrough state player game_descr startcl =
@@ -2007,7 +2007,7 @@
game_description := game_descr;
player_name_terms := [|Const "WHITE"; Const "BLACK"|];
let effort, horizon, heur_adv_ratio =
- 2, 100, 2.0 in
+ 3, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game_pawn_whopping state player game_descr startcl =
@@ -2016,7 +2016,7 @@
game_description := game_descr;
player_name_terms := [|Const "X"; Const "O"|];
let effort, horizon, heur_adv_ratio =
- 2, 100, 2.0 in
+ 4, 100, 2.0 in
effort, horizon, heur_adv_ratio
let initialize_game state player game_descr startcl =
@@ -2121,23 +2121,36 @@
Const "NOOP"] when x1 = x2 && (s2i y2) - (s2i y1) = 1 ->
"WhiteStraight",
["a1", Structure.board_coords_name (s2i x1, s2i y1);
- "a2", Structure.board_coords_name (s2i x2, s2i y2)]
+ "a2", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Func ("MOVE", [Const x1; Const y1; Const x2; Const y2]);
+ Const "NOOP"] when x1 = x2 && (s2i y2) - (s2i y1) = 2 ->
+ "WhiteStraightTwo",
+ ["a1", Structure.board_coords_name (s2i x1, s2i y1);
+ "a2", Structure.board_coords_name (s2i x1, (s2i y1) + 1);
+ "a3", Structure.board_coords_name (s2i x2, s2i y2)]
| [Func ("CAPTURE", [Const x1; Const y1; Const x2; Const y2]);
Const "NOOP"] ->
"WhiteDiag",
["a", Structure.board_coords_name (s2i x1, s2i y1);
- "b", Structure.board_coords_name (s2i x2, s2i y2)]
+ "b", Structure.board_coords_name (s2i x2, s2i y2)]
| [Const "NOOP";
Func ("MOVE", [Const x1; Const y1; Const x2; Const y2])]
when x1 = x2 && (s2i y1) - (s2i y2) = 1 ->
"BlackStraight",
["a2", Structure.board_coords_name (s2i x1, s2i y1);
- "a1", Structure.board_coords_name (s2i x2, s2i y2)]
+ "a1", Structure.board_coords_name (s2i x2, s2i y2)]
| [Const "NOOP";
+ Func ("MOVE", [Const x1; Const y1; Const x2; Const y2])]
+ when x1 = x2 && (s2i y1) - (s2i y2) = 2 ->
+ "BlackStraightTwo",
+ ["a3", Structure.board_coords_name (s2i x1, s2i y1);
+ "a2", Structure.board_coords_name (s2i x1, (s2i y1) - 1);
+ "a1", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Const "NOOP";
Func ("CAPTURE", [Const x1; Const y1; Const x2; Const y2])] ->
"BlackDiag",
["a", Structure.board_coords_name (s2i x1, s2i y1);
- "b", Structure.board_coords_name (s2i x2, s2i y2)]
+ "b", Structure.board_coords_name (s2i x2, s2i y2)]
| _ -> assert false
let translate_last_action struc actions =
@@ -2190,7 +2203,7 @@
let struc = new_state.Arena.struc in
match emb with
| [(_,a); (_,b)] ->
- let a, b = if rule = "BlackStraight" then b, a else a, b in
+ let a, b = if rule = "BlackStraight" then a, b else b, a in
let x1, y1 =
Structure.board_elem_coords (Structure.elem_str struc a)
and x2, y2 =
@@ -2202,6 +2215,8 @@
let struc = new_state.Arena.struc in
match emb with
| [(_,a); (_,b)] ->
+ let a, b =
+ if rule = "BlackStraight" then a, b else b, a in
let x1, y1 =
Structure.board_elem_coords (Structure.elem_str struc a)
and x2, y2 =
@@ -2211,7 +2226,7 @@
else
Printf.sprintf "(CAPTURE %d %d %d %d)" x1 y1 x2 y2
| [(_,a); (_,b); (_, c)] ->
- let a, b = if rule = "BlackStraightTwo" then a, c else a, c in
+ let a, b = if rule = "BlackStraightTwo" then a, c else c, a in
let x1, y1 =
Structure.board_elem_coords (Structure.elem_str struc a)
and x2, y2 =
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-01-30 00:49:08 UTC (rev 1288)
+++ trunk/Toss/GGP/Makefile 2011-01-30 02:27:25 UTC (rev 1289)
@@ -15,16 +15,28 @@
GDLTestDebug:
-%.ggp: examples/%.gdl ../TossServer
+%.black: examples/%.gdl ../TossServer
../TossServer -gdl unset -v &
- java -jar gamecontroller-cli.jar play $< 120 30 1 -legal 1 -remote 2 toss localhost 8110 1 | grep results
+ java -jar gamecontroller-cli.jar play $< 120 30 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
+%.white: examples/%.gdl ../TossServer
+ ../TossServer -gdl unset -v &
+ java -jar gamecontroller-cli.jar play $< 120 30 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
+ killall -v TossServer
+
tests:
make -C .. GGP_tests
- make tictactoe.ggp
- make breakthrough.ggp
- make connect5.ggp
+ make tictactoe.white
+ make tictactoe.black
+ make breakthrough.white
+ make breakthrough.black
+ make pawn_whopping.white
+ make pawn_whopping.black
+ make connect4.white
+ make connect4.black
+ make connect5.white
+ make connect5.black
.PHONY: clean
Modified: trunk/Toss/GGP/examples/pawn_whopping.gdl
===================================================================
--- trunk/Toss/GGP/examples/pawn_whopping.gdl 2011-01-30 00:49:08 UTC (rev 1288)
+++ trunk/Toss/GGP/examples/pawn_whopping.gdl 2011-01-30 02:27:25 UTC (rev 1289)
@@ -1,3 +1,8 @@
+; Pawn Whopping with corrected first double jump for black.
+; The only changed rule is "(can_move o (move ?x 8 ?x 6))" (to "... 7 ... 5").
+; If possible, please correct the original and remove this game.
+;
+;
; Pawnville Pawn whopping from Learning to Play Chess with Fritz and Chesster.
; Goal is to either move a pawn to the opposite side or capture all the
; opponent's pawns.
@@ -34,6 +39,7 @@
(<= (legal ?p noop)
(role ?p)
(not (can_move_somewhere ?p)))
+
; Move forward
(<= (can_move x (move ?x ?y1 ?x ?y2))
(true (cell ?x ?y1 x))
@@ -51,10 +57,10 @@
(true (cell ?x 2 x))
(not (occupied ?x 3))
(not (occupied ?x 4)))
-(<= (can_move o (move ?x 8 ?x 6))
- (true (cell ?x 8 o))
- (not (occupied ?x 7))
- (not (occupied ?x 6)))
+(<= (can_move o (move ?x 7 ?x 5))
+ (true (cell ?x 7 o))
+ (not (occupied ?x 6))
+ (not (occupied ?x 5)))
; Capture diagonally
(<= (can_move x (capture ?x1 ?y1 ?x2 ?y2))
(true (cell ?x1 ?y1 x))
@@ -69,6 +75,7 @@
(or (succ ?x1 ?x2)
(succ ?x2 ?x1)))
+
; Transition rules
(<= (next (cell ?x ?y ?p))
(true (cell ?x ?y ?p))
@@ -142,6 +149,7 @@
(succ 4 5)
(succ 5 6)
(succ 6 7)
-(succ 7 8)
+(succ 7 8)
+
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-30 00:49:15
|
Revision: 1288
http://toss.svn.sourceforge.net/toss/?rev=1288&view=rev
Author: lukaszkaiser
Date: 2011-01-30 00:49:08 +0000 (Sun, 30 Jan 2011)
Log Message:
-----------
Manual translation of pawn whopping and connect4, game detection.
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/Makefile
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/GGP/examples/connect4.gdl
trunk/Toss/GGP/examples/pawn_whopping.gdl
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-01-29 16:49:51 UTC (rev 1287)
+++ trunk/Toss/GGP/GDL.ml 2011-01-30 00:49:08 UTC (rev 1288)
@@ -1967,7 +1967,13 @@
let manual_translation = ref true
let manual_game = ref "tictactoe"
let top_exec_path = ref "." (* path to top Toss directory *)
+let tictactoe_descr = ref None
+let breakthrough_descr = ref None
+let connect5_descr = ref None
+let connect4_descr = ref None
+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;
@@ -1986,6 +1992,15 @@
2, 100, 4.0 in
effort, horizon, heur_adv_ratio
+let initialize_game_connect4 state player game_descr startcl =
+ state := state_of_file (!top_exec_path ^ "/examples/Connect4.toss");
+ playing_as := player;
+ game_description := game_descr;
+ player_name_terms := [|Const "WHITE"; Const "RED"|];
+ let effort, horizon, heur_adv_ratio =
+ 2, 100, 4.0 in
+ effort, horizon, heur_adv_ratio
+
let initialize_game_breakthrough state player game_descr startcl =
state := state_of_file (!top_exec_path ^ "/examples/Breakthrough.toss");
playing_as := player;
@@ -1995,14 +2010,32 @@
2, 100, 2.0 in
effort, horizon, heur_adv_ratio
+let initialize_game_pawn_whopping state player game_descr startcl =
+ state := state_of_file (!top_exec_path ^ "/examples/PawnWhopping.toss");
+ playing_as := player;
+ game_description := game_descr;
+ player_name_terms := [|Const "X"; Const "O"|];
+ let effort, horizon, heur_adv_ratio =
+ 2, 100, 2.0 in
+ effort, horizon, heur_adv_ratio
+
let initialize_game state player game_descr startcl =
+ if (Some game_descr) = !tictactoe_descr then manual_game := "tictactoe";
+ if (Some game_descr) = !breakthrough_descr then manual_game := "breakthrough";
+ if (Some game_descr) = !connect5_descr then manual_game := "connect5";
+ if (Some game_descr) = !connect4_descr then manual_game := "connect4";
+ if (Some game_descr) = !pawn_whopping_descr then manual_game:="pawn_whopping";
match !manual_translation, !manual_game with
| true, "tictactoe" ->
initialize_game_tictactoe state player game_descr startcl
| true, "connect5" ->
initialize_game_gomoku state player game_descr startcl
+ | true, "connect4" ->
+ initialize_game_connect4 state player game_descr startcl
| true, "breakthrough" ->
initialize_game_breakthrough state player game_descr startcl
+ | true, "pawn_whopping" ->
+ initialize_game_pawn_whopping state player game_descr startcl
| true, game ->
failwith ("GDL: manual translation of unknown game "^game)
| false, _ ->
@@ -2034,6 +2067,23 @@
"Circle", ["a1", ((String.lowercase col) ^ (number_of_letter row.[0]))]
| _ -> assert false
+let translate_last_action_connect4 struc actions =
+ let int2col i = let s = String.create 1 in s.[0] <- Char.chr (i + 96); s in
+ let elem2i elem_s = Structure.StringMap.find elem_s struc.Structure.names in
+ let pair2i (i, j) = elem2i ((int2col i) ^ (string_of_int j)) in
+ let check rel p = Structure.check_rel struc rel [|pair2i p|] in
+ let is_free p = not (check "P" p || check "Q" p) in
+ let first_free i = List.find (fun j -> is_free (i, j)) [1;2;3;4;5;6] in
+ match actions with
+ | [] ->
+ (* start of game -- Server will handle this answer as NOOP *)
+ "", []
+ | [Func ("DROP", [Const col]); Const "NOOP"] ->
+ "Cross", ["a", (int2col (s2i col))^(string_of_int(first_free (s2i col)))]
+ | [ Const "NOOP"; Func ("DROP", [Const col])] ->
+ "Circle", ["a", (int2col (s2i col))^(string_of_int(first_free (s2i col)))]
+ | _ -> assert false
+
let translate_last_action_breakthrough actions =
match actions with
| [] ->
@@ -2062,14 +2112,46 @@
"b", Structure.board_coords_name (s2i x2, s2i y2)]
| _ -> assert false
-let translate_last_action actions =
+let translate_last_action_pawn_whopping actions =
+ match actions with
+ | [] ->
+ (* start of game -- Server will handle this answer as NOOP *)
+ "", []
+ | [Func ("MOVE", [Const x1; Const y1; Const x2; Const y2]);
+ Const "NOOP"] when x1 = x2 && (s2i y2) - (s2i y1) = 1 ->
+ "WhiteStraight",
+ ["a1", Structure.board_coords_name (s2i x1, s2i y1);
+ "a2", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Func ("CAPTURE", [Const x1; Const y1; Const x2; Const y2]);
+ Const "NOOP"] ->
+ "WhiteDiag",
+ ["a", Structure.board_coords_name (s2i x1, s2i y1);
+ "b", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Const "NOOP";
+ Func ("MOVE", [Const x1; Const y1; Const x2; Const y2])]
+ when x1 = x2 && (s2i y1) - (s2i y2) = 1 ->
+ "BlackStraight",
+ ["a2", Structure.board_coords_name (s2i x1, s2i y1);
+ "a1", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Const "NOOP";
+ Func ("CAPTURE", [Const x1; Const y1; Const x2; Const y2])] ->
+ "BlackDiag",
+ ["a", Structure.board_coords_name (s2i x1, s2i y1);
+ "b", Structure.board_coords_name (s2i x2, s2i y2)]
+ | _ -> assert false
+
+let translate_last_action struc actions =
match !manual_translation, !manual_game with
| true, "tictactoe" ->
translate_last_action_tictactoe actions
| true, "connect5" ->
translate_last_action_gomoku actions
+ | true, "connect4" ->
+ translate_last_action_connect4 struc actions
| true, "breakthrough" ->
translate_last_action_breakthrough actions
+ | true, "pawn_whopping" ->
+ translate_last_action_pawn_whopping actions
| true, game ->
failwith ("GDL: manual translation of unknown game "^game)
| false, _ ->
@@ -2097,6 +2179,13 @@
let cs, rs = Char.chr (c + 64), Char.chr (r + 64) in
Printf.sprintf "(MARK %c %c)" cs rs
+let translate_move_connect4 rule emb new_state =
+ let struc = 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
match emb with
@@ -2109,14 +2198,39 @@
Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2
| _ -> assert false
+let translate_move_pawn_whopping rule emb new_state =
+ let struc = new_state.Arena.struc in
+ match emb with
+ | [(_,a); (_,b)] ->
+ let x1, y1 =
+ Structure.board_elem_coords (Structure.elem_str struc a)
+ and x2, y2 =
+ Structure.board_elem_coords (Structure.elem_str struc b) in
+ if x1 = x2 then
+ Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2
+ else
+ Printf.sprintf "(CAPTURE %d %d %d %d)" x1 y1 x2 y2
+ | [(_,a); (_,b); (_, c)] ->
+ let a, b = if rule = "BlackStraightTwo" then a, c else a, c in
+ let x1, y1 =
+ Structure.board_elem_coords (Structure.elem_str struc a)
+ and x2, y2 =
+ Structure.board_elem_coords (Structure.elem_str struc b) in
+ Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2
+ | _ -> assert false
+
let translate_move rule emb new_state =
match !manual_translation, !manual_game with
| true, "tictactoe" ->
translate_move_tictactoe rule emb new_state
| true, "connect5" ->
translate_move_gomoku rule emb new_state
+ | true, "connect4" ->
+ translate_move_connect4 rule emb new_state
| true, "breakthrough" ->
translate_move_breakthrough rule emb new_state
+ | true, "pawn_whopping" ->
+ translate_move_pawn_whopping rule emb new_state
| true, game ->
failwith ("GDL: manual translation of unknown game "^game)
| false, _ ->
Modified: trunk/Toss/GGP/GDL.mli
===================================================================
--- trunk/Toss/GGP/GDL.mli 2011-01-29 16:49:51 UTC (rev 1287)
+++ trunk/Toss/GGP/GDL.mli 2011-01-30 00:49:08 UTC (rev 1288)
@@ -38,6 +38,12 @@
| Initial of term * literal list
| Atomic of string * term list
+val tictactoe_descr : game_descr_entry list option ref
+val breakthrough_descr : game_descr_entry list option ref
+val connect5_descr : game_descr_entry list option ref
+val connect4_descr : game_descr_entry list option ref
+val pawn_whopping_descr : game_descr_entry list option ref
+
type request =
| Start of string * term * game_descr_entry list * int * int
(** prepare game: match id, role, game, startclock, playclock *)
@@ -76,7 +82,7 @@
int * int * float
val translate_last_action :
- term list -> string * (string * string) list
+ Structure.structure -> term list -> string * (string * string) list
(** Whether the current player is the one being played as. *)
val our_turn : Arena.game_state -> bool
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-01-29 16:49:51 UTC (rev 1287)
+++ trunk/Toss/GGP/Makefile 2011-01-30 00:49:08 UTC (rev 1288)
@@ -16,7 +16,7 @@
GDLTestDebug:
%.ggp: examples/%.gdl ../TossServer
- ../TossServer -gdl $(basename $@) -v &
+ ../TossServer -gdl unset -v &
java -jar gamecontroller-cli.jar play $< 120 30 1 -legal 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
Added: trunk/Toss/GGP/examples/connect4.gdl
===================================================================
--- trunk/Toss/GGP/examples/connect4.gdl (rev 0)
+++ trunk/Toss/GGP/examples/connect4.gdl 2011-01-30 00:49:08 UTC (rev 1288)
@@ -0,0 +1,268 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Connect 4
+;;;
+;;;
+;;; modified 2007-06-05 by dhaley: made line rules more efficient
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (role white)
+ (role red)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (init (cell 1 0 dirt))
+ (init (cell 2 0 dirt))
+ (init (cell 3 0 dirt))
+ (init (cell 4 0 dirt))
+ (init (cell 5 0 dirt))
+ (init (cell 6 0 dirt))
+ (init (cell 7 0 dirt))
+
+ (init (cell 1 1 b))
+ (init (cell 1 2 b))
+ (init (cell 1 3 b))
+ (init (cell 1 4 b))
+ (init (cell 1 5 b))
+ (init (cell 1 6 b))
+
+ (init (cell 2 1 b))
+ (init (cell 2 2 b))
+ (init (cell 2 3 b))
+ (init (cell 2 4 b))
+ (init (cell 2 5 b))
+ (init (cell 2 6 b))
+
+ (init (cell 3 1 b))
+ (init (cell 3 2 b))
+ (init (cell 3 3 b))
+ (init (cell 3 4 b))
+ (init (cell 3 5 b))
+ (init (cell 3 6 b))
+
+ (init (cell 4 1 b))
+ (init (cell 4 2 b))
+ (init (cell 4 3 b))
+ (init (cell 4 4 b))
+ (init (cell 4 5 b))
+ (init (cell 4 6 b))
+
+ (init (cell 5 1 b))
+ (init (cell 5 2 b))
+ (init (cell 5 3 b))
+ (init (cell 5 4 b))
+ (init (cell 5 5 b))
+ (init (cell 5 6 b))
+
+ (init (cell 6 1 b))
+ (init (cell 6 2 b))
+ (init (cell 6 3 b))
+ (init (cell 6 4 b))
+ (init (cell 6 5 b))
+ (init (cell 6 6 b))
+
+ (init (cell 7 1 b))
+ (init (cell 7 2 b))
+ (init (cell 7 3 b))
+ (init (cell 7 4 b))
+ (init (cell 7 5 b))
+ (init (cell 7 6 b))
+
+ (init (control white))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (<= (empty ?c ?h)
+ (true (cell ?c ?h b)))
+
+ (<= (filled ?c ?h)
+ (true (cell ?c ?h dirt)))
+ (<= (filled ?c ?h)
+ (true (cell ?c ?h w)))
+ (<= (filled ?c ?h)
+ (true (cell ?c ?h r)))
+
+ (<= (next (cell ?c ?h2 w))
+ (does white (drop ?c))
+ (true (cell ?c ?h2 b))
+ (filled ?c ?h1)
+ (succ ?h1 ?h2))
+
+ (<= (next (cell ?c ?h2 r))
+ (does red (drop ?c))
+ (true (cell ?c ?h2 b))
+ (filled ?c ?h1)
+ (succ ?h1 ?h2))
+
+ (<= (next (cell ?x ?y ?z))
+ (true (cell ?x ?y ?z))
+ (distinct ?z b))
+
+ (<= (next (cell ?c2 ?y b))
+ (does ?w (drop ?c1))
+ (true (cell ?c2 ?y b))
+ (distinct ?c1 ?c2))
+
+;; (<= (next (cell ?c ?h3 b))
+;; (role ?r)
+;; (does ?r (drop ?c))
+;; (true (cell ?c ?h2 b))
+;; (filled ?c ?h1)
+;; (succ ?h1 ?h2)
+;; (succ ?h2 ?h3))
+
+ (<= (next (cell ?c ?y2 b))
+ (true (cell ?c ?y1 b))
+ (distinct ?y1 6)
+ (succ ?y1 ?y2))
+
+ (<= (next (control white))
+ (true (control red)))
+
+ (<= (next (control red))
+ (true (control white)))
+
+ ;; horizontal
+ (<= (row ?z) (true (cell ?x1 ?y ?z))
+ (distinct ?z b)
+ (distinct ?z dirt)
+ (succ ?x1 ?x2)
+ (true (cell ?x2 ?y ?z))
+ (succ ?x2 ?x3)
+ (true (cell ?x3 ?y ?z))
+ (succ ?x3 ?x4)
+ (true (cell ?x4 ?y ?z))
+ )
+
+ ;; vertical
+ (<= (column ?z) (true (cell ?x ?y1 ?z))
+ (distinct ?z b)
+ (succ ?y1 ?y2)
+ (true (cell ?x ?y2 ?z))
+ (succ ?y2 ?y3)
+ (true (cell ?x ?y3 ?z))
+ (succ ?y3 ?y4)
+ (true (cell ?x ?y4 ?z))
+ )
+
+ ;; diagonal (north-east)
+ (<= (diag ?z) (true (cell ?x1 ?y1 ?z))
+ (distinct ?z b)
+ (succ ?x1 ?x2)
+ (succ ?y1 ?y2)
+ (true (cell ?x2 ?y2 ?z))
+ (succ ?x2 ?x3)
+ (succ ?y2 ?y3)
+ (true (cell ?x3 ?y3 ?z))
+ (succ ?x3 ?x4)
+ (succ ?y3 ?y4)
+ (true (cell ?x4 ?y4 ?z))
+ )
+
+ ;; diagonal (south-east)
+ (<= (diag ?z) (true (cell ?x1 ?y1 ?z))
+ (distinct ?z b)
+ (succ ?x1 ?x2)
+ (succ ?y2 ?y1)
+ (true (cell ?x2 ?y2 ?z))
+ (succ ?x2 ?x3)
+ (succ ?y3 ?y2)
+ (true (cell ?x3 ?y3 ?z))
+ (succ ?x3 ?x4)
+ (succ ?y4 ?y3)
+ (true (cell ?x4 ?y4 ?z))
+ )
+
+ (<= (line ?x) (row ?x))
+ (<= (line ?x) (column ?x))
+ (<= (line ?x) (diag ?x))
+
+ (<= open
+ (empty ?c ?h))
+
+ (<= terminal
+ (line r))
+
+ (<= terminal
+ (line w))
+
+ (<= terminal
+ (not open))
+
+ (<= (legal ?w (drop ?c))
+ (true (cell ?c ?y2 b))
+ (filled ?c ?y1)
+ (succ ?y1 ?y2)
+ (true (control ?w)))
+
+ (<= (legal white noop)
+ (true (control red)))
+
+ (<= (legal red noop)
+ (true (control white)))
+
+ (<= (goal white 100)
+ (line w))
+
+ (<= (goal white 50)
+ (not (line r))
+ (not (line w))
+ (not open))
+
+ (<= (goal white 0)
+ (line r))
+
+ (<= (goal red 100)
+ (line r))
+
+ (<= (goal red 50)
+ (not (line r))
+ (not (line w))
+ (not open))
+
+ (<= (goal red 0)
+ (line w))
+
+ (<= (goal ?w 70)
+ (role ?w)
+ (not (line r))
+ (not (line w))
+ open)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; arithmetic
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(<= (lte 0 ?x)
+ (number ?x))
+
+(<= (lte ?x ?x)
+ (number ?x))
+
+(<= (lte ?x ?z)
+ (succ ?y ?z)
+ (lte ?x ?y))
+
+(<= (lte ?x ?y)
+ (succ ?x ?y))
+
+(number 0)
+(number 1)
+(number 2)
+(number 3)
+(number 4)
+(number 5)
+(number 6)
+(number 7)
+(number 8)
+
+(succ 0 1)
+(succ 1 2)
+(succ 2 3)
+(succ 3 4)
+(succ 4 5)
+(succ 5 6)
+(succ 6 7)
+(succ 7 8)
+
+
+
+
Added: trunk/Toss/GGP/examples/pawn_whopping.gdl
===================================================================
--- trunk/Toss/GGP/examples/pawn_whopping.gdl (rev 0)
+++ trunk/Toss/GGP/examples/pawn_whopping.gdl 2011-01-30 00:49:08 UTC (rev 1288)
@@ -0,0 +1,147 @@
+; Pawnville Pawn whopping from Learning to Play Chess with Fritz and Chesster.
+; Goal is to either move a pawn to the opposite side or capture all the
+; opponent's pawns.
+; The game is played on a 8 x 8 board. This version ignores en passant.
+(role x)
+(role o)
+
+; Initial conditions
+(init (cell 1 7 o))
+(init (cell 2 7 o))
+(init (cell 3 7 o))
+(init (cell 4 7 o))
+(init (cell 5 7 o))
+(init (cell 6 7 o))
+(init (cell 7 7 o))
+(init (cell 8 7 o))
+(init (cell 1 2 x))
+(init (cell 2 2 x))
+(init (cell 3 2 x))
+(init (cell 4 2 x))
+(init (cell 5 2 x))
+(init (cell 6 2 x))
+(init (cell 7 2 x))
+(init (cell 8 2 x))
+(init (control x))
+
+; Legal moves
+(<= (legal ?p noop)
+ (role ?p)
+ (not (true (control ?p))))
+(<= (legal ?p ?move)
+ (true (control ?p))
+ (can_move ?p ?move))
+(<= (legal ?p noop)
+ (role ?p)
+ (not (can_move_somewhere ?p)))
+; Move forward
+(<= (can_move x (move ?x ?y1 ?x ?y2))
+ (true (cell ?x ?y1 x))
+ (succ ?y1 ?y2)
+ (not (occupied ?x ?y2)))
+(<= (occupied ?x ?y)
+ (role ?r)
+ (true (cell ?x ?y ?r)))
+(<= (can_move o (move ?x ?y1 ?x ?y2))
+ (true (cell ?x ?y1 o))
+ (succ ?y2 ?y1)
+ (not (occupied ?x ?y2)))
+; First move can be a double.
+(<= (can_move x (move ?x 2 ?x 4))
+ (true (cell ?x 2 x))
+ (not (occupied ?x 3))
+ (not (occupied ?x 4)))
+(<= (can_move o (move ?x 8 ?x 6))
+ (true (cell ?x 8 o))
+ (not (occupied ?x 7))
+ (not (occupied ?x 6)))
+; Capture diagonally
+(<= (can_move x (capture ?x1 ?y1 ?x2 ?y2))
+ (true (cell ?x1 ?y1 x))
+ (true (cell ?x2 ?y2 o))
+ (succ ?y1 ?y2)
+ (or (succ ?x1 ?x2)
+ (succ ?x2 ?x1)))
+(<= (can_move o (capture ?x1 ?y1 ?x2 ?y2))
+ (true (cell ?x1 ?y1 o))
+ (true (cell ?x2 ?y2 x))
+ (succ ?y2 ?y1)
+ (or (succ ?x1 ?x2)
+ (succ ?x2 ?x1)))
+
+; Transition rules
+(<= (next (cell ?x ?y ?p))
+ (true (cell ?x ?y ?p))
+ (not (changes ?x ?y)))
+(<= (next (cell ?x ?y ?p))
+ (does ?p (move ?any_x ?any_y ?x ?y)))
+(<= (next (cell ?x ?y ?p))
+ (does ?p (capture ?any_x ?any_y ?x ?y)))
+
+(<= (changes ?x ?y)
+ (does ?r (move ?x ?y ?any_x ?any_y)))
+(<= (changes ?x ?y)
+ (does ?r (capture ?x ?y ?any_x ?any_y)))
+(<= (changes ?x ?y)
+ (does ?r (capture ?any_x ?any_y ?x ?y)))
+
+; Control
+(<= (next (control o))
+ (true (control x)))
+(<= (next (control x))
+ (true (control o)))
+
+; Goal
+(<= (goal x 100)
+ xwins)
+
+(<= (goal o 100)
+ owins)
+
+(<= (has_pieces ?p)
+ (true (cell ?x ?y ?p)))
+
+(<= (goal ?p 50)
+ (role ?p)
+ (not (can_move_somewhere x))
+ (not (can_move_somewhere o))
+ (not xwins)
+ (not owins))
+
+(<= (goal x 0)
+ owins)
+
+(<= (goal o 0)
+ xwins)
+
+(<= xwins
+ (true (cell ?any_x 8 x)))
+(<= xwins
+ (not (has_pieces o)))
+
+(<= owins
+ (true (cell ?any_x 1 o)))
+(<= owins
+ (not (has_pieces x)))
+
+; Terminal conditions
+(<= terminal
+ (goal ?role 100))
+
+(<= terminal
+ (not (can_move_somewhere x))
+ (not (can_move_somewhere o)))
+
+(<= (can_move_somewhere ?p)
+ (can_move ?p ?m))
+
+; Successor axioms
+(succ 1 2)
+(succ 2 3)
+(succ 3 4)
+(succ 4 5)
+(succ 5 6)
+(succ 6 7)
+(succ 7 8)
+
+
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-01-29 16:49:51 UTC (rev 1287)
+++ trunk/Toss/Server/Server.ml 2011-01-30 00:49:08 UTC (rev 1288)
@@ -283,7 +283,7 @@
| Aux.Right (GDL.Play (_, actions)) ->
let r_name, mtch =
- GDL.translate_last_action actions in
+ GDL.translate_last_action !state.Arena.struc actions in
if r_name <> "" then (
let {Arena.rules=rules; graph=graph} = !state.Arena.game in
@@ -388,7 +388,7 @@
| Aux.Right (GDL.Stop (_, actions)) ->
let r_name, mtch =
- GDL.translate_last_action actions in
+ GDL.translate_last_action !state.Arena.struc actions in
if r_name <> "" then (
let {Arena.rules=rules; graph=graph} = !state.Arena.game in
@@ -532,5 +532,22 @@
(* so that the server is not started by the test suite. *)
if not test_fname then (
GDL.top_exec_path := dir_from_path Sys.argv.(0);
+ let parse_game_descr s =
+ GDLParser.parse_game_description KIFLexer.lex (Lexing.from_string s) in
+ let input_file fname =
+ let lines, f = ref [], open_in fname in
+ try
+ while true; do lines := input_line f :: !lines done; ""
+ with End_of_file ->
+ close_in f;
+ String.concat "\n" (List.rev !lines) in
+ let load_rules fname =
+ let gdl = input_file (!GDL.top_exec_path ^ "/GGP/examples/" ^ fname) in
+ parse_game_descr (String.uppercase gdl) in
+ GDL.tictactoe_descr := Some (load_rules "tictactoe.gdl");
+ GDL.breakthrough_descr := Some (load_rules "breakthrough.gdl");
+ GDL.connect5_descr := Some (load_rules "connect5.gdl");
+ GDL.connect4_descr := Some (load_rules "connect4.gdl");
+ GDL.pawn_whopping_descr := Some (load_rules "pawn_whopping.gdl");
main ()
) ;;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-29 16:49:59
|
Revision: 1287
http://toss.svn.sourceforge.net/toss/?rev=1287&view=rev
Author: lukaszkaiser
Date: 2011-01-29 16:49:51 +0000 (Sat, 29 Jan 2011)
Log Message:
-----------
Rearangement for ggp testing, added automated test with java gamecontroller.
Modified Paths:
--------------
trunk/Toss/.cvsignore
trunk/Toss/Makefile
trunk/Toss/Play/GameTest.ml
trunk/Toss/Toss.py
trunk/Toss/TossTest.ml
Added Paths:
-----------
trunk/Toss/GGP/
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLParser.mly
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/KIFLexer.mll
trunk/Toss/GGP/Makefile
trunk/Toss/GGP/examples/
trunk/Toss/GGP/examples/breakthrough.gdl
trunk/Toss/GGP/examples/checkers.gdl
trunk/Toss/GGP/examples/chess.gdl
trunk/Toss/GGP/examples/connect5.gdl
trunk/Toss/GGP/examples/tictactoe.gdl
trunk/Toss/GGP/gamecontroller-cli.jar
trunk/Toss/Server/
trunk/Toss/Server/Makefile
trunk/Toss/Server/Server.ml
trunk/Toss/Server/ServerGDLTest.in
trunk/Toss/Server/ServerGDLTest.out
trunk/Toss/Server/ServerTest.in
trunk/Toss/Server/ServerTest.ml
trunk/Toss/Server/ServerTest.out
Removed Paths:
-------------
trunk/Toss/Play/GDL.ml
trunk/Toss/Play/GDL.mli
trunk/Toss/Play/GDLParser.mly
trunk/Toss/Play/GDLTest.ml
trunk/Toss/Play/KIFLexer.mll
trunk/Toss/Play/Server.ml
trunk/Toss/Play/ServerGDLTest.in
trunk/Toss/Play/ServerGDLTest.out
trunk/Toss/Play/ServerTest.in
trunk/Toss/Play/ServerTest.out
trunk/Toss/examples/breakthrough.gdl
trunk/Toss/examples/checkers.gdl
trunk/Toss/examples/chess.gdl
trunk/Toss/examples/connect5.gdl
Property Changed:
----------------
trunk/Toss/
Property changes on: trunk/Toss
___________________________________________________________________
Modified: svn:ignore
- # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
Toss.docdir
_build
Server
*.native
*Profile.log
gmon.out
*~
*.annot
*.cmx
*.cmi
*.o
*.cmo
*.a
*.cmxa
log.*
+ # We are still using .cvsignore files as we find them easier to manage
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
Toss.docdir
_build
TossServer
*.native
*Profile.log
gmon.out
*~
*.annot
*.cmx
*.cmi
*.o
*.cmo
*.a
*.cmxa
log.*
Modified: trunk/Toss/.cvsignore
===================================================================
--- trunk/Toss/.cvsignore 2011-01-29 13:11:29 UTC (rev 1286)
+++ trunk/Toss/.cvsignore 2011-01-29 16:49:51 UTC (rev 1287)
@@ -4,7 +4,7 @@
Toss.docdir
_build
-Server
+TossServer
*.native
*Profile.log
gmon.out
Copied: trunk/Toss/GGP/GDL.ml (from rev 1286, trunk/Toss/Play/GDL.ml)
===================================================================
--- trunk/Toss/GGP/GDL.ml (rev 0)
+++ trunk/Toss/GGP/GDL.ml 2011-01-29 16:49:51 UTC (rev 1287)
@@ -0,0 +1,2123 @@
+(** {2 Game Description Language.}
+
+ Type definitions, helper functions, game specification
+ translation.
+
+ The translation is not complete (yet), and not yet guaranteed to
+ be sound (but aiming at it) -- report any cases where the
+ algorithm does not fail explicitly but does not preserve
+ semantics.
+
+ (1) Aggregate playout: generate successive states as if all moves
+ legal in the previous state were performed. Do not check the
+ termination predicate.
+
+ (1a) Reason for unsoundness: "legal" or "next" preconditions can
+ depend negatively on state, preventing further moves in the
+ aggregate state that would be possible in some of valid game
+ states; the aggregate state does not have enough terms as a
+ result. Workaround: remove negative literals from "legal"/"next"
+ conditions for generating aggregate playout.
+
+ (1b) Saturation works on definitions stratified
+ w.r.t. negation. Positive literals are instantiated one by one,
+ then negative literals are checked over the facts derived from
+ previous strata. To avoid redundancy, new facts and new
+ instantiations are kept separate for the next iteration within a
+ stratum.
+
+ (1c) Heuristic reason for unsoundness: while we check for fixpoint
+ in the playout, we rule out state terms "F(X)" where X is a player
+ (assuming that "F" means "control"). Workaround: turn off fixpoint
+ checking [aggregate_fixpoint].
+
+ (2) Arena graph: currently, only a simple cycle is allowed. The
+ succession of players is determined from the aggregate playout.
+
+ (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
+ action in the corresponding state of an aggregate playout for the
+ player that is also constant.
+
+ (2b) We determine the player of a location by requiring that at
+ most one player has a non-noop action in an aggregate
+ state. When all players are noops we select the control player so
+ that the smallest "game cycle" is preserved. Otherwise (more than
+ one no-noop move) we fail (simultaneous moves not supported). We
+ remember the noop actions for each location and player.
+
+ (3) Currently, a constant number of elements is assumed. The rules
+ processed in (3a)-(3b) are already expanded by (6).
+
+ (3a) Element terms are collected from the aggregate playout: the
+ sum of state terms (the "control" function could be dropped but we
+ are not taking the effort to identify it).
+
+ (3b) Element masks are generated by generalization from all "next"
+ rules where the "does" relations are expanded by all unifying
+ "legal" rules (see also (7a)).
+
+ (3c) Generalization in a single expanded "next" rule is by finding
+ for the "next" term the closest "true" term in the lexicographic
+ ordering of (# of matched variables, # of other matched leaves),
+ but in case the closest term is found in the negative part, it is
+ further processed.
+
+ (3c1) Unmatched subterms are replaced by meta-variables.
+
+ (3c2) When the generalization comes from the negative part, we
+ replace all constant leaves with meta-variables. Warning: this
+ heuristic is a reason for unsoundness -- search for a workaround
+ once a real counterexample is encountered.
+
+ (3d) The masks are all the minimal w.r.t. matching (substitution)
+ of the generalized terms, with only meta-variable positions of the
+ mask matching meta-variable positions of a generalized
+ term.
+
+ (3e) The elements are the equivalence classes of element terms,
+ where terms are equivalent when they both match a single mask and
+ their matching substitutions differ only at
+ meta-variables. (I.e. for t1 and t2 there exists a mask m and
+ substitutions s1 and s2 such that s1(m)=t1 and s2(m)=t2 and
+ s1(x)=/=s2(x) implies that x is/contains a meta-variable.)
+
+ (Note that there is "nothing wrong" with a given equiv class not
+ having any member in the initial state or some other state. The
+ element is still there in the structure, still participating in
+ the "static" relations, but not in the "dynamic" predicates in
+ that particular state. We use a special _BLANK_ term/predicate to
+ faciliate operations on such "absent" elements.)
+
+ (4) Static relations (their tuples do not change during the game)
+ are derived from static facts with subterms common with element
+ terms but not below meta-variables.
+
+ Define mask-paths as the set of a mask together with a path in it
+ to a position that is not below (or at) a meta-variable.
+
+ Implementation: currently we approximate paths by only taking the
+ positions of variables in the mask.
+
+ (4a) (Fact relations.) For a static fact (a relation that does not
+ depend on "true" or "init") (unless it is expanded -- see (6)),
+ introduce a relation for each mask-paths tuple with arity of the
+ relation (i.e., introduced relations are a dependent product of
+ static fact relations and a cartesian n-th power of the mask-paths
+ set where n is the arity of the relation). An introduced relation
+ holds over a tuple of elements, iff the corresponding element
+ terms match the respective masks, and the original relation holds
+ over the tuple of subterms selected from the element terms by the
+ corresponding paths.
+
+ (4b) (Equality relations.) For each mask-path, introduce a binary
+ relation that holds over elements which have the same subterm at
+ the mask-path position. (Because of mask-paths definition, same
+ 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
+ semantics: "matches the mask and has the constant at the path
+ position".
+
+ (5) (Mostly) dynamic relations ("fluents": their tuples change
+ during the game), relations derived from all below-meta-variable
+ subterms of element terms, initialized by those that appear in the
+ initial state. (Some relations introduced in this step might not
+ be fluents.)
+
+ (See also (7k).) For each element term, find the element mask it
+ matches, and introduce relations for each meta-variable of the
+ element mask, associated with the subterm that matches the
+ meta-variable. The semantic is that the relation selects the
+ element terms that match the mask with the associated subterm
+ subsituted for the corresponding meta-variable, with existential
+ interpretation. A relation holds initially over an element, if in
+ the initial set of element terms at least one from the element's
+ equivalence class is selected by the relation. An occurrence of
+ "true" or "next" relation is replaced by a conjunction of
+ relations whose substituted-masks match the relation's term.
+
+ When generating predicates that hold over an element term, no
+ predicate is generated for any its meta-variable position that
+ contains _BLANK_.
+
+ (6) Currently how to introduce defined relations in translation is
+ not yet solved in the presented framework. Currently, we simply
+ expand relations that are not static, or (optionally) are static
+ but do not contain ground facts, by duplicating the branch in
+ which body an atom of the relation occurs, for each branch of the
+ relation definition, unifying and applying the unifier. (If the
+ duplication turns out prohibitive, this will be a *huge* TODO for
+ this translation framework.)
+
+ (6a) The definition:
+
+ [(r, params1) <= body1 ... (r, params_n) <= body_n]
+
+ provides a DNF defining formula (using negation-as-failure):
+
+ [(r, args) <=> exist vars1 (args = params1 /\ body1) \/ ...
+ \/ exist vars_n (args = params_n /\ body_n)]
+
+ which expands in a natural way for positive occurrences. We
+ duplicate the branch where [(r, args)] is substitued for each
+ disjunct and apply the unifier of [args = params_i] in the whole
+ [i]th cloned branch. We freshen each [vars_i] to avoid capture. If
+ unification fails, we drop the corresponding branch clone.
+
+ (6b) For negative occurrences we transform the defining formula
+ to:
+
+ [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
+ 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
+ subformula inside a branch). We only apply the unifier of [args =
+ params_i] to [body_i] (in general, the whole negated
+ subformula). Still, we freshen each [vars_i] to avoid capture. If
+ unification fails, we drop the corresponding negated
+ subformula. If unification succeeds but the corresponding [body_i]
+ is empty (and, in general, no other disjuncts in the negated
+ subformula are left), we drop the branch.
+
+ (6b1) The general case is not implemented yet since it slightly
+ complicates the code, and expressivity gain is very small.
+
+ (7) Generation of rewrite rules when the dynamic relations are not
+ recursive and are expanded in the GDL definition.
+
+ (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
+ 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
+ substituted in the body of the "legal" branch. A rewrite rule is
+ associated with a single "lead legal" branch of the location's
+ player.
+
+ (7b) We collect all the branches of the "next" relation definition
+ for which the selected branches of "lead legal" and "noop legal"
+ (the "joint legal" actions) unify with all (usually one, but we
+ allow zero or more) occurrences of "does" with a single unifier
+ per "next" branch. (A "noop legal" actually only matches and
+ substitutes the local variables of "next" branches.) Split the
+ unifiers into equivalence classes (w.r.t. substitution), each
+ class will be a different rewrite rule (or set of rules). (Note
+ that equivalent unifiers turn out to be those that when truncated
+ to variables of the "legal" branch are renamings of each other.)
+
+ (7b1) Since the "noop legals" are constants (by current
+ assumption), we do not need to construct equivalence classes for
+ them. Their branches will join every rule generated for the "joint
+ legal" choice.
+
+ (7c) Find a single MGU that unifies the "legal" atom argument and
+ all the "does" atoms arguments into a single instance, and apply
+ it to all "next" branches of the rule (i.e. after applying the
+ original unifier, apply a renaming that makes the unifier equal to
+ all other unifiers in the equiv. class). We replace all
+ occurrences of "does" with the body of the selected "legal"
+ branch.
+
+ (7d) Add all branches of equiv classes smaller than a given equiv
+ class to its branch set.
+
+ Implementation TODO (reason for unsoundness): currently, we
+ 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.
+
+ (7e) Associate negation of equalities specific to the unifiers
+ strictly less general than the equivalence class with it, so that
+ the resulting conditions form a partition of the space of
+ substitutions for the "legal" branch processed.
+
+ (7f) We remember all variables in the "legal"/"does" instantiation
+ as "fixed variables". We seggregate "next" atoms into these that
+ contain some fixed variables or no variables at all, and other
+ containing only unfixed variables.
+
+ (7f1) Branches with (only) unfixed variables in "next" atoms that
+ are "identities" are the "frame" branches. "Identity" here means
+ the "next" atom is equal to one of the positive "true" atoms.
+
+ (7f2) Transform the "frame" branches into "erasure" branches:
+ distribute them into equivalence classes of head terms
+ (w.r.t. substitution but treating fixed variables as constants),
+ add smaller elements and negation of larger elements (in the same
+ 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
+ positions replaced by _BLANK_ as the head of the "erasure" branch,
+ apply (and remove) unification atoms resulting from negating the
+ "distinct" relation.
+
+ (7f4) Drop the erasure branches that contradict the "legal"
+ condition of their rule.
+
+ (7f5) Redistribute the erasure branches in case they were
+ substituted with the "not distinct" unifier to proper equivalence
+ classes (remove equivalence classes that become empty).
+
+ (7g) Instantiate remaining unfixed variables. Implementation TODO.
+
+ (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
+ atoms "corresponding variable".) From now on until (7m1) we keep
+ both the (partially) Toss-translated versions and the (complete)
+ GDL-originals of branches (so to use GDL atoms for "subsumption
+ checking" in (7m)).
+
+ (7i-4a) For all subterms of "next" and "true" atoms, identify the
+ 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 (FIXME: why disjunction is wrong?).
+
+ (7i-4c) Include the (4c) relations for "next" and "true" positive
+ atoms. Negative atoms are added with (5) relations since they are
+ under a common negation.
+
+ (7i-4b) Add an appropriate equality relation of (4b) for each case
+ of variable shared by terms corresponding to different element
+ variables (regardless if the element terms are in positive or
+ negative literals). FIXME: any shared subterm, not limited to
+ variables, right?
+
+ Implementation: instead of all subterms we currently only consider
+ subterms that instantiate (ordinary) variables in the mask
+ corresponding to the "next"/"true" atom.
+
+ (7i1) Remove branches that are unsatisfiable by their static
+ relations (4a), (4b) and (4c) alone.
+
+ (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.)
+
+ (7k) Replace the "next" and "true" atoms by the conjunction of
+ (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).
+
+ (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
+ consequent does not, but does not need to always say "yes"
+ otherwise. Build a rewrite rule for each equivalence class
+ w.r.t. subsumption, including also branches that are below the
+ equiv class, and including negation of conditions that make the
+ branches strictly above more specific -- so that the classes form
+ a partition of the nonterminal game states (it is semantically
+ necessary so that all applicable changes are applied in the
+ translated game when making a move).
+
+ (7l1) Since all variables are fixed, the lattice is built by
+ summing rule bodies. To avoid contradictions and have a complete
+ partition, we construct the set of all bit vectors indexed by all
+ atoms occurring in the bodies. With every index-bit value we
+ associate the set of branches that do not allow such literal. For
+ every vector we calculate the complement of the sum of branch sets
+ associated with every bit. The unique resulting sets are exactly
+ the Toss rules precursors.
+
+ (7m) Include translated negation of the terminal condition. (Now we
+ build rewrite rules for a refinement of an equivalence class of
+ (7b): from the branches with unifiers in the equiv class, from
+ branches with unifiers more general than the equiv class, and from
+ the disjointness conditions and the terminal condition.)
+
+ 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).
+
+ (8) We use a single payoff matrix for all locations. Goal patterns
+ are expanded to regular goals by instantiating the value variable
+ by all values in its domain (for example, as gathered from the
+ aggregate playout), and expanding all atoms that contained value
+ variables (both static and dynamic) using (6); fail if a goal
+ value cannot be determined. The payoff formula is the sum of
+ "goal" value times the characterisic function of the "goal"
+ body. We do not translate the body if the value is zero (we drop
+ the zero goal branches from the definition). Translate the body
+ using (7h)-(7m), but treating "goal" branches separately -- when
+ (7k) duplicates a branch, new branches add new sum elements.
+
+*)
+
+let debug_level = ref 0
+let aggregate_drop_negative = ref false
+let aggregate_fixpoint = ref true
+(** Expand static relations that do not have ground facts and have
+ arity above the threshold. *)
+let expand_arity_above = ref 0
+
+type term =
+ | Const of string
+ | Var of string
+ | MVar of string (* meta-variable, not used in GDL *)
+ | Func of string * term list
+
+type atom =
+ | Distinct of term list
+ | Rel of string * term list
+ | Currently of term
+ | Does of term * term
+
+type literal =
+ | Pos of atom
+ | Neg of atom
+ | Disj of literal list
+
+type game_descr_entry =
+ | Datalog of string * term list * literal list
+ | Next of term * literal list
+ | Legal of term * term * literal list
+ | Goal of term * int * literal list
+ | GoalPattern of term * string * literal list
+ | Terminal of literal list
+ | Role of term
+ | Initial of term * literal list
+ | Atomic of string * term list
+
+type request =
+ | Start of string * term * game_descr_entry list * int * int
+ (* prepare game: match id, role, game, startclock, playclock *)
+ | Play of string * term list
+ (* request a move: match id, actions on previous step *)
+ | Stop of string * term list
+ (* game ends here: match id, actions on previous step *)
+
+let rec term_str = function
+ | Const c -> c
+ | Var v -> "?"^v
+ | MVar v -> "@"^v
+ | Func (f, args) ->
+ "(" ^ f ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
+
+let rec term_to_name ?(nested=false) = function
+ | Const c -> c
+ | Var v -> v
+ | MVar v -> v
+ | Func (f, args) ->
+ f ^ "_" ^ (if nested then "_S_" else "") ^
+ String.concat "_" (List.map (term_to_name ~nested:true) args) ^
+ (if nested then "_Z_" else "")
+
+let rec vars ?(meta=false) = function
+ | Const _ -> []
+ | Var x -> [x]
+ | MVar x -> if meta then [x] else []
+ | Func (_, args) -> Aux.concat_map vars args
+
+let rec term_vars = function
+ | Const _ -> Aux.Strings.empty
+ | Var v | MVar v -> Aux.Strings.singleton v
+ | Func (f, args) -> terms_vars args
+and terms_vars args =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map term_vars args)
+
+let fact_of_atom = function
+ | Distinct args -> assert false
+ | Rel (rel, args) -> rel, args
+ | Currently arg -> "true", [arg]
+ | Does (arg1, arg2) -> "does", [arg1; arg2]
+
+let rec body_of_literal = function
+ | Pos (Distinct args) ->
+ [Aux.Right ("distinct", args)] (* not negated actually! *)
+ | Neg (Distinct _) -> assert false
+ | Pos atom -> [Aux.Left (fact_of_atom atom)]
+ | Neg atom -> [Aux.Right (fact_of_atom atom)]
+ | Disj disjs ->
+ Aux.concat_map body_of_literal disjs
+
+let func_graph f terms =
+ Aux.map_some
+ (function Func (g, args) when f=g -> Some args | _ -> None) terms
+
+(* Type shortcuts (mostly for documentation). *)
+type gdl_atom = string * term list
+type gdl_rule = gdl_atom * gdl_atom list * gdl_atom list
+(* Definition with expanded definitions: expansion of a negated
+ relation brings negated conjunctions. *)
+type exp_def_branch =
+ term list * gdl_atom list * gdl_atom list list
+type exp_def =
+ string * exp_def_branch list
+
+module Terms = Set.Make (
+ struct type t = term let compare = Pervasives.compare end)
+
+(*
+let branch_vars (args, body, neg_body) =
+*)
+
+let rules_of_entry = function
+ | Datalog (rel, args, body) ->
+ let head = rel, args in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Next (head, body) ->
+ let head = "next", [head] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Legal (arg1, arg2, body) ->
+ let head = "legal", [arg1; arg2] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Goal (arg, payoff, body) ->
+ let head = "goal", [arg; Const (string_of_int payoff)] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | GoalPattern (arg, var, body) ->
+ let head = "goal", [arg; Var var] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Terminal body ->
+ let head = "terminal", [] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Role arg -> [("role", [arg]), [], []]
+ | Initial (arg, body) ->
+ let head = "init", [arg] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Atomic (rel, args) -> [(rel, args), [], []]
+
+let defs_of_rules rules : (string * exp_def_branch list) list =
+ Aux.map_reduce
+ (fun ((drel, params), body, neg_body) ->
+ drel,(params, body, List.map (fun a->[a]) 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) =
+ 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
+ (rel, args), body, neg_body) 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) =
+ match
+ List.partition (fun (_, branches) ->
+ List.for_all (fun (_, body, neg_body) ->
+ List.for_all (fun (rel1,_) ->
+ rel1 = "distinct" || rel1 = "true" || rel1 = "does" ||
+ not (List.mem_assoc rel1 defs))
+ (if def then body @ List.concat neg_body
+ else List.concat neg_body)) branches) defs
+ with
+ | [], [] -> List.rev strata
+ | stratum, [] -> List.rev (stratum::strata)
+ | [], _ ->
+ if def then raise
+ (Lexer.Parsing_error
+ "GDL.stratify: recursive non-static definitions not handled yet")
+ else raise
+ (Lexer.Parsing_error
+ "GDL.stratify: cyclic negation dependency")
+ | stratum, rules -> stratify (stratum::strata) rules
+
+
+let rec subst_one (x, term as sb) = function
+ | Var y when x=y -> term
+ | MVar y when x=y -> term
+ | (Const _ | Var _ | MVar _ as t) -> t
+ | Func (f, args) ->
+ Func (f, List.map (subst_one sb) args)
+
+let rec unify sb terms1 terms2 =
+ match terms1, terms2 with
+ | [], [] -> sb
+ | Const a::terms1, Const b::terms2 when a=b ->
+ unify sb terms1 terms2
+ | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
+ unify sb (args1 @ terms1) (args2 @ terms2)
+ | Var x::terms1, Var y::terms2 when x=y ->
+ unify sb terms1 terms2
+ | (Var x::terms1, (Var _ | Const _ as term)::terms2
+ | (Const _ as term)::terms1, Var x::terms2) ->
+ let sb1 = x, term in
+ unify (sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb)
+ (List.map (subst_one sb1) terms1)
+ (List.map (subst_one sb1) terms2)
+ | (Var x::_, term::_ | term::_, Var x::_)
+ when Aux.Strings.mem x (term_vars term) ->
+ raise Not_found
+ | Var x::terms1, term::terms2 | term::terms1, Var x::terms2 ->
+ let sb1 = x, term in
+ unify (sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb)
+ (List.map (subst_one sb1) terms1)
+ (List.map (subst_one sb1) terms2)
+ | _ -> raise Not_found
+
+(* 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 =
+ 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
+ | 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 ->
+ (* we don't substitute because metavariables are linear *)
+ match_meta sb ((x, term)::m_sb) terms1 terms2
+ | MVar _::_, _ -> raise Not_found
+ | term::terms1, Var x::terms2 ->
+ let sb1 = x, term in
+ let sb =
+ if List.mem_assoc x sb then
+ if List.assoc x sb = term then sb
+ else raise Not_found
+ else sb1::sb in
+ match_meta sb m_sb terms1 terms2
+ | _ -> raise Not_found
+
+
+(* 3c1 *)
+let generalize term1 term2 =
+ let fresh_count = ref 0 in
+ let rec loop pf terms1 terms2 =
+ match terms1, terms2 with
+ | [], [] -> (0, 0), []
+ | (Const a as cst)::terms1, Const b::terms2 when a=b ->
+ let (good_vars, good_csts), gens = loop pf terms1 terms2 in
+ (good_vars, good_csts+1), cst::gens
+ | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
+ let (good_vars1, good_csts1), gen_args = loop f args1 args2 in
+ let (good_vars2, good_csts2), gens = loop pf terms1 terms2 in
+ (good_vars1+good_vars2, good_csts1+good_csts2),
+ (Func (f,gen_args))::gens
+ | (Var x as var)::terms1, Var y::terms2 when x=y ->
+ let (good_vars, good_csts), gens = loop pf terms1 terms2 in
+ (good_vars+1, good_csts), var::gens
+ | _::terms1, _::terms2 ->
+ let measure, gens = loop pf terms1 terms2 in
+ incr fresh_count;
+ measure, MVar ("MV"^string_of_int !fresh_count)::gens
+ | _::_, [] | [], _::_ -> raise
+ (Lexer.Parsing_error
+ ("GDL.generalize: arity mismatch at function "^pf)) in
+ let measure, gens = loop "impossible" [term1] [term2] in
+ measure, !fresh_count, List.hd gens
+
+(* 3c2 *)
+let abstract_consts fresh_count term =
+ let fresh_count = ref fresh_count in
+ let rec loop = function
+ | Const _ -> incr fresh_count; MVar ("MV"^string_of_int !fresh_count)
+ | Func (f,args) -> Func (f, List.map loop args)
+ | term -> term in
+ loop term
+
+let rec subst sb = function
+ | Var y as t ->
+ (try List.assoc y sb with Not_found -> t)
+ | MVar y as t ->
+ (try List.assoc y sb with Not_found -> t)
+ | Const _ as t -> t
+ | 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 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
+ let vars2, terms2 = List.split sb2 in
+ let var_terms = List.map (fun v->Var v) (vars1 @ vars2) in
+ unify [] var_terms (terms1 @ terms2)
+
+let subst_br sb (head, body, neg_body) =
+ List.map (subst sb) head,
+ List.map (subst_rel sb) body,
+ List.map (List.map (subst_rel sb)) neg_body
+
+let fact_str (rel, args) =
+ "("^rel^" "^String.concat " " (List.map term_str args) ^")"
+
+let tuples_str tups =
+ let tup_str tup =
+ "("^String.concat " " (List.map term_str tup) ^")" in
+ String.concat " " (List.map tup_str tups)
+
+let facts_str facts =
+ String.concat " " (List.map fact_str facts)
+let neg_facts_str negs =
+ String.concat " "
+ (List.map (fun d -> "(not (and "^facts_str d^"))") negs)
+
+let 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)
+
+let sb_str sb =
+ String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
+
+(* 1b *)
+
+(* TODO: optimize by using rel-indexing (also in [aggregate_playout]).
+ TODO: optimize by using constant-time append data structure. *)
+let saturate base rules =
+
+ let instantiate_one tot_base cur_base irules =
+ Aux.concat_map (function
+ | head, [], neg_body ->
+ if List.mem head tot_base then []
+ else if List.exists (fun (rel,args as neg_atom) ->
+ rel = "distinct" && Aux.not_unique args ||
+ List.mem neg_atom tot_base) neg_body then []
+ else [Aux.Left head]
+ | head, cond1::body, neg_body ->
+ Aux.map_try (fun fact ->
+ (* {{{ log entry *)
+
+ if !debug_level > 5 then (
+ Printf.printf "instantiate_one: trying to unify %s and %s\n%!"
+ (fact_str fact) (fact_str cond1)
+ );
+
+ (* }}} *)
+ let sb = unify_rels fact cond1 in
+ (* {{{ log entry *)
+ if !debug_level > 5 then (
+ Printf.printf "instantiate_one: succeeded with %s\n%!"
+ (sb_str sb)
+ );
+ (* }}} *)
+ let irule =
+ subst_rel sb head,
+ subst_rels sb body, subst_rels sb neg_body in
+ Aux.Right irule
+ ) cur_base) irules in
+
+ let rec inst_stratum old_base old_irules cur_base cur_irules =
+ (* {{{ log entry *)
+
+ if !debug_level > 4 then (
+ Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!"
+ (facts_str old_base) (facts_str cur_base);
+ Printf.printf
+ "inst_stratum: #old_irules = %d, #cur_irules = %d\n%!"
+ (List.length old_irules) (List.length cur_irules)
+ );
+
+ (* }}} *)
+ let base = Aux.unique_sorted (cur_base @ old_base)
+ and irules = Aux.unique_sorted (cur_irules @ old_irules) in
+ let new_base1, new_irules1 =
+ Aux.partition_choice (instantiate_one base cur_base cur_irules) in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "inst_stratum: cur-cur = %s\n%!"
+ (facts_str new_base1)
+ );
+ (* }}} *)
+ let new_base2, new_irules2 =
+ Aux.partition_choice (instantiate_one base cur_base old_irules) in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "inst_stratum: cur-old = %s\n%!"
+ (facts_str new_base2)
+ );
+ (* }}} *)
+ let new_base3, new_irules3 =
+ Aux.partition_choice (instantiate_one base old_base cur_irules) in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "inst_stratum: old-cur = %s\n%!"
+ (facts_str new_base3)
+ );
+ (* }}} *)
+ let new_base = Aux.unique_sorted (new_base1 @ new_base2 @ new_base3)
+ and new_irules = Aux.unique_sorted
+ (new_irules1 @ new_irules2 @ new_irules3) in
+ let new_base =
+ List.filter (fun f->not (List.mem f base)) new_base in
+ let new_irules =
+ List.filter (fun f->not (List.mem f irules)) new_irules in
+ if new_base = [] && new_irules = []
+ then base
+ else inst_stratum base irules new_base new_irules in
+
+ let rec instantiate base = function
+ | [] -> base
+ | stratum::strata ->
+ instantiate (inst_stratum [] [] base stratum) strata in
+
+ instantiate base
+ (List.map rules_of_defs (stratify [] (defs_of_rules rules)))
+
+
+let playing_as = ref (Const "uninitialized")
+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 *)
+
+(* Need a global access so that the count can be reset between
+ different translations. (Generalization uses a local [fresh_count]
+ state.) *)
+let freshen_count = ref 0
+
+(* TODO: do proper elegant renaming... *)
+let freshen_branch (args, body, neg_body) =
+ incr freshen_count;
+ let rec map_vnames = function
+ | Var x -> Var (x^string_of_int !freshen_count)
+ | MVar x -> MVar (x^string_of_int !freshen_count)
+ | 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
+ List.map map_vnames args,
+ List.map map_rel body,
+ List.map (List.map map_rel) neg_body
+
+let freshen_def_branches =
+ List.map freshen_branch
+
+(* 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 =
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding branch %s\n%!" (def_str ("BRANCH", [br]));
+ );
+ (* }}} *)
+ (* 6a *)
+ let sols =
+ List.fold_left (fun sols (rel, args as atom) ->
+ (let try def =
+ freshen_def_branches (List.assoc rel defs) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding positive %s by %s\n%!" rel
+ (def_str (rel, def))
+ );
+ (* }}} *)
+ Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ Aux.map_some (fun (dparams, dbody, dneg_body) ->
+ try
+ let sb1 = unify [] dparams args in
+ Some (
+ subst_rels sb1 (dbody @ pos_sol),
+ List.map (subst_rels sb1) (dneg_body @ neg_sol),
+ extend_sb sb1 sb)
+ with Not_found -> None
+ ) def
+ ) sols
+ with Not_found ->
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ subst_rel sb atom::pos_sol, neg_sol, sb) sols))
+ ([[],[],[]]) body in
+ (* 6b *)
+ let sols =
+ List.fold_left (fun sols -> function [rel, args as atom] ->
+ (let try def =
+ freshen_def_branches (List.assoc rel defs) in
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ let more_neg =
+ Aux.map_some (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);
+ try
+ let sb1 = unify [] dparams args in
+ Some (subst_rels sb1 dbody)
+ with Not_found -> None
+ ) def in
+ pos_sol, more_neg @ neg_sol, sb
+ ) sols
+ with Not_found ->
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ pos_sol, [subst_rel sb atom]::neg_sol, sb) sols)
+ | _ -> failwith
+ "GDL.subst_def_branch: unimplemented, see (6b1) of spec")
+ sols neg_body in
+ Aux.map_some (fun (pos_sol, neg_sol, sb) ->
+ if List.mem [] neg_sol then None
+ else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols
+
+(* Stratify and expand all relations in the given set. *)
+let expand_def_rules ?(more_defs=[]) rules =
+ let rec loop base = function
+ | [] -> base
+ | stratum::strata ->
+ let step = List.map (fun (rel, branches) ->
+ rel, Aux.concat_map
+ (subst_def_branch (more_defs@base)) branches) stratum in
+ loop (base @ step) strata in
+ match stratify ~def:true [] (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
+ | def_strata -> loop more_defs def_strata
+
+
+(* As [subst_def_branch], but specifically for "legal" definition and
+ result structured by "legal" definition branches. *)
+(* 7b *)
+let subst_legal_rule
+ (legal_args, legal_body, legal_neg_body : exp_def_branch)
+ (head, body, neg_body : exp_def_branch)
+ : (exp_def_branch * exp_def_branch) option =
+ if List.exists (List.exists (fun (rel,_)->rel="does")) neg_body
+ then failwith
+ "GDL.translate_game: negated \"does\" conditions not implemented yet";
+ try
+ let body, more_neg_body, sb =
+ List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) ->
+ if rel = "does" then
+ List.rev_append legal_body body,
+ List.rev_append legal_neg_body more_neg_body,
+ unify sb legal_args args
+ else atom::body, more_neg_body, sb) ([],[],[]) body in
+
+ Some (
+ (List.map (subst sb) legal_args,
+ List.map (subst_rel sb) legal_body,
+ List.map (List.map (subst_rel sb)) legal_neg_body),
+ (List.map (subst sb) head,
+ List.map (subst_rel sb) (List.rev body),
+ List.map (List.map (subst_rel sb))
+ (List.rev_append more_neg_body neg_body)))
+ with Not_found -> None
+
+(* 1 *)
+
+(* Collect the aggregate playout, but also the actions available in
+ the state. *)
+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
+ 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)
+ does) players
+ then raise Not_found
+ else
+ let step = saturate (does @ base) rules in
+ let step = Aux.map_some (function ("next", [arg]) -> Some arg
+ | _ -> None) step in
+ if !aggregate_fixpoint && (* fixpoint reached *)
+ List.for_all (function
+ | Func (_,[arg]) when
+ Aux.array_existsi (fun _ player -> arg=player) players -> true
+ | term -> List.mem term current
+ ) step
+ then raise Not_found
+ else
+ List.map snd does, step
+
+(* Besides the aggregate playout, also return the separation of rules
+ into static and dynamic. Note that the list of playout states is
+ one longer than that of playout actions. *)
+let aggregate_playout players horizon rules =
+ (* separate and precompute the static part *)
+ let rec separate static_rels state_rels =
+ let static, more_state =
+ List.partition (fun rel ->
+ List.for_all (fun ((rule,_), body, neg_body) ->
+ rule <> rel || List.for_all (fun srel ->
+ not (List.mem_assoc srel (neg_body @ body))) state_rels)
+ rules) static_rels in
+ if more_state = [] then static_rels, state_rels
+ else separate static (more_state @ state_rels) in
+ let static_rels, state_rels =
+ separate (List.map (fun ((r,_),_,_)->r) rules)
+ ["init"; "does"; "true"; "next"; "terminal"; "goal"] in
+ let static_rules, dynamic_rules = List.partition
+ (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
+ let rec loop actions_accu state_accu step state =
+ (* {{{ log entry *)
+
+ if !debug_level > 0 then (
+ Printf.printf "aggregate_playout: step %d...\n%!" step
+ );
+
+ (* }}} *)
+ (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 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 ->
+ 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
+ let init_state =
+ Aux.map_some (function ("init", [arg]) -> Some arg
+ | _ -> None) init_base in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "aggregate_playout: init %s\n%!"
+ (String.concat " " (List.map term_str init_state))
+ );
+ (* }}} *)
+ static_rules, dynamic_rules, static_base, init_state,
+ loop [] [] 0 init_state
+
+
+let find_cycle cands =
+ let rec loop cycle trav pref rem path =
+ if cycle = [] then
+ let ini = [List.hd path] in
+ loop ini ini ini [] (List.tl path)
+ else match path, rem with
+ | _, [] -> loop cycle trav [] cycle path
+ | [], _ -> cycle (* consumed the whole path *)
+ | x::tail, y::rem when x=y || x = None->
+ (* either elements agree or indifferent path element *)
+ loop cycle (x::trav) (y::pref) rem tail
+ | x::tail, None::rem ->
+ (* instantiating undecided cycle element *)
+ loop (List.rev pref @ [x] @ rem) (x::trav) (x::pref) rem tail
+ | x::tail, _::_ ->
+ (* mismatch: grow the cycle to current point *)
+ let trav = x::trav in
+ let cycle = List.rev trav in
+ loop cycle trav [] cycle tail in
+ loop [] [] [] [] cands
+
+let cmp_masks t1 t2 =
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "cmp_masks: %s <= %s .. " (term_str t1) (term_str t2);
+ );
+ (* }}} *)
+ try ignore (match_meta [] [] [t2] [t1]);
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "true\n%!";
+ );
+ (* }}} *)
+ true
+ with Not_found ->
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "false\n%!";
+ );
+ (* }}} *)
+ false
+
+let rec blank_out = function
+ | Const a as c, Const b when a = b -> c
+ | (*Var _ as*) v, Var _ -> v
+ | t, MVar _ -> Const "_BLANK_"
+ | Func (f, f_args), Func (g, g_args) when f = g ->
+ Func (f, List.map blank_out (List.combine f_args g_args))
+ | a, b ->
+ Printf.printf "blank_out mismatch: term %s, mask %s\n%!"
+ (term_str a) (term_str b);
+ assert false
+
+let translate_game 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
+ let rules = Aux.concat_map rules_of_entry game_descr in
+ 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
+ let noop_cands = List.map (fun actions ->
+ let actions = Aux.map_reduce
+ (function [player; action] -> player, action
+ | _ -> assert false) (fun y x->x::y) [] actions in
+ (* 2a *)
+ List.map (function
+ | player, [Const _ as noop] -> player, Some noop
+ | player, _ -> player, None) actions
+ ) agg_actions in
+ let control_cands = List.map (fun noop_cands ->
+ List.fold_left (fun accu -> function
+ | player, None ->
+ if accu = None then Some player
+ else raise
+ (Lexer.Parsing_error
+ ("GDL.initialize_game: branching arena graphs"^
+ " or simultaneous moves not supported yet"))
+ | _, Some _ -> accu) None noop_cands) noop_cands in
+ let noop_cands = List.map Aux.collect noop_cands in
+ (* throw in players with (multiple) constant actions *)
+ let control_noop_cands = List.map2 (fun ccand noops ->
+ let nccands, noops = Aux.partition_map
+ (function player, [] -> assert false
+ | player, [noop] -> Aux.Right (player, noop)
+ | player, more_actions -> Aux.Left player) noops in
+ match ccand, nccands with
+ | None, [player] -> Some player, noops
+ | Some _, [] -> ccand, noops
+ | _ -> failwith
+ "GDL.initialize_game: simultaneous moves not supported yet"
+ ) control_cands noop_cands in
+ let control_cands, noop_cands =
+ List.split control_noop_cands in
+ (* 2b *)
+ let loc_players = find_cycle control_cands in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "translate_game: location players %s\n%!"
+ (String.concat " "
+ (List.map (function Some t->term_str t | None->"None")
+ loc_players))
+ );
+ (* }}} *)
+ let loc_players = Array.of_list
+ (List.map (function Some p -> p | None -> player_terms.(0))
+ loc_players) in
+ let loc_n = Array.length loc_players in
+ let find_player_locs player =
+ Aux.array_argfind_all (fun p->p=player) loc_players in
+ (* noop actions of a player in a location *)
+ let loc_noops =
+ let i = ref 0 in
+ let noops = ref noop_cands in
+ let loc_noops = Array.make_matrix loc_n players_n None in
+ while !noops <> [] do
+ List.iter (function _, None -> ()
+ | player, (Some _ as noop) ->
+ let p_i = find_player player in
+ if loc_noops.(!i).(p_i) = None
+ then loc_noops.(!i).(p_i) <- noop
+ else if loc_noops.(!i).(p_i) <> noop
+ (* moves are not simultaneous, but different [noop] actions
+ are used by the same player -- can be resolved by
+ introducing separate locations for each noop case *)
+ then failwith
+ "GDL.translate_game: noop-driven location splits unimplemented")
+ (List.hd !noops);
+ incr i; if !i = loc_n then i := 0;
+ noops := List.tl !noops
+ done;
+ loc_noops in
+ (* 6 *)
+ let static_rules, exp_static_rules =
+ List.partition (fun ((rel,args), _, _) ->
+ List.length args <= !expand_arity_above ||
+ List.exists (function ((r,_),[],[]) when rel=r-> true
+ | _ -> 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 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))
+ );
+ (* }}} *)
+ (* 3 *)
+ let legal_rules = List.assoc "legal" exp_defs in
+ let next_rules = List.assoc "next" exp_defs in
+ (* 3b *)
+ let exp_next =
+ Aux.concat_map (subst_def_branch ["does", 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))
+ );
+
+ (* }}} *)
+ (* 3c *)
+ let masks = List.map (function
+ | [next_arg], body, neg_body ->
+ let collect = Aux.map_some
+ (function "true", [arg] -> Some arg
+ | "true", _ -> raise
+ (Lexer.Parsing_error
+ ("GDL.initialize_game: invalid arity of \"true\" atom"))
+ | _ -> None) in
+ let pos_cands = collect body in
+ let neg_cands = Aux.concat_map collect neg_body in
+ let pos_gens = List.map (generalize next_arg) pos_cands in
+ let neg_gens = List.map (generalize next_arg) neg_cands in
+ (* using the fact that Pervasives.compare is lexicographic *)
+ let pos_gen = List.fold_left max ((-1,0),0,Const "") pos_gens in
+ let neg_gen = List.fold_left max ((-1,0),0,Const "") neg_gens in
+ let (_, fresh_count, mask as gen) = max pos_gen neg_gen in
+ if gen == pos_gen then mask
+ else abstract_consts fresh_count mask
+ | _ -> raise
+ (Lexer.Parsing_error
+ ("GDL.initialize_game: invalid arity of \"next\" atom")))
+ exp_next in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "translate_game: Generalized element terms (mask candidates):\n%s\n%!"
+ (String.concat " " (List.map term_str masks))
+ );
+ (* }}} *)
+ (* find minimal *)
+ let masks = Aux.maximal (fun t1 t2->cmp_masks t2 t1) masks in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "translate_game: Masks:\n%s\n%!"
+ (String.concat " " (List.map term_str masks))
+ );
+ (* }}} *)
+ (* 3e *)
+ let elements = List.fold_left (fun elements term ->
+ let mask, sb, m_sb =
+ match
+ Aux.map_try (fun mask ->
+ mask, match_meta [] [] [term] [mask]) masks
+ with [mask, (sb, m_sb)] -> mask, sb, m_sb
+ | _ -> assert false in (* masks are minimal *)
+ let sbs, elements =
+ try Aux.pop_assoc mask elements
+ with Not_found -> [], elements in
+ (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) ->
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "mask-elements:";
+ );
+ (* }}} *)
+ let struc, m_elements =
+ List.fold_left (fun (struc, m_elements) sb ->
+ let e_term = subst sb mask in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf ", %s%!" (term_to_name e_term)
+ );
+ (* }}} *)
+ let struc, elem =
+ Structure.add_new_elem struc ~name:(term_to_name e_term) () in
+ struc, (sb, elem)::m_elements
+ ) (struc, []) sbs in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "\n%!";
+ );
+ (* }}} *)
+ struc, (mask, m_elements)::elements
+ ) (struc, []) elements in
+ (* 4 *)
+ (* currently, position paths are approximated by variables
+ (non-variable positions are ignored) *)
+ let mask_paths = Aux.concat_map (function _, [] -> assert false
+ | 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
+ let static_rels =
+ List.map (fun (rel,args) ->
+ rel, List.length args,
+ Aux.all_tuples_for args mask_paths) static_rels in
+ let static_base = Aux.collect static_base in
+ (* TODO: optimize by indexing elements by path position
+ terms (currently, substitution values) *)
+ let struc =
+ 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 "__"
+ (List.map (fun (mask,v)->
+ term_to_name mask ^ "_" ^ v) ptup) in
+ let struc =
+ Structure.add_rel_name rname (List.length ptup) struc in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "static-rel: %s, of... %!" rname;
+ );
+ (* }}} *)
+ let elem_sets =
+ List.map (fun (mask,v)->
+ List.map (fun (sb,elem)->
+ try List.assoc v sb, elem
+ with Not_found -> assert false)
+ (List.assoc mask elements)) ptup in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%s ... %!" (String.concat "x" (
+ List.map (fun x-> string_of_int (List.length x)) elem_sets));
+ );
+ (* }}} *)
+ let elem_tups =
+ Aux.concat_map (fun ttup ->
+ let elem_sets = List.map2 (fun term elems ->
+ Aux.map_some (fun (tcand, e) ->
+ if tcand=term then Some e else None) elems
+ ) ttup elem_sets in
+ List.map Array.of_list (Aux.product elem_sets)
+ ) brel_tups in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%d tuples, adding to struc...%!"
+ (List.length elem_tups);
+ );
+ (* }}} *)
+ let res = Structure.unsafe_add_rels struc rname elem_tups in
+ (* {{{ log entry *)
+
+ if !debug_level > 1 then (
+ Printf.printf " done\n%!";
+ );
+
+ (* }}} *)
+ res
+ ) struc path_tups
+ ) struc static_rels in
+
+ (* 4b *)
+ let struc = List.fold_left (fun struc (mask,v) ->
+ let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
+ let struc =
+ 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) ->
+ List.fold_left (fun tups (sb2, e2) ->
+ try
+ if List.assoc v sb1 = List.assoc v sb2
+ then [|e1; e2|]::[|e2; e1|]::tups
+ else tups
+ with Not_found -> assert false
+ ) tups elems
+ ) [] elems in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups);
+ );
+ (* }}} *)
+ l...
[truncated message content] |
|
From: <luk...@us...> - 2011-01-29 13:11:39
|
Revision: 1286
http://toss.svn.sourceforge.net/toss/?rev=1286&view=rev
Author: lukstafi
Date: 2011-01-29 13:11:29 +0000 (Sat, 29 Jan 2011)
Log Message:
-----------
GDL: Manual (i.e. hard-coded) translation interface.
Modified Paths:
--------------
trunk/Toss/Play/GDL.ml
trunk/Toss/Play/GDL.mli
trunk/Toss/Play/GameTest.ml
trunk/Toss/Play/Server.ml
Modified: trunk/Toss/Play/GDL.ml
===================================================================
--- trunk/Toss/Play/GDL.ml 2011-01-29 00:22:13 UTC (rev 1285)
+++ trunk/Toss/Play/GDL.ml 2011-01-29 13:11:29 UTC (rev 1286)
@@ -1961,38 +1961,165 @@
Structure.empty_structure element_names in
*)
-let initialize_game state player game_descr startcl =
+let player_name_terms = ref [|Const "uninit"|]
+
+
+let manual_translation = ref true
+let manual_game = ref "tictactoe"
+
+let initialize_game_tictactoe state player game_descr startcl =
+ state := state_of_file "./examples/Tic-Tac-Toe.toss";
playing_as := player;
- let struc = translate_game game_descr in
- ignore struc;
- (* state := Arena.process_definition ~extend_state:(!state) defs; *)
- 2, 100, 2.0
+ game_description := game_descr;
+ player_name_terms := [|Const "X"; Const "O"|];
+ let effort, horizon, heur_adv_ratio =
+ 2, 100, 4.0 in
+ effort, horizon, heur_adv_ratio
+let initialize_game_gomoku state player game_descr startcl =
+ state := state_of_file "./examples/Gomoku.toss";
+ playing_as := player;
+ game_description := game_descr;
+ player_name_terms := [|Const "X"; Const "O"|];
+ let effort, horizon, heur_adv_ratio =
+ 2, 100, 4.0 in
+ effort, horizon, heur_adv_ratio
-let translate_last_action actions =
+let initialize_game_breakthrough state player game_descr startcl =
+ state := state_of_file "./examples/Breakthrough.toss";
+ playing_as := player;
+ game_description := game_descr;
+ player_name_terms := [|Const "WHITE"; Const "BLACK"|];
+ let effort, horizon, heur_adv_ratio =
+ 2, 100, 2.0 in
+ effort, horizon, heur_adv_ratio
+
+let initialize_game state player game_descr startcl =
+ match !manual_translation, !manual_game with
+ | true, "tictactoe" ->
+ initialize_game_tictactoe state player game_descr startcl
+ | true, "gomoku" ->
+ initialize_game_gomoku state player game_descr startcl
+ | true, "breakthrough" ->
+ initialize_game_breakthrough state player game_descr startcl
+ | true, game ->
+ failwith ("GDL: manual translation of unknown game "^game)
+ | false, _ ->
+ failwith "GDL: automatic translation not finished yet"
+
+let s2i = int_of_string
+
+let translate_last_action_tictactoe actions =
match actions with
| [] ->
(* start of game -- Server will handle this answer as NOOP *)
"", []
| [Func ("MARK", [Const col; Const row]); Const "NOOP"] ->
- "Cross", ["a1",
+ "Cross", ["a",
Structure.board_coords_name
- (int_of_string col, int_of_string row)]
+ (s2i col, s2i row)]
| [ Const "NOOP"; Func ("MARK", [Const col; Const row])] ->
- "Circle", ["a1",
+ "Circle", ["a",
Structure.board_coords_name
- (int_of_string col, int_of_string row)]
+ (s2i col, s2i row)]
| _ -> assert false
+
+let translate_last_action_gomoku actions =
+ let number_of_letter c =
+ string_of_int ((Char.code (Char.lowercase c)) - 96) in
+ match actions with
+ | [] ->
+ (* start of game -- Server will handle this answer as NOOP *)
+ "", []
+ | [Func ("MARK", [Const col; Const row]); Const "NOOP"] ->
+ "Cross", ["a1", ((String.lowercase col) ^ (number_of_letter row.[0]))]
+ | [ Const "NOOP"; Func ("MARK", [Const col; Const row])] ->
+ "Circle", ["a1", ((String.lowercase col) ^ (number_of_letter row.[0]))]
+ | _ -> assert false
+let translate_last_action_breakthrough actions =
+ match actions with
+ | [] ->
+ (* start of game -- Server will handle this answer as NOOP *)
+ "", []
+ | [Func ("MOVE", [Const x1; Const y1; Const x2; Const y2]);
+ Const "NOOP"] when x1 = x2 ->
+ "WhiteStraight",
+ ["a1", Structure.board_coords_name (s2i x1, s2i y1);
+ "a2", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Func ("MOVE", [Const x1; Const y1; Const x2; Const y2]);
+ Const "NOOP"] ->
+ "WhiteDiag",
+ ["a", Structure.board_coords_name (s2i x1, s2i y1);
+ "b", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Const "NOOP";
+ Func ("MOVE", [Const x1; Const y1; Const x2; Const y2])]
+ when x1 = x2 ->
+ "BlackStraight",
+ ["a2", Structure.board_coords_name (s2i x1, s2i y1);
+ "a1", Structure.board_coords_name (s2i x2, s2i y2)]
+ | [Const "NOOP";
+ Func ("MOVE", [Const x1; Const y1; Const x2; Const y2])] ->
+ "BlackDiag",
+ ["a", Structure.board_coords_name (s2i x1, s2i y1);
+ "b", Structure.board_coords_name (s2i x2, s2i y2)]
+ | _ -> assert false
+
+let translate_last_action actions =
+ match !manual_translation, !manual_game with
+ | true, "tictactoe" ->
+ translate_last_action_tictactoe actions
+ | true, "gomoku" ->
+ translate_last_action_gomoku actions
+ | true, "breakthrough" ->
+ translate_last_action_breakthrough actions
+ | true, game ->
+ failwith ("GDL: manual translation of unknown game "^game)
+ | false, _ ->
+ failwith "GDL: automatic translation not finished yet"
+
let our_turn state =
let loc = state.Arena.cur_loc in
let loc_player =
state.Arena.game.Arena.graph.(loc).Arena.player in
- !player_terms.(loc_player) = !playing_as
+ !player_name_terms.(loc_player) = !playing_as
-let translate_move rule emb new_state =
+let translate_move_tictactoe rule emb new_state =
let struc = new_state.Arena.struc in
let elem = snd (List.hd emb) in
let c, r =
Structure.board_elem_coords (Structure.elem_str struc elem) in
Printf.sprintf "(MARK %d %d)" c r
+
+let translate_move_gomoku rule emb new_state =
+ let struc = new_state.Arena.struc in
+ let elem = snd (List.hd emb) in
+ let c, r =
+ Structure.board_elem_coords (Structure.elem_str struc elem) in
+ let cs, rs = Char.chr (c + 64), Char.chr (r + 64) in
+ Printf.sprintf "(MARK %c %c)" cs rs
+
+let translate_move_breakthrough rule emb new_state =
+ let struc = new_state.Arena.struc in
+ match emb with
+ | [(_,a); (_,b)] ->
+ let a, b = if rule = "BlackStraight" then b, a else a, b in
+ let x1, y1 =
+ Structure.board_elem_coords (Structure.elem_str struc a)
+ and x2, y2 =
+ Structure.board_elem_coords (Structure.elem_str struc b) in
+ Printf.sprintf "(MOVE %d %d %d %d)" x1 y1 x2 y2
+ | _ -> assert false
+
+let translate_move rule emb new_state =
+ match !manual_translation, !manual_game with
+ | true, "tictactoe" ->
+ translate_move_tictactoe rule emb new_state
+ | true, "gomoku" ->
+ translate_move_gomoku rule emb new_state
+ | true, "breakthrough" ->
+ translate_move_breakthrough rule emb new_state
+ | true, game ->
+ failwith ("GDL: manual translation of unknown game "^game)
+ | false, _ ->
+ failwith "GDL: automatic translation not finished yet"
Modified: trunk/Toss/Play/GDL.mli
===================================================================
--- trunk/Toss/Play/GDL.mli 2011-01-29 00:22:13 UTC (rev 1285)
+++ trunk/Toss/Play/GDL.mli 2011-01-29 13:11:29 UTC (rev 1286)
@@ -6,6 +6,9 @@
val aggregate_drop_negative : bool ref
val aggregate_fixpoint : bool ref
+val manual_translation : bool ref
+val manual_game : string ref
+
type term =
| Const of string
| Var of string
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-01-29 00:22:13 UTC (rev 1285)
+++ trunk/Toss/Play/GameTest.ml 2011-01-29 13:11:29 UTC (rev 1286)
@@ -249,6 +249,9 @@
(fun () ->
let old_det_suggest = !Game.deterministic_suggest in
Game.deterministic_suggest := true;
+ let old_translation = !GDL.manual_translation in
+ GDL.manual_translation := true;
+ GDL.manual_game := "tictactoe";
let in_ch = open_in "./Play/ServerGDLTest.in" in
let out_ch = open_out "./Play/ServerGDLTest.temp" in
(try while true do
Modified: trunk/Toss/Play/Server.ml
===================================================================
--- trunk/Toss/Play/Server.ml 2011-01-29 00:22:13 UTC (rev 1285)
+++ trunk/Toss/Play/Server.ml 2011-01-29 13:11:29 UTC (rev 1286)
@@ -288,7 +288,11 @@
if r_name <> "" then (
let {Arena.rules=rules; graph=graph} = !state.Arena.game in
let struc = !state.Arena.struc in
- let fn s n = Structure.find_elem s n in
+ let fn s n =
+ try Structure.find_elem s n
+ with Not_found -> failwith
+ ("Server: GDL translation error -- unknown element "^n^
+ " of structure "^(Structure.str s)) in
let r = List.assoc r_name rules in
let lhs =
r.ContinuousRule.discrete.DiscreteRule.lhs_struc in
@@ -497,6 +501,9 @@
("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose");
("-d", Arg.Int (fun i -> set_debug_level i), " Toss server debug log level");
("-s", Arg.String (fun s -> (server := s)), " server (default: localhost)");
+ ("-gdl", Arg.String (fun s ->
+ GDL.manual_game := s; GDL.manual_translation := true),
+ " GDL game for manual (i.e. hard-coded) translation (tictactoe, gomoku, breakthrough)");
("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)");
("-t", Arg.Int (fun i -> (dtimeout := i)), " timeout (default: none)");
] in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-29 00:22:20
|
Revision: 1285
http://toss.svn.sourceforge.net/toss/?rev=1285&view=rev
Author: lukstafi
Date: 2011-01-29 00:22:13 +0000 (Sat, 29 Jan 2011)
Log Message:
-----------
GDL translation work in progress: preparing GDL rules to be translated as Toss rules.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/Play/GDL.ml
trunk/Toss/Play/GDL.mli
trunk/Toss/Play/GDLTest.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-01-23 21:35:16 UTC (rev 1284)
+++ trunk/Toss/Formula/Aux.ml 2011-01-29 00:22:13 UTC (rev 1285)
@@ -15,6 +15,10 @@
(c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') ||
(c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9')
+let fst3 (a,_,_) = a
+let snd3 (_,a,_) = a
+let trd3 (_,_,a) = a
+
(* {2 Helper functions on lists and other functions lacking from the
standard library.} *)
let concat_map f l =
@@ -47,6 +51,17 @@
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
+ | [] -> []
+ | (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,List.rev vs)::l)
+ (k0, [v0], []) tl in
+ List.rev ((k0,List.rev vs)::l)
+
+
let list_remove v l = List.filter (fun w->v<>w) l
let rec rev_assoc l x = match l with
@@ -60,6 +75,13 @@
if b = x then aux (a::acc) l else aux acc l in
aux [] l
+let assoc_all x l =
+ let rec aux acc = function
+ | [] -> acc
+ | (a,b)::l ->
+ if a = x then aux (b::acc) l else aux acc l in
+ aux [] l
+
let rec replace_assoc k v = function
| [] -> [k, v]
| (a, b as pair) :: l ->
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-01-23 21:35:16 UTC (rev 1284)
+++ trunk/Toss/Formula/Aux.mli 2011-01-29 00:22:13 UTC (rev 1285)
@@ -9,6 +9,10 @@
val is_digit : char -> bool
+val fst3 : 'a * 'b * 'c -> 'a
+val snd3 : 'a * 'b * 'c -> 'b
+val trd3 : 'a * 'b * 'c -> 'c
+
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
@@ -28,6 +32,10 @@
val map_reduce :
('a -> 'b * 'c) -> ('d -> 'c -> 'd) -> 'd -> 'a list -> ('b * 'd) list
+(** Collects elements by key. Same as
+ [map_reduce (fun x -> x) (fun y x->x::y) []]. *)
+val collect : ('a * 'b) list -> ('a * 'b list) list
+
(** Remove all elements equal to the argument, using structural
inequality. *)
val list_remove : 'a -> 'a list -> 'a list
@@ -40,6 +48,9 @@
value (using structural equality). Returns elements in reverse order. *)
val rev_assoc_all : ('a * 'b) list -> 'b -> 'a list
+(** Return all values of a key. *)
+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. *)
val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-01-23 21:35:16 UTC (rev 1284)
+++ trunk/Toss/Formula/AuxTest.ml 2011-01-29 00:22:13 UTC (rev 1285)
@@ -4,6 +4,9 @@
let print_alist f l =
String.concat ", " (List.map (fun (k,v) -> k^": "^f v) l)
+let print_list f l =
+ "["^String.concat "; " (List.map f l)^"]"
+
let tests = "Aux" >::: [
"concat_map, map_some, array_map_some" >::
(fun () ->
@@ -26,7 +29,7 @@
(Aux.array_map_some f [|`A;`B;`C;`D|]);
);
- "map_reduce" >::
+ "map_reduce, collect" >::
(fun () ->
let mapf = function `A -> "1", ["a";"b"] | `B -> "2", ["c"]
| `C -> "1", [] | `D -> "2", ["d";"e"] in
@@ -39,6 +42,11 @@
["abra",3; "bra", 1; "cada",2]
(Aux.map_reduce (fun k->k,1) (+) 0
["abra"; "cada"; "abra"; "bra"; "cada"; "abra"]);
+
+ assert_equal ~msg:"collect"
+ ~printer:(print_alist (print_list string_of_int))
+ ["1",[2;3;2]; "2",[1;5;3]; "3",[7]]
+ (Aux.collect ["1",2;"1",3;"2",1;"2",5;"1",2;"3",7;"2",3])
);
"rev_assoc, rev_assoc_all" >::
@@ -205,6 +213,12 @@
["a";"c";"e";"b";"d"]
(Aux.unique (=) ["a";"c";"e"; "b"; "d"; "e"; "c"; "e"]);
+ assert_bool "not unique"
+ (Aux.not_unique ["a";"c";"b"; "d"; "c"]);
+
+ assert_bool "unique"
+ (not (Aux.not_unique ["a";"c";"b";"d"]));
+
assert_equal ~printer:(String.concat "; ")
~msg:"should remove duplicates"
["a";"b";"c";"d";"e"]
Modified: trunk/Toss/Play/GDL.ml
===================================================================
--- trunk/Toss/Play/GDL.ml 2011-01-23 21:35:16 UTC (rev 1284)
+++ trunk/Toss/Play/GDL.ml 2011-01-29 00:22:13 UTC (rev 1285)
@@ -38,7 +38,7 @@
state. For this we need to locate the "noop" arguments to "legal"
and "does" relations. A noop action in a location is the only
action in the corresponding state of an aggregate playout for the
- player that is additionally constant.
+ player that is also constant.
(2b) We determine the player of a location by requiring that at
most one player has a non-noop action in an aggregate
@@ -111,19 +111,16 @@
over the tuple of subterms selected from the element terms by the
corresponding paths.
- (Relations that do not hold for any tuple of element terms in the
- whole aggregate playout can be removed.)
-
(4b) (Equality relations.) For each mask-path, introduce a binary
relation that holds over elements which have the same subterm at
the mask-path position. (Because of mask-paths definition, same
for all element terms in element's equivalence class.)
- (4c) (Anchor predicates.) Collect all terms under "true" and
- "next" predicates in the game definition. For each mask-path
- pointing to a constant in some of the terms and that constant,
- introduce a new predicate with semantics: "matches the mask and
- has the constant at the path position".
+ (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
+ semantics: "matches the mask and has the constant at the path
+ position".
(5) (Mostly) dynamic relations ("fluents": their tuples change
during the game), relations derived from all below-meta-variable
@@ -131,13 +128,12 @@
initial state. (Some relations introduced in this step might not
be fluents.)
- Collect all terms under "true" and "next" predicates in the game
- definition. For each term, find the element mask it matches, and
- introduce relations for each meta-variable of the element mask,
- associated with the subterm that matches the meta-variable. The
- semantic is that the relation selects the element terms that match
- the mask with the associated subterm subsituted for the
- corresponding meta-variable, with existential
+ (See also (7k).) For each element term, find the element mask it
+ matches, and introduce relations for each meta-variable of the
+ element mask, associated with the subterm that matches the
+ meta-variable. The semantic is that the relation selects the
+ element terms that match the mask with the associated subterm
+ subsituted for the corresponding meta-variable, with existential
interpretation. A relation holds initially over an element, if in
the initial set of element terms at least one from the element's
equivalence class is selected by the relation. An occurrence of
@@ -202,77 +198,122 @@
(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 solely on the player in the location and in
- the "legal" definition (currently, we do not allow simultaneous
- moves). Consequently, we define rules on a per-player basis rather
- than a per-location basis. If the branch of "legal" definition has
- a variable for a player, it is instantiated for each player in the
- game, and the variable substituted in the body of the "legal"
- branch.
+ rules in a location on the player in the location and noop actions
+ of other players in it, compared to the 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
+ substituted in the body of the "legal" branch. A rewrite rule is
+ associated with a single "lead legal" branch of the location's
+ player.
(7b) We collect all the branches of the "next" relation definition
- for which the selected branch of "legal" unifies with all (usually
- one, but we allow zero or more) occurrences of "does" with a
- single unifier per "next" branch. Split the unifiers into
- equivalence classes (w.r.t. substitution), each class will be a
- different rewrite rule (or set of rules). Associate negation of
- equalities specific to the unifiers strictly less general than the
- equivalence class with it, so that the resulting conditions form a
- partition of the space of substitutions for the "legal" branch
- processed.
+ for which the selected branches of "lead legal" and "noop legal"
+ (the "joint legal" actions) unify with all (usually one, but we
+ allow zero or more) occurrences of "does" with a single unifier
+ per "next" branch. (A "noop legal" actually only matches and
+ substitutes the local variables of "next" branches.) Split the
+ unifiers into equivalence classes (w.r.t. substitution), each
+ class will be a different rewrite rule (or set of rules). (Note
+ that equivalent unifiers turn out to be those that when truncated
+ to variables of the "legal" branch are renamings of each other.)
+ (7b1) Since the "noop legals" are constants (by current
+ assumption), we do not need to construct equivalence classes for
+ them. Their branches will join every rule generated for the "joint
+ legal" choice.
+
(7c) Find a single MGU that unifies the "legal" atom argument and
all the "does" atoms arguments into a single instance, and apply
- it to all "next" branches of the rule. We remember all variables
- in the "legal"/"does" instantiation as "fixed variables". We
- replace all occurrences of "does" with the body of the selected
- "legal" branch.
+ it to all "next" branches of the rule (i.e. after applying the
+ original unifier, apply a renaming that makes the unifier equal to
+ all other unifiers in the equiv. class). We replace all
+ occurrences of "does" with the body of the selected "legal"
+ branch.
- (7d) We seggregate "next" atoms into these that contain some fixed
- variables or no variables at all, and other containing only
- unfixed variables. Eliminate unfixed variables from "next"
- atoms with fixed variables by enumerating their domains and
- duplicating whole "next" branches with each instantiation. (They
- will not have unfixed variables.)
+ (7d) Add all branches of equiv classes smaller than a given equiv
+ class to its branch set.
- (This perhaps could be done in a better way by better integrating
- (7d) and (7e)...)
+ Implementation TODO (reason for unsoundness): currently, we
+ 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.
- (7e) Branches with (only) unfixed variables in "next" atoms are
- the "frame" branches. Check that each "frame" branch is an
- identity: the "next" atom is equal to one of the positive "true"
- atoms. If not, expand all variables (as they are unfixed)
- duplicating that branch for each instantiation (the duplicated
- branches become regular branches -- with constant "next"
- atoms).
+ (7e) Associate negation of equalities specific to the unifiers
+ strictly less general than the equivalence class with it, so that
+ the resulting conditions form a partition of the space of
+ substitutions for the "legal" branch processed.
- (7e1) Transform the remaining proper "frame" branches into
- "erasure" branches: negate the body, push negation inside (using
- de Morgan laws etc.), reduce to DNF and split into separate
- "erasure" branch for each disjunct, place the original "next" atom
- but with meta-variable positions replaced by _BLANK_ as the head
- of the "erasure" branch, apply (and remove) unification atoms
- resulting from negating the "distinct" relation.
+ (7f) We remember all variables in the "legal"/"does" instantiation
+ as "fixed variables". We seggregate "next" atoms into these that
+ contain some fixed variables or no variables at all, and other
+ containing only unfixed variables.
- (7f) Introduce a new element variable for each class of "next" and
+ (7f1) Branches with (only) unfixed variables in "next" atoms that
+ are "identities" are the "frame" branches. "Identity" here means
+ the "next" atom is equal to one of the positive "true" atoms.
+
+ (7f2) Transform the "frame" branches into "erasure" branches:
+ distribute them into equivalence classes of head terms
+ (w.r.t. substitution but treating fixed variables as constants),
+ add smaller elements and negation of larger elements (in the same
+ 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
+ positions replaced by _BLANK_ as the head of the "erasure" branch,
+ apply (and remove) unification atoms resulting from negating the
+ "distinct" relation.
+
+ (7f4) Drop the erasure branches that contradict the "legal"
+ condition of their rule.
+
+ (7f5) Redistribute the erasure branches in case they were
+ substituted with the "not distinct" unifier to proper equivalence
+ classes (remove equivalence classes that become empty).
+
+ (7g) Instantiate remaining unfixed variables. Implementation TODO.
+
+ (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
- atoms "corresponding variable".)
+ atoms "corresponding variable".) From now on until (7m1) we keep
+ both the (partially) Toss-translated versions and the (complete)
+ GDL-originals of branches (so to use GDL atoms for "subsumption
+ checking" in (7m)).
- (7g) Add an appropriate equality relation of (4b) for each case
- of variable shared by terms corresponding to different element
- variables (regardless if the element terms are in positive or
- negative literals).
-
- (7h) For all subterms of "next" and "true" atoms, identify the
+ (7i-4a) For all subterms of "next" and "true" atoms, identify the
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 the result will be equivalent to a disjunction of
- negations of generated atoms.)
+ fact's argument by applying corresponding (4a) relations. For a
+ negative literal generate result equivalent to a conjunction of
+ negations of generated atoms (FIXME: why disjunction is wrong?).
- (7i) Identify variables in "next" & "true" terms that are
+ (7i-4c) Include the (4c) relations for "next" and "true" positive
+ atoms. Negative atoms are added with (5) relations since they are
+ under a common negation.
+
+ (7i-4b) Add an appropriate equality relation of (4b) for each case
+ of variable shared by terms corresponding to different element
+ variables (regardless if the element terms are in positive or
+ negative literals). FIXME: any shared subterm, not limited to
+ variables, right?
+
+ Implementation: instead of all subterms we currently only consider
+ subterms that instantiate (ordinary) variables in the mask
+ corresponding to the "next"/"true" atom.
+
+ (7i1) Remove branches that are unsatisfiable by their static
+ relations (4a), (4b) and (4c) alone.
+
+ (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
@@ -280,11 +321,13 @@
position). (Note that since branches do not have unfixed variables
anymore, we do not rename variables during duplication.)
- (7j) Now we build rewrite rules for a refinement of an equivalence
- class of (7b): from the branches with unifiers in the equiv class,
- from branches with unifiers more general than the equiv class, and
- from the disjointness conditions (and the terminal condition, see
- below). Build a pre-lattice of branch bodies w.r.t. subsumption,
+ (7k) Replace the "next" and "true" atoms by the conjunction of
+ (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).
+
+ (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
consequent does not, but does not need to always say "yes"
@@ -296,12 +339,20 @@
necessary so that all applicable changes are applied in the
translated game when making a move).
- (7k) Replace the "next" and "true" atoms by the conjunction of
- (4c) and (5) predicates over their corresponding variable. (For
- negative "true" literals this will be equivalent to a disjunction
- of negations of the predicates.)
+ (7l1) Since all variables are fixed, the lattice is built by
+ summing rule bodies. To avoid contradictions and have a complete
+ partition, we construct the set of all bit vectors indexed by all
+ atoms occurring in the bodies. With every index-bit value we
+ associate the set of branches that do not allow such literal. For
+ every vector we calculate the complement of the sum of branch sets
+ associated with every bit. The unique resulting sets are exactly
+ the Toss rules precursors.
- (7l) Include translated negation of the terminal condition.
+ (7m) Include translated negation of the terminal condition. (Now we
+ build rewrite rules for a refinement of an equivalence class of
+ (7b): from the branches with unifiers in the equiv class, from
+ branches with unifiers more general than the equiv class, and from
+ the disjointness conditions and the terminal condition.)
The rewrite rule is generated by joining the derived conjunctions
from "next" atoms as RHS, and from bodies as the
@@ -317,8 +368,8 @@
"goal" value times the characterisic function of the "goal"
body. We do not translate the body if the value is zero (we drop
the zero goal branches from the definition). Translate the body
- using (7f)-(7k), but treating "goal" branches separately -- when
- (7i) duplicates a branch, new branches add new sum elements.
+ using (7h)-(7m), but treating "goal" branches separately -- when
+ (7k) duplicates a branch, new branches add new sum elements.
*)
@@ -381,6 +432,20 @@
String.concat "_" (List.map (term_to_name ~nested:true) args) ^
(if nested then "_Z_" else "")
+let rec vars ?(meta=false) = function
+ | Const _ -> []
+ | Var x -> [x]
+ | MVar x -> if meta then [x] else []
+ | Func (_, args) -> Aux.concat_map vars args
+
+let rec term_vars = function
+ | Const _ -> Aux.Strings.empty
+ | Var v | MVar v -> Aux.Strings.singleton v
+ | Func (f, args) -> terms_vars args
+and terms_vars args =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map term_vars args)
+
let fact_of_atom = function
| Distinct args -> assert false
| Rel (rel, args) -> rel, args
@@ -410,6 +475,13 @@
type exp_def =
string * exp_def_branch list
+module Terms = Set.Make (
+ struct type t = term let compare = Pervasives.compare end)
+
+(*
+let branch_vars (args, body, neg_body) =
+*)
+
let rules_of_entry = function
| Datalog (rel, args, body) ->
let head = rel, args in
@@ -495,12 +567,6 @@
| stratum, rules -> stratify (stratum::strata) rules
-let rec vars ?(meta=false) = function
- | Const _ -> []
- | Var x -> [x]
- | MVar x -> if meta then [x] else []
- | Func (_, args) -> Aux.concat_map vars args
-
let rec subst_one (x, term as sb) = function
| Var y when x=y -> term
| MVar y when x=y -> term
@@ -524,7 +590,7 @@
(List.map (subst_one sb1) terms1)
(List.map (subst_one sb1) terms2)
| (Var x::_, term::_ | term::_, Var x::_)
- when List.mem x (vars term) ->
+ when Aux.Strings.mem x (term_vars term) ->
raise Not_found
| Var x::terms1, term::terms2 | term::terms1, Var x::terms2 ->
let sb1 = x, term in
@@ -539,8 +605,9 @@
let rec match_meta sb m_sb terms1 terms2 =
match terms1, terms2 with
| [], [] -> sb, m_sb
- | (Const a | Var a)::terms1, (Const b | Var b)::terms2 when a=b ->
- match_meta sb m_sb terms1 terms2
+ | (Const _ (* | Var _ *) as a)::terms1,
+ (Const _ (* | Var _ *) as b)::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 ->
@@ -609,8 +676,19 @@
let subst_rel sb (rel, args) = rel, List.map (subst sb) args
let subst_rels sb body = List.map (subst_rel sb) body
-let compose_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb
+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
+ let vars2, terms2 = List.split sb2 in
+ let var_terms = List.map (fun v->Var v) (vars1 @ vars2) in
+ unify [] var_terms (terms1 @ terms2)
+
+let subst_br sb (head, body, neg_body) =
+ List.map (subst sb) head,
+ List.map (subst_rel sb) body,
+ List.map (List.map (subst_rel sb)) neg_body
+
let fact_str (rel, args) =
"("^rel^" "^String.concat " " (List.map term_str args) ^")"
@@ -621,11 +699,11 @@
let facts_str facts =
String.concat " " (List.map fact_str facts)
+let neg_facts_str negs =
+ String.concat " "
+ (List.map (fun d -> "(not (and "^facts_str d^"))") negs)
let def_str (rel, branches) =
- let neg_facts_str negs =
- String.concat " "
- (List.map (fun d -> "(not (and "^facts_str d^"))") negs) in
String.concat "\n" (List.map (fun (args, body, neg_body) ->
"("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
" " ^ neg_facts_str neg_body ^ ")"
@@ -651,14 +729,16 @@
| head, cond1::body, neg_body ->
Aux.map_try (fun fact ->
(* {{{ log entry *)
- if !debug_level > 4 then (
+
+ if !debug_level > 5 then (
Printf.printf "instantiate_one: trying to unify %s and %s\n%!"
(fact_str fact) (fact_str cond1)
);
+
(* }}} *)
let sb = unify_rels fact cond1 in
(* {{{ log entry *)
- if !debug_level > 4 then (
+ if !debug_level > 5 then (
Printf.printf "instantiate_one: succeeded with %s\n%!"
(sb_str sb)
);
@@ -671,20 +751,22 @@
let rec inst_stratum old_base old_irules cur_base cur_irules =
(* {{{ log entry *)
- if !debug_level > 3 then (
+
+ if !debug_level > 4 then (
Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!"
(facts_str old_base) (facts_str cur_base);
Printf.printf
"inst_stratum: #old_irules = %d, #cur_irules = %d\n%!"
(List.length old_irules) (List.length cur_irules)
);
+
(* }}} *)
let base = Aux.unique_sorted (cur_base @ old_base)
and irules = Aux.unique_sorted (cur_irules @ old_irules) in
let new_base1, new_irules1 =
Aux.partition_choice (instantiate_one base cur_base cur_irules) in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "inst_stratum: cur-cur = %s\n%!"
(facts_str new_base1)
);
@@ -692,7 +774,7 @@
let new_base2, new_irules2 =
Aux.partition_choice (instantiate_one base cur_base old_irules) in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "inst_stratum: cur-old = %s\n%!"
(facts_str new_base2)
);
@@ -700,7 +782,7 @@
let new_base3, new_irules3 =
Aux.partition_choice (instantiate_one base old_base cur_irules) in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "inst_stratum: old-cur = %s\n%!"
(facts_str new_base3)
);
@@ -740,32 +822,48 @@
(* 6 *)
+(* Need a global access so that the count can be reset between
+ different translations. (Generalization uses a local [fresh_count]
+ state.) *)
+let freshen_count = ref 0
+
(* TODO: do proper elegant renaming... *)
+let freshen_branch (args, body, neg_body) =
+ incr freshen_count;
+ let rec map_vnames = function
+ | Var x -> Var (x^string_of_int !freshen_count)
+ | MVar x -> MVar (x^string_of_int !freshen_count)
+ | 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
+ List.map map_vnames args,
+ List.map map_rel body,
+ List.map (List.map map_rel) neg_body
+
let freshen_def_branches =
- let fresh_count = ref 0 in
- let map_branch (args, body, neg_body) =
- incr fresh_count;
- let rec map_vnames = function
- | Var x -> Var (x^string_of_int !fresh_count)
- | MVar x -> MVar (x^string_of_int !fresh_count)
- | 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
- List.map map_vnames args,
- List.map map_rel body,
- List.map (List.map map_rel) neg_body in
- List.map map_branch
+ List.map freshen_branch
(* assumption: [defs] bodies are already clean of defined relations *)
let subst_def_branch (defs : exp_def list)
- (head, body, neg_body : exp_def_branch) : exp_def_branch list =
+ (head, body, neg_body as br : exp_def_branch) : exp_def_branch list =
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding branch %s\n%!" (def_str ("BRANCH", [br]));
+ );
+ (* }}} *)
(* 6a *)
let sols =
List.fold_left (fun sols (rel, args as atom) ->
(let try def =
freshen_def_branches (List.assoc rel defs) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding positive %s by %s\n%!" rel
+ (def_str (rel, def))
+ );
+ (* }}} *)
Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
let args = List.map (subst sb) args in
Aux.map_some (fun (dparams, dbody, dneg_body) ->
@@ -774,7 +872,7 @@
Some (
subst_rels sb1 (dbody @ pos_sol),
List.map (subst_rels sb1) (dneg_body @ neg_sol),
- compose_sb sb1 sb)
+ extend_sb sb1 sb)
with Not_found -> None
) def
) sols
@@ -823,70 +921,40 @@
loop (base @ step) strata in
match stratify ~def:true [] (defs_of_rules rules) with
| [] -> []
- | [no_defined_rels] ->
- if more_defs = [] then no_defined_rels
- else List.map (fun (rel, branches) ->
- rel, Aux.concat_map (subst_def_branch more_defs) branches)
- no_defined_rels
- | def_base::def_strata -> loop def_base def_strata
+ | [no_defined_rels] when more_defs=[] -> no_defined_rels
+ | def_base::def_strata when more_defs=[] -> loop def_base def_strata
+ | def_strata -> loop more_defs def_strata
(* As [subst_def_branch], but specifically for "legal" definition and
result structured by "legal" definition branches. *)
- (*
-let subst_legal_rule (legal_defs : exp_def_branch list)
- (head, body, neg_body : exp_def_branch) : exp_def_branch list =
- (* 6a *)
- let sols =
- List.fold_left (fun sols (rel, args as atom) ->
- (let try def =
- freshen_def_branches (List.assoc rel defs) in
- Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
- let args = List.map (subst sb) args in
- Aux.map_some (fun (dparams, dbody, dneg_body) ->
- try
- let sb1 = unify [] dparams args in
- Some (
- subst_rels sb1 (dbody @ pos_sol),
- List.map (subst_rels sb1) (dneg_body @ neg_sol),
- compose_sb sb1 sb)
- with Not_found -> None
- ) def
- ) sols
- with Not_found ->
- List.map (fun (pos_sol, neg_sol, sb) ->
- subst_rel sb atom::pos_sol, neg_sol, sb) sols))
- ([[],[],[]]) body in
- (* 6b *)
- let sols =
- List.fold_left (fun sols -> function [rel, args as atom] ->
- (let try def =
- freshen_def_branches (List.assoc rel defs) in
- List.map (fun (pos_sol, neg_sol, sb) ->
- let args = List.map (subst sb) args in
- let more_neg =
- Aux.map_some (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);
- try
- let sb1 = unify [] dparams args in
- Some (subst_rels sb1 dbody)
- with Not_found -> None
- ) def in
- pos_sol, more_neg @ neg_sol, sb
- ) sols
- with Not_found ->
- List.map (fun (pos_sol, neg_sol, sb) ->
- pos_sol, [subst_rel sb atom]::neg_sol, sb) sols)
- | _ -> failwith
- "GDL.subst_def_branch: unimplemented, see (6b1) of spec")
- sols neg_body in
- Aux.map_some (fun (pos_sol, neg_sol, sb) ->
- if List.mem [] neg_sol then None
- else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols
- *)
+(* 7b *)
+let subst_legal_rule
+ (legal_args, legal_body, legal_neg_body : exp_def_branch)
+ (head, body, neg_body : exp_def_branch)
+ : (exp_def_branch * exp_def_branch) option =
+ if List.exists (List.exists (fun (rel,_)->rel="does")) neg_body
+ then failwith
+ "GDL.translate_game: negated \"does\" conditions not implemented yet";
+ try
+ let body, more_neg_body, sb =
+ List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) ->
+ if rel = "does" then
+ List.rev_append legal_body body,
+ List.rev_append legal_neg_body more_neg_body,
+ unify sb legal_args args
+ else atom::body, more_neg_body, sb) ([],[],[]) body in
+
+ Some (
+ (List.map (subst sb) legal_args,
+ List.map (subst_rel sb) legal_body,
+ List.map (List.map (subst_rel sb)) legal_neg_body),
+ (List.map (subst sb) head,
+ List.map (subst_rel sb) (List.rev body),
+ List.map (List.map (subst_rel sb))
+ (List.rev_append more_neg_body neg_body)))
+ with Not_found -> None
+
(* 1 *)
(* Collect the aggregate playout, but also the actions available in
@@ -946,17 +1014,21 @@
else dynamic_rules in
let rec loop actions_accu state_accu step state =
(* {{{ log entry *)
+
if !debug_level > 0 then (
Printf.printf "aggregate_playout: step %d...\n%!" step
);
+
(* }}} *)
(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 step < horizon then
loop (actions::actions_accu) (state::state_accu) (step+1) next
@@ -976,7 +1048,8 @@
(String.concat " " (List.map term_str init_state))
);
(* }}} *)
- static_rules, dynamic_rules, static_base, loop [] [] 0 init_state
+ static_rules, dynamic_rules, static_base, init_state,
+ loop [] [] 0 init_state
let find_cycle cands =
@@ -1000,13 +1073,49 @@
loop cycle trav [] cycle tail in
loop [] [] [] [] cands
+let cmp_masks t1 t2 =
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "cmp_masks: %s <= %s .. " (term_str t1) (term_str t2);
+ );
+ (* }}} *)
+ try ignore (match_meta [] [] [t2] [t1]);
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "true\n%!";
+ );
+ (* }}} *)
+ true
+ with Not_found ->
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "false\n%!";
+ );
+ (* }}} *)
+ false
+let rec blank_out = function
+ | Const a as c, Const b when a = b -> c
+ | (*Var _ as*) v, Var _ -> v
+ | t, MVar _ -> Const "_BLANK_"
+ | Func (f, f_args), Func (g, g_args) when f = g ->
+ Func (f, List.map blank_out (List.combine f_args g_args))
+ | a, b ->
+ Printf.printf "blank_out mismatch: term %s, mask %s\n%!"
+ (term_str a) (term_str b);
+ assert false
+
let translate_game 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
let rules = Aux.concat_map rules_of_entry game_descr in
- let static_rules, dynamic_rules, static_base, (agg_actions, agg_states) =
+ 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
@@ -1022,7 +1131,8 @@
(* 2a *)
List.map (function
| player, [Const _ as noop] -> player, Some noop
- | player, _ -> player, None) actions) agg_actions in
+ | player, _ -> player, None) actions
+ ) agg_actions in
let control_cands = List.map (fun noop_cands ->
List.fold_left (fun accu -> function
| player, None ->
@@ -1032,15 +1142,59 @@
("GDL.initialize_game: branching arena graphs"^
" or simultaneous moves not supported yet"))
| _, Some _ -> accu) None noop_cands) noop_cands in
+ let noop_cands = List.map Aux.collect noop_cands in
+ (* throw in players with (multiple) constant actions *)
+ let control_noop_cands = List.map2 (fun ccand noops ->
+ let nccands, noops = Aux.partition_map
+ (function player, [] -> assert false
+ | player, [noop] -> Aux.Right (player, noop)
+ | player, more_actions -> Aux.Left player) noops in
+ match ccand, nccands with
+ | None, [player] -> Some player, noops
+ | Some _, [] -> ccand, noops
+ | _ -> failwith
+ "GDL.initialize_game: simultaneous moves not supported yet"
+ ) control_cands noop_cands in
+ let control_cands, noop_cands =
+ List.split control_noop_cands in
(* 2b *)
- let cycle = find_cycle control_cands in
+ let loc_players = find_cycle control_cands in
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "translate_game: location players %s\n%!"
(String.concat " "
- (List.map (function Some t->term_str t | None->"None") cycle))
+ (List.map (function Some t->term_str t | None->"None")
+ loc_players))
);
(* }}} *)
+ let loc_players = Array.of_list
+ (List.map (function Some p -> p | None -> player_terms.(0))
+ loc_players) in
+ let loc_n = Array.length loc_players in
+ let find_player_locs player =
+ Aux.array_argfind_all (fun p->p=player) loc_players in
+ (* noop actions of a player in a location *)
+ let loc_noops =
+ let i = ref 0 in
+ let noops = ref noop_cands in
+ let loc_noops = Array.make_matrix loc_n players_n None in
+ while !noops <> [] do
+ List.iter (function _, None -> ()
+ | player, (Some _ as noop) ->
+ let p_i = find_player player in
+ if loc_noops.(!i).(p_i) = None
+ then loc_noops.(!i).(p_i) <- noop
+ else if loc_noops.(!i).(p_i) <> noop
+ (* moves are not simultaneous, but different [noop] actions
+ are used by the same player -- can be resolved by
+ introducing separate locations for each noop case *)
+ then failwith
+ "GDL.translate_game: noop-driven location splits unimplemented")
+ (List.hd !noops);
+ incr i; if !i = loc_n then i := 0;
+ noops := List.tl !noops
+ done;
+ loc_noops in
(* 6 *)
let static_rules, exp_static_rules =
List.partition (fun ((rel,args), _, _) ->
@@ -1049,10 +1203,12 @@
| _ -> 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 =
@@ -1076,10 +1232,12 @@
let exp_next =
Aux.concat_map (subst_def_branch ["does", 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))
);
+
(* }}} *)
(* 3c *)
let masks = List.map (function
@@ -1110,11 +1268,8 @@
(String.concat " " (List.map term_str masks))
);
(* }}} *)
- let cmp_masks t1 t2 =
- Printf.printf "cmp_masks: %s <= %s .. " (term_str t1) (term_str t2);
- try ignore (match_meta [] [] [t1] [t2]); Printf.printf "true\n%!"; true
- with Not_found -> Printf.printf "false\n%!"; false in
- let masks = Aux.maximal cmp_masks masks in
+ (* find minimal *)
+ let masks = Aux.maximal (fun t1 t2->cmp_masks t2 t1) masks in
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "translate_game: Masks:\n%s\n%!"
@@ -1167,72 +1322,75 @@
let mask_paths = Aux.concat_map (function _, [] -> assert false
| mask, (sb,_)::_ -> List.map (fun (v,_)->mask, v) sb) elements in
(* 4a *)
- (* TODO: move generation of static rels graphs to the end and
- filter to only generate used relations *)
let static_rels =
Aux.unique_sorted
(List.map (fun ((rname,args),_,_) ->
rname, List.map (fun _ -> ()) args) static_rules) in
let static_rels =
List.map (fun (rel,args) ->
- rel,
+ rel, List.length args,
Aux.all_tuples_for args mask_paths) static_rels in
- let static_base =
- Aux.map_reduce (fun x->x) (fun x y->y::x) [] static_base in
+ let static_base = Aux.collect static_base in
(* TODO: optimize by indexing elements by path position
terms (currently, substitution values) *)
- let struc = List.fold_left (fun struc (brel, 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 "__"
- (List.map (fun (mask,v)->
- term_to_name mask ^ "_" ^ v) ptup) in
- let struc =
- Structure.add_rel_name rname (List.length ptup) struc in
+ let struc =
+ List.fold_left (fun struc (brel, arity, path_tups) ->
+ let brel_tups = List.assoc brel static_base in
(* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "static-rel: %s, of... %!" rname;
+ 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);
);
(* }}} *)
- let elem_sets =
- List.map (fun (mask,v)->
- List.map (fun (sb,elem)->
- try List.assoc v sb, elem
- with Not_found -> assert false)
- (List.assoc mask elements)) ptup in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "%s ... %!" (String.concat "x" (
- List.map (fun x-> string_of_int (List.length x)) elem_sets));
- );
- (* }}} *)
- let elem_tups =
- Aux.concat_map (fun ttup ->
- let elem_sets = List.map2 (fun term elems ->
- Aux.map_some (fun (tcand, e) ->
- if tcand=term then Some e else None) elems
- ) ttup elem_sets in
- List.map Array.of_list (Aux.product elem_sets)
- ) brel_tups in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups);
- );
- (* }}} *)
- let res = Structure.unsafe_add_rels struc rname elem_tups in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf " done\n%!";
- );
- (* }}} *)
- res
- ) struc path_tups) struc static_rels in
+ List.fold_left (fun struc ptup ->
+ let rname = brel ^ "__" ^ String.concat "__"
+ (List.map (fun (mask,v)->
+ term_to_name mask ^ "_" ^ v) ptup) in
+ let struc =
+ Structure.add_rel_name rname (List.length ptup) struc in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "static-rel: %s, of... %!" rname;
+ );
+ (* }}} *)
+ let elem_sets =
+ List.map (fun (mask,v)->
+ List.map (fun (sb,elem)->
+ try List.assoc v sb, elem
+ with Not_found -> assert false)
+ (List.assoc mask elements)) ptup in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%s ... %!" (String.concat "x" (
+ List.map (fun x-> string_of_int (List.length x)) elem_sets));
+ );
+ (* }}} *)
+ let elem_tups =
+ Aux.concat_map (fun ttup ->
+ let elem_sets = List.map2 (fun term elems ->
+ Aux.map_some (fun (tcand, e) ->
+ if tcand=term then Some e else None) elems
+ ) ttup elem_sets in
+ List.map Array.of_list (Aux.product elem_sets)
+ ) brel_tups in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%d tuples, adding to struc...%!"
+ (List.length elem_tups);
+ );
+ (* }}} *)
+ let res = Structure.unsafe_add_rels struc rname elem_tups in
+ (* {{{ log entry *)
+
+ if !debug_level > 1 then (
+ Printf.printf " done\n%!";
+ );
+
+ (* }}} *)
+ res
+ ) struc path_tups
+ ) struc static_rels in
+
(* 4b *)
let struc = List.fold_left (fun struc (mask,v) ->
let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
@@ -1255,53 +1413,553 @@
with Not_found -> assert false
) tups elems
) [] elems in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups);
- );
- (* }}} *)
- let res = Structure.unsafe_add_rels struc rname elem_tups in
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf " done\n%!";
- );
- (* }}} *)
- res
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups);
+ );
+ (* }}} *)
+ let res = Structure.unsafe_add_rels struc rname elem_tups in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf " done\n%!";
+ );
+ (* }}} *)
+ res
) struc mask_paths in
- (* 4c: TODO -- see laziness TODO 4 *)
- (* 5: TODO *)
+ (* 4c *)
+ let struc = List.fold_left (fun struc mask ->
+ let rname = term_to_name mask in
+ let struc =
+ 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 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
+ Structure.add_rel struc rname [|elem|]) struc sb) struc elems
+ ) struc elements in
+ (* 5 *)
+ let term_to_blank next_arg =
+ let mask_cands =
+ Aux.map_try (fun mask ->
+ mask, match_meta [] [] [next_arg] [mask]
+ ) masks in
+ let mask, sb, m_sb = match mask_cands with
+ | [mask, (sb, m_sb)] -> mask, sb, m_sb
+ | _ -> assert false in
+ mask, sb, m_sb, blank_out (next_arg, mask) in
+ let struc = List.fold_left (fun struc term ->
+ let mask, sb, m_sb, blanked = term_to_blank term in
+ let e =
+ let elems = List.assoc mask elements in
+ List.assoc sb elems in
+ List.fold_left (fun struc (v,t as v_sb) ->
+ let rname = term_to_name (subst_one v_sb mask) in
+ if List.mem term init_state then
+ Structure.add_rel struc rname [|e|]
+ else Structure.add_rel_name rname 1 struc) struc m_sb
+ ) struc element_terms in
+
(* 7a *)
let legal_rules =
Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule]
| [Var v; lterm], body, neg_body ->
Array.to_list
- (Array.map (fun player -> [player; lterm], body, neg_body)
+ (Array.map (fun player ->
+ let sb = [v, player] in
+ [player; subst sb lterm],
+ List.map (subst_rel sb) body,
+ List.map (List.map (subst_rel sb)) neg_body)
player_terms)
| [Func _; lterm], _, _ ->
(* TODO: easy to fix *)
failwith "GDL.translate_game: bigger player terms not handled yet"
| _ -> assert false) legal_rules in
- (* indexed by players, then "legal" branches, then by MGUs for
- unifier equivalence classes *)
- (*
- let player_next =
- Aux.map_reduce (fun ()) in
- *)
+ (* expanded "next" branches indexed by locations, then "legal"
+ branches, then by MGUs for unifier equivalence classes *)
+ let loc_lead_legal, loc_noop_legal =
+ (* actions of the player *of the location* *)
+ let loc_lead_legal = Array.make loc_n [] in
+ (* noop actions in locations -- cannot have choice *)
+ let loc_noop_legal =
+ Array.make_matrix loc_n players_n None in
+ List.iter (function
+ | [player; action], _, _ as legal ->
+ for i=0 to loc_n - 1 do
+ if List.mem i (find_player_locs player)
+ then
+ if not (List.mem legal loc_lead_legal.(i))
+ then loc_lead_legal.(i) <- legal :: loc_lead_legal.(i);
+ for p=0 to players_n - 1 do
+ match loc_noops.(i).(p) with None -> ()
+ | Some noop ->
+ if p = find_player player && (
+ try ignore (match_meta [] [] [noop] [action]); true
+ with Not_found -> false)
+ then
+ if loc_noop_legal.(i).(p) <> None
+ && loc_noop_legal.(i).(p) <> Some legal
+ then (
+ Printf.printf "Multiple noops: %s, %s\n%!"
+ (term_str (Func ("legal", Aux.fst3 legal)))
+ (term_str (Func ("legal", Aux.fst3
+ (Aux.unsome loc_noop_legal.(i).(p)))));
+ assert false)
+ else loc_noop_legal.(i).(p) <- Some legal
+ done
+ done
+ | _ -> assert false
+ ) legal_rules;
+ loc_lead_legal, loc_noop_legal in
+ (* the joint actions available in a location *)
+ let loc_joint_legal =
+ Array.mapi (fun i lead ->
+ let cur_player = find_player loc_players.(i) in
+ let p_acts = Array.to_list
+ (Array.mapi
+ (fun p noop ->
+ if p = cur_player then lead
+ else match noop with
+ | Some noop -> [noop] | None -> assert false)
+ loc_noop_legal.(i)) in
+ Aux.product p_acts
+ ) loc_lead_legal in
+ (* 7b *)
+ let grtr ((lead1,_,_), _) ((lead2,_,_), _) = cmp_masks lead2 lead1 in
+ let loc_next_classes =
+ Array.mapi (fun loc joint_legal_branches ->
+ Aux.concat_map (fun joint_legal ->
+ let lead_legal, noop_legals =
+ List.partition (function
+ | [player; action],_,_ -> player=loc_players.(loc)
+ | _ -> assert false) joint_legal in
+ let lead_legal =
+ match lead_legal with [lead_legal] -> lead_legal
+ | _ -> assert false in
+ (* 7b1 *)
+ let noop_branches = Aux.concat_map (fun legal ->
+ Aux.map_some
+ (fun next_br ->
+ subst_legal_rule legal (freshen_branch next_br))
+ next_rules) noop_legals in
+ let noop_branches =
+ List.map snd noop_branches in
+ (* now, continue with the lead player *)
+ let unifs = Aux.map_some (* and substituted legal br-es *)
+ (fun next_br ->
+ match
+ subst_legal_rule lead_legal (freshen_branch next_br)
+ with None -> None
+ | Some (([_; lead],lead_body,lead_neg_body), br) ->
+ Some ((lead,lead_body,lead_neg_body), br)
+ | _ -> assert false)
+ next_rules in
+ (* building "Hasse layers" imperatively *)
+ let unifs = ref unifs in
+ let hasse_layer () =
+ let minimal = Aux.maximal grtr !unifs in
+ (* 7c *)
+ List.map (fun (min_head, _, _ as min_lead, _) ->
+ let branches =
+ Aux.map_try (fun ((head, _, _), br as lbr) ->
+ let renaming, _ =
+ match_meta [] [] [min_head] [head] in
+ unifs := Aux.list_remove lbr !unifs;
+ subst_br renaming br) !unifs in
+ min_lead, branches
+ ) minimal in
+ let layers = ref [] in
+ while !unifs <> [] do
+ layers := hasse_layer () :: !layers
+ done;
+ let layers = List.rev !layers in
+ (* 7d *)
+ let rules_brs = List.fold_left
+ (* folding reverses order so the maximal layer will
+ generate the returned classes *)
+ (fun rules_brs layer ->
+ List.map
+ (fun (new_lead, new_brs as nrule) ->
+ let smaller = List.filter (grtr nrule) rules_brs in
+ new_lead,
+ List.concat (new_brs::List.map snd smaller)
+ ) layer
+ ) [] layers in
+ (* 7b1 continued *)
+ let rules_brs = List.map (fun (lead, brs) ->
+ lead, noop_branches @ brs) rules_brs in
+ (* 7e -- TODO (together with non-maximal (7d) classes) *)
+ (* 7f *)
+ let rules_brs =
+ List.map (fun (lead_head, lead_body, lead_neg_body as lead,
+ branches) ->
+ let fixed_vars = term_vars lead_head in
+ let fixed_brs, other_brs = List.partition
+ (function
+ | [next_arg],_,_ ->
+ Aux.Strings.subset (term_vars next_arg) fixed_vars
+ | _ -> assert false) branches in
+ let frame_brs, to_expand = List.partition
+ (function
+ | [next_arg],_,_ ->
+ Aux.Strings.is_empty
+ (Aux.Strings.inter (term_vars next_arg) fixed_vars)
+ | _ -> assert false) other_brs in
+ (* 7f1 *)
+ let frame_brs, more_to_expand = List.partition
+ (fun (args, body, neg_body) ->
+ List.exists
+ (fun (rel, r_args) -> rel="true" && r_args=args) body
+ ) 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));
+ (* 7f2 *)
+ let leq3 (head1, _, _) (head2, _, _) =
+ try
+ let sb, _ = match_meta [] [] head2 head1 in
+ List.for_all (fun (v,_)->
+ 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
+ (* 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 ->
+ let multi_body = List.map
+ (fun (head2, body2, neg_body2) ->
+ let sb, _ = match_meta [] [] head head2 in
+ List.map (subst_rel sb) body2,
+ List.map (List.map (subst_rel sb)) neg_body2
+ ) f_brs in
+ head, (body, neg_body)::multi_body
+ ) frames in
+ (* 7f3 *)
+ let erasure_brs = Aux.concat_map
+ (function
+ | [next_arg] as next_args,multi_body ->
+ let mask, _, _, blank_arg = term_to_blank next_arg in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ 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 (
+ fun (body, neg_body) ->
+ "("^ facts_str body ^
+ " " ^ neg_facts_str neg_body ^ ")"
+ ) multi_body))
+ );
+ (* }}} *)
+ let multi_body = List.map (fun (body, neg_body) ->
+ let body =
+ Aux.map_some (fun (rel, args) ->
+ if rel <> "role" &&
+ (rel <> "true" || args <> next_args)
+ then Some (Aux.Left (rel, args))
+ else None) body in
+ let neg_body =
+ List.map
+ (function
+ | ["distinct", []] -> assert false
+ | ["distinct", arg::more_args] ->
+ let _, sb =
+ List.fold_left (fun (base, sb) arg ->
+ let sb = unify sb [base] [arg] in
+ subst sb base, sb)
+ (arg, []) more_args in
+ (* inverting unfixed-to-fixed *)
+ let sb = List.map (function
+ | v1, Var v2
+ when Aux.Strings.mem v1 fixed_vars
+ -> v2, Var v1
+ | vsb -> vsb) sb in
+ Aux.Right (Aux.Right sb)
+ | conj when List.mem_assoc "distinct" conj ->
+ assert false
+ | conj ->
+ Aux.Right (Aux.Left conj))
+ neg_body in
+ body @ neg_body) multi_body in
+ let erasures = List.map Aux.partition_choice
+ (Aux.unique_sorted (Aux.product multi_body)) in
+ let erasures =
+ Aux.map_some (fun (neg_body, body) ->
+ try
+ let body, sbs = Aux.partition_choice body in
+ let body = List.concat body in
+ let sb = List.fold_left compose_sb [] sbs in
+ if List.exists (fun (v,_)->
+ Aux.Strings.mem v fixed_vars) sb
+ then None
+ else
+ let body = List.map (subst_rel sb) body in
+ let neg_body =
+ List.map (fun a -> [subst_rel sb a]) neg_body in
+ let head = subst sb blank_arg in
+ if
+ (* TODO: (7g) instead *)
+ Aux.Strings.subset (term_vars head)
+ fixed_vars &&
+ (* (7f4) *)
+ not (List.exists (fun pos ->
+ List.mem [pos] lead_neg_body
+ ) body) &&
+ not (List.exists (fun neg ->
+ List.for_all
+ (fun neg->List.mem neg lead_body) neg
+ ) neg_body)
+ then Some ([head], body, neg_body)
+ else None
+ with Not_found -> None) erasures in
+ let erasures = Aux.unique_sorted
+ (List.map (fun (head, body, neg_body) ->
+ head, Aux.unique_sorted body,
+ Aux.unique_sorted neg_body) erasures) in
+ erasures
+ (* TODO: (7g) *)
+ | _ -> 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, fixed_brs @ erasure_brs
+ ) rules_brs in
+ (* let rules_inds = Array.of_list rules_brs in *)
+ rules_brs
+ ) joint_legal_branches
+ ) loc_joint_legal in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Array.iteri (fun loc rules_brs ->
+ Printf.printf "Rule precursors for loc %d:\n%!" loc;
+ 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))
+ ) rules_brs;
+ ) loc_next_classes;
+ );
+ (* }}} *)
+ (* 7h *)
+ let toss_var term =
+ let mask, _, _, blank = term_to_blank term in
+ mask, Formula.fo_var_of_string (term_to_name blank) in
+ (* 7i *)
+ let state_terms =
+ Array.fold_left (fun acc rules_brs ->
+ List.fold_left (fun acc (lead, brs) ->
+ List.fold_left (fun acc -> function
+ | [next_arg], body, neg_body ->
+ let res =
+ ...
[truncated message content] |
|
From: <luk...@us...> - 2011-01-23 21:35:22
|
Revision: 1284
http://toss.svn.sourceforge.net/toss/?rev=1284&view=rev
Author: lukaszkaiser
Date: 2011-01-23 21:35:16 +0000 (Sun, 23 Jan 2011)
Log Message:
-----------
Add Connect4 and make Pawn Whopping as in GDL.
Added Paths:
-----------
trunk/Toss/examples/Connect4.toss
trunk/Toss/examples/Connect4.tossstyle
trunk/Toss/examples/PawnWhopping.toss
trunk/Toss/examples/PawnWhopping.tossstyle
Removed Paths:
-------------
trunk/Toss/examples/Pawns.toss
trunk/Toss/examples/Pawns.tossstyle
Added: trunk/Toss/examples/Connect4.toss
===================================================================
--- trunk/Toss/examples/Connect4.toss (rev 0)
+++ trunk/Toss/examples/Connect4.toss 2011-01-23 21:35:16 UTC (rev 1284)
@@ -0,0 +1,52 @@
+PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 4, depth: 1
+REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
+REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
+REL Row4 (x, y, z, v) = R(x, y) and R(y, z) and R(z, v)
+REL Col4 (x, y, z, v) = C(x, y) and C(y, z) and C(z, v)
+REL DiagA4 (x, y, z, v) = DiagA(x, y) and DiagA(y, z) and DiagA(z, v)
+REL DiagB4 (x, y, z, v) = DiagB(x, y) and DiagB(y, z) and DiagB(z, v)
+REL Conn4 (x, y, z, v) =
+ Row4(x,y,z,v) or Col4(x,y,z,v) or DiagA4(x,y,z,v) or DiagB4(x,y,z,v)
+REL WinQ() =
+ ex x,y,z,v (Q(x) and Q(y) and Q(z) and Q(v) and Conn4(x, y, z, v))
+REL WinP() =
+ ex x,y,z,v (P(x) and P(y) and P(z) and P(v) and Conn4(x, y, z, v))
+REL EmptyUnder (x) = ex y (C(y, x) and not P(y) and not Q(y))
+RULE Cross:
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P
+ pre not EmptyUnder (a) and not WinQ()
+RULE Circle:
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P
+ pre not EmptyUnder (a) and not WinP()
+LOC 0 {
+ PLAYER 1
+ PAYOFF {
+ 1: :(WinP()) - :(WinQ());
+ 2: :(WinQ()) - :(WinP())
+ }
+ MOVES [Cross -> 1]
+}
+LOC 1 {
+ PLAYER 2
+ PAYOFF {
+ 1: :(WinP()) - :(WinQ());
+ 2: :(WinQ()) - :(WinP())
+ }
+ MOVES [Circle -> 0]
+}
+MODEL [ | P:1 {}; Q:1 {} |
+ ] "
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+"
Added: trunk/Toss/examples/Connect4.tossstyle
===================================================================
--- trunk/Toss/examples/Connect4.tossstyle (rev 0)
+++ trunk/Toss/examples/Connect4.tossstyle 2011-01-23 21:35:16 UTC (rev 1284)
@@ -0,0 +1,6 @@
+nocolor ;
+elOPACITY: 20 ;
+relOPACITY: 150 ;
+arrLENscale: 0.0 ;
+P: ~/greencircle.svg;
+Q: ~/bluecircle.svg;
Copied: trunk/Toss/examples/PawnWhopping.toss (from rev 1283, trunk/Toss/examples/Pawns.toss)
===================================================================
--- trunk/Toss/examples/PawnWhopping.toss (rev 0)
+++ trunk/Toss/examples/PawnWhopping.toss 2011-01-23 21:35:16 UTC (rev 1284)
@@ -0,0 +1,170 @@
+PLAYERS 1, 2
+DATA depth: 2, adv_ratio: 2
+REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
+REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
+REL IsFirst(x) = not ex z C(z, x)
+REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
+REL IsEight(x) = not ex z C(x, z)
+REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
+REL WhiteEnds() = (ex x (W(x) and not ex y C(x, y))) or (not ex z B(z))
+REL BlackEnds() = (ex x (B(x) and not ex y C(y, x))) or (not ex z W(z))
+RULE WhiteDiag:
+ [ a, b | W { a }; B { b } | - ] -> [ a, b | W { b } | - ] emb W, B
+ pre DiagW(a, b) and not BlackEnds()
+RULE WhiteStraight:
+ [ | B:1 {}; R:2 {} | ] "
+
+ .
+
+ W
+" -> [ | B:1 {}; R:2 {} | ] "
+
+ W
+
+ .
+" emb W, B pre not BlackEnds()
+RULE WhiteStraightTwo:
+ [ | B:1 {}; R:2 {} | ] "
+
+ .
+
+ .
+
+ W
+" -> [ | B:1 {}; R:2 {} | ] "
+
+ W
+
+ .
+
+ .
+" emb W, B pre IsSecond(a1) and not BlackEnds()
+RULE WhitePawnRightDbl:
+ [ | | ] "
+ ...
+ ?..-B
+ ...
+ ? ...
+ ...
+ W..B
+" -> [ | | ] "
+ ...
+ ?...
+ ...
+ ? W..
+ ...
+ ....
+" emb W, B pre not BlackEnds()
+RULE WhitePawnLeftDbl:
+ [ | | ] "
+ ...
+ -B.?
+ ...
+ . ?..
+ ...
+ B..W
+" -> [ | | ] "
+ ...
+ ...?
+ ...
+ W ?..
+ ...
+ ....
+" emb W, B pre not BlackEnds()
+RULE BlackDiag:
+ [ a, b | B { a }; W { b } | - ] -> [ a, b | B { b } | - ] emb W, B
+ pre DiagB(a, b) and not WhiteEnds()
+RULE BlackStraight:
+ [ | R:2 {}; W:1 {} | ] "
+
+ B
+
+ .
+" -> [ | R:2 {}; W:1 {} | ] "
+
+ .
+
+ B
+" emb W, B pre not WhiteEnds()
+RULE BlackStraightTwo:
+ [ | R:2 {}; W:1 {} | ] "
+
+ B
+
+ .
+
+ .
+" -> [ | R:2 {}; W:1 {} | ] "
+
+ .
+
+ .
+
+ B
+" emb W, B pre IsSeventh(a3) and not WhiteEnds()
+RULE BlackPawnRightDbl:
+ [ | | ] "
+ ...
+ B..W
+ ...
+ ? ...
+ ...
+ ?..-W
+" -> [ | | ] "
+ ...
+ ....
+ ...
+ ? B..
+ ...
+ ?...
+" emb W, B pre not WhiteEnds()
+RULE BlackPawnLeftDbl:
+ [ | | ] "
+ ...
+ W..B
+ ...
+ . ?..
+ ...
+ -W.?
+" -> [ | | ] "
+ ...
+ ....
+ ...
+ B ?..
+ ...
+ ...?
+" emb W, B pre not WhiteEnds()
+LOC 0 {
+ PLAYER 1
+ PAYOFF {
+ 1: :(WhiteEnds()) - :(BlackEnds());
+ 2: :(BlackEnds()) - :(WhiteEnds())
+ }
+ MOVES [WhiteDiag -> 1]; [WhiteStraight -> 1]; [WhiteStraightTwo -> 1]
+}
+LOC 1 {
+ PLAYER 2
+ PAYOFF {
+ 1: :(WhiteEnds()) - :(BlackEnds());
+ 2: :(BlackEnds()) - :(WhiteEnds())
+ }
+ MOVES [BlackDiag -> 0]; [BlackStraight -> 0]; [BlackStraightTwo -> 0]
+}
+MODEL [ | | ] "
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ ... ... ... ...
+"
Copied: trunk/Toss/examples/PawnWhopping.tossstyle (from rev 1283, trunk/Toss/examples/Pawns.tossstyle)
===================================================================
--- trunk/Toss/examples/PawnWhopping.tossstyle (rev 0)
+++ trunk/Toss/examples/PawnWhopping.tossstyle 2011-01-23 21:35:16 UTC (rev 1284)
@@ -0,0 +1,6 @@
+nocolor ;
+elOPACITY: 20 ;
+relOPACITY: 150 ;
+arrLENscale: 0.0 ;
+W: ~/pawn_white.svg;
+B: ~/pawn_black.svg;
Deleted: trunk/Toss/examples/Pawns.toss
===================================================================
--- trunk/Toss/examples/Pawns.toss 2011-01-21 20:46:12 UTC (rev 1283)
+++ trunk/Toss/examples/Pawns.toss 2011-01-23 21:35:16 UTC (rev 1284)
@@ -1,179 +0,0 @@
-PLAYERS 1, 2
-DATA depth: 2, adv_ratio: 2
-REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
-REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
-REL IsFirst(x) = not ex z C(z, x)
-REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
-REL IsEight(x) = not ex z C(x, z)
-REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
-RULE WhiteDiag:
- [ a, b | W { a }; B { b } | - ]
- ->
- [ a, b | W { b } | - ]
- emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
-RULE WhiteStraight:
- [ | B:1 {}; R:2 {} | ] "
-
- .
-
- W
-" -> [ | B:1 {}; R:2 {} |
- ] "
-
- W
-
- .
-" emb W, B pre not ex x (B(x) and not ex y C(y, x))
-RULE WhiteStraightTwo:
- [ | B:1 {}; R:2 {} | ] "
-
- .
-
- .
-
- W
-" -> [ | B:1 {}; R:2 {} |
- ] "
-
- W
-
- .
-
- .
-" emb W, B pre IsSecond(a1) and not ex x (B(x) and not ex y C(y, x))
-RULE WhitePawnRightDbl:
- [ | | ] "
- ...
- ?..-B
- ...
- ? ...
- ...
- W..B
-" -> [ | | ] "
- ...
- ?...
- ...
- ? W..
- ...
- ....
-" emb W, B
-RULE WhitePawnLeftDbl:
- [ | | ] "
- ...
- -B.?
- ...
- . ?..
- ...
- B..W
-" -> [ | | ] "
- ...
- ...?
- ...
- W ?..
- ...
- ....
-" emb W, B
-RULE BlackDiag:
- [ a, b | B { a }; W { b } | - ]
- ->
- [ a, b | B { b } | - ]
- emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
-RULE BlackStraight:
- [ | R:2 {}; W:1 {} | ] "
-
- B
-
- .
-" -> [ | R:2 {}; W:1 {} |
- ] "
-
- .
-
- B
-" emb W, B pre not ex x (W(x) and not ex y C(x, y))
-RULE BlackStraightTwo:
- [ | R:2 {}; W:1 {} | ] "
-
- B
-
- .
-
- .
-" -> [ | R:2 {}; W:1 {} |
- ] "
-
- .
-
- .
-
- B
-" emb W, B pre IsSeventh(a3) and not ex x (W(x) and not ex y C(x, y))
-RULE BlackPawnRightDbl:
- [ | | ] "
- ...
- B..W
- ...
- ? ...
- ...
- ?..-W
-" -> [ | | ] "
- ...
- ....
- ...
- ? B..
- ...
- ?...
-" emb W, B
-RULE BlackPawnLeftDbl:
- [ | | ] "
- ...
- W..B
- ...
- . ?..
- ...
- -W.?
-" -> [ | | ] "
- ...
- ....
- ...
- B ?..
- ...
- ...?
-" emb W, B
-LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)));
- 2: :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
- }
- MOVES [WhiteDiag -> 1]; [WhiteStraight -> 1];
- [WhitePawnRightDbl -> 1]; [WhitePawnLeftDbl -> 1]; [WhiteStraightTwo -> 1]
-}
-LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)));
- 2: :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
- }
- MOVES [BlackDiag -> 0]; [BlackStraight -> 0];
- [BlackPawnRightDbl -> 0]; [BlackPawnLeftDbl -> 0]; [BlackStraightTwo -> 0]
-}
-MODEL [ | |
- ] "
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- B..B B..B B..B B..B
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- W W..W W..W W..W W..
- ... ... ... ...
- ... ... ... ...
-"
Deleted: trunk/Toss/examples/Pawns.tossstyle
===================================================================
--- trunk/Toss/examples/Pawns.tossstyle 2011-01-21 20:46:12 UTC (rev 1283)
+++ trunk/Toss/examples/Pawns.tossstyle 2011-01-23 21:35:16 UTC (rev 1284)
@@ -1,6 +0,0 @@
-nocolor ;
-elOPACITY: 20 ;
-relOPACITY: 150 ;
-arrLENscale: 0.0 ;
-W: ~/pawn_white.svg;
-B: ~/pawn_black.svg;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-21 20:46:19
|
Revision: 1283
http://toss.svn.sourceforge.net/toss/?rev=1283&view=rev
Author: lukaszkaiser
Date: 2011-01-21 20:46:12 +0000 (Fri, 21 Jan 2011)
Log Message:
-----------
Extending structure parser to add positions in line when requested, using it to shorten game descriptions.
Modified Paths:
--------------
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureParser.mly
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/examples/Breakthrough.toss
trunk/Toss/examples/Checkers.toss
trunk/Toss/examples/Chess.toss
trunk/Toss/examples/Gomoku.toss
trunk/Toss/examples/Pawns.toss
trunk/Toss/examples/Tic-Tac-Toe.toss
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/Solver/Structure.ml 2011-01-21 20:46:12 UTC (rev 1283)
@@ -312,6 +312,14 @@
| None -> empty_structure ()
| Some s -> s in
add_from_lists struc els rels funs
+
+let create_from_lists_position ?struc els rels =
+ let s = create_from_lists ?struc els rels [] in
+ let elems = Elems.elements s.elements in
+ let zero = List.map (fun e -> (e, 0.)) elems in
+ let next = List.map (fun e -> (e, cBOARD_DX*. (float_of_int (e-1)))) elems in
+ let afuns s (fn, asg) = add_funs s fn asg in
+ List.fold_left afuns s [("x", next); ("y", zero); ("vx", zero); ("vy", zero)]
(* ---------- REMOVING RELATION TUPLES AND ELEMENTS FROM A STRUCTURE -------- *)
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/Solver/Structure.mli 2011-01-21 20:46:12 UTC (rev 1283)
@@ -172,7 +172,10 @@
(string * int option * string array list) list ->
(string * (string * float) list) list -> structure
+val create_from_lists_position : ?struc:structure -> string list ->
+ (string * int option * string array list) list -> structure
+
(** {2 Removing relation tuples and elements from a structure} *)
(** Remove the tuple [tp] from relation [rn] in structure [struc]. May
Modified: trunk/Toss/Solver/StructureParser.mly
===================================================================
--- trunk/Toss/Solver/StructureParser.mly 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/Solver/StructureParser.mly 2011-01-21 20:46:12 UTC (rev 1283)
@@ -69,6 +69,12 @@
{ fun struc ->
create_from_lists ~struc elems rels funs }
| OPENSQ
+ elems = separated_list (COMMA, id_int)
+ MID
+ rels = separated_list (SEMICOLON, rel_expr)
+ MID MINUS CLOSESQ
+ { fun struc -> create_from_lists_position ~struc elems rels }
+ | OPENSQ
separated_list (COMMA, id_int)
MID
separated_list (SEMICOLON, rel_expr)
Modified: trunk/Toss/Solver/StructureTest.ml
===================================================================
--- trunk/Toss/Solver/StructureTest.ml 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/Solver/StructureTest.ml 2011-01-21 20:46:12 UTC (rev 1283)
@@ -54,6 +54,9 @@
~result:"[a | P (a) | f {a->1.3}]"
"[ a | P{a} | f { a-> 1.3 } ]";
test_parse
+ ~result:"[a | P (a) | vx {a->0.}; vy {a->0.}; x {a->0.}; y {a->0.}]"
+ "[ a | P{a} | - ]";
+ test_parse
~result:"[a, b, c | | f {a->1.3, b->2., c->2.}]"
"[ | | f { a-> 1.3, b->2, c->3.3 } ; f { c -> 2 } ]";
test_parse
Modified: trunk/Toss/examples/Breakthrough.toss
===================================================================
--- trunk/Toss/examples/Breakthrough.toss 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/examples/Breakthrough.toss 2011-01-21 20:46:12 UTC (rev 1283)
@@ -3,12 +3,10 @@
REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
RULE WhiteDiag:
- [ a, b | W { a }; _opt_B { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | W { a }; _opt_B { b } | - ]
->
- [ a, b | W { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
+ [ a, b | W { b } | - ]
+ emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
RULE WhiteStraight:
[ | B:1 {}; R:2 {} | ] "
@@ -23,12 +21,10 @@
.
" emb W, B pre not ex x (B(x) and not ex y C(y, x))
RULE BlackDiag:
- [ a, b | B { a }; _opt_W { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | B { a }; _opt_W { b } | - ]
->
- [ a, b | B { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
+ [ a, b | B { b } | - ]
+ emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
RULE BlackStraight:
[ | R:2 {}; W:1 {} | ] "
Modified: trunk/Toss/examples/Checkers.toss
===================================================================
--- trunk/Toss/examples/Checkers.toss 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/examples/Checkers.toss 2011-01-21 20:46:12 UTC (rev 1283)
@@ -22,167 +22,67 @@
REL BJumps() = ex x, y ((B(x) and BeatsB (x, y)) or (Bq(x) and BeatsBX (x, y)))
REL WJumps() = ex x, y ((W(x) and BeatsW (x, y)) or (Wq(x) and BeatsWX (x, y)))
RULE RedMove:
- [ a, b | W { a } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- ->
- [ a, b | W { b } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b))
- and not WJumps()
+ [ a, b | W { a } | - ] -> [ a, b | W { b } | - ] emb w, b
+ pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps()
RULE WhiteMove:
- [ a, b | B { a } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- ->
- [ a, b | B { b } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b))
- and not BJumps()
+ [ a, b | B { a } | - ] -> [ a, b | B { b } | - ] emb w, b
+ pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps()
RULE RedPromote:
- [ a, b | W { a } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- ->
- [ a, b | Wq { b } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b))
- and not WJumps()
+ [ a, b | W { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b
+ pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b)) and not WJumps()
RULE WhitePromote:
- [ a, b | B { a } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- ->
- [ a, b | Bq { b } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b))
- and not BJumps()
+ [ a, b | B { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b
+ pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b)) and not BJumps()
RULE RedQMove:
- [ a, b | Wq { a } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- ->
- [ a, b | Wq { b } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre AnyDiag (a, b) and not WJumps()
+ [ a, b | Wq { a } | - ] -> [ a, b | Wq { b } | - ] emb w, b
+ pre AnyDiag (a, b) and not WJumps()
RULE WhiteQMove:
- [ a, b | Bq { a } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- ->
- [ a, b | Bq { b } |
- vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre AnyDiag (a, b) and not BJumps()
+ [ a, b | Bq { a } | - ] -> [ a, b | Bq { b } | - ] emb w, b
+ pre AnyDiag (a, b) and not BJumps()
RULE RedBeat:
- [ a, b, c | W { a }; b { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | W { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre DiagW2 (a, b, c) and not IsEight(c)
- post not ex x, y (_new_W(x) and BeatsWX (x, y))
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
RULE WhiteBeat:
- [ a, b, c | B { a }; w { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | B { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre DiagB2 (a, b, c) and not IsFirst(c)
- post not ex x, y (_new_B(x) and BeatsBX (x, y))
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
RULE RedBeatBoth:
- [ a, b, c | W { a }; b { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | W { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
- post not ex x, y (_new_W(x) and BeatsWX (x, y))
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
RULE WhiteBeatBoth:
- [ a, b, c | B { a }; w { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | B { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
- post not ex x, y (_new_B(x) and BeatsBX (x, y))
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
RULE RedBeatPromote:
- [ a, b, c | W { a }; b { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | Wq { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre DiagW2 (a, b, c) and IsEight(c)
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and IsEight(c)
RULE WhiteBeatPromote:
- [ a, b, c | B { a }; w { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | Bq { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre DiagB2 (a, b, c) and IsFirst(c)
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and IsFirst(c)
RULE RedBeatCont:
- [ a, b, c | W { a }; b { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | W { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre DiagW2 (a, b, c) and not IsEight(c)
- post ex x, y (_new_W(x) and BeatsWX (x, y))
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre DiagW2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
RULE WhiteBeatCont:
- [ a, b, c | B { a }; w { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | B { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre DiagB2 (a, b, c) and not IsFirst(c)
- post ex x, y (_new_B(x) and BeatsBX (x, y))
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre DiagB2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
RULE RedBeatBothCont:
- [ a, b, c | W { a }; b { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | W { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
- post ex x, y (_new_W(x) and BeatsWX (x, y))
+ [ a, b, c | W { a }; b { b } | - ] -> [ a, b, c | W { c } | - ] emb w, b
+ pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
RULE WhiteBeatBothCont:
- [ a, b, c | B { a }; w { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | B { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
- post ex x, y (_new_B(x) and BeatsBX (x, y))
+ [ a, b, c | B { a }; w { b } | - ] -> [ a, b, c | B { c } | - ] emb w, b
+ pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
RULE RedQBeat:
- [ a, b, c | Wq { a }; b { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | Wq { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c)
+ [ a, b, c | Wq { a }; b { b } | - ] -> [ a, b, c | Wq { c } | - ] emb w, b
+ pre Diag2 (a, b, c)
RULE WhiteQBeat:
- [ a, b, c | Bq { a }; w { b } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- ->
- [ a, b, c | Bq { c } |
- vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
- x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c)
+ [ a, b, c | Bq { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
+ pre Diag2 (a, b, c)
LOC 0 {
PLAYER 1
PAYOFF {
Modified: trunk/Toss/examples/Chess.toss
===================================================================
--- trunk/Toss/examples/Chess.toss 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/examples/Chess.toss 2011-01-21 20:46:12 UTC (rev 1283)
@@ -231,103 +231,75 @@
bQ
" emb w, b pre IsFirst(a1) post not CheckB()
RULE WhiteKnight:
- [ a, b | wN { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wN { a }; _opt_b { b } | - ]
->
- [ a, b | wN { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre Knight(a, b) post not CheckW()
+ [ a, b | wN { b } | - ]
+ emb w, b pre Knight(a, b) post not CheckW()
RULE BlackKnight:
- [ a, b | bN { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bN { a }; _opt_w { b } | - ]
->
- [ a, b | bN { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre Knight(a, b) post not CheckB()
+ [ a, b | bN { b } | - ]
+ emb w, b pre Knight(a, b) post not CheckB()
RULE WhiteBishop:
- [ a, b | wB { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wB { a }; _opt_b { b } | - ]
->
- [ a, b | wB { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre Diag(a, b) post not CheckW()
+ [ a, b | wB { b } | - ]
+ emb w, b pre Diag(a, b) post not CheckW()
RULE BlackBishop:
- [ a, b | bB { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bB { a }; _opt_w { b } | - ]
->
- [ a, b | bB { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre Diag(a, b) post not CheckB()
+ [ a, b | bB { b } | - ]
+ emb w, b pre Diag(a, b) post not CheckB()
RULE WhiteRook:
- [ a, b | wR { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wR { a }; _opt_b { b } | - ]
->
- [ a, b | wR { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre not IsA1(a) and not IsH1(a) and Line(a, b) post not CheckW()
+ [ a, b | wR { b } | - ]
+ emb w, b pre not IsA1(a) and not IsH1(a) and Line(a, b) post not CheckW()
RULE WhiteRookA1:
- [ a, b | wR { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wR { a }; _opt_b { b } | - ]
->
- [ a, b | wR { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre IsA1(a) and Line(a, b) post not CheckW()
+ [ a, b | wR { b } | - ]
+ emb w, b pre IsA1(a) and Line(a, b) post not CheckW()
RULE WhiteRookH1:
- [ a, b | wR { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wR { a }; _opt_b { b } | - ]
->
- [ a, b | wR { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre IsH1(a) and Line(a, b) post not CheckW()
+ [ a, b | wR { b } | - ]
+ emb w, b pre IsH1(a) and Line(a, b) post not CheckW()
RULE BlackRook:
- [ a, b | bR { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bR { a }; _opt_w { b } | - ]
->
- [ a, b | bR { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre not IsA8(a) and not IsH8(a) and Line(a, b) post not CheckB()
+ [ a, b | bR { b } | - ]
+ emb w, b pre not IsA8(a) and not IsH8(a) and Line(a, b) post not CheckB()
RULE BlackRookA8:
- [ a, b | bR { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bR { a }; _opt_w { b } | - ]
->
- [ a, b | bR { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre IsA8(a) and Line(a, b) post not CheckB()
+ [ a, b | bR { b } | - ]
+ emb w, b pre IsA8(a) and Line(a, b) post not CheckB()
RULE BlackRookH8:
- [ a, b | bR { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bR { a }; _opt_w { b } | - ]
->
- [ a, b | bR { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre IsH8(a) and Line(a, b) post not CheckB()
+ [ a, b | bR { b } | - ]
+ emb w, b pre IsH8(a) and Line(a, b) post not CheckB()
RULE WhiteQueen:
- [ a, b | wQ { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wQ { a }; _opt_b { b } | - ]
->
- [ a, b | wQ { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW()
+ [ a, b | wQ { b } | - ]
+ emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW()
RULE BlackQueen:
- [ a, b | bQ { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bQ { a }; _opt_w { b } | - ]
->
- [ a, b | bQ { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB()
+ [ a, b | bQ { b } | - ]
+ emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB()
RULE WhiteKing:
- [ a, b | wK { a }; _opt_b { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | wK { a }; _opt_b { b } | - ]
->
- [ a, b | wK { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre Near(a, b) post not CheckW()
+ [ a, b | wK { b } | - ]
+ emb w, b pre Near(a, b) post not CheckW()
RULE BlackKing:
- [ a, b | bK { a }; _opt_w { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | bK { a }; _opt_w { b } | - ]
->
- [ a, b | bK { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre Near(a, b) post not CheckB()
+ [ a, b | bK { b } | - ]
+ emb w, b pre Near(a, b) post not CheckB()
RULE WhiteLeftCastle:
[ | | ] "
... ... ...
Modified: trunk/Toss/examples/Gomoku.toss
===================================================================
--- trunk/Toss/examples/Gomoku.toss 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/examples/Gomoku.toss 2011-01-21 20:46:12 UTC (rev 1283)
@@ -15,14 +15,14 @@
REL WinP() =
ex x,y,z,v,w (P(x) and P(y) and P(z) and P(v) and P(w) and Conn5(x,y,z,v,w))
RULE Cross:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
+ [a1 | P:1 {}; Q:1 {} | - ]
->
- [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
+ [a1 | P (a1); Q:1 {} | - ]
emb Q, P pre not WinQ()
RULE Circle:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
+ [a1 | P:1 {}; Q:1 {} | - ]
->
- [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
+ [a1 | P:1 {}; Q (a1) | - ]
emb Q, P pre not WinP()
LOC 0 {
PLAYER 1
Modified: trunk/Toss/examples/Pawns.toss
===================================================================
--- trunk/Toss/examples/Pawns.toss 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/examples/Pawns.toss 2011-01-21 20:46:12 UTC (rev 1283)
@@ -7,12 +7,10 @@
REL IsEight(x) = not ex z C(x, z)
REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
RULE WhiteDiag:
- [ a, b | W { a }; B { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | W { a }; B { b } | - ]
->
- [ a, b | W { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
+ [ a, b | W { b } | - ]
+ emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
RULE WhiteStraight:
[ | B:1 {}; R:2 {} | ] "
@@ -76,12 +74,10 @@
....
" emb W, B
RULE BlackDiag:
- [ a, b | B { a }; W { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ [ a, b | B { a }; W { b } | - ]
->
- [ a, b | B { b } |
- vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
+ [ a, b | B { b } | - ]
+ emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
RULE BlackStraight:
[ | R:2 {}; W:1 {} | ] "
Modified: trunk/Toss/examples/Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-19 20:57:15 UTC (rev 1282)
+++ trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-21 20:46:12 UTC (rev 1283)
@@ -11,15 +11,9 @@
REL WinQ() = ex x, y, z (Q(x) and Q(y) and Q(z) and Conn3(x, y, z))
REL WinP() = ex x, y, z (P(x) and P(y) and P(z) and Conn3(x, y, z))
RULE Cross:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- ->
- [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- emb Q, P pre not WinQ()
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P pre not WinQ()
RULE Circle:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- ->
- [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- emb Q, P pre not WinP()
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not WinP()
LOC 0 {
PLAYER 1
PAYOFF {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-19 20:57:23
|
Revision: 1282
http://toss.svn.sourceforge.net/toss/?rev=1282&view=rev
Author: lukaszkaiser
Date: 2011-01-19 20:57:15 +0000 (Wed, 19 Jan 2011)
Log Message:
-----------
Some more html corrections.
Modified Paths:
--------------
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/contact.html
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/profile.html
trunk/Toss/WebClient/register.html
trunk/Toss/www/index.php
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/WebClient/Login.js 2011-01-19 20:57:15 UTC (rev 1282)
@@ -110,6 +110,10 @@
}
}
+function login_onenter () {
+ if (window.event && window.event.keyCode == 13) { login() }
+}
+
// Logout
function logout () {
clear_view ();
@@ -208,3 +212,19 @@
if (resp != "OK") { alert(resp); }
window.location.reload ();
}
+
+
+// Email address obfuscation to prevent some spamming.
+function begin_mailto (name, domain, title) {
+ var address = name + '@' + domain;
+ if(title) {
+ document.write("<a class='mail' href='mailto:" + address + "'>" + "<span>");
+ } else {
+ document.write("<a class='mail' href='mailto:" + address + "'>" +
+ address + "<span style='display: none;'>");
+ }
+}
+
+function end_mailto() {
+ document.write("</span></a>");
+}
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/WebClient/Style.css 2011-01-19 20:57:15 UTC (rev 1282)
@@ -345,12 +345,12 @@
/* Content */
-.mail {
+.mail, .ta {
color: #260314;
text-decoration: underline;
}
-.mail:hover {
+.mail:hover, .ta:hover {
cursor: pointer;
text-decoration: none;
}
@@ -404,6 +404,15 @@
left: 1em;
}
+.welcome-list {
+ list-style: square;
+ padding-left: 1.5em;
+}
+
+.welcome-list li {
+ margin-top: 0.5em;
+}
+
#users-list {
list-style: none;
padding-left: 1.5em;
@@ -475,14 +484,14 @@
#welcome {
text-align: justify;
- margin-top: 3.5em;
- margin-left: 1em;
+ margin-top: 5em;
+ margin-left: 2em;
}
#welcome-top {
font-size: 1.2em;
font-weight: bold;
- padding-left: 1.25em;
+ padding-left: 0em;
}
#game-disp {
Modified: trunk/Toss/WebClient/contact.html
===================================================================
--- trunk/Toss/WebClient/contact.html 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/WebClient/contact.html 2011-01-19 20:57:15 UTC (rev 1282)
@@ -3,24 +3,11 @@
<head>
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay — Contact</title>
- <meta http-equiv="X-UA-Compatible" content="chrome=1">
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
- <script type="text/javascript">
- function begin_mailto (name, domain, title) {
- var address = name + '@' + domain;
- if(title) {
- document.write("<a class='mail' href='mailto:" + address + "'>" + "<span>");
- } else {
- document.write("<a class='mail' href='mailto:" + address + "'>" +
- address + "<span style='display: none;'>");
- }
- }
- function end_mailto() {
- document.write("</span></a>");
- }
- </script>
+ <script type="text/javascript" src="Login.js"> </script>
</head>
<body>
@@ -40,6 +27,14 @@
tossplay [AT] gmail [DOT] com
<script type="text/javascript">end_mailto();</script>
+<h2>Links</h2>
+
+<ul>
+<li><a class="ta" href="http://toss.sourceforge.net/">Toss Homepage</a></li>
+<li><a class="ta" href="http://www.playok.com/">Online games on PlayOK</a></li>
+<li><a class="ta" href="http://apronus.com/chess/index.htm">Chess on Apronus</a></li>
+</ul>
+
</div>
<div id="bottom">
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/WebClient/index.html 2011-01-19 20:57:15 UTC (rev 1282)
@@ -3,7 +3,9 @@
<head>
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay</title>
- <meta http-equiv="X-UA-Compatible" content="chrome=1">
+ <meta name="Description"
+ content="Play the best strategic games online with a nice interface." />
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
@@ -22,7 +24,7 @@
<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
<div id="topbar">
<span id="topuser"></span>
-<form id="loginform" style="display: inline;">
+<form id="loginform" style="display: inline;" action="">
<div id="login1">
<p class="loginsmall">Username:</p>
<input class="loginput" type="text" name="username" id="username" size="15" />
@@ -30,14 +32,13 @@
<div id="login2">
<p class="loginsmall">Password:</p>
<input class="loginput" type="password" name="password" id="password" size="15"
- onkeypress="if (window.event && window.event.keyCode == 13) { login() }"
- />
+ onkeypress="login_onenter()" />
</div>
<div id="login3">
<p class="loginchk">
<input type="checkbox" id="remember" value="r"
- checked="yes"><span id="rememberspan">Remember me</span>
- </input>
+ checked="checked" />
+ <span id="rememberspan">Remember me</span>
</p>
<button type="button" id="loginbt" onclick="login()">
<span id="loginspan">Login</span>
@@ -60,7 +61,7 @@
onclick="window.location.reload()">Find New</a>
<button class="bt" id="opponents-cancel"
onclick="window.location.reload()">Cancel</button>
- <ul id="opponents-list"></ul>
+ <ul id="opponents-list"><li style="display: none;"/></ul>
<button class="bt" id="opponents-prev"
onclick="opponents_prev()">Prev</button>
<button class="bt" id="opponents-next"
@@ -68,16 +69,25 @@
</div>
<div id="welcome">
-<p id="welcome-top">Enjoy games on <span class="logo-in">tPlay</span></p>
+<p id="welcome-top">Enjoy the best games on <span class="logo-in">tPlay</span> for free</p>
<p>
Strategic games are fun!
- <a href="register.html">Register</a>, login and enjoy
- <span class="logo-in">tPlay</span>!</p>
+ <a href="register.html">Register</a>, login and enjoy quality games
+ with our best interface on <span class="logo-in">tPlay</span>!
+</p>
+<ul class="welcome-list">
+<li>Play Breakthrough, Checkers, Chess, Gomoku and many other board games</li>
+<li>Challenge your friends or play a fast game against the computer for fun</li>
+<li>Focus fully on the game thanks to our intuitive clean interface</li>
+<li>Keep and analyze your games to improve your strength</li>
+<li>Invent new games with <a href="http://toss.sourceforge.net/">Toss</a>
+ and play them online here</li>
+</ul>
</div>
<div id="nosvg"
style="border: 1px solid #260314; padding-left: 1em; display: none;">
-<p style="padding-left: 1.2em; font-size: 1.2em;"<b>SVG Support Missing</b></p>
+<p style="padding-left: 1.2em; font-size: 1.2em;"><b>SVG Support Missing</b></p>
<p>Your browser does not seem to support SVG,
which is <b>necessary</b> to enjoy tPlay.
To correct this problem install the following plugin.</p>
@@ -100,38 +110,50 @@
class="boldobt">Breakthrough</button>
(<a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)">info</a>)
</p>
- <ul class="plays-list" id="plays-list-Breakthrough"></ul>
+ <ul class="plays-list" id="plays-list-Breakthrough">
+ <li style="display: none;"/>
+ </ul>
<p class="game-par">
<button onclick="new_play('Checkers')"
class="boldobt">Checkers</button>
(<a href="http://en.wikipedia.org/wiki/English_draughts">info</a>)
</p>
- <ul class="plays-list" id="plays-list-Checkers"></ul>
+ <ul class="plays-list" id="plays-list-Checkers">
+ <li style="display: none;"/>
+ </ul>
<p class="game-par">
<button onclick="new_play('Chess')"
class="boldobt">Chess</button>
(<a href="http://en.wikipedia.org/wiki/Chess">info</a>)
</p>
- <ul class="plays-list" id="plays-list-Chess"></ul>
+ <ul class="plays-list" id="plays-list-Chess">
+ <li style="display: none;"/>
+ </ul>
<p class="game-par">
<button onclick="new_play('Entanglement')"
class="boldobt">Entanglement</button>
(<a href="http://en.wikipedia.org/wiki/Entanglement_(graph_measure)"
>info</a>)
</p>
- <ul class="plays-list" id="plays-list-Entanglement"></ul>
+ <ul class="plays-list" id="plays-list-Entanglement">
+ <li style="display: none;"/>
+ </ul>
<p class="game-par">
<button onclick="new_play('Gomoku')"
class="boldobt">Gomoku</button>
(<a href="http://en.wikipedia.org/wiki/Gomoku">info</a>)
</p>
- <ul class="plays-list" id="plays-list-Gomoku"></ul>
+ <ul class="plays-list" id="plays-list-Gomoku">
+ <li style="display: none;"/>
+ </ul>
<p class="game-par">
<button onclick="new_play('Tic-Tac-Toe')"
class="boldobt">Tic-Tac-Toe</button>
(<a href="http://en.wikipedia.org/wiki/Tic-tac-toe">info</a>)
</p>
- <ul class="plays-list" id="plays-list-Tic-Tac-Toe"></ul>
+ <ul class="plays-list" id="plays-list-Tic-Tac-Toe">
+ <li style="display: none;"/>
+ </ul>
</div>
@@ -151,7 +173,7 @@
<button id="sugbt" class="bt" onclick="suggest_move()">
Suggest (weak, fast)
</button>
- <button id="sugbt" class="bt" onclick="suggest_move_better()">
+ <button id="sugbts" class="bt" onclick="suggest_move_better()">
Suggest (stronger, slow)
</button>
</p>
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/WebClient/profile.html 2011-01-19 20:57:15 UTC (rev 1282)
@@ -3,7 +3,7 @@
<head>
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay — Profile</title>
- <meta http-equiv="X-UA-Compatible" content="chrome=1">
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
@@ -15,11 +15,14 @@
</head>
<body onload="startup_profile()">
+
+<div id="main">
+
<div id="top">
<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
<div id="topbar">
<span id="topuser"></span>
-<form id="loginform" style="display: inline;">
+<form id="loginform" style="display: inline;" action="">
<div id="login1">
<p class="loginsmall">Username:</p>
<input class="loginput" type="text" name="username" id="username" size="15" />
@@ -27,14 +30,13 @@
<div id="login2">
<p class="loginsmall">Password:</p>
<input class="loginput" type="password" name="password" id="password" size="15"
- onkeypress="if (window.event && window.event.keyCode == 13) { login() }"
- />
+ onkeypress="login_onenter()" />
</div>
<div id="login3">
<p class="loginchk">
<input type="checkbox" id="remember" value="r"
- checked="yes"><span id="rememberspan">Remember me</span>
- </input>
+ checked="checked"/>
+ <span id="rememberspan">Remember me</span>
</p>
<button type="button" id="loginbt" onclick="login()">
<span id="loginspan">Login</span>
@@ -49,10 +51,7 @@
<a href="register.html">Register</a>
</span>
</div>
-</div>
-<div id="main">
-
<div id="welcome">
<p id="welcome-top">To edit your <span class="logo-in">tPlay</span>
profile please login above or <a href="register.html">register</a> first.
@@ -62,7 +61,7 @@
<div id="main-profile" style="display: none;">
<h2>Your Profile</h2>
-<form id="changeprofileform">
+<form id="changeprofileform" action="">
<p> <span class="reglabel">Name:</span>
<input class="forminput" type="text" name="name" id="name" />
</p>
@@ -72,30 +71,30 @@
<p> <span class="reglabel">Email:</span>
<input class="forminput" type="text" name="email" id="email" />
</p>
-<button class="bt" id="changebt" type="button"
- onclick="change_profile()">Change</button>
+<p><button class="bt" id="changebt" type="button"
+ onclick="change_profile()">Change</button></p>
</form>
<h2>Your Current Opponents</h2>
<div id="opponents-profile">
- <ul id="opponents-list"></ul>
+ <ul id="opponents-list"><li style="display: none;"/></ul>
</div>
<h2>Suggested New Opponents</h2>
<div id="users-profile">
- <ul id="users-list"></ul>
+ <ul id="users-list"><li style="display: none;"/></ul>
</div>
</div>
-</div>
-
<div id="bottom">
<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
<a href="contact.html" id="contact">Contact and Info</a>
</div>
+</div>
+
</body>
</html>
Modified: trunk/Toss/WebClient/register.html
===================================================================
--- trunk/Toss/WebClient/register.html 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/WebClient/register.html 2011-01-19 20:57:15 UTC (rev 1282)
@@ -3,7 +3,7 @@
<head>
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay — Registration</title>
- <meta http-equiv="X-UA-Compatible" content="chrome=1">
+ <meta http-equiv="X-UA-Compatible" content="chrome=1" />
<link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
@@ -13,17 +13,18 @@
</head>
<body>
+
+<div id="main">
+
<div id="top">
<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
</div>
-<div id="main">
-
<div id="register-content">
<h2>Register on tPlay</h2>
-<form id="registerform">
+<form id="registerform" action="">
<p> <span class="reglabel">Username:</span>
<input class="forminput" type="text" name="username" id="username" /> </p>
<p> <span class="reglabel">Password:</span>
@@ -42,17 +43,17 @@
<p> <span class="reglabel">Email:</span>
<input class="forminput" type="text" name="email" id="email" />
</p>
-<button class="bt" id="registerbt" type="button" onclick="register()">Register</button>
+<p><button class="bt" id="registerbt" type="button" onclick="register()">Register</button></p>
</form>
</div>
-</div>
-
<div id="bottom">
<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
<a href="contact.html" id="contact">Contact and Info</a>
</div>
+</div>
+
</body>
</html>
Modified: trunk/Toss/www/index.php
===================================================================
--- trunk/Toss/www/index.php 2011-01-13 19:33:52 UTC (rev 1281)
+++ trunk/Toss/www/index.php 2011-01-19 20:57:15 UTC (rev 1282)
@@ -1,6 +1,7 @@
<?php @include "site_template.php";
$prefix = "";
+$style = "";
$url = "index.php";
$title = "Toss Home Page";
@@ -13,6 +14,9 @@
did you ever wonder how your favorite game would feel if you removed
the middle of the board? With Toss, it is easy to experiment!</p>
<ul>
+<li style="margin: 0.5em"><b>Play</b> Toss games online at
+ <a href="http://tplay.org">
+ tPlay.org</a>.</li>
<li style="margin: 0.5em"><b>Download</b> Toss from the
<a href="http://sourceforge.net/project/showfiles.php?group_id=115606">
Sourceforge Download Page</a>.</li>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-13 19:33:58
|
Revision: 1281
http://toss.svn.sourceforge.net/toss/?rev=1281&view=rev
Author: lukaszkaiser
Date: 2011-01-13 19:33:52 +0000 (Thu, 13 Jan 2011)
Log Message:
-----------
One more very small change.
Modified Paths:
--------------
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/profile.html
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-01-13 03:02:02 UTC (rev 1280)
+++ trunk/Toss/WebClient/Login.js 2011-01-13 19:33:52 UTC (rev 1281)
@@ -53,6 +53,13 @@
}
}
+// Html of the list item for adding new opponents.
+function add_opponent_item_html (uname) {
+ var onclick = 'onclick="add_opponent (' + "'" + uname + "'" + ')"';
+ var bt = '<button class="bt" ' + onclick + ">Add</button>"
+ return (bt + " " + disp_name(uname) + " (" + uname + ")")
+}
+
// Onload handler for the profile page
function startup_profile () {
var un = srv("USERNAME", "user");
@@ -81,7 +88,7 @@
for (var i = 0; i < users.length; i++) {
if (users[i] != un && FRIENDS.indexOf(users[i]) == -1) {
var li = document.createElement('li');
- li.innerHTML = disp_name(users[i]) + " (" + users[i] + ")";
+ li.innerHTML = add_opponent_item_html (users[i]);
u.appendChild (li);
}
}
@@ -196,8 +203,7 @@
}
// Add opponent for the current user.
-function add_opponent () {
- var oppuname = document.getElementById('oppuname').value;
+function add_opponent (oppuname) {
var resp = sync_server_msg ("ADDOPP#" + oppuname);
if (resp != "OK") { alert(resp); }
window.location.reload ();
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-01-13 03:02:02 UTC (rev 1280)
+++ trunk/Toss/WebClient/Style.css 2011-01-13 19:33:52 UTC (rev 1281)
@@ -93,13 +93,6 @@
margin-top: 0.3em;
}
-.regwidelabel {
- float: left;
- clear: left;
- width: 19em;
- margin-top: 0.3em;
-}
-
.loginsmall {
position: relative;
top: 1px;
@@ -411,6 +404,12 @@
left: 1em;
}
+#users-list {
+ list-style: none;
+ padding-left: 1.5em;
+ margin-top: 0.5em;
+}
+
#opponents {
display: none;
position: absolute;
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-01-13 03:02:02 UTC (rev 1280)
+++ trunk/Toss/WebClient/profile.html 2011-01-13 19:33:52 UTC (rev 1281)
@@ -82,20 +82,12 @@
<ul id="opponents-list"></ul>
</div>
-<h2>Suggested Opponents</h2>
+<h2>Suggested New Opponents</h2>
<div id="users-profile">
<ul id="users-list"></ul>
</div>
-<form id="opponentsform">
-<p> <span class="regwidelabel">Opponent Username (in brackets):</span>
- <input class="forminput" type="text" name="oppuname" id="oppuname"
- onkeypress="if (window.event && window.event.keyCode == 13) { add_opponent() }" />
-</p>
-<button class="bt" id="oppaddbt" type="button"
- onclick="add_opponent()">Add Opponent</button>
-</form>
</div>
</div>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-13 03:02:10
|
Revision: 1280
http://toss.svn.sourceforge.net/toss/?rev=1280&view=rev
Author: lukaszkaiser
Date: 2011-01-13 03:02:02 +0000 (Thu, 13 Jan 2011)
Log Message:
-----------
Just small easy corrections for now.
Modified Paths:
--------------
trunk/Toss/WebClient/Handler.py
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/profile.html
Modified: trunk/Toss/WebClient/Handler.py
===================================================================
--- trunk/Toss/WebClient/Handler.py 2011-01-10 01:10:08 UTC (rev 1279)
+++ trunk/Toss/WebClient/Handler.py 2011-01-13 03:02:02 UTC (rev 1280)
@@ -75,6 +75,9 @@
return (str([play_name (p) for p in plays]))
def list_friends (db, uid):
+ if (uid == "**"):
+ users = get_all_from_db (db, "users", "0=0")
+ return ([str(u) for (u, _, _, _, _) in users])
friends = get_all_from_db (db, "friends", "id='"+ uid + "'")
return (str([str(f) for (_, f) in friends]))
@@ -313,7 +316,9 @@
req.write(str(get_user_surname (db, data)))
return apache.OK
if cmd == "LIST_FRIENDS":
- req.write(str(list_friends (db, usr)))
+ requsr = usr
+ if data == "**": requsr = "**"
+ req.write(str(list_friends (db, requsr)))
return apache.OK
if cmd == "GET_MAIL":
if usr == "": return ("You must login first to get email data.")
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-01-10 01:10:08 UTC (rev 1279)
+++ trunk/Toss/WebClient/Login.js 2011-01-13 03:02:02 UTC (rev 1280)
@@ -75,16 +75,27 @@
li.innerHTML = disp_name(FRIENDS[i]) + " (" + FRIENDS[i] + ")";
o.appendChild (li);
}
+ var lst = srv ("LIST_FRIENDS", "**");
+ var users = convert_python_list (',', lst);
+ var u = document.getElementById("users-list");
+ for (var i = 0; i < users.length; i++) {
+ if (users[i] != un && FRIENDS.indexOf(users[i]) == -1) {
+ var li = document.createElement('li');
+ li.innerHTML = disp_name(users[i]) + " (" + users[i] + ")";
+ u.appendChild (li);
+ }
+ }
};
}
// Login
-function login () {
- un = document.getElementById('username').value;
- pwd = document.getElementById('password').value;
- chk = "false";
+function login () {
+ var unv = document.getElementById('username').value;
+ var un = unv.toLowerCase();
+ var pwd = document.getElementById('password').value;
+ var chk = "false";
if (document.getElementById('remember').checked) { chk = "true" };
- resp = sync_server_msg ("LOGIN#" + un +"$"+ chk +"$"+ crypt(TSALT + pwd));
+ var resp = sync_server_msg("LOGIN#"+ un +"$"+ chk +"$"+ crypt(TSALT + pwd));
if (resp == "OK") {
window.location.reload ()
} else {
@@ -112,12 +123,13 @@
// Register new user
function register () {
- un = document.getElementById('username').value;
- pwd = document.getElementById('password').value;
- rptpwd = document.getElementById('rptpassword').value;
- name = document.getElementById('name').value;
- surname = document.getElementById('surname').value;
- email = document.getElementById('email').value;
+ var unv = document.getElementById('username').value;
+ var un = unv.toLowerCase();
+ var pwd = document.getElementById('password').value;
+ var rptpwd = document.getElementById('rptpassword').value;
+ var name = document.getElementById('name').value;
+ var surname = document.getElementById('surname').value;
+ var email = document.getElementById('email').value;
if (un.length < 2) {
alert ("Your username must contain at least 2 letters." + CORRMSG);
return;
@@ -151,16 +163,16 @@
alert ("Your data must not contain $, i.e. the dolar sign." + CORRMSG);
return;
}
- data = un + "$" + name + "$" + surname + "$" + email;
- resp = sync_server_msg ("REGISTER#" + data + "$" + crypt(TSALT + pwd));
+ var data = un + "$" + name + "$" + surname + "$" + email;
+ var resp = sync_server_msg ("REGISTER#" + data + "$" + crypt(TSALT + pwd));
alert (resp);
}
// Change user data
function change_profile () {
- name = document.getElementById('name').value;
- surname = document.getElementById('surname').value;
- email = document.getElementById('email').value;
+ var name = document.getElementById('name').value;
+ var surname = document.getElementById('surname').value;
+ var email = document.getElementById('email').value;
if (name == "") {
alert ("Your name was not given and it is necessary." + CORRMSG);
return;
@@ -178,15 +190,15 @@
alert ("Your data must not contain $, i.e. the dolar sign." + CORRMSG);
return;
}
- resp = sync_server_msg ("CHANGEUSR#" + name + "$" + surname + "$" + email);
+ var resp = sync_server_msg ("CHANGEUSR#" + name +"$"+ surname +"$"+ email);
if (resp != "OK") { alert(resp); }
window.location.reload ();
}
// Add opponent for the current user.
function add_opponent () {
- oppuname = document.getElementById('oppuname').value;
- resp = sync_server_msg ("ADDOPP#" + oppuname);
+ var oppuname = document.getElementById('oppuname').value;
+ var resp = sync_server_msg ("ADDOPP#" + oppuname);
if (resp != "OK") { alert(resp); }
window.location.reload ();
-}
\ No newline at end of file
+}
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-01-10 01:10:08 UTC (rev 1279)
+++ trunk/Toss/WebClient/Style.css 2011-01-13 03:02:02 UTC (rev 1280)
@@ -93,6 +93,13 @@
margin-top: 0.3em;
}
+.regwidelabel {
+ float: left;
+ clear: left;
+ width: 19em;
+ margin-top: 0.3em;
+}
+
.loginsmall {
position: relative;
top: 1px;
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-01-10 01:10:08 UTC (rev 1279)
+++ trunk/Toss/WebClient/profile.html 2011-01-13 03:02:02 UTC (rev 1280)
@@ -76,15 +76,22 @@
onclick="change_profile()">Change</button>
</form>
-<h2>Your Opponents</h2>
+<h2>Your Current Opponents</h2>
<div id="opponents-profile">
<ul id="opponents-list"></ul>
</div>
+<h2>Suggested Opponents</h2>
+
+<div id="users-profile">
+ <ul id="users-list"></ul>
+</div>
+
<form id="opponentsform">
-<p> <span class="reglabel">Opponent Username:</span>
- <input class="forminput" type="text" name="oppuname" id="oppuname" />
+<p> <span class="regwidelabel">Opponent Username (in brackets):</span>
+ <input class="forminput" type="text" name="oppuname" id="oppuname"
+ onkeypress="if (window.event && window.event.keyCode == 13) { add_opponent() }" />
</p>
<button class="bt" id="oppaddbt" type="button"
onclick="add_opponent()">Add Opponent</button>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-10 01:10:14
|
Revision: 1279
http://toss.svn.sourceforge.net/toss/?rev=1279&view=rev
Author: lukaszkaiser
Date: 2011-01-10 01:10:08 +0000 (Mon, 10 Jan 2011)
Log Message:
-----------
Some more small corrections.
Modified Paths:
--------------
trunk/Toss/WebClient/MakeDB.py
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/contact.html
trunk/Toss/WebClient/favicon.ico
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/profile.html
trunk/Toss/WebClient/register.html
Added Paths:
-----------
trunk/Toss/WebClient/toss.png
Modified: trunk/Toss/WebClient/MakeDB.py
===================================================================
--- trunk/Toss/WebClient/MakeDB.py 2011-01-09 23:36:40 UTC (rev 1278)
+++ trunk/Toss/WebClient/MakeDB.py 2011-01-10 01:10:08 UTC (rev 1279)
@@ -3,18 +3,18 @@
import os
from pysqlite2 import dbapi2 as sqlite3
+TUID = "toss_id_05174_"
+
DB_FILE = "/var/www/WebClient/tossdb.sqlite"
SERVER_FILE = "/var/www/WebClient/TossServer"
GAMES_PATH = "../examples"
+
GAMES = ["Breakthrough", "Checkers", "Chess", "Entanglement",
"Gomoku", "Tic-Tac-Toe"]
-TUID = "toss_id_05174_"
-
-
def create_db (db_file, games_path, games):
conn = sqlite3.connect(db_file)
conn.execute("create table users(id string primary key," +
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-01-09 23:36:40 UTC (rev 1278)
+++ trunk/Toss/WebClient/Style.css 2011-01-10 01:10:08 UTC (rev 1279)
@@ -15,7 +15,7 @@
padding: 0px;
margin: 0px;
text-align: center;
- background-color: #f7ffd8;
+ background-color: #f5f2ef;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
}
@@ -173,7 +173,7 @@
#logoutbt:hover {
cursor: pointer;
- color: #f7ffd8;
+ color: #f5f2ef;
}
#login1 {
@@ -204,6 +204,7 @@
#logo img {
height: 1.5em;
width: 2.5em;
+ border: 0px;
}
#top a, #logo a:link, #logo a:active, #logo a:visited {
@@ -213,7 +214,7 @@
}
#top a:hover {
- color: #f7ffd8;
+ color: #f5f2ef;
}
.logo-in {
@@ -338,7 +339,7 @@
}
#topbar a:hover {
- color: #f7ffd8;
+ color: #f5f2ef;
}
@@ -635,7 +636,7 @@
}
.model-elem-highlight {
- fill: #f7ffd8;
+ fill: #f5f2ef;
stroke: #400827;
stroke-width: 3px;
}
Modified: trunk/Toss/WebClient/contact.html
===================================================================
--- trunk/Toss/WebClient/contact.html 2011-01-09 23:36:40 UTC (rev 1278)
+++ trunk/Toss/WebClient/contact.html 2011-01-10 01:10:08 UTC (rev 1279)
@@ -28,7 +28,7 @@
<div id="main">
<div id="top">
-<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
+<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
</div>
<div id="register-content">
Modified: trunk/Toss/WebClient/favicon.ico
===================================================================
(Binary files differ)
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-01-09 23:36:40 UTC (rev 1278)
+++ trunk/Toss/WebClient/index.html 2011-01-10 01:10:08 UTC (rev 1279)
@@ -19,7 +19,7 @@
<div id="main">
<div id="top">
-<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
+<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
<div id="topbar">
<span id="topuser"></span>
<form id="loginform" style="display: inline;">
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-01-09 23:36:40 UTC (rev 1278)
+++ trunk/Toss/WebClient/profile.html 2011-01-10 01:10:08 UTC (rev 1279)
@@ -16,7 +16,7 @@
<body onload="startup_profile()">
<div id="top">
-<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
+<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
<div id="topbar">
<span id="topuser"></span>
<form id="loginform" style="display: inline;">
Modified: trunk/Toss/WebClient/register.html
===================================================================
--- trunk/Toss/WebClient/register.html 2011-01-09 23:36:40 UTC (rev 1278)
+++ trunk/Toss/WebClient/register.html 2011-01-10 01:10:08 UTC (rev 1279)
@@ -14,7 +14,7 @@
<body>
<div id="top">
-<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
+<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
</div>
<div id="main">
Added: trunk/Toss/WebClient/toss.png
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/WebClient/toss.png
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-09 23:36:47
|
Revision: 1278
http://toss.svn.sourceforge.net/toss/?rev=1278&view=rev
Author: lukaszkaiser
Date: 2011-01-09 23:36:40 +0000 (Sun, 09 Jan 2011)
Log Message:
-----------
Correcting examples and webclient.
Modified Paths:
--------------
trunk/Toss/WebClient/Connect.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/MakeDB.py
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/contact.html
trunk/Toss/WebClient/favicon.ico
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/profile.html
trunk/Toss/WebClient/register.html
trunk/Toss/examples/Checkers.toss
trunk/Toss/examples/Tic-Tac-Toe.toss
trunk/Toss/www/links.php
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/Connect.js 2011-01-09 23:36:40 UTC (rev 1278)
@@ -133,10 +133,12 @@
var all_moves = convert_python_list (';', MOVES_STR);
var elem_moves = []
for (i = 0; i < all_moves.length; i++) {
- if (all_moves[i].indexOf(elem) >= 0) {
+ var br = all_moves[i].indexOf(":");
+ if (br < 0) { br = 0; };
+ if (all_moves[i].indexOf(elem, br) > br) {
if (other == "") {
elem_moves.push(all_moves[i])
- } else if (all_moves[i].indexOf(other) >= 0) {
+ } else if (all_moves[i].indexOf(other, br) > br) {
elem_moves.push(all_moves[i])
}
}
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/Main.js 2011-01-09 23:36:40 UTC (rev 1278)
@@ -368,13 +368,21 @@
}
function suggest_move () {
+ document.getElementById("working").innerHTML = "Calculating move...";
+ document.getElementById("working").style.display = "block";
var m = srv("SUGGEST", 'c, '+ play_py_id (CUR_PLAY_I));
+ document.getElementById("working").style.display = "none";
+ document.getElementById("working").innerHTML = "Working...";
if (m != "") { show_move (m); }
return (m);
}
function suggest_move_better () {
+ document.getElementById("working").innerHTML = "Calculating move...";
+ document.getElementById("working").style.display = "block";
var m = srv("SUGGESTX", 'c, '+ play_py_id (CUR_PLAY_I));
+ document.getElementById("working").style.display = "none";
+ document.getElementById("working").innerHTML = "Working...";
if (m != "") { show_move (m); }
return (m);
}
Modified: trunk/Toss/WebClient/MakeDB.py
===================================================================
--- trunk/Toss/WebClient/MakeDB.py 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/MakeDB.py 2011-01-09 23:36:40 UTC (rev 1278)
@@ -45,7 +45,24 @@
os.chmod (db_file, 0777)
+def reload_games (db_file, games_path, games):
+ conn = sqlite3.connect(db_file)
+ conn.execute ("delete from games");
+ print "Deleted old games";
+ for g in games:
+ f = open(games_path + "/" + g + ".toss")
+ toss = f.read()
+ f.close()
+ conn.execute ("insert into games(game, toss) values (?, ?)", (g, toss))
+ print ("Reloading games: added " + g)
+ conn.commit ()
+
if __name__ == "__main__":
- print "Creating empty Toss DB"
- create_db (DB_FILE, GAMES_PATH, GAMES)
- print "Created tossdb.sqlite"
+ if os.path.exists (DB_FILE):
+ print ("Reloading games into Toss DB (" + DB_FILE + ")")
+ reload_games (DB_FILE, GAMES_PATH, GAMES)
+ print "Games reloaded"
+ else:
+ print ("Creating empty Toss DB (" + DB_FILE + ")")
+ create_db (DB_FILE, GAMES_PATH, GAMES)
+ print "Created tossdb.sqlite"
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/Style.css 2011-01-09 23:36:40 UTC (rev 1278)
@@ -15,7 +15,7 @@
padding: 0px;
margin: 0px;
text-align: center;
- background-color: #b5bf8f;
+ background-color: #f7ffd8;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
}
@@ -43,7 +43,7 @@
float: right;
}
-.obt {
+.obt, .boldobt {
text-align: left;
border-color: #260314;
border-radius: 4px;
@@ -60,6 +60,16 @@
text-decoration: underline;
}
+.boldobt {
+ font-weight: bold;
+ font-size: 1em;
+}
+
+.boldobt:hover {
+ cursor: pointer;
+ text-decoration: underline;
+}
+
.dbt {
border-color: #fff1d4;
border-radius: 4px;
@@ -163,7 +173,7 @@
#logoutbt:hover {
cursor: pointer;
- color: #b5bf8f;
+ color: #f7ffd8;
}
#login1 {
@@ -191,6 +201,11 @@
padding-left: 0.25em;
}
+#logo img {
+ height: 1.5em;
+ width: 2.5em;
+}
+
#top a, #logo a:link, #logo a:active, #logo a:visited {
color: #fff1d4;
background-color: transparent;
@@ -198,7 +213,7 @@
}
#top a:hover {
- color: #b5bf8f;
+ color: #f7ffd8;
}
.logo-in {
@@ -323,12 +338,22 @@
}
#topbar a:hover {
- color: #b5bf8f;
+ color: #f7ffd8;
}
/* Content */
+.mail {
+ color: #260314;
+ text-decoration: underline;
+}
+
+.mail:hover {
+ cursor: pointer;
+ text-decoration: none;
+}
+
.game_list {
font-weight: bold;
}
@@ -505,7 +530,6 @@
font-weight: bold;
color: #fff1d4;
background-color: #400827;
- display: none;
padding: 1em;
}
@@ -585,9 +609,9 @@
#svg {
min-width: 10em;
max-width: 120em;
- width: 65%;
+ width: 75%;
min-height: 10em;
- max-height: 120em;
+ max-height: 35em;
height: 75%;
/* border: 1px solid #260314; */
}
@@ -611,7 +635,7 @@
}
.model-elem-highlight {
- fill: #b5bf8f;
+ fill: #f7ffd8;
stroke: #400827;
stroke-width: 3px;
}
@@ -651,6 +675,18 @@
stroke-width: 3px;
}
+.Game-Checkers .model-pred-B {
+ fill: #fff1d4;
+ stroke: #260314;
+ stroke-width: 3px;
+}
+
+.Game-Checkers .model-pred-W {
+ fill: #400827;
+ stroke: #260314;
+ stroke-width: 3px;
+}
+
.model-edge-E {
fill: #260314;
stroke: #260314;
Modified: trunk/Toss/WebClient/contact.html
===================================================================
--- trunk/Toss/WebClient/contact.html 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/contact.html 2011-01-09 23:36:40 UTC (rev 1278)
@@ -4,32 +4,51 @@
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay — Contact</title>
<meta http-equiv="X-UA-Compatible" content="chrome=1">
- <link rel="icon" type="image/vnd.microsoft.icon" href="/favicon.ico" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
+ <script type="text/javascript">
+ function begin_mailto (name, domain, title) {
+ var address = name + '@' + domain;
+ if(title) {
+ document.write("<a class='mail' href='mailto:" + address + "'>" + "<span>");
+ } else {
+ document.write("<a class='mail' href='mailto:" + address + "'>" +
+ address + "<span style='display: none;'>");
+ }
+ }
+ function end_mailto() {
+ document.write("</span></a>");
+ }
+ </script>
</head>
<body>
+
+<div id="main">
+
<div id="top">
-<div id="logo"><a href="index.html">tPlay</a></div>
+<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
</div>
-<div id="main">
-
<div id="register-content">
<h2>Contact tPlay</h2>
-Just write us an email!
+Just write an email to
+<script type="text/javascript">begin_mailto("tossplay", "gmail.com");</script>
+tossplay [AT] gmail [DOT] com
+<script type="text/javascript">end_mailto();</script>
</div>
-</div>
-
<div id="bottom">
<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
<a href="contact.html" id="contact">Contact and Info</a>
</div>
+</div>
+
+
</body>
</html>
Modified: trunk/Toss/WebClient/favicon.ico
===================================================================
(Binary files differ)
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/index.html 2011-01-09 23:36:40 UTC (rev 1278)
@@ -4,7 +4,7 @@
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay</title>
<meta http-equiv="X-UA-Compatible" content="chrome=1">
- <link rel="icon" type="image/vnd.microsoft.icon" href="/favicon.ico" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
<script type="text/javascript" src="crypto-sha256.js"> </script>
@@ -19,7 +19,7 @@
<div id="main">
<div id="top">
-<div id="logo"><a href="index.html">tPlay</a></div>
+<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
<div id="topbar">
<span id="topuser"></span>
<form id="loginform" style="display: inline;">
@@ -96,38 +96,40 @@
<div id="plays">
<p class="game-par">
- <button class="bt" onclick="new_play ('Breakthrough')">New Game</button>
- <a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)"
- class="game_list">Breakthrough</a>
+ <button onclick="new_play('Breakthrough')"
+ class="boldobt">Breakthrough</button>
+ (<a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)">info</a>)
</p>
<ul class="plays-list" id="plays-list-Breakthrough"></ul>
<p class="game-par">
- <button class="bt" onclick="new_play ('Checkers')">New Game</button>
- <a class="game_list"
- href="http://en.wikipedia.org/wiki/English_draughts">Checkers</a>
+ <button onclick="new_play('Checkers')"
+ class="boldobt">Checkers</button>
+ (<a href="http://en.wikipedia.org/wiki/English_draughts">info</a>)
</p>
<ul class="plays-list" id="plays-list-Checkers"></ul>
<p class="game-par">
- <button class="bt" onclick="new_play ('Chess')">New Game</button>
- <a class="game_list" href="http://en.wikipedia.org/wiki/Chess">Chess</a>
+ <button onclick="new_play('Chess')"
+ class="boldobt">Chess</button>
+ (<a href="http://en.wikipedia.org/wiki/Chess">info</a>)
</p>
<ul class="plays-list" id="plays-list-Chess"></ul>
<p class="game-par">
- <button class="bt" onclick="new_play ('Entanglement')">New Game</button>
- <a href="http://en.wikipedia.org/wiki/Entanglement_(graph_measure)"
- class="game_list">Entanglement</a>
+ <button onclick="new_play('Entanglement')"
+ class="boldobt">Entanglement</button>
+ (<a href="http://en.wikipedia.org/wiki/Entanglement_(graph_measure)"
+ >info</a>)
</p>
<ul class="plays-list" id="plays-list-Entanglement"></ul>
<p class="game-par">
- <button class="bt" onclick="new_play ('Gomoku')">New Game</button>
- <a href="http://en.wikipedia.org/wiki/Gomoku"
- class="game_list">Gomoku</a>
+ <button onclick="new_play('Gomoku')"
+ class="boldobt">Gomoku</button>
+ (<a href="http://en.wikipedia.org/wiki/Gomoku">info</a>)
</p>
<ul class="plays-list" id="plays-list-Gomoku"></ul>
<p class="game-par">
- <button class="bt" onclick="new_play ('Tic-Tac-Toe')">New Game</button>
- <a href="http://en.wikipedia.org/wiki/Tic-tac-toe"
- class="game_list">Tic-Tac-Toe</a>
+ <button onclick="new_play('Tic-Tac-Toe')"
+ class="boldobt">Tic-Tac-Toe</button>
+ (<a href="http://en.wikipedia.org/wiki/Tic-tac-toe">info</a>)
</p>
<ul class="plays-list" id="plays-list-Tic-Tac-Toe"></ul>
</div>
Modified: trunk/Toss/WebClient/profile.html
===================================================================
--- trunk/Toss/WebClient/profile.html 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/profile.html 2011-01-09 23:36:40 UTC (rev 1278)
@@ -4,7 +4,7 @@
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay — Profile</title>
<meta http-equiv="X-UA-Compatible" content="chrome=1">
- <link rel="icon" type="image/vnd.microsoft.icon" href="/favicon.ico" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
<script type="text/javascript" src="crypto-sha256.js"> </script>
@@ -16,7 +16,7 @@
<body onload="startup_profile()">
<div id="top">
-<div id="logo"><a href="index.html">tPlay</a></div>
+<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
<div id="topbar">
<span id="topuser"></span>
<form id="loginform" style="display: inline;">
Modified: trunk/Toss/WebClient/register.html
===================================================================
--- trunk/Toss/WebClient/register.html 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/WebClient/register.html 2011-01-09 23:36:40 UTC (rev 1278)
@@ -4,7 +4,7 @@
<meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
<title>tPlay — Registration</title>
<meta http-equiv="X-UA-Compatible" content="chrome=1">
- <link rel="icon" type="image/vnd.microsoft.icon" href="/favicon.ico" />
+ <link rel="icon" type="image/vnd.microsoft.icon" href="favicon.ico" />
<link href="fontstyle.css" media="screen" rel="stylesheet" type="text/css" />
<link rel="stylesheet" type="text/css" href="Style.css" media="screen" title="Default"/>
<script type="text/javascript" src="crypto-sha256.js"> </script>
@@ -14,7 +14,7 @@
<body>
<div id="top">
-<div id="logo"><a href="index.html">tPlay</a></div>
+<div id="logo"><a href="index.html"><img src="toss.svg" alt="tPlay" /></a></div>
</div>
<div id="main">
Modified: trunk/Toss/examples/Checkers.toss
===================================================================
--- trunk/Toss/examples/Checkers.toss 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/examples/Checkers.toss 2011-01-09 23:36:40 UTC (rev 1278)
@@ -18,54 +18,56 @@
REL BeatsW (x, y) = ex z (b(z) and not b(y) and not w(y) and DiagW2 (x, z, y))
REL BeatsWX (x, y) = ex z (b(z) and not b(y) and not w(y) and Diag2 (x, z, y))
REL BeatsB (x, y) = ex z (w(z) and not b(y) and not w(y) and DiagB2 (x, z, y))
-REL BeatsBX (x, y) = ex z (w(z) and not b(y) and not w(y) and DiagB2 (x, z, y))
-RULE WhiteMove:
+REL BeatsBX (x, y) = ex z (w(z) and not b(y) and not w(y) and Diag2 (x, z, y))
+REL BJumps() = ex x, y ((B(x) and BeatsB (x, y)) or (Bq(x) and BeatsBX (x, y)))
+REL WJumps() = ex x, y ((W(x) and BeatsW (x, y)) or (Wq(x) and BeatsWX (x, y)))
+RULE RedMove:
[ a, b | W { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | W { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
emb w, b pre (not IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b))
- and not ex x, y (W(x) and BeatsW (x, y))
-RULE BlackMove:
+ and not WJumps()
+RULE WhiteMove:
[ a, b | B { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | B { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
emb w, b pre (not IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b))
- and not ex x, y (B(x) and BeatsB (x, y))
-RULE WhitePromote:
+ and not BJumps()
+RULE RedPromote:
[ a, b | W { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | Wq { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
emb w, b pre (IsEight(b)) and (DiagWa(a, b) or DiagWb(a, b))
- and not ex x, y (W(x) and BeatsW (x, y))
-RULE BlackPromote:
+ and not WJumps()
+RULE WhitePromote:
[ a, b | B { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | Bq { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
emb w, b pre (IsFirst(b)) and (DiagBa(a, b) or DiagBb(a, b))
- and not ex x, y (B(x) and BeatsB(x, y))
-RULE WhiteQMove:
+ and not BJumps()
+RULE RedQMove:
[ a, b | Wq { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | Wq { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre AnyDiag (a, b)
-RULE BlackQMove:
+ emb w, b pre AnyDiag (a, b) and not WJumps()
+RULE WhiteQMove:
[ a, b | Bq { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | Bq { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre AnyDiag (a, b)
-RULE WhiteBeat:
+ emb w, b pre AnyDiag (a, b) and not BJumps()
+RULE RedBeat:
[ a, b, c | W { a }; b { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -74,8 +76,8 @@
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
emb w, b pre DiagW2 (a, b, c) and not IsEight(c)
- post not ex x, y (_new_W(x) and BeatsW (x, y))
-RULE BlackBeat:
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeat:
[ a, b, c | B { a }; w { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -84,18 +86,37 @@
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
emb w, b pre DiagB2 (a, b, c) and not IsFirst(c)
- post not ex x, y (_new_B(x) and BeatsB (x, y))
-RULE WhiteBeatPromote:
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatBoth:
[ a, b, c | W { a }; b { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
->
+ [ a, b, c | W { c } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ emb w, b pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post not ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatBoth:
+ [ a, b, c | B { a }; w { b } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ ->
+ [ a, b, c | B { c } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ emb w, b pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post not ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatPromote:
+ [ a, b, c | W { a }; b { b } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ ->
[ a, b, c | Wq { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
emb w, b pre DiagW2 (a, b, c) and IsEight(c)
- post not ex x, y (_new_W(x) and BeatsW (x, y))
-RULE BlackBeatPromote:
+RULE WhiteBeatPromote:
[ a, b, c | B { a }; w { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -104,8 +125,27 @@
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
emb w, b pre DiagB2 (a, b, c) and IsFirst(c)
- post not ex x, y (_new_B(x) and BeatsB (x, y))
+RULE RedBeatCont:
+ [ a, b, c | W { a }; b { b } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ ->
+ [ a, b, c | W { c } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ emb w, b pre DiagW2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
RULE WhiteBeatCont:
+ [ a, b, c | B { a }; w { b } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ ->
+ [ a, b, c | B { c } |
+ vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
+ x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
+ emb w, b pre DiagB2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedBeatBothCont:
[ a, b, c | W { a }; b { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -113,8 +153,9 @@
[ a, b, c | W { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c) post ex x, y (_new_W(x) and BeatsW (x, y))
-RULE BlackBeatCont:
+ emb w, b pre _new_W(a) and Diag2 (a, b, c) and not IsEight(c)
+ post ex x, y (_new_W(x) and BeatsWX (x, y))
+RULE WhiteBeatBothCont:
[ a, b, c | B { a }; w { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -122,8 +163,9 @@
[ a, b, c | B { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c) post ex x, y (_new_B(x) and BeatsB (x, y))
-RULE WhiteQBeat:
+ emb w, b pre _new_B(a) and Diag2 (a, b, c) and not IsFirst(c)
+ post ex x, y (_new_B(x) and BeatsBX (x, y))
+RULE RedQBeat:
[ a, b, c | Wq { a }; b { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -132,7 +174,7 @@
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
emb w, b pre Diag2 (a, b, c)
-RULE BlackQBeat:
+RULE WhiteQBeat:
[ a, b, c | Bq { a }; w { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
@@ -147,9 +189,9 @@
1: :(ex x w(x)) - :(ex x b(x));
2: :(ex x b(x)) - :(ex x w(x))
}
- MOVES [WhiteMove -> 1]; [WhitePromote -> 1]; [WhiteQMove -> 1];
- [WhiteBeat -> 1]; [WhiteBeatPromote -> 1]; [WhiteQBeat -> 1];
- [WhiteBeatCont -> 2]
+ MOVES [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
+ [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
+ [RedBeatCont -> 2]
}
LOC 1 {
PLAYER 2
@@ -157,9 +199,9 @@
1: :(ex x w(x)) - :(ex x b(x));
2: :(ex x b(x)) - :(ex x w(x))
}
- MOVES [BlackMove -> 0]; [BlackPromote -> 0]; [BlackQMove -> 0];
- [BlackBeat -> 0]; [BlackBeatPromote -> 0]; [BlackQBeat -> 0];
- [BlackBeatCont -> 3]
+ MOVES [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
+ [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
+ [WhiteBeatCont -> 3]
}
LOC 2 {
PLAYER 1
@@ -167,7 +209,7 @@
1: :(ex x w(x)) - :(ex x b(x));
2: :(ex x b(x)) - :(ex x w(x))
}
- MOVES [WhiteBeat -> 1]; [WhiteBeatPromote -> 1]; [WhiteBeatCont -> 2]
+ MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
}
LOC 3 {
PLAYER 2
@@ -175,7 +217,7 @@
1: :(ex x w(x)) - :(ex x b(x));
2: :(ex x b(x)) - :(ex x w(x))
}
- MOVES [BlackBeat -> 0]; [BlackBeatPromote -> 0]; [BlackBeatCont -> 3]
+ MOVES [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
}
MODEL [ | Wq:1 { }; Bq:1 { } |
] "
Modified: trunk/Toss/examples/Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-09 23:36:40 UTC (rev 1278)
@@ -1,5 +1,5 @@
PLAYERS 1, 2
-DATA r1: circle, r2: line, adv_ratio: 4, depth: 4
+DATA r1: circle, r2: line, adv_ratio: 4, depth: 3
REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
REL Row3 (x, y, z) = R(x, y) and R(y, z)
Modified: trunk/Toss/www/links.php
===================================================================
--- trunk/Toss/www/links.php 2011-01-09 20:58:08 UTC (rev 1277)
+++ trunk/Toss/www/links.php 2011-01-09 23:36:40 UTC (rev 1278)
@@ -4,6 +4,7 @@
$prefix = "";
$url = "links.php";
+$style = "";
$title = "Toss Links Page";
$body = '
<div class="main">
@@ -20,6 +21,18 @@
Zillions of Games is a language for defining games together with a simulator
and a large library of games. It is very nice but unluckily not open source.</p>
+<p><a href="http://www.kurnik.pl/">Kurnik</a><br/>
+Kurnik is a polish site on which you can play various games.</p>
+
+<p><a href="http://abstractstrategy.com/main.html">Abstract Strategy Games</a><br/>
+Abstract Strategy Games site allows you to learn and play such games.</p>
+
+<p><a href="http://www.yourturnmyturn.com/">Your Turn My Turn</a><br/>
+On Your-Turn-My-Turn you can play various board games online.</p>
+
+
+
+
<h2>Modelling Tools</h2>
<p><a href="http://edu.kde.org/step/">Step</a><br/>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-09 20:58:16
|
Revision: 1277
http://toss.svn.sourceforge.net/toss/?rev=1277&view=rev
Author: lukstafi
Date: 2011-01-09 20:58:08 +0000 (Sun, 09 Jan 2011)
Log Message:
-----------
GDL translation initial commit, work in progress. Aux.unique_sorted bug fix.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/Play/GDL.ml
trunk/Toss/Play/GDL.mli
trunk/Toss/Play/GDLParser.mly
trunk/Toss/Play/KIFLexer.mll
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
Added Paths:
-----------
trunk/Toss/Play/GDLTest.ml
trunk/Toss/examples/breakthrough.gdl
trunk/Toss/examples/checkers.gdl
trunk/Toss/examples/chess.gdl
trunk/Toss/examples/connect5.gdl
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-01-07 11:41:28 UTC (rev 1276)
+++ trunk/Toss/Formula/Aux.ml 2011-01-09 20:58:08 UTC (rev 1277)
@@ -24,6 +24,10 @@
in
List.rev (cmap_f [] l)
+let rec map_prepend tl f = function
+ [] -> tl
+ | a::l -> let r = f a in r :: map_prepend tl f l
+
let map_some f l =
let rec maps_f accu = function
| [] -> accu
@@ -87,8 +91,15 @@
let tl = map_try f tl in
try f hd :: tl
with Not_found -> tl
-
+let rec fold_left_try f accu l =
+ match l with
+ [] -> accu
+ | a::l ->
+ try
+ fold_left_try f (f accu a) l
+ with Not_found -> fold_left_try f accu l
+
let product l =
List.fold_right (fun set prod ->
concat_map (fun el -> List.map (fun tup -> el::tup) prod) set)
@@ -126,13 +137,27 @@
| [] -> acc in
List.rev (aux [] l)
-(* TODO: that's quadratic, perhaps (sort |> drop_repeating)
- would be faster in practice *)
+(* Not tail-recursive. *)
+let unique_sorted l =
+ let rec idemp = function
+ | e1::(e2::_ as tl) when e1 = e2 -> idemp tl
+ | e::tl -> e::idemp tl
+ | [] -> [] in
+ idemp (List.sort Pervasives.compare l)
+
+(* TODO: that's quadratic, optimize? *)
let rec unique eq = function
| [] -> []
| x :: xs ->
x :: unique eq (List.filter (fun y -> not (eq y x)) xs)
+let not_unique xs =
+ let rec aux left = function
+ | [] -> false
+ | x :: xs when List.mem x left || List.mem x xs -> true
+ | x :: xs -> aux (x::left) xs in
+ aux [] xs
+
let take_n n l =
let rec aux n acc = function
| hd::tl when n > 0 ->
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-01-07 11:41:28 UTC (rev 1276)
+++ trunk/Toss/Formula/Aux.mli 2011-01-09 20:58:08 UTC (rev 1277)
@@ -15,6 +15,10 @@
(** Concatenate results of a function. *)
val concat_map : ('a -> 'b list) -> 'a list -> 'b list
+(** Map a second list and prepend the result to the first list, by
+ single traversal. Not tail-recursive. *)
+val map_prepend : 'a list -> ('b -> 'a) -> 'b list -> 'a list
+
(** Map a list filtering out some elements. *)
val map_some : ('a -> 'b option) -> 'a list -> 'b list
@@ -54,6 +58,12 @@
raise [Not_found]. Therefore [map_try] call cannot raise [Not_found]. *)
val map_try : ('a -> 'b) -> 'a list -> 'b list
+
+(** Fold [f] over the list collecting results whose computation does
+ not raise [Not_found]. Therefore [fold_left_try] call cannot raise
+ [Not_found]. *)
+val fold_left_try : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+
(** Cartesian product of lists. Not tail recursive. *)
val product : 'a list list -> 'a list list
@@ -78,12 +88,18 @@
equal elements only the last one is preserved.) *)
val maximal : ('a -> 'a -> bool) -> 'a list -> 'a list
+(** Return the list of structurally unique elements, in order sorted
+ by {!Pervasives.compare}. Not tail-recursive. *)
+val unique_sorted : 'a list -> 'a list
+
(** Return the list of unique elements, under the given comparison
(the input does not need to be sorted). (Currently uses a
- straightforward [n^2] algorithm, a sorting-based would reduce it to
- [n log n]. Currently not tail-recursive.) *)
+ straightforward [n^2] algorithm. Currently not tail-recursive.) *)
val unique : ('a -> 'a -> bool) -> 'a list -> 'a list
+(** Check whether the list contains duplicates, using structural equality. *)
+val not_unique : 'a list -> bool
+
(** Take [n] elements of the given list, or less it the list does not
contain enough values. *)
val take_n : int -> 'a list -> 'a list
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2011-01-07 11:41:28 UTC (rev 1276)
+++ trunk/Toss/Formula/AuxTest.ml 2011-01-09 20:58:08 UTC (rev 1277)
@@ -198,13 +198,25 @@
["a1";"c2"; "b1"; "a3"; "c7"]);
);
- "unique, take_n" >::
+ "unique, unique_soted, not_unique, take_n" >::
(fun () ->
assert_equal ~printer:(String.concat "; ")
- ["a";"c";"b";"d"]
- (Aux.unique (=) ["a";"c";"b"; "d"; "c"]);
+ ~msg:"should remove duplicates"
+ ["a";"c";"e";"b";"d"]
+ (Aux.unique (=) ["a";"c";"e"; "b"; "d"; "e"; "c"; "e"]);
assert_equal ~printer:(String.concat "; ")
+ ~msg:"should remove duplicates"
+ ["a";"b";"c";"d";"e"]
+ (Aux.unique_sorted ["a";"c";"e"; "b"; "d"; "e"; "c"; "e"]);
+
+ assert_bool "not unique"
+ (Aux.not_unique ["a";"c";"b"; "d"; "c"]);
+
+ assert_bool "unique"
+ (not (Aux.not_unique ["a";"c";"b";"d"]));
+
+ assert_equal ~printer:(String.concat "; ")
["a";"c";"b"]
(Aux.take_n 3 ["a";"c";"b"; "d"; "c"]);
Modified: trunk/Toss/Play/GDL.ml
===================================================================
--- trunk/Toss/Play/GDL.ml 2011-01-07 11:41:28 UTC (rev 1276)
+++ trunk/Toss/Play/GDL.ml 2011-01-09 20:58:08 UTC (rev 1277)
@@ -1,10 +1,338 @@
(** {2 Game Description Language.}
- Type definitions, helper functions, game specification translation. *)
+ Type definitions, helper functions, game specification
+ translation.
+ The translation is not complete (yet), and not yet guaranteed to
+ be sound (but aiming at it) -- report any cases where the
+ algorithm does not fail explicitly but does not preserve
+ semantics.
+
+ (1) Aggregate playout: generate successive states as if all moves
+ legal in the previous state were performed. Do not check the
+ termination predicate.
+
+ (1a) Reason for unsoundness: "legal" or "next" preconditions can
+ depend negatively on state, preventing further moves in the
+ aggregate state that would be possible in some of valid game
+ states; the aggregate state does not have enough terms as a
+ result. Workaround: remove negative literals from "legal"/"next"
+ conditions for generating aggregate playout.
+
+ (1b) Saturation works on definitions stratified
+ w.r.t. negation. Positive literals are instantiated one by one,
+ then negative literals are checked over the facts derived from
+ previous strata. To avoid redundancy, new facts and new
+ instantiations are kept separate for the next iteration within a
+ stratum.
+
+ (1c) Heuristic reason for unsoundness: while we check for fixpoint
+ in the playout, we rule out state terms "F(X)" where X is a player
+ (assuming that "F" means "control"). Workaround: turn off fixpoint
+ checking [aggregate_fixpoint].
+
+ (2) Arena graph: currently, only a simple cycle is allowed. The
+ succession of players is determined from the aggregate playout.
+
+ (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
+ action in the corresponding state of an aggregate playout for the
+ player that is additionally constant.
+
+ (2b) We determine the player of a location by requiring that at
+ most one player has a non-noop action in an aggregate
+ state. When all players are noops we select the control player so
+ that the smallest "game cycle" is preserved. Otherwise (more than
+ one no-noop move) we fail (simultaneous moves not supported). We
+ remember the noop actions for each location and player.
+
+ (3) Currently, a constant number of elements is assumed. The rules
+ processed in (3a)-(3b) are already expanded by (6).
+
+ (3a) Element terms are collected from the aggregate playout: the
+ sum of state terms (the "control" function could be dropped but we
+ are not taking the effort to identify it).
+
+ (3b) Element masks are generated by generalization from all "next"
+ rules where the "does" relations are expanded by all unifying
+ "legal" rules (see also (7a)).
+
+ (3c) Generalization in a single expanded "next" rule is by finding
+ for the "next" term the closest "true" term in the lexicographic
+ ordering of (# of matched variables, # of other matched leaves),
+ but in case the closest term is found in the negative part, it is
+ further processed.
+
+ (3c1) Unmatched subterms are replaced by meta-variables.
+
+ (3c2) When the generalization comes from the negative part, we
+ replace all constant leaves with meta-variables. Warning: this
+ heuristic is a reason for unsoundness -- search for a workaround
+ once a real counterexample is encountered.
+
+ (3d) The masks are all the minimal w.r.t. matching (substitution)
+ of the generalized terms, with only meta-variable positions of the
+ mask matching meta-variable positions of a generalized
+ term.
+
+ (3e) The elements are the equivalence classes of element terms,
+ where terms are equivalent when they both match a single mask and
+ their matching substitutions differ only at
+ meta-variables. (I.e. for t1 and t2 there exists a mask m and
+ substitutions s1 and s2 such that s1(m)=t1 and s2(m)=t2 and
+ s1(x)=/=s2(x) implies that x is/contains a meta-variable.)
+
+ (Note that there is "nothing wrong" with a given equiv class not
+ having any member in the initial state or some other state. The
+ element is still there in the structure, still participating in
+ the "static" relations, but not in the "dynamic" predicates in
+ that particular state. We use a special _BLANK_ term/predicate to
+ faciliate operations on such "absent" elements.)
+
+ (4) Static relations (their tuples do not change during the game)
+ are derived from static facts with subterms common with element
+ terms but not below meta-variables.
+
+ Define mask-paths as the set of a mask together with a path in it
+ to a position that is not below (or at) a meta-variable.
+
+ Implementation: currently we approximate paths by only taking the
+ positions of variables in the mask.
+
+ (4a) (Fact relations.) For a static fact (a relation that does not
+ depend on "true" or "init") (unless it is expanded -- see (6)),
+ introduce a relation for each mask-paths tuple with arity of the
+ relation (i.e., introduced relations are a dependent product of
+ static fact relations and a cartesian n-th power of the mask-paths
+ set where n is the arity of the relation). An introduced relation
+ holds over a tuple of elements, iff the corresponding element
+ terms match the respective masks, and the original relation holds
+ over the tuple of subterms selected from the element terms by the
+ corresponding paths.
+
+ (Relations that do not hold for any tuple of element terms in the
+ whole aggregate playout can be removed.)
+
+ (4b) (Equality relations.) For each mask-path, introduce a binary
+ relation that holds over elements which have the same subterm at
+ the mask-path position. (Because of mask-paths definition, same
+ for all element terms in element's equivalence class.)
+
+ (4c) (Anchor predicates.) Collect all terms under "true" and
+ "next" predicates in the game definition. For each mask-path
+ pointing to a constant in some of the terms and that constant,
+ introduce a new predicate with semantics: "matches the mask and
+ has the constant at the path position".
+
+ (5) (Mostly) dynamic relations ("fluents": their tuples change
+ during the game), relations derived from all below-meta-variable
+ subterms of element terms, initialized by those that appear in the
+ initial state. (Some relations introduced in this step might not
+ be fluents.)
+
+ Collect all terms under "true" and "next" predicates in the game
+ definition. For each term, find the element mask it matches, and
+ introduce relations for each meta-variable of the element mask,
+ associated with the subterm that matches the meta-variable. The
+ semantic is that the relation selects the element terms that match
+ the mask with the associated subterm subsituted for the
+ corresponding meta-variable, with existential
+ interpretation. A relation holds initially over an element, if in
+ the initial set of element terms at least one from the element's
+ equivalence class is selected by the relation. An occurrence of
+ "true" or "next" relation is replaced by a conjunction of
+ relations whose substituted-masks match the relation's term.
+
+ When generating predicates that hold over an element term, no
+ predicate is generated for any its meta-variable position that
+ contains _BLANK_.
+
+ (6) Currently how to introduce defined relations in translation is
+ not yet solved in the presented framework. Currently, we simply
+ expand relations that are not static, or (optionally) are static
+ but do not contain ground facts, by duplicating the branch in
+ which body an atom of the relation occurs, for each branch of the
+ relation definition, unifying and applying the unifier. (If the
+ duplication turns out prohibitive, this will be a *huge* TODO for
+ this translation framework.)
+
+ (6a) The definition:
+
+ [(r, params1) <= body1 ... (r, params_n) <= body_n]
+
+ provides a DNF defining formula (using negation-as-failure):
+
+ [(r, args) <=> exist vars1 (args = params1 /\ body1) \/ ...
+ \/ exist vars_n (args = params_n /\ body_n)]
+
+ which expands in a natural way for positive occurrences. We
+ duplicate the branch where [(r, args)] is substitued for each
+ disjunct and apply the unifier of [args = params_i] in the whole
+ [i]th cloned branch. We freshen each [vars_i] to avoid capture. If
+ unification fails, we drop the corresponding branch clone.
+
+ (6b) For negative occurrences we transform the defining formula
+ to:
+
+ [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
+ 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
+ subformula inside a branch). We only apply the unifier of [args =
+ params_i] to [body_i] (in general, the whole negated
+ subformula). Still, we freshen each [vars_i] to avoid capture. If
+ unification fails, we drop the corresponding negated
+ subformula. If unification succeeds but the corresponding [body_i]
+ is empty (and, in general, no other disjuncts in the negated
+ subformula are left), we drop the branch.
+
+ (6b1) The general case is not implemented yet since it slightly
+ complicates the code, and expressivity gain is very small.
+
+ (7) Generation of rewrite rules when the dynamic relations are not
+ recursive and are expanded in the GDL definition.
+
+ (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 solely on the player in the location and in
+ the "legal" definition (currently, we do not allow simultaneous
+ moves). Consequently, we define rules on a per-player basis rather
+ than a per-location basis. If the branch of "legal" definition has
+ a variable for a player, it is instantiated for each player in the
+ game, and the variable substituted in the body of the "legal"
+ branch.
+
+ (7b) We collect all the branches of the "next" relation definition
+ for which the selected branch of "legal" unifies with all (usually
+ one, but we allow zero or more) occurrences of "does" with a
+ single unifier per "next" branch. Split the unifiers into
+ equivalence classes (w.r.t. substitution), each class will be a
+ different rewrite rule (or set of rules). Associate negation of
+ equalities specific to the unifiers strictly less general than the
+ equivalence class with it, so that the resulting conditions form a
+ partition of the space of substitutions for the "legal" branch
+ processed.
+
+ (7c) Find a single MGU that unifies the "legal" atom argument and
+ all the "does" atoms arguments into a single instance, and apply
+ it to all "next" branches of the rule. We remember all variables
+ in the "legal"/"does" instantiation as "fixed variables". We
+ replace all occurrences of "does" with the body of the selected
+ "legal" branch.
+
+ (7d) We seggregate "next" atoms into these that contain some fixed
+ variables or no variables at all, and other containing only
+ unfixed variables. Eliminate unfixed variables from "next"
+ atoms with fixed variables by enumerating their domains and
+ duplicating whole "next" branches with each instantiation. (They
+ will not have unfixed variables.)
+
+ (This perhaps could be done in a better way by better integrating
+ (7d) and (7e)...)
+
+ (7e) Branches with (only) unfixed variables in "next" atoms are
+ the "frame" branches. Check that each "frame" branch is an
+ identity: the "next" atom is equal to one of the positive "true"
+ atoms. If not, expand all variables (as they are unfixed)
+ duplicating that branch for each instantiation (the duplicated
+ branches become regular branches -- with constant "next"
+ atoms).
+
+ (7e1) Transform the remaining proper "frame" branches into
+ "erasure" branches: negate the body, push negation inside (using
+ de Morgan laws etc.), reduce to DNF and split into separate
+ "erasure" branch for each disjunct, place the original "next" atom
+ but with meta-variable positions replaced by _BLANK_ as the head
+ of the "erasure" branch, apply (and remove) unification atoms
+ resulting from negating the "distinct" relation.
+
+ (7f) 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
+ atoms "corresponding variable".)
+
+ (7g) Add an appropriate equality relation of (4b) for each case
+ of variable shared by terms corresponding to different element
+ variables (regardless if the element terms are in positive or
+ negative literals).
+
+ (7h) For all subterms of "next" and "true" atoms, identify the
+ 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 the result will be equivalent to a disjunction of
+ negations of generated atoms.)
+
+ (7i) 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.)
+
+ (7j) Now we build rewrite rules for a refinement of an equivalence
+ class of (7b): from the branches with unifiers in the equiv class,
+ from branches with unifiers more general than the equiv class, and
+ from the disjointness conditions (and the terminal condition, see
+ below). 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
+ consequent does not, but does not need to always say "yes"
+ otherwise. Build a rewrite rule for each equivalence class
+ w.r.t. subsumption, including also branches that are below the
+ equiv class, and including negation of conditions that make the
+ branches strictly above more specific -- so that the classes form
+ a partition of the nonterminal game states (it is semantically
+ necessary so that all applicable changes are applied in the
+ translated game when making a move).
+
+ (7k) Replace the "next" and "true" atoms by the conjunction of
+ (4c) and (5) predicates over their corresponding variable. (For
+ negative "true" literals this will be equivalent to a disjunction
+ of negations of the predicates.)
+
+ (7l) Include translated negation of the terminal condition.
+
+ 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).
+
+ (8) We use a single payoff matrix for all locations. Goal patterns
+ are expanded to regular goals by instantiating the value variable
+ by all values in its domain (for example, as gathered from the
+ aggregate playout), and expanding all atoms that contained value
+ variables (both static and dynamic) using (6); fail if a goal
+ value cannot be determined. The payoff formula is the sum of
+ "goal" value times the characterisic function of the "goal"
+ body. We do not translate the body if the value is zero (we drop
+ the zero goal branches from the definition). Translate the body
+ using (7f)-(7k), but treating "goal" branches separately -- when
+ (7i) duplicates a branch, new branches add new sum elements.
+
+*)
+
+let debug_level = ref 0
+let aggregate_drop_negative = ref false
+let aggregate_fixpoint = ref true
+(** Expand static relations that do not have ground facts and have
+ arity above the threshold. *)
+let expand_arity_above = ref 0
+
type term =
| Const of string
| Var of string
+ | MVar of string (* meta-variable, not used in GDL *)
| Func of string * term list
type atom =
@@ -16,18 +344,19 @@
type literal =
| Pos of atom
| Neg of atom
+ | Disj of literal list
type game_descr_entry =
| Datalog of string * term list * literal list
| Next of term * literal list
| Legal of term * term * literal list
| Goal of term * int * literal list
+ | GoalPattern of term * string * literal list
| Terminal of literal list
| Role of term
| Initial of term * literal list
| Atomic of string * term list
-
type request =
| Start of string * term * game_descr_entry list * int * int
(* prepare game: match id, role, game, startclock, playclock *)
@@ -36,11 +365,369 @@
| Stop of string * term list
(* game ends here: match id, actions on previous step *)
-let compile_game_descr entries = entries
+let rec term_str = function
+ | Const c -> c
+ | Var v -> "?"^v
+ | MVar v -> "@"^v
+ | Func (f, args) ->
+ "(" ^ f ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
+let rec term_to_name ?(nested=false) = function
+ | Const c -> c
+ | Var v -> v
+ | MVar v -> v
+ | Func (f, args) ->
+ f ^ "_" ^ (if nested then "_S_" else "") ^
+ String.concat "_" (List.map (term_to_name ~nested:true) args) ^
+ (if nested then "_Z_" else "")
+
+let fact_of_atom = function
+ | Distinct args -> assert false
+ | Rel (rel, args) -> rel, args
+ | Currently arg -> "true", [arg]
+ | Does (arg1, arg2) -> "does", [arg1; arg2]
+
+let rec body_of_literal = function
+ | Pos (Distinct args) ->
+ [Aux.Right ("distinct", args)] (* not negated actually! *)
+ | Neg (Distinct _) -> assert false
+ | Pos atom -> [Aux.Left (fact_of_atom atom)]
+ | Neg atom -> [Aux.Right (fact_of_atom atom)]
+ | Disj disjs ->
+ Aux.concat_map body_of_literal disjs
+
+let func_graph f terms =
+ Aux.map_some
+ (function Func (g, args) when f=g -> Some args | _ -> None) terms
+
+(* Type shortcuts (mostly for documentation). *)
+type gdl_atom = string * term list
+type gdl_rule = gdl_atom * gdl_atom list * gdl_atom list
+(* Definition with expanded definitions: expansion of a negated
+ relation brings negated conjunctions. *)
+type exp_def_branch =
+ term list * gdl_atom list * gdl_atom list list
+type exp_def =
+ string * exp_def_branch list
+
+let rules_of_entry = function
+ | Datalog (rel, args, body) ->
+ let head = rel, args in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Next (head, body) ->
+ let head = "next", [head] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Legal (arg1, arg2, body) ->
+ let head = "legal", [arg1; arg2] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Goal (arg, payoff, body) ->
+ let head = "goal", [arg; Const (string_of_int payoff)] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | GoalPattern (arg, var, body) ->
+ let head = "goal", [arg; Var var] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Terminal body ->
+ let head = "terminal", [] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Role arg -> [("role", [arg]), [], []]
+ | Initial (arg, body) ->
+ let head = "init", [arg] in
+ let bodies = Aux.product (List.map body_of_literal body) in
+ List.map (fun body ->
+ let pos_body, neg_body = Aux.partition_choice body in
+ head, pos_body, neg_body) bodies
+ | Atomic (rel, args) -> [(rel, args), [], []]
+
+let defs_of_rules rules : (string * exp_def_branch list) list =
+ Aux.map_reduce
+ (fun ((drel, params), body, neg_body) ->
+ drel,(params, body, List.map (fun a->[a]) 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) =
+ 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
+ (rel, args), body, neg_body) 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) =
+ match
+ List.partition (fun (_, branches) ->
+ List.for_all (fun (_, body, neg_body) ->
+ List.for_all (fun (rel1,_) ->
+ rel1 = "distinct" || rel1 = "true" || rel1 = "does" ||
+ not (List.mem_assoc rel1 defs))
+ (if def then body @ List.concat neg_body
+ else List.concat neg_body)) branches) defs
+ with
+ | [], [] -> List.rev strata
+ | stratum, [] -> List.rev (stratum::strata)
+ | [], _ ->
+ if def then raise
+ (Lexer.Parsing_error
+ "GDL.stratify: recursive non-static definitions not handled yet")
+ else raise
+ (Lexer.Parsing_error
+ "GDL.stratify: cyclic negation dependency")
+ | stratum, rules -> stratify (stratum::strata) rules
+
+
+let rec vars ?(meta=false) = function
+ | Const _ -> []
+ | Var x -> [x]
+ | MVar x -> if meta then [x] else []
+ | Func (_, args) -> Aux.concat_map vars args
+
+let rec subst_one (x, term as sb) = function
+ | Var y when x=y -> term
+ | MVar y when x=y -> term
+ | (Const _ | Var _ | MVar _ as t) -> t
+ | Func (f, args) ->
+ Func (f, List.map (subst_one sb) args)
+
+let rec unify sb terms1 terms2 =
+ match terms1, terms2 with
+ | [], [] -> sb
+ | Const a::terms1, Const b::terms2 when a=b ->
+ unify sb terms1 terms2
+ | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
+ unify sb (args1 @ terms1) (args2 @ terms2)
+ | Var x::terms1, Var y::terms2 when x=y ->
+ unify sb terms1 terms2
+ | (Var x::terms1, (Var _ | Const _ as term)::terms2
+ | (Const _ as term)::terms1, Var x::terms2) ->
+ let sb1 = x, term in
+ unify (sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb)
+ (List.map (subst_one sb1) terms1)
+ (List.map (subst_one sb1) terms2)
+ | (Var x::_, term::_ | term::_, Var x::_)
+ when List.mem x (vars term) ->
+ raise Not_found
+ | Var x::terms1, term::terms2 | term::terms1, Var x::terms2 ->
+ let sb1 = x, term in
+ unify (sb1::List.map (fun (x,t)->x, subst_one sb1 t) sb)
+ (List.map (subst_one sb1) terms1)
+ (List.map (subst_one sb1) terms2)
+ | _ -> raise Not_found
+
+(* 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 =
+ match terms1, terms2 with
+ | [], [] -> sb, m_sb
+ | (Const a | Var a)::terms1, (Const b | Var b)::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 ->
+ (* we don't substitute because metavariables are linear *)
+ match_meta sb ((x, term)::m_sb) terms1 terms2
+ | MVar _::_, _ -> raise Not_found
+ | term::terms1, Var x::terms2 ->
+ let sb1 = x, term in
+ let sb =
+ if List.mem_assoc x sb then
+ if List.assoc x sb = term then sb
+ else raise Not_found
+ else sb1::sb in
+ match_meta sb m_sb terms1 terms2
+ | _ -> raise Not_found
+
+
+(* 3c1 *)
+let generalize term1 term2 =
+ let fresh_count = ref 0 in
+ let rec loop pf terms1 terms2 =
+ match terms1, terms2 with
+ | [], [] -> (0, 0), []
+ | (Const a as cst)::terms1, Const b::terms2 when a=b ->
+ let (good_vars, good_csts), gens = loop pf terms1 terms2 in
+ (good_vars, good_csts+1), cst::gens
+ | Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
+ let (good_vars1, good_csts1), gen_args = loop f args1 args2 in
+ let (good_vars2, good_csts2), gens = loop pf terms1 terms2 in
+ (good_vars1+good_vars2, good_csts1+good_csts2),
+ (Func (f,gen_args))::gens
+ | (Var x as var)::terms1, Var y::terms2 when x=y ->
+ let (good_vars, good_csts), gens = loop pf terms1 terms2 in
+ (good_vars+1, good_csts), var::gens
+ | _::terms1, _::terms2 ->
+ let measure, gens = loop pf terms1 terms2 in
+ incr fresh_count;
+ measure, MVar ("MV"^string_of_int !fresh_count)::gens
+ | _::_, [] | [], _::_ -> raise
+ (Lexer.Parsing_error
+ ("GDL.generalize: arity mismatch at function "^pf)) in
+ let measure, gens = loop "impossible" [term1] [term2] in
+ measure, !fresh_count, List.hd gens
+
+(* 3c2 *)
+let abstract_consts fresh_count term =
+ let fresh_count = ref fresh_count in
+ let rec loop = function
+ | Const _ -> incr fresh_count; MVar ("MV"^string_of_int !fresh_count)
+ | Func (f,args) -> Func (f, List.map loop args)
+ | term -> term in
+ loop term
+
+let rec subst sb = function
+ | Var y as t ->
+ (try List.assoc y sb with Not_found -> t)
+ | MVar y as t ->
+ (try List.assoc y sb with Not_found -> t)
+ | Const _ as t -> t
+ | 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 subst_rel sb (rel, args) = rel, List.map (subst sb) args
+let subst_rels sb body = List.map (subst_rel sb) body
+let compose_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb
+
+let fact_str (rel, args) =
+ "("^rel^" "^String.concat " " (List.map term_str args) ^")"
+
+let tuples_str tups =
+ let tup_str tup =
+ "("^String.concat " " (List.map term_str tup) ^")" in
+ String.concat " " (List.map tup_str tups)
+
+let facts_str facts =
+ String.concat " " (List.map fact_str facts)
+
+let def_str (rel, branches) =
+ let neg_facts_str negs =
+ String.concat " "
+ (List.map (fun d -> "(not (and "^facts_str d^"))") negs) in
+ String.concat "\n" (List.map (fun (args, body, neg_body) ->
+ "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
+ " " ^ neg_facts_str neg_body ^ ")"
+ ) branches)
+
+let sb_str sb =
+ String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
+
+(* 1b *)
+
+(* TODO: optimize by using rel-indexing (also in [aggregate_playout]).
+ TODO: optimize by using constant-time append data structure. *)
+let saturate base rules =
+
+ let instantiate_one tot_base cur_base irules =
+ Aux.concat_map (function
+ | head, [], neg_body ->
+ if List.mem head tot_base then []
+ else if List.exists (fun (rel,args as neg_atom) ->
+ rel = "distinct" && Aux.not_unique args ||
+ List.mem neg_atom tot_base) neg_body then []
+ else [Aux.Left head]
+ | head, cond1::body, neg_body ->
+ Aux.map_try (fun fact ->
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "instantiate_one: trying to unify %s and %s\n%!"
+ (fact_str fact) (fact_str cond1)
+ );
+ (* }}} *)
+ let sb = unify_rels fact cond1 in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "instantiate_one: succeeded with %s\n%!"
+ (sb_str sb)
+ );
+ (* }}} *)
+ let irule =
+ subst_rel sb head,
+ subst_rels sb body, subst_rels sb neg_body in
+ Aux.Right irule
+ ) cur_base) irules in
+
+ let rec inst_stratum old_base old_irules cur_base cur_irules =
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "inst_stratum: old_base = %s; cur_base = %s\n%!"
+ (facts_str old_base) (facts_str cur_base);
+ Printf.printf
+ "inst_stratum: #old_irules = %d, #cur_irules = %d\n%!"
+ (List.length old_irules) (List.length cur_irules)
+ );
+ (* }}} *)
+ let base = Aux.unique_sorted (cur_base @ old_base)
+ and irules = Aux.unique_sorted (cur_irules @ old_irules) in
+ let new_base1, new_irules1 =
+ Aux.partition_choice (instantiate_one base cur_base cur_irules) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "inst_stratum: cur-cur = %s\n%!"
+ (facts_str new_base1)
+ );
+ (* }}} *)
+ let new_base2, new_irules2 =
+ Aux.partition_choice (instantiate_one base cur_base old_irules) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "inst_stratum: cur-old = %s\n%!"
+ (facts_str new_base2)
+ );
+ (* }}} *)
+ let new_base3, new_irules3 =
+ Aux.partition_choice (instantiate_one base old_base cur_irules) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "inst_stratum: old-cur = %s\n%!"
+ (facts_str new_base3)
+ );
+ (* }}} *)
+ let new_base = Aux.unique_sorted (new_base1 @ new_base2 @ new_base3)
+ and new_irules = Aux.unique_sorted
+ (new_irules1 @ new_irules2 @ new_irules3) in
+ let new_base =
+ List.filter (fun f->not (List.mem f base)) new_base in
+ let new_irules =
+ List.filter (fun f->not (List.mem f irules)) new_irules in
+ if new_base = [] && new_irules = []
+ then base
+ else inst_stratum base irules new_base new_irules in
+
+ let rec instantiate base = function
+ | [] -> base
+ | stratum::strata ->
+ instantiate (inst_stratum [] [] base stratum) strata in
+
+ instantiate base
+ (List.map rules_of_defs (stratify [] (defs_of_rules rules)))
+
+
let playing_as = ref (Const "uninitialized")
let game_description = ref []
-let player_name_terms = ref [| |]
+let player_terms = ref [| |]
let state_of_file s =
Printf.printf "GDL: Loading file %s...\n%!" s;
@@ -51,99 +738,603 @@
Printf.printf "GDL: File %s loaded.\n%!" s;
res
-let initialize_game_gomoku state player game_descr startcl =
- state := state_of_file "./examples/Gomoku.toss";
- playing_as := player;
- game_description := game_descr;
- player_name_terms := [|Const "X"; Const "O"|];
- let effort, horizon, heur_adv_ratio =
- 2, 100, 4.0 in
- effort, horizon, heur_adv_ratio
+(* 6 *)
-let initialize_game_breakthrough state player game_descr startcl =
- state := state_of_file "./examples/Breakthrough.toss";
+(* TODO: do proper elegant renaming... *)
+let freshen_def_branches =
+ let fresh_count = ref 0 in
+ let map_branch (args, body, neg_body) =
+ incr fresh_count;
+ let rec map_vnames = function
+ | Var x -> Var (x^string_of_int !fresh_count)
+ | MVar x -> MVar (x^string_of_int !fresh_count)
+ | 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
+ List.map map_vnames args,
+ List.map map_rel body,
+ List.map (List.map map_rel) neg_body in
+ List.map map_branch
+
+(* assumption: [defs] bodies are already clean of defined relations *)
+let subst_def_branch (defs : exp_def list)
+ (head, body, neg_body : exp_def_branch) : exp_def_branch list =
+ (* 6a *)
+ let sols =
+ List.fold_left (fun sols (rel, args as atom) ->
+ (let try def =
+ freshen_def_branches (List.assoc rel defs) in
+ Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ Aux.map_some (fun (dparams, dbody, dneg_body) ->
+ try
+ let sb1 = unify [] dparams args in
+ Some (
+ subst_rels sb1 (dbody @ pos_sol),
+ List.map (subst_rels sb1) (dneg_body @ neg_sol),
+ compose_sb sb1 sb)
+ with Not_found -> None
+ ) def
+ ) sols
+ with Not_found ->
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ subst_rel sb atom::pos_sol, neg_sol, sb) sols))
+ ([[],[],[]]) body in
+ (* 6b *)
+ let sols =
+ List.fold_left (fun sols -> function [rel, args as atom] ->
+ (let try def =
+ freshen_def_branches (List.assoc rel defs) in
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ let more_neg =
+ Aux.map_some (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);
+ try
+ let sb1 = unify [] dparams args in
+ Some (subst_rels sb1 dbody)
+ with Not_found -> None
+ ) def in
+ pos_sol, more_neg @ neg_sol, sb
+ ) sols
+ with Not_found ->
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ pos_sol, [subst_rel sb atom]::neg_sol, sb) sols)
+ | _ -> failwith
+ "GDL.subst_def_branch: unimplemented, see (6b1) of spec")
+ sols neg_body in
+ Aux.map_some (fun (pos_sol, neg_sol, sb) ->
+ if List.mem [] neg_sol then None
+ else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols
+
+(* Stratify and expand all relations in the given set. *)
+let expand_def_rules ?(more_defs=[]) rules =
+ let rec loop base = function
+ | [] -> base
+ | stratum::strata ->
+ let step = List.map (fun (rel, branches) ->
+ rel, Aux.concat_map
+ (subst_def_branch (more_defs@base)) branches) stratum in
+ loop (base @ step) strata in
+ match stratify ~def:true [] (defs_of_rules rules) with
+ | [] -> []
+ | [no_defined_rels] ->
+ if more_defs = [] then no_defined_rels
+ else List.map (fun (rel, branches) ->
+ rel, Aux.concat_map (subst_def_branch more_defs) branches)
+ no_defined_rels
+ | def_base::def_strata -> loop def_base def_strata
+
+
+(* As [subst_def_branch], but specifically for "legal" definition and
+ result structured by "legal" definition branches. *)
+ (*
+let subst_legal_rule (legal_defs : exp_def_branch list)
+ (head, body, neg_body : exp_def_branch) : exp_def_branch list =
+ (* 6a *)
+ let sols =
+ List.fold_left (fun sols (rel, args as atom) ->
+ (let try def =
+ freshen_def_branches (List.assoc rel defs) in
+ Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ Aux.map_some (fun (dparams, dbody, dneg_body) ->
+ try
+ let sb1 = unify [] dparams args in
+ Some (
+ subst_rels sb1 (dbody @ pos_sol),
+ List.map (subst_rels sb1) (dneg_body @ neg_sol),
+ compose_sb sb1 sb)
+ with Not_found -> None
+ ) def
+ ) sols
+ with Not_found ->
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ subst_rel sb atom::pos_sol, neg_sol, sb) sols))
+ ([[],[],[]]) body in
+ (* 6b *)
+ let sols =
+ List.fold_left (fun sols -> function [rel, args as atom] ->
+ (let try def =
+ freshen_def_branches (List.assoc rel defs) in
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ let more_neg =
+ Aux.map_some (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);
+ try
+ let sb1 = unify [] dparams args in
+ Some (subst_rels sb1 dbody)
+ with Not_found -> None
+ ) def in
+ pos_sol, more_neg @ neg_sol, sb
+ ) sols
+ with Not_found ->
+ List.map (fun (pos_sol, neg_sol, sb) ->
+ pos_sol, [subst_rel sb atom]::neg_sol, sb) sols)
+ | _ -> failwith
+ "GDL.subst_def_branch: unimplemented, see (6b1) of spec")
+ sols neg_body in
+ Aux.map_some (fun (pos_sol, neg_sol, sb) ->
+ if List.mem [] neg_sol then None
+ else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols
+ *)
+(* 1 *)
+
+(* Collect the aggregate playout, but also the actions available in
+ the state. *)
+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
+ 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)
+ does) players
+ then raise Not_found
+ else
+ let step = saturate (does @ base) rules in
+ let step = Aux.map_some (function ("next", [arg]) -> Some arg
+ | _ -> None) step in
+ if !aggregate_fixpoint && (* fixpoint reached *)
+ List.for_all (function
+ | Func (_,[arg]) when
+ Aux.array_existsi (fun _ player -> arg=player) players -> true
+ | term -> List.mem term current
+ ) step
+ then raise Not_found
+ else
+ List.map snd does, step
+
+(* Besides the aggregate playout, also return the separation of rules
+ into static and dynamic. Note that the list of playout states is
+ one longer than that of playout actions. *)
+let aggregate_playout players horizon rules =
+ (* separate and precompute the static part *)
+ let rec separate static_rels state_rels =
+ let static, more_state =
+ List.partition (fun rel ->
+ List.for_all (fun ((rule,_), body, neg_body) ->
+ rule <> rel || List.for_all (fun srel ->
+ not (List.mem_assoc srel (neg_body @ body))) state_rels)
+ rules) static_rels in
+ if more_state = [] then static_rels, state_rels
+ else separate static (more_state @ state_rels) in
+ let static_rels, state_rels =
+ separate (List.map (fun ((r,_),_,_)->r) rules)
+ ["init"; "does"; "true"; "next"; "terminal"; "goal"] in
+ let static_rules, dynamic_rules = List.partition
+ (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
+ let rec loop actions_accu state_accu step state =
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "aggregate_playout: step %d...\n%!" step
+ );
+ (* }}} *)
+ (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 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 ->
+ 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
+ let init_state =
+ Aux.map_some (function ("init", [arg]) -> Some arg
+ | _ -> None) init_base in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "aggregate_playout: init %s\n%!"
+ (String.concat " " (List.map term_str init_state))
+ );
+ (* }}} *)
+ static_rules, dynamic_rules, static_base, loop [] [] 0 init_state
+
+
+let find_cycle cands =
+ let rec loop cycle trav pref rem path =
+ if cycle = [] then
+ let ini = [List.hd path] in
+ loop ini ini ini [] (List.tl path)
+ else match path, rem with
+ | _, [] -> loop cycle trav [] cycle path
+ | [], _ -> cycle (* consumed the whole path *)
+ | x::tail, y::rem when x=y || x = None->
+ (* either elements agree or indifferent path element *)
+ loop cycle (x::trav) (y::pref) rem tail
+ | x::tail, None::rem ->
+ (* instantiating undecided cycle element *)
+ loop (List.rev pref @ [x] @ rem) (x::trav) (x::pref) rem tail
+ | x::tail, _::_ ->
+ (* mismatch: grow the cycle to current point *)
+ let trav = x::trav in
+ let cycle = List.rev trav in
+ loop cycle trav [] cycle tail in
+ loop [] [] [] [] cands
+
+
+let translate_game game_descr =
+ let player_terms =
+ Array.of_list
+ (Aux.map_some (function Role p -> Some p | _ -> None) game_descr) in
+ let rules = Aux.concat_map rules_of_entry game_descr in
+ let static_rules, dynamic_rules, static_base, (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
+ let noop_cands = List.map (fun actions ->
+ let actions = Aux.map_reduce
+ (function [player; action] -> player, action
+ | _ -> assert false) (fun y x->x::y) [] actions in
+ (* 2a *)
+ List.map (function
+ | player, [Const _ as noop] -> player, Some noop
+ | player, _ -> player, None) actions) agg_actions in
+ let control_cands = List.map (fun noop_cands ->
+ List.fold_left (fun accu -> function
+ | player, None ->
+ if accu = None then Some player
+ else raise
+ (Lexer.Parsing_error
+ ("GDL.initialize_game: branching arena graphs"^
+ " or simultaneous moves not supported yet"))
+ | _, Some _ -> accu) None noop_cands) noop_cands in
+ (* 2b *)
+ let cycle = find_cycle control_cands in
+ (* {{{ log entry *)
+ if !debug_level > 0 then (
+ Printf.printf "translate_game: location players %s\n%!"
+ (String.concat " "
+ (List.map (function Some t->term_str t | None->"None") cycle))
+ );
+ (* }}} *)
+ (* 6 *)
+ let static_rules, exp_static_rules =
+ List.partition (fun ((rel,args), _, _) ->
+ List.length args <= !expand_arity_above ||
+ List.exists (function ((r,_),[],[]) when rel=r-> true
+ | _ -> 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 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))
+ );
+ (* }}} *)
+ (* 3 *)
+ let legal_rules = List.assoc "legal" exp_defs in
+ let next_rules = List.assoc "next" exp_defs in
+ (* 3b *)
+ let exp_next =
+ Aux.concat_map (subst_def_branch ["does", 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))
+ );
+ (* }}} *)
+ (* 3c *)
+ let masks = List.map (function
+ | [next_arg], body, neg_body ->
+ let collect = Aux.map_some
+ (function "true", [arg] -> Some arg
+ | "true", _ -> raise
+ (Lexer.Parsing_error
+ ("GDL.initialize_game: invalid arity of \"true\" atom"))
+ | _ -> None) in
+ let pos_cands = collect body in
+ let neg_cands = Aux.concat_map collect neg_body in
+ let pos_gens = List.map (generalize next_arg) pos_cands in
+ let neg_gens = List.map (generalize next_arg) neg_cands in
+ (* using the fact that Pervasives.compare is lexicographic *)
+ let pos_gen = List.fold_left max ((-1,0),0,Const "") pos_gens in
+ let neg_gen = List.fold_left max ((-1,0),0,Const "") neg_gens in
+ let (_, fresh_count, mask as gen) = max pos_gen neg_gen in
+ if gen == pos_gen then mask
+ else abstract_consts fresh_count mask
+ | _ -> raise
+ (Lexer.Parsing_error
+ ("GDL.initialize_game: invalid arity of \"next\" atom")))
+ exp_next in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "translate_game: Generalized element terms (mask candidates):\n%s\n%!"
+ (String.concat " " (List.map term_str masks))
+ );
+ (* }}} *)
+ let cmp_masks t1 t2 =
+ Printf.printf "cmp_masks: %s <= %s .. " (term_str t1) (term_str t2);
+ try ignore (match_meta [] [] [t1] [t2]); Printf.printf "true\n%!"; true
+ with Not_found -> Printf.printf "false\n%!"; false in
+ let masks = Aux.maximal cmp_masks masks in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "translate_game: Masks:\n%s\n%!"
+ (String.concat " " (List.map term_str masks))
+ );
+ (* }}} *)
+ (* 3e *)
+ let elements = List.fold_left (fun elements term ->
+ let mask, sb, m_sb =
+ match
+ Aux.map_try (fun mask ->
+ mask, match_meta [] [] [term] [mask]) masks
+ with [mask, (sb, m_sb)] -> mask, sb, m_sb
+ | _ -> assert false in (* masks are minimal *)
+ let sbs, elements =
+ try Aux.pop_assoc mask elements
+ with Not_found -> [], elements in
+ (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) ->
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "mask-elements:";
+ );
+ (* }}} *)
+ let struc, m_elements =
+ List.fold_left (fun (struc, m_elements) sb ->
+ let e_term = subst sb mask in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf ", %s%!" (term_to_name e_term)
+ );
+ (* }}} *)
+ let struc, elem =
+ Structure.add_new_elem struc ~name:(term_to_name e_term) () in
+ struc, (sb, elem)::m_elements
+ ) (struc, []) sbs in
+ (* {{{ log entry *)
+ if !debug_level > 2 then (
+ Printf.printf "\n%!";
+ );
+ (* }}} *)
+ struc, (mask, m_elements)::elements
+ ) (struc, []) elements in
+ (* 4 *)
+ (* currently, position paths are approximated by variables
+ (non-variable positions are ignored) *)
+ let mask_paths = Aux.concat_map (function _, [] -> assert false
+ | mask, (sb,_)::_ -> List.map (fun (v,_)->mask, v) sb) elements in
+ (* 4a *)
+ (* TODO: move generation of static rels graphs to the end and
+ filter to only generate used relations *)
+ let static_rels =
+ Aux.unique_sorted
+ (List.map (fun ((rname,args),_,_) ->
+ rname, List.map (fun _ -> ()) args) static_rules) in
+ let static_rels =
+ List.map (fun (rel,args) ->
+ rel,
+ Aux.all_tuples_for args mask_paths) static_rels in
+ let static_base =
+ Aux.map_reduce (fun x->x) (fun x y->y::x) [] static_base in
+ (* TODO: optimize by indexing elements by path position
+ terms (currently, substitution values) *)
+ let struc = List.fold_left (fun struc (brel, 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 "__"
+ (List.map (fun (mask,v)->
+ term_to_name mask ^ "_" ^ v) ptup) in
+ let struc =
+ Structure.add_rel_name rname (List.length ptup) struc in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "static-rel: %s, of... %!" rname;
+ );
+ (* }}} *)
+ let elem_sets =
+ List.map (fun (mask,v)->
+ List.map (fun (sb,elem)->
+ try List.assoc v sb, elem
+ with Not_found -> assert false)
+ (List.assoc mask elements)) ptup in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%s ... %!" (String.concat "x" (
+ List.map (fun x-> string_of_int (List.length x)) elem_sets));
+ );
+ (* }}} *)
+ let elem_tups =
+ Aux.concat_map (fun ttup ->
+ let elem_sets = List.map2 (fun term elems ->
+ Aux.map_some (fun (tcand, e) ->
+ if tcand=term then Some e else None) elems
+ ) ttup elem_sets in
+ List.map Array.of_list (Aux.product elem_sets)
+ ) brel_tups in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups);
+ );
+ (* }}} *)
+ let res = Structure.unsafe_add_rels struc rname elem_tups in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf " done\n%!";
+ );
+ (* }}} *)
+ res
+ ) struc path_tups) struc static_rels in
+ (* 4b *)
+ let struc = List.fold_left (fun struc (mask,v) ->
+ let rname = "EQ___" ^ term_to_name mask ^ "_" ^ v in
+ let struc =
+ 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) ->
+ List.fold_left (fun tups (sb2, e2) ->
+ try
+ if List.assoc v sb1 = List.assoc v sb2
+ then [|e1; e2|]::[|e2; e1|]::tups
+ else tups
+ with Not_found -> assert false
+ ) tups elems
+ ) [] elems in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf "%d tuples, adding to struc...%!" (List.length elem_tups);
+ );
+ (* }}} *)
+ let res = Structure.unsafe_add_rels struc rname elem_tups in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf " done\n%!";
+ );
+ (* }}} *)
+ res
+ ) struc mask_paths in
+ (* 4c: TODO -- see laziness TODO 4 *)
+
+ (* 5: TODO *)
+
+ (* 7a *)
+ let legal_rules =
+ Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule]
+ | [Var v; lterm], body, neg_body ->
+ Array.to_list
+ (Array.map (fun player -> [player; lterm], body, neg_body)
+ player_terms)
+ | [Func _; lterm], _, _ ->
+ (* TODO: easy to fix *)
+ failwith "GDL.translate_game: bigger player terms not handled yet"
+ | _ -> assert false) legal_rules in
+ (* indexed by players, then "legal" branches, then by MGUs for
+ unifier equivalence classes *)
+ (*
+ let player_next =
+ Aux.map_reduce (fun ()) in
+ *)
+ struc
+
+(*
+ let paths = collect_paths element_terms in
+ let static_facts =
+ Array.of_list
+ (Aux.map_some (function Atomic p -> Some p | _ -> None) game_descr) in
+ let element_names = List.map term_to_name element_terms in
+
+ let struc = List.fold_left (fun acc name ->
+ fst (Structure.add_new_elem acc ~name ()))
+ Structure.empty_structure element_names in
+ *)
+
+let initialize_game state player game_descr startcl =
playing_as := player;
- game_description := game_descr;
- player_name_terms := [|Const "WHITE"; Const "BLACK"|];
- let effort, horizon, heur_adv_ratio =
- 3, 100, 2.0 in
- effort, horizon, heur_adv_ratio
+ let struc = translate_game game_descr in
+ ignore struc;
+ (* state := Arena.process_definition ~extend_state:(!state) defs; *)
+ 2, 100, 2.0
-let initialize_game =
- initialize_game_breakthrough
-
-let translate_last_action_gomoku actions =
- let number_of_letter c =
- string_of_int ((Char.code (Char.lowercase c)) - 96) in
+
+let translate_last_action actions =
match actions with
| [] ->
(* start of game -- Server will handle this answer as NOOP *)
"", []
| [Func ("MARK", [Const col; Const row]); Const "NOOP"] ->
- "Cross", ["a1", ((String.lowercase col) ^ (number_of_letter row.[0]))]
+ "Cross", ["...
[truncated message content] |
|
From: <luk...@us...> - 2011-01-07 11:41:34
|
Revision: 1276
http://toss.svn.sourceforge.net/toss/?rev=1276&view=rev
Author: lukaszkaiser
Date: 2011-01-07 11:41:28 +0000 (Fri, 07 Jan 2011)
Log Message:
-----------
Corrections
Modified Paths:
--------------
trunk/Toss/README
trunk/Toss/Toss.py
trunk/Toss/WebClient/README
trunk/Toss/examples/Tic-Tac-Toe.toss
Modified: trunk/Toss/README
===================================================================
--- trunk/Toss/README 2011-01-05 14:24:57 UTC (rev 1275)
+++ trunk/Toss/README 2011-01-07 11:41:28 UTC (rev 1276)
@@ -11,7 +11,7 @@
-- Installing dependencies under Ubuntu
Run the following in terminal:
- sudo apt-get install python-qt4 python-dev pyqt4-dev-tools ocaml-findlib menhir libounit-ocaml-dev
+ sudo apt-get install g++ python-qt4 python-dev pyqt4-dev-tools ocaml-findlib menhir libounit-ocaml-dev
Finally to compile Toss just type
make
Modified: trunk/Toss/Toss.py
===================================================================
--- trunk/Toss/Toss.py 2011-01-05 14:24:57 UTC (rev 1275)
+++ trunk/Toss/Toss.py 2011-01-07 11:41:28 UTC (rev 1276)
@@ -4,7 +4,6 @@
import os
import subprocess
import socket
-import socket
from PyQt4.QtGui import QApplication
# QtGui Ref: www.riverbankcomputing.co.uk/static/Docs/PyQt4/html/qtgui.html
Modified: trunk/Toss/WebClient/README
===================================================================
--- trunk/Toss/WebClient/README 2011-01-05 14:24:57 UTC (rev 1275)
+++ trunk/Toss/WebClient/README 2011-01-07 11:41:28 UTC (rev 1276)
@@ -3,8 +3,8 @@
Connection with Server goes through a python wrapper and it uses sqlite, so do:
sudo apt-get install libapache2-mod-python sqlite3 python-pysqlite2
to run the wrapper. Make sure apache works (you may need to edit the file
-/etc/apache2/apache2.conf and set ServerRoot to e.g. /var/www/) and then
-in the file /etc/apache2/sites-enabled/[your-site] add e.g.
+/etc/apache2/apache2.conf and uncoment ServerRoot to e.g. /etc/apache2) and
+then in the file /etc/apache2/sites-enabled/[your-site] add e.g.
<Directory /var/www/WebClient>
AddHandler mod_python .py
PythonHandler Handler
Modified: trunk/Toss/examples/Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-05 14:24:57 UTC (rev 1275)
+++ trunk/Toss/examples/Tic-Tac-Toe.toss 2011-01-07 11:41:28 UTC (rev 1276)
@@ -1,5 +1,5 @@
PLAYERS 1, 2
-DATA r1: circle, r2: line, adv_ratio: 4, depth: 3
+DATA r1: circle, r2: line, adv_ratio: 4, depth: 4
REL DiagA (x, y) = ex u (R(x, u) and C(u, y))
REL DiagB (x, y) = ex u (R(x, u) and C(y, u))
REL Row3 (x, y, z) = R(x, y) and R(y, z)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-05 14:25:03
|
Revision: 1275
http://toss.svn.sourceforge.net/toss/?rev=1275&view=rev
Author: lukaszkaiser
Date: 2011-01-05 14:24:57 +0000 (Wed, 05 Jan 2011)
Log Message:
-----------
Just a test.
Modified Paths:
--------------
trunk/Toss/Toss.py
Modified: trunk/Toss/Toss.py
===================================================================
--- trunk/Toss/Toss.py 2011-01-05 00:52:39 UTC (rev 1274)
+++ trunk/Toss/Toss.py 2011-01-05 14:24:57 UTC (rev 1275)
@@ -4,6 +4,7 @@
import os
import subprocess
import socket
+import socket
from PyQt4.QtGui import QApplication
# QtGui Ref: www.riverbankcomputing.co.uk/static/Docs/PyQt4/html/qtgui.html
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-01-05 00:52:46
|
Revision: 1274
http://toss.svn.sourceforge.net/toss/?rev=1274&view=rev
Author: lukaszkaiser
Date: 2011-01-05 00:52:39 +0000 (Wed, 05 Jan 2011)
Log Message:
-----------
Correcting checkers, adding pure chess pawn progress game.
Modified Paths:
--------------
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/index.html
trunk/Toss/examples/Checkers.toss
Added Paths:
-----------
trunk/Toss/examples/Pawns.toss
trunk/Toss/examples/Pawns.tossstyle
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2010-12-30 22:58:00 UTC (rev 1273)
+++ trunk/Toss/WebClient/Main.js 2011-01-05 00:52:39 UTC (rev 1274)
@@ -238,7 +238,7 @@
var li = new_play_item (GAME_NAME, CUR_PLAY_I);
old_li.parentNode.replaceChild (li, old_li);
if (PLAYS[CUR_PLAY_I][(m + 1) % 2] == "computer") {
- var m = suggest_move ();
+ var m = suggest_move_better ();
if (m != "") { make_move (); }
}
}
@@ -390,4 +390,4 @@
"Hide Move Suggestions";
document.getElementById("player-info-par").style.display = "block";
}
-}
\ No newline at end of file
+}
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2010-12-30 22:58:00 UTC (rev 1273)
+++ trunk/Toss/WebClient/index.html 2011-01-05 00:52:39 UTC (rev 1274)
@@ -104,7 +104,7 @@
<p class="game-par">
<button class="bt" onclick="new_play ('Checkers')">New Game</button>
<a class="game_list"
- href="http://en.wikipedia.org/wiki/Checkers">Checkers</a>
+ href="http://en.wikipedia.org/wiki/English_draughts">Checkers</a>
</p>
<ul class="plays-list" id="plays-list-Checkers"></ul>
<p class="game-par">
Modified: trunk/Toss/examples/Checkers.toss
===================================================================
--- trunk/Toss/examples/Checkers.toss 2010-12-30 22:58:00 UTC (rev 1273)
+++ trunk/Toss/examples/Checkers.toss 2011-01-05 00:52:39 UTC (rev 1274)
@@ -8,30 +8,17 @@
REL DiagBa (x, y) = ex z (C(z, x) and R(z, y))
REL DiagWb (x, y) = ex z (C(x, z) and R(z, y))
REL DiagBb (x, y) = ex z (C(z, x) and R(y, z))
+REL AnyDiag (x, y) =
+ DiagWa (x, y) or DiagWb (x, y) or DiagBa (x, y) or DiagBb (x, y)
REL DiagW2 (x, y, z) =
(DiagWa (x, y) and DiagWa (y, z)) or (DiagWb (x, y) and DiagWb (y, z))
REL DiagB2 (x, y, z) =
(DiagBa (x, y) and DiagBa (y, z)) or (DiagBb (x, y) and DiagBb (y, z))
REL Diag2 (x, y, z) = DiagW2 (x, y, z) or DiagB2 (x, y, z)
-REL BeatsW (x, y) = ex z (b(z) and not b(y) and not w(y) and Diag2 (x, z, y))
-REL BeatsB (x, y) = ex z (w(z) and not b(y) and not w(y) and Diag2 (x, z, y))
-REL Da (x, y) = DiagWa (x, y) or DiagBa (x, y)
-REL Db (x, y) = DiagWb (x, y) or DiagBb (x, y)
-REL FreeDa (x, y) = tc 7 x, y (Da (x, y) and not w(y) and not b(y))
-REL FreeDb (x, y) = tc 7 x, y (Db (x, y) and not w(y) and not b(y))
-REL FreeDWa (x, y) = tc 6 x, y (DiagWa (x, y) and not w(y) and not b(y))
-REL FreeDWb (x, y) = tc 6 x, y (DiagWb (x, y) and not w(y) and not b(y))
-REL FreeDBa (x, y) = tc 6 x, y (DiagBa (x, y) and not w(y) and not b(y))
-REL FreeDBb (x, y) = tc 6 x, y (DiagBb (x, y) and not w(y) and not b(y))
-REL TrDWa (x, y) = ex z (FreeDWa (x, z) and (z = y or DiagWa (z, y)))
-REL TrDWb (x, y) = ex z (FreeDWb (x, z) and (z = y or DiagWb (z, y)))
-REL TrDBa (x, y) = ex z (FreeDBa (x, z) and (z = y or DiagBa (z, y)))
-REL TrDBb (x, y) = ex z (FreeDBb (x, z) and (z = y or DiagBb (z, y)))
-REL TDiagW2 (x, y, z) =
- (TrDWa (x, y) and DiagWa (y, z)) or (TrDWb (x, y) and DiagWb (y, z))
-REL TDiagB2 (x, y, z) =
- (TrDBa (x, y) and DiagBa (y, z)) or (TrDBb (x, y) and DiagBb (y, z))
-REL TDiag2 (x, y, z) = TDiagW2 (x, y, z) or TDiagB2 (x, y, z)
+REL BeatsW (x, y) = ex z (b(z) and not b(y) and not w(y) and DiagW2 (x, z, y))
+REL BeatsWX (x, y) = ex z (b(z) and not b(y) and not w(y) and Diag2 (x, z, y))
+REL BeatsB (x, y) = ex z (w(z) and not b(y) and not w(y) and DiagB2 (x, z, y))
+REL BeatsBX (x, y) = ex z (w(z) and not b(y) and not w(y) and DiagB2 (x, z, y))
RULE WhiteMove:
[ a, b | W { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
@@ -70,14 +57,14 @@
->
[ a, b | Wq { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre FreeDa(a, b) or FreeDb(a, b)
+ emb w, b pre AnyDiag (a, b)
RULE BlackQMove:
[ a, b | Bq { a } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
->
[ a, b | Bq { b } |
vx {a->0.,b->0.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
- emb w, b pre FreeDa(a, b) or FreeDb(a, b)
+ emb w, b pre AnyDiag (a, b)
RULE WhiteBeat:
[ a, b, c | W { a }; b { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
@@ -86,7 +73,7 @@
[ a, b, c | W { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c) and not IsEight(c)
+ emb w, b pre DiagW2 (a, b, c) and not IsEight(c)
post not ex x, y (_new_W(x) and BeatsW (x, y))
RULE BlackBeat:
[ a, b, c | B { a }; w { b } |
@@ -96,7 +83,7 @@
[ a, b, c | B { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c) and not IsFirst(c)
+ emb w, b pre DiagB2 (a, b, c) and not IsFirst(c)
post not ex x, y (_new_B(x) and BeatsB (x, y))
RULE WhiteBeatPromote:
[ a, b, c | W { a }; b { b } |
@@ -106,7 +93,7 @@
[ a, b, c | Wq { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c) and IsEight(c)
+ emb w, b pre DiagW2 (a, b, c) and IsEight(c)
post not ex x, y (_new_W(x) and BeatsW (x, y))
RULE BlackBeatPromote:
[ a, b, c | B { a }; w { b } |
@@ -116,7 +103,7 @@
[ a, b, c | Bq { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre Diag2 (a, b, c) and IsFirst(c)
+ emb w, b pre DiagB2 (a, b, c) and IsFirst(c)
post not ex x, y (_new_B(x) and BeatsB (x, y))
RULE WhiteBeatCont:
[ a, b, c | W { a }; b { b } |
@@ -144,7 +131,7 @@
[ a, b, c | Wq { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre TDiag2 (a, b, c)
+ emb w, b pre Diag2 (a, b, c)
RULE BlackQBeat:
[ a, b, c | Bq { a }; w { b } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
@@ -153,7 +140,7 @@
[ a, b, c | Bq { c } |
vx {a->0.,b->0.,c->0.}; vy {a->0.,b->0.,c->0.};
x {a->0.,b->10.,c->20.}; y {a->0.,b->10.,c->20.} ]
- emb w, b pre TDiag2 (a, b, c)
+ emb w, b pre Diag2 (a, b, c)
LOC 0 {
PLAYER 1
PAYOFF {
Added: trunk/Toss/examples/Pawns.toss
===================================================================
--- trunk/Toss/examples/Pawns.toss (rev 0)
+++ trunk/Toss/examples/Pawns.toss 2011-01-05 00:52:39 UTC (rev 1274)
@@ -0,0 +1,183 @@
+PLAYERS 1, 2
+DATA depth: 2, adv_ratio: 2
+REL DiagW (x, y) = ex z (C(x, z) and (R(y, z) or R(z, y)))
+REL DiagB (x, y) = ex z (C(z, x) and (R(y, z) or R(z, y)))
+REL IsFirst(x) = not ex z C(z, x)
+REL IsSecond(x) = ex y (C(y, x) and IsFirst(y))
+REL IsEight(x) = not ex z C(x, z)
+REL IsSeventh(x) = ex y (C(x, y) and IsEight(y))
+RULE WhiteDiag:
+ [ a, b | W { a }; B { b } |
+ vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ ->
+ [ a, b | W { b } |
+ vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ emb W, B pre DiagW(a, b) and not ex x (B(x) and not ex y C(y, x))
+RULE WhiteStraight:
+ [ | B:1 {}; R:2 {} | ] "
+
+ .
+
+ W
+" -> [ | B:1 {}; R:2 {} |
+ ] "
+
+ W
+
+ .
+" emb W, B pre not ex x (B(x) and not ex y C(y, x))
+RULE WhiteStraightTwo:
+ [ | B:1 {}; R:2 {} | ] "
+
+ .
+
+ .
+
+ W
+" -> [ | B:1 {}; R:2 {} |
+ ] "
+
+ W
+
+ .
+
+ .
+" emb W, B pre IsSecond(a1) and not ex x (B(x) and not ex y C(y, x))
+RULE WhitePawnRightDbl:
+ [ | | ] "
+ ...
+ ?..-B
+ ...
+ ? ...
+ ...
+ W..B
+" -> [ | | ] "
+ ...
+ ?...
+ ...
+ ? W..
+ ...
+ ....
+" emb W, B
+RULE WhitePawnLeftDbl:
+ [ | | ] "
+ ...
+ -B.?
+ ...
+ . ?..
+ ...
+ B..W
+" -> [ | | ] "
+ ...
+ ...?
+ ...
+ W ?..
+ ...
+ ....
+" emb W, B
+RULE BlackDiag:
+ [ a, b | B { a }; W { b } |
+ vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ ->
+ [ a, b | B { b } |
+ vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ]
+ emb W, B pre DiagB(a, b) and not ex x (W(x) and not ex y C(x, y))
+RULE BlackStraight:
+ [ | R:2 {}; W:1 {} | ] "
+
+ B
+
+ .
+" -> [ | R:2 {}; W:1 {} |
+ ] "
+
+ .
+
+ B
+" emb W, B pre not ex x (W(x) and not ex y C(x, y))
+RULE BlackStraightTwo:
+ [ | R:2 {}; W:1 {} | ] "
+
+ B
+
+ .
+
+ .
+" -> [ | R:2 {}; W:1 {} |
+ ] "
+
+ .
+
+ .
+
+ B
+" emb W, B pre IsSeventh(a3) and not ex x (W(x) and not ex y C(x, y))
+RULE BlackPawnRightDbl:
+ [ | | ] "
+ ...
+ B..W
+ ...
+ ? ...
+ ...
+ ?..-W
+" -> [ | | ] "
+ ...
+ ....
+ ...
+ ? B..
+ ...
+ ?...
+" emb W, B
+RULE BlackPawnLeftDbl:
+ [ | | ] "
+ ...
+ W..B
+ ...
+ . ?..
+ ...
+ -W.?
+" -> [ | | ] "
+ ...
+ ....
+ ...
+ B ?..
+ ...
+ ...?
+" emb W, B
+LOC 0 {
+ PLAYER 1
+ PAYOFF {
+ 1: :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)));
+ 2: :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ }
+ MOVES [WhiteDiag -> 1]; [WhiteStraight -> 1];
+ [WhitePawnRightDbl -> 1]; [WhitePawnLeftDbl -> 1]; [WhiteStraightTwo -> 1]
+}
+LOC 1 {
+ PLAYER 2
+ PAYOFF {
+ 1: :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)));
+ 2: :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ }
+ MOVES [BlackDiag -> 0]; [BlackStraight -> 0];
+ [BlackPawnRightDbl -> 0]; [BlackPawnLeftDbl -> 0]; [BlackStraightTwo -> 0]
+}
+MODEL [ | |
+ ] "
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ B..B B..B B..B B..B
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ W W..W W..W W..W W..
+ ... ... ... ...
+ ... ... ... ...
+"
Added: trunk/Toss/examples/Pawns.tossstyle
===================================================================
--- trunk/Toss/examples/Pawns.tossstyle (rev 0)
+++ trunk/Toss/examples/Pawns.tossstyle 2011-01-05 00:52:39 UTC (rev 1274)
@@ -0,0 +1,6 @@
+nocolor ;
+elOPACITY: 20 ;
+relOPACITY: 150 ;
+arrLENscale: 0.0 ;
+W: ~/pawn_white.svg;
+B: ~/pawn_black.svg;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
