toss-devel-svn Mailing List for Toss (Page 13)
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-05-19 23:54:30
|
Revision: 1448
http://toss.svn.sourceforge.net/toss/?rev=1448&view=rev
Author: lukaszkaiser
Date: 2011-05-19 23:54:24 +0000 (Thu, 19 May 2011)
Log Message:
-----------
Basic concurrency support (run -redodb examples to get concurrent tic-tac-toe).
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
trunk/Toss/Server/DB.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Connect.js
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/index.html
Added Paths:
-----------
trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Arena/Arena.ml 2011-05-19 23:54:24 UTC (rev 1448)
@@ -293,7 +293,8 @@
(rr) ^ ", " ^ fpstr ("t", t_interval) ^ par_str
(* Print a move as string. *)
-let move_str (lb, i) = "["^ (label_str lb) ^" -> "^ (string_of_int i) ^"]"
+let move_str (lb, i) = Printf.sprintf "[%s -> %i]" (label_str lb) i
+let pmv_str (pl, lb, i) = Printf.sprintf "[%s,%s -> %i]" pl (label_str lb) i
let fprint_loc_body_in struc pnames f player {payoff = in_p; moves = in_m} =
Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
@@ -815,13 +816,15 @@
state_game.graph.(i) <- { state_game.graph.(i) with moves = moves };
((state_game, state), "LOC MOVES SET")
) *)
- | GetLocMoves (i) -> (* TODO! adapt for concurrency! *)
+ | GetLocMoves (i) ->
if i < 0 || i > Array.length state_game.graph then
((state_game, state), "ERR location "^string_of_int i^" not found")
else
- let all_moves = List.concat (Array.to_list (Array.map (
- fun loc -> loc.moves) state_game.graph.(i))) in
- ((state_game,state), (String.concat "; " (List.map move_str all_moves)))
+ let pl i = Aux.rev_assoc state_game.player_names i in
+ let all_moves = List.concat (Array.to_list (
+ Array.mapi (fun i ploc -> List.map (fun (l, e) -> (pl i, l, e))
+ ploc.moves) state_game.graph.(i))) in
+ ((state_game,state), (String.concat "; " (List.map pmv_str all_moves)))
| SuggestLocMoves _ ->
failwith "handle_req: SuggestLocMoves handled in Server"
| EvalFormula (phi) -> ((state_game, state), "ERR eval not yet implemented")
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Play/GameTree.ml 2011-05-19 23:54:24 UTC (rev 1448)
@@ -101,7 +101,7 @@
let l_pl = moving_player game.Arena.graph.(leaf_s.Arena.cur_loc) in
let l_info = info_leaf (depth+1) game leaf_s l_pl player in
Leaf (leaf_s, l_pl, l_info) in
- let children = parallel_map (fun (m,s) -> (m, leaf_of_move s)) moves in
+ let children = parallel_map (fun (_,m,s)-> (m, leaf_of_move s)) moves in
Solver.M.clear_timeout ();
Node (state, player,info_node depth game state player children,children)
| Node (state, player, info, children) ->
@@ -241,7 +241,8 @@
(* Choose one of the maximizing moves (at random) given a game tree. *)
let choose_moves game = function
| Terminal _ -> raise Not_found
- | Leaf (state, _, _) -> Array.to_list (Move.list_moves game state)
+ | Leaf (state, _, _) ->
+ List.map (fun (_,a,b) -> (a,b)) (Array.to_list (Move.list_moves game state))
| Node (_, p, info, succ) ->
let cmp (_, c1) (_, c2) =
let nval child = (node_values child).(p) in
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Play/Move.ml 2011-05-19 23:54:24 UTC (rev 1448)
@@ -115,11 +115,13 @@
Array.of_list moves, Array.of_list models
let list_moves game s =
- let select_moving a =(*temporary function - accept just one player w/ moves*)
- let locs = Aux.array_find_all (fun l -> l.Arena.moves <> []) a in
- if List.length locs <> 1 then failwith "too many moves in loc for now" else
- if locs = [] then a.(0) else List.hd locs in
- let loc = select_moving (game.Arena.graph.(s.Arena.cur_loc)) in
- let m = gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc in
- Array.of_list (gen_models_list game.Arena.rules s.Arena.struc s.Arena.time m)
-
+ let select_moving a =
+ let pls = Aux.array_argfind_all (fun l -> l.Arena.moves <> []) a in
+ if pls = [] then [0] else pls in
+ let loc = game.Arena.graph.(s.Arena.cur_loc) in
+ let moving = select_moving loc in
+ let get_moves pl =
+ let m = gen_moves cGRID_SIZE game.Arena.rules s.Arena.struc loc.(pl) in
+ (gen_models_list game.Arena.rules s.Arena.struc s.Arena.time m) in
+ Array.of_list (List.concat (
+ List.map (fun p -> List.map (fun (a,b) -> (p,a,b)) (get_moves p)) moving))
Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Play/Move.mli 2011-05-19 23:54:24 UTC (rev 1448)
@@ -34,4 +34,4 @@
float -> move array -> move array * Arena.game_state array
val list_moves : Arena.game -> Arena.game_state ->
- (move * Arena.game_state) array
+ (int * move * Arena.game_state) array
Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Server/DB.ml 2011-05-19 23:54:24 UTC (rev 1448)
@@ -10,7 +10,8 @@
let dbFILE = ref ((Unix.getenv "HOME") ^ "/.tossdb.sqlite")
let tGAMES = ref ["Breakthrough"; "Checkers"; "Chess"; "Connect4";
- "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe"]
+ "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe";
+ "Concurrent-Tic-Tac-Toe"]
let def_gdir = if Sys.file_exists "/usr/share/toss" then
"/usr/share/toss/games" else "./examples"
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-19 23:54:24 UTC (rev 1448)
@@ -215,8 +215,9 @@
(strip_ws sep.(0), strip_ws d.(0), strip_ws d.(1)) in
let make_move m =
let gs = split "->" m in
- let lab = split_list "," gs.(0) in
- (strip_ws (List.hd lab),
+ let lab_all = split_list "," gs.(0) in
+ let (lab_pl, lab) = (List.hd lab_all, List.tl lab_all) in
+ (strip_ws lab_pl, strip_ws (List.hd lab),
List.map (fun v -> make_itvl (strip_ws v)) (List.tl lab),
strip_ws gs.(1)) in
List.map (fun m -> make_move (strip_ws_lst m)) moves
@@ -245,18 +246,20 @@
let client_open_from_str s = client_set_state ("#db#" ^ s)
-let client_move_str (m, r, e) =
+let client_move_str (pl, m, r, e) =
let mstr m = String.concat ", " (List.map (fun (a, b) -> a ^ ": " ^ b) m) in
- "({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
+ pl ^ ",({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
let client_cur_moves () =
- let append_move moves (r, _, endp) = (* FIXME! currently we ignore itvls *)
- (List.map (fun m -> (m, r, endp)) (client_query r)) @ moves in
+ let append_move moves (pl, r, _, endp) = (* currently we ignore itvls *)
+ (List.map (fun m -> (pl, m, r, endp)) (client_query r)) @ moves in
let cur_loc = client_get_cur_loc () in
let moves = List.fold_left append_move [] (client_get_loc_moves cur_loc) in
String.concat "; " (List.map client_move_str moves)
-let client_get_loc_player i = client_msg ("GET LOC PLAYER " ^ i)
+let client_get_loc_player i =
+ let msg = client_msg ("GET LOC PLAYER " ^ i) in
+ if (String.length msg > 3 && String.sub msg 0 3 = "ERR") then "-1" else msg
let client_make_move m r endp =
let _ = client_apply_rule r m "1.0" [] in
@@ -276,7 +279,7 @@
(t.(0), t.(1))
-let client_suggest timeout advr =
+let client_suggest pl timeout advr =
let loc = client_get_cur_loc () in
let (ts, t) = client_get_time () in
let m = client_msg ("EVAL LOC MOVES " ^ advr ^ ".0 " ^ loc ^
@@ -288,7 +291,7 @@
let es = Array.map strip_ws (split ":" s) in
(es.(0), es.(1)) :: emb in
let emb = List.fold_left append_emb [] (split_list "," msg.(1)) in
- client_move_str (emb, msg.(0), msg.(3))
+ client_move_str (string_of_int pl, emb, msg.(0), msg.(3))
let client_model_get_elem_val el_id vl =
@@ -412,7 +415,7 @@
| "sv" -> "image/svg+xml"
| _ -> "text/html charset=utf-8" in
http_msg true "200 OK" tp [] content
- ) else http_msg true "404 NOT FOUND" "text/html charset=utf-8" []
+ ) else http_msg true "404 NOT FOUND" "text/html; charset=utf-8" []
("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
@@ -476,16 +479,16 @@
db_cur_insert game pl1 pl2 pid (string_of_int move_pl) model loc info "";
release_global_lock ();
pid ^ "$" ^ info ^ "$" ^ (string_of_int move_pl) in
- let game_select_s g p1 p2 pid m =
+ let game_select_s g p1 p2 pid =
"game='" ^ g ^ "' and player1='" ^ p1 ^ "' and player2='" ^ p2 ^
- "' and playid=" ^ pid ^ " and move=" ^ m in
+ "' and playid=" ^ pid in
let upd_svg g p1 p2 pid m svg_s =
- let select = game_select_s g p1 p2 pid m in
+ let select = game_select_s g p1 p2 pid in
let _ = DB.update_table dbFILE ~select ("svg='"^ svg_s ^"'") "cur_states" in
"" in
let db_escape s = str_replace "'" "''" s in
let move_play move_tup g p1 p2 pid m =
- let sel_s = game_select_s g p1 p2 pid m in
+ let sel_s = game_select_s g p1 p2 pid in
let old_res= List.hd (dbtable sel_s "cur_states") in
let (old_toss, old_loc, old_info, old_svg) =
(old_res.(5), old_res.(6), old_res.(7), old_res.(8)) in
@@ -509,14 +512,14 @@
[pid; g; p1; p2; m; old_toss; old_loc; old_info; old_svg];
new_info ^ "$" ^ (string_of_int new_pl) in
let suggest time g p1 p2 pid m =
- let res = List.hd (dbtable (game_select_s g p1 p2 pid m) "cur_states") in
+ let res = List.hd (dbtable (game_select_s g p1 p2 pid) "cur_states") in
let (toss, loc) = (res.(5), res.(6)) in
let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
client_open_from_str (game_toss ^ "\nMODEL " ^ toss);
client_set_cur_loc loc;
let adv_ratio_data = client_get_data "adv_ratio" in
let adv_ratio = if adv_ratio_data = "none" then "4" else adv_ratio_data in
- client_suggest time adv_ratio in
+ client_suggest (m+1) time adv_ratio in
let register_user ui =
if Array.length ui <> 5 then false else
let (uid, name, surname, email, pwd) =
@@ -538,7 +541,7 @@
let friends = dbtable ("id='" ^ uid ^ "'") "friends" in
List.map (fun a -> a.(1)) friends in
let open_db game p1 p2 pid move =
- let res = dbtable (game_select_s game p1 p2 pid move) "cur_states" in
+ let res = dbtable (game_select_s game p1 p2 pid) "cur_states" in
let (move, info) = ((List.hd res).(4), (List.hd res).(7)) in
info ^ "$" ^ move in
let add_opponent uid oppid =
@@ -604,7 +607,8 @@
| "NEW_PLAY" ->
let a = get_args data in new_play a.(1) a.(2) a.(3), []
| "SUGGEST" ->
- let a = get_args data in suggest a.(1) a.(2) a.(3) a.(4) a.(5) a.(6), []
+ let a = get_args data in
+ suggest a.(1) a.(2) a.(3) a.(4) a.(5) (int_of_string a.(6)), []
| "MOVE_PLAY" ->
let (op_i, cl_i) = (String.index data '(', String.index data ')') in
let tp_s = String.sub data (op_i+1) (cl_i - op_i-1) in
@@ -618,7 +622,7 @@
move_play tp a.(0) a.(1) a.(2) a.(3) a.(4), []
| _ ->
"MOD_PYTHON ERROR ; Traceback: Unknown Toss Command! \n " ^ tcmd, [] in
- http_msg false "200 OK" "text/html charset=utf-8" new_cookies resp
+ http_msg false "200 OK" "text/html; charset=utf-8" new_cookies resp
let handle_http_msg rstate cmd head msg ck =
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/Connect.js 2011-05-19 23:54:24 UTC (rev 1448)
@@ -41,11 +41,11 @@
function set_info (info) {
var res_arr = [];
res_arr = info.split("$");
- if (res_arr.length != 5) { return (false); }
+ if (res_arr.length != 5) { alert (res_arr); return (false); }
DIM_STR = res_arr[0];
ELEM_STR = res_arr[1];
RELS_STR = res_arr[2];
- if (res_arr[3].substring(0, 1) == "(") {
+ if (res_arr[3].substring(2, 3) == "(") {
MOVES_STR = res_arr[3];
PAYOFF_STR = "";
} else {
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/Login.js 2011-05-19 23:54:24 UTC (rev 1448)
@@ -30,6 +30,7 @@
list_plays_string ("Gomoku", udata[7]);
list_plays_string ("Pawn-Whopping", udata[8]);
list_plays_string ("Tic-Tac-Toe", udata[9]);
+ list_plays_string ("Concurrent-Tic-Tac-Toe", udata[10]);
get_opponents ();
}
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/Main.js 2011-05-19 23:54:24 UTC (rev 1448)
@@ -244,8 +244,8 @@
document.getElementById("game-disp").style.display = "none";
document.getElementById("plays").style.display = "none";
GAME_NAME = game;
- if (game == "Tic-Tac-Toe") { // bigger margins needed
- create_svg_box (130, 130, "board");
+ if (game == "Tic-Tac-Toe" || game == "Concurrent-Tic-Tac-Toe") {
+ create_svg_box (130, 130, "board"); // bigger margins needed
} else {
create_svg_box (40, 40, "board");
}
@@ -277,9 +277,9 @@
function make_move () {
if (ASYNC_ALL_REQ_PENDING != 0) { alert ("async"); return; }
if (CUR_MOVE == "") return;
- var m = PLAYS[CUR_PLAY_I][3];
+ var m = parseInt(CUR_MOVE.substring (0, 1)) - 1;
if (PLAYS[CUR_PLAY_I][m] != UNAME && PLAYS[CUR_PLAY_I][m] != "computer") {
- alert ("It is your Opponent's turn");
+ alert ("It is your Opponent's move");
return;
}
if (! SIMPLE_MOVES) {
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-05-19 10:44:34 UTC (rev 1447)
+++ trunk/Toss/WebClient/index.html 2011-05-19 23:54:24 UTC (rev 1448)
@@ -258,6 +258,14 @@
<ul class="plays-list" id="plays-list-Tic-Tac-Toe">
<li style="display: none;"/>
</ul>
+ <p class="game-par">
+ <button onclick="new_play('Concurrent-Tic-Tac-Toe')"
+ class="boldobt">Concurrent-Tic-Tac-Toe</button>
+ (<a href="http://en.wikipedia.org/wiki/Tic-tac-toe">info</a>)
+ </p>
+ <ul class="plays-list" id="plays-list-Concurrent-Tic-Tac-Toe">
+ <li style="display: none;"/>
+ </ul>
</div>
Added: trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss (rev 0)
+++ trunk/Toss/examples/Concurrent-Tic-Tac-Toe.toss 2011-05-19 23:54:24 UTC (rev 1448)
@@ -0,0 +1,30 @@
+PLAYERS 1, 2
+DATA r1: circle, r2: line, adv_ratio: 5, 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)
+REL Col3 (x, y, z) = C(x, y) and C(y, z)
+REL DiagA3 (x, y, z) = DiagA(x, y) and DiagA(y, z)
+REL DiagB3 (x, y, z) = DiagB(x, y) and DiagB(y, z)
+REL Conn3 (x, y, z) =
+ Row3(x, y, z) or Col3(x, y, z) or DiagA3(x, y, z) or DiagB3(x, y, z)
+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:
+ [a | P:1 {} | - ] -> [a | P (a) | - ] emb Q, P pre not (WinP() or WinQ())
+RULE Circle:
+ [a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not (WinP() or WinQ())
+LOC 0 {
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 0] }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0] }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] "
+
+ . . .
+
+ . . .
+
+ . . .
+"
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-19 10:44:40
|
Revision: 1447
http://toss.svn.sourceforge.net/toss/?rev=1447&view=rev
Author: lukstafi
Date: 2011-05-19 10:44:34 +0000 (Thu, 19 May 2011)
Log Message:
-----------
Reference specification of GDL translation: {Introducing and Using Defined Relations} a better approach, work in progress.
Modified Paths:
--------------
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-05-18 15:52:15 UTC (rev 1446)
+++ trunk/Toss/www/reference/reference.tex 2011-05-19 10:44:34 UTC (rev 1447)
@@ -92,6 +92,7 @@
\newcommand{\tpos}{\downharpoonleft}
\newcommand{\TrRels}{\ensuremath{\mathrm{TrRels}}}
\newcommand{\TrST}{\ensuremath{\mathrm{TrST}}}
+\newcommand{\TrDefRels}{\ensuremath{\mathrm{TrDefRels}}}
% Theorem environments
\theoremstyle{plain}
@@ -1863,13 +1864,14 @@
\subsubsection{Stable Relations and Fluents}
-We normalize the GDL formula to be translated $\Phi$, which is composed of
-conjunctions, disjunctions and literals, into a disjunction $\Phi_1
-\vee \ldots \vee \Phi_n$, so that every $\Phi_i \equiv G_i \wedge
-ST^{+}_i \wedge ST^{-}_i$, where all literals in $G_i$ are other than
-\texttt{true}, all literals in $ST^{+}_i$ are positive \texttt{true}
-atoms, all literals in $ST^{-}_i$ are negated \texttt{true} atoms. (We
-avoid unnecessary expansions.) Let $\mathrm{ST}(\phi)$ be all the
+We normalize the GDL formula to be translated $\Phi$, which is
+composed of conjunctions, disjunctions and literals, into a
+disjunction $\mathrm{TrDistr}(\Phi) := \Phi_1 \vee \ldots \vee
+\Phi_n$, so that every $\Phi_i = G_i \wedge ST^{+}_i \wedge ST^{-}_i$,
+where all literals in $ST^{+}_i$ are positive \texttt{true} atoms and all
+literals in $ST^{-}_i$ are negated \texttt{true} atoms, and literals
+in $D_i$ are of relations to be translated as defined relations. (We
+avoid unnecessary expansions.) Let $\mathtt{ST}(\phi)$ be all the
state terms, \ie arguments of \texttt{true} atoms, in $\phi$.
$\TrRels(\phi, S_1, S_2)$ descends $\phi$ translating each literal as a
@@ -1885,20 +1887,21 @@
equality relations $Eq_{p,q}$.
The result of translation is the disjunction of translations of each
-$\Phi_i$. A single $\Phi_i \equiv G_i \wedge ST^{+}_i \wedge ST^{-}_i$
+$\Phi_i$. A single $\Phi_i = G_i \wedge ST^{+}_i \wedge ST^{-}_i$
is translated as:
\begin{align*}
-\rho_i := \exists \mathrm{ST}(ST^{+}_i) \big( & \TrRels(eqs_i
-\wedge G_i, \mathrm{ST}(ST^{+}_i), \mathrm{ST}(ST^{+}_i)) \wedge
-\TrST(ST^{+}_i) \wedge \\ & \neg \exists \mathrm{ST}(ST^{-}_i) \big(
-\TrRels(eqs_i \wedge G_i, \mathrm{ST}(ST^{+}_i) \cup
-\mathrm{ST}(ST^{-}_i), \mathrm{ST}(ST^{-}_i)) \wedge \\ &
+ \mathrm{Tr}(\Phi_i) := \exists \mathtt{ST}(ST^{+}_i) \big( &
+ \TrRels(eqs_i \wedge G_i, \mathtt{ST}(ST^{+}_i), \mathtt{ST}(ST^{+}_i))
+ \wedge \TrST(ST^{+}_i) \wedge \\ &
+ \neg \exists \mathtt{ST}(ST^{-}_i) \big(
+\TrRels(eqs_i \wedge G_i, \mathtt{ST}(ST^{+}_i) \cup
+\mathtt{ST}(ST^{-}_i), \mathtt{ST}(ST^{-}_i)) \wedge \\ &
\ \ \ \ \ \ \ \ \TrST(\mathtt{NNF}(\neg ST^{-}_i)) \big) \big)
\end{align*}
-The result of translation is $\mathrm{Tr}(\Phi) := \rho_1 \vee \ldots
-\vee \rho_n$.
+The result of translation is $\mathrm{Tr}(\Phi) := \mathrm{Tr}(\Phi_1) \vee \ldots
+\vee \mathrm{Tr}(\Phi_n)$.
We now proceed to define $\TrRels$ and $\TrST$. Let $\mathtt{BL}(t)$
be the term $t$ with fluent paths replaced with \texttt{BLANK}.
@@ -1914,12 +1917,14 @@
v_1 = \mathtt{BL}(s_1) \wedge \ldots \wedge v_n = \mathtt{BL}(s_n) \wedge \\
& p_1, \ldots, p_n \in \calP_m \wedge
s_1 \tpos_{p_1} = t_1 \wedge \ldots \wedge s_n \tpos_{p_n} = t_n \big\} \\
+ & \textit{(when $R$ is a stable relation)} \\
\TrRels (\neg R(t_1, \ldots, t_n), S_1, S_2) = & \Land \big\{
\neg R_{p_1,\ldots,p_n}(v_1, \ldots, v_n) \; \big| \; s_1,\ldots,s_n \in S_1 \wedge \\
& \{s_1,\ldots,s_n \} \cap S_2 \neq \emptyset \wedge
v_1 = \mathtt{BL}(s_1) \wedge \ldots \wedge v_n = \mathtt{BL}(s_n) \wedge \\
& p_1, \ldots, p_n \in \calP_m \wedge
s_1 \tpos_{p_1} = t_1 \wedge \ldots \wedge s_n \tpos_{p_n} = t_n \big\} \\
+ & \textit{(when $R$ is a stable relation)} \\
\TrST (\phi_1 \wedge \phi_2) = &
\TrST (\phi_1) \wedge \TrST(\phi_2) \\
\TrST (\phi_1 \vee \phi_2) = &
@@ -1932,71 +1937,57 @@
p \in \calP_f \wedge t \tpos_p = s \big\}
\end{align*}
+The case of $\TrRels$ for non-stable relations will be covered in the
+next section.
+
\subsubsection{Introducing and Using Defined Relations}
-A new Toss defined relation is generated for each atom of a GDL
-non-stable relation, with parameters of the defined relation derived
-from the use context. Yet the GDL non-stable relations can themselves
-depend on other defined relations. We therefore generate Toss defined
-relations in a stratified order, so that all Toss definitions of a
-single GDL relation are generated from its (single) pre-processed
-form, with the Toss defined relations it uses already generated. This
-can lead to less constraining relations than their GDL originals,
-because all interaction between the strata is mediated by local
-variables, \ie when $R_3$ calls $R_2$ which calls $R_1$, $R_1$ defined
-relation is created for the $R_2$-$R_1$ context, ignoring the $R_3$-$R_2$
-context. Should it pose problems in practice, countermeasures like
-inlining can be used.
+Consider generating defined relation for relation $R$ with GDL
+defining clauses $\mathtt{(<= (R \ t^1_1 \ldots t^1_n) \ b_1)},
+\ldots, \mathtt{(<= (R \ t^k_1 \ldots t^k_n) \ b_k)}$. For $i$th
+argument of $R$ ($i \in \{1,\ldots,n\}$) we will find
+$\mathtt{ArgType}(R,i)$ with possible values
+$(\mathtt{DefSide},\calS_i,p_i)$, $(\mathtt{CallSide},\calS_i,p_i)$ or
+$(\mathtt{NoSide},p_i)$, with a mapping $\calS_i$ into state terms
+corresponding to the argument in a given context and a path $p_i \in
+\calP_m$ corresponding to the subterm position selected to
+``transfer'' the argument.
-Consider translating a GDL formula $\Phi$ with atoms of non-stable GDL
-relations, we therefore need to generate Toss defined relations for
-them. Let $R$ be non-stable GDL relation. We update $\TrRels$ to:
+Let $\mathrm{TrDistr}(b_j) = D^j_1 \wedge G^j_1 \wedge ST^{j+}_1
+\wedge ST^{j-}_1 \vee \ldots \vee D^j_{m_j} \wedge G^j_{m_j} \wedge ST^{j+}_{m_j}
+\wedge ST^{j-}_{m_j}$. Let $\calS_i$ be a mapping from $(j,l)$ to
+$s^i_{j,l} \in \mathtt{ST}(ST^{j+}_l)$ and $p_i \in \calP_m$ a path such that
+$s^i_{j,l} \tpos_{p_i} = t^j_i$. If such a path and (total for $j,l$) mapping exist,
+then $\mathtt{ArgType}(R,i) = (\mathtt{DefSide},\calS_i,p_i)$.
-\[\TrRels (R(t_1, \ldots, t_n), S_1, S_2) =
-\mathrm{GenDefRel}(R(t_1,\ldots,t_n), S_1) \]
+Otherwise, let $r = R(u_1,\ldots,u_n)$ be an atom of $R$ occurring in
+the $\Phi_d = G \wedge ST^{+} \wedge ST^{-}$ disjunct of
+$\mathrm{TrDistr}$ result for arbitrary clause of the GDL game
+definition. Let $\calS_i$ be a mapping from $\Phi_d$ to $s^i_{\Phi_d}
+\in \mathtt{ST}(ST^{+})$ and $p_i \in \calP_m$ a path such that
+$s^i_{\Phi_d} \tpos_{p_i} = u_i$. If such a path and (total for
+$\Phi_d$) mapping exist, then $\mathtt{ArgType}(R,i) =
+(\mathtt{CallSide},\calS_i,p_i)$.
-$\mathrm{GenDefRel}$ generates and stores Toss defined relation
-$R_{def}$ under context $S_1$, and returns $R_{def}$ applied to
-variables corresponding to state terms from $S_1$. Additional pass can
-be added to game simplification (see Section~\ref{sec-game-simpl}) to
-remove unused parameters of definitions and conflate equivalent
-definitions.
+Still therwise, let $p_i \in \calP_m$ be a path whose domain, \ie the
+set $\big\{t \big| s\tpos_{p_i} = t, s \in \calS\big\}$, contains the
+domain of the $i$th argument of $R$, \ie the sum of projections of $R$
+on $i$th argument for all possible game states. Let
+$\mathtt{ArgType}(R,i) = (\mathtt{NoSide},p_i)$.
-Consider generating defined relation for atom $r$ of relation $R$ with
-GDL defining clauses $\mathtt{(<= h_1 \ b_1)}, \ldots, \mathtt{(<= h_k
- \ b_k)}$. Let the context be a set $S$ of state terms, arbitrarily
-ordered into a sequence $(s_1,\ldots,s_m)$. Let $\sigma_i =
-\mathtt{MGU} (r, h_i)$ and $c = \mathtt{true}(s_1) \wedge \ldots
-\wedge \mathtt{true}(s_m)$. The result of translation is
-
+We are ready to provide the translated definition. Let $\big\{v_i \big|
+\mathtt{ArgType}(R,i) = (\mathtt{DefSide},\calS_i,p_i)\big\}$ be fresh Toss variables, and let $\mathrm{Tr}(G^j_l
+\wedge ST^{j+}_l) = \exists \mathtt{ST}(ST^{+}_i) \phi^j_l$. The
+translation is:
\[
-R_{def}(\mathtt{BL}(s_1),\ldots,\mathtt{BL}(s_m)) =
-\mathrm{Tr}_{S,\sigma_1}(\sigma_1(c \wedge b_1)) \vee \ldots \vee
-\mathrm{Tr}_{S,\sigma_k}(\sigma_k(c \wedge b_k))
+R_{def}(v_1,\ldots,v_n) = \big(\exists \mathtt{ST}(ST^{+}_i)
+\big(\bigwedge \big\{v_1=s^i_{j,l} \big| \mathtt{ArgType}(R,i) =
+(\mathtt{DefSide},\calS_i,p_i)\big\} \wedge
+\mathtt{BL}(\phi^j_l) \big) \vee \ldots \vee \big)
+
\]
-where $\mathrm{Tr}_{S,\sigma_i}$ is $\mathrm{Tr}$ modified by not
-introducing quantification over variables derived for $\sigma_i(c)$,
-calling $\mathtt{BL}_{S,\sigma_i}$ instead of $\mathtt{BL}$, and
-calling $\TrRels_{S,\sigma_i}$ instead of
-$\TrRels$. $\mathtt{BL}_{S,\sigma_i}(\sigma_i(s_j)) =
-\mathtt{BL}(s_j)$, and $\mathtt{BL}_{S,\sigma_i}(t) = \mathtt{BL}(t)$
-for other terms. $\TrRels_{S,\sigma_i}$ is the same as $\TrRels$ except for when it is called on a non-stable GDL relation $R'$:
-\begin{align*}
-\TrRels_{S,\sigma_i} (R'(t_1, \ldots, t_n), S_1, S_2) = &
-\mathrm{GenDefRel}(R(t_1,\ldots,t_n), S_1 \setminus \sigma_i(S)) \textit{ (for } R \neq R' \textit{)} \\
-\TrRels_{S,\sigma_i} (R(t_1, \ldots, t_n), S_1, S_2) = &
-\textit{somehow use the least fixpoint for } R_{def} \\
-\end{align*}
-Observe that $\mathrm{Tr}_{\emptyset,\sigma_i} = \mathrm{Tr}$.
-
-Using memoization for $\mathrm{GenDefRel}$, we only generate a single
-defined relation per atom of non-stable GDL relation occurring in
-another non-stable GDL relation, even though we might generate
-multiple Toss defined relations for the GDL relation containing the
-atom.
-
\section{Game Simplification in Toss} \label{sec-game-simpl}
Games automatically translated from GDL, as described above, are verbose
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-18 15:52:21
|
Revision: 1446
http://toss.svn.sourceforge.net/toss/?rev=1446&view=rev
Author: lukaszkaiser
Date: 2011-05-18 15:52:15 +0000 (Wed, 18 May 2011)
Log Message:
-----------
Further UI improvements.
Modified Paths:
--------------
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
Added Paths:
-----------
trunk/Toss/WebClient/support.html
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-05-17 01:34:48 UTC (rev 1445)
+++ trunk/Toss/WebClient/Main.js 2011-05-18 15:52:15 UTC (rev 1446)
@@ -400,6 +400,14 @@
return ("'''" + svg_s + "'''");
}
+function show_chess_warning () {
+ document.getElementById("chess-level-warning").style.display = "block";
+}
+
+function hide_chess_warning () {
+ document.getElementById("chess-level-warning").style.display = "none";
+}
+
function new_play_guest (game) {
GAME_NAME = game;
UNAME = "guest";
@@ -411,7 +419,7 @@
document.getElementById("topuser").innerHTML =
game + ' (<a href="' + wiki + '">Move Rules</a>)';
if (SIMPLE_SET) { document.getElementById("topuser").innerHTML = game };
- document.getElementById("pdescBack").style.display = "block";
+ document.getElementById("pdescBack").style.display = "inline";
document.getElementById("game-title").style.display = "none";
document.getElementById("game-info-par").style.paddingBottom = "1em";
document.getElementById("loginform").style.display = "none";
@@ -419,6 +427,10 @@
document.getElementById("topright").style.display = "inline";
document.getElementById("logoutbt").style.display = "none";
document.getElementById("welcome").style.display = "none";
+ if (game == "Chess") {
+ show_chess_warning ();
+ setTimeout("hide_chess_warning ()", 3000);
+ }
new_play_do ("computer", 0);
}
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-05-17 01:34:48 UTC (rev 1445)
+++ trunk/Toss/WebClient/Style.css 2011-05-18 15:52:15 UTC (rev 1446)
@@ -126,15 +126,12 @@
}
.logo-picspan {
+ position: relative;
+ top: -0.5em;
+ left: 0px;
display: none;
- position: absolute;
- top: 0px;
- left: 0px;
- width: 100%;
- text-align: center;
font-size: 1.1em;
font-weight: bold;
- background-color: rgba(64, 8, 39, 0.7);
}
.logo-pictxt {
@@ -143,8 +140,16 @@
border-radius: 4px;
-moz-border-radius: 4px;
opacity: 1;
+ font-size: 1em;
+ background-color: rgba(64, 8, 39, 0.7);
}
+#leftupperlogo-img {
+ position: relative;
+ left: -0.2em;
+ top: 0px;
+}
+
.loginsmall {
position: relative;
top: 1px;
@@ -313,10 +318,10 @@
}
#topbar {
- margin-left: 6.5em;
+ margin-left: 7.5em;
padding-left: 1em;
padding-right: 1em;
- padding-top: 0.7em;
+ padding-top: 0.8em;
}
#topright {
@@ -369,6 +374,7 @@
position: absolute;
top: 0px;
right: 0.5em;
+ color: inherit;
}
#suggestions-toggle {
@@ -493,7 +499,7 @@
margin-top: 0.5em;
}
-#opponents {
+#opponents, #chess-level-warning {
display: none;
position: fixed;
left: 0px;
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-05-17 01:34:48 UTC (rev 1445)
+++ trunk/Toss/WebClient/index.html 2011-05-18 15:52:15 UTC (rev 1446)
@@ -23,10 +23,10 @@
<div id="top">
<div id="logo">
<a id="leftupperlogo-link" href="index.html">
- <img src="toss.png" alt="tPlay" />
<span id="pdescBack" class="logo-picspan">
- <span class="logo-pictxt">←</span>
+ <span class="logo-pictxt">⇐</span>
</span>
+ <img id="leftupperlogo-img" src="toss.png" alt="tPlay" />
</a>
</div>
<div id="topbar">
@@ -72,6 +72,11 @@
</span>
</div>
+<div id="chess-level-warning">
+Chess is set to very weak play.</br>
+<br/>
+No training here, just have fun!
+</div>
<div id="opponents">
Pick Opponent:
Added: trunk/Toss/WebClient/support.html
===================================================================
--- trunk/Toss/WebClient/support.html (rev 0)
+++ trunk/Toss/WebClient/support.html 2011-05-18 15:52:15 UTC (rev 1446)
@@ -0,0 +1,96 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xmlns:svg="http://www.w3.org/2000/svg" xml:lang="en" lang="en">
+<head>
+ <meta http-equiv="Content-Type" content="text/xhtml+xml; charset=UTF-8" />
+ <title>tPlay — Support</title>
+ <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" src="Login.js"> </script>
+</head>
+
+<body>
+
+<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">Support</span></div>
+</div>
+
+<div style="font-size: 1.1em; margin: 1em; padding: 1em;">
+
+<h2>Contact Us</h2>
+<p style="line-height: 130%;">
+Thank you for your interest in tPlay! We try to make our interface as
+intuitive and simple as possible, and we hope it is mostly self-explanatory.
+If you encounter any problems, have some remarks or just want to tell us
+how you feel about tPlay, write us an email.<br/>
+<span style="position: relative; top: 0px; left: 15em;">
+<script type="text/javascript">begin_mailto("tossplay", "gmail.com",
+ "Email tos...@gm...");</script>tossplay [AT] gmail [DOT] com
+<script type="text/javascript">end_mailto();</script>
+</span>
+<br/>
+</p>
+
+<h2>How Do I Move?</h2>
+<p style="line-height: 130%;">
+At tPlay you make moves just by clicking on the fields from and to which you
+move. In case there is only a single possible move, it is made directly to
+speed up the play. If you make moves by mistake, activate the
+<span style="font-weight: bold;">Ask Before Move</span> control
+in the bottom-left of the screen. Then you will be asked to confirm
+each selected move before it is taken.
+</p>
+
+<h2>What Are The Rules Of The Games?</h2>
+<ul>
+ <li>Breakthrough — break through opponent's lines, see
+ <a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)"
+ style="color: #400827;">Breakthrough on Wikipedia</a>
+<li>Checkers — beat opponent's pieces, see
+ <a href="http://en.wikipedia.org/wiki/English_draughts"
+ style="color: #400827;">Checkers on Wikipedia</a>
+<li>Chess — check-mate, see
+ <a href="http://en.wikipedia.org/wiki/Chess"
+ style="color: #400827;">Chess on Wikipedia</a>
+<li>Connect4 — make a line of four, see
+ <a href="http://en.wikipedia.org/wiki/Connect4"
+ style="color: #400827;">Connect4 on Wikipedia</a>
+</li>
+<li>Gomoku — make a line of five, see
+ <a href="http://en.wikipedia.org/wiki/Gomoku"
+ style="color: #400827;">Gomoku on Wikipedia</a>
+</li>
+<li>Pawn-Whopping — get a pawn to the other end, see
+ <a href="http://en.wikipedia.org/wiki/Pawn_(chess)"
+ style="color: #400827;">Pawn Moves on Wikipedia</a>
+</li>
+</ul>
+
+<h2>How Do I Set The Playing Level?</h2>
+<p style="line-height: 130%;">
+The level at tPlay varies according to the
+<span style="font-weight: bold;">Speed</span> setting in the top right
+corner of the screen. Increase the time for slower but better moves.
+</p>
+
+<h2>Can I Play Other Games?</h2>
+<p style="line-height: 130%;">
+We are adding new games to tPlay all the time.
+Email us your suggestion if you desire a particular game!
+</p>
+
+</div>
+
+<div id="bottom">
+<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
+</div>
+
+</div>
+
+
+</body>
+</html>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-17 01:34:54
|
Revision: 1445
http://toss.svn.sourceforge.net/toss/?rev=1445&view=rev
Author: lukaszkaiser
Date: 2011-05-17 01:34:48 +0000 (Tue, 17 May 2011)
Log Message:
-----------
Further UI improvements.
Modified Paths:
--------------
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-05-16 20:09:29 UTC (rev 1444)
+++ trunk/Toss/WebClient/Login.js 2011-05-17 01:34:48 UTC (rev 1445)
@@ -55,8 +55,21 @@
if (udata != "") { setup_user (udata.split("$")) };
}
if (window.location.href.indexOf("?simple=true") > 0) {
+ SIMPLE_SET = true;
+ document.getElementById("pdescChess").style.display = "block";
+ document.getElementById("pdescConnect4").style.display = "block";
+ document.getElementById("pdescPawn-Whopping").style.display = "block";
+ document.getElementById("pdescBreakthrough").style.display = "block";
+ document.getElementById("pdescCheckers").style.display = "block";
+ document.getElementById("pdescGomoku").style.display = "block";
document.getElementById("loginform").style.display = "none";
document.getElementById("topright-register").style.display = "none";
+ document.getElementById("toss-link").style.display = "none";
+ document.getElementById("welcome-top").style.display = "none";
+ document.getElementById("welcome-list-main").style.display = "none";
+ document.getElementById("topuser").innerHTML = "Choose Your Next Game";
+ document.getElementById("leftupperlogo-link").href =
+ "index.html?simple=true";
};
cur_game = "";
if (game) { var cur_game = game; }
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-05-16 20:09:29 UTC (rev 1444)
+++ trunk/Toss/WebClient/Main.js 2011-05-17 01:34:48 UTC (rev 1445)
@@ -17,6 +17,7 @@
var LAST_CLICKED_ELEM = "";
var SIMPLE_MOVES = true;
+var SIMPLE_SET = false;
// Get model information from server.
function get_model_info () {
@@ -94,6 +95,7 @@
document.getElementById("board").style.paddingTop = "0em";
}
document.getElementById("move-info-par").style.display = "none";
+ document.getElementById("game-info-par").style.paddingBottom = "0em";
document.getElementById('payoffs').innerHTML =
"Result: " + subst_pl(PAYOFF_STR);
document.getElementById('payoffs').style.display = "inline";
@@ -266,6 +268,7 @@
document.getElementById("cur-player").innerHTML =
disp_name(PLAYS[CUR_PLAY_I][PLAYS[CUR_PLAY_I][3]]);
toss_open_db (play_py_id(pi));
+ document.getElementById("suggestions-toggle").style.display = "inline";
full_redraw ();
}
@@ -400,7 +403,17 @@
function new_play_guest (game) {
GAME_NAME = game;
UNAME = "guest";
- document.getElementById("topuser").innerHTML = "Welcome!";
+ wgame = game;
+ if (game == "Breakthrough") { wgame = "Breakthrough_(board_game)" };
+ if (game == "Pawn-Whopping") { wgame = "Pawn_(chess)" };
+ if (game == "Entanglement") { wgame = "Entanglement_(graph_measure)" };
+ wiki = "http://en.wikipedia.org/wiki/" + wgame;
+ document.getElementById("topuser").innerHTML =
+ game + ' (<a href="' + wiki + '">Move Rules</a>)';
+ if (SIMPLE_SET) { document.getElementById("topuser").innerHTML = game };
+ document.getElementById("pdescBack").style.display = "block";
+ document.getElementById("game-title").style.display = "none";
+ document.getElementById("game-info-par").style.paddingBottom = "1em";
document.getElementById("loginform").style.display = "none";
document.getElementById("topright-register").style.display = "none";
document.getElementById("topright").style.display = "inline";
@@ -423,6 +436,7 @@
info_nbr = srv ("NEW_PLAY", "c, '" + GAME_NAME + "', '" + UNAME +
"', '" + opp_uid + "'");
document.getElementById("working").style.display = "none";
+ document.getElementById("suggestions-toggle").style.display = "inline";
info_idx = info_nbr.indexOf('$');
FREE_PLAY_NO = parseInt(info_nbr.substring(0, info_idx));
document.getElementById("play-number").innerHTML = "" + FREE_PLAY_NO;
@@ -449,6 +463,9 @@
document.getElementById('payoffs').innerHTML = "Not Finished Yet";
document.getElementById('payoffs').style.display = "none";
document.getElementById('new-play-par').style.display = "none";
+ if (UNAME == "guest") {
+ document.getElementById("game-info-par").style.paddingBottom = "1em";
+ };
toggle_suggestions ();
toggle_suggestions ();
clear_svg ();
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-05-16 20:09:29 UTC (rev 1444)
+++ trunk/Toss/WebClient/Style.css 2011-05-17 01:34:48 UTC (rev 1445)
@@ -93,6 +93,58 @@
margin-top: 0.3em;
}
+.game-picbt {
+ position: relative;
+ top:0px;
+ left:0px;
+ text-align: center;
+ width:32%;
+ text-align: center;
+ border-width: 0px;
+ color: #260314;
+ background-color: #fff1d4;
+ font-family: Verdana, 'TeXGyreHerosRegular', sans;
+}
+
+.game-picspan {
+ display: none;
+ position: absolute;
+ top: 50%;
+ left: 0px;
+ width: 100%;
+ text-align: center;
+ font-size: 2.2em;
+}
+
+.game-pictxt {
+ position: relative;
+ top: -1em;
+ background-color: rgba(255, 241, 228, 0.8);
+ border-radius: 4px;
+ -moz-border-radius: 4px;
+ opacity: 1;
+}
+
+.logo-picspan {
+ display: none;
+ position: absolute;
+ top: 0px;
+ left: 0px;
+ width: 100%;
+ text-align: center;
+ font-size: 1.1em;
+ font-weight: bold;
+ background-color: rgba(64, 8, 39, 0.7);
+}
+
+.logo-pictxt {
+ position: relative;
+ top: 0em;
+ border-radius: 4px;
+ -moz-border-radius: 4px;
+ opacity: 1;
+}
+
.loginsmall {
position: relative;
top: 1px;
@@ -214,6 +266,9 @@
}
#logo {
+ position: relative;
+ left: 0px;
+ top: 0px;
font-size: 2em;
float: left;
font-family: arial, 'OFLSortsMillGoudyRegular', serif;
Modified: trunk/Toss/WebClient/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-05-16 20:09:29 UTC (rev 1444)
+++ trunk/Toss/WebClient/index.html 2011-05-17 01:34:48 UTC (rev 1445)
@@ -21,7 +21,14 @@
<div id="main">
<div id="top">
-<div id="logo"><a href="index.html"><img src="toss.png" alt="tPlay" /></a></div>
+<div id="logo">
+ <a id="leftupperlogo-link" href="index.html">
+ <img src="toss.png" alt="tPlay" />
+ <span id="pdescBack" class="logo-picspan">
+ <span class="logo-pictxt">←</span>
+ </span>
+ </a>
+</div>
<div id="topbar">
<span id="topuser"></span>
<form id="loginform" style="display: inline;" action="">
@@ -88,39 +95,57 @@
with our best interface on <span class="logo-in">tPlay</span>!
</p>
-<p style="width:100%; text-align: justify">
-<button onclick="new_play_guest('Chess')" style="width:32%"
- class="boldobt" title="Play Chess">
+<p style="width:100%; text-align: justify;">
+<button onclick="new_play_guest('Chess')" class="game-picbt"
+ title="Play Chess">
<img style="max-width:95%" src="pics/Chess.png" alt="Chess Board" />
+ <span id="pdescChess" class="game-picspan">
+ <span class="game-pictxt">Chess</span>
+ </span>
</button>
-<button onclick="new_play_guest('Connect4')" style="width:32%"
+<button onclick="new_play_guest('Connect4')" class="game-picbt"
class="boldobt" title="Play Connect4">
<img style="max-width:95%" src="pics/Connect4.png" alt="Connect4 Board" />
+ <span id="pdescConnect4" class="game-picspan">
+ <span class="game-pictxt">Connect4</span>
+ </span>
</button>
-<button onclick="new_play_guest('Pawn-Whopping')" style="width:32%"
+<button onclick="new_play_guest('Pawn-Whopping')" class="game-picbt"
class="boldobt" title="Play Pawn-Whopping">
<img style="max-width:95%" src="pics/Pawn-Whopping.png"
alt="Pawn-Whopping Board" />
+ <span id="pdescPawn-Whopping" class="game-picspan">
+ <span class="game-pictxt">Pawn-Whopping</span>
+ </span>
</button>
</p>
<p style="width:100%; text-align: justify">
-<button onclick="new_play_guest('Breakthrough')" style="width:32%"
+<button onclick="new_play_guest('Breakthrough')" class="game-picbt"
class="boldobt" title="Play Breakthrough">
<img style="max-width:95%" src="pics/Breakthrough.png"
alt="Breakthrough Board" />
+ <span id="pdescBreakthrough" class="game-picspan">
+ <span class="game-pictxt">Breakthrough</span>
+ </span>
</button>
-<button onclick="new_play_guest('Checkers')" style="width:32%"
+<button onclick="new_play_guest('Checkers')" class="game-picbt"
class="boldobt" title="Play Checkers">
<img style="max-width:95%" src="pics/Checkers.png" alt="Checkers Board" />
+ <span id="pdescCheckers" class="game-picspan">
+ <span class="game-pictxt">Checkers</span>
+ </span>
</button>
-<button onclick="new_play_guest('Gomoku')" style="width:32%"
+<button onclick="new_play_guest('Gomoku')" class="game-picbt"
class="boldobt" title="Play Gomoku">
<img style="max-width:95%" src="pics/Gomoku.png" alt="Gomoku Board" />
+ <span id="pdescGomoku" class="game-picspan">
+ <span class="game-pictxt">Gomoku</span>
+ </span>
</button>
</p>
-<ul class="welcome-list">
+<ul id="welcome-list-main" class="welcome-list">
<li>Play
<a href="http://en.wikipedia.org/wiki/Breakthrough_(board_game)"
>Breakthrough,</a>
@@ -262,9 +287,8 @@
<div id="bottom">
-<button id="suggestions-toggle" onclick="toggle_suggestions()">
- Ask Before Move
-</button>
+<button id="suggestions-toggle" style="display: none;"
+ onclick="toggle_suggestions()">Ask Before Move</button>
<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
<script type="text/javascript">begin_mailto(
"tossplay", "gmail.com", "Contact Us");</script>
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-16 20:09:35
|
Revision: 1444
http://toss.svn.sourceforge.net/toss/?rev=1444&view=rev
Author: lukstafi
Date: 2011-05-16 20:09:29 +0000 (Mon, 16 May 2011)
Log Message:
-----------
Reference specification for GDL translation: {Introducing and Using Defined Relations} complete idea except for how to deal with recursion.
Modified Paths:
--------------
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-05-16 17:40:23 UTC (rev 1443)
+++ trunk/Toss/www/reference/reference.tex 2011-05-16 20:09:29 UTC (rev 1444)
@@ -1863,7 +1863,7 @@
\subsubsection{Stable Relations and Fluents}
-We normalize the GDL formula to be translated, which is composed of
+We normalize the GDL formula to be translated $\Phi$, which is composed of
conjunctions, disjunctions and literals, into a disjunction $\Phi_1
\vee \ldots \vee \Phi_n$, so that every $\Phi_i \equiv G_i \wedge
ST^{+}_i \wedge ST^{-}_i$, where all literals in $G_i$ are other than
@@ -1889,14 +1889,17 @@
is translated as:
\begin{align*}
-\exists \mathrm{ST}(ST^{+}_i) \big( & \TrRels(eqs_i
+\rho_i := \exists \mathrm{ST}(ST^{+}_i) \big( & \TrRels(eqs_i
\wedge G_i, \mathrm{ST}(ST^{+}_i), \mathrm{ST}(ST^{+}_i)) \wedge
\TrST(ST^{+}_i) \wedge \\ & \neg \exists \mathrm{ST}(ST^{-}_i) \big(
\TrRels(eqs_i \wedge G_i, \mathrm{ST}(ST^{+}_i) \cup
\mathrm{ST}(ST^{-}_i), \mathrm{ST}(ST^{-}_i)) \wedge \\ &
-\; \; \; \; \; \; \TrST(\mathtt{NNF}(\neg ST^{-}_i)) \big) \big)
+\ \ \ \ \ \ \ \ \TrST(\mathtt{NNF}(\neg ST^{-}_i)) \big) \big)
\end{align*}
+The result of translation is $\mathrm{Tr}(\Phi) := \rho_1 \vee \ldots
+\vee \rho_n$.
+
We now proceed to define $\TrRels$ and $\TrST$. Let $\mathtt{BL}(t)$
be the term $t$ with fluent paths replaced with \texttt{BLANK}.
@@ -1931,9 +1934,71 @@
\subsubsection{Introducing and Using Defined Relations}
+A new Toss defined relation is generated for each atom of a GDL
+non-stable relation, with parameters of the defined relation derived
+from the use context. Yet the GDL non-stable relations can themselves
+depend on other defined relations. We therefore generate Toss defined
+relations in a stratified order, so that all Toss definitions of a
+single GDL relation are generated from its (single) pre-processed
+form, with the Toss defined relations it uses already generated. This
+can lead to less constraining relations than their GDL originals,
+because all interaction between the strata is mediated by local
+variables, \ie when $R_3$ calls $R_2$ which calls $R_1$, $R_1$ defined
+relation is created for the $R_2$-$R_1$ context, ignoring the $R_3$-$R_2$
+context. Should it pose problems in practice, countermeasures like
+inlining can be used.
-\section{Game Simplification in Toss}
+Consider translating a GDL formula $\Phi$ with atoms of non-stable GDL
+relations, we therefore need to generate Toss defined relations for
+them. Let $R$ be non-stable GDL relation. We update $\TrRels$ to:
+\[\TrRels (R(t_1, \ldots, t_n), S_1, S_2) =
+\mathrm{GenDefRel}(R(t_1,\ldots,t_n), S_1) \]
+
+$\mathrm{GenDefRel}$ generates and stores Toss defined relation
+$R_{def}$ under context $S_1$, and returns $R_{def}$ applied to
+variables corresponding to state terms from $S_1$. Additional pass can
+be added to game simplification (see Section~\ref{sec-game-simpl}) to
+remove unused parameters of definitions and conflate equivalent
+definitions.
+
+Consider generating defined relation for atom $r$ of relation $R$ with
+GDL defining clauses $\mathtt{(<= h_1 \ b_1)}, \ldots, \mathtt{(<= h_k
+ \ b_k)}$. Let the context be a set $S$ of state terms, arbitrarily
+ordered into a sequence $(s_1,\ldots,s_m)$. Let $\sigma_i =
+\mathtt{MGU} (r, h_i)$ and $c = \mathtt{true}(s_1) \wedge \ldots
+\wedge \mathtt{true}(s_m)$. The result of translation is
+
+\[
+R_{def}(\mathtt{BL}(s_1),\ldots,\mathtt{BL}(s_m)) =
+\mathrm{Tr}_{S,\sigma_1}(\sigma_1(c \wedge b_1)) \vee \ldots \vee
+\mathrm{Tr}_{S,\sigma_k}(\sigma_k(c \wedge b_k))
+\]
+
+where $\mathrm{Tr}_{S,\sigma_i}$ is $\mathrm{Tr}$ modified by not
+introducing quantification over variables derived for $\sigma_i(c)$,
+calling $\mathtt{BL}_{S,\sigma_i}$ instead of $\mathtt{BL}$, and
+calling $\TrRels_{S,\sigma_i}$ instead of
+$\TrRels$. $\mathtt{BL}_{S,\sigma_i}(\sigma_i(s_j)) =
+\mathtt{BL}(s_j)$, and $\mathtt{BL}_{S,\sigma_i}(t) = \mathtt{BL}(t)$
+for other terms. $\TrRels_{S,\sigma_i}$ is the same as $\TrRels$ except for when it is called on a non-stable GDL relation $R'$:
+
+\begin{align*}
+\TrRels_{S,\sigma_i} (R'(t_1, \ldots, t_n), S_1, S_2) = &
+\mathrm{GenDefRel}(R(t_1,\ldots,t_n), S_1 \setminus \sigma_i(S)) \textit{ (for } R \neq R' \textit{)} \\
+\TrRels_{S,\sigma_i} (R(t_1, \ldots, t_n), S_1, S_2) = &
+\textit{somehow use the least fixpoint for } R_{def} \\
+\end{align*}
+Observe that $\mathrm{Tr}_{\emptyset,\sigma_i} = \mathrm{Tr}$.
+
+Using memoization for $\mathrm{GenDefRel}$, we only generate a single
+defined relation per atom of non-stable GDL relation occurring in
+another non-stable GDL relation, even though we might generate
+multiple Toss defined relations for the GDL relation containing the
+atom.
+
+\section{Game Simplification in Toss} \label{sec-game-simpl}
+
Games automatically translated from GDL, as described above, are verbose
compared to games defined manually for Toss. They are also inefficient,
since the current solver in Toss works fast only for sparse relations.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-16 17:40:29
|
Revision: 1443
http://toss.svn.sourceforge.net/toss/?rev=1443&view=rev
Author: lukaszkaiser
Date: 2011-05-16 17:40:23 +0000 (Mon, 16 May 2011)
Log Message:
-----------
Make parallel calls stable. Inefficient for now due to multi-threading cache misses.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Play/GameTree.ml
trunk/Toss/Server/ReqHandler.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-05-15 22:48:50 UTC (rev 1442)
+++ trunk/Toss/Formula/Aux.ml 2011-05-16 17:40:23 UTC (rev 1443)
@@ -660,16 +660,21 @@
addr_arr.(0)
with Not_found -> raise Host_not_found
-let toss_call (client_port, client_addr_s) f x =
- let client_addr = get_inet_addr client_addr_s in
- let client_sock = Unix.ADDR_INET (client_addr, client_port) in
- let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
- output_string cl_out_ch "COMP\n";
- flush cl_out_ch;
- Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
- flush cl_out_ch;
- fun () ->
- let res = Marshal.from_channel cl_in_ch in
- Unix.shutdown_connection cl_in_ch;
- res
+let toss_call (client_port, client_addr_s) f_in x =
+ try
+ let client_addr = get_inet_addr client_addr_s in
+ let client_sock = Unix.ADDR_INET (client_addr, client_port) in
+ let (cl_in_ch, cl_out_ch) = Unix.open_connection client_sock in
+ output_string cl_out_ch "COMP\n";
+ flush cl_out_ch;
+ let f a = try `Res (f_in a) with exn -> `Exn exn in
+ Marshal.to_channel cl_out_ch (f, x) [Marshal.Closures];
+ flush cl_out_ch;
+ (fun () ->
+ let res = Marshal.from_channel cl_in_ch in
+ Unix.shutdown_connection cl_in_ch;
+ match res with `Res r -> r | `Exn e -> raise e)
+ with Unix.Unix_error (e, f, s) ->
+ Printf.printf "Toss call failed: %s; %s %s\n%!" (Unix.error_message e) f s;
+ (fun () -> f_in x)
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-05-15 22:48:50 UTC (rev 1442)
+++ trunk/Toss/Formula/Aux.mli 2011-05-16 17:40:23 UTC (rev 1443)
@@ -309,5 +309,8 @@
(** Determine the internet address or raise Host_not_found. *)
val get_inet_addr : string -> Unix.inet_addr
-(** Call a Toss Server on [port, server] to compute [f] on [x]. *)
+(** Call a Toss Server on [port, server] to compute [f] on [x]. BEWARE:
+ (1) references are not sent, e.g. you must redo timeouts.
+ (2) on single-threaded servers handling calls (older Toss versions),
+ you have to collect the results, even on Exception in caller *)
val toss_call : int * string -> ('a -> 'b) -> 'a -> (unit -> 'b)
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-05-15 22:48:50 UTC (rev 1442)
+++ trunk/Toss/Play/GameTree.ml 2011-05-16 17:40:23 UTC (rev 1443)
@@ -14,8 +14,11 @@
if l = 0 then [||] else if l = 1 then [|f a.(0)|] else (
let (a1, a2) = (Array.sub a 0 (l/2+1), Array.sub a (l/2+1) (l-(l/2+1))) in
let r1 = Aux.toss_call !parallel_toss (Array.map f) a1 in
- let r2 = Array.map f a2 in
- Array.append (r1 ()) (r2)
+ (* If the server handling COMP is single-threaded, they must wait for it!
+ In such case replace the last line with the two lines below.
+ try let r2 = Array.map f a2 in Array.append (r1 ()) (r2) with exn ->
+ ignore (r1 ()); raise exn *)
+ let r2 = Array.map f a2 in Array.append (r1 ()) r2
)
(* Abstract game tree, just stores state and move information. *)
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-15 22:48:50 UTC (rev 1442)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-16 17:40:23 UTC (rev 1443)
@@ -658,7 +658,7 @@
| None ->
if line_in = "COMP" then
let res = Marshal.from_channel in_ch in
- if !debug_level > 0 then Printf.printf "COMP\n%!";
+ if !debug_level > 0 then Printf.printf "COMP, %!";
("COMP", Some (Aux.Right res))
else
(* We put endlines, encoded by '$', back into the message.
@@ -684,10 +684,14 @@
(new_rstate, continue) in
match read_in_line in_ch with
| (line, Some (Aux.Right (f, x))) when line = "COMP" ->
- let res = f x in
- Marshal.to_channel out_ch res [Marshal.Closures];
- flush out_ch;
- (rstate, true)
+ (match Unix.fork () with
+ | 0 (* child *) ->
+ let res = f x in
+ Marshal.to_channel out_ch res [Marshal.Closures];
+ flush out_ch;
+ (rstate, false)
+ | _ (* parent *) -> (rstate, true)
+ )
| (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" ->
(match handle_http_msg rstate cmd head msg ck with
| Aux.Left ((state, resp)) -> report (state, resp) true
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-15 22:48:59
|
Revision: 1442
http://toss.svn.sourceforge.net/toss/?rev=1442&view=rev
Author: lukaszkaiser
Date: 2011-05-15 22:48:50 +0000 (Sun, 15 May 2011)
Log Message:
-----------
Web user interface improvements.
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/Server.ml
trunk/Toss/WebClient/Connect.js
trunk/Toss/WebClient/DefaultStyle.js
trunk/Toss/WebClient/Login.js
trunk/Toss/WebClient/Main.js
trunk/Toss/WebClient/Style.css
trunk/Toss/WebClient/index.html
trunk/Toss/WebClient/pics/Breakthrough.png
trunk/Toss/WebClient/pics/Checkers.png
trunk/Toss/WebClient/pics/Chess.png
trunk/Toss/WebClient/pics/Connect4.png
trunk/Toss/WebClient/pics/Connect4.svg
trunk/Toss/WebClient/pics/Entanglement.png
trunk/Toss/WebClient/pics/Gomoku.png
trunk/Toss/WebClient/pics/Gomoku.svg
trunk/Toss/WebClient/pics/Pawn-Whopping.png
trunk/Toss/WebClient/pics/Style.css
trunk/Toss/WebClient/pics/Style2.css
trunk/Toss/WebClient/pics/Tic-Tac-Toe.png
trunk/Toss/WebClient/pics/Tic-Tac-Toe.svg
trunk/Toss/WebClient/pics/convert_all.sh
Added Paths:
-----------
trunk/Toss/WebClient/pics/Style3.css
Removed Paths:
-------------
trunk/Toss/WebClient/contact.html
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-15 22:48:50 UTC (rev 1442)
@@ -6,7 +6,9 @@
let html_dir_path = ref (if Sys.file_exists "/usr/share/toss" then
"/usr/share/toss/html" else "WebClient/")
+let quit_on_eof = ref true;
+
(* ---------- Basic request type and internal handler ---------- *)
type req_state =
@@ -55,12 +57,15 @@
let heur = match game_modified, g_heur with
| false, Some h -> Some h
| true, _ | _, None -> Some (compute_heuristic advr state) in
- let (move, _) =
- Aux.random_elem (Play.maximax_unfold_choose effort
- (fst state) (snd state) (Aux.unsome heur)) in
- Play.cancel_timeout ();
- (heur, game_modified, state, gdl_transl, playclock),
- Move.move_gs_str state move
+ try
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose effort
+ (fst state) (snd state) (Aux.unsome heur)) in
+ Play.cancel_timeout ();
+ (heur, game_modified, state, gdl_transl, playclock),
+ Move.move_gs_str state move
+ with Not_found -> (heur, game_modified, state, gdl_transl, playclock),
+ "ERR: suggest called but no possible moves!"
)
| Aux.Left(Arena.ApplyRule (r_name, mtch, t, p) as req) ->
@@ -399,7 +404,7 @@
let content = Aux.input_file f in
close_in f;
let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
- | "ht" -> "text/html charset=utf-8"
+ | "ht" -> "text/html; charset=utf-8"
| "ic" -> "image/x-icon"
| "pn" -> "image/png"
| "cs" -> "text/css"
@@ -707,14 +712,15 @@
output_string out_ch ("ERR could not parse\n");
flush out_ch;
rstate, true
- | End_of_file ->
+ | End_of_file when !quit_on_eof ->
output_string out_ch ("ERR processing completed -- EOF\n");
flush out_ch;
- raise End_of_file
+ raise End_of_file
| exn ->
Printf.printf "Toss Server: error -- exception %s\n%!"
(Printexc.to_string exn);
Printf.printf "Exception backtrace: %s\n%!"
(Printexc.get_backtrace ());
output_string out_ch ("ERR internal error -- see server stdout\n");
+ flush out_ch;
rstate, true
Modified: trunk/Toss/Server/ReqHandler.mli
===================================================================
--- trunk/Toss/Server/ReqHandler.mli 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/Server/ReqHandler.mli 2011-05-15 22:48:50 UTC (rev 1442)
@@ -5,6 +5,7 @@
(** Set debugging level. *)
val set_debug_level : int -> unit
+val quit_on_eof : bool ref
(** {2 Request Handling Functions} *)
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/Server/Server.ml 2011-05-15 22:48:50 UTC (rev 1442)
@@ -169,6 +169,8 @@
("-nm", Arg.Unit (fun () -> Heuristic.use_monotonic := false),
" monotonicity off");
("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)");
+ ("-eof", Arg.Unit (fun () -> ReqHandler.quit_on_eof := false),
+ "do not quit server on end of file of requests");
("-html", Arg.String (fun s -> ReqHandler.html_dir_path := s),
"set path to directory with html files for the web-based client");
("-db", Arg.String (fun s -> (DB.dbFILE := s)), "use specified DB file");
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/Connect.js 2011-05-15 22:48:50 UTC (rev 1442)
@@ -28,7 +28,8 @@
var PAYOFF_STR = ""
var PLAYER_STR = ""
-var ASYNC_REQ_PENDING = 0;
+var ASYNC_ALL_REQ_PENDING = 0;
+var ASYNC_CMD_REQ_PENDING = {};
// Helper function: sign of a number.
function sign (x) {
@@ -78,21 +79,32 @@
}
// Send [msg] to server asynchronously, ignore response text.
-function async_server_msg (msg, f) {
+function async_server_msg (msg, count, f) {
var xml_request = new XMLHttpRequest ();
xml_request.open ('POST', 'Handler', true);
xml_request.setRequestHeader ('Content-Type',
'application/x-www-form-urlencoded; charset=UTF-8');
- xml_request.onreadystatechange = function () {
- if (xml_request.readyState == 4) {
- ASYNC_REQ_PENDING -= 1;
- resp = xml_request.responseText;
- if (resp.indexOf ("MOD_PYTHON ERROR") > -1) {
- alert (resp.substring(resp.indexOf("Traceback")));
- } else { f(resp) };
+ if (count) {
+ xml_request.onreadystatechange = function () {
+ if (xml_request.readyState == 4) {
+ ASYNC_ALL_REQ_PENDING -= 1;
+ resp = xml_request.responseText;
+ if (resp.indexOf ("MOD_PYTHON ERROR") > -1) {
+ alert (resp.substring(resp.indexOf("Traceback")));
+ } else { f(resp) };
+ }
}
+ } else {
+ xml_request.onreadystatechange = function () {
+ if (xml_request.readyState == 4) {
+ resp = xml_request.responseText;
+ if (resp.indexOf ("MOD_PYTHON ERROR") > -1) {
+ alert (resp.substring(resp.indexOf("Traceback")));
+ } else { f(resp) };
+ }
+ }
};
- ASYNC_REQ_PENDING += 1;
+ if (count) { ASYNC_ALL_REQ_PENDING += 1; }
xml_request.send (msg);
}
@@ -103,12 +115,19 @@
// Send [msg] to server attaching prefix '[cmd]#' async., ignore response.
function async_srv_ignore (cmd, msg) {
- return (async_server_msg (cmd + '#' + msg, function(x) { } ));
+ return (async_server_msg (cmd + '#' + msg, false, function(x) { } ));
}
// Send [msg] to server attaching prefix '[cmd]#' async., run f on return.
function async_srv (cmd, msg, f) {
- return (async_server_msg (cmd + '#' + msg, f ));
+ if (ASYNC_CMD_REQ_PENDING[cmd]) {
+ ASYNC_CMD_REQ_PENDING[cmd] += 1;
+ } else { ASYNC_CMD_REQ_PENDING[cmd] = 1; };
+ var fm = function (m) {
+ ASYNC_CMD_REQ_PENDING[cmd] -= 1;
+ f ();
+ };
+ return (async_server_msg (cmd + '#' + msg, true, f));
}
// Strip [c1] and [c2] from beginning and end of [str].
@@ -174,9 +193,9 @@
function translate_pos (pos) {
var x = ((pos[0] - MODEL_MINX) * SVG_WIDTH) / MODEL_WIDTH;
if (VIEW_MIRROR == 0) {
- var y = ((pos[1] - MODEL_MINY) * SVG_HEIGHT) / MODEL_HEIGHT;
+ var y = ((pos[1] - MODEL_MINY) * SVG_HEIGHT) / MODEL_HEIGHT;
} else {
- var y = ((MODEL_HEIGHT - (pos[1] - MODEL_MINY)) * SVG_WIDTH) / MODEL_HEIGHT;
+ var y = ((MODEL_HEIGHT - (pos[1] - MODEL_MINY))*SVG_WIDTH)/MODEL_HEIGHT;
}
return ([x + SVG_MARGINX, y + SVG_MARGINY])
}
@@ -209,26 +228,37 @@
SVG_MARGINY = margx;
var svg = document.createElementNS('http://www.w3.org/2000/svg', 'svg');
svg.setAttribute('id', 'svg');
- var wx = SVG_WIDTH + 2*SVG_MARGINX;
- var wy = SVG_HEIGHT + 2*SVG_MARGINY;
- svg.setAttribute('viewBox', '0 0 ' + wx + " " + wy);
+ var wx = SVG_WIDTH + 2*SVG_MARGINX + 20;
+ var wy = SVG_HEIGHT + 2*SVG_MARGINY + 20;
+ svg.setAttribute('viewBox', '-10 -10 ' + wx + " " + wy);
document.getElementById(parent_id).appendChild(svg);
}
-// Create new svg element [elem], child of svg, with [attributes].
-function svg_from_string (x, y, sizex, sizey, s) {
+// Just make an svg elem from string
+function bare_svg_from_string (s) {
var parser = new DOMParser ();
var svgs = '<svg version="1.1" xmlns="http://www.w3.org/2000/svg">';
+ var doc = parser.parseFromString(svgs + s + '</svg>', "text/xml");
+ return (document.adoptNode(doc.childNodes[0]).childNodes[0]);
+}
+
+// Create new svg element [elem], child of svg, set attributes, scale.
+function svg_from_string (x, y, sizex, sizey, s, attributes) {
+ var parser = new DOMParser ();
+ var svgs = '<svg version="1.1" xmlns="http://www.w3.org/2000/svg">';
var scfx = (SUGGESTED_ELEM_SIZEX - 10) / sizex;
var scfy = (SUGGESTED_ELEM_SIZEY - 10) / sizey;
var sc = "scale(" + scfx + "," + scfy + ")";
var gs = '<g transform="translate(' + x + "," + y + ") " + sc + '">';
- var doc = parser.parseFromString(svgs+ gs+ s + ' </g> </svg>', "text/xml");
- var elem = document.adoptNode(doc.childNodes[0]);
- return(elem.childNodes[0]);
+ var doc = parser.parseFromString(svgs+ gs+ s + '</g></svg>', "text/xml");
+ var elem = document.adoptNode(doc.childNodes[0]).childNodes[0];
+ var elem_in = elem.childNodes[0];
+ for (var i = 0; i < attributes.length; i++) {
+ elem_in.setAttribute (attributes[i][0], attributes[i][1].toString());
+ }
+ return (elem);
}
-
// Create new svg element [elem], child of svg, with [attributes].
function add_svg (elem, attributes) {
var elem = document.createElementNS("http://www.w3.org/2000/svg", elem);
Modified: trunk/Toss/WebClient/DefaultStyle.js
===================================================================
--- trunk/Toss/WebClient/DefaultStyle.js 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/DefaultStyle.js 2011-05-15 22:48:50 UTC (rev 1442)
@@ -2,10 +2,11 @@
// This module implements default drawing style for games.
// Functions expected from this module:
-// - draw_elem (elem)
+// - draw_background (game)
+// - draw_elem (game, elem)
// - highlight_elem (elem)
// - unhighlight_elem (elem)
-// - draw_rel (rel_name, args)
+// - draw_rel (game, rel_name, args)
var DEFpawn = '<g transform="translate(-22.5,-22.5)"> \
@@ -140,6 +141,19 @@
return (parseInt(s).toString() == s)
}
+// Mostly we skip background drawings, but when needed, they are here.
+function draw_background (game) {
+ if (game == "Connect4") {
+ var x = SVG_MARGINX;
+ var y = SVG_MARGINY;
+ var w = SVG_WIDTH + 2 * x;
+ var h = SVG_HEIGHT + 2 * x;
+ var b = '<rect x="' + 0 + '" y="' + 0 + '" width="' + w + '" height="'
+ + h + '" stroke-width="5" rx="5" ry="5" id="board_connect4" />';
+ document.getElementById("svg").appendChild(bare_svg_from_string (b));
+ }
+}
+
// To draw chess board we distinguish even/odd placed elements.
function elem_class (elem) {
var elem_cl = "model-elem";
@@ -151,17 +165,25 @@
}
// Draw the element [elem].
-function draw_elem (elem) {
+function draw_elem (game, elem) {
var pos = ELEM_POS[elem];
- add_svg ("rect",
- [["x", pos[0] - SUGGESTED_ELEM_SIZEX],
- ["y", pos[1] - SUGGESTED_ELEM_SIZEY],
- ["width", 2 * SUGGESTED_ELEM_SIZEX],
- ["height", 2 * SUGGESTED_ELEM_SIZEX],
- ["id", "elem_" + elem],
- ["class", elem_class(elem)],
- ["onclick", ("handle_elem_click('" + elem + "')")]]
- );
+ if (game != "Connect4") {
+ add_svg ("rect",
+ [["x", pos[0] - SUGGESTED_ELEM_SIZEX],
+ ["y", pos[1] - SUGGESTED_ELEM_SIZEY],
+ ["width", 2 * SUGGESTED_ELEM_SIZEX],
+ ["height", 2 * SUGGESTED_ELEM_SIZEY],
+ ["id", "elem_" + elem],
+ ["class", elem_class(elem)],
+ ["onclick", ("handle_elem_click('" + elem + "')")]]
+ );
+ } else {
+ var circ = svg_from_string
+ (pos[0], pos[1], 10, 10, '<circle cx="0" cy="0" r="20" />',
+ [["id", "elem_" + elem], ["class", elem_class(elem)],
+ ["onclick", "handle_elem_click('" + elem + "')"]])
+ document.getElementById("svg").appendChild(circ);
+ }
}
// Highlight the element [elem].
@@ -177,18 +199,45 @@
}
// Draw relation [rel_name] between elements [args].
-function draw_rel (rel_name, args) {
+function draw_rel (game, rel_name, args) {
if (args.length == 1) {
var is = 'id="' + "pred_" + args[0] + "_" + rel_name + '" ';
var hs = 'onclick="' + "handle_elem_click('" + args[0] + "')" + '" ';
var pos = ELEM_POS[args[0]];
if (rel_name == "P") { // Tic-tac-toe cross
- var cs = 'class="' + "model-pred-" + rel_name + '" ';
- var ls1 = '<line x1="-10" y1="-10" x2="10" y2="10" />';
- var ls2 = '<line x1="10" y1="-10" x2="-10" y2="10" />';
- var cr = svg_from_string (pos[0], pos[1], 12, 12,
- '<g ' + cs + is + hs + '>' + ls1 + ls2 + '</g>');
- document.getElementById("svg").appendChild(cr);
+ if (game != "Connect4") {
+ var cs = 'class="' + "model-pred-" + rel_name + '" ';
+ var ls1 = '<line x1="-10" y1="-10" x2="10" y2="10" />';
+ var ls2 = '<line x1="10" y1="-10" x2="-10" y2="10" />';
+ var cr = svg_from_string
+ (pos[0], pos[1], 12, 12,
+ '<g ' + cs + is + hs + '>' + ls1 + ls2 + '</g>', []);
+ document.getElementById("svg").appendChild(cr);
+ } else {
+ var cls = "model-pred-" + rel_name;
+ var ids = "pred_" + args[0] + "_" + rel_name;
+ var circ = svg_from_string
+ (pos[0], pos[1], 10, 10,
+ '<circle cx="0" cy="0" r="20" />',
+ [["id", ids], ["class", cls],
+ ["onclick", "handle_elem_click('" + args[0] + "')"]]);
+ document.getElementById("svg").appendChild(circ);
+ }
+ } else if (rel_name == "Q") { // Tic-tac-toe Circle
+ var clp = ["class", "model-pred-" + rel_name];
+ var idp = ["id", "pred_" + args[0] + "_" + rel_name];
+ var hdp = ["onclick", ("handle_elem_click('" + args[0] + "')")];
+ if (game != "Connect4") {
+ var circ = svg_from_string (pos[0], pos[1], 10, 10,
+ '<circle cx="0" cy="0" r="8" />',
+ [idp, clp, hdp]);
+ document.getElementById("svg").appendChild(circ);
+ } else {
+ var circ = svg_from_string (pos[0], pos[1], 10, 10,
+ '<circle cx="0" cy="0" r="20" />',
+ [idp, clp, hdp]);
+ document.getElementById("svg").appendChild(circ);
+ }
} else if (rel_name == "R") { // Robber in Entanglement
add_svg ("circle",
[["cx", pos[0]], ["cy", pos[1]], ["r", SUGGESTED_ELEM_SIZEX - 5],
@@ -197,53 +246,53 @@
["onclick", ("handle_elem_click('" + args[0] + "')")]]);
} else if (rel_name == "wP") { // Chess Figure: white pawn
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessW" ' + is + hs + '>' + DEFpawn + '</g>');
+ '<g class="chessW" ' + is + hs + '>' + DEFpawn + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "bP") { // Chess Figure: black pawn
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessB" ' + is + hs + '>' + DEFpawn + '</g>');
+ '<g class="chessB" ' + is + hs + '>' + DEFpawn + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "wN") { // Chess Figure: white knight
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessW" ' + is + hs + '>' + DEFknight + '</g>');
+ '<g class="chessW" ' + is + hs + '>' + DEFknight + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "bN") { // Chess Figure: black knight
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessB" ' + is + hs + '>' + DEFknight + '</g>');
+ '<g class="chessB" ' + is + hs + '>' + DEFknight + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "wB") { // Chess Figure: white bishop
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessW" ' + is + hs + '>' + DEFbishop + '</g>');
+ '<g class="chessW" ' + is + hs + '>' + DEFbishop + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "bB") { // Chess Figure: black bishop
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessB" ' + is + hs + '>' + DEFbishop + '</g>');
+ '<g class="chessB" ' + is + hs + '>' + DEFbishop + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "wR") { // Chess Figure: white rook
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessW" ' + is + hs + '>' + DEFrook + '</g>');
+ '<g class="chessW" ' + is + hs + '>' + DEFrook + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "bR") { // Chess Figure: black rook
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessB" ' + is + hs + '>' + DEFrook + '</g>');
+ '<g class="chessB" ' + is + hs + '>' + DEFrook + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "wQ" || rel_name == "Wq") {
// Chess Figure: white queen or Checkers: white queen
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessW" ' + is + hs + '>' + DEFqueen + '</g>');
+ '<g class="chessW" ' + is + hs + '>' + DEFqueen + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "bQ" || rel_name == "Bq") {
// Chess Figure: black queen or Checkers: black queen
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessB" ' + is + hs + '>' + DEFqueen + '</g>');
+ '<g class="chessB" ' + is + hs + '>' + DEFqueen + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "wK") { // Chess Figure: white king
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessW" ' + is + hs + '>' + DEFking + '</g>');
+ '<g class="chessW" ' + is + hs + '>' + DEFking + '</g>', []);
document.getElementById("svg").appendChild(f);
} else if (rel_name == "bK") { // Chess Figure: black king
var f = svg_from_string (pos[0], pos[1], 20, 20,
- '<g class="chessB" ' + is + hs + '>' + DEFking + '</g>');
+ '<g class="chessB" ' + is + hs + '>' + DEFking + '</g>', []);
document.getElementById("svg").appendChild(f);
} else {
add_svg ("circle",
Modified: trunk/Toss/WebClient/Login.js
===================================================================
--- trunk/Toss/WebClient/Login.js 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/Login.js 2011-05-15 22:48:50 UTC (rev 1442)
@@ -54,6 +54,10 @@
var udata = srv("USERPLAYS", "user");
if (udata != "") { setup_user (udata.split("$")) };
}
+ if (window.location.href.indexOf("?simple=true") > 0) {
+ document.getElementById("loginform").style.display = "none";
+ document.getElementById("topright-register").style.display = "none";
+ };
cur_game = "";
if (game) { var cur_game = game; }
var gindex = window.location.href.indexOf("?game=")
@@ -235,9 +239,10 @@
function begin_mailto (name, domain, title) {
var address = name + '@' + domain;
if(title) {
- document.write("<a class='mail' href='mailto:" + address + "'>" + "<span>");
+ document.write("<a class='contact' href='mailto:" + address + "'>" +
+ title + "<span style='display: none;'>");
} else {
- document.write("<a class='mail' href='mailto:" + address + "'>" +
+ document.write("<a class='contact' href='mailto:" + address + "'>" +
address + "<span style='display: none;'>");
}
}
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/Main.js 2011-05-15 22:48:50 UTC (rev 1442)
@@ -16,6 +16,8 @@
var LAST_CLICKED_ELEM = "";
+var SIMPLE_MOVES = true;
+
// Get model information from server.
function get_model_info () {
get_elems_with_pos ();
@@ -35,12 +37,13 @@
// Draw the model using function from Toss[X]Style.js.
// WARNING: must call get_model_info first!
-function draw_model () {
+function draw_model (game) {
+ draw_background (game);
for (var i = 0; i < ELEMS.length; i++) {
- draw_elem (ELEMS[i]);
+ draw_elem (game, ELEMS[i]);
}
for (var i = 0; i < RELS.length; i++) {
- draw_rel (RELS[i][0], RELS[i][1]);
+ draw_rel (game, RELS[i][0], RELS[i][1]);
}
}
@@ -55,8 +58,17 @@
svg_e.parentNode.removeChild (svg_e);
}
+function win_s (i) {
+ var pl = PLAYS[CUR_PLAY_I][i];
+ if (pl == UNAME) { return ("You Win!"); }
+ return (disp_name(pl) + " Wins");
+}
+
// Substitute players for 0 and 1 in a payoff string.
function subst_pl (s) {
+ if (s == "0: 1., 1: -1.") { return (win_s (0)); }
+ if (s == "0: -1., 1: 1.") { return (win_s (1)); }
+ if (s == "0: 0., 1: 0.") { return ("Tie"); }
var s1 = s.replace (/0:/g, disp_name(PLAYS[CUR_PLAY_I][0]) + ":");
var s2 = s1.replace (/1:/g, disp_name(PLAYS[CUR_PLAY_I][1]) + ":");
var s3 = s2.replace (/1.,/g, "1,");
@@ -68,16 +80,24 @@
// Full redraw.
function full_redraw () {
clear_svg ();
- document.getElementById("working").style.display = "block";
+ if (! SIMPLE_MOVES) {
+ document.getElementById("working").style.display = "block";
+ }
get_model_info ();
create_svg_box (SVG_MARGINX, SVG_MARGINY, "board");
- draw_model ();
+ draw_model (GAME_NAME);
if (PAYOFF_STR == "") {
document.getElementById('movebt').innerHTML = "Make move:";
document.getElementById('cur-move').innerHTML = "none";
} else {
- document.getElementById('movebt').innerHTML = "Payoffs:";
- document.getElementById('cur-move').innerHTML = subst_pl(PAYOFF_STR);
+ if (SIMPLE_MOVES) {
+ document.getElementById("board").style.paddingTop = "0em";
+ }
+ document.getElementById("move-info-par").style.display = "none";
+ document.getElementById('payoffs').innerHTML =
+ "Result: " + subst_pl(PAYOFF_STR);
+ document.getElementById('payoffs').style.display = "inline";
+ document.getElementById('new-play-par').style.display = "block";
}
document.getElementById("working").style.display = "none";
}
@@ -120,13 +140,34 @@
// Handler for clicks on elements.
function handle_elem_click (elem) {
- if (ASYNC_REQ_PENDING != 0) { return; }
+ if (ASYNC_ALL_REQ_PENDING != 0) { return; }
var moves = get_moves (elem, LAST_CLICKED_ELEM);
if (moves.length == 0) {
LAST_CLICKED_ELEM = "";
moves = get_moves (elem, LAST_CLICKED_ELEM);
};
- if (moves.length > ELEM_COUNTERS[elem]) {
+ if (moves.length == 0) { // still no moves, unhighlight
+ for (var i = 0; i < CUR_ELEMS.length; i++) {
+ unhighlight_elem (CUR_ELEMS[i]);
+ }
+ CUR_ELEMS = [];
+ CUR_MOVE = "";
+ LAST_CLICKED_ELEM = "";
+ } else if (moves.length == 1) {
+ show_move (moves[0]);
+ ELEM_COUNTERS[elem] = 1;
+ if (SIMPLE_MOVES) { make_move (); };
+ } else if (LAST_CLICKED_ELEM != "" && LAST_CLICKED_ELEM != elem //move fast
+ && moves.length == 2 && moves[0].length > moves[1].length + 2) {
+ show_move (moves[1]);
+ ELEM_COUNTERS[elem] = 2;
+ if (SIMPLE_MOVES) { make_move (); };
+ } else if (LAST_CLICKED_ELEM != "" && LAST_CLICKED_ELEM != elem //move fast
+ && moves.length == 2 && moves[1].length > moves[0].length + 2) {
+ show_move (moves[0]);
+ ELEM_COUNTERS[elem] = 1;
+ if (SIMPLE_MOVES) { make_move (); };
+ } else if (moves.length > ELEM_COUNTERS[elem]) {
show_move (moves[ELEM_COUNTERS[elem]]);
ELEM_COUNTERS[elem] += 1;
} else if (moves.length > 0) {
@@ -151,7 +192,7 @@
}
function disp_name (uname) {
- if (uname == "guest") { return ("Guest"); }
+ if (uname == "guest") { return ("You"); }
if (UNAME_TO_NAME_MAP[uname]) { return (UNAME_TO_NAME_MAP[uname]); }
name = srv ("GET_NAME", uname);
UNAME_TO_NAME_MAP[uname] = name;
@@ -219,7 +260,9 @@
document.getElementById("game-disp").style.display = "block";
document.getElementById("play-number").innerHTML = "" + play_id;
CUR_PLAY_I = pi;
- VIEW_MIRROR = (PLAYS[CUR_PLAY_I][0] == UNAME) ? 0 : 1;
+ if (game == "Connect4") { VIEW_MIRROR = 0; } else {
+ VIEW_MIRROR = (PLAYS[CUR_PLAY_I][0] == UNAME) ? 0 : 1;
+ }
document.getElementById("cur-player").innerHTML =
disp_name(PLAYS[CUR_PLAY_I][PLAYS[CUR_PLAY_I][3]]);
toss_open_db (play_py_id(pi));
@@ -229,14 +272,16 @@
// Apply current move.
function make_move () {
- if (ASYNC_REQ_PENDING != 0) return;
+ if (ASYNC_ALL_REQ_PENDING != 0) { alert ("async"); return; }
if (CUR_MOVE == "") return;
var m = PLAYS[CUR_PLAY_I][3];
if (PLAYS[CUR_PLAY_I][m] != UNAME && PLAYS[CUR_PLAY_I][m] != "computer") {
alert ("It is your Opponent's turn");
return;
}
- document.getElementById("working").style.display = "block";
+ if (! SIMPLE_MOVES) {
+ document.getElementById("working").style.display = "block";
+ }
async_srv("MOVE_PLAY", 'c, '+ CUR_MOVE +', '+ play_py_id (CUR_PLAY_I),
make_move_continue);
}
@@ -257,7 +302,8 @@
var li = new_play_item (GAME_NAME, CUR_PLAY_I);
old_li.parentNode.replaceChild (li, old_li);
if (PLAYS[CUR_PLAY_I][PLAYER_STR] == "computer") {
- suggest_move_async (make_move);
+ var mv_time = document.getElementById("speed").value;
+ suggest_move_async (mv_time, make_move);
}
}
@@ -271,7 +317,7 @@
li.setAttribute ("class", "opponents-list-elem");
li.setAttribute ("id", "opponent-" + uid); // + "-" + index
li.innerHTML =
- '<button class="dbt" onclick="new_play_do(' + "'" + uid + "'" + ')">' +
+ '<button class="dbt" onclick="new_play_do('+ "'" + uid + "', 0"+ ')">'+
disp_name(uid) + ' (' + uid + ') </button>';
return (li);
}
@@ -293,7 +339,7 @@
var zeroli = document.createElement('li');
zeroli.setAttribute ("class", "opponents-list-elem");
zeroli.setAttribute ("id", "opponent-" + "-0");
- zeroli.innerHTML = '<button class="dbt" onclick="new_play_do(-1)">' +
+ zeroli.innerHTML = '<button class="dbt" onclick="new_play_do(-1, 0)">' +
'Play against Yourself</button>';
o.appendChild (zeroli);
for (var i = 0; i < FRIENDS.length; i++) {
@@ -307,6 +353,8 @@
function new_play (game) {
if (UNAME == "") { alert ("Please log in to create plays"); return; }
GAME_NAME = game;
+ var olist = document.getElementById("opponents-list");
+ while (olist.childNodes.length > 0) { olist.removeChild(olist.firstChild); }
make_opnt_list ();
}
@@ -352,10 +400,16 @@
function new_play_guest (game) {
GAME_NAME = game;
UNAME = "guest";
- new_play_do ("computer");
+ document.getElementById("topuser").innerHTML = "Welcome!";
+ document.getElementById("loginform").style.display = "none";
+ document.getElementById("topright-register").style.display = "none";
+ document.getElementById("topright").style.display = "inline";
+ document.getElementById("logoutbt").style.display = "none";
+ document.getElementById("welcome").style.display = "none";
+ new_play_do ("computer", 0);
}
-function new_play_do (opp_uid) {
+function new_play_do (opp_uid, vm) {
list_plays (GAME_NAME)
game_click (GAME_NAME)
document.getElementById ("game-title").innerHTML = GAME_NAME;
@@ -373,7 +427,7 @@
FREE_PLAY_NO = parseInt(info_nbr.substring(0, info_idx));
document.getElementById("play-number").innerHTML = "" + FREE_PLAY_NO;
CUR_PLAY_I = PLAYS.length;
- VIEW_MIRROR = 0;
+ VIEW_MIRROR = vm;
document.getElementById("cur-player").innerHTML = disp_name(UNAME);
document.getElementById("game-disp").style.display = "block";
document.getElementById("plays").style.left = "30em";
@@ -391,6 +445,32 @@
FRIENDS = convert_python_list (',', lst);
}
+function play_anew (me_starts) {
+ document.getElementById('payoffs').innerHTML = "Not Finished Yet";
+ document.getElementById('payoffs').style.display = "none";
+ document.getElementById('new-play-par').style.display = "none";
+ toggle_suggestions ();
+ toggle_suggestions ();
+ clear_svg ();
+ if (me_starts) {
+ var opp = PLAYS[CUR_PLAY_I][1];
+ if (PLAYS[CUR_PLAY_I][0] != UNAME) { opp = PLAYS[CUR_PLAY_I][0]; }
+ new_play_do (opp, 0);
+ } else {
+ var opp = PLAYS[CUR_PLAY_I][1];
+ if (PLAYS[CUR_PLAY_I][0] != UNAME) { opp = PLAYS[CUR_PLAY_I][0]; }
+ var me = UNAME;
+ UNAME = opp;
+ var vm = (GAME_NAME == "Connect4") ? 0 : 1;
+ new_play_do (me, vm);
+ UNAME = me;
+ if (opp == "computer") {
+ var mv_time = document.getElementById("speed").value;
+ suggest_move_async (mv_time, make_move);
+ }
+ }
+}
+
function decrease_moving (n) {
document.getElementById("working").innerHTML = "Moving in " + n + "s ...";
if (n > 0) {
@@ -398,43 +478,44 @@
}
}
-function suggest_move_async (f) {
- document.getElementById("working").innerHTML = "Moving in 5s ...";
- document.getElementById("working").style.display = "block";
- setTimeout("decrease_moving(4)", 1000)
+function show_moving_msg (n) {
+ if (n > 1) {
+ document.getElementById("working").innerHTML = "Moving in "+ n+ "s ...";
+ document.getElementById("working").style.display = "block";
+ setTimeout("decrease_moving(" + (n-1) + ")", 1000);
+ }
+}
+
+function suggest_move_async (time, f) {
+ show_moving_msg (time);
var fm = function (m) {
document.getElementById("working").style.display = "none";
document.getElementById("working").innerHTML = "Working...";
if (m != "") { show_move (m); f() }
};
- async_srv("SUGGEST", 'c, 5, '+ play_py_id (CUR_PLAY_I), fm);
+ async_srv("SUGGEST", 'c, ' + time + ', '+ play_py_id (CUR_PLAY_I), fm);
}
function suggest_move_click () {
- suggest_move_async (function () {});
+ var mv_time = document.getElementById("speed").value;
+ suggest_move_async (mv_time, function () {});
}
-function suggest_move_better_click () {
- document.getElementById("working").innerHTML = "Moving in 10s ...";
- document.getElementById("working").style.display = "block";
- setTimeout("decrease_moving(9)", 1000)
- var fm = function (m) {
- document.getElementById("working").style.display = "none";
- document.getElementById("working").innerHTML = "Working...";
- if (m != "") { show_move (m); f() }
- };
- async_srv("SUGGEST", 'c, 10, '+ play_py_id (CUR_PLAY_I), fm);
-}
-
function toggle_suggestions () {
var txt = document.getElementById("suggestions-toggle").innerHTML;
- if (txt.indexOf ("Show") == -1) {
+ if (txt.indexOf ("Before") == -1) {
+ SIMPLE_MOVES = true;
+ document.getElementById("play-nbr-info").style.display = "none";
+ document.getElementById("board").style.paddingTop = "1em";
document.getElementById("suggestions-toggle").innerHTML =
- "Show Move Suggestions";
- document.getElementById("player-info-par").style.display = "none";
+ "Ask Before Move";
+ document.getElementById("move-info-par").style.display = "none";
} else {
+ SIMPLE_MOVES = false;
+ document.getElementById("play-nbr-info").style.display = "inline";
+ document.getElementById("board").style.paddingTop = "0em";
document.getElementById("suggestions-toggle").innerHTML =
- "Hide Move Suggestions";
- document.getElementById("player-info-par").style.display = "block";
+ "Move Without Asking";
+ document.getElementById("move-info-par").style.display = "block";
}
}
Modified: trunk/Toss/WebClient/Style.css
===================================================================
--- trunk/Toss/WebClient/Style.css 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/Style.css 2011-05-15 22:48:50 UTC (rev 1442)
@@ -116,6 +116,25 @@
top: 2px;
}
+#speed {
+ position: relative;
+ top: -2px;
+ font-weight: bold;
+ font-family: Verdana, 'TeXGyreHerosRegular', sans;
+ color: #400827;
+ background-color: #fff1d4;
+ border-color: #fff1d4;
+ border-radius: 4px;
+ -moz-border-radius: 4px;
+ border-width: 1px;
+}
+
+.speed_val {
+ color: #400827;
+ background-color: #fff1d4;
+ border-color: #400827;
+}
+
.forminput {
border-color: #fff1d4;
border-radius: 4px;
@@ -159,7 +178,7 @@
#logoutbt {
position: relative;
- top: -0.2em;
+ top: -0.1em;
font-family: Verdana, 'TeXGyreHerosRegular', sans;
font-size: 1em;
font-weight: bold;
@@ -291,7 +310,7 @@
/* Bottom styles. */
-#contact {
+.contact {
position: absolute;
top: 0px;
right: 0.5em;
@@ -421,7 +440,7 @@
#opponents {
display: none;
- position: absolute;
+ position: fixed;
left: 0px;
right: 0px;
top: 4em;
@@ -523,9 +542,16 @@
#move-info-par {
margin-top: 0.5em;
padding: 0px;
+ display: none;
}
+#new-play-par {
+ display: none;
+ padding: 0px;
+}
+
#board {
+ padding-top: 1em;
min-width: 10em;
max-width: 120em;
width: 100%;
@@ -536,10 +562,10 @@
}
#working {
- position: absolute;
+ position: fixed;
left: 0px;
right: 0px;
- top: 7em;
+ top: 4em;
width: 10em;
margin-left: auto;
margin-right: auto;
@@ -548,6 +574,7 @@
color: #fff1d4;
background-color: #400827;
padding: 1em;
+ border: 1px solid #260314;
}
#opening {
@@ -626,13 +653,18 @@
#svg {
min-width: 10em;
max-width: 120em;
- width: 75%;
+ width: 80%;
min-height: 10em;
- max-height: 35em;
- height: 75%;
+ max-height: 40em;
+ height: 80%;
/* border: 1px solid #260314; */
}
+#board_connect4 {
+ fill: blue;
+ stroke: #260314;
+}
+
.model-elem, .model-elem-0, .model-elem-1 {
fill: #ffe4aa; /* #ffce9e; */
stroke: #260314;
@@ -659,17 +691,35 @@
stroke-width: 3px;
}
+.Game-Connect4 .model-elem-highlight {
+ opacity: 0.3;
+}
+
+
.model-pred-P {
fill: #400827;
stroke: #260314;
stroke-width: 5px;
}
+.Game-Connect4 .model-pred-P {
+ fill: red;
+ stroke: #260314;
+ stroke-width: 3px;
+}
+
.model-pred-Q {
fill: #ffe4aa; /* #ffce9e; */
stroke: #260314;
+ stroke-width: 3px;
}
+.Game-Connect4 .model-pred-Q {
+ fill: yellow;
+ stroke: #260314;
+ stroke-width: 3px;
+}
+
.model-pred-C {
fill: #fff1d4;
stroke: #260314;
@@ -695,13 +745,13 @@
}
.Game-Checkers .model-pred-B {
- fill: #fff1d4;
+ fill: white;
stroke: #260314;
stroke-width: 3px;
}
.Game-Checkers .model-pred-W {
- fill: #400827;
+ fill: red;
stroke: #260314;
stroke-width: 3px;
}
@@ -712,8 +762,7 @@
stroke-width: 3px;
}
-.Game-Chess .chessW .chess-path-A, .Game-Pawn-Whopping .chessW .chess-path-A,
- .Game-Checkers .chessB .chess-path-A {
+.Game-Chess .chessW .chess-path-A, .Game-Pawn-Whopping .chessW .chess-path-A {
opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
@@ -728,9 +777,23 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-A, .Game-Pawn-Whopping .chessB .chess-path-A,
- .Game-Checkers .chessW .chess-path-A {
+.Game-Checkers .chessB .chess-path-A {
opacity: 1;
+ fill: white;
+ fill-opacity: 1;
+ fill-rule: nonzero;
+ stroke: #260314;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: miter;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-dashoffset: 10;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessB .chess-path-A, .Game-Pawn-Whopping .chessB .chess-path-A {
+ opacity: 1;
fill: #400827;
fill-opacity: 1;
fill-rule: nonzero;
@@ -744,9 +807,23 @@
stroke-opacity: 1;
}
-.Game-Chess .chessW .chess-path-B, .Game-Pawn-Whopping .chessW .chess-path-B,
- .Game-Checkers .chessB .chess-path-B {
+.Game-Checkers .chessW .chess-path-A {
opacity: 1;
+ fill: red;
+ fill-opacity: 1;
+ fill-rule: nonzero;
+ stroke: #260314;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: miter;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-dashoffset: 10;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessW .chess-path-B, .Game-Pawn-Whopping .chessW .chess-path-B {
+ opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
fill-rule: evenodd;
@@ -759,9 +836,22 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-B, .Game-Pawn-Whopping .chessB .chess-path-B,
- .Game-Checkers .chessW .chess-path-B {
+.Game-Checkers .chessB .chess-path-B {
opacity: 1;
+ fill: white;
+ fill-opacity: 1;
+ fill-rule: evenodd;
+ stroke: #260314;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: round;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessB .chess-path-B, .Game-Pawn-Whopping .chessB .chess-path-B {
+ opacity: 1;
fill: #400827;
fill-opacity: 1;
fill-rule: evenodd;
@@ -774,9 +864,22 @@
stroke-opacity: 1;
}
+.Game-Checkers .chessW .chess-path-B {
+ opacity: 1;
+ fill: red;
+ fill-opacity: 1;
+ fill-rule: evenodd;
+ stroke: #260314;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: round;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
-.Game-Chess .chessW .chess-path-Bx, .Game-Pawn-Whopping .chessW .chess-path-Bx,
- .Game-Checkers .chessB .chess-path-Bx {
+
+.Game-Chess .chessW .chess-path-Bx, .Game-Pawn-Whopping .chessW .chess-path-Bx {
opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
@@ -790,9 +893,22 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-Bx, .Game-Pawn-Whopping .chessB .chess-path-Bx,
- .Game-Checkers .chessW .chess-path-Bx {
+.Game-Checkers .chessB .chess-path-Bx {
opacity: 1;
+ fill: white;
+ fill-opacity: 1;
+ fill-rule: evenodd;
+ stroke: #260314;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: round;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessB .chess-path-Bx, .Game-Pawn-Whopping .chessB .chess-path-Bx {
+ opacity: 1;
fill: #fff1d4;
fill-opacity: 1;
fill-rule: evenodd;
@@ -805,9 +921,22 @@
stroke-opacity: 1;
}
-.Game-Chess .chessW .chess-path-C, .Game-Pawn-Whopping .chessW .chess-path-C,
- .Game-Checkers .chessB .chess-path-C {
+.Game-Checkers .chessW .chess-path-Bx {
opacity: 1;
+ fill: white;
+ fill-opacity: 1;
+ fill-rule: evenodd;
+ stroke: #400827;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: round;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessW .chess-path-C, .Game-Pawn-Whopping .chessW .chess-path-C {
+ opacity: 1;
fill: #400827;
fill-opacity: 1;
stroke: #260314;
@@ -819,8 +948,20 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-C, .Game-Pawn-Whopping .chessB .chess-path-C,
- .Game-Checkers .chessW .chess-path-C {
+.Game-Checkers .chessB .chess-path-C {
+ opacity: 1;
+ fill: red;
+ fill-opacity: 1;
+ stroke: #260314;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: round;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessB .chess-path-C, .Game-Pawn-Whopping .chessB .chess-path-C {
opacity:1;
fill: #fff1d4;
fill-opacity: 1;
@@ -833,8 +974,20 @@
stroke-opacity: 1;
}
-.Game-Chess .chessW .chess-path-D, .Game-Pawn-Whopping .chessW .chess-path-D,
- .Game-Checkers .chessB .chess-path-D {
+.Game-Checkers .chessW .chess-path-C {
+ opacity:1;
+ fill: white;
+ fill-opacity: 1;
+ stroke: white;
+ stroke-width: 1.5;
+ stroke-linecap: round;
+ stroke-linejoin: round;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessW .chess-path-D, .Game-Pawn-Whopping .chessW .chess-path-D {
fill: #fff1d4;
fill-opacity: 0.75;
fill-rule: evenodd;
@@ -847,8 +1000,20 @@
stroke-opacity: 1;
}
-.Game-Chess .chessB .chess-path-D, .Game-Pawn-Whopping .chessB .chess-path-D,
- .Game-Checkers .chessW .chess-path-D {
+.Game-Checkers .chessB .chess-path-D {
+ fill: white;
+ fill-opacity: 0.75;
+ fill-rule: evenodd;
+ stroke: #260314;
+ stroke-width: 1;
+ stroke-linecap: round;
+ stroke-linejoin: miter;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
+
+.Game-Chess .chessB .chess-path-D, .Game-Pawn-Whopping .chessB .chess-path-D {
fill: #400827;
fill-opacity: 0.75;
fill-rule: evenodd;
@@ -860,3 +1025,16 @@
stroke-dasharray: none;
stroke-opacity: 1;
}
+
+.Game-Checkers .chessW .chess-path-D {
+ fill: red;
+ fill-opacity: 0.75;
+ fill-rule: evenodd;
+ stroke: #260314;
+ stroke-width: 1;
+ stroke-linecap: round;
+ stroke-linejoin: miter;
+ stroke-miterlimit: 4;
+ stroke-dasharray: none;
+ stroke-opacity: 1;
+}
Deleted: trunk/Toss/WebClient/contact.html
===================================================================
--- trunk/Toss/WebClient/contact.html 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/contact.html 2011-05-15 22:48:50 UTC (rev 1442)
@@ -1,50 +0,0 @@
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xmlns:svg="http://www.w3.org/2000/svg" xml:lang="en" lang="en">
-<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" />
- <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="Login.js"> </script>
-</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="register-content">
-
-<h2>Contact tPlay</h2>
-
-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>
-
-<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://www.apronus.com/chess/wbeditor.php">Chess
- on Apronus</a></li>
-</ul>
-
-</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/index.html
===================================================================
--- trunk/Toss/WebClient/index.html 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/index.html 2011-05-15 22:48:50 UTC (rev 1442)
@@ -47,6 +47,17 @@
</form>
</div>
<span id="topright">
+ Speed: <select id="speed">
+ <option class="speed_val" value="1">1s</option>
+ <option class="speed_val" value="2">2s</option>
+ <option class="speed_val" value="3">3s</option>
+ <option class="speed_val" value="4">4s</option>
+ <option class="speed_val" value="5">5s</option>
+ <option class="speed_val" value="10">10s</option>
+ <option class="speed_val" value="15">15s</option>
+ <option class="speed_val" value="30">30s</option>
+ <option class="speed_val" value="60">60s</option>
+ </select>
<button id="logoutbt" onclick="logout()">Logout</button>
</span>
<span id="topright-register">
@@ -69,49 +80,44 @@
</div>
<div id="welcome">
-<p id="welcome-top">Enjoy the best games on <span class="logo-in">tPlay</span> for free</p>
-<p>
+<p id="welcome-top">Enjoy the best games on <span class="logo-in">tPlay</span>
+ for free</p>
+<p id="p-under-welcome" style="display: none;">
Strategic games are fun!
<a href="register.html">Register</a>, login and enjoy quality games
with our best interface on <span class="logo-in">tPlay</span>!
</p>
<p style="width:100%; text-align: justify">
-<button onclick="new_play_guest('Breakthrough')" style="width:24%"
- class="boldobt" title="Play Breakthrough">
- <img style="max-width:95%" src="pics/Breakthrough.png" alt="Breakthrough Board">
-</button>
-<button onclick="new_play_guest('Checkers')" style="width:24%"
- class="boldobt" title="Play Checkers">
- <img style="max-width:95%" src="pics/Checkers.png" alt="Checkers Board">
-</button>
-<button onclick="new_play_guest('Chess')" style="width:24%"
+<button onclick="new_play_guest('Chess')" style="width:32%"
class="boldobt" title="Play Chess">
- <img style="max-width:95%" src="pics/Chess.png" alt="Chess Board">
+ <img style="max-width:95%" src="pics/Chess.png" alt="Chess Board" />
</button>
-<button onclick="new_play_guest('Connect4')" style="width:24%"
+<button onclick="new_play_guest('Connect4')" style="width:32%"
class="boldobt" title="Play Connect4">
- <img style="max-width:95%" src="pics/Connect4.png" alt="Connect4 Board">
+ <img style="max-width:95%" src="pics/Connect4.png" alt="Connect4 Board" />
</button>
+<button onclick="new_play_guest('Pawn-Whopping')" style="width:32%"
+ class="boldobt" title="Play Pawn-Whopping">
+ <img style="max-width:95%" src="pics/Pawn-Whopping.png"
+ alt="Pawn-Whopping Board" />
+</button>
</p>
<p style="width:100%; text-align: justify">
-<button onclick="new_play_guest('Entanglement')" style="width:24%"
- class="boldobt" title="Play Entanglement">
- <img style="max-width:95%" src="pics/Entanglement.png" alt="Entanglement Board">
+<button onclick="new_play_guest('Breakthrough')" style="width:32%"
+ class="boldobt" title="Play Breakthrough">
+ <img style="max-width:95%" src="pics/Breakthrough.png"
+ alt="Breakthrough Board" />
</button>
-<button onclick="new_play_guest('Gomoku')" style="width:24%"
+<button onclick="new_play_guest('Checkers')" style="width:32%"
+ class="boldobt" title="Play Checkers">
+ <img style="max-width:95%" src="pics/Checkers.png" alt="Checkers Board" />
+</button>
+<button onclick="new_play_guest('Gomoku')" style="width:32%"
class="boldobt" title="Play Gomoku">
- <img style="max-width:95%" src="pics/Gomoku.png" alt="Gomoku Board">
+ <img style="max-width:95%" src="pics/Gomoku.png" alt="Gomoku Board" />
</button>
-<button onclick="new_play_guest('Pawn-Whopping')" style="width:24%"
- class="boldobt" title="Play Pawn-Whopping">
- <img style="max-width:95%" src="pics/Pawn-Whopping.png" alt="Pawn-Whopping Board">
-</button>
-<button onclick="new_play_guest('Tic-Tac-Toe')" style="width:24%"
- class="boldobt" title="Play Tic-Tac-Toe">
- <img style="max-width:95%" src="pics/Tic-Tac-Toe.png" alt="Tic-Tac-Toe Board">
-</button>
</p>
<ul class="welcome-list">
@@ -131,11 +137,8 @@
<a href="http://en.wikipedia.org/wiki/Pawn_(chess)"
>Pawn-Whopping,</a>
and many other board games</li>
+<li>Focus fully on the game thanks to our intuitive clean interface</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>
@@ -231,34 +234,42 @@
<div id="game-disp">
<p id="game-info-par">
<span id="game-title"></span>
- game <span id="play-number">?</span>
+ <span id="play-nbr-info" style="display:none;">
+ (game <span id="play-number">?</span>)
+ </span>
+ <span id="payoffs" style="display:none;">Not Finished Yet</span>
</p>
+ <p id="new-play-par">
+ <button id="new_game_me" class="bt" onclick="play_anew(true)">
+ New Game (You Start)
+ </button>
+ <button id="new_game_opp" class="bt" onclick="play_anew(false)">
+ New Game (Opponent Starts)
+ </button>
+ </p>
+
<p id="move-info-par">
+ <span style="display: none;">Moves: <span id="cur-player">?</span></span>
<button id="movebt" class="bt" onclick="make_move ()">Make move:</button>
- <span id="cur-move">none</span>
- </p>
-
- <p id="player-info-par">
- Moving: <span id="cur-player">?</span>
+ <span id="cur-move">none</span>
<button id="sugbt" class="bt" onclick="suggest_move_click()">
- Suggest (weak, fast)
+ Suggest
</button>
- <button id="sugbts" class="bt" onclick="suggest_move_better_click()">
- Suggest (stronger, slow)
- </button>
</p>
-
<div id="board"><div id="working">Working...</div></div>
</div>
<div id="bottom">
<button id="suggestions-toggle" onclick="toggle_suggestions()">
- Show Move Suggestions
+ Ask Before Move
</button>
<a href="http://toss.sourceforge.net" id="toss-link">Powered by Toss</a>
-<a href="contact.html" id="contact">Contact and Info</a>
+<script type="text/javascript">begin_mailto(
+ "tossplay", "gmail.com", "Contact Us");</script>
+tossplay [AT] gmail [DOT] com
+<script type="text/javascript">end_mailto();</script>
</div>
</div>
Modified: trunk/Toss/WebClient/pics/Breakthrough.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/WebClient/pics/Checkers.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/WebClient/pics/Chess.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/WebClient/pics/Connect4.png
===================================================================
(Binary files differ)
Modified: trunk/Toss/WebClient/pics/Connect4.svg
===================================================================
--- trunk/Toss/WebClient/pics/Connect4.svg 2011-05-14 14:30:21 UTC (rev 1441)
+++ trunk/Toss/WebClient/pics/Connect4.svg 2011-05-15 22:48:50 UTC (rev 1442)
@@ -1,2 +1,2 @@
-<?xml-stylesheet href="Style.css" type="text/css"?>
-<svg id="svg" viewBox="0 0 580 580"><rect class="model-elem-0" x="15" y="515" width="50" height="50" id="elem_a1" ></rect><rect class="model-elem-1" x="98.33333333333333" y="515" width="50" height="50" id="elem_b1" ></rect><rect class="model-elem-0" x="181.66666666666666" y="515" width="50" height="50" id="elem_c1" ></rect><rect class="model-elem-1" x="265" y="515" width="50" height="50" id="elem_d1" ></rect><rect class="model-elem-0" x="348.3333333333333" y="515" width="50" height="50" id="elem_e1" ></rect><rect class="model-elem-1" x="431.6666666666667" y="515" width="50" height="50" id="elem_f1" ></rect><rect class="model-elem-0" x="515" y="515" width="50" height="50" id="elem_g1" ></rect><rect class="model-elem-1" x="15" y="415" width="50" height="50" id="elem_a2" ></rect><rect class="model-elem-0" x="98.33333333333333" y="415" width="50" height="50" id="elem_b2" ></rect><rect class="model-elem-1" x="181.66666666666666" y="415" width="50" height="50" id="elem_c2" ></rect><rect class="model-elem-0" x="265" y="415" width="50" height="50" id="elem_d2" ></rect><rect class="model-elem-1" x="348.3333333333333" y="415" width="50" height="50" id="elem_e2" ></rect><rect class="model-elem-0" x="431.6666666666667" y="415" width="50" height="50" id="elem_f2" ></rect><rect class="model-elem-1" x="515" y="415" width="50" height="50" id="elem_g2" ></rect><rect class="model-elem-0" x="15" y="315" width="50" height="50" id="elem_a3" ></rect><rect class="model-elem-1" x="98.33333333333333" y="315" width="50" height="50" id="elem_b3" ></rect><rect class="model-elem-0" x="181.66666666666666" y="315" width="50" height="50" id="elem_c3" ></rect><rect class="model-elem-1" x="265" y="315" width="50" height="50" id="elem_d3" ></rect><rect class="model-elem-0" x="348.3333333333333" y="315" width="50" height="50" id="elem_e3" ></rect><rect class="model-elem-1" x="431.6666666666667" y="315" width="50" height="50" id="elem_f3" ></rect><rect class="model-elem-0" x="515" y="315" width="50" height="50" id="elem_g3" ></rect><rect class="model-elem-1" x="15" y="215" width="50" height="50" id="elem_a4" ></rect><rect class="model-elem-0" x="98.33333333333333" y="215" width="50" height="50" id="elem_b4" ></rect><rect class="model-elem-1" x="181.66666666666666" y="215" width="50" height="50" id="elem_c4" ></rect><rect class="model-elem-0" x="265" y="215" width="50" height="50" id="elem_d4" ></rect><rect class="model-elem-1" x="348.3333333333333" y="215" width="50" height="50" id="elem_e4" ></rect><rect class="model-elem-0" x="431.6666666666667" y="215" width="50" height="50" id="elem_f4" ></rect><rect class="model-elem-1" x="515" y="215" width="50" height="50" id="elem_g4" ></rect><rect class="model-elem-0" x="15" y="115" width="50" height="50" id="elem_a5" ></rect><rect class="model-elem-1" x="98.33333333333333" y="115" width="50" height="50" id="elem_b5" ></rect><rect class="model-elem-0" x="181.66666666666666" y="115" width="50" height="50" id="elem_c5" ></rect><rect class="model-elem-1" x="265" y="115" width="50" height="50" id="elem_d5" ></rect><rect class="model-elem-0" x="348.3333333333333" y="115" width="50" height="50" id="elem_e5" ></rect><rect class="model-elem-1" x="431.6666666666667" y="115" width="50" height="50" id="elem_f5" ></rect><rect class="model-elem-0" x="515" y="115" width="50" height="50" id="elem_g5" ></rect><rect class="model-elem-1" x="15" y="15" width="50" height="50" id="elem_a6" ></rect><rect class="model-elem-0" x="98.33333333333333" y="15" width="50" height="50" id="elem_b6" ></rect><rect class="model-elem-1" x="181.66666666666666" y="15" width="50" height="50" id="elem_c6" ></rect><rect class="model-elem-0" x="265" y="15" width="50" height="50" id="elem_d6" ></rect><rect class="model-elem-1" x="348.3333333333333" y="15" width="50" height="50" id="elem_e6" ></rect><rect class="model-elem-0" x="431.6666666666667" y="15" width="50" height="50" id="elem_f6" ></rect><rect class="model-elem-1" x="515" y="15" width="50" height="50" id="elem_g6" ></rect><circle class="model-pred-Q" cx="206.66666666666666" cy="540" r="13" id="pred_c1_Q" stroke-width="4.5" ></circle><circle class="model-pred-Q" cx="373.3333333333333" cy="540" r="13" id="pred_e1_Q" stroke-width="4.5" ></circle><circle class="model-pred-Q" cx="206.66666666666666" cy="440" r="13" id="pred_c2_Q" stroke-width="4.5" ></circle><circle class="model-pred-Q" cx="456.6666666666667" cy="440" r="13" id="pred_f2_Q" stroke-width="4.5" ></circle><circle class="model-pred-Q" cx="290" cy="340" r="13" id="pred_d3_Q" stroke-width="4.5" ></circle><g transform="translate(290,540) scale(1.25,1.25)"><g class="model-pred-P" id="pred_d1_P" ><line x1="-10" y1="-10" x2="10" y2="10"></line><line x1="10" y1="-10" x2="-10" y2="10"></line></g> </g><g transform="translate(456.6666666666667,540) scale(1.25,1.25)"><g class="model-pred-P" id="pred_f1_P" ><line x1="-10" y1="-10" x2="10" y2="10"></line><line x1="10" y1="-10" x2="-10" y2="10"></line></g> </g><g transform="translate(290,440) scale(1.25,1.25)"><g class="model-pred-P" id="pred_d2_P" ><line x1="-10" y1="-10" x2="10" y2="10"></line><line x1="10" y1="-10" x2="-10" y2="10"></line></g> </g><g transform="translate(373.3333333333333,440) scale(1.25,1.25)"><g class="model-pred-P" id="pred_e2_P" ><line x1="-10" y1="-10" x2="10" y2="10"></line><line x1="10" y1="-10" x2="-10" y2="10"></line></g> </g><g transform="translate(456.6666666666667,340) scale(1.25,1.25)"><g class="model-pred-P" id="pred_f3_P" ><line x1="-10" y1="-10" x2="10" y2="10"></line><line x1="10" y1="-10" x2="-10" y2="10"></line></g> </g></svg>
+<?xml-stylesheet href="Style3.css" type="text/css"?>
+<svg id="svg" viewBox="-10 -10 600 600"><rect x="0" y="0" width="580" height="580" stroke-width="5" rx="5" ry="5" id="board_connect4"></rect><g transform="translate(40,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_a1" class="model-elem-0" ></circle></g><g transform="translate(123.33333333333333,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_b1" class="model-elem-1" ></circle></g><g transform="translate(206.66666666666666,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_c1" class="model-elem-0" ></circle></g><g transform="translate(290,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_d1" class="model-elem-1" ></circle></g><g transform="translate(373.3333333333333,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_e1" class="model-elem-0" ></circle></g><g transform="translate(456.6666666666667,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_f1" class="model-elem-1" ></circle></g><g transform="translate(540,540) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_g1" class="model-elem-0" ></circle></g><g transform="translate(40,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_a2" class="model-elem-1" ></circle></g><g transform="translate(123.33333333333333,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_b2" class="model-elem-0" ></circle></g><g transform="translate(206.66666666666666,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_c2" class="model-elem-1" ></circle></g><g transform="translate(290,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_d2" class="model-elem-0" ></circle></g><g transform="translate(373.3333333333333,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_e2" class="model-elem-1" ></circle></g><g transform="translate(456.6666666666667,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_f2" class="model-elem-0" ></circle></g><g transform="translate(540,440) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_g2" class="model-elem-1" ></circle></g><g transform="translate(40,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_a3" class="model-elem-0" ></circle></g><g transform="translate(123.33333333333333,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_b3" class="model-elem-1" ></circle></g><g transform="translate(206.66666666666666,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_c3" class="model-elem-0" ></circle></g><g transform="translate(290,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_d3" class="model-elem-1" ></circle></g><g transform="translate(373.3333333333333,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_e3" class="model-elem-0" ></circle></g><g transform="translate(456.6666666666667,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_f3" class="model-elem-1" ></circle></g><g transform="translate(540,340) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_g3" class="model-elem-0" ></circle></g><g transform="translate(40,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_a4" class="model-elem-1" ></circle></g><g transform="translate(123.33333333333333,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_b4" class="model-elem-0" ></circle></g><g transform="translate(206.66666666666666,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_c4" class="model-elem-1" ></circle></g><g transform="translate(290,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_d4" class="model-elem-0" ></circle></g><g transform="translate(373.3333333333333,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_e4" class="model-elem-1" ></circle></g><g transform="translate(456.6666666666667,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_f4" class="model-elem-0" ></circle></g><g transform="translate(540,240) scale(1.5,1.5)"><circle cx="0" cy="0" r="20" id="elem_g4" class="model-elem-1" ></circle></g><g transform="translate(40,140) scale(1.5,1.5)"><circle cx="0" cy="0" r=...
[truncated message content] |
|
From: <luk...@us...> - 2011-05-14 14:30:28
|
Revision: 1441
http://toss.svn.sourceforge.net/toss/?rev=1441&view=rev
Author: lukaszkaiser
Date: 2011-05-14 14:30:21 +0000 (Sat, 14 May 2011)
Log Message:
-----------
Small correction: handle params in GET urls (make toss.sourceforge.net games work again).
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-13 23:33:56 UTC (rev 1440)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-14 14:30:21 UTC (rev 1441)
@@ -389,7 +389,9 @@
Printf.printf "Cookies: %s\n%!" (String.concat "; " ck_strs);
);
let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
- let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
+ let fname_in1 = if fname_in0 = "" then "index.html" else fname_in0 in
+ let fname_in = try String.sub fname_in1 0 (String.index fname_in1 '?')
+ with Not_found -> fname_in1 in
let fname = !html_dir_path ^ fname_in in
if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
if Sys.file_exists fname then (
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-13 23:34:02
|
Revision: 1440
http://toss.svn.sourceforge.net/toss/?rev=1440&view=rev
Author: lukaszkaiser
Date: 2011-05-13 23:33:56 +0000 (Fri, 13 May 2011)
Log Message:
-----------
Add cache expiration to http GET answers.
Modified Paths:
--------------
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Connect.js
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-13 23:17:33 UTC (rev 1439)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-13 23:33:56 UTC (rev 1440)
@@ -353,7 +353,7 @@
(* ------------ Http Handlers ------------ *)
-let http_msg code mimetp cookies s =
+let http_msg get code mimetp cookies s =
let get_tm s =
let t = Unix.gmtime (Unix.gettimeofday() +. s) in
let day = match t.Unix.tm_wday with
@@ -371,7 +371,12 @@
| None -> c ^ "httponly"
| Some t -> c ^ "Expires=" ^ (get_tm t) ^ "; httponly" in
let cookies_s = String.concat "\n" (List.map ck_str cookies) in
- "HTTP/1.1 " ^ code ^ "\r\n" ^
+ let expires_str = if not get then "" else
+ "Expires: " ^ (get_tm (float (40 * 24 * 3600))) ^ "\r\n" in
+ "HTTP/1.1 " ^ code ^ "\r\n" ^
+ "Date: " ^ (get_tm 0.) ^ "\r\n" ^
+ "Server: Toss\r\n" ^
+ expires_str ^
"Content-Type: " ^ mimetp ^ "\r\n" ^
(if cookies = [] then "" else cookies_s ^ "\r\n") ^
"Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
@@ -399,8 +404,8 @@
| "js" -> "text/javascript"
| "sv" -> "image/svg+xml"
| _ -> "text/html charset=utf-8" in
- http_msg "200 OK" tp [] content
- ) else http_msg "404 NOT FOUND" "text/html charset=utf-8" []
+ http_msg true "200 OK" tp [] content
+ ) else http_msg true "404 NOT FOUND" "text/html charset=utf-8" []
("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
@@ -606,7 +611,7 @@
move_play tp a.(0) a.(1) a.(2) a.(3) a.(4), []
| _ ->
"MOD_PYTHON ERROR ; Traceback: Unknown Toss Command! \n " ^ tcmd, [] in
- http_msg "200 OK" "text/html charset=utf-8" new_cookies resp
+ http_msg false "200 OK" "text/html charset=utf-8" new_cookies resp
let handle_http_msg rstate cmd head msg ck =
Modified: trunk/Toss/WebClient/Connect.js
===================================================================
--- trunk/Toss/WebClient/Connect.js 2011-05-13 23:17:33 UTC (rev 1439)
+++ trunk/Toss/WebClient/Connect.js 2011-05-13 23:33:56 UTC (rev 1440)
@@ -65,7 +65,7 @@
// Send [msg] to server and return response text.
function sync_server_msg (msg) {
var xml_request = new XMLHttpRequest ();
- xml_request.open ('POST', 'Handler.py', false);
+ xml_request.open ('POST', 'Handler', false);
xml_request.setRequestHeader ('Content-Type',
'application/x-www-form-urlencoded; charset=UTF-8');
xml_request.send (msg);
@@ -80,7 +80,7 @@
// Send [msg] to server asynchronously, ignore response text.
function async_server_msg (msg, f) {
var xml_request = new XMLHttpRequest ();
- xml_request.open ('POST', 'Handler.py', true);
+ xml_request.open ('POST', 'Handler', true);
xml_request.setRequestHeader ('Content-Type',
'application/x-www-form-urlencoded; charset=UTF-8');
xml_request.onreadystatechange = function () {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-13 23:17:41
|
Revision: 1439
http://toss.svn.sourceforge.net/toss/?rev=1439&view=rev
Author: lukstafi
Date: 2011-05-13 23:17:33 +0000 (Fri, 13 May 2011)
Log Message:
-----------
Reference specification of GDL translation: subsection {Stable Relations and Fluents} of {Translating Formulas} (may require style corrections).
Modified Paths:
--------------
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-05-13 22:22:02 UTC (rev 1438)
+++ trunk/Toss/www/reference/reference.tex 2011-05-13 23:17:33 UTC (rev 1439)
@@ -90,6 +90,8 @@
\newcommand{\mgu}{\ensuremath{\mathrm{MGU}}}
\newcommand{\ot}{\leftarrow}
\newcommand{\tpos}{\downharpoonleft}
+\newcommand{\TrRels}{\ensuremath{\mathrm{TrRels}}}
+\newcommand{\TrST}{\ensuremath{\mathrm{TrST}}}
% Theorem environments
\theoremstyle{plain}
@@ -1463,12 +1465,14 @@
the \emph{subterm equality relation} $Eq_{p,q}$:
\[ Eq_{p,q}(a_1,a_2) \ \ \iff \ \ a_1\tpos^m_{p}\ =\ a_2\tpos^m_{q}. \]
-\noindent \textbf{Fact relations.}
-For all predicates $R$ of $G$ that do not (directly or indirectly) depend
-on the state, and all pairs of paths $p,q \in \calP_m$, we introduce
-the \emph{fact relation} $R_{p,q}$:
-\[ R_{p,q}(a_1,a_2) \ \ \iff \ \ R(a_1\tpos^m_{p},\ a_2\tpos^m_{q})
- \text{ in any state}. \]
+\noindent \textbf{Fact relations.} For all relations $R$ of $G$ that
+do not (directly or indirectly) depend on the state, and all tuples of
+paths $p_1,\ldots,p_n \in \calP_m$, we introduce the \emph{fact
+ relation} $R_{p_1,\ldots,p_n}$:
+\[
+R_{p_1,\ldots,p_n}(a_1,\ldots,a_n) \ \ \iff \ \ R(a_1\tpos^m_{p_1},\ldots,
+a_n\tpos^m_{p_n}) \text{ in any state}.
+\]
\noindent \textbf{Anchor predicates.}
For all paths $p \in \calP_m$ and subterms $s = t\tpos_p, t \in \calS$,
@@ -1522,7 +1526,7 @@
\emph{Fact relations.}
-The only predicate in the example specification is \texttt{nextcol}
+The only relation in the example specification is \texttt{nextcol}
and we thus get the relations $\mathtt{nextcol}_{i, j}$.
For example, the relation
\begin{align*}
@@ -1820,7 +1824,9 @@
the \texttt{terminal} condition and specific \texttt{goal} value
conditions are translated as described in
Section~\ref{subsec-translate}, from disjunctions of bodies of their
-respective clauses.
+respective clauses. Actually, instead of ``freshening'' the clauses
+and translating the disjunction of their bodies, we (equivalently)
+form disjunction of translations of each body.
\subsection{Translating Moves between Toss and GDL} \label{subsec-move-tr}
@@ -1848,25 +1854,81 @@
\subsection{Translating Formulas} \label{subsec-translate}
+First we describe translation in the case all GDL relations other than
+\texttt{next} are stable, \ie do not even indirectly depend on
+\texttt{true}. A stable GDL relation is translated as multiple stable
+Toss relations. Then we approach the GDL relations (other than
+\texttt{next}) that depend on \texttt{true} by translating them as
+defined relations in Toss.
+
\subsubsection{Stable Relations and Fluents}
-Divide Phi into the part other than \texttt{true}: LitsPhi (can
-contain disjunctions), positive \texttt{true} literals: Tru+ and
-negative \texttt{true} literals: Tru-.
+We normalize the GDL formula to be translated, which is composed of
+conjunctions, disjunctions and literals, into a disjunction $\Phi_1
+\vee \ldots \vee \Phi_n$, so that every $\Phi_i \equiv G_i \wedge
+ST^{+}_i \wedge ST^{-}_i$, where all literals in $G_i$ are other than
+\texttt{true}, all literals in $ST^{+}_i$ are positive \texttt{true}
+atoms, all literals in $ST^{-}_i$ are negated \texttt{true} atoms. (We
+avoid unnecessary expansions.) Let $\mathrm{ST}(\phi)$ be all the
+state terms, \ie arguments of \texttt{true} atoms, in $\phi$.
-Translate conjunctions as conjunctions, and disjunctions as disjunctions.
+$\TrRels(\phi, S_1, S_2)$ descends $\phi$ translating each literal as a
+conjunction of literals, for every combination of mask paths into $S_1$
+state terms, such that at least one of those terms is from $S_2$.
-Translate TrLits(Phi, Tru1, Tru2) by translating each literal as a
-conjunction of literals, for every combination of mask paths into Tru1
-terms, such that at least one of the terms is from Tru2.
+$\TrST(\phi)$ translates \texttt{true} atoms as a conjunction of their
+anchor and fluent predicates.
-Translate \texttt{true} atoms as a conjunction of their anchor and
-fluent predicates TrTru.
+Let $eqs_i$ be $\Land \big\{ \mathtt{EQ}(x,x) | x \in \fv(\Phi_i)
+\big\}$. The relation name $\mathtt{EQ}$ serves technical purposes:
+fact relations $\mathtt{EQ}_{p,q}$ are identified with subterm
+equality relations $Eq_{p,q}$.
-Translate the whole Phi as ``ex Tru+ (TrLits(LitsPhi, Tru+, Tru+) and
-conj of TrTru(Tru+) and TrLits(ex Tru- (not (TrLits(LitsPhi, Tru+ sum
-Tru-, Tru-) and disj of TrTru(Tru-)))))''.
+The result of translation is the disjunction of translations of each
+$\Phi_i$. A single $\Phi_i \equiv G_i \wedge ST^{+}_i \wedge ST^{-}_i$
+is translated as:
+\begin{align*}
+\exists \mathrm{ST}(ST^{+}_i) \big( & \TrRels(eqs_i
+\wedge G_i, \mathrm{ST}(ST^{+}_i), \mathrm{ST}(ST^{+}_i)) \wedge
+\TrST(ST^{+}_i) \wedge \\ & \neg \exists \mathrm{ST}(ST^{-}_i) \big(
+\TrRels(eqs_i \wedge G_i, \mathrm{ST}(ST^{+}_i) \cup
+\mathrm{ST}(ST^{-}_i), \mathrm{ST}(ST^{-}_i)) \wedge \\ &
+\; \; \; \; \; \; \TrST(\mathtt{NNF}(\neg ST^{-}_i)) \big) \big)
+\end{align*}
+
+We now proceed to define $\TrRels$ and $\TrST$. Let $\mathtt{BL}(t)$
+be the term $t$ with fluent paths replaced with \texttt{BLANK}.
+
+\begin{align*}
+ \TrRels (\phi_1 \wedge \phi_2, S_1, S_2) = &
+ \TrRels (\phi_1, S_1, S_2) \wedge \TrRels(\phi_2, S_1, S_2) \\
+ \TrRels (\phi_1 \vee \phi_2, S_1, S_2) = &
+ \TrRels (\phi_1, S_1, S_2) \vee \TrRels(\phi_2, S_1, S_2) \\
+ \TrRels (R(t_1, \ldots, t_n), S_1, S_2) = & \Land \big\{
+ R_{p_1,\ldots,p_n}(v_1, \ldots, v_n) \; \big| \; s_1,\ldots,s_n \in S_1 \wedge \\
+ & \{s_1,\ldots,s_n \} \cap S_2 \neq \emptyset \wedge
+ v_1 = \mathtt{BL}(s_1) \wedge \ldots \wedge v_n = \mathtt{BL}(s_n) \wedge \\
+ & p_1, \ldots, p_n \in \calP_m \wedge
+ s_1 \tpos_{p_1} = t_1 \wedge \ldots \wedge s_n \tpos_{p_n} = t_n \big\} \\
+ \TrRels (\neg R(t_1, \ldots, t_n), S_1, S_2) = & \Land \big\{
+ \neg R_{p_1,\ldots,p_n}(v_1, \ldots, v_n) \; \big| \; s_1,\ldots,s_n \in S_1 \wedge \\
+ & \{s_1,\ldots,s_n \} \cap S_2 \neq \emptyset \wedge
+ v_1 = \mathtt{BL}(s_1) \wedge \ldots \wedge v_n = \mathtt{BL}(s_n) \wedge \\
+ & p_1, \ldots, p_n \in \calP_m \wedge
+ s_1 \tpos_{p_1} = t_1 \wedge \ldots \wedge s_n \tpos_{p_n} = t_n \big\} \\
+ \TrST (\phi_1 \wedge \phi_2) = &
+ \TrST (\phi_1) \wedge \TrST(\phi_2) \\
+ \TrST (\phi_1 \vee \phi_2) = &
+ \TrST (\phi_1) \vee \TrST(\phi_2) \\
+ \TrST (\mathtt{true}(t)) = & \Land \big\{
+ Anch^s_p(v) \; \big| \; v = \mathtt{BL}(t) \wedge
+ p \in \calP_m \wedge t \tpos_p = s \big\} \wedge \\
+ & \Land \big\{
+ Flu^s_p(v) \; \big| \; v = \mathtt{BL}(t) \wedge
+ p \in \calP_f \wedge t \tpos_p = s \big\}
+\end{align*}
+
\subsubsection{Introducing and Using Defined Relations}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-13 22:22:09
|
Revision: 1438
http://toss.svn.sourceforge.net/toss/?rev=1438&view=rev
Author: lukaszkaiser
Date: 2011-05-13 22:22:02 +0000 (Fri, 13 May 2011)
Log Message:
-----------
WebClient handling fully in TossServer, removing python files.
Modified Paths:
--------------
trunk/Toss/Server/DB.ml
trunk/Toss/Server/DB.mli
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/WebClient/.cvsignore
Removed Paths:
-------------
trunk/Toss/WebClient/Handler.py
trunk/Toss/WebClient/MakeDB.py
trunk/Toss/WebClient/README
trunk/Toss/WebClient/Wrapper.py
Property Changed:
----------------
trunk/Toss/WebClient/
Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/Server/DB.ml 2011-05-13 22:22:02 UTC (rev 1438)
@@ -2,15 +2,94 @@
http://hg.ocaml.info/release/ocaml-sqlite3/file/0e2f7d2cbd12/sqlite3.mli
*)
+let debug_level = ref 0
+
+
+let tID = ref "toss_id_05174_"
+
+let dbFILE = ref ((Unix.getenv "HOME") ^ "/.tossdb.sqlite")
+
+let tGAMES = ref ["Breakthrough"; "Checkers"; "Chess"; "Connect4";
+ "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe"]
+
+let def_gdir = if Sys.file_exists "/usr/share/toss" then
+ "/usr/share/toss/games" else "./examples"
+
+
+(* ------- Toss DB Creation ------- *)
+
+let create_db dbfname games_path games =
+ let db = Sqlite3.db_open dbfname in
+ let exec s = ignore (Sqlite3.exec_not_null_no_headers db (fun _ -> ()) s) in
+ exec ("create table users(id string primary key," ^
+ " name string, surname string, email string, passwd string)");
+ exec ("create table cur_states(playid int primary key," ^
+ " game string, player1 string, player2 string," ^
+ " move int, toss string, loc string, info string, svg string)");
+ exec ("create table old_states(playid int," ^
+ " game string, player1 string, player2 string," ^
+ " move int, toss string, loc string, info string, svg string)");
+ exec ("create table games(game string primary key, toss string)");
+ exec ("create table lock(tid int primary key, locked bool)");
+ exec ("create table friends(id string, fid string)");
+ exec ("insert into lock(tid, locked) values ('" ^ !tID ^ "', 'false')");
+ exec ("insert into users(id, name, surname, email, passwd) values " ^
+ "('computer', 'Computer', 'tPlay', 'co...@tp...', 'xxx')");
+ let insert_game g =
+ let f = open_in (games_path ^ "/" ^ g ^ ".toss") in
+ let toss = Aux.input_file f in
+ close_in f;
+ exec ("insert into games(game, toss) values ('" ^ g ^ "','" ^ toss ^ "')");
+ print_endline ("Added " ^ g) in
+ List.iter insert_game games;
+ ignore (Sqlite3.db_close db);
+ Unix.chmod dbfname 0o777
+
+
+let reload_games dbfname games_path games =
+ let db = Sqlite3.db_open dbfname in
+ let exec s = ignore (Sqlite3.exec_not_null_no_headers db (fun _ -> ()) s) in
+ exec "delete from games";
+ print_endline "Deleted old games";
+ let reload_game g =
+ let f = open_in (games_path ^ "/" ^ g ^ ".toss") in
+ let toss = Aux.input_file f in
+ close_in f;
+ exec ("insert into games(game, toss) values ('" ^ g ^ "','" ^ toss ^ "')");
+ print_endline ("Reloading games: added " ^ g) in
+ List.iter reload_game games;
+ ignore (Sqlite3.db_close db)
+
+
+let renew_db ~games_dir =
+ let nolastslash s =
+ let l = String.length s in
+ if s.[l-1] = '/' then String.sub s 0 (l-1) else s in
+ let gdir = nolastslash games_dir in
+ if Sys.file_exists !dbFILE then (
+ print_endline ("Reloading games into Toss DB (" ^ !dbFILE ^ ")");
+ reload_games !dbFILE gdir !tGAMES;
+ print_endline "Games reloaded";
+ ) else (
+ print_endline ("Creating empty Toss DB (" ^ !dbFILE ^ ")");
+ create_db !dbFILE gdir !tGAMES;
+ print_endline "Created tossdb.sqlite";
+ )
+
+
+
+(* ---------- DB functions wrapper ------------- *)
+
exception DBError of string
let print_row r = Array.iter (fun s -> print_string (s ^ " | ")) r
let print_rows rs = List.iter (fun r -> print_row r; print_endline "") rs
-let apply_cmd dbfile select cmd =
+let rec apply_cmd ?(retried=0) dbfile select cmd =
let (rows, wh_s) = (ref [], if select = "" then "" else " where " ^ select) in
let select_s = cmd ^ wh_s in
+ if not (Sys.file_exists !dbFILE) then create_db !dbFILE def_gdir !tGAMES;
let db = Sqlite3.db_open dbfile in
let add_row r = rows := r :: !rows in
let res = Sqlite3.exec_not_null_no_headers db add_row select_s in
@@ -18,6 +97,11 @@
ignore (Sqlite3.db_close db);
match res with
| Sqlite3.Rc.OK -> (List.rev !rows, nbr_changed)
+ | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED when retried < 20 ->
+ if !debug_level > 0 then
+ Printf.printf "DB busy or locked, retrying %i\n%!" retried;
+ ignore (Unix.select [] [] [] 0.1);
+ apply_cmd ~retried:(retried+1) dbfile select cmd
| x -> raise (DBError (Sqlite3.Rc.to_string x))
let get_table dbfile ?(select="") tbl =
@@ -34,4 +118,4 @@
let update_table dbfile ?(select="") set_s tbl =
snd (apply_cmd dbfile select ("update " ^ tbl ^ " set " ^ set_s))
-
+
Modified: trunk/Toss/Server/DB.mli
===================================================================
--- trunk/Toss/Server/DB.mli 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/Server/DB.mli 2011-05-13 22:22:02 UTC (rev 1438)
@@ -1,5 +1,11 @@
exception DBError of string
+val debug_level : int ref
+
+val tID : string ref
+val dbFILE : string ref
+val tGAMES : string list ref
+
val print_row : string array -> unit
val print_rows : string array list -> unit
@@ -11,3 +17,5 @@
val insert_table : string -> string -> string -> string list -> unit
val update_table : string -> ?select : string -> string -> string -> int
+
+val renew_db : games_dir : string -> unit
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-13 22:22:02 UTC (rev 1438)
@@ -3,7 +3,10 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i;)
+let html_dir_path = ref (if Sys.file_exists "/usr/share/toss" then
+ "/usr/share/toss/html" else "WebClient/")
+
(* ---------- Basic request type and internal handler ---------- *)
type req_state =
@@ -382,7 +385,7 @@
);
let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
- let fname = "WebClient/" ^ fname_in in
+ let fname = !html_dir_path ^ fname_in in
if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
if Sys.file_exists fname then (
let f = open_in fname in
@@ -402,10 +405,7 @@
"<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
let handle_http_post cmd head msg ck =
- let tUID = "toss_id_05174_" in
- let dbFILE = "/var/www/WebClient/tossdb.sqlite" in
- let tGAMES = ["Breakthrough"; "Checkers"; "Chess"; "Connect4";
- "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe"] in
+ let (tID, dbFILE) = (!DB.tID, !DB.dbFILE) in
let get_args s = Array.map (strip_all ["'"]) (split ", " s) in
let dbtable select tbl = DB.get_table dbFILE ~select tbl in
let passwd_from_db uid =
@@ -421,7 +421,7 @@
| x when x > 1 -> failwith ("get_user_name: multiple entries for " ^ uid)
| _ -> let r = List.hd res in (r.(1), r.(2), r.(3)) in
let verif_uid () =
- let (ukey, pkey)= (tUID ^ "username", tUID ^ "passphrase") in
+ let (ukey, pkey)= (tID ^ "username", tID ^ "passphrase") in
if not (List.mem_assoc ukey ck) then "" else
if not (List.mem_assoc pkey ck) then "" else
let (uid, pwd1) = (List.assoc ukey ck, List.assoc pkey ck) in
@@ -436,7 +436,7 @@
let user_plays uid =
let (name, _, _) = get_user_name_surname_mail uid in
let app_plays plays g = plays ^ "$" ^ (list_plays g uid) in
- let plays = List.fold_left app_plays "" tGAMES in
+ let plays = List.fold_left app_plays "" !DB.tGAMES in
uid ^ "$" ^ name ^ plays in
let get_free_id () = (DB.count_table dbFILE "cur_states") + 1 in
let db_cur_insert game p1 p2 pid move toss loc info svg_str =
@@ -444,12 +444,12 @@
"playid, game, player1, player2, move, toss, loc, info, svg"
[pid; game; p1; p2; move; toss; loc; info; svg_str] in
let rec get_global_lock () =
- let select = "locked='false' and tid='" ^ tUID ^ "'" in
+ let select = "locked='false' and tid='" ^ tID ^ "'" in
let i = DB.update_table dbFILE ~select "locked='true'" "lock" in
if !debug_level > 1 then print_endline ("Glob lock " ^ (string_of_int i));
if i = 1 then () else get_global_lock () in
let release_global_lock () =
- let select = "locked='true' and tid='" ^ tUID ^ "'" in
+ let select = "locked='true' and tid='" ^ tID ^ "'" in
if !debug_level > 1 then print_endline "Glob lock release";
ignore (DB.update_table dbFILE ~select "locked='false'" "lock") in
let new_play game pl1 pl2 =
@@ -520,7 +520,7 @@
| Some p when p <> pwd -> ("wrong password", [])
| Some _ ->
let exp = if chk then Some (float (3600 * 1000)) else None in
- ("OK", [(tUID^"username", uid, exp); (tUID^"passphrase", pwd, exp)]) in
+ ("OK", [(tID^"username", uid, exp); (tID^"passphrase", pwd, exp)]) in
let list_friends all uid =
if all then List.map (fun a -> a.(0)) (dbtable "" "users") else
let friends = dbtable ("id='" ^ uid ^ "'") "friends" in
@@ -545,8 +545,6 @@
upd ("surname='" ^ udata.(1) ^ "'");
upd ("email='" ^ udata.(2) ^ "'");
"OK" in
- if !debug_level > 1 then
- Printf.printf "POST\n%s\n%s\nCONTENT\n%s\nEND CONTENT\n" cmd head msg;
let (tcmd, data) = split_two "#" msg in
let resp, new_cookies = match tcmd with
| "USERNAME" ->
@@ -569,7 +567,7 @@
) else "Login: internal error", []
| "LOGOUT" ->
let c =
- [(tUID ^ "username", "a", None); (tUID ^ "passphrase", "a", None)] in
+ [(tID ^ "username", "a", None); (tID ^ "passphrase", "a", None)] in
("User logged out: " ^ (verif_uid ()), c)
| "ADDOPP" ->
add_opponent (verif_uid ()) data, []
@@ -613,15 +611,14 @@
let handle_http_msg rstate cmd head msg ck =
if String.sub cmd 0 5 = "GET /" then
- rstate, handle_http_get cmd head msg ck
+ Aux.Right (rstate, fun () -> handle_http_get cmd head msg ck)
else if String.length cmd > 13 && String.sub cmd 0 13 = "POST /Handler" then
- rstate, handle_http_post cmd head msg ck
- else try
- req_handle rstate
- (Aux.Right (GDLParser.parse_request KIFLexer.lex
- (Lexing.from_string msg)))
+ Aux.Right (rstate, fun () -> handle_http_post cmd head msg ck)
+ else try Aux.Left (req_handle rstate
+ (Aux.Right (GDLParser.parse_request KIFLexer.lex
+ (Lexing.from_string msg))))
with Parsing.Parse_error | Lexer.Parsing_error _ ->
- rstate, handle_http_post cmd head msg ck
+ Aux.Right (rstate, fun () -> handle_http_post cmd head msg ck)
@@ -664,7 +661,7 @@
let full_req_handle rstate in_ch out_ch =
try
let time_started = Unix.gettimeofday () in
- let report (new_rstate, resp) =
+ let report (new_rstate, resp) continue =
if !debug_level > 0 then (
Printf.printf "Resp-time: %F\n%!" (Unix.gettimeofday() -. time_started);
if !debug_level > 1 || String.length resp < 500 then
@@ -672,31 +669,37 @@
);
output_string out_ch (resp ^ "\n");
flush out_ch;
- new_rstate in
+ (new_rstate, continue) in
match read_in_line in_ch with
| (line, Some (Aux.Right (f, x))) when line = "COMP" ->
let res = f x in
Marshal.to_channel out_ch res [Marshal.Closures];
flush out_ch;
- rstate
+ (rstate, true)
| (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" ->
- report (handle_http_msg rstate cmd head msg ck)
+ (match handle_http_msg rstate cmd head msg ck with
+ | Aux.Left ((state, resp)) -> report (state, resp) true
+ | Aux.Right (state, future) ->
+ match Unix.fork () with
+ | 0 (* child *) -> report (state, future ()) false
+ | _ (* parent *) -> state, true
+ )
| (_, Some _) -> failwith "Internal ReqHandler Error (full_req_handle)!"
| (line, None) ->
report (req_handle rstate
(Aux.Left (ArenaParser.parse_request Lexer.lex
- (Lexing.from_string line))))
+ (Lexing.from_string line)))) true
with
| Parsing.Parse_error ->
Printf.printf "Toss Server: parse error\n%!";
output_string out_ch ("ERR could not parse\n");
flush out_ch;
- rstate
+ rstate, true
| Lexer.Parsing_error msg ->
Printf.printf "Toss Server: parse error: %s\n%!" msg;
output_string out_ch ("ERR could not parse\n");
flush out_ch;
- rstate
+ rstate, true
| End_of_file ->
output_string out_ch ("ERR processing completed -- EOF\n");
flush out_ch;
@@ -707,4 +710,4 @@
Printf.printf "Exception backtrace: %s\n%!"
(Printexc.get_backtrace ());
output_string out_ch ("ERR internal error -- see server stdout\n");
- rstate
+ rstate, true
Modified: trunk/Toss/Server/ReqHandler.mli
===================================================================
--- trunk/Toss/Server/ReqHandler.mli 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/Server/ReqHandler.mli 2011-05-13 22:22:02 UTC (rev 1438)
@@ -6,8 +6,10 @@
val set_debug_level : int -> unit
-(** {2 Request Handlinf Functions} *)
+(** {2 Request Handling Functions} *)
+val html_dir_path : string ref
+
type req_state =
Formula.real_expr array array option (** heuristic option *)
* bool (** game modified *)
@@ -17,4 +19,8 @@
val init_state : req_state
-val full_req_handle : req_state -> in_channel -> out_channel -> req_state
+val req_handle : req_state -> (Arena.request, GDL.request) Aux.choice ->
+ req_state * string
+
+val full_req_handle : req_state -> in_channel -> out_channel ->
+ req_state * bool
Modified: trunk/Toss/Server/ReqHandlerTest.ml
===================================================================
--- trunk/Toss/Server/ReqHandlerTest.ml 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/Server/ReqHandlerTest.ml 2011-05-13 22:22:02 UTC (rev 1438)
@@ -9,7 +9,7 @@
let out_ch = open_out "./Server/ServerTest.temp" in
let state = ref ReqHandler.init_state in
(try while true do
- state := ReqHandler.full_req_handle !state in_ch out_ch done
+ state := fst (ReqHandler.full_req_handle !state in_ch out_ch) done
with End_of_file -> ());
close_in in_ch; close_out out_ch;
let result =
@@ -33,7 +33,7 @@
let out_ch = open_out "./Server/ServerGDLTest.temp" in
let state = ref ReqHandler.init_state in
(try while true do
- state := ReqHandler.full_req_handle !state in_ch out_ch done
+ state := fst (ReqHandler.full_req_handle !state in_ch out_ch) done
with End_of_file -> ());
close_in in_ch; close_out out_ch;
let result =
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/Server/Server.ml 2011-05-13 22:22:02 UTC (rev 1438)
@@ -4,6 +4,7 @@
let set_debug_level i =
debug_level := i;
+ DB.debug_level := i;
ReqHandler.set_debug_level i;
if i > 5 then Solver.set_debug_level 1 else Solver.set_debug_level 0;
if i > 0 then
@@ -25,20 +26,31 @@
let start_server f port addr_s =
(* Unix.establish_server f (Unix.ADDR_INET (get_inet_addr (addr_s), port))
- BUT we do not want a separate process for [f] as we use global state! *)
+ BUT we do not want a separate process for each [f], we use global state.*)
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt_optint sock Unix.SO_LINGER (Some 2);
Unix.setsockopt sock Unix.SO_REUSEADDR true;
Unix.bind sock (Unix.ADDR_INET (Aux.get_inet_addr (addr_s), port));
Unix.listen sock 99; (* maximally 99 pending requests *)
- while true do
+ let continue = ref true in
+ while !continue do
let (cl_sock, _) = Unix.accept sock in
- f (Unix.in_channel_of_descr cl_sock) (Unix.out_channel_of_descr cl_sock);
+ continue := f (Unix.in_channel_of_descr cl_sock)
+ (Unix.out_channel_of_descr cl_sock);
Unix.close cl_sock;
+ if !continue then (* collect zombies *)
+ try
+ ignore (Unix.waitpid [Unix.WNOHANG] (-1));
+ ignore (Unix.waitpid [Unix.WNOHANG] (-1));
+ with
+ Unix.Unix_error (e,_,_) -> if !debug_level > 1 then
+ Printf.printf "UNIX WAITPID: %s\n%!" (Unix.error_message e);
done
let req_handle in_ch out_ch =
- full_state := ReqHandler.full_req_handle !full_state in_ch out_ch
+ let (state, cont) = ReqHandler.full_req_handle !full_state in_ch out_ch in
+ full_state := state;
+ cont
let set_state_from_file fn =
let f = open_in fn in
@@ -123,13 +135,24 @@
Printf.printf "Aggregate payoffs %f, %f\n" !aggr_payoff_w !aggr_payoff_b;
) done
+let precache_game g =
+ let handle state s =
+ let (new_st, res) = ReqHandler.req_handle state
+ (Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))) in
+ new_st in
+ print_endline ("Precaching " ^ g);
+ let toss = DB.get_table !DB.dbFILE ~select:("game='" ^ g ^ "'") "games" in
+ let init_g = handle (ReqHandler.init_state)
+ ("SET STATE #db#" ^ (List.hd toss).(1)) in
+ ignore (handle init_g "EVAL LOC MOVES 4.0 0 TIMEOUT 30 3 alpha_beta_ord")
+
(* ----------------------- START SERVER WHEN CALLED ------------------------- *)
let main () =
Aux.set_optimized_gc ();
- let (server, port) = (ref "localhost", ref 8110) in
- let (test_s, test_full) = (ref "# # / $", ref false) in
+ let (server, port, gmdir) = (ref "localhost", ref 8110, ref "") in
+ let (test_s, test_full, precache) = (ref "# # / $", ref false, ref false) in
let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
let set_parallel_port p =
let (_, s) = !GameTree.parallel_toss in
@@ -146,6 +169,12 @@
("-nm", Arg.Unit (fun () -> Heuristic.use_monotonic := false),
" monotonicity off");
("-p", Arg.Int (fun i -> (port := i)), " port number (default: 8110)");
+ ("-html", Arg.String (fun s -> ReqHandler.html_dir_path := s),
+ "set path to directory with html files for the web-based client");
+ ("-db", Arg.String (fun s -> (DB.dbFILE := s)), "use specified DB file");
+ ("-redodb", Arg.String (fun s -> gmdir := s),
+ "recreate DB files with games from given directory, e.g. 'examples'");
+ ("-tID", Arg.String (fun s -> DB.tID := s), "use specified tID");
("-heur-white-1", Arg.String (fun s -> heur_val_white1 := s),
"white (=first) player heuristic for use by the first player in tests");
("-heur-black-1", Arg.String (fun s -> heur_val_black1 := s),
@@ -159,6 +188,7 @@
("-test", Arg.String (fun s -> test_s := s), "unit tests for given path");
("-fulltest", Arg.String (fun s -> test_s := s; test_full := true),
"full unit tests for given path, might take longer");
+ ("-precache", Arg.Unit (fun () -> precache := true), "do game pre-caching");
("-experiment",
Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i);
Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)],
@@ -168,6 +198,10 @@
"Use a parallel running Toss client (port [p] server [s]) for computation")
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ if !precache then (
+ List.iter precache_game !DB.tGAMES;
+ print_endline "- precaching finished";
+ );
if !test_s <> "# # / $" then (
let (name, full) = (!test_s, !test_full) in
let len = String.length name in
@@ -184,10 +218,12 @@
let verbose = !debug_level > 0 in
set_debug_level 0;
ignore (OUnit.run_test_tt ~verbose (Tests.tests ~full ~dirs ~files ()))
- ) else if !experiment then
+ ) else if !experiment then (
run_test !e_len !e_d1 !e_d2
- else try
- start_server req_handle !port !server
+ ) else if !gmdir <> "" then (
+ DB.renew_db ~games_dir:!gmdir
+ ) else try
+ start_server req_handle !port !server
with Aux.Host_not_found ->
print_endline "The host you specified was not found."
Property changes on: trunk/Toss/WebClient
___________________________________________________________________
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 .
TossServer
tossdb.sqlite
*.ttf
*.eot
*.svg
*.woff
*~
+ # 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 .
*.ttf
*.eot
*.svg
*.woff
*~
Modified: trunk/Toss/WebClient/.cvsignore
===================================================================
--- trunk/Toss/WebClient/.cvsignore 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/WebClient/.cvsignore 2011-05-13 22:22:02 UTC (rev 1438)
@@ -2,8 +2,6 @@
# than svn properties. Therefore if you change .cvsignore do the following.
# svn propset svn:ignore -F .cvsignore .
-TossServer
-tossdb.sqlite
*.ttf
*.eot
*.svg
Deleted: trunk/Toss/WebClient/Handler.py
===================================================================
--- trunk/Toss/WebClient/Handler.py 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/WebClient/Handler.py 2011-05-13 22:22:02 UTC (rev 1438)
@@ -1,340 +0,0 @@
-import subprocess
-import socket
-import time
-from mod_python import apache, Cookie
-from pysqlite2 import dbapi2 as sqlite3
-from Wrapper import *
-import MakeDB
-
-
-def tmp_log (str):
- file = open ("/tmp/th.log", 'a')
- file.write (str)
- file.close()
-
-def get_all_from_db (db, tbl, select_s):
- res = []
- for r in db.execute("select * from " + tbl + " where " + select_s):
- res.append(r)
- return (res)
-
-def open_toss_server (port):
- args = [MakeDB.SERVER_FILE,
- "-s", "localhost", "-p", str(port)]
- server_proc = subprocess.Popen(args)
- time.sleep (0.1)
- return (port)
-
-def get_global_lock (db):
- cur = db.cursor ()
- cur.execute ("update lock set locked='true' " +
- " where locked='false' and tid='" + str(MakeDB.TUID) + "'")
- db.commit ()
- if cur.rowcount == 1:
- return
- time.sleep (0.1)
- get_global_lock (db)
-
-def release_global_lock (db):
- db.execute ("update lock set locked='false' " +
- " where locked='true' and tid='" + str(MakeDB.TUID) + "'")
- db.commit ()
-
-def get_toss_port (db):
- get_global_lock (db)
- free_ports = get_all_from_db (db, "ports", "locked='false'")
- if len(free_ports) == 0:
- fid = 0
- for f in db.execute ("select count(*) from ports"):
- fid = int(f[0])
- port = 8110+fid+1
- db.execute ("insert into ports(port, locked) values (?, ?)",
- (port, 'true'))
- release_global_lock (db)
- open_toss_server (port)
- return (port)
- (port, _) = free_ports[0]
- db.execute ("update ports set locked='true' where port=" + str(port))
- release_global_lock (db)
- return (port)
-
-def release_toss_port (db, port):
- db.execute ("update ports set locked='false' where port=" + str(port))
- db.commit ()
-
-def cp (f1, f2):
- subprocess.call(["cp", f1, f2])
-
-def list_plays (db, game, player_id):
- or_s = "(player1='" + player_id + "' or player2='" + player_id + "')"
- plays = get_all_from_db (db, "cur_states", "game='"+ game + "' and " + or_s)
- def play_name (p):
- (pid, g, p1, p2, move, _, _, _, _) = p
- return ("/plays/" + str(g) + "_" + str(p1) + "_" + str(p2) + "_" +
- str(pid) + "_" + str(move))
- 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]))
-
-def db_cur_insert (db, game, p1, p2, pid, move, toss, loc, info, svg_str):
- db.execute ("insert into cur_states(playid, game, player1, player2, move, toss, loc, info, svg) values (?, ?, ?, ?, ?, ?, ?, ?, ?)",
- (pid, game, p1, p2, move, toss, str(loc), info, svg_str))
- db.commit ()
-
-def db_old_insert (db, game, p1, p2, pid, move, toss, loc, info, svg_str):
- db.execute ("insert into old_states(playid, game, player1, player2, move, toss, loc, info, svg) values (?, ?, ?, ?, ?, ?, ?, ?, ?)",
- (pid, game, p1, p2, move, toss, str(loc), info, svg_str))
- db.commit ()
-
-def get_game_info (client):
- dim_s = str(client.model.get_dim())
- model_s = str(client.model.get_elems_with_pos())
- rels_s = str(client.model.get_rels_simple())
- moves = client.cur_moves()
- moves_s = str(moves)
- if (len(moves) == 0): moves_s = client.get_payoffs()
- return (dim_s + "$" + model_s + "$" + rels_s + "$" + moves_s)
-
-def get_free_id (db):
- fid = 0
- for f in db.execute ("select count(*) from cur_states"):
- fid = int(f[0])
- return (fid + 1)
-
-def new_play (db, client, game, p1, p2):
- res = get_all_from_db (db, "games", "game='" + game + "'")
- (_, toss) = res[0]
- client.open_from_str (toss)
- info = get_game_info (client)
- model = client.get_model ()
- loc = client.get_cur_loc ()
- move_pl = int(client.get_loc_player (loc)) - 1
- get_global_lock (db)
- pid = get_free_id (db)
- db_cur_insert (db, game, p1, p2, pid, move_pl, model, loc, info, "")
- release_global_lock (db)
- return (str(pid) + "$" + info + "$" + str(move_pl))
-
-def game_select_s (g, p1, p2, pid, m):
- return("game='" + g + "' and player1='" + p1 + "' and player2='" + p2 +
- "' and playid=" + pid + " and move=" + m)
-
-def open_db (db, game, p1, p2, pid, move):
- select_s = game_select_s (game, p1, p2, pid, move)
- res = get_all_from_db (db, "cur_states", select_s)
- (_, _, _, _, move, _, _, info, _) = res[0]
- return (info + "$" + str(move))
-
-def db_escape (s):
- return (s.replace("'", "''"))
-
-def move_play (db, client, move_tup, g, p1, p2, pid, m):
- sel_s = game_select_s (g, p1, p2, pid, m)
- old_res = get_all_from_db (db, "cur_states", sel_s)
- (_, _, _, _, _, old_toss, old_loc, old_info, old_svg) = old_res[0]
- res = get_all_from_db (db, "games", "game='" + g + "'")
- (_, game_toss) = res[0]
- client.open_from_str (game_toss + "\n MODEL " + old_toss)
- client.set_cur_loc (old_loc)
- (move1, move2, move3) = move_tup
- new_pl = int(client.make_move (move1, move2, move3)) - 1
- new_toss = db_escape (client.get_model ())
- new_info = get_game_info (client)
- new_info_db = db_escape (new_info)
- db.execute ("update cur_states set toss='" + new_toss + "' where " + sel_s)
- db.execute ("update cur_states set info='"+ new_info_db +"' where "+ sel_s)
- db.execute ("update cur_states set loc='"+ str(move3) +"' where "+ sel_s)
- db.execute ("update cur_states set move=" + str(new_pl) +" where "+ sel_s)
- db_old_insert (db, g, p1, p2, pid, m, old_toss, old_loc, old_info, old_svg)
- return (new_info + "$" + str(new_pl))
-
-def upd_svg (db, g, p1, p2, pid, m, svg_s):
- select_s = game_select_s (g, p1, p2, pid, m)
- db.execute ("update cur_states set svg='" + svg_s + "' where " + select_s)
- db.commit ()
-
-def passwd_from_db (db, uid):
- res = get_all_from_db (db, "users", "id='" + uid + "'")
- if len(res) > 1: raise Exception ("db", "multiple entries for " + uid)
- if len(res) == 0: return (None)
- (uid, _, _, _, passwd) = res[0]
- return (str(passwd))
-
-def confirm_username (db, req):
- cookies = Cookie.get_cookies(req)
- if not (cookies.has_key(MakeDB.TUID + 'username')): return ""
- if not (cookies.has_key(MakeDB.TUID + 'passphrase')): return ""
- uid = cookies[MakeDB.TUID + 'username'].value
- pwd1 = cookies[MakeDB.TUID + 'passphrase'].value
- pwd2 = passwd_from_db (db, uid)
- if (pwd1 != pwd2): return ""
- return (uid)
-
-def login_user (db, req, uid, chk, pwd):
- db_pwd = passwd_from_db (db, uid)
- if not db_pwd: return ("no such user registered")
- if (pwd != db_pwd): return ("wrong password")
- t = time.time() + 3600000;
- if chk == "false":
- cookie1 = Cookie.Cookie(MakeDB.TUID + 'username', uid)
- cookie2 = Cookie.Cookie(MakeDB.TUID + 'passphrase', pwd)
- else:
- cookie1 = Cookie.Cookie(MakeDB.TUID + 'username', uid, expires=t)
- cookie2 = Cookie.Cookie(MakeDB.TUID + 'passphrase', pwd, expires=t)
- Cookie.add_cookie(req, cookie1)
- Cookie.add_cookie(req, cookie2)
- return ("OK")
-
-def register_user (db, ui):
- if len(ui) != 5: return (False)
- (uid, name, surname, email, pwd) = (ui[0], ui[1], ui[2], ui[3], ui[4])
- if passwd_from_db (db, uid): return (False)
- db.execute ("insert into users(id, name, surname, email, passwd) " +
- "values (?, ?, ?, ?, ?)", (uid, name, surname, email, pwd))
- db.execute ("insert into friends(id, fid) values (?, ?)", (uid, "computer"))
- db.commit ()
- return (True)
-
-def add_opponent (db, uid, oppid):
- if uid == "": return ("You must login first to add opponents.")
- if get_user_name (db, oppid) == "":
- return ("No such opponent found among tPlay users.")
- db.execute ("insert into friends(id, fid) values (?, ?)", (uid, oppid))
- db.commit ()
- return ("OK")
-
-def get_user_name (db, uname):
- res = get_all_from_db (db, "users", "id='" + uname + "'")
- if len(res) > 1: raise Exception ("db", "many entries for " + uname)
- if len(res) == 0: return ("")
- (_, name, _, _, _) = res[0]
- return (name)
-
-def get_user_surname (db, uname):
- res = get_all_from_db (db, "users", "id='" + uname + "'")
- if len(res) > 1: raise Exception ("db", "many entries for " + uname)
- if len(res) == 0: return ("")
- (_, _, surname, _, _) = res[0]
- return (surname)
-
-def get_user_mail (db, uname):
- res = get_all_from_db (db, "users", "id='" + uname + "'")
- if len(res) > 1: raise Exception ("db", "many entries for " + uname)
- if len(res) == 0: return ("")
- (_, _, _, email, _) = res[0]
- return (email)
-
-def change_user_data (db, uid, udata):
- if uid == "": return ("You must login first to change data.")
- if len(udata) != 3: return ("Internal error, data not changed.")
- uid_s = "id='" + uid + "'"
- db.execute ("update users set name='" + udata[0] + "' where " + uid_s)
- db.execute ("update users set surname='" + udata[1] + "' where " + uid_s)
- db.execute ("update users set email='" + udata[2] + "' where " + uid_s)
- db.commit ()
- return ("OK")
-
-def user_plays (db, usr):
- name = get_user_name (db, usr);
- plays = ""
- for g in MakeDB.GAMES:
- plays += "$" + list_plays (db, g, usr)
- return (usr + "$" + name + plays)
-
-def suggest_offset (offset, db, client, g, p1, p2, pid, m):
- sel_s = game_select_s (g, p1, p2, pid, m)
- res = get_all_from_db (db, "cur_states", sel_s)
- (_, _, _, _, _, toss, loc, _, _) = res[0]
- game_res = get_all_from_db (db, "games", "game='" + g + "'")
- (_, game_toss) = game_res[0]
- client.open_from_str (game_toss + "\n MODEL " + toss)
- client.set_cur_loc (loc)
- #depth = client.get_data ("depth")
- #if depth == "none": depth = 2
- adv_ratio = client.get_data ("adv_ratio")
- if adv_ratio == "none": adv_ratio = 4
- return (client.suggest (offset, adv_ratio))
-
-def suggest (db, client, time, g, p1, p2, pid, m):
- return (suggest_offset (time, db, client, g, p1, p2, pid, m))
-
-def handler(req):
- req.content_type = "text/plain"
- db = sqlite3.connect(MakeDB.DB_FILE)
- usr = confirm_username (db, req)
- msg = req.read ()
- #tmp_log(msg)
- cmd, sep, data = msg.partition('#')
- if cmd == "USERNAME":
- req.write(usr)
- return apache.OK
- if cmd == "USERPLAYS":
- if usr == "":
- req.write(usr)
- return apache.OK
- req.write (user_plays (db, usr))
- return apache.OK
- if cmd == "REGISTER":
- ui = data.split('$')
- if register_user (db, ui):
- req.write("Registration successful for " + ui[0] + ".")
- return apache.OK
- req.write("Registration failed:\n username "+ui[0]+" already in use."+
- "\nPlease choose another username and try again.")
- return apache.OK
- if cmd == "LOGIN":
- ui = data.split("$")
- res = "internal error"
- if len(ui) == 3:
- res = login_user (db, req, ui[0], ui[1], ui[2])
- if res == "OK":
- req.write("OK")
- return apache.OK
- req.write("Login failed for " + ui[0] + ": " + res)
- return apache.OK
- if cmd == "LOGOUT":
- cookie1 = Cookie.Cookie(MakeDB.TUID + 'passphrase', "a")
- cookie2 = Cookie.Cookie(MakeDB.TUID + 'username', "a")
- Cookie.add_cookie(req, cookie1)
- Cookie.add_cookie(req, cookie2)
- req.write ("User logged out: " + usr + ".")
- return apache.OK
- if cmd == "ADDOPP":
- req.write(str(add_opponent (db, usr, data)))
- return apache.OK
- if cmd == "GET_NAME":
- req.write(str(get_user_name (db, data)))
- return apache.OK
- if cmd == "GET_SURNAME":
- req.write(str(get_user_surname (db, data)))
- return apache.OK
- if cmd == "LIST_FRIENDS":
- 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.")
- req.write(str(get_user_mail (db, data)))
- return apache.OK
- if cmd == "CHANGEUSR":
- req.write(str(change_user_data (db, usr, data.split("$"))))
- return apache.OK
- if (cmd == "LIST_PLAYS") or (cmd == "OPEN_DB") or (cmd == "UPD_SVG"):
- res = eval (cmd.lower() + "(db, " + data + ")")
- req.write(str(res))
- return apache.OK
- if ((cmd == "NEW_PLAY") or (cmd == "MOVE_PLAY") or (cmd == "SUGGEST")):
- port = get_toss_port (db)
- c = SystemClient ("localhost", port)
- res = eval (cmd.lower() + "(db, " + data + ")")
- release_toss_port (db, port)
- req.write(str(res))
- return apache.OK
- req.write("MOD_PYTHON ERROR ; Traceback: Unknown Toss Command! \n " + cmd)
- return apache.OK
Deleted: trunk/Toss/WebClient/MakeDB.py
===================================================================
--- trunk/Toss/WebClient/MakeDB.py 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/WebClient/MakeDB.py 2011-05-13 22:22:02 UTC (rev 1438)
@@ -1,68 +0,0 @@
-#!/usr/bin/python
-
-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", "Connect4", "Entanglement",
- "Gomoku", "Pawn-Whopping", "Tic-Tac-Toe"]
-
-
-def create_db (db_file, games_path, games):
- conn = sqlite3.connect(db_file)
- conn.execute("create table users(id string primary key," +
- " name string, surname string, email string, passwd string)")
- conn.execute("create table cur_states(playid int primary key," +
- " game string, player1 string, player2 string," +
- " move int, toss string, loc string, info string, svg string)")
- conn.execute("create table old_states(playid int," +
- " game string, player1 string, player2 string," +
- " move int, toss string, loc string, info string, svg string)")
- conn.execute("create table games(game string primary key, toss string)")
- conn.execute("create table ports(port int primary key, locked bool)")
- conn.execute("create table lock(tid int primary key, locked bool)")
- conn.execute("create table friends(id string, fid string)")
- conn.commit ()
- conn.execute ("insert into lock(tid, locked) values (?, ?)",
- (TUID, 'false'))
- conn.execute ("insert into users(id, name, surname, email, passwd) values"+
- " (?, ?, ?, ?, ?)",
- ("computer", "Computer", "tPlay", "co...@tp...", "xxx"))
- 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 ("Added " + g)
- conn.commit ()
- 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__":
- 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"
Deleted: trunk/Toss/WebClient/README
===================================================================
--- trunk/Toss/WebClient/README 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/WebClient/README 2011-05-13 22:22:02 UTC (rev 1438)
@@ -1,25 +0,0 @@
-This is an experimental new Toss Client, which runs in a browser.
-
-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 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
- # During development you might turn debugging on
- PythonDebug On
- </Directory>
-The main handler script is called Hander.py (server side) and corresponding
-JavaScript functions are in *.js. To start client open index.html, but
-first make sure that WebClient is linked in /var/www (ln -s should suffice).
-Then run "./MakeDB.py" from WebClient and make sure Handler entry (above) is ok.
-Also copy Server from main Toss dir as TossServer to the WebClient directory.
-
-
-TODO:
- - sort plays by who's turn it is
- - option to give up game and offer a draw
- - enable google (or other) analytics
- - refresh (async?) plays in which the other player moves
Deleted: trunk/Toss/WebClient/Wrapper.py
===================================================================
--- trunk/Toss/WebClient/Wrapper.py 2011-05-13 12:42:31 UTC (rev 1437)
+++ trunk/Toss/WebClient/Wrapper.py 2011-05-13 22:22:02 UTC (rev 1438)
@@ -1,234 +0,0 @@
-#!/usr/bin/python
-
-import socket
-
-class ModelClient:
- """Ask the Toss server for approproate results.
-
- This is just a client to an XML RPC server serving Toss Model.
- """
-
- def __init__ (self, server, i, pos):
- self.s = server
- self.i = i
- self.p = pos
-
- def __str__ (self):
- return ("Nbr " + (str (self.i)) + " pos " + (str (self.i)) + ";")
-
- def id (self):
- return ("SOME MODEL", "SFX")
-
- def _pos (self):
- if self.i == ";MODEL":
- return (" MODEL ")
- if self.p == 0:
- return (" RULE " + (str (self.i)) + " LEFT ")
- return (" RULE " + (str (self.i)) + " RIGHT ")
-
- def get_elem_val (self, el_id, val):
- v = self.s.msg ("GET FUN" + (self._pos ()) + val + " " + (str (el_id)))
- return (float (v))
-
- def get_elem_pos (self, el_id):
- x = self.get_elem_val (el_id, "x")
- y = self.get_elem_val (el_id, "y")
- return (x, y)
-
- def get_elems (self):
- m = self.s.msg ("GET ALLOF ELEM" + (self._pos ()))
- if len(m) < 1:
- els = []
- else:
- els = [s.strip() for s in m.split (';')]
- return (els)
-
- def get_dim (self, elems = []):
- """Return the width, height and middle-mass x, y of [elems].
-
- If the list [elems] is empty, then it means all elements.
- """
- if elems == []: elems = self.get_elems ()
- pos = map (self.get_elem_pos , elems)
- posx, posy = [x for (x, y) in pos], [y for (x, y) in pos]
- minx, maxx, miny, maxy = min(posx), max(posx), min(posy), max(posy)
- sumx, sumy, l = sum(posx), sum(posy), len(pos)
- return (maxx, minx, maxy, miny, sumx / l, sumy / l)
-
-
- def get_rel_names_arities (self):
- mrel = self.s.msg ("GET SIGNATURE REL" + (self._pos ()))
- if len(mrel) < 1: return ([])
- pair_strs = [s.strip() for s in mrel.split (',')]
- rels_ar_lst = [p.split(':') for p in pair_strs]
- rels = [(rl[0].strip(), int (rl[1].strip())) for rl in rels_ar_lst]
- return ([r for r in set(rels)])
-
- def get_rel (self, rel_name):
- m = self.s.msg ("GET ALLOF REL" + (self._pos ()) + rel_name)
- cur = m.find('{')
- par = m.find('(')
- if cur < 0 and par < 0: return ([])
- tps = [ts.strip('{}() ') for ts in m[max(cur,par):].split(";")]
- return ([[t.strip() for t in ts.split(",")] for ts in tps])
-
- def get_rels_simple (self):
- """Return list of (rel, args, rel_id) for all rel(args) tuples."""
- sig = self.get_rel_names_arities ()
- tuples = []
- for (r, _) in sig:
- tuples = [(r, a) for a in self.get_rel (r)] + tuples
- return ("; ".join ([str(t) for t in tuples]))
-
- def get_elems_with_pos (self):
- m = self.s.msg ("GET ALLOF ELEM" + (self._pos ()))
- if len(m) < 1: return ([])
- els = [s.strip() for s in m.split (';')]
- els_p = [(e, self.get_elem_pos (e)) for e in els]
- return ([e + " ; " + str(x) + " ; " + str(y) for (e, (x, y)) in els_p])
-
-
-class SystemClient:
- """Representing the model and rewrite rules.
- """
- def __init__ (self, host, port):
- """Initialize the system given its URL and port.
- """
- self.host = host
- self.port = port
- self.model = ModelClient (self, ";MODEL", 0)
-
-
- def __str__ (self):
- return ("System")
-
- def msg (self, s):
- sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
- sock.connect ((self.host, self.port))
- sock.send (s + "\n")
- res = ""
- while 1:
- data = sock.recv(1024)
- if not data: break
- res += data
- sock.close ()
- return (res.strip ())
-
- def get_state (self):
- return (self.msg ("GET STATE"))
-
- def get_model (self):
- return (self.msg ("GET MODEL"))
-
- def set_state (self, state):
- m = self.msg ("SET STATE " + state)
- return (m)
-
- def get_cur_loc (self):
- """Get current game location from server."""
- m = self.msg ("GET LOC").split("/")
- return (int (m[0].strip()))
-
- def set_cur_loc (self, i):
- """Set current game location."""
- m = self.msg ("SET LOC " + str(i))
- return (m)
-
- def get_payoffs (self):
- """Get (evaluated) payoffs for all players in the current location."""
- m = self.msg ("GET PAYOFF")
- return (m)
-
- def get_loc_moves (self, i):
- """Get moves for the i-th position."""
- msg = self.msg("GET LOC MOVES " + (str (i)))
- if len (msg) < 1: return ([])
- moves = msg.split(';')
- def make_itvl (v):
- sep = v.split(':')
- d = sep[1].split('--')
- return (sep[0].strip(), float(d[0].strip()), float(d[1].strip()))
- def make_move (m):
- gs = m.split('->')
- lab = gs[0].split(',')
- return ((lab[0].strip(),
- [make_itvl(v.strip()) for v in lab[1:]],
- int (gs[1].strip())))
- return ([make_move(m.strip('[] ')) for m in moves])
-
- def query (self, rule_nm):
- msg = self.msg ("GET RULE " + rule_nm + " MODEL")
- if msg.find('->') < 0: return ([])
- def make_match (m_str):
- m = dict ()
- for p in m_str.split(','):
- p_str = p.split("->")
- m[p_str[0].strip()] = p_str[1].strip()
- return (m)
- return ([make_match (m.strip()) for m in msg.split(';')])
-
- def apply_rule (self, rule_nm, match, time, params):
- match_s = ", ".join([str(l) + ": " + str(r) for (l,r) in match.items()])
- param_s = ", ".join([str(p) + ": " + repr(v) for (p,v) in params])
- m = self.msg ("SET RULE "+ rule_nm + " MODEL " + match_s +
- " " + repr(time) + " " + param_s)
- shifts = dict ()
- for s in [s.strip() for s in m.split(";")]:
- seq = [e.strip() for e in s.split(",")]
- if len(seq) > 2:
- if not (seq[0] in shifts.keys()): shifts[seq[0]] = dict ()
- shifts[seq[0]][seq[1]] = [float(f) for f in seq[2:]]
- return (shifts)
-
- def open_from_str (self, s):
- state_str = ("#db#") + "$".join (s.split ("\n"))
- self.set_state (state_str)
-
- def cur_moves (self):
- cur_loc = self.get_cur_loc ()
- moves = []
- for (r, itvls, endp) in self.get_loc_moves (cur_loc):
- for m in self.query (r):
- # FIXME! currently we ignore params in html (skip itvls here)
- moves.append ((m, r, endp))
- return ("; ".join([str(m) for m in moves]))
-
- def get_loc_player (self, i):
- """Get player for the i-th location."""
- m = self.msg ("GET LOC PLAYER " + (str (i)))
- return (m)
-
- def make_move (self, m, r, endp):
- self.apply_rule (r, m, 1.0, [])
- self.set_cur_loc (endp)
- return (self.get_loc_player(endp))
-
- def get_data (self, did):
- m = self.msg ("GET DATA " + did)
- if len(m) < 3: return (m)
- if m[0:3] == "ERR": return ("none")
- return (m)
-
- def set_time (self, tstep, t):
- m = self.msg ("SET dynamics " + repr(tstep) + " " + repr(t))
- return (m)
-
- def get_time (self):
- m = self.msg ("GET dynamics")
- t = [s.strip() for s in m.split('/')]
- return ((float(t[0]), float(t[1])))
-
- def suggest (self, timeout, advr):
- loc = self.get_cur_loc ()
- (ts, t) = self.get_time ()
- m = self.msg ("EVAL LOC MOVES " + str(advr) + ".0 " + str(loc) +
- " TIMEOUT "+ str(timeout) + " 55500 alpha_beta_ord")
- self.set_time (ts, t)
- msg = [s.strip() for s in m.split(';')]
- if len(msg) < 2: return ("")
- emb = dict()
- for s in msg[1].split(','):
- es = [x.strip() for x in s.split(':')]
- emb[es[0]] = es[1]
- # we ignore params in html for now
- return ((emb, msg[0], int(msg[3])))
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-13 12:42:38
|
Revision: 1437
http://toss.svn.sourceforge.net/toss/?rev=1437&view=rev
Author: lukstafi
Date: 2011-05-13 12:42:31 +0000 (Fri, 13 May 2011)
Log Message:
-----------
Reference specification of GDL translation: expanded {Rewriting Rule Creation}, first draft of {Translating Formulas}.
Modified Paths:
--------------
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-05-12 23:29:43 UTC (rev 1436)
+++ trunk/Toss/www/reference/reference.tex 2011-05-13 12:42:31 UTC (rev 1437)
@@ -1112,9 +1112,13 @@
\section{Game Description Language}
The game description language, GDL, is a variant of Datalog used to
-specify games in a compact, prolog-like way. The GDL syntax and semantics
-are defined in \cite{GLP05,LHHSG08}, we refer the reader there for the
-definition and will only recapitulate some notions here.
+specify games in a compact, prolog-like way. The GDL syntax and
+semantics are defined in \cite{GLP05,LHHSG08}, we refer the reader
+there for the definition and will only recapitulate some notions
+here. When we build first-order formulas over GDL atoms during
+intermediate steps of translation, they are intended to be interpreted
+in already existing GDL models (which are defined in
+\cite{GLP05,LHHSG08}).
The state of the game in GDL is defined by the set of propositions
true in that state. These propositions are represented by terms of
@@ -1133,6 +1137,7 @@
the second arguments of \texttt{legal} and \texttt{does} relations,
\ie those terms which are used to specify the moves of the players.
+
The complete Tic-tac-toe specification in GDL is given in
Figure~\ref{fig-ttt-gdl}. While games can be formalised in various
ways in both systems, Figures \ref{fig-ttt-code} and \ref{fig-ttt-gdl}
@@ -1762,49 +1767,62 @@
\subsubsection{Rewriting Rule Creation} \label{subsec-rules}
-For each suitable tuple $\ol{\calC}, \ol{\calN}$ we have now
-created the unifier $\sigma_{\ol{\calC}, \ol{\calN}}$ and computed
-the erasure clauses $\calE_{\ol{\calC}, \ol{\calN}}$. To create the rules,
-we first collect all atoms in the bodies of
-$\sigma_{\ol{\calC}, \ol{\calN}}(\calC_i), \sigma_{\ol{\calC}, \ol{\calN}}(\calN_i)$
-and $\calE_{\ol{\calC}, \ol{\calN}}$. We generate a Toss rule candidate for
-every partition of atoms into true and false ones, and later \emph{filter}
-these candidates by checking for satisfiability in the initial structure
-of the stable part of the rule matching criteria and precondition.
+For each suitable tuple $\ol{\calC}, \ol{\calN}$ we have now created
+the unifier $\sigma_{\ol{\calC}, \ol{\calN}}$ and computed the erasure
+clauses $\calE_{\ol{\calC}, \ol{\calN}}$. To create the rules, we need
+to further partition the \emph{rule clauses} $\sigma_{\ol{\calC},
+ \ol{\calN}}(\calC_i), \sigma_{\ol{\calC}, \ol{\calN}}(\calN_i)$ and
+$\calE_{\ol{\calC}, \ol{\calN}}$, and augment them with further
+conditions. The reason is that the prepared rule clauses may have
+different matches in different game states, while the Toss rule has to
+be built from all the rule clauses that would match when the Toss rule
+matches. Therefore, we need to build a Toss rule for each subset of
+rule clauses that are ``selected'' by some game state (i.e. are
+exactly the rule clauses matching in that state), but add to it
+``separation conditions'' that prevent the Toss rule from matching in
+game states where more rule clauses can match.
-For a given a partition of GDL atoms into true and false ones,
-we will construct the candidate rule in two steps.
+We select groups of atoms (collected from rule clauses) that separate
+rule clauses, and generate a Toss rule candidate for every partition
+of the groups into true and false ones: we collect the rule clauses
+that agree with the given partition. The selected atoms, some negated
+according to the partition, form the separation condition.
-In the first step, we transform the GDL atoms into Toss clauses.
-This translation follows the definitions of atomic relations
-presented in Section~\ref{subsec-rels}, and the relations there were
-chosen so as to suffice for this translation. Due to space constraints
-we omit further technical details of this step here.
-%Before creating the rules, we currently expand (inline)
-%relations of $G$ that directly or indirectly depend on game state, and
-%we instantiate variables at fluent paths. We translate state terms
-%as Toss variables, so that terms are translated as the same variable
-%iff they are syntactically equal or differ only at fluent paths.
+For each candidate, we will construct the Toss rule in two steps.
-In the second step, we use Toss clauses to construct the structures
-for the rule. The $\frakL$-structure and precondition of a Toss rewrite rule
-is built by first translating the existential closure of conjunctions of
-bodies of \texttt{next} clauses of the rule. Based on the heads of
-\texttt{next} clauses, the relevant information is extracted from the
-resulting precondition formula and quantification over variables
-corresponding to $\frakL$ elements is dropped. The right-hand
-structure is constructed similarly.
+In the first step we generate the \emph{matching condition}: we
+translate the conjunction of the bodies of rule clauses and the
+separation condition. This translation follows the definitions of
+atomic relations presented in Section~\ref{subsec-rels} and is
+described in Section~\ref{subsec-translate}.
-Having constructed and filtered the rewriting rule candidates,
-we have almost completed the definition of $T(G)$. The rules
-are assigned to locations based on who moves in which location,
-as we only translate turn-based games for now. Payoff formulas
-are derived by instantiating variables standing for the \texttt{goal}
-values. The formulas defining the \texttt{terminal} condition and
-specific \texttt{goal} value conditions are existential closures of
-disjunctions of bodies of their respective clauses.
+Later we \emph{filter} the rule candidates by checking for
+satisfiability in the initial structure of the stable part of the
+matching condition.
+In the second step, we build a Toss rewrite rule itself. From the
+heads of rule clauses of a rule candidate, we build the
+$\frakR$-structure: each \texttt{next} term, with its fluent paths
+replaced by \texttt{BLANK}, is an $\frakR$ element, and the fluent
+predicates holding for the \texttt{next} state terms are the relations
+of $\frakR$. The $\frakL$-structure and precondition of the Toss rule
+is built from the matching condition, based on elements of $\frakR$.
+Quantification over variables corresponding to $\frakR$ elements
+(which are the same as $\frakL$ elements) is dropped, and atoms
+involving only these variables and not occurring inside disjunctions
+are extracted to be relations tuples in $\frakL$.
+Having constructed and filtered the rewriting rule candidates, we have
+almost completed the definition of $T(G)$. The rules are assigned to
+locations based on who moves in which location, as we only translate
+turn-based games for now. Payoff formulas are derived by instantiating
+variables standing for the \texttt{goal} values. The formulas defining
+the \texttt{terminal} condition and specific \texttt{goal} value
+conditions are translated as described in
+Section~\ref{subsec-translate}, from disjunctions of bodies of their
+respective clauses.
+
+
\subsection{Translating Moves between Toss and GDL} \label{subsec-move-tr}
To play as a GDL client, we need to translate legal moves from $G$
@@ -1828,7 +1846,30 @@
such that $t\tpos_p = v$, and $a\tpos^m_p = s$, then we substitute
$v$ by $s$. The move translation function $\mu$ is thus constructed.
+\subsection{Translating Formulas} \label{subsec-translate}
+\subsubsection{Stable Relations and Fluents}
+
+Divide Phi into the part other than \texttt{true}: LitsPhi (can
+contain disjunctions), positive \texttt{true} literals: Tru+ and
+negative \texttt{true} literals: Tru-.
+
+Translate conjunctions as conjunctions, and disjunctions as disjunctions.
+
+Translate TrLits(Phi, Tru1, Tru2) by translating each literal as a
+conjunction of literals, for every combination of mask paths into Tru1
+terms, such that at least one of the terms is from Tru2.
+
+Translate \texttt{true} atoms as a conjunction of their anchor and
+fluent predicates TrTru.
+
+Translate the whole Phi as ``ex Tru+ (TrLits(LitsPhi, Tru+, Tru+) and
+conj of TrTru(Tru+) and TrLits(ex Tru- (not (TrLits(LitsPhi, Tru+ sum
+Tru-, Tru-) and disj of TrTru(Tru-)))))''.
+
+\subsubsection{Introducing and Using Defined Relations}
+
+
\section{Game Simplification in Toss}
Games automatically translated from GDL, as described above, are verbose
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-12 23:29:50
|
Revision: 1436
http://toss.svn.sourceforge.net/toss/?rev=1436&view=rev
Author: lukaszkaiser
Date: 2011-05-12 23:29:43 +0000 (Thu, 12 May 2011)
Log Message:
-----------
Make TossServer handle WebClient requests natively.
Modified Paths:
--------------
trunk/Toss/Server/DB.ml
trunk/Toss/Server/DB.mli
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/WebClient/Main.js
Modified: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml 2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/DB.ml 2011-05-12 23:29:43 UTC (rev 1436)
@@ -8,15 +8,30 @@
let print_rows rs = List.iter (fun r -> print_row r; print_endline "") rs
-let get_table dbfile ?(select="") tbl =
+let apply_cmd dbfile select cmd =
let (rows, wh_s) = (ref [], if select = "" then "" else " where " ^ select) in
- let select_s = "select * from " ^ tbl ^ wh_s in
+ let select_s = cmd ^ wh_s in
let db = Sqlite3.db_open dbfile in
let add_row r = rows := r :: !rows in
let res = Sqlite3.exec_not_null_no_headers db add_row select_s in
+ let nbr_changed = Sqlite3.changes db in
ignore (Sqlite3.db_close db);
match res with
- | Sqlite3.Rc.OK -> List.rev !rows
+ | Sqlite3.Rc.OK -> (List.rev !rows, nbr_changed)
| x -> raise (DBError (Sqlite3.Rc.to_string x))
+let get_table dbfile ?(select="") tbl =
+ fst (apply_cmd dbfile select ("select * from " ^ tbl))
+let count_table dbfile ?(select="") tbl =
+ let (rows, _) = apply_cmd dbfile select ("select count(*) from " ^ tbl) in
+ int_of_string (List.hd rows).(0)
+
+let insert_table dbfile tbl schm vals =
+ let vals_s = String.concat ", " (List.map (fun s -> "'" ^ s ^ "'") vals) in
+ let ins_s = Printf.sprintf "insert into %s(%s) values (%s)" tbl schm vals_s in
+ ignore (apply_cmd dbfile "" ins_s)
+
+let update_table dbfile ?(select="") set_s tbl =
+ snd (apply_cmd dbfile select ("update " ^ tbl ^ " set " ^ set_s))
+
Modified: trunk/Toss/Server/DB.mli
===================================================================
--- trunk/Toss/Server/DB.mli 2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/DB.mli 2011-05-12 23:29:43 UTC (rev 1436)
@@ -5,3 +5,9 @@
val print_rows : string array list -> unit
val get_table : string -> ?select : string -> string -> string array list
+
+val count_table : string -> ?select : string -> string -> int
+
+val insert_table : string -> string -> string -> string list -> unit
+
+val update_table : string -> ?select : string -> string -> string -> int
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-12 23:29:43 UTC (rev 1436)
@@ -4,6 +4,7 @@
let set_debug_level i = (debug_level := i;)
+(* ---------- Basic request type and internal handler ---------- *)
type req_state =
Formula.real_expr array array option (** heuristic option *)
@@ -145,10 +146,487 @@
(g_heur, game_modified, state, gdl_transl, playclock), resp
+(* ------------ Old Python Wrapper Client Functions ------------ *)
-(* --------- LINES PARSING AND FULL REQUEST HANDLING ------------ *)
+let client = ref init_state
+let lstr l = "[" ^ (String.concat ", " l) ^ "]"
+let split_list ?(bound=None) pat s =
+ let r = Str.regexp_string pat in
+ match bound with None-> Str.split r s | Some b-> Str.bounded_split r s b
+
+let split_two pat s =
+ match split_list ~bound:(Some 2) pat s with
+ | [x; y] -> (x, y)
+ | l -> failwith ("ReqHandler.split_two: " ^ (String.concat "|" l))
+
+let split ?(bound=None) pat s = Array.of_list (split_list ~bound pat s)
+
+let strip pat s = String.concat pat (split_list pat s)
+
+let strip_ws = Aux.strip_spaces
+
+let strip_all patl s =
+ let once str = List.fold_left (fun s p -> strip p s) (strip_ws str) patl in
+ let rec fp str = let ns = once str in if ns = str then ns else fp ns in fp s
+
+let strip_ws_lst s = strip_all ["]"; "["] s
+
+let str_find pat s =
+ try Str.search_forward (Str.regexp_string pat) s 0 with Not_found -> -1
+
+let str_replace pat repl s = Str.global_replace (Str.regexp_string pat) repl s
+
+let client_msg s =
+ let (new_st, res) = req_handle !client
+ (Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))) in
+ client := new_st;
+ strip_ws res
+
+let client_get_state () = client_msg "GET STATE"
+
+let client_get_model () = client_msg "GET MODEL"
+
+let client_set_state state_s = ignore (client_msg ("SET STATE " ^ state_s))
+
+let client_get_cur_loc () =
+ strip_ws (split "/" (client_msg "GET LOC")).(0)
+
+let client_set_cur_loc i = ignore (client_msg ("SET LOC " ^ i))
+
+let client_get_payoffs () = client_msg "GET PAYOFF"
+
+let client_get_loc_moves i =
+ let msg = client_msg ("GET LOC MOVES " ^ i) in
+ if String.length msg < 1 then [] else
+ let moves = split_list ";" msg in
+ let make_itvl v =
+ let sep = split ":" v in
+ let d = split "--" sep.(1) in
+ (strip_ws sep.(0), strip_ws d.(0), strip_ws d.(1)) in
+ let make_move m =
+ let gs = split "->" m in
+ let lab = split_list "," gs.(0) in
+ (strip_ws (List.hd lab),
+ List.map (fun v -> make_itvl (strip_ws v)) (List.tl lab),
+ strip_ws gs.(1)) in
+ List.map (fun m -> make_move (strip_ws_lst m)) moves
+
+let client_query rule_nm =
+ let msg = client_msg ("GET RULE " ^ rule_nm ^ " MODEL") in
+ if str_find "->" msg < 0 then [] else
+ let make_match m_str =
+ let app_p_assoc dict p =
+ let p_str = split "->" p in
+ (strip_ws p_str.(0), strip_ws p_str.(1)) :: dict in
+ List.fold_left app_p_assoc [] (split_list "," m_str) in
+ List.map (fun m -> make_match (strip_ws m)) (split_list ";" msg)
+
+let client_apply_rule rule_nm mtch_s time params =
+ (*let mt_s = String.concat ", " (List.map (fun (l,r)-> l ^": "^ r) mtch) in*)
+ let param_s = String.concat ", " (List.map (fun (p,v)-> p ^": "^ v) params) in
+ let m = client_msg ("SET RULE " ^ rule_nm ^ " MODEL " ^ mtch_s ^ " " ^
+ time ^ " " ^ param_s) in
+ let add_shift shifts seq =
+ if Array.length seq > 2 then
+ ((seq.(0), seq.(1)), Array.sub seq 2 ((Array.length seq) - 2)) :: shifts
+ else shifts in
+ let add_shift_s sh s = add_shift sh (Array.map strip_ws (split "," s)) in
+ List.fold_left add_shift_s [] (List.map strip_ws (split_list ";" m))
+
+let client_open_from_str s = client_set_state ("#db#" ^ s)
+
+let client_move_str (m, r, e) =
+ let mstr m = String.concat ", " (List.map (fun (a, b) -> a ^ ": " ^ b) m) in
+ "({" ^ mstr m ^ "}, " ^ r ^ ", " ^ e ^ ")"
+
+let client_cur_moves () =
+ let append_move moves (r, _, endp) = (* FIXME! currently we ignore itvls *)
+ (List.map (fun m -> (m, r, endp)) (client_query r)) @ moves in
+ let cur_loc = client_get_cur_loc () in
+ let moves = List.fold_left append_move [] (client_get_loc_moves cur_loc) in
+ String.concat "; " (List.map client_move_str moves)
+
+let client_get_loc_player i = client_msg ("GET LOC PLAYER " ^ i)
+
+let client_make_move m r endp =
+ let _ = client_apply_rule r m "1.0" [] in
+ client_set_cur_loc endp;
+ client_get_loc_player endp
+
+let client_get_data data_id =
+ let m = client_msg ("GET DATA " ^ data_id) in
+ if String.length m > 2 && String.sub m 0 3 = "ERR" then "none" else m
+
+let client_set_time tstep t =
+ ignore (client_msg ("SET dynamics " ^ tstep ^ " " ^ t))
+
+let client_get_time () =
+ let m = client_msg "GET dynamics" in
+ let t = Array.map strip_ws (split "/" m) in
+ (t.(0), t.(1))
+
+
+let client_suggest timeout advr =
+ let loc = client_get_cur_loc () in
+ let (ts, t) = client_get_time () in
+ let m = client_msg ("EVAL LOC MOVES " ^ advr ^ ".0 " ^ loc ^
+ " TIMEOUT " ^ timeout ^ " 55500 alpha_beta_ord") in
+ client_set_time ts t;
+ let msg = Array.map strip_ws (split ";" m) in
+ if Array.length msg < 2 then "" else
+ let append_emb emb s =
+ let es = Array.map strip_ws (split ":" s) in
+ (es.(0), es.(1)) :: emb in
+ let emb = List.fold_left append_emb [] (split_list "," msg.(1)) in
+ client_move_str (emb, msg.(0), msg.(3))
+
+
+let client_model_get_elem_val el_id vl =
+ let v = client_msg ("GET FUN MODEL " ^ vl ^ " " ^ el_id) in
+ float_of_string v
+
+let client_model_get_elem_pos el_id =
+ (client_model_get_elem_val el_id "x", client_model_get_elem_val el_id "y")
+
+let client_model_get_elems () =
+ let m = client_msg "GET ALLOF ELEM MODEL " in
+ if String.length m < 1 then [] else List.map strip_ws (split_list ";" m)
+
+
+let client_model_get_dim () =
+ let (posx, posy) = List.split
+ (List.map client_model_get_elem_pos (client_model_get_elems ())) in
+ let mkfl f l = List.fold_left (fun x y -> f x y) (List.hd l) (List.tl l) in
+ let (minl, maxl, suml) = (mkfl min, mkfl max, mkfl (+.)) in
+ let minx, maxx, miny, maxy = minl posx, maxl posx, minl posy, maxl posy in
+ let sumx, sumy, l = suml posx, suml posy, float (List.length posx) in
+ (maxx, minx, maxy, miny, sumx /. l, sumy /. l)
+
+let client_model_get_rel_names_arities () =
+ let mrel = client_msg "GET SIGNATURE REL MODEL " in
+ if String.length mrel < 1 then [] else
+ let rel_of_ps ps =
+ let p = split ":" (strip_ws ps) in (strip_ws p.(0), strip_ws p.(1)) in
+ let rels = List.map rel_of_ps (split_list "," mrel) in
+ Aux.unique_sorted rels
+
+let client_model_get_rel rel_name =
+ let m = client_msg ("GET ALLOF REL MODEL " ^ rel_name) in
+ let first_br = max (str_find "{" m) (str_find "(" m) in
+ if first_br < 0 then [] else
+ let m_br = String.sub m first_br ((String.length m) - first_br) in
+ let tps = List.map (strip_all ["{";"}";"(";")"]) (split_list ";" m_br) in
+ List.map (fun ts -> List.map strip_ws (split_list "," ts)) tps
+
+let client_model_get_rels_simple () =
+ let sg = client_model_get_rel_names_arities () in
+ let app_rel_tuples tuples (r, _) =
+ (List.map (fun a -> (r, a)) (client_model_get_rel r)) @ tuples in
+ let tuples = List.fold_left app_rel_tuples [] sg in
+ let tp_str (r, a) = "(" ^ r ^ ", " ^ (lstr a) ^ ")" in
+ String.concat "; " (List.map tp_str tuples)
+
+let client_model_get_elems_with_pos () =
+ let m = client_msg "GET ALLOF ELEM MODEL " in
+ if String.length m < 1 then [] else
+ let els = List.map strip_ws (split_list ";" m) in
+ let els_p = List.map (fun e -> (e, client_model_get_elem_pos e)) els in
+ let ep_str (e, (x, y)) = Printf.sprintf "%s ; %f ; %f" e x y in
+ List.map ep_str els_p
+
+let client_get_game_info () =
+ let (x1, x2, y1, y2, mx, my) = client_model_get_dim () in
+ let dim_s = Printf.sprintf "(%f, %f, %f, %f, %f, %f)" x1 x2 y1 y2 mx my in
+ let model_s = lstr (client_model_get_elems_with_pos ()) in
+ let rels_s = client_model_get_rels_simple () in
+ let moves = client_cur_moves () in
+ let moves_s =
+ if String.length moves < 2 then client_get_payoffs () else moves in
+ dim_s ^ "$" ^ model_s ^ "$" ^ rels_s ^ "$" ^ moves_s
+
+
+
+(* ------------ Http Handlers ------------ *)
+
+let http_msg code mimetp cookies s =
+ let get_tm s =
+ let t = Unix.gmtime (Unix.gettimeofday() +. s) in
+ let day = match t.Unix.tm_wday with
+ | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed" | 4 -> "Thu"
+ | 5 -> "Fri" | 6 -> "Sat" | _ -> failwith "no such day" in
+ let mon = match t.Unix.tm_mon with
+ | 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr" | 4 -> "May"
+ | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug" | 8 -> "Sep" | 9 -> "Oct"
+ | 10 -> "Nov" | 11 -> "Dec" | _ -> failwith "no such month" in
+ Printf.sprintf "%s, %02i-%s-%04i %02i:%02i:%02i GMT" day t.Unix.tm_mday mon
+ (1900 + t.Unix.tm_year) t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec in
+ let ck_str (n, v, expires) =
+ let c = "Set-Cookie: " ^ n ^ "=" ^ v ^ "; " in
+ match expires with
+ | None -> c ^ "httponly"
+ | Some t -> c ^ "Expires=" ^ (get_tm t) ^ "; httponly" in
+ let cookies_s = String.concat "\n" (List.map ck_str cookies) in
+ "HTTP/1.1 " ^ code ^ "\r\n" ^
+ "Content-Type: " ^ mimetp ^ "\r\n" ^
+ (if cookies = [] then "" else cookies_s ^ "\r\n") ^
+ "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+
+let handle_http_get cmd head msg ck =
+ if !debug_level > 1 then (
+ Printf.printf "Http Get Handler\n%s%s\n%!" cmd msg;
+ if ck <> [] then
+ let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
+ Printf.printf "Cookies: %s\n%!" (String.concat "; " ck_strs);
+ );
+ let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
+ let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
+ let fname = "WebClient/" ^ fname_in in
+ if !debug_level > 1 then Printf.printf "SERVING FILE: %s;\n%!" fname;
+ if Sys.file_exists fname then (
+ let f = open_in fname in
+ let content = Aux.input_file f in
+ close_in f;
+ let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
+ | "ht" -> "text/html charset=utf-8"
+ | "ic" -> "image/x-icon"
+ | "pn" -> "image/png"
+ | "cs" -> "text/css"
+ | "js" -> "text/javascript"
+ | "sv" -> "image/svg+xml"
+ | _ -> "text/html charset=utf-8" in
+ http_msg "200 OK" tp [] content
+ ) else http_msg "404 NOT FOUND" "text/html charset=utf-8" []
+ ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
+ "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
+
+let handle_http_post cmd head msg ck =
+ let tUID = "toss_id_05174_" in
+ let dbFILE = "/var/www/WebClient/tossdb.sqlite" in
+ let tGAMES = ["Breakthrough"; "Checkers"; "Chess"; "Connect4";
+ "Entanglement"; "Gomoku"; "Pawn-Whopping"; "Tic-Tac-Toe"] in
+ let get_args s = Array.map (strip_all ["'"]) (split ", " s) in
+ let dbtable select tbl = DB.get_table dbFILE ~select tbl in
+ let passwd_from_db uid =
+ let res = dbtable ("id='" ^ uid ^ "'") "users" in
+ match List.length res with
+ | 0 -> None
+ | x when x > 1 -> failwith ("passwd from db: multiple entries for " ^ uid)
+ | _ -> let r = List.hd res in (* r = (uid,_,_,_,pwd) *) Some (r.(4)) in
+ let get_user_name_surname_mail uid =
+ let res = dbtable ("id='" ^ uid ^ "'") "users" in
+ match List.length res with
+ | 0 -> ("", "", "")
+ | x when x > 1 -> failwith ("get_user_name: multiple entries for " ^ uid)
+ | _ -> let r = List.hd res in (r.(1), r.(2), r.(3)) in
+ let verif_uid () =
+ let (ukey, pkey)= (tUID ^ "username", tUID ^ "passphrase") in
+ if not (List.mem_assoc ukey ck) then "" else
+ if not (List.mem_assoc pkey ck) then "" else
+ let (uid, pwd1) = (List.assoc ukey ck, List.assoc pkey ck) in
+ match passwd_from_db uid with None -> "" | Some pwd2 ->
+ if pwd1 = pwd2 then uid else "" in
+ let list_plays game pl_id =
+ let or_s = "(player1='" ^ pl_id ^ "' or player2='" ^ pl_id ^ "')" in
+ let plays = dbtable ("game='" ^ game ^ "' and " ^ or_s) "cur_states" in
+ let play_name p = (* p = (pid, g, p1, p2, move, _, _, _, _) *)
+ "/plays/"^ p.(1) ^"_"^ p.(2) ^"_"^ p.(3) ^"_"^ p.(0) ^"_"^ p.(4) in
+ lstr (List.map play_name plays) in
+ let user_plays uid =
+ let (name, _, _) = get_user_name_surname_mail uid in
+ let app_plays plays g = plays ^ "$" ^ (list_plays g uid) in
+ let plays = List.fold_left app_plays "" tGAMES in
+ uid ^ "$" ^ name ^ plays in
+ let get_free_id () = (DB.count_table dbFILE "cur_states") + 1 in
+ let db_cur_insert game p1 p2 pid move toss loc info svg_str =
+ DB.insert_table dbFILE "cur_states"
+ "playid, game, player1, player2, move, toss, loc, info, svg"
+ [pid; game; p1; p2; move; toss; loc; info; svg_str] in
+ let rec get_global_lock () =
+ let select = "locked='false' and tid='" ^ tUID ^ "'" in
+ let i = DB.update_table dbFILE ~select "locked='true'" "lock" in
+ if !debug_level > 1 then print_endline ("Glob lock " ^ (string_of_int i));
+ if i = 1 then () else get_global_lock () in
+ let release_global_lock () =
+ let select = "locked='true' and tid='" ^ tUID ^ "'" in
+ if !debug_level > 1 then print_endline "Glob lock release";
+ ignore (DB.update_table dbFILE ~select "locked='false'" "lock") in
+ let new_play game pl1 pl2 =
+ let toss = (List.hd (dbtable ("game='" ^ game ^ "'") "games")).(1) in
+ client_open_from_str toss;
+ let info = client_get_game_info () in
+ let model = client_get_model () in
+ let loc = client_get_cur_loc () in
+ let move_pl = int_of_string (client_get_loc_player loc) - 1 in
+ get_global_lock ();
+ let pid = string_of_int (get_free_id ()) in
+ db_cur_insert game pl1 pl2 pid (string_of_int move_pl) model loc info "";
+ release_global_lock ();
+ pid ^ "$" ^ info ^ "$" ^ (string_of_int move_pl) in
+ let game_select_s g p1 p2 pid m =
+ "game='" ^ g ^ "' and player1='" ^ p1 ^ "' and player2='" ^ p2 ^
+ "' and playid=" ^ pid ^ " and move=" ^ m in
+ let upd_svg g p1 p2 pid m svg_s =
+ let select = game_select_s g p1 p2 pid m in
+ let _ = DB.update_table dbFILE ~select ("svg='"^ svg_s ^"'") "cur_states" in
+ "" in
+ let db_escape s = str_replace "'" "''" s in
+ let move_play move_tup g p1 p2 pid m =
+ let sel_s = game_select_s g p1 p2 pid m in
+ let old_res= List.hd (dbtable sel_s "cur_states") in
+ let (old_toss, old_loc, old_info, old_svg) =
+ (old_res.(5), old_res.(6), old_res.(7), old_res.(8)) in
+ let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
+ client_open_from_str (game_toss ^ "\nMODEL " ^ old_toss);
+ client_set_cur_loc old_loc;
+ let (move1a, move2, move3) = move_tup in
+ let move1 = strip_all ["{"; "}"] move1a in
+ let new_pl = int_of_string (client_make_move move1 move2 move3) - 1 in
+ let new_toss = db_escape (client_get_model ()) in
+ let new_info = client_get_game_info () in
+ let new_info_db = db_escape new_info in
+ let cur_upd s =
+ ignore (DB.update_table dbFILE ~select:sel_s s "cur_states") in
+ cur_upd ("toss='" ^ new_toss ^ "'");
+ cur_upd ("info='" ^ new_info_db ^ "'");
+ cur_upd ("loc='" ^ move3 ^ "'");
+ cur_upd ("move=" ^ (string_of_int new_pl));
+ DB.insert_table dbFILE "old_states"
+ "playid, game, player1, player2, move, toss, loc, info, svg"
+ [pid; g; p1; p2; m; old_toss; old_loc; old_info; old_svg];
+ new_info ^ "$" ^ (string_of_int new_pl) in
+ let suggest time g p1 p2 pid m =
+ let res = List.hd (dbtable (game_select_s g p1 p2 pid m) "cur_states") in
+ let (toss, loc) = (res.(5), res.(6)) in
+ let game_toss = (List.hd (dbtable ("game='" ^ g ^ "'") "games")).(1) in
+ client_open_from_str (game_toss ^ "\nMODEL " ^ toss);
+ client_set_cur_loc loc;
+ let adv_ratio_data = client_get_data "adv_ratio" in
+ let adv_ratio = if adv_ratio_data = "none" then "4" else adv_ratio_data in
+ client_suggest time adv_ratio in
+ let register_user ui =
+ if Array.length ui <> 5 then false else
+ let (uid, name, surname, email, pwd) =
+ (ui.(0), ui.(1), ui.(2), ui.(3), ui.(4)) in
+ match passwd_from_db uid with Some _ -> false | None ->
+ DB.insert_table dbFILE "users" "id, name, surname, email, passwd"
+ [uid; name; surname; email; pwd];
+ DB.insert_table dbFILE "friends" "id, fid" [uid; "computer"];
+ true in
+ let login_user uid chk pwd =
+ match passwd_from_db uid with
+ | None -> ("no such user registered", [])
+ | Some p when p <> pwd -> ("wrong password", [])
+ | Some _ ->
+ let exp = if chk then Some (float (3600 * 1000)) else None in
+ ("OK", [(tUID^"username", uid, exp); (tUID^"passphrase", pwd, exp)]) in
+ let list_friends all uid =
+ if all then List.map (fun a -> a.(0)) (dbtable "" "users") else
+ let friends = dbtable ("id='" ^ uid ^ "'") "friends" in
+ List.map (fun a -> a.(1)) friends in
+ let open_db game p1 p2 pid move =
+ let res = dbtable (game_select_s game p1 p2 pid move) "cur_states" in
+ let (move, info) = ((List.hd res).(4), (List.hd res).(7)) in
+ info ^ "$" ^ move in
+ let add_opponent uid oppid =
+ if uid = "" then "You must login first to add opponents." else
+ let (name, _, _) = get_user_name_surname_mail oppid in
+ if name = "" then "No such opponent found among tPlay users." else (
+ DB.insert_table dbFILE "friends" "id, fid" [uid; oppid];
+ "OK"
+ ) in
+ let change_user_data uid udata =
+ if uid = "" then "You must login first to change data." else
+ if Array.length udata <> 3 then "Internal error, data not changed." else
+ let uid_s = "id='" ^ uid ^ "'" in
+ let upd s = ignore (DB.update_table dbFILE ~select:uid_s s "users") in
+ upd ("name='" ^ udata.(0) ^ "'");
+ upd ("surname='" ^ udata.(1) ^ "'");
+ upd ("email='" ^ udata.(2) ^ "'");
+ "OK" in
+ if !debug_level > 1 then
+ Printf.printf "POST\n%s\n%s\nCONTENT\n%s\nEND CONTENT\n" cmd head msg;
+ let (tcmd, data) = split_two "#" msg in
+ let resp, new_cookies = match tcmd with
+ | "USERNAME" ->
+ verif_uid (), []
+ | "USERPLAYS" ->
+ if verif_uid () = "" then "", [] else user_plays (verif_uid ()), []
+ | "REGISTER" ->
+ let ui = split "$" data in
+ if register_user ui then
+ "Registration successful for " ^ ui.(0) ^ ".", []
+ else
+ "Registration failed:\n username " ^ ui.(0) ^ " already in use." ^
+ "\nPlease choose another username and try again.", []
+ | "LOGIN" ->
+ let ui = split "$" data in
+ if Array.length ui = 3 then (
+ let (resp, new_ck) = login_user ui.(0) (ui.(1) = "true") ui.(2) in
+ if resp = "OK" then (resp, new_ck) else
+ ("Login failed for " ^ ui.(0) ^ ": " ^ resp, [])
+ ) else "Login: internal error", []
+ | "LOGOUT" ->
+ let c =
+ [(tUID ^ "username", "a", None); (tUID ^ "passphrase", "a", None)] in
+ ("User logged out: " ^ (verif_uid ()), c)
+ | "ADDOPP" ->
+ add_opponent (verif_uid ()) data, []
+ | "GET_NAME" ->
+ let (name, _, _) = get_user_name_surname_mail data in name, []
+ | "GET_SURNAME" ->
+ let (_, surname, _) = get_user_name_surname_mail data in surname, []
+ | "LIST_FRIENDS" ->
+ lstr (list_friends (data = "**") (verif_uid ())), []
+ | "GET_MAIL" ->
+ if verif_uid()="" then "You must login first to get email data.", [] else
+ let (_, _, mail) = get_user_name_surname_mail data in mail, []
+ | "CHANGEUSR" ->
+ change_user_data (verif_uid ()) (split "$" data), []
+ | "LIST_PLAYS" ->
+ let a = get_args data in list_plays a.(0) a.(1), []
+ | "OPEN_DB" ->
+ let a = get_args data in open_db a.(0) a.(1) a.(2) a.(3) a.(4), []
+ | "UPD_SVG" ->
+ let a = Array.map (strip_all ["'"]) (split ~bound:(Some 6) ", " data) in
+ upd_svg a.(0) a.(1) a.(2) a.(3) a.(4) a.(5), []
+ | "NEW_PLAY" ->
+ let a = get_args data in new_play a.(1) a.(2) a.(3), []
+ | "SUGGEST" ->
+ let a = get_args data in suggest a.(1) a.(2) a.(3) a.(4) a.(5) a.(6), []
+ | "MOVE_PLAY" ->
+ let (op_i, cl_i) = (String.index data '(', String.index data ')') in
+ let tp_s = String.sub data (op_i+1) (cl_i - op_i-1) in
+ let args_s = String.sub data (cl_i+2) ((String.length data) - cl_i-2) in
+ let tp_i, tp_l = String.rindex tp_s ',', String.length tp_s in
+ let tp_j = String.rindex_from tp_s (tp_i - 1) ',' in
+ let tp0 = String.sub tp_s 0 tp_j in
+ let tp1 = String.sub tp_s (tp_j+1) (tp_i - tp_j - 1) in
+ let tp2 = String.sub tp_s (tp_i+1) (tp_l - tp_i - 1) in
+ let tp, a = (strip_ws tp0, strip_ws tp1, strip_ws tp2), get_args args_s in
+ move_play tp a.(0) a.(1) a.(2) a.(3) a.(4), []
+ | _ ->
+ "MOD_PYTHON ERROR ; Traceback: Unknown Toss Command! \n " ^ tcmd, [] in
+ http_msg "200 OK" "text/html charset=utf-8" new_cookies resp
+
+
+let handle_http_msg rstate cmd head msg ck =
+ if String.sub cmd 0 5 = "GET /" then
+ rstate, handle_http_get cmd head msg ck
+ else if String.length cmd > 13 && String.sub cmd 0 13 = "POST /Handler" then
+ rstate, handle_http_post cmd head msg ck
+ else try
+ req_handle rstate
+ (Aux.Right (GDLParser.parse_request KIFLexer.lex
+ (Lexing.from_string msg)))
+ with Parsing.Parse_error | Lexer.Parsing_error _ ->
+ rstate, handle_http_post cmd head msg ck
+
+
+
+(* ------- Full Request Handler (both Html and Generic Toss) ------- *)
+
let rec read_in_line in_ch =
let line_in =
let rec nonempty () =
@@ -166,7 +644,8 @@
match Aux.input_if_http_message line_in in_ch with
| Some (head, msg, cookies) ->
if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
- ("HTTP", Some (Aux.Left (line_in, head, msg, cookies)))
+ let ck = List.map (fun (k, v) -> (strip_ws k, strip_ws v)) cookies in
+ ("HTTP", Some (Aux.Left (line_in, head, msg, ck)))
| None ->
if line_in = "COMP" then
let res = Marshal.from_channel in_ch in
@@ -181,65 +660,7 @@
if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
(line, None)
-let http_msg code mimetp cookies s =
- let get_tm s =
- let t = Unix.gmtime (Unix.gettimeofday() +. s) in
- let day = match t.Unix.tm_wday with
- | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed" | 4 -> "Thu"
- | 5 -> "Fri" | 6 -> "Sat" | _ -> failwith "no such day" in
- let mon = match t.Unix.tm_mon with
- | 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr" | 4 -> "May"
- | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug" | 8 -> "Sep" | 9 -> "Oct"
- | 10 -> "Nov" | 11 -> "Dec" | _ -> failwith "no such month" in
- Printf.sprintf "%s, %02i-%s-%04i %02i:%02i:%02i GMT" day t.Unix.tm_mday mon
- (1900 + t.Unix.tm_year) t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec in
- let ck_str (n, v, expires) =
- let c = "Set-Cookie: " ^ n ^ "=" ^ v ^ "; " in
- match expires with
- | None -> c ^ "httponly"
- | Some t -> c ^ "Expires=" ^ (get_tm t) ^ "; httponly" in
- let cookies_s = String.concat "\n" (List.map ck_str cookies) in
- "HTTP/1.1 " ^ code ^ "\r\n" ^
- "Content-Type: " ^ mimetp ^ "\r\n" ^
- (if cookies = [] then "" else cookies_s ^ "\r\n") ^
- "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
-let handle_pure_http cmd head msg ck =
- if !debug_level > 0 then (
- Printf.printf "Pure Http Handler\n%s%s\n%!" cmd msg;
- if ck <> [] then
- let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
- Printf.printf "Cookies: %s\n%!" (String.concat "; " ck_strs);
- );
- if String.sub cmd 0 5 = "GET /" then (
- let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
- let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
- let fname = "WebClient/" ^ fname_in in
- if !debug_level > 0 then Printf.printf "SERVING FILE: %s;\n%!" fname;
- if Sys.file_exists fname then (
- let f = open_in fname in
- let content = Aux.input_file f in
- close_in f;
- let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
- | "ht" -> "text/html charset=utf-8"
- | "ic" -> "image/x-icon"
- | "pn" -> "image/png"
- | "cs" -> "text/css"
- | "js" -> "text/javascript"
- | "sv" -> "image/svg+xml"
- | _ -> "text/html charset=utf-8" in
- http_msg "200 OK" tp [] content
- ) else http_msg "404 NOT FOUND" "text/html charset=utf-8" []
- ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
- "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
- ) else (
- if !debug_level > 1 then
- Printf.printf "POST\n%s\n%s\nCONTENT\n%s\nEND CONTENT\n" cmd head msg;
- http_msg "200 OK" "text/html charset=utf-8" [("post","error", Some 5.)]
- ("<html>\n<head><title>Errror</title></head>\n" ^
- "<body><p>Http POST not functional yet</p></body>\n</html>")
- )
-
let full_req_handle rstate in_ch out_ch =
try
let time_started = Unix.gettimeofday () in
@@ -258,16 +679,9 @@
Marshal.to_channel out_ch res [Marshal.Closures];
flush out_ch;
rstate
- | (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" -> (
- report (
- try
- req_handle rstate
- (Aux.Right (GDLParser.parse_request KIFLexer.lex
- (Lexing.from_string msg)))
- with Parsing.Parse_error | Lexer.Parsing_error _ ->
- rstate, handle_pure_http cmd head msg ck
- ))
- | (_, Some _) -> failwith "Internal ReqHandler Error!"
+ | (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" ->
+ report (handle_http_msg rstate cmd head msg ck)
+ | (_, Some _) -> failwith "Internal ReqHandler Error (full_req_handle)!"
| (line, None) ->
report (req_handle rstate
(Aux.Left (ArenaParser.parse_request Lexer.lex
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/Server/Server.ml 2011-05-12 23:29:43 UTC (rev 1436)
@@ -131,7 +131,6 @@
let (server, port) = (ref "localhost", ref 8110) in
let (test_s, test_full) = (ref "# # / $", ref false) in
let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
- let sqltest = ref "" in
let set_parallel_port p =
let (_, s) = !GameTree.parallel_toss in
GameTree.parallel_toss := (p, s) in
@@ -143,7 +142,6 @@
("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss 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)");
- ("-sql", Arg.String (fun s -> (sqltest := s)), " sql testing (temporary)");
("-f", Arg.String (fun s -> set_state_from_file s), " open file");
("-nm", Arg.Unit (fun () -> Heuristic.use_monotonic := false),
" monotonicity off");
@@ -188,8 +186,6 @@
ignore (OUnit.run_test_tt ~verbose (Tests.tests ~full ~dirs ~files ()))
) else if !experiment then
run_test !e_len !e_d1 !e_d2
- else if !sqltest <> "" then
- DB.print_rows (DB.get_table "WebClient/tossdb.sqlite" !sqltest)
else try
start_server req_handle !port !server
with Aux.Host_not_found ->
Modified: trunk/Toss/WebClient/Main.js
===================================================================
--- trunk/Toss/WebClient/Main.js 2011-05-09 23:43:28 UTC (rev 1435)
+++ trunk/Toss/WebClient/Main.js 2011-05-12 23:29:43 UTC (rev 1436)
@@ -99,7 +99,8 @@
function show_move (m) {
var m_act = get_move_elems (m);
m_act.sort ();
- var m_rule = m.substring (m.indexOf("},")+4, m.lastIndexOf(',')-1);
+ var m_rule = strip ("'", " ",
+ m.substring (m.indexOf("},")+3, m.lastIndexOf(',')));
for (var i = 0; i < CUR_ELEMS.length; i++) {
unhighlight_elem (CUR_ELEMS[i]);
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-09 23:43:35
|
Revision: 1435
http://toss.svn.sourceforge.net/toss/?rev=1435&view=rev
Author: lukaszkaiser
Date: 2011-05-09 23:43:28 +0000 (Mon, 09 May 2011)
Log Message:
-----------
WebClient corrections, better http handling in TossServer.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/WebClient/Handler.py
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/Formula/Aux.ml 2011-05-09 23:43:28 UTC (rev 1435)
@@ -614,21 +614,40 @@
let rec input_http_message file =
let buf = Buffer.create 256 in
- let line = ref "POST / HTTP" in
- let msg_len = ref 0 in
+ let get_pair s =
+ let i, l = String.index s '=', String.length s in
+ (String.sub s 0 i, String.sub s (i+1) (l-i-1)) in
+ let rec get_cookies s =
+ try
+ let i, l = String.index s ';', String.length s in
+ (get_pair (String.sub s 0 i)) :: get_cookies (String.sub s (i+1) (l-i-1))
+ with Not_found -> [] in
+ let line, head, cookies, msg_len = ref "HTTP", ref [], ref [], ref 0 in
while !line <> "" do
line := strip_spaces (input_line file);
+ head := !line :: !head;
let line_len = String.length !line in
- if line_len > 16 && String.sub !line 0 15 = "Content-length:" then (
- msg_len := int_of_string
- (String.sub !line 16 (line_len - 16));
- )
+ if line_len > 6 && String.lowercase (String.sub !line 0 6) = "cookie" then (
+ let start = (String.index !line ' ') + 1 in
+ let ck_str = String.sub !line start (line_len - start) in
+ cookies := get_cookies (ck_str ^ ";") @ !cookies
+ );
+ if line_len > 16 &&
+ String.lowercase (String.sub !line 0 15) = "content-length:" then (
+ msg_len := int_of_string (String.sub !line 16 (line_len - 16));
+ )
done;
Buffer.add_channel buf file !msg_len;
- Buffer.contents buf
+ (String.concat "\n" !head, Buffer.contents buf, !cookies)
+let input_if_http_message line in_ch =
+ let ht1, ht2 = "GET /", "POST /" in
+ let l1, l2, l = String.length ht1, String.length ht2, String.length line in
+ if ((l > l1 && String.sub line 0 l1 = ht1) ||
+ (l > l2 && String.sub line 0 l2 = ht2)) then
+ Some (input_http_message in_ch)
+ else None
-
exception Host_not_found
let get_inet_addr addr_s =
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/Formula/Aux.mli 2011-05-09 23:43:28 UTC (rev 1435)
@@ -295,10 +295,14 @@
(** Input a file to a string. *)
val input_file : in_channel -> string
-(** Skip the header extracting the [Content-length] field and input the
- content of an HTTP message. *)
-val input_http_message : in_channel -> string
+(** Extracting the [Content-length] field and input the content of
+ an HTTP message. Return the pair: header first, content next. *)
+val input_http_message : in_channel -> string * string * (string * string) list
+(** Input HTTP message if [line] is a http header, ie. "GET /" or "POST /".*)
+val input_if_http_message : string -> in_channel ->
+ (string * string * (string * string) list) option
+
(** Exception used in connections when the host is not found. *)
exception Host_not_found
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/GGP/Makefile 2011-05-09 23:43:28 UTC (rev 1435)
@@ -26,10 +26,10 @@
make tictactoe.black
make breakthrough.white
make breakthrough.black
- make pawn_whopping.white
- make pawn_whopping.black
- make connect4.white
- make connect4.black
+ #make pawn_whopping.white
+ #make pawn_whopping.black
+ #make connect4.white
+ #make connect4.black
make connect5.white
make connect5.black
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-09 23:43:28 UTC (rev 1435)
@@ -43,56 +43,6 @@
exception Found of int
-let req_of_str s =
- let s_len = String.length s in
- if s_len > 4 && String.sub s 0 4 = "GDL "
- then (
- (* {{{ log entry *)
- if !debug_level > 1 then (
- Printf.printf "req_of_str-GDL:\n%s\n%!" (String.sub s 4 (s_len-4));
- );
- (* }}} *)
- Aux.Right (GDLParser.parse_request KIFLexer.lex
- (Lexing.from_string (String.sub s 4 (s_len-4))))
- )
- else
- Aux.Left (ArenaParser.parse_request Lexer.lex (Lexing.from_string s))
-
-
-let rec read_in_line in_ch =
- let line_in =
- let rec nonempty () =
- let line_in = input_line in_ch in
- if line_in = "" || line_in = "\r" then nonempty ()
- else line_in in
- nonempty () in
- let line_in_len = String.length line_in in
- (* TODO: who needs escaping? *)
- let line_in =
- if line_in.[line_in_len-1] <> '\r' then
- (* String.escaped *) line_in
- else
- (* String.escaped *) (String.sub line_in 0 (line_in_len-1)) in
- let http_beg = "POST / HTTP/" in
- let http_beg_l = String.length http_beg in
- if line_in_len > http_beg_l && String.sub line_in 0 http_beg_l = http_beg
- then
- let msg = Aux.input_http_message in_ch in
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
- ("GDL " ^ msg, None)
- else if line_in = "COMP" then
- let res = Marshal.from_channel in_ch in
- ("COMP", Some res)
- else
- (* We put endlines, encoded by '$', back into the message.
- TODO: perhaps a "better" solution now that HTTP has one? *)
- let line =
- String.concat "\n"
- (Str.split (Str.regexp "\\$") line_in) in
- if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
- (line, None)
-
-
let req_handle (g_heur, game_modified, state, gdl_transl, playclock) = function
| Aux.Left (Arena.SuggestLocMoves
(loc, timer, effort, _, _, heuristic, advr)) -> (
@@ -193,30 +143,135 @@
("HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: "
^ string_of_int msg_len ^ "\r\n\r\n" ^ mov_msg) in
(g_heur, game_modified, state, gdl_transl, playclock), resp
+
+(* --------- LINES PARSING AND FULL REQUEST HANDLING ------------ *)
+
+let rec read_in_line in_ch =
+ let line_in =
+ let rec nonempty () =
+ let line_in = input_line in_ch in
+ if line_in = "" || line_in = "\r" then nonempty ()
+ else line_in in
+ nonempty () in
+ let line_in_len = String.length line_in in
+ (* TODO: who needs escaping? *)
+ let line_in =
+ if line_in.[line_in_len-1] <> '\r' then
+ (* String.escaped *) line_in
+ else
+ (* String.escaped *) (String.sub line_in 0 (line_in_len-1)) in
+ match Aux.input_if_http_message line_in in_ch with
+ | Some (head, msg, cookies) ->
+ if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
+ ("HTTP", Some (Aux.Left (line_in, head, msg, cookies)))
+ | None ->
+ if line_in = "COMP" then
+ let res = Marshal.from_channel in_ch in
+ if !debug_level > 0 then Printf.printf "COMP\n%!";
+ ("COMP", Some (Aux.Right res))
+ else
+ (* We put endlines, encoded by '$', back into the message.
+ TODO: perhaps a "better" solution now that HTTP has one? *)
+ let line =
+ String.concat "\n"
+ (Str.split (Str.regexp "\\$") line_in) in
+ if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
+ (line, None)
+
+let http_msg code mimetp cookies s =
+ let get_tm s =
+ let t = Unix.gmtime (Unix.gettimeofday() +. s) in
+ let day = match t.Unix.tm_wday with
+ | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed" | 4 -> "Thu"
+ | 5 -> "Fri" | 6 -> "Sat" | _ -> failwith "no such day" in
+ let mon = match t.Unix.tm_mon with
+ | 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr" | 4 -> "May"
+ | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug" | 8 -> "Sep" | 9 -> "Oct"
+ | 10 -> "Nov" | 11 -> "Dec" | _ -> failwith "no such month" in
+ Printf.sprintf "%s, %02i-%s-%04i %02i:%02i:%02i GMT" day t.Unix.tm_mday mon
+ (1900 + t.Unix.tm_year) t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec in
+ let ck_str (n, v, expires) =
+ let c = "Set-Cookie: " ^ n ^ "=" ^ v ^ "; " in
+ match expires with
+ | None -> c ^ "httponly"
+ | Some t -> c ^ "Expires=" ^ (get_tm t) ^ "; httponly" in
+ let cookies_s = String.concat "\n" (List.map ck_str cookies) in
+ "HTTP/1.1 " ^ code ^ "\r\n" ^
+ "Content-Type: " ^ mimetp ^ "\r\n" ^
+ (if cookies = [] then "" else cookies_s ^ "\r\n") ^
+ "Content-length: " ^ (string_of_int (String.length s)) ^ "\r\n\r\n" ^ s
+
+let handle_pure_http cmd head msg ck =
+ if !debug_level > 0 then (
+ Printf.printf "Pure Http Handler\n%s%s\n%!" cmd msg;
+ if ck <> [] then
+ let ck_strs = List.map (fun (n, v) -> n ^ "=" ^ v) ck in
+ Printf.printf "Cookies: %s\n%!" (String.concat "; " ck_strs);
+ );
+ if String.sub cmd 0 5 = "GET /" then (
+ let fname_in0 = String.sub cmd 5 ((String.index_from cmd 5 ' ') - 5) in
+ let fname_in = if fname_in0 = "" then "index.html" else fname_in0 in
+ let fname = "WebClient/" ^ fname_in in
+ if !debug_level > 0 then Printf.printf "SERVING FILE: %s;\n%!" fname;
+ if Sys.file_exists fname then (
+ let f = open_in fname in
+ let content = Aux.input_file f in
+ close_in f;
+ let tp = match String.sub fname ((String.index fname '.') + 1) 2 with
+ | "ht" -> "text/html charset=utf-8"
+ | "ic" -> "image/x-icon"
+ | "pn" -> "image/png"
+ | "cs" -> "text/css"
+ | "js" -> "text/javascript"
+ | "sv" -> "image/svg+xml"
+ | _ -> "text/html charset=utf-8" in
+ http_msg "200 OK" tp [] content
+ ) else http_msg "404 NOT FOUND" "text/html charset=utf-8" []
+ ("<html>\n<head><title>Toss: Page Not Found</title></head>\n" ^
+ "<body><p>Not found: " ^ fname_in ^ "</p></body>\n</html>")
+ ) else (
+ if !debug_level > 1 then
+ Printf.printf "POST\n%s\n%s\nCONTENT\n%s\nEND CONTENT\n" cmd head msg;
+ http_msg "200 OK" "text/html charset=utf-8" [("post","error", Some 5.)]
+ ("<html>\n<head><title>Errror</title></head>\n" ^
+ "<body><p>Http POST not functional yet</p></body>\n</html>")
+ )
+
let full_req_handle rstate in_ch out_ch =
try
let time_started = Unix.gettimeofday () in
- let (line, marshaled) = read_in_line in_ch in
- if line = "COMP" && marshaled <> None then (
- let (f, x) = Aux.unsome marshaled in
- let res = f x in
- Marshal.to_channel out_ch res [Marshal.Closures];
- flush out_ch;
- rstate
- ) else (
- let req = req_of_str line in
- let new_rstate, resp = req_handle rstate req in
+ let report (new_rstate, resp) =
if !debug_level > 0 then (
Printf.printf "Resp-time: %F\n%!" (Unix.gettimeofday() -. time_started);
- print_endline ("\nRepl: " ^ resp ^ "\n");
- );
+ if !debug_level > 1 || String.length resp < 500 then
+ print_endline ("\nRepl: " ^ resp ^ "\n");
+ );
output_string out_ch (resp ^ "\n");
flush out_ch;
- new_rstate
- )
+ new_rstate in
+ match read_in_line in_ch with
+ | (line, Some (Aux.Right (f, x))) when line = "COMP" ->
+ let res = f x in
+ Marshal.to_channel out_ch res [Marshal.Closures];
+ flush out_ch;
+ rstate
+ | (line, Some (Aux.Left (cmd, head, msg, ck))) when line = "HTTP" -> (
+ report (
+ try
+ req_handle rstate
+ (Aux.Right (GDLParser.parse_request KIFLexer.lex
+ (Lexing.from_string msg)))
+ with Parsing.Parse_error | Lexer.Parsing_error _ ->
+ rstate, handle_pure_http cmd head msg ck
+ ))
+ | (_, Some _) -> failwith "Internal ReqHandler Error!"
+ | (line, None) ->
+ report (req_handle rstate
+ (Aux.Left (ArenaParser.parse_request Lexer.lex
+ (Lexing.from_string line))))
with
| Parsing.Parse_error ->
Printf.printf "Toss Server: parse error\n%!";
Modified: trunk/Toss/WebClient/Handler.py
===================================================================
--- trunk/Toss/WebClient/Handler.py 2011-05-09 01:19:32 UTC (rev 1434)
+++ trunk/Toss/WebClient/Handler.py 2011-05-09 23:43:28 UTC (rev 1435)
@@ -20,7 +20,7 @@
def open_toss_server (port):
args = [MakeDB.SERVER_FILE,
- "-nogdl", "-s", "localhost", "-p", str(port)]
+ "-s", "localhost", "-p", str(port)]
server_proc = subprocess.Popen(args)
time.sleep (0.1)
return (port)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-09 01:19:40
|
Revision: 1434
http://toss.svn.sourceforge.net/toss/?rev=1434&view=rev
Author: lukaszkaiser
Date: 2011-05-09 01:19:32 +0000 (Mon, 09 May 2011)
Log Message:
-----------
Playing with Chess heuristic, Chess allowed in WebClient. Moving ServerTest to ReqHandlerTest as it should be, then moving TossTest and TossFullTest to Tests ml in Server, which is now executed from TossServer (one target spares ocamlbuild). Splitting GDL ml to GDL with basic functions and Translate ml with most code.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Makefile
trunk/Toss/Formula/Makefile
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/Makefile
trunk/Toss/Makefile
trunk/Toss/Play/Makefile
trunk/Toss/Server/Makefile
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/Makefile
trunk/Toss/Solver/Solver.ml
trunk/Toss/WebClient/Handler.py
trunk/Toss/WebClient/Main.js
trunk/Toss/examples/Chess.toss
Added Paths:
-----------
trunk/Toss/GGP/Translate.ml
trunk/Toss/GGP/Translate.mli
trunk/Toss/GGP/TranslateTest.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Server/Tests.mli
Removed Paths:
-------------
trunk/Toss/Server/ServerTest.ml
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-05-07 22:30:43 UTC (rev 1433)
+++ trunk/Toss/Arena/Arena.ml 2011-05-09 01:19:32 UTC (rev 1434)
@@ -264,9 +264,10 @@
(* }}} *)
let graph = Array.of_list (List.rev locations) in
(* TODO; FIXME; JUST THIS List.rev ABOVE WILL NOT ALWAYS BE GOOD, OR?!! *)
+ let pats = List.rev_map (FormulaOps.subst_rels_expr def_rels_pure) patterns in
{
rules = rules;
- patterns = List.rev patterns;
+ patterns = pats;
graph = graph;
num_players = num_players;
player_names = player_names;
Modified: trunk/Toss/Arena/Makefile
===================================================================
--- trunk/Toss/Arena/Makefile 2011-05-07 22:30:43 UTC (rev 1433)
+++ trunk/Toss/Arena/Makefile 2011-05-09 01:19:32 UTC (rev 1434)
@@ -1,7 +1,7 @@
all: tests
%Test:
- make -C .. Arena/$@
+ make -C .. Arena/$@Verbose
TermTest:
DiscreteRuleTest:
Modified: trunk/Toss/Formula/Makefile
===================================================================
--- trunk/Toss/Formula/Makefile 2011-05-07 22:30:43 UTC (rev 1433)
+++ trunk/Toss/Formula/Makefile 2011-05-09 01:19:32 UTC (rev 1434)
@@ -1,7 +1,7 @@
all: tests
%Test:
- make -C .. Formula/$@
+ make -C .. Formula/$@Verbose
AuxTest:
FormulaTest:
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-05-07 22:30:43 UTC (rev 1433)
+++ trunk/Toss/GGP/GDL.ml 2011-05-09 01:19:32 UTC (rev 1434)
@@ -1,592 +1,8 @@
-
(** {2 Game Description Language.}
+ Type definitions, helper functions, game specification. *)
- Type definitions, helper functions, game specification
- translation.
+open Aux.BasicOperators
- 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. To avoid ungrounded player variables, add
- "role" filter to "legal" rules.
-
- (1a) Reason for unsoundness: "legal" or "next" preconditions can
- depend negatively on state, preventing further moves in the
- 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.
-
- In case of problems, it should be relatively easy to expand the
- translation to use a single location per player, and for rules to
- determine which player is active after the rule takes effect
- (i.e. the target location.) Once Toss has a good system for
- simultaneous moves, we can simplify by translating into a single
- location game, obsoleting this "chapter".
-
- (2a) We need to recognize which player actually makes a move in a
- state. For this we need to locate the "noop" arguments to "legal"
- and "does" relations. A noop action in a location is the only
- 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.
-
- (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.
-
- (3c3) When [nonerasing_frame_wave] is set to [true], remove
- branches that have a variable/variable mismatch at proposed fluent
- position.(TODO)
-
- (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.
-
- TODO: this is wrong! Generates too many masks compared to the
- paper method (using fluent paths). Should generalize masks that
- do not differ at constant/functor-constant/functor positions.
-
- (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 (which is applied in (7i-4c) only if not adding mask-path
- predicates, fact or equivalence relations from which it can be
- inferred). For each mask-path pointing to a constant in some of
- the elements and that constant, introduce a new predicate with
- semantics: "matches the mask and has the constant at the path
- position".
-
- Optionally, also include a positive mask predicate for negative
- state terms (rather than a negative one).
-
- (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.)
-
- First, we expand all uses of the built-in "role" predicate.
-
- (6a) The definition:
-
- [(r, params1) <= body1 ... (r, params_n) <= body_n]
-
- provides a DNF defining formula (using negation-as-failure):
-
- [(r, args) <=> exist vars1 (params1 = args /\ body1) \/ ...
- \/ exist vars_n (params_n = args /\ 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 [params_i = args] in the whole
- [i]th cloned branch, eliminating the [params] (rather than the
- [args]) when possible. 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)]
-
- (6b1) If the relation has negative subformulas in any of [body_i],
- unless all the negative subformulas are just "distinct" checks
- that become ground, we first negate the definition and then expand
- the negation as in the positive case.
-
- (6b1a) Eliminate [args = params_i] by substituting-out variables
- from [params_i] whenever possible.
-
- Note: the [args] need to be instatiated for the particular
- solution that is extended (the solution substitution applied).
-
- (6b1b) We group the positive atoms of body_i together and split
- the quantifier if each negative subformula and the positive part
- have disjoint [vars_i] variables; if not, the translation fails;
- currently, if a negative subformula has free variables in vars_i,
- the translation also fails.
-
- (6b1c) So we have two levels of specification-affecting TODOs;
- working around variables shared between negated subformulas or the
- positive part -- forbidding pushing quantification inside -- will
- require major rethinking of implementation; if the quantification
- can be pushed inside but doesn't disappear around a negated
- subformula, we will need to extend the universal quantifier
- handling from only negated to both negated and positive
- subformulas, which shouldn't be problematic.
-
- (6b1d) Now push the negation inside the conjunction so that all
- double negations cancel out (the positive conjuncts are under a
- single, now negated, quantifier -- see (6b2) about negated
- conjunctions of atoms). Next we pull the disjunctions out
- (reducing to DNF-like form), and continue as in the positive case
- (6a).
-
- (6b2) We allow conjunctions of atoms to be negated (not only
- literals) in a branch. We expand [not (r, args)] (in general, [not
- (and (...(r args)...))]) into the conjunction of negations, with
- no branch duplication (in general, duplicating the negated
- subformula inside a branch). We only apply the unifier of [args =
- params_i] to [body_i] (in general, the whole negated subformula),
- eliminating the [params] (rather than the [args]) when
- possible. Still, we freshen each [vars_i] to avoid capture. We
- remember the (uneliminated) [vars_i] in the set of variables
- quantified existentially under the negation (since the free
- variables occurring only under the negation are quantified
- universally there -- it is a positive position). 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.
-
- (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 "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.
-
- (7a1) Filter "lead legal" rules by satisfiability in the current
- location plys of the aggregate playout.
-
- (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. TODO: rethink, compare with (7f2).
-
- (7e) Associate negation of equalities specific to the unifiers
- strictly less general than the equivalence class with it, so that
- 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 (TODO: some? (x)) 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.
-
- (x) It is probably better to not expand "identity" branches that
- have both fixed and unfixed variables in the head, as they will be
- correctly handled (translated to erasure branches) in the
- following code.
-
- (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:
-
- (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. The local variables of newly created negated
- subformulas become existentially-quantified-under-negation
- (i.e. universally quantified) (while the local variables of old
- negated subformulas are "let free").
-
- FIXME: it is probably wrongly assumed in the implementation that
- negated "distinct" unifies all terms, instead of disjunction of
- pairwise unification, check that.
-
- (7f4) Drop the erasure branches that contradict the "legal"
- condition of their rule. (Add the "legal" condition for early pruning.)
-
- (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).
-
- (7f6) Filter-out branches that are not satisfiable by their static
- part (in the initial structure).
-
- (7g) NOOP (Was eliminating unfixed variables.)
-
- (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 (7l1) we keep
- both the (partially) Toss-translated versions and the (complete)
- GDL-originals of branches (so to use GDL atoms for "subsumption
- checking" in (7l)).
-
- (7i-7k) Variables corresponding to negated "true" atoms
- that contain locally existentially quantified variables are
- quantified universally (with a scope containing all their
- occurrences).
-
- Implementation: we only introduce universal quantification after
- filtering (7m), is it OK?
-
- (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. Only
- build the relation over positive elements, deferring negated ones
- to (7k-4a) so that they are included under common
- disjunction. Relations over elements coming from different
- negations are not introduced, which agrees with negation-as-failure.
-
- (7i-4c) Include the (4c) relations for "next" and "true" positive
- atoms.
-
- (7i-4b) (4b) is essentially a special case of (4a). Add an
- appropriate equality relation of (4b) for each case of subterm
- shared by terms corresponding to different positive elements.
-
- Implementation: instead of all subterms we currently only consider
- subterms that instantiate (ordinary) variables in the mask
- corresponding to the "next"/"true" atom.
-
- (7i0) For "distinct", negate the anchors of the constants at mask
- paths of the variables, and equivalences of the variables (if
- there are multiple variables).
-
- TODO: currently only checks whether "distinct" arguments are
- syntactically equal.
-
- (7i1) Remove branches that are unsatisfiable by their static
- relations (4a), (4b) and (positive) (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.) Such fixed variables should be expanded by duplicating
- the whole set of branches together with the "lead legal" term.
-
- Implementation: TODO; currently, we check for such fixed
- variables and fail if they're present.
-
- (7k) Replace the "next" and "true" atoms by the conjunction of
- (4b), (4c) and (5) predicates over their corresponding variable. (For
- negative "true" literals this will be equivalent to a disjunction
- of negations of the predicates.) Note that positive static
- relations are already added in (7i-4b,4c). Handle negative subformula
- translations of (4a, 4b, 4c, 5) together.
-
- (7k-4a-1) Add to the disjunction a negation of all what (7i-4a)
- would generate (i.e. for positive facts), but over tuples with at
- least one of the negated elements of current negation (no elements
- from other negations).
-
- (7k-4a-2) For a negative fact generate result equivalent to a
- *conjunction* of negations of generated atoms if all elements are
- positive,
-
- (7k-4a-3) but add a *disjunction* of negations (i.e. a negated
- conjunction) of tuples with at least one negated element.
-
- (7k-4c) Include the (4c) relations for "next" and "true" negative
- atoms.
-
- (7k-4b) It is essentially a special case of (7k-4a-1). Introduce
- equivalences as in (7i-4b), but with tuples containing at least
- one element from the current negation (no elements from other
- negations). Generate the same set of equivalence tuples as a
- positive occurrence would so that they can be pruned when
- possible.
-
- TODO: handle "distinct" that contains variable(s)!
-
- (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). The lattice is built by
- summing rule bodies.
-
- (7l0) To avoid contradictions and have a complete partition, we
- construct the set of all bit vectors indexed by all atoms
- occurring in the bodies (optionally, all atoms in bodies of
- branches containing "does" atoms). We collapse atoms that have the
- same pattern of occurrence in the branches as single index.
-
- (7l1) 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. Heuristic (FIXME: needed?): We only use atoms that are
- deterministically present or absent in at least some branch for
- indexing.
-
- (7l2) Filter rule candidates so that each has a "does"-specific
- branch.
-
- TODO: perhaps should be optional -- perhaps there are "default
- all noop rules" in some games.
-
- (7l3) Optionally, remove synthetic branches that do not have (a)
- gdl variables (i.e. Toss equivalence relations) or (b) state terms
- (i.e. Toss variables) in common with the non-synthetic branches of
- the rule candidate.
-
- Only translate the formulas after (7l3).
-
- (7l3b) In this optional case, only keep synthetic branches that
- either have non-state-term atoms with gdl variables common with
- base branches, or actually have state terms in common with base
- branches. (E.g. do not keep a branch with "(R ?x ?y) (true (ST ?v ?x))
- (true (ST ?v ?y))" when only "v" is in common with base branches.)
-
- (7l4) Filter out rule candidates that contradict all states
- from the current location plys of aggregate playout (by their
- "true" atoms -- "not true" are not valid in the aggregate playout).
-
- (7l5) Here a set of branches has conjunctive interpretation, since
- they are the "next" clauses that simultaneously match. If a branch
- fails, the whole case fails.
-
- (7m) Filter the final rule candidates by satisfiability of the
- static part (same as (7i1) conjoined).
-
- (7n) 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.)
-
- (7n1) Prior to translation, expand all variables under
- meta-variables in "terminal" branches, as in (7j).
-
- The rewrite rule is generated by joining the derived conjunctions
- from "next" atoms as RHS, and from bodies as the
- precondition. Exactly the RHS variables are listed in the LHS
- (other variables are existentially closed in the
- precondition). All the relations that appear in either LHS or RHS
- are considered embedded.
-
- (7o) After the rules are translated, perform an aggregated playout
- of the Toss variant of the game. Remove the rules that were never
- applied.
-
- (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.
-
- (8a) Filter-out goal branches that are contradictory with the
- terminal condition (using resolution on the GDL
- side). Implementation TODO.
-
- (8b) For each goal value we collect bodies to form a disjunction.
-
- (8c) The payoff formula is the sum of "goal" value times the
- characterisic function of the corresponding "goal" bodies. To
- simplify the result, we find the longest formula, and center the
- payoff around it: for the goal value V_i if i-th formula phi_i and
- phi_K being the longest formula, we translate the payoff into "K +
- (V_1 - V_K) :(phi_1) + ... (V_n - V_K) :(phi_n)" thus removing
- phi_K from translation.
-
- (8d) Finally, we simplify the result. Unused predicates are not
- removed, because some of them will be needed for action translation.
-
- (9) To translate an incoming action, we:
-
- (9a) find the "lead legal" term to which the "does move" ground
- term of the current player matches;
-
- (9b) earlier, remember which Toss variables of a rule contain which
- fixed variables at which positions in their masks;
-
- (9c) find anchor predicates corresponding to instantiations of the
- "lead legal" variables, anchoring positions found by (9b) "fixed
- var" - "mask + mask var" correspondence;
-
- (9d) build a conjunction of anchor predicates over variables that
- contain the fixed variable which is "instantiated" by the anchor
- of the corresponding position, as established by (9c);
-
- (9e) conjoin the (9d) with the "matching" formula of a rule, and
- evaluate the result for all rules (of the located "lead legal"
- class); only a single rule should have a match, and only a single
- assignment should be returned; this rule with this assignment is
- the translated move.
-
- (10) To translate an outgoing action, we:
-
- (10a) associate the rule with its corresponding data: the "lead
- legal" term, the fixed variables corresponding to rule elements,
- ...
-
- (10b) earlier, return/store the mapping from an element to the
- mask and subsitution that define the element;
-
- (10c) earlier, for each rule store a mapping from fixed variables
- to rule variables and the mask variables that in the rule variable
- are instantiated by the fixed variables;
-
- (10d) to determine how to instantiate the fixed variables in the
- "lead legal" term, find the (10b) substitutions of assigned
- elements and (10c) mask variables for fixed variables; compose the
- maps to get fixed variable to GDL ground term mapping, each
- "route" should give the same term.
-
- Implementation TODO: once the LHS-RHS structures are removed from
- the backbone and formula registration is removed, some
- simplifications can be done in (9) and (10).
-
-*)
-
let debug_level = ref 0
let aggregate_drop_negative = ref false
let aggregate_fixpoint = ref true
@@ -602,44 +18,6 @@
[nonerasing_frame_wave] is set to [true].) *)
let nonerasing_frame_wave = ref true
-(** Include mask predicates (first part of (4c)) of negative state
- term atoms as either positive or negated atoms. *)
-type mask_anchors_of_neg = Positive_anch | Negative_anch | No_anch
-let mask_anchors_of_neg = ref (* Positive_anch *) Negative_anch
-
-(** Approximate rule preconditions by dropping parts of "partition
- guards" of (7l) -- parts of conditions introduced merely to
- distinguish rules that should not be available at the same time. *)
-type approximate_rule_preconds =
- | Exact (** keep all conditions *)
- | Connected (** keep all connected to
- variables appearing in the
- rest, i.e. containing
- common gdl variables *)
- | TightConnected (** keep connected but
- ignoring equivalence
- links, i.e. containing
- common gdl state terms *)
- | DropAll
-let approximate_rule_preconds = ref (* Connected *) Exact
-
-(** Filter rule candidates by the stable part of precondition either
- before or after game simplification. *)
-type prune_rulecands = Before_simpl | After_simpl | Never
-let prune_rulecands_at = ref (* Before_simpl *) Never
-
-(** Perhaps generate all tuples for equivalences, to faciliate further
- transformations of formulas in the game definition (outside of
- translation). *)
-type pair_matrix = Pairs_all | Pairs_triang | Pairs_star
-let equivalences_all_tuples = ref Pairs_triang
-let equivalences_ordered = ref true
-
-(** Generate test case for the given game name. *)
-let generate_test_case = ref None
-
-open Aux.BasicOperators
-
type term =
| Const of string
| Var of string
@@ -676,47 +54,7 @@
| Stop of string * term list
(* game ends here: match id, actions on previous step *)
-type tossrule_data = {
- lead_legal : term;
- (* the "legal"/"does" term of the player that performs the move, we
- call its parameters "fixed variables" as they are provided externally *)
- precond : Formula.formula;
- (* the LHS match condition (the LHS structure and the precondition) *)
- rhs_add : (string * string array) list;
- (* the elements of LHS/RHS structures, corresponding to the "next"
- terms *)
- struc_elems : string list;
- fixvar_elemvars :
- (string * (term * (string * string list) list) list) list;
- (* "state" terms indexed by variables that they contain, together
- with the mask-path of the variable *)
- elemvars : term Aux.StrMap.t;
-(* "state" terms indexed by Toss variable names they generate *)
-}
-type gdl_translation = {
- anchor_terms :
- (term * (string * (term * string) list) list) list;
- (* mask path (i.e. mask+var) and a ground term to anchor predicate *)
- tossrule_data : tossrule_data Aux.StrMap.t;
- (* rule name to rule translation data *)
- t_elements : term Aux.IntMap.t;
- (* element terms (with metavariables only) *)
- playing_as : int;
- (* "active" player *)
- noop_actions : term option array;
- (* NOOP actions of "active" player indexed by locations *)
- fluents : string list;
-}
-
-let empty_gdl_translation =
- {anchor_terms = [];
- tossrule_data = Aux.StrMap.empty;
- t_elements = Aux.IntMap.empty;
- playing_as = 0;
- noop_actions = [||];
- fluents = []}
-
let rec term_str = function
| Const c -> c
| Var v -> "?"^v
@@ -743,6 +81,7 @@
| 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)
@@ -754,33 +93,6 @@
| Currently arg -> "true", [arg]
| Does (arg1, arg2) -> "does", [arg1; arg2]
-let fprint_gdl_transl_data ?(details=false) ppf gdl =
- (* TODO: print more data if needed *)
- Format.fprintf ppf
- "GDL_DATA@,{@[<1>FLUENTS@ %a;@ PLAYING_AS@ %d;@ NOOPS@ %a;"
- (Aux.fprint_sep_list "," Format.pp_print_string) gdl.fluents
- gdl.playing_as
- (Aux.fprint_sep_list "," Format.pp_print_string)
- (Array.to_list (Array.mapi (fun i -> function
- | None -> string_of_int i ^": None"
- | Some noop -> string_of_int i ^": "^term_str noop) gdl.noop_actions));
- Aux.StrMap.iter (fun rname data ->
- Format.fprintf ppf "@ @[<1>RULE@ %s:@ LEGAL=@,%s;@ PRECOND=@,%a;@ "
- rname (term_str data.lead_legal) Formula.fprint data.precond;
- Format.fprintf ppf "{@[<1>RHS ADD:@ ";
- Aux.fprint_sep_list ";" Format.pp_print_string ppf
- (List.map (fun (rel,args) -> rel^"("^String.concat ", "
- (Array.to_list args)^")") data.rhs_add);
- Format.fprintf ppf "@]}@]"
- ) gdl.tossrule_data;
- Format.fprintf ppf "@]}"
-
-let sprint_gdl_transl_data ?(details=false) gdl =
- ignore (Format.flush_str_formatter ());
- Format.fprintf Format.str_formatter "@[%a@]"
- (fprint_gdl_transl_data ~details) gdl;
- Format.flush_str_formatter ()
-
let rec body_of_literal = function
| Pos (Distinct args) ->
[Aux.Right ("distinct", args)] (* not negated actually! *)
@@ -791,8 +103,7 @@
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
+ 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
@@ -801,15 +112,13 @@
variables found. *)
type lit_def_branch =
term list * gdl_atom list * (Aux.Strings.t * gdl_atom) list
-type lit_def =
- string * lit_def_branch list
+type lit_def = string * lit_def_branch list
(* Definition with expanded definitions: expansion of a negated
relation brings negated (possibly locally existentially quantified)
conjunctions. *)
type exp_def_branch =
term list * gdl_atom list * (Aux.Strings.t * gdl_atom list) list
-type exp_def =
- string * exp_def_branch list
+type exp_def = string * exp_def_branch list
module Terms = Set.Make (
struct type t = term let compare = Pervasives.compare end)
@@ -844,9 +153,6 @@
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map sdef_br_vars brs)
-(*
- let branch_vars (args, body, neg_body) =
-*)
let rels_vars body =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map (fun (_,args)->terms_vars args) body)
@@ -897,14 +203,12 @@
head, pos_body, neg_body) bodies
| Atomic (rel, args) -> [(rel, args), [], []]
-let add_neg_body_vars global_vars neg_body
- : (Aux.Strings.t * gdl_atom) list =
+let add_neg_body_vars global_vars neg_body : (Aux.Strings.t * gdl_atom) list =
List.map (fun (_, args as a)->
let local_vs = Aux.Strings.diff (terms_vars args) global_vars in
local_vs, a) neg_body
-let lit_defs_of_rules rules
- : (string * lit_def_branch list) list =
+let lit_defs_of_rules rules : (string * lit_def_branch list) list =
Aux.map_reduce
(fun ((drel, params), body, neg_body) ->
let global_vs =
@@ -1016,7 +320,7 @@
(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 ?(ignore_meta=false) sb m_sb terms1 terms2 =
@@ -1052,7 +356,6 @@
raise Not_found
-(* 3c1 *)
let generalize term1 term2 =
let fresh_count = ref 0 in
let rec loop pf terms1 terms2 =
@@ -1079,14 +382,6 @@
let measure, mism, gens = loop "impossible" [term1] [term2] in
measure, !fresh_count, mism, 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 ->
@@ -1097,8 +392,6 @@
| Func (f, args) ->
Func (f, List.map (subst sb) args)
-let extend_sb sb1 sb = Aux.map_prepend sb1 (fun (x,t)->x, subst sb1 t) sb
-
let rec unify_all sb = function
| [] | [_] -> sb
| t1::t2::tl ->
@@ -1131,7 +424,7 @@
List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body
let fact_str (rel, args) =
- "("^rel^" "^String.concat " " (List.map term_str args) ^")"
+ "(" ^ rel ^ " " ^ String.concat " " (List.map term_str args) ^ ")"
let tuples_str tups =
let tup_str tup =
@@ -1141,8 +434,8 @@
let terms_str facts =
String.concat ", " (List.map term_str facts)
-let facts_str facts =
- String.concat " " (List.map fact_str facts)
+let facts_str facts = String.concat " " (List.map fact_str facts)
+
let neg_lfacts_str negs =
String.concat " "
(List.map (fun (vs,d) ->
@@ -1150,6 +443,7 @@
let q = if vs = [] then ""
else "forall "^String.concat ", " vs in
q ^ "(not "^fact_str d^")") negs)
+
let neg_facts_str negs =
String.concat " "
(List.map (fun (vs,d) ->
@@ -1173,21 +467,13 @@
"("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
" " ^ neg_facts_str neg_body ^ ")"
) branches)
-(*
-let rule_str (head, body, neg_body) =
- String.concat "\n" (List.map (fun (args, body, neg_body) ->
- "("^ fact_str (rel, args) ^ " <= " ^ facts_str body ^
- " " ^ String.concat " "
- (List.map (fun f->"not "^fact_str f) neg_body) ^ ")"
- ) branches)
-*)
+
let sb_str sb =
String.concat ", " (List.map (fun (v,t)->v^":="^term_str t) sb)
let proto_rel_str (rel, args) =
rel ^"(" ^ String.concat ", " (Array.to_list args) ^")"
-(* 1b *)
(* TODO: optimize by using rel-indexing (also in [aggregate_playout]).
TODO: optimize by using constant-time append data structure. *)
@@ -1227,7 +513,6 @@
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);
@@ -1235,7 +520,6 @@
"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
@@ -1283,367 +567,10 @@
(List.map rules_of_lit_defs (stratify [] (lit_defs_of_rules rules)))
-let game_description = ref []
-let player_terms = ref [| |]
-
-let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- res
-
-(* 6 *)
-
-(* Need a global access so that the support can be reset between
- different translations. (Generalization uses a local [fresh_count]
- state.) *)
-let var_support = ref Aux.Strings.empty
-
-let freshen_branch (args, body, neg_body) =
- let sb = ref [] in
- let rec map_vnames = function
- | Var x ->
- if List.mem_assoc x !sb then Var (List.assoc x !sb)
- else
- let x1 = Aux.not_conflicting_name ~truncate:true !var_support x in
- var_support := Aux.Strings.add x1 !var_support;
- sb := (x,x1)::!sb;
- Var x1
- | MVar x ->
- if List.mem_assoc x !sb then MVar (List.assoc x !sb)
- else
- let x1 = Aux.not_conflicting_name ~truncate:true !var_support x in
- var_support := Aux.Strings.add x1 !var_support;
- sb := (x,x1)::!sb;
- MVar x1
- | Const _ as t -> t
- | Func (f, args) ->
- Func (f, List.map map_vnames args) in
- let map_rel (rel, args) =
- rel, List.map map_vnames args in
- let map_neg (vs, atoms) =
- let vs =
- List.map (fun x ->
- if List.mem_assoc x !sb then List.assoc x !sb
- else
- let x1 = Aux.not_conflicting_name ~truncate:true !var_support x in
- var_support := Aux.Strings.add x1 !var_support;
- sb := (x,x1)::!sb; x1
- ) (Aux.Strings.elements vs) in
- Aux.strings_of_list vs,
- List.map map_rel atoms in
- List.map map_vnames args,
- List.map map_rel body,
- List.map map_neg neg_body
-
-let freshen_def_branches brs =
- List.map freshen_branch brs
-
-(* [args] are the actual, instatiated, arguments. *)
-let negate_def uni_vs args neg_def =
- (* 6b1a *)
- let global_vars = terms_vars args in
- let aux_br (params, body, neg_body) =
- let sb = unify [] params args in
- let body = subst_rels sb body in
- let neg_body = List.map (fun (vs, conjs) ->
- vs, subst_rels sb conjs) neg_body in
- let subforms = (Aux.Strings.empty, body) :: neg_body in
- (* components of [vars_i] by conjuncts *)
- let sub_fvars = List.map (fun (_, subphi) ->
- Aux.Strings.diff (rels_vars subphi) global_vars) subforms in
- let subvars = List.map2 (fun fvs (qvs,_) ->
- Aux.Strings.diff fvs qvs) sub_fvars subforms in
- (* 6b1b *)
- if List.exists (fun (vs1, vs2) ->
- not (Aux.Strings.is_empty (Aux.Strings.inter vs1 vs2)))
- (Aux.pairs subvars)
- then failwith
- ("GDL.negate_def: variables shared between negated subformulas" ^
- " -- long term TODO (params: "^terms_str params^")");
- (if List.exists (fun (fvs, (qvs,_)) ->
- (* [fvs - qvs] must be a subset of the "vars_i" quantified vars *)
- not (Aux.Strings.is_empty (Aux.Strings.diff fvs qvs)))
- (List.tl (List.combine sub_fvars subforms))
- then
- let (fvs,(qvs,_)) = List.find (fun (fvs, (qvs,_)) ->
- not (Aux.Strings.is_empty (Aux.Strings.diff fvs qvs)))
- (List.tl (List.combine sub_fvars subforms)) in
- failwith
- ("GDL.negate_def: universal quantification escapes negation" ^
- " -- doable TODO (params: "^terms_str params^") (vars: "^
- String.concat ", " (Aux.Strings.elements
- (Aux.Strings.diff fvs qvs))^")"));
- Aux.Right (List.hd sub_fvars, body) ::
- List.map (fun (_,conjs) -> Aux.Left conjs) neg_body in
- (* 6b1c *)
- (* We drop branches whose heads don't match. *)
- let cnf = Aux.map_try aux_br neg_def in
- let dnf = Aux.product cnf in
- List.map (fun conjs ->
- let pos, neg = Aux.partition_choice conjs in
- (* since (6b1b), no local universal quantification *)
- let pos = List.concat pos in
- pos, neg
- ) dnf
-
-
-(* assumption: [defs] bodies are already clean of defined relations *)
-let subst_def_branch (defs : exp_def list)
- (head, body, neg_body as br : lit_def_branch) : exp_def_branch list =
- var_support := Aux.Strings.union !var_support
- (lit_def_br_vars br);
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "Expanding branch %s\n%!" (lit_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
- (exp_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 (fun (vs,bs)->vs, subst_rels sb1 bs)
- (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 neg_body_flat, neg_body_rec =
- Aux.partition_map (fun (uni_vs, (neg_rel, neg_args) as neg_lit) ->
- (let try def =
- freshen_def_branches (List.assoc neg_rel defs) in
- if not (List.exists (fun (_,_,negb) -> negb<>[]) def)
- then Aux.Left (neg_lit, Some def)
- else (
- (* {{{ log entry *)
- if !debug_level > 3 then (
- let _,_,def_neg_body =
- List.find (fun (_,_,negb) -> negb <> []) def in
- Printf.printf
- "expand: found recursive negative %s(%s): neg_body= not %s\n%!"
- neg_rel (terms_str neg_args)
- (String.concat " and not "
- (List.map facts_str (List.map snd def_neg_body)))
- );
- (* }}} *)
- Aux.Right (neg_lit, def))
- with Not_found -> Aux.Left (neg_lit, None))
- ) neg_body in
- (* checking if all negative bodies are just already satisfied
- "distinct" atoms; we could refine the split per-solution, but it
- isn't worth the effort *)
- let more_neg_flat, neg_body_rec =
- Aux.partition_map (fun (_, (_, args) as neg_lit, def as neg_case) ->
- if List.for_all (function
- | _,_,[] -> true
- |_,_,neg_body ->
- List.for_all (function
- | _, ["distinct", _] -> true | _ -> false) neg_body
- ) def
- then
- if List.for_all (function
- | _,_,[] -> true
- |params,_,neg_body ->
- List.for_all (function
- | _, ["distinct", terms] ->
- List.for_all (fun (_,_,sb) ->
- let args = List.map (subst sb) args in
- let sb1 = unify [] params args in
- let terms = List.map (subst sb1) terms in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- Printf.printf
- "Checking distinctness of %s after sb=%s; sb1=%s\n%!"
- (terms_str terms)
- (sb_str sb) (sb_str sb1)
- );
- (* }}} *)
- Aux.Strings.is_empty (terms_vars terms)
- && List.length (Aux.unique_sorted terms) > 1
- ) sols
- | _ -> false) neg_body) def
- then
- let def = List.map (fun (params, body, neg_body) ->
- params, body, []) def in
- Aux.Left (neg_lit, Some def)
- else Aux.Right neg_case
- else Aux.Right neg_case
- ) neg_body_rec in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "Expanding (%s) negative part: flat %s; rec %s\n%!"
- (terms_str head)
- (String.concat ", "(List.map (fun ((_,(nr,_)),_) -> nr) neg_body_flat))
- (String.concat ", "(List.map (fun ((_,(nr,_)),_) -> nr) neg_body_rec))
- );
- (* }}} *)
- (* 6b1 *)
- let sols =
- List.fold_left (fun sols ((uni_vs, (rel, args)), neg_def) ->
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "Expanding rec-negative %s by %s\n%!" rel
- (exp_def_str (rel, neg_def))
- );
- (* }}} *)
- (* we don't keep the substitution from the negated match *)
- Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
- let args = List.map (subst sb) args in
- let branches = negate_def uni_vs args neg_def in
- List.map (fun (dbody, dneg_body) ->
- dbody @ pos_sol, dneg_body @ neg_sol, sb) branches
- ) sols)
- sols neg_body_rec in
-
- (* 6b2 *)
- let sols =
- List.map (fun (pos_sol, neg_sol, sb) ->
- let more_neg_sol =
- Aux.concat_map (fun ((uni_vs, (rel, args as atom)), def_opt) ->
- (* negated subformulas are duplicated instead of branches *)
- match def_opt with
- | Some def ->
- let args = List.map (subst sb) args in
- Aux.map_try (fun (dparams, dbody, _) ->
- (let sb1 = unify [] dparams args in
- let param_vars = terms_vars dparams in
- let body_vars = rels_vars dbody in
- let dbody = subst_rels sb1 dbody in
- let local_vs =
- Aux.Strings.diff body_vars
- (Aux.Strings.diff param_vars uni_vs) in
- local_vs, dbody)
- ) def
- | None -> (* rel not in defs *)
- [uni_vs, [atom]]
- ) (more_neg_flat @ neg_body_flat) in
- List.rev pos_sol, List.rev_append neg_sol more_neg_sol, sb
- ) sols in
- let res =
- Aux.map_some (fun (pos_sol, neg_sol, sb) ->
- if List.exists (function _,[] -> true | _ -> false) neg_sol
- then None
- else Some (List.map (subst sb) head, pos_sol, neg_sol)) sols in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "Expansion: res =\n%s\nExpansion done.\n%!"
- (String.concat "\n"(List.map (branch_str "exp-unkn") res))
- );
- (* }}} *)
- res
-
-(* Stratify and expand all relations in the given set. *)
-let expand_def_rules ?(more_defs=[]) rules =
- let rec loop base = function
- | [] -> base
- | stratum::strata ->
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "expand_def_rules: step base rels = %s\n%!"
- (String.concat ", " (List.map fst base))
- );
- (* }}} *)
- let step = List.map (fun (rel, branches) ->
- rel, Aux.concat_map
- (subst_def_branch (more_defs@base)) branches) stratum in
- (* {{{ log entry *)
-if !debug_level > 3 then (
- Printf.printf "expand_def_rules: step result = %s\nexpand_def_rules: end step\n%!"
- (String.concat "\n" (List.map exp_def_str step))
-);
-(* }}} *)
- loop (base @ step) strata in
- match stratify ~def:true [] (lit_defs_of_rules rules) with
- | [] -> []
- | [no_defined_rels] when more_defs=[] ->
- exp_defs_of_lit_defs no_defined_rels
- | def_base::def_strata when more_defs=[] ->
- loop (exp_defs_of_lit_defs def_base) def_strata
- | def_strata -> loop more_defs def_strata
-
-(* As [subst_def_branch], but specifically for "legal" definition and
- result structured by "legal" definition branches. *)
-(* 7b *)
-let subst_legal_rule legal
- (head, body, neg_body as br)
- : (exp_def_branch * exp_def_branch) option =
- var_support := Aux.Strings.union !var_support
- (exp_def_br_vars br);
- let legal = freshen_branch legal in
- let legal_args, legal_body, legal_neg_body = legal in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "subst_legal_rule:\n%s\n%s\n%!"
- (exp_def_str ("legal", [legal]))
- (exp_def_str ("branch", [br]))
- );
- (* }}} *)
- if List.exists (fun (_,neg_conjs) ->
- List.exists (fun (rel,_)->rel="does") neg_conjs) 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
- ("_DOES_PLACEHOLDER_", args) :: 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
- let legal_res =
- List.map (subst sb) legal_args,
- subst_rels sb legal_body,
- List.map (fun (uni_vs,neg_conjs) ->
- (* local variables so cannot be touched *)
- uni_vs, subst_rels sb neg_conjs)
- legal_neg_body in
- let br_res =
- List.map (subst sb) head,
- subst_rels sb (List.rev body),
- List.map (fun (uni_vs, neg_conjs) ->
- uni_vs, subst_rels sb neg_conjs)
- (List.rev_append more_neg_body neg_body) in
- (* {{{ log entry *)
-if !debug_level > 3 then (
- Printf.printf "%s\n%s\n"
- (exp_def_str ("legal-res", [legal_res]))
- (exp_def_str ("br-res", [br_res]))
-);
-(* }}} *)
- Some (legal_res, br_res)
- with Not_found -> None
-
-let subst_legal_rules def_brs brs =
- Aux.unique_sorted
- (Aux.concat_map (fun br ->
- List.map (fun (_,x) -> br, x)
- (Aux.map_some (fun def -> subst_legal_rule def br) def_brs)) brs)
-
-(* 1 *)
-
(* Collect the aggregate playout, but also the actions available in
the state. *)
exception Playout_over
+
let aggregate_ply players static current rules =
let base =
Aux.map_prepend static (fun term -> "true", [term]) current in
@@ -1717,7 +644,6 @@
(fun ((rel,_),_,_) -> List.mem rel static_rels) rules in
let static_base = saturate [] static_rules in
let state_rules =
- (* 1, 1a *)
List.map (function
| ("legal", [player; _] as head), body, neg_body ->
head, ("role", [player])::body,
@@ -1808,2956 +734,3 @@
);
(* }}} *)
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 triang_matrix elems =
- let rec aux acc = function
- | [] -> acc
- | hd::tl -> aux (List.map (fun e->[|hd; e|]) tl @ acc) tl in
- aux [] elems
-
-
-let term_to_blank masks next_arg =
- let mask_cands =
- 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
- | _ ->
- Printf.printf "GDL.term_to_blank: bad state term %s\n%!"
- (term_str next_arg);
- assert false in
- mask, sb, m_sb, blank_out (next_arg, mask)
-
-let toss_var masks term =
- let mask, _, _, blank = term_to_blank masks term in
- mask, Formula.fo_var_of_string (String.lowercase (term_to_name blank))
-
-
-(* Expand branch variables. If [freshen_unfixed=Right fixed], expand
- all variables that don't belong to [fixed] and appear in the head
- of some branch. If [freshen_unfixed=Left freshen], then expand all
- variables below meta-variables of masks. If [freshen] is true,
- rename other (i.e. non-expanded) variables while duplicating
- branches. (When [freshen] is false, all remaining variables should
- be fixed.)
-
- With each branch, also return the instantiation used to derive it???
-
- As in the expansion of relation definitions, branches are
- duplicated for instantiations of positive literals, and
- additionally of heads. For instantiations of atoms in negated
- subformulas, the subformulas are duplicated within a branch, with
- instantiations kept local to the subformula. Final substitution is
- re-applied to catch up with later instantiations. *)
-let expand_branch_vars masks playout_terms ~freshen_unfixed brs =
- let head_vars = List.fold_left (fun acc -> function [head],_,_ ->
- Aux.Strings.union acc (term_vars head)
- | _ -> assert false) Aux.Strings.empty brs in
- let use_fixed, fixed =
- match freshen_unfixed with
- | Aux.Left _ -> false, Aux.Strings.empty
- | Aux.Right fixed -> true, fixed in
-(* {{{ log entry *)
-if !debug_level > 4 then (
- Printf.printf "expand_branch_vars: head_vars: %s; fixed vars: %s; before=\n%s\n%!"
- (String.concat ","(Aux.Strings.elements head_vars))
- (String.concat ","(Aux.Strings.elements fixed))
- (exp_def_str ("before", brs))
-);
-(* }}} *)
- let expand sb arg =
- let arg = subst sb arg in
- let mask, _, m_sb, blank = term_to_blank masks arg in
- let ivars = Aux.concat_map (fun (_,t) ->
- Aux.Strings.elements (term_vars t)) m_sb in
- let is_inst_var v =
- (*if use_fixed
- then
- (Aux.Strings.mem v head_vars || List.mem v ivars)
- && not (Aux.Strings.mem v fixed)
- else*) List.mem v ivars in
- Aux.unique_sorted
- (Aux.map_try (fun term ->
- let sb1, _ = match_meta [] [] [term] [arg] in
- let sb1 = List.sort Pervasives.compare
- (List.filter (fun (v,_)->is_inst_var v) sb1) in
- extend_sb sb1 sb, subst sb1 arg
- ) playout_terms) in
- let expand_rel atom (sb, acc) =
- match atom with
- | "true", [arg] ->
- List.map (fun (sb,arg) -> sb, ("true",[arg])::acc) (expand sb arg)
- | rel, args -> [sb, (rel, List.map (subst sb) args)::acc] in
- let expand_neg sb (v...
[truncated message content] |
|
From: <luk...@us...> - 2011-05-07 22:30:51
|
Revision: 1433
http://toss.svn.sourceforge.net/toss/?rev=1433&view=rev
Author: lukaszkaiser
Date: 2011-05-07 22:30:43 +0000 (Sat, 07 May 2011)
Log Message:
-----------
Fixed-points corrections and optimisations, using lfp for tc, manual heuristic in Chess.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Client/Makefile
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/Heuristic.mli
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/AssignmentSet.ml
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/TossFullTest.ml
trunk/Toss/examples/Chess.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Arena/Arena.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -113,6 +113,7 @@
| DefPlayers of string list (* add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
(* add a defined relation *)
+ | DefPattern of Formula.real_expr (* Pattern definition *)
| StateStruc of Structure.structure (* initial/saved state *)
| StateTime of float (* initial/saved time *)
| StateLoc of int (* initial/saved location *)
@@ -138,12 +139,13 @@
let make_player_loc defs =
- let (payoff, moves) = List.fold_left
- (fun (payoff, moves) -> function
- | `Payoff poff -> (poff, moves)
- | `Moves mvs -> (payoff, moves @ mvs)
- ) (Formula.Const 0., []) defs in
- { zero_loc with payoff = payoff ; moves = moves }
+ let (payoff, moves, heurs) = List.fold_left
+ (fun (payoff, moves, heurs) -> function
+ | `Payoff poff -> (poff, moves, heurs)
+ | `Moves mvs -> (payoff, moves @ mvs, heurs)
+ | `Heurs hs -> (payoff, moves, heurs @ hs)
+ ) (Formula.Const 0., [], []) defs in
+ { zero_loc with payoff = payoff ; moves = moves; heur = heurs }
let make_location id loc_defs =
fun player_names ->
@@ -158,18 +160,16 @@
list of definitions (usually corresponding to a ".toss" file.) *)
let process_definition ?extend_state defs =
let (old_rules, old_locs, players, old_defined_rels,
- state, time, cur_loc, data) =
+ state, time, cur_loc, patterns, data) =
match extend_state with
| None ->
- [], [], [], [], Structure.empty_structure (), 0.0, 0, []
- | Some state ->
- (fst state).rules, Array.to_list (fst state).graph,
- List.map fst (List.sort (fun (_,x) (_,y) -> x-y)
- (fst state).player_names),
- List.map (fun (rel, (args, body)) -> rel, args, body)
- (fst state).defined_rels,
- (snd state).struc, (snd state).time,
- (snd state).cur_loc, (fst state).data in
+ [], [], [], [], Structure.empty_structure (), 0.0, 0, [], []
+ | Some (game, gstate) ->
+ game.rules, Array.to_list game.graph,
+ List.map fst (List.sort (fun (_,x) (_,y) -> x-y) game.player_names),
+ List.map (fun (rel, (args, body)) -> rel, args, body) game.defined_rels,
+ gstate.struc, gstate.time, gstate.cur_loc,
+ game.patterns, game.data in
(* {{{ log entry *)
if !debug_level > 2 then (
printf "process_definition: %d old rules, %d old locs\n%!"
@@ -177,37 +177,40 @@
);
(* }}} *)
let rules, locations, players, defined_rels,
- state, time, cur_loc, data =
+ state, time, cur_loc, patterns, data =
List.fold_left (fun (rules, locations, players, defined_rels,
- state, time, cur_loc, data) def ->
+ state, time, cur_loc, patterns, data) def ->
match def with
| DefRule (rname, r) ->
((rname, r)::rules, locations, players, defined_rels,
- state, time, cur_loc, data)
+ state, time, cur_loc, patterns, data)
| DefLoc loc ->
(rules, loc::locations, players, defined_rels,
- state, time, cur_loc, data)
+ state, time, cur_loc, patterns, data)
| DefPlayers more_players ->
(rules, locations, players @ more_players, defined_rels,
- state, time, cur_loc, data)
+ state, time, cur_loc, patterns, data)
| DefRel (rel, args, body) ->
(rules, locations, players,
(rel, args, body)::defined_rels,
- state, time, cur_loc, data)
+ state, time, cur_loc, patterns, data)
+ | DefPattern pat ->
+ (rules, locations, players, defined_rels,
+ state, time, cur_loc, pat :: patterns, data)
| StateStruc struc ->
(rules, locations, players, defined_rels,
- struc, time, cur_loc, data)
+ struc, time, cur_loc, patterns, data)
| StateTime ntime ->
(rules, locations, players, defined_rels,
- state, ntime, cur_loc, data)
+ state, ntime, cur_loc, patterns, data)
| StateLoc ncur_loc ->
(rules, locations, players, defined_rels,
- state, time, ncur_loc, data)
+ state, time, ncur_loc, patterns, data)
| StateData more_data ->
(rules, locations, players, defined_rels,
- state, time, cur_loc, data @ more_data)
+ state, time, cur_loc, patterns, data @ more_data)
) ([], [], players, [],
- state, time, cur_loc, data) defs in
+ state, time, cur_loc, patterns, data) defs in
(* {{{ log entry *)
if !debug_level > 2 then (
printf "process_definition: %d new rules, %d new defined rels\n%!"
@@ -261,15 +264,15 @@
(* }}} *)
let graph = Array.of_list (List.rev locations) in
(* TODO; FIXME; JUST THIS List.rev ABOVE WILL NOT ALWAYS BE GOOD, OR?!! *)
- let game = {
+ {
rules = rules;
- patterns = [];
+ patterns = List.rev patterns;
graph = graph;
num_players = num_players;
player_names = player_names;
data = data;
defined_rels = List.map (fun (a, b, c) -> (a, (b, c))) defined_rels;
- } in game, {
+ }, {
struc = state;
time = time;
cur_loc = cur_loc;
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Arena/Arena.mli 2011-05-07 22:30:43 UTC (rev 1433)
@@ -93,6 +93,7 @@
| DefPlayers of string list (** add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
(** add a defined relation *)
+ | DefPattern of Formula.real_expr (** Pattern definition *)
| StateStruc of Structure.structure (** initial/saved state *)
| StateTime of float (** initial/saved time *)
| StateLoc of int (** initial/saved location *)
@@ -110,7 +111,8 @@
val make_location :
int ->
(string * [< `Moves of (label * int) list
- | `Payoff of Formula.real_expr ] list) list ->
+ | `Payoff of Formula.real_expr
+ | `Heurs of float list ] list) list ->
(string * int) list -> player_loc array
(** Create a game state, possibly by extending an old state, from a
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-05-07 22:30:43 UTC (rev 1433)
@@ -37,23 +37,28 @@
"Syntax error in move definition."
}
-real_expr_wrapper:
+real_expr_err:
| rexp = real_expr { rexp }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in real expression."
}
-formula_expr_wrapper:
+formula_expr_err:
| phi = formula_expr { phi }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in formula expression."
}
+float_or_int:
+ | FLOAT { $1 }
+ | INT { float_of_int $1 }
+
player_loc_defs:
- | PAYOFF poff = real_expr_wrapper { `Payoff poff }
- | MOVES moves = separated_list (SEMICOLON, move) { `Moves moves }
+ | PAYOFF poff = real_expr_err { `Payoff poff }
+ | MOVES moves = separated_list (SEMICOLON, move) { `Moves moves }
+ | COND hs = separated_list (SEMICOLON, float_or_int) { `Heurs hs }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in location field."
@@ -78,7 +83,7 @@
rel_def_simple:
| rel = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
- EQ body = formula_expr { (rel, args, body) }
+ EQ body = formula_expr_err { (rel, args, body) }
game_defs:
| RULE_SPEC rname = id_int COLON r = rule_expr
@@ -87,14 +92,16 @@
{ DefLoc l }
| PLAYERS_MOD pnames = separated_list (COMMA, id_int)
{ DefPlayers pnames }
+ | SET_CMD r = real_expr_err
+ { DefPattern r }
| REL_MOD rel = ID
arg = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
- body = delimited (OPENCUR, formula_expr, CLOSECUR)
+ body = delimited (OPENCUR, formula_expr_err, CLOSECUR)
{ DefRel (rel, arg, body) }
| REL_MOD rel = ID
arg = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
EQ
- body = formula_expr
+ body = formula_expr_err
{ DefRel (rel, arg, body) }
| MODEL_SPEC model = struct_expr
{ StateStruc model }
@@ -164,7 +171,7 @@
{ GetFun (wh, fn, elem) }
| SET_CMD PLAYER_MOD oldn=id_int PLAYER_MOD newn=id_int
{ RenamePlayer (oldn, newn) }
- | SET_CMD LOC_MOD PAYOFF loc=INT player=id_int poff=real_expr_wrapper
+ | SET_CMD LOC_MOD PAYOFF loc=INT player=id_int poff=real_expr_err
{ SetLocPayoff (loc, player, poff) }
| GET_CMD LOC_MOD PAYOFF loc=INT player=id_int
{ GetLocPayoff (loc, player) }
@@ -184,7 +191,7 @@
OPENSQ,
separated_nonempty_list(SEMICOLON,
delimited(OPENCUR, separated_list (
- SEMICOLON, separated_pair (id_int, COLON, real_expr_wrapper)
+ SEMICOLON, separated_pair (id_int, COLON, real_expr_err)
), CLOSECUR)), CLOSESQ)
loc=INT
TIMEOUT_MOD timer=INT effort=INT algo=ID horizon=INT?
@@ -196,8 +203,8 @@
| GET_CMD LOC_MOD PLAYER_MOD loc=INT { GetLocPlayer loc }
| SET_CMD LOC_MOD loc=INT { SetLoc loc }
| GET_CMD LOC_MOD { GetLoc }
- | EVAL_CMD OPEN phi=formula_expr CLOSE { EvalFormula phi }
- | EVAL_CMD OPENSQ re=real_expr_wrapper CLOSESQ { EvalRealExpr re }
+ | EVAL_CMD OPEN phi=formula_expr_err CLOSE { EvalFormula phi }
+ | EVAL_CMD OPENSQ re=real_expr_err CLOSESQ { EvalRealExpr re }
| SET_CMD DATA_MOD i=ID v=id_int { SetData (i, v) }
| GET_CMD DATA_MOD i=ID { GetData i }
| SET_CMD RULE_SPEC r=id_int rdef=rule_expr { SetRule (r, rdef) }
@@ -234,7 +241,7 @@
| GET_CMD RULE_SPEC EMB r=id_int { GetRuleEmb r }
| GET_CMD RULE_SPEC COND r=id_int { GetRuleCond r }
| SET_CMD RULE_SPEC COND r=id_int
- pre=formula_expr inv=formula_expr post=formula_expr
+ pre=formula_expr_err inv=formula_expr_err post=formula_expr_err
{ SetRuleCond (r, pre, inv, post) }
| error
{ raise (Lexer.Parsing_error "Syntax error in Server request.") }
Modified: trunk/Toss/Client/Makefile
===================================================================
--- trunk/Toss/Client/Makefile 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Client/Makefile 2011-05-07 22:30:43 UTC (rev 1433)
@@ -1,7 +1,8 @@
all: Shapes.so
Shapes.so: Shapes.c
- gcc -fPIC Shapes.c -I/usr/include/python2.5/ -I/usr/include/python2.6/ -lm -lpthread -shared -o Shapes.so
+ gcc -fPIC Shapes.c -I/usr/include/python2.5/ -I/usr/include/python2.6/\
+ -I/usr/include/python2.7/ -lm -lpthread -shared -o Shapes.so
clean:
rm -rf *.pyc Shapes.so
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -524,7 +524,18 @@
(* --------------------------- TRANSITIVE CLOSURE --------------------------- *)
-(* We construct transitive closure of phi(x, y, z) over x, y as
+(* We construct the lfp transitive closure of phi(x, y, z) over x, y as
+ "lfp T(y) = (y = x or ex n (n in T and phi (n, y, z)))" *)
+let make_lfp_tc x y phi =
+ let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in
+ let (_, nn) = subst_name_avoiding fv (fo_var_of_string "n") in
+ let nnv = fo_var_of_string nn in
+ let frT = mso_var_of_string(snd(subst_name_avoiding fv(var_of_string "T"))) in
+ let nphi = subst_vars [(x, nn)] phi in
+ let fpphi = Or [Eq (xv, yv); Ex([(nnv :> var)], And [In (nnv, frT); nphi])] in
+ Lfp ((frT :> [ mso_var | so_var ]), [|yv|], fpphi)
+
+(* We construct the mso transitive closure of phi(x, y, z) over x, y as
"all X (x in X and (all x',y'
(x' in X and phi(x',y',z)-> y' in X)) -> y in X)" *)
let make_mso_tc x y phi =
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-05-07 22:30:43 UTC (rev 1433)
@@ -137,6 +137,10 @@
(** {2 Transitive Closure} *)
+
+(** Transitive closure of phi(x, y, z) over x and y, an LFP formula. *)
+val make_lfp_tc : string -> string -> formula -> formula
+
(** Transitive closure of phi(x, y, z) over x and y, an MSO formula. *)
val make_mso_tc : string -> string -> formula -> formula
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Formula/FormulaParser.mly 2011-05-07 22:30:43 UTC (rev 1433)
@@ -89,7 +89,8 @@
| NOT formula_expr { Not ($2) }
| EX var_list formula_expr { Ex ($2, $3) }
| ALL var_list formula_expr { All ($2, $3) }
- | TC ID COMMA ID formula_expr { FormulaOps.make_mso_tc $2 $4 $5 }
+ | TC ID COMMA ID formula_expr { FormulaOps.make_lfp_tc $2 $4 $5 }
+ | TC IN ID COMMA ID formula_expr { FormulaOps.make_mso_tc $3 $5 $6 }
| TC INT ID COMMA ID formula_expr { FormulaOps.make_fo_tc_conj $2 $3 $5 $6 }
| LFP ID OPEN fo_var_list CLOSE EQ formula_expr
{ let vs = Array.of_list $4 in if Array.length vs <> 1 then
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Formula/Lexer.mll 2011-05-07 22:30:43 UTC (rev 1433)
@@ -193,6 +193,7 @@
| "false" { FALSE }
| "assoc" { ASSOC }
| "cond" { COND }
+ | "COND" { COND }
| "PAYOFF" { PAYOFF }
| "MOVES" { MOVES }
| "ADD" { ADD_CMD }
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Play/Heuristic.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -267,7 +267,16 @@
Times (Formula.pow n (int_of_float adv_ratio),
Const (1. /. float_of_int m ** adv_ratio))
+let print_heur msg heur =
+ print_endline ("\nAll-Heuristics " ^ msg);
+ let print_heur_arr = Array.iteri (fun i heur ->
+ print_endline ("\n for player " ^ (string_of_int i));
+ print_endline (" " ^ Formula.sprint_real heur);) in
+ Array.iteri (fun i harr ->
+ print_endline ("\nHeuristic for location " ^ (string_of_int i));
+ print_heur_arr harr;) heur
+
(* ********** Structure-Expanded Form ********** *)
let rec has_rels frels = function
Modified: trunk/Toss/Play/Heuristic.mli
===================================================================
--- trunk/Toss/Play/Heuristic.mli 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Play/Heuristic.mli 2011-05-07 22:30:43 UTC (rev 1433)
@@ -59,6 +59,9 @@
val debug_level : int ref
+(** Simple heuristic print helper. *)
+val print_heur : string -> Formula.real_expr array array -> unit
+
(** Irrespective of the shape of payoffs, take the difference of
heuristics as the final heuristic for each player (in
{!Heuristic.default_heuristic_old}). *)
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Server/ReqHandler.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -11,19 +11,33 @@
let possibly_modifies_game = Arena.can_modify_game
+let compute_heuristic advr (game, state) =
+ let pat_arr = Array.of_list game.Arena.patterns in
+ let pl_heur l =
+ let len = List.length l.Arena.heur in
+ if len = 0 || len > Array.length pat_arr then raise Not_found else
+ let add_pat (i, h) pw =
+ let pat = Formula.Times (Formula.Const pw, pat_arr.(i)) in
+ (i+1, Formula.Plus (pat, h)) in
+ snd (List.fold_left add_pat (0, Formula.Const 0.) l.Arena.heur) in
+ try
+ let res = Array.map (fun a-> Array.map pl_heur a) game.Arena.graph in
+ if !debug_level > 1 then Heuristic.print_heur "manual heur" res;
+ res
+ with Not_found ->
+ Heuristic.default_heuristic ~struc:state.Arena.struc ?advr game
+
exception Found of int
let req_handle g_heur game_modified state gdl_transl playclock = function
| Aux.Left (Arena.SuggestLocMoves
- (loc, timer, effort, how, horizon, heuristic, advr)) -> (
+ (loc, timer, effort, _, _, heuristic, advr)) -> (
Random.self_init ();
Play.set_timeout (float(timer));
let heur = match game_modified, g_heur with
| false, Some h -> Some h
- | true, _ | _, None ->
- Some (Heuristic.default_heuristic ~struc:(snd state).Arena.struc
- ?advr (fst state)); in
+ | true, _ | _, None -> Some (compute_heuristic advr state) in
let (move, _) =
Aux.random_elem (Play.maximax_unfold_choose effort
(fst state) (snd state) (Aux.unsome heur)) in
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Server/Server.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -1,6 +1,7 @@
(* Server for Toss Functions. *)
let debug_level = ref 0
+
let set_debug_level i =
debug_level := i;
if i > 5 then Solver.set_debug_level 1;
@@ -102,7 +103,8 @@
let (line, marshaled) = read_in_line in_ch in
if line = "COMP" && marshaled <> None then (
let (f, x) = Aux.unsome marshaled in
- let res = Marshal.to_channel out_ch (f x) [Marshal.Closures] in
+ let res = f x in
+ Marshal.to_channel out_ch res [Marshal.Closures];
flush out_ch;
) else
let req = req_of_str line in
@@ -144,13 +146,18 @@
let f = open_in fn in
let s = ArenaParser.parse_game_state Lexer.lex (Lexing.from_channel f) in
game_modified := true;
- state := s
-;;
+ state := s;
+ let pats = (fst !state).Arena.patterns in
+ print_endline ("P: " ^ String.concat ", " (List.map Formula.real_str pats));
+ let ploc l = if l.Arena.heur <> [] then
+ print_endline ("H: " ^ String.concat ", "
+ (List.map string_of_float l.Arena.heur)) in
+ Array.iter (fun l -> Array.iter ploc l) (fst !state).Arena.graph
-let heur_val_white1 = ref "";;
-let heur_val_black1 = ref "";;
-let heur_val_white2 = ref "";;
-let heur_val_black2 = ref "";;
+let heur_val_white1 = ref ""
+let heur_val_black1 = ref ""
+let heur_val_white2 = ref ""
+let heur_val_black2 = ref ""
let heur_of_vals white_val black_val =
let real_expr_of_str s =
@@ -161,17 +168,8 @@
real_expr_of_str ("("^black_val^") - ("^white_val^")") in
let heuristic = [|white_heur; black_heur|] in
Array.make (Array.length (fst !state).Arena.graph) heuristic
-;;
-let print_heur pl heur =
- print_endline ("\nAll-Heuristics for player " ^ pl);
- let print_heur_arr = Array.iteri (fun i heur ->
- print_endline ("\n for player " ^ (string_of_int i));
- print_endline (" " ^ Formula.sprint_real heur);) in
- Array.iteri (fun i harr ->
- print_endline ("\nHeuristic for location " ^ (string_of_int i));
- print_heur_arr harr;) heur
-;;
+let print_heur pl heur = Heuristic.print_heur ("for player " ^ pl) heur
let do_play game state depth1 depth2 advr heur1 heur2 =
let cur_state = ref state in
@@ -194,7 +192,6 @@
let payoffs = Array.map (fun l -> l.Arena.payoff)
game.Arena.graph.(!cur_state.Arena.cur_loc) in
Array.map (fun p -> Solver.M.get_real_val p (!cur_state).Arena.struc) payoffs
-;;
let run_test n depth1 depth2 =
let advr = 2.0 in
@@ -232,8 +229,7 @@
aggr_payoff_w := !aggr_payoff_w +. payoff.(0);
aggr_payoff_b := !aggr_payoff_b +. payoff.(1);
Printf.printf "Aggregate payoffs %f, %f\n" !aggr_payoff_w !aggr_payoff_b;
- ) done;
-;;
+ ) done
(* ----------------------- START SERVER WHEN CALLED ------------------------- *)
@@ -312,7 +308,6 @@
start_server req_handle !port !server
with Aux.Host_not_found ->
print_endline "The host you specified was not found."
-;;
let _ =
(* Test against being called from a test... *)
@@ -327,4 +322,4 @@
(* so that the server is not started by the test suite. *)
if not test_fname then (
main ()
- ) ;;
+ )
Modified: trunk/Toss/Solver/AssignmentSet.ml
===================================================================
--- trunk/Toss/Solver/AssignmentSet.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Solver/AssignmentSet.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -117,9 +117,10 @@
in order in which [vars] are given. [elems] are all elements. *)
let rec tuples elems vars = function
| Empty -> []
- | Any -> List.rev_map Array.of_list
- (Aux.product
- (List.rev_map (fun _ -> Structure.Elems.elements elems) vars))
+ | Any ->
+ List.rev_map Array.of_list
+ (Aux.product
+ (List.rev_map (fun _ -> Structure.Elems.elements elems) vars))
| FO (`FO v, (e,other_aset)::asg_list) when e < 0 ->
let asg_list = List.map (fun e ->
e, try List.assoc e asg_list with Not_found -> other_aset)
Modified: trunk/Toss/Solver/Assignments.ml
===================================================================
--- trunk/Toss/Solver/Assignments.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Solver/Assignments.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -68,7 +68,7 @@
before join and join must take elems as argument. *)
let small_simp l =
let rec del_dupl acc = function
- [] -> acc
+ | [] -> acc
| [x] -> x :: acc
| x :: y :: xs when x = y -> del_dupl acc (y :: xs)
| x :: y :: xs -> del_dupl (x :: acc) (y :: xs) in
@@ -86,7 +86,7 @@
let r = small_simp (map_snd f m) in
if r=[] then Empty else MSO(v,r) in
match (aset1, aset2) with
- (Empty, _) | (_, Empty) -> Empty
+ | (Empty, _) | (_, Empty) -> Empty
| (Any, a) -> a
| (a, Any) -> a
| (FO (v1, map1), FO (v2, map2)) -> (
@@ -119,7 +119,7 @@
if poly_dnf = [] then Empty else Real (poly_dnf)
and join_maps_rev acc = function
- ([], _) -> acc
+ | ([], _) -> acc
| (_, []) -> acc
| ((e1, a1) :: r1, (e2, a2) :: r2) ->
match compare_elems e1 e2 with
@@ -131,7 +131,7 @@
| x -> join_maps_rev acc (((e1, a1) :: r1), r2)
and join_disj acc disj1 = function
- [] -> acc
+ | [] -> acc
| ((pos2, neg2), a2) :: rest ->
let adjoin_one acc ((pos1, neg1), a1) =
let (pos, neg) = (Elems.union pos2 pos1, Elems.union neg2 neg1) in
@@ -146,7 +146,7 @@
(* Enforce [aset] and additionally that the FO variable [v] is set to [e]. *)
let rec set_equal v e = function
- Empty -> Empty
+ | Empty -> Empty
| FO (u, map) as aset -> (
match compare_vars (u :> Formula.var) (v :> Formula.var) with
0 ->
@@ -161,7 +161,7 @@
(* Enforce that in [aset] the variable [u] is equal to [w]; assumes u < w. *)
let rec eq_vars els u w = function
- Empty -> Empty
+ | Empty -> Empty
| FO (v, map) as aset -> (
match compare_vars (v :> Formula.var) (u :> Formula.var) with
0 ->
@@ -179,7 +179,7 @@
(* Enforce that in [aset] the variable [u] is equal to [w]. *)
let equal_vars elems u w aset =
match compare_vars (u :> Formula.var) (w :> Formula.var) with
- 0 -> aset (* TODO: with one var is assigned, we could be more efficient *)
+ | 0 -> aset (* TODO: with one var is assigned, we could be more efficient *)
| x when x < 0 -> eq_vars elems u w aset
| _ -> eq_vars elems w u aset
@@ -202,12 +202,12 @@
We assume that [elems] are sorted. Corresponds to disjunction of formulas. *)
let rec sum elems aset1 aset2 =
match (aset1, aset2) with
- (Any, _) | (_, Any) -> Any
+ | (Any, _) | (_, Any) -> Any
| (Empty, a) -> a
| (a, Empty) -> a
| (FO (v1, map1), FO (v2, map2)) -> (
match compare_vars (v1 :> Formula.var) (v2 :> Formula.var) with
- 0 ->
+ | 0 ->
let res_map = List.rev (sum_maps_rev elems [] (map1, map2)) in
if is_full elems res_map then Any else FO (v1, res_map)
| x when x < 0 ->
@@ -253,7 +253,7 @@
Real (List.rev_append poly_disj1 poly_disj2)
and sum_maps_rev elems acc = function
- ([], m) -> List.rev_append m acc
+ | ([], m) -> List.rev_append m acc
| (m, []) -> List.rev_append m acc
| ((e1, a1) :: r1, (e2, a2) :: r2) ->
match compare_elems e1 e2 with
@@ -276,7 +276,7 @@
(* Project assignments on a given variable. We assume that [elems] are all
elements and are sorted. Corresponds to the existential quantifier. *)
let rec project elems v = function
- Empty -> Empty
+ | Empty -> Empty
| Any -> Any
| FO (u, m) when (u :> Formula.var) = v -> (* Sum the assignments below *)
List.fold_left (fun s (_, a) -> sum elems s a) Empty m
@@ -317,7 +317,7 @@
(* Project assignments on a given universal variable. We assume that [elems]
are all elements and are sorted. Corresponds to the for-all v quantifier. *)
let rec universal elems v = function
- Empty -> Empty
+ | Empty -> Empty
| Any -> Any
| FO (u, m) when (u :> Formula.var) = v -> (* Join the assignments below *)
if List.length m < sllen elems then Empty else
@@ -347,7 +347,7 @@
let neg_disj = negate_real_disj poly_disj in
if neg_disj = [] then Any else
match project elems v (Real (neg_disj)) with
- Any -> Empty
+ | Any -> Empty
| Real disj ->
let nd = negate_real_disj disj in
if nd = [] then Empty else Real nd
@@ -363,29 +363,29 @@
(* Complement an assignment set assuming [elems] are all assignable elements.
We assume [elems] are sorted. This corresponds to negation of formulas. *)
let rec complement elems = function
- Empty -> Any
+ | Empty -> Any
| Any -> Empty
| FO (v, map) ->
- let compl_map =
- List.rev (complement_map_rev elems [] (slist elems, map)) in
- if compl_map = [] then Empty else FO (v, compl_map)
+ let compl_map =
+ List.rev (complement_map_rev elems [] (slist elems, map)) in
+ if compl_map = [] then Empty else FO (v, compl_map)
| MSO (v, disj) ->
- let compl_disj = complement_disj elems disj in
- if compl_disj = [] then Empty else MSO (v, compl_disj)
+ let compl_disj = complement_disj elems disj in
+ if compl_disj = [] then Empty else MSO (v, compl_disj)
| Real poly_disj -> Real (negate_real_disj poly_disj)
and complement_map_rev elems acc = function
- ([], []) -> acc
+ | ([], []) -> acc
| ([], _) -> failwith "more assigned elements as elements at all"
| (e::es, []) -> complement_map_rev elems ((e, Any)::acc) (es, [])
| (e1 :: es, (e2, a) :: ms) ->
match compare_elems e1 e2 with
- 0 ->
- let compl = complement elems a in
- if compl = Empty then complement_map_rev elems acc (es, ms) else
- complement_map_rev elems ((e1, compl)::acc) (es, ms)
+ | 0 ->
+ let compl = complement elems a in
+ if compl = Empty then complement_map_rev elems acc (es, ms) else
+ complement_map_rev elems ((e1, compl)::acc) (es, ms)
| x when x < 0 ->
- complement_map_rev elems ((e1, Any)::acc) (es, (e2, a) :: ms)
+ complement_map_rev elems ((e1, Any)::acc) (es, (e2, a) :: ms)
| _ -> failwith "assigned element not in the set of all elements"
and complement_disj elems disj =
@@ -419,7 +419,7 @@
(* Complement [a] and join with [aset]; assumes [a] is joined with [aset] *)
let rec complement_join elems aset a =
match (aset, a) with
- (Empty, _) | (_, Any) -> Empty
+ | (Empty, _) | (_, Any) -> Empty
| (Any, a) -> complement elems a
| (a, Empty) -> a
| (FO (v1, map1), FO (v2, map2)) when v1 = v2 ->
@@ -429,7 +429,7 @@
| _ -> join aset (complement elems a)
and complement_join_map_rev elems acc = function
- ([], []) -> acc
+ | ([], []) -> acc
| ([], _) -> failwith "complement-join-map: set to complement too big (1)"
| (map, []) -> List.rev_append map acc
| ((e1, aset) :: es, (e2, a) :: ms) ->
@@ -450,7 +450,7 @@
(* Helper function to remove duplicate assignments to variables and append.*)
let remove_dup_append assgn_list asgn =
let rec remove_dup acc = function
- [] -> acc :: assgn_list
+ | [] -> acc :: assgn_list
| [x] -> (x :: acc) :: assgn_list
| (v1, e1) :: (v2, e2) :: xs when v1 = v2 ->
if e1 = e2 then remove_dup acc ((v2, e2) :: xs) else assgn_list
@@ -469,7 +469,7 @@
let make_append l t = remove_dup_append l (make_assign t) in
let asgn_list = List.fold_left make_append [] tl in
let rec set_of_single = function
- [] -> Empty
+ | [] -> Empty
| [(v, e)] -> FO (v, [(e, Any)])
| (v, e) :: rest -> FO (v, [(e, set_of_single rest)])
in
@@ -480,7 +480,7 @@
let rec join_rel aset vars tuples_set incidence_map all_elems =
match aset with (* TODO: better use of incidence map? *)
- Empty -> Empty
+ | Empty -> Empty
| FO (v, map) when Aux.array_mem v vars ->
let tps e =
try IntMap.find e incidence_map with Not_found -> Tuples.empty in
@@ -495,3 +495,16 @@
let tuples = Tuples.elements tuples_set in
let rel_aset = assignments_of_list all_elems vars tuples in
join aset rel_aset
+
+(* ------------ SIMPLE VARIABLE COMPRESSION ---------- *)
+
+let rec same_asg = function
+ | [] | [_] -> true
+ | (_, a1) :: (((_, a2) :: _) as r) when a1 = a2 -> same_asg r
+ | _ -> false
+
+let rec compress no_elems = function
+ | FO (v, map) when List.length map = no_elems && same_asg map ->
+ compress no_elems (snd (List.hd map))
+ | FO (v, map) -> FO (v, map_snd (compress no_elems) map)
+ | x -> x
Modified: trunk/Toss/Solver/Assignments.mli
===================================================================
--- trunk/Toss/Solver/Assignments.mli 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Solver/Assignments.mli 2011-05-07 22:30:43 UTC (rev 1433)
@@ -104,6 +104,12 @@
Structure.Tuples.t -> set_list ref -> assignment_set
+(** {2 Basic univeral variable compression} *)
+
+(** Compress the given assignment set, use number of elements. *)
+val compress : int -> assignment_set -> assignment_set
+
+
(** {2 Debugging} *)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Solver/Solver.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -98,9 +98,10 @@
if !debug_level > 1 then print_endline ("Got: " ^ (AssignmentSet.str res));
res in
if !debug_level > 1 then print_endline ("Evaluating: " ^ (str phi)) else ();
- let fp_split vl nasg =
- let vlen, vs = Array.length vl, (Array.to_list vl :> var list) in
- let avars = List.map to_fo (AssignmentSet.assigned_vars [] nasg) in
+ let fp_split vs nasg =
+ let vlen = List.length vs in
+ let avars =
+ Aux.unique_sorted (List.map to_fo(AssignmentSet.assigned_vars [] nasg)) in
let ovars = List.filter (fun v -> not (List.mem (v :> var) vs)) avars in
let vars = vs @ (ovars :> var list) in
let tps = AssignmentSet.tuples (Assignments.sset elems)
@@ -108,20 +109,23 @@
let split tp =
if Array.length tp = vlen then (tp, [||]) else
Array.sub tp 0 vlen, Array.sub tp vlen ((Array.length tp) - vlen) in
- let asplit tp =
- let (vasg, rst) = split tp in
- ((if rst = [||] then Any else
- Assignments.assignments_of_list elems (Array.of_list ovars) [rst]),
+ let asplit (vasg, rst) =
+ ((if List.hd rst = [||] then Any else
+ Assignments.assignments_of_list elems (Array.of_list ovars) rst),
vasg) in
- Aux.collect (List.map asplit tps) in
- let fp_next v vl psi nasg =
+ let res= Aux.collect (List.map asplit (Aux.collect (List.map split tps))) in
+ if !debug_level > 1 then Printf.printf "rlen %i\n%!" (List.length res);
+ res in
+ let fp_next v vs psi nasg =
let nx (a, vsl) =
eval ((v, Structure.tuples_of_list vsl)::fp) model elems a psi in
List.fold_left (fun acc a -> Assignments.sum elems (nx a) acc)
- Empty (fp_split vl nasg) in
- let rec fixpnt v vl psi a =
- let nxt = fp_next v vl psi a in
- if nxt = a then nxt else fixpnt v vl psi nxt in
+ Empty (fp_split vs nasg) in
+ let rec fixpnt v vs psi a =
+ if !debug_level > 1 then print_endline "Fixed-point step.";
+ let nxt = report(fp_next v vs psi a) in
+ if nxt = a then nxt else fixpnt v vs psi nxt in
+ let simp a = Assignments.compress (Assignments.sllen elems) a in
if aset = Empty then Empty else
match phi with
| Rel (relname, vl) ->
@@ -178,23 +182,29 @@
let in_aset =
if List.exists (fun v->List.mem v aset_vars) vl then Any else aset in
let phi_asgn = eval fp model elems in_aset phi in
- report (join aset (project_list elems phi_asgn vl))
+ report (simp (join aset (project_list elems phi_asgn vl)))
| All (vl, phi) ->
check_timeout "Solver.eval.All";
let aset_vars = AssignmentSet.assigned_vars [] aset in
let in_aset =
if List.exists (fun v->List.mem v aset_vars) vl then Any else aset in
let phi_asgn = eval fp model elems in_aset phi in
- report (join aset (universal_list elems phi_asgn vl))
+ report (simp (join aset (universal_list elems phi_asgn vl)))
| Lfp (v, vl, phi) ->
- let a0 = eval ((v, Structure.Tuples.empty)::fp) model elems aset phi in
- report (if a0 = Empty then Empty else fixpnt v vl phi a0)
- | Gfp (v, vl, phi) ->
+ let vll = (Array.to_list vl :> var list) in
+ let asg0 = simp (project_list elems aset vll) in
+ let a0 = eval ((v, Structure.Tuples.empty)::fp) model elems asg0 phi in
+ let fp_res = if a0 = Empty then Empty else fixpnt v vll phi a0 in
+ report (simp (join aset fp_res))
+ | Gfp (v, vl, phi) ->
+ let vll = (Array.to_list vl :> var list) in
+ let asg0 = simp (project_list elems aset vll) in
let alltps = Structure.tuples_of_list
(AssignmentSet.tuples (Assignments.sset elems)
(List.map var_str ((Array.to_list vl) :> var list)) Any) in
- let a0 = eval ((v, alltps)::fp) model elems aset phi in
- report (if a0 = Empty then Empty else fixpnt v vl phi a0)
+ let a0 = eval ((v, alltps)::fp) model elems asg0 phi in
+ let fp_res = if a0 = Any then Any else fixpnt v vll phi a0 in
+ report (simp (join aset fp_res))
and assignment_of_real_expr fp ?(check=true) model elems (p, sgn) =
let rec fo_vars_r_rec = function
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/Solver/SolverTest.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -111,12 +111,12 @@
"eval: mso with quantifiers" >::
(fun () ->
- eval_eq "[ | R { (a, b); (a, c) } | ]" "tc x, y R(x, y)"
+ eval_eq "[ | R { (a, b); (a, c) } | ]" "tc in x, y R(x, y)"
"{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3{ x->1, x->3 } }";
- eval_eq "[ | R { (a, b); (b, c) } | ]" "tc x, y R(x, y)"
+ eval_eq "[ | R { (a, b); (b, c) } | ]" "tc in x, y R(x, y)"
"{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }";
eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]"
- "x != y and not R(x, y) and tc x, y R(x, y)"
+ "x != y and not R(x, y) and tc in x, y R(x, y)"
("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^
" y->6{ x->1, x->2, x->3, x->4 } , y->7{ x->1, x->2, x->3, x->4," ^
" x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }");
@@ -134,7 +134,7 @@
"eval: fixed-points" >::
(fun () ->
- eval_eq "[ | P (a) | ]" "lfp T(x) = P(x)" "{ x->1 }";
+ eval_eq "[a, b | P (a) | ]" "lfp T(x) = P(x)" "{ x->1 }";
eval_eq "[ | P:1 {} | ]" "lfp T(x) = P(x)" "{}";
eval_eq "[ | R { (a, b); (b, c) } | ]"
"lfp T(x) = (x = y or ex z (z in T and R (x, z)))"
@@ -142,47 +142,16 @@
eval_eq "[ | R { (a, b); (b, a); (b, c) } | ]"
"gfp T(x) = (x != y and x in T and all z (R (x, z) -> z in T))"
"{ y->1{ x->3 } , y->2{ x->3 } }";
- );
- "eval: bigger tc tests" >::
- (fun () ->
- let diag_phi =
- "set d1(x, y) = ex z ((R(x, z) and C(z, y)) or (R(y, z) and C(z, x))) in
- set d2(x, y) = ex z ((R(x, z) and C(y, z)) or (R(y, z) and C(x, z))) in
- set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in
- set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in
- set fd1(x, y) = tc x,y (d1(x, y) and not w(y) and not b(y)) in
- set fd2(x, y) = tc x,y (d2(x, y) and not w(y) and not b(y)) in
- set Diag1 (x, y) = ex z (fd1 (x, z) and (z = y or d1 (z, y))) in
- set Diag2 (x, y) = ex z (fd2 (x, z) and (z = y or d2 (z, y))) in
- wB(x) and (Diag1 (x, y) or Diag2 (x, y))" in
- eval_eq "[ | | ] \"
- ... ...
- ... ...
- ... ...
- ... ...
- ... ...
- ... ...
- ... ...
- ... wB.
-\"" diag_phi
- "{ y->3{ x->3 } , y->6{ x->3 } , y->8{ x->3 } , y->9{ x->3 } }";
-(* eval_eq "[ | | ] \"
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... ... ...
- ... wB. ...
-\"" diag_phi
- ("{ y->3{ x->3 } , y->8{ x->3 } , y->10{ x->3 } ," ^
- " y->13{ x->3 } , y->17{ x->3 } , y->24{ x->3 } }"); *)
+ eval_eq "[ | R { (a, b); (a, c) } | ]" "tc x, y R(x, y)"
+ "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3{ x->1, x->3 } }";
+ eval_eq "[ | R { (a, b); (b, c) } | ]" "tc x, y R(x, y)"
+ "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }";
+ eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]"
+ "x != y and not R(x, y) and tc x, y R(x, y)"
+ ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^
+ " y->6{ x->1, x->2, x->3, x->4 } , y->7{ x->1, x->2, x->3, x->4," ^
+ " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }");
);
"eval: with real values" >::
@@ -271,48 +240,171 @@
]
-let exec = Aux.run_test_if_target "SolverTest" tests
+let bigtests = "SolverBig" >::: [
+ "eval: bigger tc tests" >::
+ (fun () ->
+ let diag_phi_mso =
+ "set d1(x, y) = ex z ((R(x, z) and C(z, y)) or (R(y, z) and C(z, x))) in
+ set d2(x, y) = ex z ((R(x, z) and C(y, z)) or (R(y, z) and C(x, z))) in
+ set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in
+ set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in
+ set fd1(x, y) = tc in x,y (d1(x, y) and not w(y) and not b(y)) in
+ set fd2(x, y) = tc in x,y (d2(x, y) and not w(y) and not b(y)) in
+ set Diag1 (x, y) = ex z (fd1 (x, z) and (z = y or d1 (z, y))) in
+ set Diag2 (x, y) = ex z (fd2 (x, z) and (z = y or d2 (z, y))) in
+ wB(x) and (Diag1 (x, y) or Diag2 (x, y))" in
+ eval_eq "[ | | ] \"
+ ... ...
+ ... ...
+ ... ...
+ ... ...
+ ... ...
+ ... ...
+ ... ...
+ ... wB.
+\"" diag_phi_mso
+ "{ y->3{ x->3 } , y->6{ x->3 } , y->8{ x->3 } , y->9{ x->3 } }";
+ let diag_phi =
+ "set d1(x, y) = ex z ((R(x, z) and C(z, y)) or (R(y, z) and C(z, x))) in
+ set d2(x, y) = ex z ((R(x, z) and C(y, z)) or (R(y, z) and C(x, z))) in
+ set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in
+ set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in
+ set fd1(x, y) = tc x,y (d1(x, y) and not w(y) and not b(y)) in
+ set fd2(x, y) = tc x,y (d2(x, y) and not w(y) and not b(y)) in
+ set Diag1 (x, y) = ex z (fd1 (x, z) and (z = y or d1 (z, y))) in
+ set Diag2 (x, y) = ex z (fd2 (x, z) and (z = y or d2 (z, y))) in
+ wB(x) and (Diag1 (x, y) or Diag2 (x, y))" in
+ eval_eq "[ | | ] \"
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... ... ...
+ ... wB. ...
+\"" diag_phi
+ ("{ y->3{ x->3 } , y->8{ x->3 } , y->10{ x->3 } , " ^
+ "y->13{ x->3 } , y->17{ x->3 } , y->24{ x->3 } }");
+ let chess_phi = "
+set D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) in
+set D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) ) in
+set IsFirst(x) = not ex z C(z, x) in
+set IsSecond(x) = ex y (C(y, x) and IsFirst(y)) in
+set IsEight(x) = not ex z C(x, z) in
+set IsSeventh(x) = ex y (C(x, y) and IsEight(y)) in
+set IsA1(x) = not ex z R(z, x) and IsFirst(x) in
+set IsH1(x) = not ex z R(x, z) and IsFirst(x) in
+set IsA8(x) = not ex z R(z, x) and IsEight(x) in
+set IsH8(x) = not ex z R(x, z) and IsEight(x) in
+set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in
+set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in
+set DoubleC(x, y) = ex z ((C(x, z) and C(z, y)) or (C(y, z) and C(z, x))) in
+set DoubleR(x, y) = ex z ((R(x, z) and R(z, y)) or (R(y, z) and R(z, x))) in
+set KnightRCC(x, y) = ex z ((R(x, z) or R(z, x)) and DoubleC(z, y)) in
+set KnightCRR(x, y) = ex z ((C(x, z) or C(z, x)) and DoubleR(z, y)) in
+set Knight(x, y) = KnightRCC(x, y) or KnightCRR(x, y) in
+set FreeD1 (x, y) = tc x, y (D1 (x, y) and not w(y) and not b(y)) in
+set FreeD2 (x, y) = tc x, y (D2 (x, y) and not w(y) and not b(y)) in
+set Diag1 (x, y) = ex z (FreeD1 (x, z) and (z = y or D1 (z, y))) in
+set Diag2 (x, y) = ex z (FreeD2 (x, z) and (z = y or D2 (z, y))) in
+set Diag (x, y) = Diag1 (x, y) or Diag2 (x, y) in
+set FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not b(y)) in
+set FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not b(y)) in
+set Col (x, y) = ex z (FreeC (x, z) and (z = y or (C(z, y) or C(y, z)))) in
+set Row (x, y) = ex z (FreeR (x, z) and (z = y or (R(z, y) or R(y, z)))) in
+set Line (x, y) = Col (x, y) or Row (x, y) in
+set Near(x, y) = C(x,y) or C(y,x) or R(x,y) or R(y,x) or D1(x, y) or D2(x, y) in
+set wPBeats (x) = ex y (wP(y) and ex z ((R(y, z) or R(z, y)) and C(z, x))) in
+set bPBeats (x) = ex y (bP(y) and ex z ((R(y, z) or R(z, y)) and C(x, z))) in
+set wDiagBeats (x) = ex y ((wQ(y) or wB(y)) and Diag(y, x)) in
+set bDiagBeats (x) = ex y ((bQ(y) or bB(y)) and Diag(y, x)) in
+set wLineBeats (x) = ex y ((wQ(y) or wR(y)) and Line(y, x)) in
+set bLineBeats (x) = ex y ((bQ(y) or bR(y)) and Line(y, x)) in
+set wFBeats(x)= wDiagBeats(x) or wLineBeats(x) or ex y(wN(y) and Knight(y,x)) in
+set bFBeats(x)= bDiagBeats(x) or bLineBeats(x) or ex y(bN(y) and Knight(y,x)) in
+set wBeats(x) = wFBeats(x) or wPBeats(x) or ex y (wK(y) and Near(y, x)) in
+set bBeats(x) = bFBeats(x) or bPBeats(x) or ex y (bK(y) and Near(y, x)) in
+set CheckW() = ex x (wK(x) and bBeats(x)) in
+set CheckB() = ex x (bK(x) and wBeats(x)) in " in
+ eval_eq "[ | | ] \"
+ ... ... ... ...
+ bR bN.bB bQ.bK bB.bN bR.
+ ... ... ... ...
+ bP.bP bP.bP bP.bP bP.bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ wP wP.wP wP.wP wP.wP wP.
+ ... ... ... ...
+ wR.wN wB.wQ wK.wB wN.wR
+\"" (chess_phi ^ "IsA8(x) and not CheckW()") "{ x->57 }";
+ );
-
-(* ----------------------- FOUR POINTS PROBLEM --------------------------- *)
-
-(*
-test_eval "[ | P {x}; Q {y}; Z {z}; S {v} | ]"
- "ex :px, :py, :qx, :qy, :zx, :zy, :sx, :sz all X ex :rt, :rb, :rl, :rr all x(
+ (*"eval: four points problem" >::
+ (fun () ->
+ Solver.set_debug_level 3;
+ FormulaOps.set_debug_level 3;
+ BoolFormula.set_debug_level 3;
+ Sat.set_debug_level 3;
+ eval_eq "[ | P {x}; Q {y}; Z {z}; S {v} | ]"
+ ("ex :px, :py, :qx, :qy, :zx, :zy, :sx, :sz all X ex :rt,:rb,:rl,:rr" ^
+ " all x(
(P(x) -> (x in X <-> (:px>:rl and :px<:rr and :py>:rb and :py<:rt))) and
(Q(x) -> (x in X <-> (:qx>:rl and :qx<:rr and :qy>:rb and :qy<:rt))) and
(Z(x) -> (x in X <-> (:zx>:rl and :zx<:rr and :zy>:rb and :zy<:rt))) and
- (S(x) -> (x in X <-> (:sx>:rl and :sx<:rr and :sy>:rb and :sy<:rt))))"
-*)
+ (S(x) -> (x in X <-> (:sx>:rl and :sx<:rr and :sy>:rb and :sy<:rt))))")
+ "";
+ );
+ "eval: four coloring problem" >::
+ (fun () ->
+ let four_color_f = "all a, b, c, d
+ (C(a,b) and C(c, d) and R(a,c) and R(b,d) -> (
+ not (a in C1 and b in C1 and c in C1 and d in C1) and
+ not (a in C2 and b in C2 and c in C2 and d in C2) and
+ not (a in C3 and b in C3 and c in C3 and d in C3) and
+ not (a in C4 and b in C4 and c in C4 and d in C4) ))" in
+ let rec linear_order name do_pref i =
+ let elem j =
+ if do_pref then
+ name ^ (string_of_int j)
+ else (string_of_int j) ^ name in
+ let rec all_from j =
+ let str = "(" ^ (elem j) ^ ", " ^ (elem i) ^ ")" in
+ if j = i - 1 then str else str ^ ", " ^ (all_from (j+1)) in
+ if i = 2 then "(" ^ (elem 1) ^ ", " ^ (elem 2) ^ ")" else
+ (linear_order name do_pref (i-1)) ^ ", " ^ (all_from 1) in
-(* ---------------------- FOUR COLORING PROBLEM --------------------------- *)
+ let grid n =
+ let rec upto i = if i = 1 then [1] else (upto (i-1)) @ [i] in
+ let col i = linear_order (string_of_int i) true n in
+ let row i = linear_order (string_of_int i) false n in
+ let cols = String.concat "; " (List.map col (upto n)) in
+ let rows = String.concat "; " (List.map row (upto n)) in
+ "[ | C { " ^ cols ^ " }; R { " ^ rows ^ " } | ]" in
-let four_color_f = "all a, b, c, d
- (C(a,b) and C(c, d) and R(a,c) and R(b,d) -> (
- not (a in C1 and b in C1 and c in C1 and d in C1) and
- not (a in C2 and b in C2 and c in C2 and d in C2) and
- not (a in C3 and b in C3 and c in C3 and d in C3) and
- not (a in C4 and b in C4 and c in C4 and d in C4) ))"
+ Solver.set_debug_level 3;
+ FormulaOps.set_debug_level 3;
+ BoolFormula.set_debug_level 3;
+ Sat.set_debug_level 3;
+ eval_eq (grid 2) four_color_f "";
+ );*)
+]
-let rec linear_order name do_pref i =
- let elem j =
- if do_pref then name ^ (string_of_int j) else (string_of_int j) ^ name in
- let rec all_from j =
- let str = "(" ^ (elem j) ^ ", " ^ (elem i) ^ ")" in
- if j = i - 1 then str else str ^ ", " ^ (all_from (j+1))
- in
- if i = 2 then "(" ^ (elem 1) ^ ", " ^ (elem 2) ^ ")" else
- (linear_order name do_pref (i-1)) ^ ", " ^ (all_from 1)
-let grid n =
- let rec upto i = if i = 1 then [1] else (upto (i-1)) @ [i] in
- let col i = linear_order (string_of_int i) true n in
- let row i = linear_order (string_of_int i) false n in
- let cols = String.concat ", " (List.map col (upto n)) in
- let rows = String.concat ", " (List.map row (upto n)) in
- "[ | C { " ^ cols ^ " }; R { " ^ rows ^ " } | ]"
+let exec = Aux.run_test_if_target "SolverTest" tests
-(* test_eval (grid 2) four_color_f ;; *)
+let execbig = Aux.run_test_if_target "SolverTest" bigtests
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/TossFullTest.ml 2011-05-07 22:30:43 UTC (rev 1433)
@@ -15,6 +15,7 @@
StructureTest.tests;
AssignmentsTest.tests;
SolverTest.tests;
+ SolverTest.bigtests;
ClassTest.tests;
ClassTest.bigtests;
]
Modified: trunk/Toss/examples/Chess.toss
===================================================================
--- trunk/Toss/examples/Chess.toss 2011-05-07 00:43:34 UTC (rev 1432)
+++ trunk/Toss/examples/Chess.toss 2011-05-07 22:30:43 UTC (rev 1433)
@@ -1,5 +1,15 @@
PLAYERS 1, 2
DATA depth: 0, adv_ratio: 1
+SET Sum (x | wP(x) : 1)
+SET Sum (x | wR(x) : 1)
+SET Sum (x | wN(x) : 1)
+SET Sum (x | wB(x) : 1)
+SET Sum (x | wQ(x) : 1)
+SET Sum (x | bP(x) : 1)
+SET Sum (x | bR(x) : 1)
+SET Sum (x | bN(x) : 1)
+SET Sum (x | bB(x) : 1)
+SET Sum (x | bQ(x) : 1)
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)
@@ -15,13 +25,13 @@
REL KnightRCC(x, y) = ex z ((R(x, z) or R(z, x)) and DoubleC(z, y))
REL KnightCRR(x, y) = ex z ((C(x, z) or C(z, x)) and DoubleR(z, y))
REL Knight(x, y) = KnightRCC(x, y) or KnightCRR(x, y)
-REL FreeD1 (x, y) = tc 6 x, y (D1 (x, y) and not w(y) and not b(y))
-REL FreeD2 (x, y) = tc 6 x, y (D2 (x, y) and not w(y) and not b(y))
+REL FreeD1 (x, y) = tc x, y (D1 (x, y) and not w(y) and not b(y))
+REL FreeD2 (x, y) = tc x, y (D2 (x, y) and not w(y) and not b(y))
REL Diag1 (x, y) = ex z (FreeD1 (x, z) and (z = y or D1 (z, y)))
REL Diag2 (x, y) = ex z (FreeD2 (x, z) and (z = y or D2 (z, y)))
REL Diag (x, y) = Diag1 (x, y) or Diag2 (x, y)
-REL FreeC (x, y) = tc 6 x, y ((C(x, y) or C(y, x)) and not w(y) and not b(y))
-REL FreeR (x, y) = tc 6 x, y ((R(x, y) or R(y, x)) and not w(y) and not b(y))
+REL FreeC (x, y) = tc x, y ((C(x, y) or C(y, x)) and not w(y) and not b(y))
+REL FreeR (x, y) = tc x, y ((R(x, y) or R(y, x)) and not w(y) and not b(y))
REL Col (x, y) = ex z (FreeC (x, z) and (z = y or (C(z, y) or C(y, z))))
REL Row (x, y) = ex z (FreeR (x, z) and (z = y or (R(z, y) or R(y, z))))
REL Line (x, y) = Col (x, y) or Row (x, y)
@@ -314,6 +324,7 @@
" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) post true
LOC 0 { // both can castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 1];
@@ -333,10 +344,14 @@
[WhiteRightCastle -> 7];
[WhiteKing -> 7]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 1 { // both can castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 0];
@@ -356,10 +371,14 @@
[BlackRightCastle -> 24];
[BlackKing -> 24]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 2 { // w left, b can castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 3];
@@ -378,10 +397,14 @@
[WhiteLeftCastle -> 7];
[WhiteKing -> 7]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 3 { // w left, b can castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 2];
@@ -401,10 +424,14 @@
[BlackRightCastle -> 26];
[BlackKing -> 26]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 4 { // w right, b can castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 5];
@@ -423,10 +450,14 @@
[WhiteRightCastle -> 7];
[WhiteKing -> 7]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 5 { // w right, b can castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 4];
@@ -446,10 +477,14 @@
[BlackRightCastle -> 28];
[BlackKing -> 28]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 6 { // w no, b can castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 7];
@@ -467,10 +502,14 @@
[WhiteQueen -> 7];
[WhiteKing -> 7]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 7 { // w no, b can castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 6];
@@ -490,10 +529,14 @@
[BlackRightCastle -> 30];
[BlackKing -> 30]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 8 { // w can, b left castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 9];
@@ -513,10 +556,14 @@
[WhiteRightCastle -> 15];
[WhiteKing -> 15]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 9 { // w can, b left castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 8];
@@ -535,10 +582,14 @@
[BlackLeftCastle -> 24];
[BlackKing -> 24]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 10 { // w left, b left castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 11];
@@ -557,10 +608,14 @@
[WhiteLeftCastle -> 15];
[WhiteKing -> 15]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 11 { // w left, b left castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 10];
@@ -579,10 +634,14 @@
[BlackLeftCastle -> 26];
[BlackKing -> 26]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 12 { // w right, b left castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 13];
@@ -601,10 +660,14 @@
[WhiteRightCastle -> 15];
[WhiteKing -> 15]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 13 { // w right, b left castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 12];
@@ -623,10 +686,14 @@
[BlackLeftCastle -> 28];
[BlackKing -> 28]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 14 { // w no, b left castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 15];
@@ -644,10 +711,14 @@
[WhiteQueen -> 15];
[WhiteKing -> 15]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 15 { // w no, b left castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 14];
@@ -666,10 +737,14 @@
[BlackLeftCastle -> 30];
[BlackKing -> 30]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 16 { // w can, b right castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 17];
@@ -689,10 +764,14 @@
[WhiteRightCastle -> 23];
[WhiteKing -> 23]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 17 { // w can, b right castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 16];
@@ -711,10 +790,14 @@
[BlackRightCastle -> 24];
[BlackKing -> 24]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 18 { // w left, b right castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 19];
@@ -733,10 +816,14 @@
[WhiteLeftCastle -> 23];
[WhiteKing -> 23]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 19 { // w left, b right castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 18];
@@ -755,10 +842,14 @@
[BlackRightCastle -> 26];
[BlackKing -> 26]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 20 { // w right, b right castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 21];
@@ -777,10 +868,14 @@
[WhiteRightCastle -> 23];
[WhiteKing -> 23]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 21 { // w right, b right castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 20];
@@ -799,10 +894,14 @@
[BlackRightCastle -> 28];
[BlackKing -> 28]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 22 { // w no, b right castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 23];
@@ -820,10 +919,14 @@
[WhiteQueen -> 23];
[WhiteKing -> 23]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
+ PAYOFF :(CheckW()) - :(CheckB())
+ }
}
LOC 23 { // w no, b right castle
PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1; 5; 3; 3; 9
PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 22];
@@ -842,10 +945,14 @@
[BlackRightCastle -> 30];
[BlackKing -> 30]
}
- PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+ PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
+ PAYOFF :(CheckB()) - :(CheckW())
+ }
}
LOC 24 { // w can, b no castle
PLAYER 1 {
+ COND 1; 5; 3; 3; 9; -1; -5; -3; -3; -9
PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 25];
@@ -865,10 +972,14 @@
[WhiteRightCastle -> 31];
[WhiteKing -> 31]
}
- PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+ PLAYER 2 {
+ COND -1; -5; -3; -3; -9; 1;...
[truncated message content] |
|
From: <luk...@us...> - 2011-05-07 00:43:41
|
Revision: 1432
http://toss.svn.sourceforge.net/toss/?rev=1432&view=rev
Author: lukaszkaiser
Date: 2011-05-07 00:43:34 +0000 (Sat, 07 May 2011)
Log Message:
-----------
Fixed-points in Solver.
Modified Paths:
--------------
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Solver/Assignments.ml
trunk/Toss/Solver/Assignments.mli
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/SolverTest.ml
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-05-03 21:18:08 UTC (rev 1431)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-05-07 00:43:34 UTC (rev 1432)
@@ -107,7 +107,8 @@
| Lfp (r, xs, phi) | Gfp (r, xs, phi) ->
let vs = (r :> var) :: ((Array.to_list xs) :> var list) in
let fv_phi = free_vars_acc [] phi in
- List.rev_append (List.filter (fun v -> not (List.mem v vs)) fv_phi) acc
+ List.rev_append ((Array.to_list xs) :> var list) (List.rev_append (
+ List.filter (fun v -> not (List.mem v vs)) fv_phi) acc)
and free_vars_real = function
| RVar s -> [s]
@@ -489,24 +490,22 @@
let (new_bad, bad_subst) = newnames new_subst bad_vs in
All (new_bad @ ok_vs, subst_vars (bad_subst @ new_subst) phi)
| Lfp (v, vs, phi) ->
- let ((bad_vs,ok_vs),new_subst) =
- splitvs subst ((v :> var) :: ((Array.to_list vs) :> var list)) in
- if new_subst = [] then Lfp (v, vs, phi) else if bad_vs = [] then
- Lfp (v, vs, subst_vars new_subst phi)
+ let subvs = Array.map (fo_var_subst subst) vs in
+ let ((bad_vs,ok_vs),new_subst) = splitvs subst [(v :> var)] in
+ if new_subst = [] then Lfp (v, subvs, phi) else if bad_vs = [] then
+ Lfp (v, subvs, subst_vars new_subst phi)
else
let (_, bad_subst) = newnames new_subst bad_vs in
- let nvs = Array.map (fo_var_subst bad_subst) vs in
- Lfp (fp_var_subst bad_subst v, nvs,
+ Lfp (fp_var_subst bad_subst v, subvs,
subst_vars (bad_subst @ new_subst) phi)
| Gfp (v, vs, phi) ->
- let ((bad_vs,ok_vs),new_subst) =
- splitvs subst ((v :> var) :: ((Array.to_list vs) :> var list)) in
- if new_subst = [] then Gfp (v, vs, phi) else if bad_vs = [] then
- Gfp (v, vs, subst_vars new_subst phi)
+ let subvs = Array.map (fo_var_subst subst) vs in
+ let ((bad_vs,ok_vs),new_subst) = splitvs subst [(v :> var)] in
+ if new_subst = [] then Gfp (v, subvs, phi) else if bad_vs = [] then
+ Gfp (v, subvs, subst_vars new_subst phi)
else
let (_, bad_subst) = newnames new_subst bad_vs in
- let nvs = Array.map (fo_var_subst bad_subst) vs in
- Gfp (fp_var_subst bad_subst v, nvs,
+ Gfp (fp_var_subst bad_subst v, subvs,
subst_vars (bad_subst @ new_subst) phi)
and subst_vars_expr subst = function
@@ -1328,21 +1327,19 @@
let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
All (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
| Lfp (v, vs, phi) ->
- let vars = (v :> var) :: ((Array.to_list vs) :> var list) in
+ let vars = [(v :> var)] in
let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
if avoidv=[] then Lfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
let subst = List.map (subst_name_avoiding avs) avoidv in
- let nvs, nv = Array.map (fo_var_subst subst) vs, fp_var_subst subst v in
- let nvars = (nv :> var) :: ((Array.to_list nvs) :> var list) in
- Lfp (nv, nvs, rename_quant_avoiding (avs @ nvars) phi)
+ let nv = fp_var_subst subst v in
+ Lfp (nv, vs, rename_quant_avoiding ((nv :> var) :: avs) phi)
| Gfp (v, vs, phi) ->
- let vars = (v :> var) :: ((Array.to_list vs) :> var list) in
+ let vars = [(v :> var)] in
let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
if avoidv=[] then Gfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
let subst = List.map (subst_name_avoiding avs) avoidv in
- let nvs, nv = Array.map (fo_var_subst subst) vs, fp_var_subst subst v in
- let nvars = (nv :> var) :: ((Array.to_list nvs) :> var list) in
- Gfp (nv, nvs, rename_quant_avoiding (avs @ nvars) phi)
+ let nv = fp_var_subst subst v in
+ Gfp (nv, vs, rename_quant_avoiding ((nv :> var) :: avs) phi)
let rec has_mso = function
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-03 21:18:08 UTC (rev 1431)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-07 00:43:34 UTC (rev 1432)
@@ -57,6 +57,8 @@
FormulaOps.free_vars (formula_of_string phi))) in
fv_eq "not (P(x) and not Q(y))" "y, x";
fv_eq "Q(x) or (ex x P(x))" "x";
+ fv_eq "P(x) or ex y (E(x, y) and y in T)" "x, T";
+ fv_eq "lfp T(x) = (P(x) or ex y (E(x, y) and y in T))" "x";
);
"cnf" >::
@@ -151,10 +153,10 @@
subst_free_eq ~sub:[("x", "m"); ("m", "x")]
"R(m) and ex m (S(m) or T(x))" "R(x) and (ex m0 (S(m0) or T(m)))";
subst_free_eq "P(x) and lfp X(x) = (P(x) or ex y (E(x, y) and y in X))"
- "P(a) and lfp X(x) = (P(x) or ex y (E(x, y) and y in X))";
+ "P(a) and lfp X(a) = (P(a) or ex y (E(a, y) and y in X))";
subst_free_eq ~sub:[("x", "a"); ("y", "x"); ("Y", "X")]
"x in Y and gfp X(x) = (x in Y or ex y (E(x, y) and y in X))"
- "a in X and gfp X0(x0) = (x0 in X or ex y (E(x0, y) and y in X0))";
+ "a in X and gfp X0(a) = (a in X or ex y (E(a, y) and y in X0))";
);
"assign emptyset" >::
Modified: trunk/Toss/Solver/Assignments.ml
===================================================================
--- trunk/Toss/Solver/Assignments.ml 2011-05-03 21:18:08 UTC (rev 1431)
+++ trunk/Toss/Solver/Assignments.ml 2011-05-07 00:43:34 UTC (rev 1432)
@@ -45,11 +45,19 @@
(* List a set or list ref; changes from set to list if required. *)
let slist slr =
match !slr with
- List (i, l) -> l
+ | List (i, l) -> l
| Set (i, s) ->
if !debug_level>1 then print_endline " converting set to list (slist)";
let l = Elems.elements s in (slr := List (i, l); l)
+(* Set from a set or list ref; changes from list to set if required. *)
+let sset slr =
+ match !slr with
+ | Set (_, s) -> s
+ | List (_, l) ->
+ if !debug_level>1 then print_endline " converting list to set (slist)";
+ List.fold_left (fun acc e -> Elems.add e acc) Elems.empty l
+
let sllen slr = match !slr with List (i, _) -> i | Set (i, _) -> i
Modified: trunk/Toss/Solver/Assignments.mli
===================================================================
--- trunk/Toss/Solver/Assignments.mli 2011-05-03 21:18:08 UTC (rev 1431)
+++ trunk/Toss/Solver/Assignments.mli 2011-05-07 00:43:34 UTC (rev 1432)
@@ -22,6 +22,7 @@
(** List a set or list ref; changes from set to list if required. *)
val slist : set_list ref -> int list
+val sset : set_list ref -> Structure.Elems.t
val sllen : set_list ref -> int
@@ -99,7 +100,10 @@
val join_rel : assignment_set -> Formula.fo_var array -> Structure.Tuples.t ->
Structure.Tuples.t Structure.IntMap.t -> set_list ref -> assignment_set
+val full_join_rel : assignment_set -> Formula.fo_var array ->
+ Structure.Tuples.t -> set_list ref -> assignment_set
+
(** {2 Debugging} *)
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-05-03 21:18:08 UTC (rev 1431)
+++ trunk/Toss/Solver/Solver.ml 2011-05-07 00:43:34 UTC (rev 1432)
@@ -93,81 +93,110 @@
| _ -> remove_dup_vars (v1::acc) (v2::vs)
(* Calculate valuations which are both in [aset] and satisfy given formula. *)
-let rec eval model elems aset phi =
+let rec eval fp model elems aset phi =
let report res =
if !debug_level > 1 then print_endline ("Got: " ^ (AssignmentSet.str res));
res in
if !debug_level > 1 then print_endline ("Evaluating: " ^ (str phi)) else ();
+ let fp_split vl nasg =
+ let vlen, vs = Array.length vl, (Array.to_list vl :> var list) in
+ let avars = List.map to_fo (AssignmentSet.assigned_vars [] nasg) in
+ let ovars = List.filter (fun v -> not (List.mem (v :> var) vs)) avars in
+ let vars = vs @ (ovars :> var list) in
+ let tps = AssignmentSet.tuples (Assignments.sset elems)
+ (List.map var_str vars) nasg in
+ let split tp =
+ if Array.length tp = vlen then (tp, [||]) else
+ Array.sub tp 0 vlen, Array.sub tp vlen ((Array.length tp) - vlen) in
+ let asplit tp =
+ let (vasg, rst) = split tp in
+ ((if rst = [||] then Any else
+ Assignments.assignments_of_list elems (Array.of_list ovars) [rst]),
+ vasg) in
+ Aux.collect (List.map asplit tps) in
+ let fp_next v vl psi nasg =
+ let nx (a, vsl) =
+ eval ((v, Structure.tuples_of_list vsl)::fp) model elems a psi in
+ List.fold_left (fun acc a -> Assignments.sum elems (nx a) acc)
+ Empty (fp_split vl nasg) in
+ let rec fixpnt v vl psi a =
+ let nxt = fp_next v vl psi a in
+ if nxt = a then nxt else fixpnt v vl psi nxt in
if aset = Empty then Empty else
match phi with
- Rel (relname, vl) -> (* TODO: move to assignments, use incidence *)
- let tuples_s =
- try StringMap.find relname model.relations
- with Not_found -> Tuples.empty in
- let inc_map =
- try StringMap.find relname model.incidence
- with Not_found -> IntMap.empty in
- report (join_rel aset vl tuples_s inc_map elems)
+ | Rel (relname, vl) ->
+ let tuples_s =
+ try StringMap.find relname model.relations
+ with Not_found -> Tuples.empty in
+ let inc_map =
+ try StringMap.find relname model.incidence
+ with Not_found -> IntMap.empty in
+ report (join_rel aset vl tuples_s inc_map elems)
| Eq (x, y) -> report (equal_vars elems x y aset)
- | In (x, y) ->
- let sing_mso e =
+ | SO (v, vl) ->
+ let tuples_s = List.assoc (v :> [ mso_var | so_var ]) fp in
+ report (full_join_rel aset vl tuples_s elems)
+ | In (x, y) -> (
+ try
+ let tuples_s = List.assoc (y :> [ mso_var | so_var ]) fp in
+ report (full_join_rel aset [|x|] tuples_s elems)
+ with Not_found ->
+ let sing_mso e =
MSO (y, [((Elems.add e Elems.empty, Elems.empty), Any)]) in
report (join aset (FO (x, List.map (fun e -> (e, sing_mso e))
- (slist elems))))
+ (slist elems))))
+ )
| Not (In (x, y)) ->
let sing_non_mso e =
MSO (y, [((Elems.empty, Elems.add e Elems.empty), Any)]) in
report (join aset (FO (x, List.map (fun e -> (e, sing_non_mso e))
(slist elems))))
| RealExpr (p, s) -> (* TODO: use aset directly as context for speed *)
- report (join aset (assignment_of_real_expr model elems (p, s)))
+ report (join aset (assignment_of_real_expr fp model elems (p, s)))
| Not phi ->
(*A intersect (complement B)=A intersect (complement(B intersect A))*)
- report (complement_join elems aset (eval model elems aset phi))
+ report (complement_join elems aset (eval fp model elems aset phi))
| And [] -> aset
- | And [phi] -> report (eval model elems aset phi)
- | And fl -> report (List.fold_left (eval model elems) aset fl)
- | Or [phi] -> report (eval model elems aset phi)
+ | And [phi] -> report (eval fp model elems aset phi)
+ | And fl -> report (List.fold_left (eval fp model elems) aset fl)
+ | Or [phi] -> report (eval fp model elems aset phi)
| Or fl ->
let step_or (ast, asets) = function
(* | Not psi ->
- let nast = eval model elems ast psi in
+ let nast = eval fp model elems ast psi in
(nast, report (complement_join elems ast nast) :: asets)
| (In (x, y)) as psi ->
- let nast = eval model elems ast (Not psi) in
- (nast, report (eval model elems ast psi) :: asets) *)
- | psi -> (ast, report (eval model elems ast psi) :: asets) in
+ let nast = eval fp model elems ast (Not psi) in
+ (nast, report (eval fp model elems ast psi) :: asets) *)
+ | psi -> (ast, report (eval fp model elems ast psi) :: asets) in
let (_, asets) = List.fold_left step_or (aset, []) fl in
report (List.fold_left (sum elems) Empty asets)
| Ex ([], phi) | All ([], phi) -> failwith "evaluating empty quantifier"
| Ex (vl, phi) ->
check_timeout "Solver.eval.Ex";
let aset_vars = AssignmentSet.assigned_vars [] aset in
- let in_aset = (* FIXME; TODO; same-name quantified vars?! (tnf_fv!) *)
- if List.exists (fun v -> List.mem v aset_vars) vl then
- (*let asg_s = AssignmentSet.str aset in
- let form_s = Formula.str (Ex (vl, phi)) in
- let msg_s =
- "solver: multiple vars?\n "^ asg_s ^ "\n "^ form_s in
- failwith msg_s *) Any
- else aset in
- let phi_asgn = eval model elems in_aset phi in
+ let in_aset =
+ if List.exists (fun v->List.mem v aset_vars) vl then Any else aset in
+ let phi_asgn = eval fp model elems in_aset phi in
report (join aset (project_list elems phi_asgn vl))
| All (vl, phi) ->
check_timeout "Solver.eval.All";
let aset_vars = AssignmentSet.assigned_vars [] aset in
- let in_aset = (* FIXME; TODO; same-name quantified vars?! (tnf_fv!) *)
- if List.exists (fun v -> List.mem v aset_vars) vl then
- (*let asg_s = AssignmentSet.str aset in
- let form_s = Formula.str (Ex (vl, phi)) in
- let msg_s =
- "solver: multiple vars?\n "^ asg_s ^ "\n "^ form_s in
- failwith msg_s *) Any
- else aset in
- let phi_asgn = eval model elems in_aset phi in
+ let in_aset =
+ if List.exists (fun v->List.mem v aset_vars) vl then Any else aset in
+ let phi_asgn = eval fp model elems in_aset phi in
report (join aset (universal_list elems phi_asgn vl))
+ | Lfp (v, vl, phi) ->
+ let a0 = eval ((v, Structure.Tuples.empty)::fp) model elems aset phi in
+ report (if a0 = Empty then Empty else fixpnt v vl phi a0)
+ | Gfp (v, vl, phi) ->
+ let alltps = Structure.tuples_of_list
+ (AssignmentSet.tuples (Assignments.sset elems)
+ (List.map var_str ((Array.to_list vl) :> var list)) Any) in
+ let a0 = eval ((v, alltps)::fp) model elems aset phi in
+ report (if a0 = Empty then Empty else fixpnt v vl phi a0)
-and assignment_of_real_expr ?(check=true) model elems (p, sgn) =
+and assignment_of_real_expr fp ?(check=true) model elems (p, sgn) =
let rec fo_vars_r_rec = function
RVar s -> []
| Const _ -> []
@@ -203,33 +232,33 @@
| Char phi -> (
let make_fo_asg asg (v, e) = FO (v, [(e, asg)]) in
let fo_aset = List.fold_left make_fo_asg Any assgn in
- match eval model elems fo_aset phi with
+ match eval fp model elems fo_aset phi with
Empty -> Poly.Const (0.)
| _ -> Poly.Const (1.)
)
| Sum (_, guard, r) -> (* FIXME; TODO; for many vars is that ok? *)
let make_fo_asg asg (v, e) = FO (v, [(e, asg)]) in
let fo_aset = List.fold_left make_fo_asg Any assgn in
- let r_a = assignment_of_real_expr ~check:false model elems (r, sgn) in
- let asg = join (eval model elems fo_aset guard) r_a in
+ let r_a = assignment_of_real_expr fp ~check:false model elems (r,sgn) in
+ let asg = join (eval fp model elems fo_aset guard) r_a in
sum_polys asg (* Note: above "sgn" is irrelevant! *) in
let rec process_vars assgn = function
- [] ->
- let poly = poly_of assgn p in
- if check then
- if not (RealQuantElim.sat [(poly, sgn)]) then Empty else
- if RealQuantElim.sat [(poly, SignTable.neg_sign_op sgn)] then
- Real [[(poly, sgn)]]
- else Any
- else Real [[(poly, sgn)]]
+ | [] ->
+ let poly = poly_of assgn p in
+ if check then
+ if not (RealQuantElim.sat [(poly, sgn)]) then Empty else
+ if RealQuantElim.sat [(poly, SignTable.neg_sign_op sgn)] then
+ Real [[(poly, sgn)]]
+ else Any
+ else Real [[(poly, sgn)]]
| v :: vs ->
- let append_elem_asg acc e =
- let asg = process_vars ((v, e)::assgn) vs in
- if asg = Empty then acc else (e, asg) :: acc in
- let asg_list = List.fold_left append_elem_asg [] (slist elems) in
- if asg_list = [] then Empty else
- FO (v, List.rev asg_list) in
- process_vars [] (List.sort Formula.compare_vars (fo_vars_real p))
+ let append_elem_asg acc e =
+ let asg = process_vars ((v, e)::assgn) vs in
+ if asg = Empty then acc else (e, asg) :: acc in
+ let asg_list = List.fold_left append_elem_asg [] (slist elems) in
+ if asg_list = [] then Empty else
+ FO (v, List.rev asg_list) in
+ process_vars [] (List.sort Formula.compare_vars (fo_vars_real p))
let eval_counter = ref 0
@@ -239,7 +268,7 @@
ref (Set (Elems.cardinal struc.elements, struc.elements)) in
let phi = Hashtbl.find solver.formulas_eval formula in
incr eval_counter;
- eval struc elems fo_aset phi
+ eval [] struc elems fo_aset phi
(* Helper: find assoc and remove. *)
let rec assoc_del (x : Formula.formula) = function
@@ -334,7 +363,7 @@
if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi));
let els = Set (Elems.cardinal struc.elements, struc.elements) in
check_timeout "Solver.eval_m.not_found";
- let asg = eval struc (ref els) Any phi in
+ let asg = eval [] struc (ref els) Any phi in
incr eval_counter;
Hashtbl.add !cache_results phi (asg, phi_rels phi);
asg
Modified: trunk/Toss/Solver/SolverTest.ml
===================================================================
--- trunk/Toss/Solver/SolverTest.ml 2011-05-03 21:18:08 UTC (rev 1431)
+++ trunk/Toss/Solver/SolverTest.ml 2011-05-07 00:43:34 UTC (rev 1432)
@@ -1,46 +1,45 @@
-open Solver.M ;;
-open OUnit ;;
+open Solver.M
+open OUnit
-Solver.set_debug_level 0 ;;
-Sat.set_debug_level 0;;
-BoolFormula.set_debug_level 0;;
-FormulaOps.set_debug_level 0;;
+Solver.set_debug_level 0;
+Sat.set_debug_level 0;
+BoolFormula.set_debug_level 0;
+FormulaOps.set_debug_level 0
let formula_of_string s =
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-;;
+
let real_expr_of_string s =
FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)
-;;
+
let struc_of_string s =
StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-;;
+
let eval_eq struc_s phi_s aset_s =
let res = ref "" in
backtrace (
let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in
- (* let solver = new_solver () in *)
res := AssignmentSet.str (evaluate struc phi);
);
assert_equal ~printer:(fun x -> x) aset_s !res
-;;
+
let eval_real_eq var_s struc_s expr_s aset_s =
let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in
assert_equal ~printer:(fun x -> x)
aset_s (AssignmentSet.str (evaluate_real var_s expr struc))
-;;
+
let real_val_eq struc_s expr_s x =
let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in
assert_equal ~printer:(fun x -> string_of_float x)
x (get_real_val expr struc)
-;;
+
let tests = "Solver" >::: [
"eval: first-order quantifier free" >::
(fun () ->
@@ -90,7 +89,8 @@
eval_eq "[ | P { a } | ]" "(t in X2) and ((t in X) or ((t in C)))"
("{ t->1{ X2->(inc {1} excl {}){ X->(inc {} excl {}){ C->(inc {1}" ^
" excl {}) }, X->(inc {1} excl {}) } } }");
- eval_eq "[ | P { a } | ]" "(t in X2) and ((t in X) or ((t in C) or (t in X)))"
+ eval_eq "[ | P { a } | ]"
+ "(t in X2) and ((t in X) or ((t in C) or (t in X)))"
("{ t->1{ X2->(inc {1} excl {}){ X->(inc {} excl {}){ C->(inc {1}" ^
" excl {}) }, X->(inc {1} excl {}) } } }");
eval_eq "[ | P { a } | ]"
@@ -132,6 +132,18 @@
" x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }");
);
+ "eval: fixed-points" >::
+ (fun () ->
+ eval_eq "[ | P (a) | ]" "lfp T(x) = P(x)" "{ x->1 }";
+ eval_eq "[ | P:1 {} | ]" "lfp T(x) = P(x)" "{}";
+ eval_eq "[ | R { (a, b); (b, c) } | ]"
+ "lfp T(x) = (x = y or ex z (z in T and R (x, z)))"
+ "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }";
+ eval_eq "[ | R { (a, b); (b, a); (b, c) } | ]"
+ "gfp T(x) = (x != y and x in T and all z (R (x, z) -> z in T))"
+ "{ y->1{ x->3 } , y->2{ x->3 } }";
+ );
+
"eval: bigger tc tests" >::
(fun () ->
let diag_phi =
@@ -256,19 +268,14 @@
real_val_eq "[ | R { (a, a); (a, b) } | ] "
"Sum (x, y | R (x, y) : 1)" 2.;
);
+]
-] ;;
-let a =
- match test_filter [""] tests with
- | Some tests -> Aux.run_test_if_target "SolverTest" tests
- | None -> ()
-;;
+let exec = Aux.run_test_if_target "SolverTest" tests
-
(* ----------------------- FOUR POINTS PROBLEM --------------------------- *)
(*
@@ -277,7 +284,7 @@
(P(x) -> (x in X <-> (:px>:rl and :px<:rr and :py>:rb and :py<:rt))) and
(Q(x) -> (x in X <-> (:qx>:rl and :qx<:rr and :qy>:rb and :qy<:rt))) and
(Z(x) -> (x in X <-> (:zx>:rl and :zx<:rr and :zy>:rb and :zy<:rt))) and
- (S(x) -> (x in X <-> (:sx>:rl and :sx<:rr and :sy>:rb and :sy<:rt))))" ;;
+ (S(x) -> (x in X <-> (:sx>:rl and :sx<:rr and :sy>:rb and :sy<:rt))))"
*)
@@ -288,7 +295,7 @@
not (a in C1 and b in C1 and c in C1 and d in C1) and
not (a in C2 and b in C2 and c in C2 and d in C2) and
not (a in C3 and b in C3 and c in C3 and d in C3) and
- not (a in C4 and b in C4 and c in C4 and d in C4) ))" ;;
+ not (a in C4 and b in C4 and c in C4 and d in C4) ))"
let rec linear_order name do_pref i =
let elem j =
@@ -307,6 +314,5 @@
let cols = String.concat ", " (List.map col (upto n)) in
let rows = String.concat ", " (List.map row (upto n)) in
"[ | C { " ^ cols ^ " }; R { " ^ rows ^ " } | ]"
-;;
(* test_eval (grid 2) four_color_f ;; *)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-03 21:18:14
|
Revision: 1431
http://toss.svn.sourceforge.net/toss/?rev=1431&view=rev
Author: lukaszkaiser
Date: 2011-05-03 21:18:08 +0000 (Tue, 03 May 2011)
Log Message:
-----------
Corrected paper version, make doc corrections.
Modified Paths:
--------------
trunk/Toss/Toss.odocl
trunk/Toss/www/pub/first_order_counting_ggp.pdf
Modified: trunk/Toss/Toss.odocl
===================================================================
--- trunk/Toss/Toss.odocl 2011-05-02 12:07:27 UTC (rev 1430)
+++ trunk/Toss/Toss.odocl 2011-05-03 21:18:08 UTC (rev 1431)
@@ -1,6 +1,7 @@
Formula/Formula
Formula/FormulaParser
Formula/BoolFormula
+Formula/BoolFunction
Formula/FFTNF
Formula/FormulaOps
Solver/Structure
@@ -22,6 +23,7 @@
Play/Move
Play/GameTree
Play/Play
-Play/Game
GGP/GDL
-GGP/GDLParser
\ No newline at end of file
+GGP/GDLParser
+GGP/GameSimpl
+Server/Picture
Modified: trunk/Toss/www/pub/first_order_counting_ggp.pdf
===================================================================
(Binary files differ)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-02 12:07:35
|
Revision: 1430
http://toss.svn.sourceforge.net/toss/?rev=1430&view=rev
Author: lukstafi
Date: 2011-05-02 12:07:27 +0000 (Mon, 02 May 2011)
Log Message:
-----------
GDL: regenerated tests.
Modified Paths:
--------------
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/tests/breakthrough-raw.toss
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-05-01 23:21:01 UTC (rev 1429)
+++ trunk/Toss/GGP/GDLTest.ml 2011-05-02 12:07:27 UTC (rev 1430)
@@ -276,7 +276,7 @@
let a () =
(* regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer"; *)
- (* regenerate ~debug:false ~game_name:"connect5" ~player:"x"; *)
- (* regenerate ~debug:false ~game_name:"breakthrough" ~player:"white"; *)
- regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x";
+ regenerate ~debug:false ~game_name:"connect5" ~player:"x";
+ regenerate ~debug:false ~game_name:"breakthrough" ~player:"white";
+ (* regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x"; *)
(* regen_with_debug ~game_name:"connect4" ~player:"white" *)
Modified: trunk/Toss/GGP/tests/breakthrough-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/breakthrough-raw.toss 2011-05-01 23:21:01 UTC (rev 1429)
+++ trunk/Toss/GGP/tests/breakthrough-raw.toss 2011-05-02 12:07:27 UTC (rev 1430)
@@ -30,24 +30,25 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (not
- ex cellholds_x616_8__blank_
+ not
+ (ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_) and
- cellholds_x2_y2_white(cellholds_x616_8__blank_)) and
- ex cellholds_x617_y658__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
- cellholds_x2_y2_black(cellholds_x617_y658__blank_)) and
- not
+ cellholds_x2_y2_white(cellholds_x616_8__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_) and
- cellholds_x2_y2_black(cellholds_x618_1__blank_)) and
- ex cellholds_x619_y659__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
- cellholds_x2_y2_white(cellholds_x619_y659__blank_)))
+ cellholds_x2_y2_black(cellholds_x618_1__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_)) or
+ not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_)))
RULE move_x319_y337_x318_y336_0:
[cellholds_x318_y336__blank_, cellholds_x319_y337__blank_, control__blank_ |
_opt_cellholds_x2_y2_black {
@@ -79,24 +80,25 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (not
- ex cellholds_x616_8__blank_
+ not
+ (ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_) and
- cellholds_x2_y2_white(cellholds_x616_8__blank_)) and
- ex cellholds_x617_y658__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
- cellholds_x2_y2_black(cellholds_x617_y658__blank_)) and
- not
+ cellholds_x2_y2_white(cellholds_x616_8__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_) and
- cellholds_x2_y2_black(cellholds_x618_1__blank_)) and
- ex cellholds_x619_y659__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
- cellholds_x2_y2_white(cellholds_x619_y659__blank_)))
+ cellholds_x2_y2_black(cellholds_x618_1__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_)) or
+ not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_)))
RULE move_x387_y417_x387_y416_0:
[cellholds_x387_y416__blank_, cellholds_x387_y417__blank_, control__blank_ |
EQ___cellholds_x2_y2_MV1_x2
@@ -126,24 +128,25 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (not
- ex cellholds_x616_8__blank_
+ not
+ (ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_) and
- cellholds_x2_y2_white(cellholds_x616_8__blank_)) and
- ex cellholds_x617_y658__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
- cellholds_x2_y2_black(cellholds_x617_y658__blank_)) and
- not
+ cellholds_x2_y2_white(cellholds_x616_8__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_) and
- cellholds_x2_y2_black(cellholds_x618_1__blank_)) and
- ex cellholds_x619_y659__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
- cellholds_x2_y2_white(cellholds_x619_y659__blank_)))
+ cellholds_x2_y2_black(cellholds_x618_1__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_)) or
+ not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_)))
RULE move_x467_y497_x466_y496_1:
[cellholds_x466_y496__blank_, cellholds_x467_y497__blank_, control__blank_ |
_opt_cellholds_x2_y2_black (control__blank_);
@@ -175,24 +178,25 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (not
- ex cellholds_x616_8__blank_
+ not
+ (ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_) and
- cellholds_x2_y2_white(cellholds_x616_8__blank_)) and
- ex cellholds_x617_y658__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
- cellholds_x2_y2_black(cellholds_x617_y658__blank_)) and
- not
+ cellholds_x2_y2_white(cellholds_x616_8__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_) and
- cellholds_x2_y2_black(cellholds_x618_1__blank_)) and
- ex cellholds_x619_y659__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
- cellholds_x2_y2_white(cellholds_x619_y659__blank_)))
+ cellholds_x2_y2_black(cellholds_x618_1__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_)) or
+ not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_)))
RULE move_x547_y577_x546_y576_1:
[cellholds_x546_y576__blank_, cellholds_x547_y577__blank_, control__blank_ |
_opt_cellholds_x2_y2_black (control__blank_);
@@ -224,24 +228,25 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (not
- ex cellholds_x616_8__blank_
+ not
+ (ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_) and
- cellholds_x2_y2_white(cellholds_x616_8__blank_)) and
- ex cellholds_x617_y658__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
- cellholds_x2_y2_black(cellholds_x617_y658__blank_)) and
- not
+ cellholds_x2_y2_white(cellholds_x616_8__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_) and
- cellholds_x2_y2_black(cellholds_x618_1__blank_)) and
- ex cellholds_x619_y659__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
- cellholds_x2_y2_white(cellholds_x619_y659__blank_)))
+ cellholds_x2_y2_black(cellholds_x618_1__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_)) or
+ not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_)))
RULE move_x615_y657_x615_y656_1:
[cellholds_x615_y656__blank_, cellholds_x615_y657__blank_, control__blank_ |
EQ___cellholds_x2_y2_MV1_x2
@@ -271,24 +276,25 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (not
- ex cellholds_x616_8__blank_
+ not
+ (ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_) and
- cellholds_x2_y2_white(cellholds_x616_8__blank_)) and
- ex cellholds_x617_y658__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
- cellholds_x2_y2_black(cellholds_x617_y658__blank_)) and
- not
+ cellholds_x2_y2_white(cellholds_x616_8__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_) and
- cellholds_x2_y2_black(cellholds_x618_1__blank_)) and
- ex cellholds_x619_y659__blank_
- (index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_) and
- index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
- cellholds_x2_y2_white(cellholds_x619_y659__blank_)))
+ cellholds_x2_y2_black(cellholds_x618_1__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x618_1__blank_)) or
+ not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x617_y658__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_x2(cellholds_x619_y659__blank_) and
+ index__cellholds_x2_y2_MV1_y2(cellholds_x619_y659__blank_)))
LOC 0 {
PLAYER white {
Modified: trunk/Toss/GGP/tests/breakthrough-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/breakthrough-simpl.toss 2011-05-01 23:21:01 UTC (rev 1429)
+++ trunk/Toss/GGP/tests/breakthrough-simpl.toss 2011-05-02 12:07:27 UTC (rev 1430)
@@ -31,18 +31,19 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (ex cellholds_x617_y658__blank_
- (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
- not control_MV1(cellholds_x617_y658__blank_)) and
- ex cellholds_x619_y659__blank_
- (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
- not control_MV1(cellholds_x619_y659__blank_)) and
- not
+ not
+ (not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ not control_MV1(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ not control_MV1(cellholds_x619_y659__blank_)) or
ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
cellholds_x2_y2_white(cellholds_x616_8__blank_) and
- not control_MV1(cellholds_x616_8__blank_)) and
- not
+ not control_MV1(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
cellholds_x2_y2_black(cellholds_x618_1__blank_) and
@@ -72,18 +73,19 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (ex cellholds_x617_y658__blank_
- (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
- not control_MV1(cellholds_x617_y658__blank_)) and
- ex cellholds_x619_y659__blank_
- (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
- not control_MV1(cellholds_x619_y659__blank_)) and
- not
+ not
+ (not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ not control_MV1(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ not control_MV1(cellholds_x619_y659__blank_)) or
ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
cellholds_x2_y2_white(cellholds_x616_8__blank_) and
- not control_MV1(cellholds_x616_8__blank_)) and
- not
+ not control_MV1(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
cellholds_x2_y2_black(cellholds_x618_1__blank_) and
@@ -110,18 +112,19 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (ex cellholds_x617_y658__blank_
- (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
- not control_MV1(cellholds_x617_y658__blank_)) and
- ex cellholds_x619_y659__blank_
- (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
- not control_MV1(cellholds_x619_y659__blank_)) and
- not
+ not
+ (not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ not control_MV1(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ not control_MV1(cellholds_x619_y659__blank_)) or
ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
cellholds_x2_y2_white(cellholds_x616_8__blank_) and
- not control_MV1(cellholds_x616_8__blank_)) and
- not
+ not control_MV1(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
cellholds_x2_y2_black(cellholds_x618_1__blank_) and
@@ -151,18 +154,19 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (ex cellholds_x617_y658__blank_
- (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
- not control_MV1(cellholds_x617_y658__blank_)) and
- ex cellholds_x619_y659__blank_
- (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
- not control_MV1(cellholds_x619_y659__blank_)) and
- not
+ not
+ (not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ not control_MV1(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ not control_MV1(cellholds_x619_y659__blank_)) or
ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
cellholds_x2_y2_white(cellholds_x616_8__blank_) and
- not control_MV1(cellholds_x616_8__blank_)) and
- not
+ not control_MV1(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
cellholds_x2_y2_black(cellholds_x618_1__blank_) and
@@ -192,18 +196,19 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (ex cellholds_x617_y658__blank_
- (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
- not control_MV1(cellholds_x617_y658__blank_)) and
- ex cellholds_x619_y659__blank_
- (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
- not control_MV1(cellholds_x619_y659__blank_)) and
- not
+ not
+ (not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ not control_MV1(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ not control_MV1(cellholds_x619_y659__blank_)) or
ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
cellholds_x2_y2_white(cellholds_x616_8__blank_) and
- not control_MV1(cellholds_x616_8__blank_)) and
- not
+ not control_MV1(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
cellholds_x2_y2_black(cellholds_x618_1__blank_) and
@@ -230,18 +235,19 @@
emb cellholds_x2_y2_black, cellholds_x2_y2_white, control_black,
control_white
pre
- (ex cellholds_x617_y658__blank_
- (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
- not control_MV1(cellholds_x617_y658__blank_)) and
- ex cellholds_x619_y659__blank_
- (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
- not control_MV1(cellholds_x619_y659__blank_)) and
- not
+ not
+ (not
+ ex cellholds_x617_y658__blank_
+ (cellholds_x2_y2_black(cellholds_x617_y658__blank_) and
+ not control_MV1(cellholds_x617_y658__blank_)) or
+ not
+ ex cellholds_x619_y659__blank_
+ (cellholds_x2_y2_white(cellholds_x619_y659__blank_) and
+ not control_MV1(cellholds_x619_y659__blank_)) or
ex cellholds_x616_8__blank_
(cellholds_x2_8_MV1(cellholds_x616_8__blank_) and
cellholds_x2_y2_white(cellholds_x616_8__blank_) and
- not control_MV1(cellholds_x616_8__blank_)) and
- not
+ not control_MV1(cellholds_x616_8__blank_)) or
ex cellholds_x618_1__blank_
(cellholds_x2_1_MV1(cellholds_x618_1__blank_) and
cellholds_x2_y2_black(cellholds_x618_1__blank_) and
Modified: trunk/Toss/GGP/tests/connect5-raw.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-raw.toss 2011-05-01 23:21:01 UTC (rev 1429)
+++ trunk/Toss/GGP/tests/connect5-raw.toss 2011-05-02 12:07:27 UTC (rev 1430)
@@ -15,83 +15,39 @@
]
emb cell_x_y_b, cell_x_y_o, cell_x_y_x, control_o, control_x
pre
- (not
- ex cell_x177_e24__blank_, cell_x177_d24__blank_, cell_x177_c32__blank_,
- cell_x177_b24__blank_, cell_x177_a24__blank_
- (EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_b24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_c32__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_d24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_e24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_b24__blank_, cell_x177_c32__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_b24__blank_, cell_x177_d24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_b24__blank_, cell_x177_e24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_c32__blank_, cell_x177_d24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_c32__blank_, cell_x177_e24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_d24__blank_, cell_x177_e24__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_d24__blank_,
- cell_x177_e24__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_c32__blank_,
- cell_x177_d24__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_b24__blank_,
- cell_x177_c32__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_a24__blank_,
- cell_x177_b24__blank_) and cell_x_y_x(cell_x177_e24__blank_) and
- cell_x_y_x(cell_x177_d24__blank_) and
- cell_x_y_x(cell_x177_c32__blank_) and
- cell_x_y_x(cell_x177_b24__blank_) and
- cell_x_y_x(cell_x177_a24__blank_)) and
- not
- ex cell_e25_y178__blank_, cell_d25_y178__blank_, cell_c33_y178__blank_,
- cell_b25_y178__blank_, cell_a25_y178__blank_
- (EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_b25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_c33_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_d25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_e25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_b25_y178__blank_, cell_c33_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_b25_y178__blank_, cell_d25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_b25_y178__blank_, cell_e25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_c33_y178__blank_, cell_d25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_c33_y178__blank_, cell_e25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_d25_y178__blank_, cell_e25_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d25_y178__blank_,
- cell_e25_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c33_y178__blank_,
- cell_d25_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b25_y178__blank_,
- cell_c33_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a25_y178__blank_,
- cell_b25_y178__blank_) and cell_x_y_x(cell_e25_y178__blank_) and
- cell_x_y_x(cell_d25_y178__blank_) and
- cell_x_y_x(cell_c33_y178__blank_) and
- cell_x_y_x(cell_b25_y178__blank_) and
- cell_x_y_x(cell_a25_y178__blank_)) and
- not
+ not
+ (not ex cell_x199_y200__blank_ cell_x_y_b(cell_x199_y200__blank_) or
ex cell_x182_y183__blank_, cell_x181_y182__blank_,
cell_x180_y181__blank_, cell_x179_y180__blank_, cell_x178_y179__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x179_y180__blank_,
- cell_x178_y179__blank_) and
+ (cell_x_y_x(cell_x178_y179__blank_) and
+ cell_x_y_x(cell_x179_y180__blank_) and
+ cell_x_y_x(cell_x180_y181__blank_) and
+ cell_x_y_x(cell_x181_y182__blank_) and
+ cell_x_y_x(cell_x182_y183__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x179_y180__blank_,
cell_x178_y179__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x179_y180__blank_,
+ cell_x178_y179__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x180_y181__blank_,
+ cell_x179_y180__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x180_y181__blank_,
cell_x179_y180__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x180_y181__blank_,
- cell_x179_y180__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x181_y182__blank_,
+ cell_x180_y181__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x181_y182__blank_,
cell_x180_y181__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x181_y182__blank_,
- cell_x180_y181__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x182_y183__blank_,
+ cell_x181_y182__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x182_y183__blank_,
- cell_x181_y182__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x182_y183__blank_,
- cell_x181_y182__blank_) and cell_x_y_x(cell_x178_y179__blank_) and
- cell_x_y_x(cell_x179_y180__blank_) and
- cell_x_y_x(cell_x180_y181__blank_) and
- cell_x_y_x(cell_x181_y182__blank_) and
- cell_x_y_x(cell_x182_y183__blank_)) and
- not
+ cell_x181_y182__blank_)) or
ex cell_x187_y188__blank_, cell_x186_y187__blank_,
cell_x185_y186__blank_, cell_x184_y185__blank_, cell_x183_y184__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x183_y184__blank_,
+ (cell_x_y_x(cell_x183_y184__blank_) and
+ cell_x_y_x(cell_x184_y185__blank_) and
+ cell_x_y_x(cell_x185_y186__blank_) and
+ cell_x_y_x(cell_x186_y187__blank_) and
+ cell_x_y_x(cell_x187_y188__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x183_y184__blank_,
cell_x184_y185__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x184_y185__blank_,
cell_x183_y184__blank_) and
@@ -106,88 +62,38 @@
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x186_y187__blank_,
cell_x187_y188__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x187_y188__blank_,
- cell_x186_y187__blank_) and cell_x_y_x(cell_x183_y184__blank_) and
- cell_x_y_x(cell_x184_y185__blank_) and
- cell_x_y_x(cell_x185_y186__blank_) and
- cell_x_y_x(cell_x186_y187__blank_) and
- cell_x_y_x(cell_x187_y188__blank_)) and
- not
- ex cell_x188_e26__blank_, cell_x188_d26__blank_, cell_x188_c34__blank_,
- cell_x188_b26__blank_, cell_x188_a26__blank_
- (EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_b26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_c34__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_d26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_e26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_b26__blank_, cell_x188_c34__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_b26__blank_, cell_x188_d26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_b26__blank_, cell_x188_e26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_c34__blank_, cell_x188_d26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_c34__blank_, cell_x188_e26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_d26__blank_, cell_x188_e26__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_d26__blank_,
- cell_x188_e26__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_c34__blank_,
- cell_x188_d26__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_b26__blank_,
- cell_x188_c34__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_a26__blank_,
- cell_x188_b26__blank_) and cell_x_y_o(cell_x188_e26__blank_) and
- cell_x_y_o(cell_x188_d26__blank_) and
- cell_x_y_o(cell_x188_c34__blank_) and
- cell_x_y_o(cell_x188_b26__blank_) and
- cell_x_y_o(cell_x188_a26__blank_)) and
- not
- ex cell_e27_y189__blank_, cell_d27_y189__blank_, cell_c35_y189__blank_,
- cell_b27_y189__blank_, cell_a27_y189__blank_
- (EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_b27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_c35_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_d27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_e27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_b27_y189__blank_, cell_c35_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_b27_y189__blank_, cell_d27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_b27_y189__blank_, cell_e27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_c35_y189__blank_, cell_d27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_c35_y189__blank_, cell_e27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_d27_y189__blank_, cell_e27_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d27_y189__blank_,
- cell_e27_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c35_y189__blank_,
- cell_d27_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b27_y189__blank_,
- cell_c35_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a27_y189__blank_,
- cell_b27_y189__blank_) and cell_x_y_o(cell_e27_y189__blank_) and
- cell_x_y_o(cell_d27_y189__blank_) and
- cell_x_y_o(cell_c35_y189__blank_) and
- cell_x_y_o(cell_b27_y189__blank_) and
- cell_x_y_o(cell_a27_y189__blank_)) and
- not
+ cell_x186_y187__blank_)) or
ex cell_x193_y194__blank_, cell_x192_y193__blank_,
cell_x191_y192__blank_, cell_x190_y191__blank_, cell_x189_y190__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x190_y191__blank_,
- cell_x189_y190__blank_) and
+ (cell_x_y_o(cell_x189_y190__blank_) and
+ cell_x_y_o(cell_x190_y191__blank_) and
+ cell_x_y_o(cell_x191_y192__blank_) and
+ cell_x_y_o(cell_x192_y193__blank_) and
+ cell_x_y_o(cell_x193_y194__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x190_y191__blank_,
cell_x189_y190__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x190_y191__blank_,
+ cell_x189_y190__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x191_y192__blank_,
+ cell_x190_y191__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x191_y192__blank_,
cell_x190_y191__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x191_y192__blank_,
- cell_x190_y191__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x192_y193__blank_,
+ cell_x191_y192__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x192_y193__blank_,
cell_x191_y192__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x192_y193__blank_,
- cell_x191_y192__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x193_y194__blank_,
+ cell_x192_y193__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x193_y194__blank_,
- cell_x192_y193__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x193_y194__blank_,
- cell_x192_y193__blank_) and cell_x_y_o(cell_x189_y190__blank_) and
- cell_x_y_o(cell_x190_y191__blank_) and
- cell_x_y_o(cell_x191_y192__blank_) and
- cell_x_y_o(cell_x192_y193__blank_) and
- cell_x_y_o(cell_x193_y194__blank_)) and
- not
+ cell_x192_y193__blank_)) or
ex cell_x198_y199__blank_, cell_x197_y198__blank_,
cell_x196_y197__blank_, cell_x195_y196__blank_, cell_x194_y195__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x194_y195__blank_,
+ (cell_x_y_o(cell_x194_y195__blank_) and
+ cell_x_y_o(cell_x195_y196__blank_) and
+ cell_x_y_o(cell_x196_y197__blank_) and
+ cell_x_y_o(cell_x197_y198__blank_) and
+ cell_x_y_o(cell_x198_y199__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x194_y195__blank_,
cell_x195_y196__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x195_y196__blank_,
cell_x194_y195__blank_) and
@@ -202,12 +108,107 @@
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x197_y198__blank_,
cell_x198_y199__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x198_y199__blank_,
- cell_x197_y198__blank_) and cell_x_y_o(cell_x194_y195__blank_) and
- cell_x_y_o(cell_x195_y196__blank_) and
- cell_x_y_o(cell_x196_y197__blank_) and
- cell_x_y_o(cell_x197_y198__blank_) and
- cell_x_y_o(cell_x198_y199__blank_)) and
- ex cell_x199_y200__blank_ cell_x_y_b(cell_x199_y200__blank_))
+ cell_x197_y198__blank_)) or
+ ex cell_e25_y178__blank_, cell_d25_y178__blank_, cell_c33_y178__blank_,
+ cell_b25_y178__blank_, cell_a25_y178__blank_
+ (cell_x_y_x(cell_a25_y178__blank_) and
+ cell_x_y_x(cell_b25_y178__blank_) and
+ cell_x_y_x(cell_c33_y178__blank_) and
+ cell_x_y_x(cell_d25_y178__blank_) and
+ cell_x_y_x(cell_e25_y178__blank_) and
+ EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_b25_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a25_y178__blank_,
+ cell_b25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_a25_y178__blank_,
+ cell_c33_y178__blank_) and EQ___cell_x_y_MV1_y(cell_a25_y178__blank_,
+ cell_d25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_a25_y178__blank_,
+ cell_e25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_b25_y178__blank_,
+ cell_c33_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b25_y178__blank_,
+ cell_c33_y178__blank_) and EQ___cell_x_y_MV1_y(cell_b25_y178__blank_,
+ cell_d25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_b25_y178__blank_,
+ cell_e25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_c33_y178__blank_,
+ cell_d25_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c33_y178__blank_,
+ cell_d25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_c33_y178__blank_,
+ cell_e25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_d25_y178__blank_,
+ cell_e25_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d25_y178__blank_,
+ cell_e25_y178__blank_)) or
+ ex cell_e27_y189__blank_, cell_d27_y189__blank_, cell_c35_y189__blank_,
+ cell_b27_y189__blank_, cell_a27_y189__blank_
+ (cell_x_y_o(cell_a27_y189__blank_) and
+ cell_x_y_o(cell_b27_y189__blank_) and
+ cell_x_y_o(cell_c35_y189__blank_) and
+ cell_x_y_o(cell_d27_y189__blank_) and
+ cell_x_y_o(cell_e27_y189__blank_) and
+ EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_b27_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a27_y189__blank_,
+ cell_b27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_a27_y189__blank_,
+ cell_c35_y189__blank_) and EQ___cell_x_y_MV1_y(cell_a27_y189__blank_,
+ cell_d27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_a27_y189__blank_,
+ cell_e27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_b27_y189__blank_,
+ cell_c35_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b27_y189__blank_,
+ cell_c35_y189__blank_) and EQ___cell_x_y_MV1_y(cell_b27_y189__blank_,
+ cell_d27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_b27_y189__blank_,
+ cell_e27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_c35_y189__blank_,
+ cell_d27_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c35_y189__blank_,
+ cell_d27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_c35_y189__blank_,
+ cell_e27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_d27_y189__blank_,
+ cell_e27_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d27_y189__blank_,
+ cell_e27_y189__blank_)) or
+ ex cell_x177_e24__blank_, cell_x177_d24__blank_, cell_x177_c32__blank_,
+ cell_x177_b24__blank_, cell_x177_a24__blank_
+ (cell_x_y_x(cell_x177_a24__blank_) and
+ cell_x_y_x(cell_x177_b24__blank_) and
+ cell_x_y_x(cell_x177_c32__blank_) and
+ cell_x_y_x(cell_x177_d24__blank_) and
+ cell_x_y_x(cell_x177_e24__blank_) and
+ EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_b24__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_a24__blank_,
+ cell_x177_b24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_a24__blank_,
+ cell_x177_c32__blank_) and EQ___cell_x_y_MV1_x(cell_x177_a24__blank_,
+ cell_x177_d24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_a24__blank_,
+ cell_x177_e24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_b24__blank_,
+ cell_x177_c32__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_b24__blank_,
+ cell_x177_c32__blank_) and EQ___cell_x_y_MV1_x(cell_x177_b24__blank_,
+ cell_x177_d24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_b24__blank_,
+ cell_x177_e24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_c32__blank_,
+ cell_x177_d24__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_c32__blank_,
+ cell_x177_d24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_c32__blank_,
+ cell_x177_e24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_d24__blank_,
+ cell_x177_e24__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_d24__blank_,
+ cell_x177_e24__blank_)) or
+ ex cell_x188_e26__blank_, cell_x188_d26__blank_, cell_x188_c34__blank_,
+ cell_x188_b26__blank_, cell_x188_a26__blank_
+ (cell_x_y_o(cell_x188_a26__blank_) and
+ cell_x_y_o(cell_x188_b26__blank_) and
+ cell_x_y_o(cell_x188_c34__blank_) and
+ cell_x_y_o(cell_x188_d26__blank_) and
+ cell_x_y_o(cell_x188_e26__blank_) and
+ EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_b26__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_a26__blank_,
+ cell_x188_b26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_a26__blank_,
+ cell_x188_c34__blank_) and EQ___cell_x_y_MV1_x(cell_x188_a26__blank_,
+ cell_x188_d26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_a26__blank_,
+ cell_x188_e26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_b26__blank_,
+ cell_x188_c34__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_b26__blank_,
+ cell_x188_c34__blank_) and EQ___cell_x_y_MV1_x(cell_x188_b26__blank_,
+ cell_x188_d26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_b26__blank_,
+ cell_x188_e26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_c34__blank_,
+ cell_x188_d26__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_c34__blank_,
+ cell_x188_d26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_c34__blank_,
+ cell_x188_e26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_d26__blank_,
+ cell_x188_e26__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_d26__blank_,
+ cell_x188_e26__blank_)))
RULE mark_x175_y176_1:
[cell_x175_y176__blank_, control__blank_ |
_opt_cell_x_y_b (control__blank_);
@@ -224,83 +225,39 @@
]
emb cell_x_y_b, cell_x_y_o, cell_x_y_x, control_o, control_x
pre
- (not
- ex cell_x177_e24__blank_, cell_x177_d24__blank_, cell_x177_c32__blank_,
- cell_x177_b24__blank_, cell_x177_a24__blank_
- (EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_b24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_c32__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_d24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_e24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_b24__blank_, cell_x177_c32__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_b24__blank_, cell_x177_d24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_b24__blank_, cell_x177_e24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_c32__blank_, cell_x177_d24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_c32__blank_, cell_x177_e24__blank_) and
- EQ___cell_x_y_MV1_x(cell_x177_d24__blank_, cell_x177_e24__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_d24__blank_,
- cell_x177_e24__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_c32__blank_,
- cell_x177_d24__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_b24__blank_,
- cell_x177_c32__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_a24__blank_,
- cell_x177_b24__blank_) and cell_x_y_x(cell_x177_e24__blank_) and
- cell_x_y_x(cell_x177_d24__blank_) and
- cell_x_y_x(cell_x177_c32__blank_) and
- cell_x_y_x(cell_x177_b24__blank_) and
- cell_x_y_x(cell_x177_a24__blank_)) and
- not
- ex cell_e25_y178__blank_, cell_d25_y178__blank_, cell_c33_y178__blank_,
- cell_b25_y178__blank_, cell_a25_y178__blank_
- (EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_b25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_c33_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_d25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_e25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_b25_y178__blank_, cell_c33_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_b25_y178__blank_, cell_d25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_b25_y178__blank_, cell_e25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_c33_y178__blank_, cell_d25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_c33_y178__blank_, cell_e25_y178__blank_) and
- EQ___cell_x_y_MV1_y(cell_d25_y178__blank_, cell_e25_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d25_y178__blank_,
- cell_e25_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c33_y178__blank_,
- cell_d25_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b25_y178__blank_,
- cell_c33_y178__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a25_y178__blank_,
- cell_b25_y178__blank_) and cell_x_y_x(cell_e25_y178__blank_) and
- cell_x_y_x(cell_d25_y178__blank_) and
- cell_x_y_x(cell_c33_y178__blank_) and
- cell_x_y_x(cell_b25_y178__blank_) and
- cell_x_y_x(cell_a25_y178__blank_)) and
- not
+ not
+ (not ex cell_x199_y200__blank_ cell_x_y_b(cell_x199_y200__blank_) or
ex cell_x182_y183__blank_, cell_x181_y182__blank_,
cell_x180_y181__blank_, cell_x179_y180__blank_, cell_x178_y179__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x179_y180__blank_,
- cell_x178_y179__blank_) and
+ (cell_x_y_x(cell_x178_y179__blank_) and
+ cell_x_y_x(cell_x179_y180__blank_) and
+ cell_x_y_x(cell_x180_y181__blank_) and
+ cell_x_y_x(cell_x181_y182__blank_) and
+ cell_x_y_x(cell_x182_y183__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x179_y180__blank_,
cell_x178_y179__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x179_y180__blank_,
+ cell_x178_y179__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x180_y181__blank_,
+ cell_x179_y180__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x180_y181__blank_,
cell_x179_y180__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x180_y181__blank_,
- cell_x179_y180__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x181_y182__blank_,
+ cell_x180_y181__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x181_y182__blank_,
cell_x180_y181__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x181_y182__blank_,
- cell_x180_y181__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x182_y183__blank_,
+ cell_x181_y182__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x182_y183__blank_,
- cell_x181_y182__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x182_y183__blank_,
- cell_x181_y182__blank_) and cell_x_y_x(cell_x178_y179__blank_) and
- cell_x_y_x(cell_x179_y180__blank_) and
- cell_x_y_x(cell_x180_y181__blank_) and
- cell_x_y_x(cell_x181_y182__blank_) and
- cell_x_y_x(cell_x182_y183__blank_)) and
- not
+ cell_x181_y182__blank_)) or
ex cell_x187_y188__blank_, cell_x186_y187__blank_,
cell_x185_y186__blank_, cell_x184_y185__blank_, cell_x183_y184__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x183_y184__blank_,
+ (cell_x_y_x(cell_x183_y184__blank_) and
+ cell_x_y_x(cell_x184_y185__blank_) and
+ cell_x_y_x(cell_x185_y186__blank_) and
+ cell_x_y_x(cell_x186_y187__blank_) and
+ cell_x_y_x(cell_x187_y188__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x183_y184__blank_,
cell_x184_y185__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x184_y185__blank_,
cell_x183_y184__blank_) and
@@ -315,88 +272,38 @@
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x186_y187__blank_,
cell_x187_y188__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x187_y188__blank_,
- cell_x186_y187__blank_) and cell_x_y_x(cell_x183_y184__blank_) and
- cell_x_y_x(cell_x184_y185__blank_) and
- cell_x_y_x(cell_x185_y186__blank_) and
- cell_x_y_x(cell_x186_y187__blank_) and
- cell_x_y_x(cell_x187_y188__blank_)) and
- not
- ex cell_x188_e26__blank_, cell_x188_d26__blank_, cell_x188_c34__blank_,
- cell_x188_b26__blank_, cell_x188_a26__blank_
- (EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_b26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_c34__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_d26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_e26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_b26__blank_, cell_x188_c34__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_b26__blank_, cell_x188_d26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_b26__blank_, cell_x188_e26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_c34__blank_, cell_x188_d26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_c34__blank_, cell_x188_e26__blank_) and
- EQ___cell_x_y_MV1_x(cell_x188_d26__blank_, cell_x188_e26__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_d26__blank_,
- cell_x188_e26__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_c34__blank_,
- cell_x188_d26__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_b26__blank_,
- cell_x188_c34__blank_) and
- nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_a26__blank_,
- cell_x188_b26__blank_) and cell_x_y_o(cell_x188_e26__blank_) and
- cell_x_y_o(cell_x188_d26__blank_) and
- cell_x_y_o(cell_x188_c34__blank_) and
- cell_x_y_o(cell_x188_b26__blank_) and
- cell_x_y_o(cell_x188_a26__blank_)) and
- not
- ex cell_e27_y189__blank_, cell_d27_y189__blank_, cell_c35_y189__blank_,
- cell_b27_y189__blank_, cell_a27_y189__blank_
- (EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_b27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_c35_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_d27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_e27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_b27_y189__blank_, cell_c35_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_b27_y189__blank_, cell_d27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_b27_y189__blank_, cell_e27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_c35_y189__blank_, cell_d27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_c35_y189__blank_, cell_e27_y189__blank_) and
- EQ___cell_x_y_MV1_y(cell_d27_y189__blank_, cell_e27_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d27_y189__blank_,
- cell_e27_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c35_y189__blank_,
- cell_d27_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b27_y189__blank_,
- cell_c35_y189__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a27_y189__blank_,
- cell_b27_y189__blank_) and cell_x_y_o(cell_e27_y189__blank_) and
- cell_x_y_o(cell_d27_y189__blank_) and
- cell_x_y_o(cell_c35_y189__blank_) and
- cell_x_y_o(cell_b27_y189__blank_) and
- cell_x_y_o(cell_a27_y189__blank_)) and
- not
+ cell_x186_y187__blank_)) or
ex cell_x193_y194__blank_, cell_x192_y193__blank_,
cell_x191_y192__blank_, cell_x190_y191__blank_, cell_x189_y190__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x190_y191__blank_,
- cell_x189_y190__blank_) and
+ (cell_x_y_o(cell_x189_y190__blank_) and
+ cell_x_y_o(cell_x190_y191__blank_) and
+ cell_x_y_o(cell_x191_y192__blank_) and
+ cell_x_y_o(cell_x192_y193__blank_) and
+ cell_x_y_o(cell_x193_y194__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x190_y191__blank_,
cell_x189_y190__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x190_y191__blank_,
+ cell_x189_y190__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x191_y192__blank_,
+ cell_x190_y191__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x191_y192__blank_,
cell_x190_y191__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x191_y192__blank_,
- cell_x190_y191__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x192_y193__blank_,
+ cell_x191_y192__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x192_y193__blank_,
cell_x191_y192__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x192_y193__blank_,
- cell_x191_y192__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x193_y194__blank_,
+ cell_x192_y193__blank_) and
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x193_y194__blank_,
- cell_x192_y193__blank_) and
- nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x193_y194__blank_,
- cell_x192_y193__blank_) and cell_x_y_o(cell_x189_y190__blank_) and
- cell_x_y_o(cell_x190_y191__blank_) and
- cell_x_y_o(cell_x191_y192__blank_) and
- cell_x_y_o(cell_x192_y193__blank_) and
- cell_x_y_o(cell_x193_y194__blank_)) and
- not
+ cell_x192_y193__blank_)) or
ex cell_x198_y199__blank_, cell_x197_y198__blank_,
cell_x196_y197__blank_, cell_x195_y196__blank_, cell_x194_y195__blank_
- (nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x194_y195__blank_,
+ (cell_x_y_o(cell_x194_y195__blank_) and
+ cell_x_y_o(cell_x195_y196__blank_) and
+ cell_x_y_o(cell_x196_y197__blank_) and
+ cell_x_y_o(cell_x197_y198__blank_) and
+ cell_x_y_o(cell_x198_y199__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x194_y195__blank_,
cell_x195_y196__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x195_y196__blank_,
cell_x194_y195__blank_) and
@@ -411,12 +318,107 @@
nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x197_y198__blank_,
cell_x198_y199__blank_) and
nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_x198_y199__blank_,
- cell_x197_y198__blank_) and cell_x_y_o(cell_x194_y195__blank_) and
- cell_x_y_o(cell_x195_y196__blank_) and
- cell_x_y_o(cell_x196_y197__blank_) and
- cell_x_y_o(cell_x197_y198__blank_) and
- cell_x_y_o(cell_x198_y199__blank_)) and
- ex cell_x199_y200__blank_ cell_x_y_b(cell_x199_y200__blank_))
+ cell_x197_y198__blank_)) or
+ ex cell_e25_y178__blank_, cell_d25_y178__blank_, cell_c33_y178__blank_,
+ cell_b25_y178__blank_, cell_a25_y178__blank_
+ (cell_x_y_x(cell_a25_y178__blank_) and
+ cell_x_y_x(cell_b25_y178__blank_) and
+ cell_x_y_x(cell_c33_y178__blank_) and
+ cell_x_y_x(cell_d25_y178__blank_) and
+ cell_x_y_x(cell_e25_y178__blank_) and
+ EQ___cell_x_y_MV1_y(cell_a25_y178__blank_, cell_b25_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a25_y178__blank_,
+ cell_b25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_a25_y178__blank_,
+ cell_c33_y178__blank_) and EQ___cell_x_y_MV1_y(cell_a25_y178__blank_,
+ cell_d25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_a25_y178__blank_,
+ cell_e25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_b25_y178__blank_,
+ cell_c33_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b25_y178__blank_,
+ cell_c33_y178__blank_) and EQ___cell_x_y_MV1_y(cell_b25_y178__blank_,
+ cell_d25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_b25_y178__blank_,
+ cell_e25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_c33_y178__blank_,
+ cell_d25_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c33_y178__blank_,
+ cell_d25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_c33_y178__blank_,
+ cell_e25_y178__blank_) and EQ___cell_x_y_MV1_y(cell_d25_y178__blank_,
+ cell_e25_y178__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d25_y178__blank_,
+ cell_e25_y178__blank_)) or
+ ex cell_e27_y189__blank_, cell_d27_y189__blank_, cell_c35_y189__blank_,
+ cell_b27_y189__blank_, cell_a27_y189__blank_
+ (cell_x_y_o(cell_a27_y189__blank_) and
+ cell_x_y_o(cell_b27_y189__blank_) and
+ cell_x_y_o(cell_c35_y189__blank_) and
+ cell_x_y_o(cell_d27_y189__blank_) and
+ cell_x_y_o(cell_e27_y189__blank_) and
+ EQ___cell_x_y_MV1_y(cell_a27_y189__blank_, cell_b27_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_a27_y189__blank_,
+ cell_b27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_a27_y189__blank_,
+ cell_c35_y189__blank_) and EQ___cell_x_y_MV1_y(cell_a27_y189__blank_,
+ cell_d27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_a27_y189__blank_,
+ cell_e27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_b27_y189__blank_,
+ cell_c35_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_b27_y189__blank_,
+ cell_c35_y189__blank_) and EQ___cell_x_y_MV1_y(cell_b27_y189__blank_,
+ cell_d27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_b27_y189__blank_,
+ cell_e27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_c35_y189__blank_,
+ cell_d27_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_c35_y189__blank_,
+ cell_d27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_c35_y189__blank_,
+ cell_e27_y189__blank_) and EQ___cell_x_y_MV1_y(cell_d27_y189__blank_,
+ cell_e27_y189__blank_) and
+ nextcol__cell_x_y_MV1_x__cell_x_y_MV1_x(cell_d27_y189__blank_,
+ cell_e27_y189__blank_)) or
+ ex cell_x177_e24__blank_, cell_x177_d24__blank_, cell_x177_c32__blank_,
+ cell_x177_b24__blank_, cell_x177_a24__blank_
+ (cell_x_y_x(cell_x177_a24__blank_) and
+ cell_x_y_x(cell_x177_b24__blank_) and
+ cell_x_y_x(cell_x177_c32__blank_) and
+ cell_x_y_x(cell_x177_d24__blank_) and
+ cell_x_y_x(cell_x177_e24__blank_) and
+ EQ___cell_x_y_MV1_x(cell_x177_a24__blank_, cell_x177_b24__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_a24__blank_,
+ cell_x177_b24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_a24__blank_,
+ cell_x177_c32__blank_) and EQ___cell_x_y_MV1_x(cell_x177_a24__blank_,
+ cell_x177_d24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_a24__blank_,
+ cell_x177_e24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_b24__blank_,
+ cell_x177_c32__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_b24__blank_,
+ cell_x177_c32__blank_) and EQ___cell_x_y_MV1_x(cell_x177_b24__blank_,
+ cell_x177_d24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_b24__blank_,
+ cell_x177_e24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_c32__blank_,
+ cell_x177_d24__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_c32__blank_,
+ cell_x177_d24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_c32__blank_,
+ cell_x177_e24__blank_) and EQ___cell_x_y_MV1_x(cell_x177_d24__blank_,
+ cell_x177_e24__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x177_d24__blank_,
+ cell_x177_e24__blank_)) or
+ ex cell_x188_e26__blank_, cell_x188_d26__blank_, cell_x188_c34__blank_,
+ cell_x188_b26__blank_, cell_x188_a26__blank_
+ (cell_x_y_o(cell_x188_a26__blank_) and
+ cell_x_y_o(cell_x188_b26__blank_) and
+ cell_x_y_o(cell_x188_c34__blank_) and
+ cell_x_y_o(cell_x188_d26__blank_) and
+ cell_x_y_o(cell_x188_e26__blank_) and
+ EQ___cell_x_y_MV1_x(cell_x188_a26__blank_, cell_x188_b26__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_a26__blank_,
+ cell_x188_b26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_a26__blank_,
+ cell_x188_c34__blank_) and EQ___cell_x_y_MV1_x(cell_x188_a26__blank_,
+ cell_x188_d26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_a26__blank_,
+ cell_x188_e26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_b26__blank_,
+ cell_x188_c34__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_b26__blank_,
+ cell_x188_c34__blank_) and EQ___cell_x_y_MV1_x(cell_x188_b26__blank_,
+ cell_x188_d26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_b26__blank_,
+ cell_x188_e26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_c34__blank_,
+ cell_x188_d26__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_c34__blank_,
+ cell_x188_d26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_c34__blank_,
+ cell_x188_e26__blank_) and EQ___cell_x_y_MV1_x(cell_x188_d26__blank_,
+ cell_x188_e26__blank_) and
+ nextcol__cell_x_y_MV1_y__cell_x_y_MV1_y(cell_x188_d26__blank_,
+ cell_x188_e26__blank_)))
LOC 0 {
PLAYER x {
Modified: trunk/Toss/GGP/tests/connect5-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-simpl.toss 2011-05-01 23:21:01 UTC (rev 1429)
+++ trunk/Toss/GGP/tests/connect5-simpl.toss 2011-05-02 12:07:27 UTC (rev 1430)
@@ -21,8 +21,8 @@
]
emb cell_x_y_b, cell_x_y_o, cell_x_y_x, control_o, control_x
pre
- (ex cell_x199_y200__blank_ cell_x_y_b(cell_x199_y200__blank_) and
- not
+ not
+ (not ex cell_x199_y200__blank_ cell_x_y_b(cell_x199_y200__blank_) or
ex cell_x182_y183__blank_, cell_x181_y182__blank_,
cell_x180_y181__blank_, cell_x179_y180__blank_, cell_x178_y179__blank_
(R(cell_x179_y180__blank_, cell_x178_y179__blank_) and
@@ -33,8 +33,7 @@
cell_x_y_x(cell_x179_y180__blank_) and
cell_x_y_x(cell_x180_y181__blank_) and
cell_x_y_x(cell_x181_y182__blank_) and
- cell_x_y_x(cell_x182_y183__blank_)) and
- not
+ cell_x_y_x(cell_x182_y183__blank_)) or
ex cell_x187_y188__blank_, cell_x186_y187__blank_,
cell_x185_y186__blank_, cell_x184_y185__blank_, cell_x183_y184__blank_
(R0(cell_x184_y185__blank_, cell_x183_y184__blank_) and
@@ -45,8 +44,7 @@
cell_x_y_x(cell_x184_y185__blank_) and
cell_x_y_x(cell_x185_y186__blank_) and
cell_x_y_x(cell_x186_y187__blank_) and
-...
[truncated message content] |
|
From: <luk...@us...> - 2011-05-01 23:21:10
|
Revision: 1429
http://toss.svn.sourceforge.net/toss/?rev=1429&view=rev
Author: lukaszkaiser
Date: 2011-05-01 23:21:01 +0000 (Sun, 01 May 2011)
Log Message:
-----------
Finishing adding fixed-points to formulas, cleanups in FormulaOps and related corrections.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FFTNF.ml
trunk/Toss/Formula/FFTNFTest.ml
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/Makefile
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Solver/ClassTest.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Arena/Arena.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -495,11 +495,9 @@
"At location %d, only the second game has label %s->%d"
i label.rule dest));
let poff1 =
- FormulaOps.map_to_formulas_expr FormulaOps.flatten_formula
- loc1.payoff in
+ FormulaOps.map_to_formulas_expr Formula.flatten loc1.payoff in
let poff2 =
- FormulaOps.map_to_formulas_expr FormulaOps.flatten_formula
- loc2.payoff in
+ FormulaOps.map_to_formulas_expr Formula.flatten loc2.payoff in
if poff1 <> poff2 then raise (Diff_result (
Printf.sprintf
"At location %d, payffs for player %d differ:\n%s\nvs.\n%s"
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -880,7 +880,7 @@
lhs_neg_tups @
List.map (function [x;y] -> Not (Eq (`FO x, `FO y))
| _ -> assert false) lhs_alldif_tups @
- FormulaOps.flatten_ands precond
+ (FormulaOps.as_conjuncts precond)
) in
(* Substitute defined relations, expanding their special variants. *)
@@ -1026,7 +1026,7 @@
);
(* }}} *)
let conjs =
- FormulaOps.flatten_ands (FormulaOps.remove_redundant precond) in
+ FormulaOps.as_conjuncts (FormulaOps.remove_redundant precond) in
let posi, conjs = Aux.partition_map (function
| Formula.Rel (rel, args) when rewritable args ->
Left (rel,args)
@@ -1253,8 +1253,8 @@
Structure.compare_diff ~cmp_funs r1.rhs_struc r2.rhs_struc in
if not eq then raise (Diff_result (
"Rule RHS structures differ: "^msg));
- let pre1 = FormulaOps.flatten_formula r1.pre in
- let pre2 = FormulaOps.flatten_formula r2.pre in
+ let pre1 = Formula.flatten r1.pre in
+ let pre2 = Formula.flatten r2.pre in
if pre1 <> pre2 then raise (Diff_result (
Printf.sprintf "Rule preconditions differ:\n%s\n =/=\n%s"
(Formula.sprint pre1) (Formula.sprint pre2)));
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -82,7 +82,7 @@
"(R(n) & (exists M m. R(m)))";
test_mod_subst "R(m) & ex M m (R(m) | R(n))" [("m", "n")]
"(R(n) & (exists M m. (R(m) | R(n))))";
- test_mod_subst "ex M m R(x)" [("x", "m")] "(exists M m0. R(m))";
+ test_mod_subst "ex M m R(x, m)" [("x", "m")] "(exists M m0. R(m, m0))";
test_mod_subst "R(m) & ex M m (S(m) | T(x))" [("x", "m"); ("m", "x")]
"(R(x) & (exists M m0. (S(m0) | T(m))))";
);
Modified: trunk/Toss/Formula/FFTNF.ml
===================================================================
--- trunk/Toss/Formula/FFTNF.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Formula/FFTNF.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -197,32 +197,28 @@
let rec nnf ?(neg=false) psi =
match psi with
- Rel _ | Eq _ | In _ | RealExpr _ as atom ->
- if neg then Not atom else atom
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ | Lfp _ | Gfp _ as atom ->
+ if neg then Not atom else atom
| Not phi -> if neg then nnf ~neg:false phi else nnf ~neg:true phi
| And (flist) when neg -> Or (List.map (nnf ~neg:true) flist)
| And (flist) -> And (List.map (nnf ~neg:false) flist)
| Or (flist) when neg -> And (List.map (nnf ~neg:true) flist)
| Or (flist) -> Or (List.map (nnf ~neg:false) flist)
- | Ex (x, _) as phi when neg && FormulaOps.free_vars phi = []
- -> Not (pn_nnf phi)
+ | Ex (x, _) as phi when neg && FormulaOps.free_vars phi = [] ->
+ Not (pn_nnf phi)
| Ex (x, phi) when neg -> All (x, nnf ~neg:true phi)
| Ex (x, phi) -> Ex (x, nnf ~neg:false phi)
| All (x, phi) when neg -> Ex (x, nnf ~neg:true phi)
- | All (x, phi) as sbt when not neg && FormulaOps.free_vars sbt = []
- -> Not (pn_nnf (Ex (x, nnf ~neg:true phi)))
+ | All (x, phi) as sbt when not neg && FormulaOps.free_vars sbt = [] ->
+ Not (pn_nnf (Ex (x, nnf ~neg:true phi)))
| All (x, phi) -> All (x, nnf ~neg:false phi)
and pn_nnf phi =
let rec pnf ex vars sb = function
- | (Rel _
- | Eq _
- | In _
- | RealExpr _) as psi ->
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ | Lfp _ | Gfp _ as psi ->
[], vars, FormulaOps.subst_vars sb psi
- | Not (Ex _) as phi -> [], vars, phi
- (* already processed recursively *)
- | Not psi as phi -> (* already reduced to NNF *)
+ | Not (Ex _) as phi -> [], vars, phi (* already processed recursively *)
+ | Not psi as phi -> (* already reduced to NNF *)
[], vars, FormulaOps.subst_vars sb phi
| And conjs ->
let (prefs, vars, conjs) =
@@ -454,14 +450,16 @@
(* Useful for debugging. *)
let rec unpack_flat = function
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as atom -> atom
+ | Not phi -> Not (unpack_flat phi)
| Or [phi] -> Or [Rel ("NOOP", [||]); unpack_flat phi]
| And [phi] -> And [Rel ("NOOP", [||]); unpack_flat phi]
| Or fl -> Or (List.map unpack_flat fl)
| And fl -> And (List.map unpack_flat fl)
| All (vs, phi) -> All (vs, unpack_flat phi)
| Ex (vs, phi) -> Ex (vs, unpack_flat phi)
- | Not phi -> Not (unpack_flat phi)
- | (Rel _ | Eq _ | In _ | RealExpr _) as atom -> atom
+ | Lfp (v, vs, phi) -> Lfp (v, vs, unpack_flat phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, unpack_flat phi)
let location_str loc =
sprintf "%s#[%s]"
@@ -559,18 +557,17 @@
| phi -> res, phi in
let revpref, phi =
prefix Top (p_pn_nnf ~do_pnf phi) in
- let phi = FormulaOps.flatten_formula phi in
+ let phi = Formula.flatten phi in
let protected lit qvs =
let lit_vs = FormulaOps.all_vars lit in
List.for_all (fun v->List.mem v lit_vs) qvs in
let rec to_tree last_qvs = function
| Not (Ex _ as phi) -> (* assumes [phi] is ground! *)
{fvs=Vars.empty; t=TNot_subtask phi}
- | (Rel _ | Eq _ | In _ | RealExpr _ | Not _) as lit
+ | (Rel _ | Eq _ | In _ | SO _ | RealExpr _ | Not _ | Lfp _ | Gfp _) as lit
when not do_pnf && protected lit last_qvs ->
{fvs=vars_of_list (FormulaOps.all_vars lit); t=TProc (0,lit)}
-
- | (Rel _ | Eq _ | In _ | RealExpr _ | Not _) as lit ->
+ | (Rel _ | Eq _ | In _ | SO _ | RealExpr _ | Not _ | Lfp _ | Gfp _) as lit->
{fvs=vars_of_list (FormulaOps.all_vars lit); t=TLit lit}
| And conjs ->
List.fold_right (fun conj -> function {fvs=vs; t=TAnd conjs} ->
@@ -927,7 +924,7 @@
match force_parsimony with
| Some parl -> parl
| None ->
- let size = FormulaOps.size phi in
+ let size = Formula.size phi in
if size < !parsimony_threshold_1 then 0
else if size < !parsimony_threshold_2 then 1
else 2 in
@@ -1108,11 +1105,11 @@
aux neg (add_vars vs evs) phi
| All (vs, phi) when neg ->
aux neg (add_vars vs evs) phi
- | Ex _ | All _ | Or [] | And [] -> evs
+ | Ex _ | All _ | Lfp _ | Gfp _ | Or [] | And [] -> evs
| Not phi -> aux (not neg) evs phi
| Or (phi::js) | And (phi::js) ->
aux neg (aux neg evs phi) (And js)
- | Rel _ | RealExpr _ | Eq _ | In _ -> evs in
+ | Rel _ | RealExpr _ | Eq _ | In _ | SO _ -> evs in
let evs = aux false Vars.empty phi in
let fevs = add_vars fvs evs in
let is_active neg rel vs =
@@ -1123,8 +1120,9 @@
| Rel (rel, vs) -> is_active neg rel (Formula.var_tup vs)
| Not phi -> has_active (not neg) phi
| And js | Or js -> List.exists (has_active neg) js
- | Ex (_, phi) | All (_, phi) -> has_active neg phi
- | Eq _ | In _ | RealExpr _ -> false in
+ | Ex (_, phi) | All (_, phi) | Lfp (_, _, phi) | Gfp (_, _, phi) ->
+ has_active neg phi
+ | Eq _ | In _ | RealExpr _ | SO _ -> false in
let rec build neg phi =
if not (has_active neg phi) then
{fvs=vars_of_list (FormulaOps.free_vars phi);
@@ -1159,7 +1157,7 @@
let t = if neg then TAnd js else TOr js in
{fvs=List.fold_left (fun fvs jt -> Vars.union fvs jt.fvs)
Vars.empty js; t=t}
- | RealExpr _ | In _ | Eq _ -> assert false
+ | RealExpr _ | In _ | Eq _ | SO _ | Lfp _ | Gfp _ -> assert false
and build_and neg phi =
match build neg phi with
| {t=TAnd js} when not neg -> js
@@ -1309,6 +1307,6 @@
let avs = FormulaOps.free_vars (And atoms) in
let avs = List.map Formula.to_fo
(List.filter (fun v->not (List.mem v fvs)) avs) in
- avs, unique (=) atoms, FormulaOps.flatten_formula
+ avs, unique (=) atoms, Formula.flatten
(erase_qs false (formula_of_tree tree))) forest
Modified: trunk/Toss/Formula/FFTNFTest.ml
===================================================================
--- trunk/Toss/Formula/FFTNFTest.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Formula/FFTNFTest.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -259,7 +259,7 @@
(* TODO? simplify the result *)
assert_eq_str ~msg:"#3"
- "ex y (C(y, z) and R(x, y)) or ex z (Q(z) and ex y true) or ex x (P(x) and ex y R(x, y))"
+ "ex y (C(y, z) and R(x, y)) or ex z (Q(z) and true) or ex x (P(x) and ex y R(x, y))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -430,27 +430,84 @@
| `Real s -> `Real (subst_str s)
let fo_var_subst subst (v : fo_var) = to_fo (var_subst subst v)
+let fp_var_subst s (v : [ mso_var | so_var ]) = to_mso_or_so (var_subst s v)
+(* Find a substitution for [v] which avoids [avs], string arguments *)
+let subst_name_avoiding_str avs var_s =
+ (* Helper: strip digits from string end if it doesn't start with one.*)
+ let rec strip_digits s =
+ if Aux.is_digit s.[0] then s else
+ let len = String.length s in
+ if Aux.is_digit s.[len-1] then
+ strip_digits (String.sub s 0 (len-1))
+ else s in
+ let v = strip_digits var_s in
+ let rec asubst i =
+ let vi = v ^ (string_of_int i) in
+ if not (List.mem vi avs) then (var_s, vi) else asubst (i+1) in
+ if List.mem var_s avs then asubst 0 else (var_s, var_s)
+
+(* Find a substitution for [v] which avoids [avs]. *)
+let subst_name_avoiding avoidv var =
+ subst_name_avoiding_str (List.rev_map var_str avoidv) (var_str var)
+
(* Apply substitution [subst] to all free variables in the given
formula. Preserves order of subformulas. *)
-let rec subst_vars subst = function
- | Rel (rn, vs) -> Rel (rn, Array.map (fo_var_subst subst) vs)
- | Eq (x, y) -> Eq (fo_var_subst subst x, fo_var_subst subst y)
- | In (x, y) -> In (fo_var_subst subst x, to_mso (var_subst subst y))
- | SO (v, vs) ->
- SO (to_so (var_subst subst v), Array.map (fo_var_subst subst) vs)
- | RealExpr (r, sgn) -> RealExpr (subst_vars_expr subst r, sgn)
- | Not phi -> Not (subst_vars subst phi)
- | Or flist -> Or (List.map (subst_vars subst) flist)
- | And flist -> And (List.map (subst_vars subst) flist)
- | Ex (vs, phi) ->
- let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
- let new_vs = List.filter (fun x -> not (in_vs x)) subst in
- if new_vs = [] then Ex (vs, phi) else Ex (vs, subst_vars new_vs phi)
- | All (vs, phi) ->
- let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
- let new_vs = List.filter (fun x -> not (in_vs x)) subst in
- if new_vs = [] then All (vs, phi) else All (vs, subst_vars new_vs phi)
+let rec subst_vars subst phi =
+ let splitvs sub vars =
+ let vs = List.rev_map (fun v -> var_str v) vars in
+ let new_sub = List.filter (fun (v, _) -> not (List.mem v vs)) sub in
+ let in_new_sub v = List.exists (fun (_, new_v) -> v = new_v) new_sub in
+ (List.partition (fun v -> in_new_sub (var_str v)) vars, new_sub) in
+ let newnames sub vars =
+ let aviodvs = List.map snd sub in
+ let new_n v = snd (subst_name_avoiding_str aviodvs (var_str v)) in
+ let new_vsub v = let n = new_n v in (var_of_string n, (var_str v, n)) in
+ List.split (List.map new_vsub vars) in
+ match phi with
+ | Rel (rn, vs) -> Rel (rn, Array.map (fo_var_subst subst) vs)
+ | Eq (x, y) -> Eq (fo_var_subst subst x, fo_var_subst subst y)
+ | In (x, y) -> In (fo_var_subst subst x, to_mso (var_subst subst y))
+ | SO (v, vs) ->
+ SO (to_so (var_subst subst v), Array.map (fo_var_subst subst) vs)
+ | RealExpr (r, sgn) -> RealExpr (subst_vars_expr subst r, sgn)
+ | Not phi -> Not (subst_vars subst phi)
+ | Or flist -> Or (List.map (subst_vars subst) flist)
+ | And flist -> And (List.map (subst_vars subst) flist)
+ | Ex (vs, phi) ->
+ let ((bad_vs, ok_vs), new_subst) = splitvs subst vs in
+ if new_subst = [] then Ex (vs, phi) else if bad_vs = [] then
+ Ex (vs, subst_vars new_subst phi)
+ else
+ let (new_bad, bad_subst) = newnames new_subst bad_vs in
+ Ex (new_bad @ ok_vs, subst_vars (bad_subst @ new_subst) phi)
+ | All (vs, phi) ->
+ let ((bad_vs, ok_vs), new_subst) = splitvs subst vs in
+ if new_subst = [] then Ex (vs, phi) else if bad_vs = [] then
+ All (vs, subst_vars new_subst phi)
+ else
+ let (new_bad, bad_subst) = newnames new_subst bad_vs in
+ All (new_bad @ ok_vs, subst_vars (bad_subst @ new_subst) phi)
+ | Lfp (v, vs, phi) ->
+ let ((bad_vs,ok_vs),new_subst) =
+ splitvs subst ((v :> var) :: ((Array.to_list vs) :> var list)) in
+ if new_subst = [] then Lfp (v, vs, phi) else if bad_vs = [] then
+ Lfp (v, vs, subst_vars new_subst phi)
+ else
+ let (_, bad_subst) = newnames new_subst bad_vs in
+ let nvs = Array.map (fo_var_subst bad_subst) vs in
+ Lfp (fp_var_subst bad_subst v, nvs,
+ subst_vars (bad_subst @ new_subst) phi)
+ | Gfp (v, vs, phi) ->
+ let ((bad_vs,ok_vs),new_subst) =
+ splitvs subst ((v :> var) :: ((Array.to_list vs) :> var list)) in
+ if new_subst = [] then Gfp (v, vs, phi) else if bad_vs = [] then
+ Gfp (v, vs, subst_vars new_subst phi)
+ else
+ let (_, bad_subst) = newnames new_subst bad_vs in
+ let nvs = Array.map (fo_var_subst bad_subst) vs in
+ Gfp (fp_var_subst bad_subst v, nvs,
+ subst_vars (bad_subst @ new_subst) phi)
and subst_vars_expr subst = function
| Const _ as x -> x
@@ -465,65 +522,19 @@
if new_vs = [] then Sum(vs, phi, r) else
Sum(vs, subst_vars new_vs phi, subst_vars_expr new_vs r)
-(* Helper function: strip digits from string end except if it starts with one.*)
-let rec strip_digits s =
- if Aux.is_digit s.[0] then s else
- let len = String.length s in
- if Aux.is_digit s.[len-1] then
- strip_digits (String.sub s 0 (len-1))
- else s
-(* Find a substitution for [v] which avoids [avs]. *)
-let subst_name_avoiding avoidv var =
- let (avs, v) = (List.rev_map var_str avoidv, strip_digits (var_str var)) in
- let rec asubst i =
- let vi = v ^ (string_of_int i) in
- if not (List.mem vi avs) then (var_str var, vi) else asubst (i+1) in
- if List.mem v avs then asubst 0 else (var_str var, v)
-
-(** Rename quantified variables avoiding the ones from [avs],
- and the above-quantified ones. Does not go into real_expr. *)
-let rec rename_quant_avoiding avs = function
- | Rel _ | Eq _ | In _ | RealExpr _ as x -> x
- | Not phi -> Not (rename_quant_avoiding avs phi)
- | Or flist -> Or (List.map (rename_quant_avoiding avs) flist)
- | And flist -> And (List.map (rename_quant_avoiding avs) flist)
- | Ex (vs, phi) ->
- let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
- if avoidv = [] then Ex (vs, rename_quant_avoiding (avs @ vs) phi) else
- let subst = List.map (subst_name_avoiding avs) avoidv in
- let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
- Ex (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
- | All (vs, phi) ->
- let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
- if avoidv = [] then All (vs, rename_quant_avoiding (avs @ vs) phi) else
- let subst = List.map (subst_name_avoiding avs) avoidv in
- let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
- All (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
-
-(* Apply substitution [subst] to all free variables in the given formula
- checking for and preventing name clashes with quantified variables. *)
-let subst_vars_check subst phi =
- let nvars = List.map (fun (_, nv) -> var_of_string nv) subst in
- let avoidvars = List.rev_append (free_vars phi) nvars in
- subst_vars subst (rename_quant_avoiding avoidvars phi)
-
-let subst_vars_nocheck subst phi = subst_vars subst phi
-let subst_vars subst phi = subst_vars_check subst phi
-
-
(* --------------------------- TRANSITIVE CLOSURE --------------------------- *)
(* We construct transitive closure of phi(x, y, z) over x, y as
"all X (x in X and (all x',y'
(x' in X and phi(x',y',z)-> y' in X)) -> y in X)" *)
-let make_tc x y phi =
+let make_mso_tc x y phi =
let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in
let (_, nx) = subst_name_avoiding fv xv in
let (_, ny) = subst_name_avoiding fv yv in
let (nxv, nyv) = (fo_var_of_string nx, fo_var_of_string ny) in
let frX = mso_var_of_string(snd(subst_name_avoiding fv(var_of_string "X"))) in
- let nphi = subst_vars_check [(x, nx); (y, ny)] phi in
+ let nphi = subst_vars [(x, nx); (y, ny)] phi in
let impphi = Or [Not (And [In (nxv, frX); nphi]); In (nyv, frX)] in
let inphi = And [In (xv, frX); All (([nxv; nyv] :> var list), impphi)] in
All ([(frX :> var)], Or [Not inphi; In (yv, frX)])
@@ -537,18 +548,18 @@
let (phi1, phi2) =
(make_fo_tc_conj k1 x y phi, make_fo_tc_conj k2 x y phi) in
let (phi1s, phi2s) =
- (subst_vars_check [(y,t)] phi1, subst_vars_check [(x,t)] phi2) in
+ (subst_vars [(y,t)] phi1, subst_vars [(x,t)] phi2) in
Ex ([var_of_string t], And [phi1s; phi2s])
(* First-order [k]-step refl. transitive closure of [phi], disjunctive form. *)
let make_fo_tc_disj k x y phi =
let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in
let (_, t) = subst_name_avoiding fv (var_of_string "t") in
- let phi_t = subst_vars_check [(y,t)] phi in
+ let phi_t = subst_vars [(y,t)] phi in
let rec k_step i =
if i = 0 then [Eq (xv, yv)] else if i = 1 then phi::[Eq (xv, yv)] else
let lst = k_step (i-1) in
- let psi = subst_vars_check [(x,t)] (List.hd lst) in
+ let psi = subst_vars [(x,t)] (List.hd lst) in
Ex ([var_of_string t], And [phi_t; psi]) :: lst in
Or (List.rev (k_step k))
@@ -562,8 +573,6 @@
try
let (dvs, dphi) = List.assoc rn defs in
let ovs = List.map var_str (Array.to_list vs) in
- (* not needed any more: let newdphi =
- rename_quant_avoiding ((Array.to_list vs) :> var list) dphi in *)
subst_vars (List.combine dvs ovs) dphi
with Not_found -> Rel (rn, vs) )
| x -> x
@@ -587,154 +596,124 @@
else
fp_n print (n-1) f nx
-(* Substitute recursively in [phi] relations defined in [defs] by their definitions. *)
+(* Substitute recursively in [phi] relations defined in [defs]. *)
let subst_rels defs phi =
fp_n str (List.length defs) (subst_once_rels defs) phi
-(* Substitute recursively in [r] relations defined in [defs] by their definitions. *)
+(* Substitute recursively in [r] relations defined in [defs]. *)
let subst_rels_expr defs r =
fp_n real_str (List.length defs) (subst_once_rels_expr defs) r
-(* ------------------------ CNF TO DNF USING SAT --------------------------- *)
-
-(* Given a list of list of formulas interpreted as CNF, convert to DNF. *)
-(*let convert ll =
- let (ids, rev_ids, free_id) = (Hashtbl.create 7, Hashtbl.create 7, ref 1) in
- let rec get_id ?(pos=true) = function
- Not (phi) -> get_id ~pos:(not pos) phi
- (* TODO: we could check also: all x not R(x) = not ex x R(x)!*)
- | phi ->
- try
- let id = Hashtbl.find ids phi in if pos then id else -1 * id
- with Not_found ->
- if !debug_level_cnf > 2 then
- print_endline ("Added " ^ (str phi) ^ " as " ^ (string_of_int !free_id));
- Hashtbl.add ids phi (!free_id);
- Hashtbl.add rev_ids (!free_id) phi;
- Hashtbl.add rev_ids (-1 * !free_id) (Not phi);
- free_id := !free_id + 1;
- if pos then !free_id - 1 else -1 * (!free_id - 1) in
- let append_formula l i =
- try (* SAT DNF conversion might generate new literals. *)
- (Hashtbl.find rev_ids i) :: l
- with Not_found -> l in (* It is safe to skip such literals. *)
- let cnf = List.rev_map (fun l -> List.rev_map get_id l) ll in
- let dnf = Sat.convert cnf in
- List.rev_map (fun l -> List.fold_left append_formula [] l) dnf
-*)
-
-(* Given a CNF formula as list of lists, return negation as DNF (and dually). *)
-let negate_sort ll =
- let neg_formula = function Not phi -> phi | phi -> Not phi in
- let neg l = List.sort compare (List.rev_map neg_formula l) in
- List.rev_map neg ll
-
-(* Given a list or lists, e.g. a disjunction of DNFs, flatten it to DNF. *)
-let rec tail_flatten ?(acc=[]) = function
- [] -> acc
- | ls :: rest -> tail_flatten ~acc:(List.rev_append ls acc) rest
-
-
(* ------------------------------------------------------------------------- *)
(* Prenex normal form. *)
(* ------------------------------------------------------------------------- *)
let mk_and phis = And phis and mk_or phis = Or phis
-and mk_forall (xs,phi) = All(xs,phi) and mk_exists (xs, phi) = Ex(xs,phi);;
+and mk_forall (xs,phi) = All(xs,phi) and mk_exists (xs, phi) = Ex(xs,phi)
let rec variant x vars =
- if List.mem x vars then variant (var_of_string ((var_str x)^"_")) vars else x;;
+ if List.mem x vars then variant (var_of_string ((var_str x)^"_")) vars else x
-(* Determine if a list of formulas contains an Ex (x, ..) such that x does not occur elsewhere. *)
+(* Determine if a list of formulas contains an Ex (x, ..) such
+ that x does not occur elsewhere. *)
let rec movable_ex acc_phis acc_vars = function
- [] -> ([], None)
+ | [] -> ([], None)
| (Ex (vs, f) as phi) :: phis ->
- let othervs = List.rev_append acc_vars (all_vars (And phis)) in
- let singvs = List.filter (fun v -> not (List.mem v othervs)) vs in
- if singvs <> [] then
- (singvs, Some (vs, f, List.rev_append acc_phis phis))
- else
- movable_ex (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
+ let othervs = List.rev_append acc_vars (all_vars (And phis)) in
+ let singvs = List.filter (fun v -> not (List.mem v othervs)) vs in
+ if singvs <> [] then
+ (singvs, Some (vs, f, List.rev_append acc_phis phis))
+ else
+ movable_ex (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
| phi :: phis ->
- movable_ex (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
+ movable_ex (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
-(* Determine if a list of formulas contains an All (x, ..) such that x does not occur elsewhere. *)
+(* Determine if a list of formulas contains an All (x, ..) such
+ that x does not occur elsewhere. *)
let rec movable_all acc_phis acc_vars = function
- [] -> ([], None)
+ | [] -> ([], None)
| (All (vs, f) as phi) :: phis ->
- let othervs = List.rev_append acc_vars (all_vars (Or phis)) in
- let singvs = List.filter (fun v -> not (List.mem v othervs)) vs in
- if singvs <> [] then
- (singvs, Some (vs, f, List.rev_append acc_phis phis))
- else
- movable_all (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
+ let othervs = List.rev_append acc_vars (all_vars (Or phis)) in
+ let singvs = List.filter (fun v -> not (List.mem v othervs)) vs in
+ if singvs <> [] then
+ (singvs, Some (vs, f, List.rev_append acc_phis phis))
+ else
+ movable_all (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
| phi :: phis ->
- movable_all (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
+ movable_all (phi::acc_phis) (List.rev_append (all_vars phi) acc_vars) phis
let rec prenex = function
- Rel _ | Eq _ | In _ | RealExpr _ as atom -> atom
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as atom -> atom
| Not phi -> Not phi (* We assume NNF on input *)
| And (flist) -> (
- let pfl = List.rev_map prenex flist in
- match movable_ex [] [] pfl with
- (svs, Some (vs, f, fl)) ->
- let dvs = List.filter (fun v -> not (List.mem v svs)) vs in
- if dvs = [] then Ex (svs, prenex (And (f :: fl))) else
- Ex (svs, prenex (And (Ex (dvs, f) :: fl)))
- | _ ->
- let (alls, atoms) = List.partition (function All _ -> true | _ -> false) pfl in
- if alls <> [] then
- let append_split_alls (vl, fl) = function
- All (xs, f) -> (List.rev_append xs vl, f :: fl)
- | _ -> failwith "" in
- let (allvs, phis) = List.fold_left append_split_alls ([], []) alls in
- All (remove_dup_vars [] (List.sort compare_vars allvs),
- prenex (And (List.rev_append phis atoms)))
- else
- let (ex, noex) = List.partition (function Ex _ -> true | _ -> false) pfl in
- if (ex = []) then And (pfl) else (
- let vars = all_vars (And (List.rev_append (List.tl ex) noex)) in
- let new_ex = match List.hd ex with
- Ex (vs, f) ->
- let newvs = List.map (fun v -> variant v vars) vs in
- let subst = List.map2 (fun v w -> (var_str v, var_str w)) vs newvs in
- Ex (newvs, subst_vars subst f)
- | _ -> failwith "cex" in
- prenex (And (new_ex :: (List.rev_append (List.tl ex) noex)))
- )
- )
+ let pfl = List.rev_map prenex flist in
+ match movable_ex [] [] pfl with
+ (svs, Some (vs, f, fl)) ->
+ let dvs = List.filter (fun v -> not (List.mem v svs)) vs in
+ if dvs = [] then Ex (svs, prenex (And (f :: fl))) else
+ Ex (svs, prenex (And (Ex (dvs, f) :: fl)))
+ | _ ->
+ let (alls, atoms) =
+ List.partition (function All _ -> true | _ -> false) pfl in
+ if alls <> [] then
+ let append_split_alls (vl, fl) = function
+ | All (xs, f) -> (List.rev_append xs vl, f :: fl)
+ | _ -> failwith "" in
+ let (allvs, phis) = List.fold_left append_split_alls ([], []) alls in
+ All (remove_dup_vars [] (List.sort compare_vars allvs),
+ prenex (And (List.rev_append phis atoms)))
+ else
+ let (ex, noex) =
+ List.partition (function Ex _ -> true | _ -> false) pfl in
+ if (ex = []) then And (pfl) else (
+ let vars = all_vars (And (List.rev_append (List.tl ex) noex)) in
+ let new_ex = match List.hd ex with
+ | Ex (vs, f) ->
+ let newvs = List.map (fun v -> variant v vars) vs in
+ let subst = List.map2
+ (fun v w -> (var_str v, var_str w)) vs newvs in
+ Ex (newvs, subst_vars subst f)
+ | _ -> failwith "cex" in
+ prenex (And (new_ex :: (List.rev_append (List.tl ex) noex)))
+ )
+ )
| Or (flist) -> (
- let pfl = List.rev_map prenex flist in
- match movable_all [] [] pfl with
- (svs, Some (vs, f, fl)) ->
- let dvs = List.filter (fun v -> not (List.mem v svs)) vs in
- if dvs = [] then All (svs, prenex (Or (f :: fl))) else
- All (svs, prenex (Or (All (dvs, f) :: fl)))
- | _ ->
- let (exs, atoms) = List.partition (function Ex _ -> true | _ -> false) pfl in
- if exs <> [] then
- let append_split_exs (vl, fl) = function
- Ex (xs, f) -> (List.rev_append xs vl, f :: fl)
- | _ -> failwith "" in
- let (exvs, phis) = List.fold_left append_split_exs ([], []) exs in
- Ex (remove_dup_vars [] (List.sort compare_vars exvs),
- prenex (Or (List.rev_append phis atoms)))
- else
- let (all, noall) = List.partition (function All _ -> true | _ -> false) pfl in
- if (all = []) then Or (pfl) else (
- let vars = all_vars (Or (List.rev_append (List.tl all) noall)) in
- let new_all = match List.hd all with
- All (vs, f) ->
- let newvs = List.map (fun v -> variant v vars) vs in
- let subst = List.map2 (fun v w -> (var_str v, var_str w)) vs newvs in
- All (newvs, subst_vars subst f)
- | _ -> failwith "call" in
- prenex (Or (new_all :: (List.rev_append (List.tl all) noall)))
- )
- )
+ let pfl = List.rev_map prenex flist in
+ match movable_all [] [] pfl with
+ (svs, Some (vs, f, fl)) ->
+ let dvs = List.filter (fun v -> not (List.mem v svs)) vs in
+ if dvs = [] then All (svs, prenex (Or (f :: fl))) else
+ All (svs, prenex (Or (All (dvs, f) :: fl)))
+ | _ ->
+ let (exs, atoms) =
+ List.partition (function Ex _ -> true | _ -> false) pfl in
+ if exs <> [] then
+ let append_split_exs (vl, fl) = function
+ | Ex (xs, f) -> (List.rev_append xs vl, f :: fl)
+ | _ -> failwith "" in
+ let (exvs, phis) = List.fold_left append_split_exs ([], []) exs in
+ Ex (remove_dup_vars [] (List.sort compare_vars exvs),
+ prenex (Or (List.rev_append phis atoms)))
+ else
+ let (all, noall) =
+ List.partition (function All _ -> true | _ -> false) pfl in
+ if (all = []) then Or (pfl) else (
+ let vars = all_vars (Or (List.rev_append (List.tl all) noall)) in
+ let new_all = match List.hd all with
+ | All (vs, f) ->
+ let newvs = List.map (fun v -> variant v vars) vs in
+ let subst = List.map2
+ (fun v w -> (var_str v, var_str w)) vs newvs in
+ All (newvs, subst_vars subst f)
+ | _ -> failwith "call" in
+ prenex (Or (new_all :: (List.rev_append (List.tl all) noall)))
+ )
+ )
| Ex (xs, phi) -> Ex (xs, prenex phi)
| All (xs, phi) -> All (xs, prenex phi)
+ | Lfp (v, vs, phi) -> Lfp (v, vs, prenex phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, prenex phi)
let pnf fm = prenex(nnf(fm))
@@ -766,7 +745,7 @@
let univ_subs atom (univ_atom, _) =
let usubs v uv = (v = uv) || (var_str uv = "u***") || (var_str uv = "U***") in
match (atom, univ_atom) with
- Rel (s, vl1), Rel (t, vl2) when s = t -> Aux.array_for_all2 usubs vl1 vl2
+ | Rel (s, vl1), Rel (t, vl2) when s = t -> Aux.array_for_all2 usubs vl1 vl2
| Eq (v1, w1), Eq (v2, w2) -> usubs v1 v2 && usubs w1 w2
| In (v1, w1), In (v2, w2) -> usubs v1 v2 && usubs w1 w2
| _ -> false
@@ -775,43 +754,45 @@
let concreter phi (conc_phi, _) =
if phi = conc_phi then true else match (phi, conc_phi) with
- (Or fl, Or cfl) -> List.for_all (fun f -> List.mem f fl) cfl
+ | (Or fl, Or cfl) -> List.for_all (fun f -> List.mem f fl) cfl
| _ -> false
(* Gather and propagate universally quantified atoms. *)
let rec propagate_univ acc_atoms acc_formulas = function
| phi when List.exists (concreter phi) acc_formulas ->
let (_, t) = List.find (concreter phi) acc_formulas in t
- | Rel _ | Eq _ | In _ | RealExpr _ as atom -> (
- try
- let (_, t) = List.find (univ_subs atom) acc_atoms in t
- with Not_found -> atom
- )
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as atom -> (
+ try
+ let (_, t) = List.find (univ_subs atom) acc_atoms in t
+ with Not_found -> atom
+ )
| Not phi -> Not (propagate_univ acc_atoms acc_formulas phi)
| Ex (vs, phi) -> Ex (vs, propagate_univ acc_atoms acc_formulas phi)
| All (vs, phi) -> All (vs, propagate_univ acc_atoms acc_formulas phi)
+ | Lfp (v, vs, phi) -> Lfp (v, vs, propagate_univ acc_atoms acc_formulas phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, propagate_univ acc_atoms acc_formulas phi)
| Or (fl) -> Or (List.map (propagate_univ acc_atoms acc_formulas) fl)
| And fl ->
- let pfl = List.rev_map (propagate_univ acc_atoms acc_formulas) fl in
- let (alls, oth) = List.partition (function All _ -> true | _ -> false) pfl in
- let (all_atoms, all_fs) = List.partition
- (function
- All (_, Not f) -> is_atom f
- | All (_, f) -> is_atom f
- | _ -> false ) alls in
- let append_univ_atom al = function
- All (vs, Not f) when is_atom f -> (sub_all vs f, Or []) :: al
- | All (vs, f) when is_atom f -> (sub_all vs f, And []) :: al
- | _ -> al in
- let acc_a = List.fold_left append_univ_atom acc_atoms all_atoms in
- let acc_fs = List.rev_append (List.map setall all_fs) acc_formulas in
- let pother = List.rev_map (propagate_univ acc_a acc_fs) oth in
- let (pallfs, _) =
- List.fold_left
- (fun (afs, acc_f) phi ->
- ((propagate_univ acc_a acc_f phi) :: afs, (setall phi) :: acc_f))
- ([], acc_formulas) (List.sort Formula.compare all_fs) in
- And (List.rev_append all_atoms (List.rev_append pallfs pother))
+ let pfl = List.rev_map (propagate_univ acc_atoms acc_formulas) fl in
+ let (alls, oth) = List.partition (function All _-> true | _-> false) pfl in
+ let (all_atoms, all_fs) = List.partition
+ (function
+ | All (_, Not f) -> is_atom f
+ | All (_, f) -> is_atom f
+ | _ -> false ) alls in
+ let append_univ_atom al = function
+ | All (vs, Not f) when is_atom f -> (sub_all vs f, Or []) :: al
+ | All (vs, f) when is_atom f -> (sub_all vs f, And []) :: al
+ | _ -> al in
+ let acc_a = List.fold_left append_univ_atom acc_atoms all_atoms in
+ let acc_fs = List.rev_append (List.map setall all_fs) acc_formulas in
+ let pother = List.rev_map (propagate_univ acc_a acc_fs) oth in
+ let (pallfs, _) =
+ List.fold_left
+ (fun (afs, acc_f) phi ->
+ ((propagate_univ acc_a acc_f phi) :: afs, (setall phi) :: acc_f))
+ ([], acc_formulas) (List.sort Formula.compare all_fs) in
+ And (List.rev_append all_atoms (List.rev_append pallfs pother))
let simp_prop_univ phi =
flatten_sort (propagate_univ [] [] (flatten_sort phi))
@@ -820,47 +801,52 @@
(* Recursively simplify a formula *)
let rec simplify ?(do_pnf=false) ?(do_re=true) ?(ni=0) phi =
let do_simplify phi =
- let (ids, rev_ids, free_id) = (Hashtbl.create 7, Hashtbl.create 7, ref 1) in
- let boolean_phi = BoolFormula.bool_formula_of_formula_arg phi (ids, rev_ids, free_id) in
+ let (ids, rev_ids, free_id) = (Hashtbl.create 7,Hashtbl.create 7,ref 1) in
+ let boolean_phi =
+ BoolFormula.bool_formula_of_formula_arg phi (ids, rev_ids, free_id) in
let simplified = BoolFormula.simplify boolean_phi in
- let simplified_phi = BoolFormula.formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
- (*print_endline("Simplified to: " ^ str simplified_phi);*)
- simplified_phi in
+ let simplified_phi = BoolFormula.formula_of_bool_formula_arg simplified
+ (ids, rev_ids, free_id) in simplified_phi in
let rec simplify_subformulas = function
- Rel _ | Eq _ | In _ as atom -> atom
+ | Rel _ | Eq _ | SO _ | In _ as atom -> atom
| RealExpr (re, sgn) as rx ->
if do_re then
RealExpr (simplify_re ~do_pnf ~do_formula:true ~ni re, sgn)
else rx
| Not psi -> do_simplify (Not (simplify_subformulas psi))
- | And (flist) -> do_simplify (And (List.rev_map simplify_subformulas flist))
- | Or (flist) -> do_simplify (Or (List.rev_map simplify_subformulas flist))
+ | And (flist) -> do_simplify (And (List.rev_map simplify_subformulas flist))
+ | Or (flist) -> do_simplify (Or (List.rev_map simplify_subformulas flist))
| Ex (x, psi) -> Ex (x, do_simplify (simplify_subformulas psi))
- | All (x, psi) -> All (x, do_simplify (simplify_subformulas psi)) in
+ | All (x, psi) -> All (x, do_simplify (simplify_subformulas psi))
+ | Lfp (x, xs, psi) -> Lfp (x, xs, do_simplify (simplify_subformulas psi))
+ | Gfp (x, xs, psi) -> Gfp (x, xs, do_simplify (simplify_subformulas psi)) in
let check_for_variants phi =
let vars = List.map var_str (all_vars phi) in
- List.exists (fun var -> var.[((String.length var)-1)]='_') vars in
+ List.exists (fun var -> var.[((String.length var)-1)]='_') vars in
let rec qfree_size = function
- All (xs, phi)
+ | All (xs, phi)
| Ex (xs, phi) -> qfree_size phi
| _ as phi -> Formula.size phi in
- let prenex_phi = if do_pnf then pnf (simp_prop_univ phi) else simp_prop_univ phi in
+ let prenex_phi =
+ if do_pnf then pnf (simp_prop_univ phi) else simp_prop_univ phi in
let prenex_size = qfree_size prenex_phi in
let simplified_prenex_phi = simplify_subformulas prenex_phi in
let simplified_size = qfree_size simplified_prenex_phi in
- if (check_for_variants simplified_prenex_phi) then (
- if !debug_level > 0 then (
- print_endline("Attention! Variants detected!");
- print_endline("Size: " ^ (string_of_int prenex_size) ^ " vs. " ^ (string_of_int simplified_size));
- print_endline(str prenex_phi ^ " vs. " ^ str simplified_prenex_phi);
- );
- if (simplified_size >= prenex_size) then (
- if !debug_level > 0 then print_endline ("Simplification of PNF not successful!");
- simplify_subformulas phi
- ) else
- simplified_prenex_phi
+ if (check_for_variants simplified_prenex_phi) then (
+ if !debug_level > 0 then (
+ print_endline("Attention! Variants detected!");
+ print_endline("Size: " ^ (string_of_int prenex_size) ^
+ " vs. " ^ (string_of_int simplified_size));
+ print_endline(str prenex_phi ^ " vs. " ^ str simplified_prenex_phi);
+ );
+ if (simplified_size >= prenex_size) then (
+ if !debug_level > 0 then
+ print_endline ("Simplification of PNF not successful!");
+ simplify_subformulas phi
) else
- simplified_prenex_phi
+ simplified_prenex_phi
+ ) else
+ simplified_prenex_phi
and simplify_re ?(do_pnf=false) ?(do_formula=true) ?(ni=0) = function
| RVar _ | Const _ | Fun _ as atom -> atom
@@ -928,66 +914,39 @@
simplify_re ~do_pnf ~do_formula ~ni (Times (simp_p, simp_q))
-(* Flatten "and"s and "or"s in a formula --
- i.e. associativity. Remove double negation along the way. *)
-let flatten_formula =
- let flat_and = function And conjs -> conjs | phi -> [phi] in
- let flat_or = function Or disjs -> disjs | phi -> [phi] in
- map_formula {identity_map with
- map_And = (function
- | [conj] -> conj
- | conjs -> And (Aux.concat_map flat_and conjs));
- map_Or = (function
- | [disj] -> disj
- | disjs -> Or (Aux.concat_map flat_or disjs));
- map_Not = (function
- | Or [] -> And []
- | And [] -> Or []
- | Not phi -> phi | phi -> Not phi)}
-
-let rec flatten_or = function
- | Or disjs -> Aux.concat_map flatten_or disjs
- | Not (Not phi) | Not (And [Not phi]) | Not (Or [Not phi]) ->
- flatten_or phi
- | phi -> [phi]
-
(* Formula as a list of conjuncts, with one level of distributing
negation over disjunction and pushing quantifiers inside. *)
-let rec flatten_ands = function
- | And conjs -> Aux.concat_map flatten_ands conjs
- | Or [phi] -> flatten_ands phi
- | Not (And [phi]) -> flatten_ands (Not phi)
- | Not (Or disjs) ->
- Aux.concat_map flatten_ands
- (List.map (fun d -> Not d)
- (Aux.concat_map flatten_or disjs))
- | All (vs, phi) ->
- List.map (fun phi -> All (vs, phi)) (flatten_ands phi)
- | Ex (vs, phi) as arg ->
- (match flatten_ands phi with
- | [] -> [] | [_] -> [arg]
- | conjs ->
- let free_conjs, bound_conjs = List.partition (fun conj ->
- Aux.list_inter vs (free_vars conj) = []) conjs in
- let bound_phi = match bound_conjs with
- | [phi] -> phi | _ -> And bound_conjs in
- free_conjs @ [Ex (vs, bound_phi)])
- | Not (Not phi) -> flatten_ands phi
- | phi -> [phi]
+let as_conjuncts phi =
+ let rec conjuncts = function
+ | And fl -> Aux.concat_map conjuncts fl
+ | All (vs, f) -> List.map (fun f -> All (vs, f)) (conjuncts f)
+ | Ex (vs, phi) ->
+ (match conjuncts phi with
+ | [] -> [] | [psi] -> [Ex (vs, psi)]
+ | conjs ->
+ let free_conjs, bound_conjs = List.partition (fun conj ->
+ Aux.list_inter vs (free_vars conj) = []) conjs in
+ let bound_phi = match bound_conjs with
+ | [phi] -> phi | _ -> And bound_conjs in
+ free_conjs @ [Ex (vs, bound_phi)])
+ | phi -> [phi] in
+ conjuncts (Formula.flatten_sort phi)
+
(* Currently, does not go down real expressions. *)
let remove_subformulas psub phi =
let rec map_formula subf =
if psub subf then raise Not_found;
match subf with
- | Rel _ | Eq _ | RealExpr _ | In _ -> subf
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ -> subf
| Not phi -> Not (map_formula phi)
| And conjs -> And (Aux.map_try map_formula conjs)
| Or disjs -> Or (Aux.map_try map_formula disjs)
| Ex (vs, phi) -> Ex (vs, map_formula phi)
- | All (vs, phi) -> All (vs, map_formula phi) in
- try flatten_formula (map_formula phi)
- with Not_found -> And []
+ | All (vs, phi) -> All (vs, map_formula phi)
+ | Lfp (v, vs, phi) -> Lfp (v, vs, map_formula phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, map_formula phi) in
+ try Formula.flatten (map_formula phi) with Not_found -> And []
let unused_quants_map = {identity_map with
map_Ex = (fun vs phi ->
@@ -1007,7 +966,6 @@
the removal till fixpoint since it can "unpack" literals e.g. from
conjunctions to disjunctions. Also perform a very basic check for
satisfiability of disjuncts.
-
TODO: traverse the real part too. *)
exception Unsatisfiable
(* [Unsatisfiable] does not escape the function -- [Or []] is
@@ -1126,6 +1084,8 @@
| Not phi -> Not (aux posbase negbase (not neg) phi)
| Ex (vs, phi) -> Ex (vs, aux posbase negbase neg phi)
| All (vs, phi) -> All (vs, aux posbase negbase neg phi)
+ | Lfp (v, vs, phi) -> Lfp (v, vs, aux posbase negbase neg phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, aux posbase negbase neg phi)
| phi -> phi in
let rec fixpoint phi =
@@ -1135,51 +1095,44 @@
(Formula.str phi)
);
(* }}} *)
- let res = aux [] [] false (flatten_formula phi) in
+ let res = aux [] [] false (Formula.flatten phi) in
if res = phi then res else fixpoint res in
try fixpoint phi
with Unsatisfiable -> Or []
-(* Compute size of a formula (currently w/o descending the real part). *)
-let rec size = function
- | Or js | And js -> List.fold_left (+) 1 (List.map size js)
- | All (_, phi) | Ex (_, phi) | Not phi -> size phi + 1
- | Rel _ | Eq _ | In _ | RealExpr _ -> 1
-
(* -------------------------- TYPE NORMAL FORM ----------------------------- *)
(* Check if [cl] is subsumed by [phi], i.e. if phi implies cl (partial). *)
let partial_subsumes cl phi =
if cl = phi then true else match cl with
- Or fl -> if List.mem phi fl then true else false
+ | Or fl -> if List.mem phi fl then true else false
| _ -> false
(* Append to [acc] new clauses from [cl]. *)
let rec append_clauses acc = function
- [] -> acc
+ | [] -> acc
| cl :: cls ->
if List.exists (partial_subsumes cl) acc then append_clauses acc cls else
append_clauses (cl :: acc) cls
(* Negate a boolean combination (do not go over quantifiers). *)
let rec neg_boolean = function
- And fl -> Or (List.rev_map neg_boolean fl)
+ | And fl -> Or (List.rev_map neg_boolean fl)
| Or fl -> And (List.rev_map neg_boolean fl)
| Not f -> f
| f -> Not f
(* Compute NNF but do not go over quantifiers. *)
-let rec bool_nnf ?(neg=false) psi =
- match psi with
- Not phi -> if neg then bool_nnf ~neg:false phi else bool_nnf ~neg:true phi
- | And [f] | Or [f] -> bool_nnf ~neg f
- | And (flist) when neg -> Or (List.rev_map (bool_nnf ~neg:true) flist)
- | And (flist) -> And (List.rev_map (bool_nnf ~neg:false) flist)
- | Or (flist) when neg -> And (List.rev_map (bool_nnf ~neg:true) flist)
- | Or (flist) -> Or (List.rev_map (bool_nnf ~neg:false) flist)
- | phi -> if neg then Not phi else phi
+let rec bool_nnf ?(neg=false) = function
+ | Not phi -> if neg then bool_nnf ~neg:false phi else bool_nnf ~neg:true phi
+ | And [f] | Or [f] -> bool_nnf ~neg f
+ | And (flist) when neg -> Or (List.rev_map (bool_nnf ~neg:true) flist)
+ | And (flist) -> And (List.rev_map (bool_nnf ~neg:false) flist)
+ | Or (flist) when neg -> And (List.rev_map (bool_nnf ~neg:true) flist)
+ | Or (flist) -> Or (List.rev_map (bool_nnf ~neg:false) flist)
+ | phi -> if neg then Not phi else phi
(* Convert an arbitrary boolean combination to CNF. *)
@@ -1208,8 +1161,6 @@
(* A bit hacky way to protect (by empty exists) parts of a boolean combination
in which all atoms already contain one of the variables [vs] as free. *)
let rec protect_full mlen vs = function
- Rel _ | Eq _ | In _ | RealExpr _ | Ex _ | All _ as phi ->
- if has_free vs phi then Ex ([], phi) else phi
| And fl when List.length fl < 2 || List.length fl > mlen ->
let pfl = List.rev_map (protect_full mlen vs) fl in
if List.for_all (function Ex ([], _) -> true | _ -> false) pfl then
@@ -1227,7 +1178,9 @@
)
| And fl -> And (List.rev_map (protect_full mlen vs) fl)
| Or fl -> Or (List.rev_map (protect_full mlen vs) fl)
+ | phi -> if has_free vs phi then Ex ([], phi) else phi
+
(* Protect parts which do not contain any of the variables [vs] at all. *)
let rec protect_empty mlen vs = function
And fl when List.length fl > mlen ->
@@ -1280,7 +1233,7 @@
in Ex (x, BC (tau's)) and All (x, BC (tau's))) it must hold that
the free variables of *each* of the tau's contain x. *)
let rec tnf_fun = function
- Rel _ | Eq _ | In _ as phi -> phi
+ | Rel _ | Eq _ | In _ | SO _ as phi -> phi
| RealExpr (re, sg) -> RealExpr (tnf_re_fun re, sg)
| Not phi -> Not (tnf_fun phi)
| Or flist -> Or (List.rev_map tnf_fun flist)
@@ -1288,38 +1241,42 @@
| Ex ([], phi) -> failwith "empty existential when computing TNF"
| Ex (xs, Or fl) -> Or (List.rev_map (fun f -> tnf_fun (Ex (xs, f))) fl)
| Ex ([x], phi) ->
- let protected_phi = protect [x] (tnf_fun phi) in
- if !debug_level_tnf > 0 then (
- print_endline ("TNF for (protected) "); print protected_phi; print_endline ("");
- );
- if !debug_level_tnf > 0 then print_endline ("TNF for var "^(var_str x));
- let unand = function And fl -> fl | psi -> [psi] in
- let conv_phi = List.rev_map unprotect (to_dnf protected_phi) in
- let dnf_phi = List.rev_map unand conv_phi in
- if !debug_level_tnf > 0 then print_endline ("TNF done: "^ (var_str x));
- Or (List.rev_map (append_quant [x] ~universal:false) dnf_phi)
+ let protected_phi = protect [x] (tnf_fun phi) in
+ if !debug_level_tnf > 0 then (
+ print_endline "TNF for (protected) ";
+ print protected_phi; print_endline "";
+ );
+ if !debug_level_tnf > 0 then print_endline ("TNF for var "^(var_str x));
+ let unand = function And fl -> fl | psi -> [psi] in
+ let conv_phi = List.rev_map unprotect (to_dnf protected_phi) in
+ let dnf_phi = List.rev_map unand conv_phi in
+ if !debug_level_tnf > 0 then print_endline ("TNF done: "^ (var_str x));
+ Or (List.rev_map (append_quant [x] ~universal:false) dnf_phi)
| Ex (vs, phi) ->
let (x, xs) = pick_var phi vs in
tnf_fun (Ex ([x], Ex (xs, phi)))
| All ([], phi) -> failwith "empty universal when computing TNF"
| All (xs, And fl) -> And (List.rev_map (fun f -> tnf_fun (All (xs, f))) fl)
| All ([x], phi) ->
- let protected_phi = protect [x] (tnf_fun phi) in
- if !debug_level_tnf > 0 then (
- print_endline ("TNF for (protected) "); print protected_phi; print_endline ("");
- );
- if !debug_level_tnf > 0 then print_endline ("TNF for var "^(var_str x));
- let unor = function Or fl -> fl | psi -> [psi] in
- let conv_phi = List.rev_map unprotect (to_cnf protected_phi) in
- let cnf_phi = List.rev_map unor conv_phi in
- if !debug_level_tnf > 0 then print_endline ("TNF done: " ^ (var_str x));
- And (List.rev_map (append_quant [x] ~universal:true) cnf_phi)
+ let protected_phi = protect [x] (tnf_fun phi) in
+ if !debug_level_tnf > 0 then (
+ print_endline "TNF for (protected) ";
+ print protected_phi; print_endline "";
+ );
+ if !debug_level_tnf > 0 then print_endline ("TNF for var "^(var_str x));
+ let unor = function Or fl -> fl | psi -> [psi] in
+ let conv_phi = List.rev_map unprotect (to_cnf protected_phi) in
+ let cnf_phi = List.rev_map unor conv_phi in
+ if !debug_level_tnf > 0 then print_endline ("TNF done: " ^ (var_str x));
+ And (List.rev_map (append_quant [x] ~universal:true) cnf_phi)
| All (vs, phi) ->
let (x, xs) = pick_var phi vs in
tnf_fun (All ([x], All (xs, phi)))
+ | Lfp (v, vs, phi) -> Lfp (v, vs, tnf_fun phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, tnf_fun phi)
and tnf_re_fun = function
- RVar _ | Const _ | Fun _ as x -> x
+ | RVar _ | Const _ | Fun _ as x -> x
| Times (re1, re2) -> Times (tnf_re_fun re1, tnf_re_fun re2)
| Plus (re1, re2) -> Plus (tnf_re_fun re1, tnf_re_fun re2)
| Char (phi) -> Char (flatten_sort (tnf_fun (flatten_sort phi)))
@@ -1331,7 +1288,7 @@
| [x] -> x
| lst -> if universal then Or lst else And lst in
match have_v with
- [] -> res no_v
+ | [] -> res no_v
| [phi] ->
let psi = if universal then All (vs, phi) else Ex (vs, phi) in
res (psi :: no_v)
@@ -1349,24 +1306,66 @@
if !debug_level_tnf > 0 then print_endline ("TNF re of " ^ (real_str re));
tnf_re_fun re
+(* ------------ TNF with variable pushing --------- *)
+(* Rename quantified variables avoiding the ones from [avs],
+ and the above-quantified ones. Does not go into real_expr. *)
+let rec rename_quant_avoiding avs = function
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as x -> x
+ | Not phi -> Not (rename_quant_avoiding avs phi)
+ | Or flist -> Or (List.map (rename_quant_avoiding avs) flist)
+ | And flist -> And (List.map (rename_quant_avoiding avs) flist)
+ | Ex (vs, phi) ->
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
+ if avoidv = [] then Ex (vs, rename_quant_avoiding (avs @ vs) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
+ Ex (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
+ | All (vs, phi) ->
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in
+ if avoidv = [] then All (vs, rename_quant_avoiding (avs @ vs) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in
+ All (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi))
+ | Lfp (v, vs, phi) ->
+ let vars = (v :> var) :: ((Array.to_list vs) :> var list) in
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
+ if avoidv=[] then Lfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nvs, nv = Array.map (fo_var_subst subst) vs, fp_var_subst subst v in
+ let nvars = (nv :> var) :: ((Array.to_list nvs) :> var list) in
+ Lfp (nv, nvs, rename_quant_avoiding (avs @ nvars) phi)
+ | Gfp (v, vs, phi) ->
+ let vars = (v :> var) :: ((Array.to_list vs) :> var list) in
+ let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vars in
+ if avoidv=[] then Gfp (v, vs, rename_quant_avoiding (avs @ vars) phi) else
+ let subst = List.map (subst_name_avoiding avs) avoidv in
+ let nvs, nv = Array.map (fo_var_subst subst) vs, fp_var_subst subst v in
+ let nvars = (nv :> var) :: ((Array.to_list nvs) :> var list) in
+ Gfp (nv, nvs, rename_quant_avoiding (avs @ nvars) phi)
+
+
let rec has_mso = function
| In _ -> true
- | Rel _ | Eq _ | RealExpr _ -> false
- | Not phi | Ex (_, phi) | All (_, phi) -> has_mso phi
+ | Rel _ | Eq _ | RealExpr _ | SO _ -> false
+ | Not phi | Ex (_, phi) | All (_, phi) | Lfp (_,_, phi) | Gfp (_,_, phi) ->
+ has_mso phi
| And flist | Or flist -> List.exists has_mso flist
let rec has_fo = function
| In _ -> false
- | Rel _ | Eq _ | RealExpr _ -> true
- | Not phi | Ex (_, phi) | All (_, phi) -> has_fo phi
+ | Rel _ | Eq _ | RealExpr _ | SO _ -> true
+ | Not phi | Ex (_, phi) | All (_, phi) | Lfp (_,_, phi) | Gfp (_,_, phi) ->
+ has_fo phi
| And flist | Or flist -> List.exists has_fo flist
let rec mso_last = function
- | Rel _ | Eq _ | In _ | RealExpr _ as phi -> phi
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ as phi -> phi
| Not phi -> Not (mso_last phi)
| Ex (vs, phi) -> Ex (vs, mso_last phi)
| All (vs, phi) -> All (vs, mso_last phi)
+ | Lfp (v, vs, phi) -> Lfp (v, vs, mso_last phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, mso_last phi)
| And flist ->
let (msos, fos) = List.partition has_mso (List.map mso_last flist) in
let (somefo, nofo) = List.partition has_fo msos in
@@ -1426,7 +1425,7 @@
let rec push_in_quant phi =
match phi with
- | In _ | Rel _ | Eq _ | RealExpr _ -> phi
+ | In _ | Rel _ | Eq _ | SO _ | RealExpr _ -> phi
| Not (Or fl) -> push_in_quant (And (List.map (fun f -> Not f) fl))
| Not (And fl) -> push_in_quant (Or (List.map (fun f -> Not f) fl))
| Not f -> Not (push_in_quant f)
@@ -1445,6 +1444,8 @@
push_in_quant (All ([List.hd vs], push_in_quant (All (List.tl vs,Or fl))))
| Ex (vs, f) -> Ex (vs, push_in_quant f)
| All (vs, f) -> All (vs, push_in_quant f)
+ | Lfp (v, vs, f) -> Lfp (v, vs, push_in_quant f)
+ | Gfp (v, vs, f) -> Gfp (v, vs, push_in_quant f)
let rec push_quant f = push_in_quant (flatten_sort (f))
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-05-01 23:21:01 UTC (rev 1429)
@@ -118,20 +118,18 @@
(** Apply substitution [subst] to all free variables in the given formula
checking for and preventing name clashes with quantified variables. *)
val subst_vars : (string * string) list -> formula -> formula
-val subst_vars_nocheck : (string * string) list -> formula -> formula
-(** Rename quantified variables avoiding the ones from [avs] list,
- and the above-quantified ones. Does not go into real_expr. *)
-val rename_quant_avoiding : var list -> formula -> formula
-
(** Substitute once relations in [defs] by corresponding subformulas
(with instantiated parameters). *)
-val subst_once_rels : (string * (string list * formula)) list -> formula -> formula
-val subst_once_rels_expr : (string * (string list * formula)) list -> real_expr -> real_expr
+val subst_once_rels :
+ (string * (string list * formula)) list -> formula -> formula
+val subst_once_rels_expr :
+ (string * (string list * formula)) list -> real_expr -> real_expr
(** Substitute recursively relations defined in [defs] by their definitions. *)
val subst_rels : (string * (string list * formula)) list -> formula -> formula
-val subst_rels_expr : (string * (string list * formula)) list -> real_expr -> real_expr
+val subst_rels_expr :
+ (string * (string list * formula)) list -> real_expr -> real_expr
(** Assign emptyset to an MSO-variable. *)
val assign_emptyset : string -> formula -> formula
@@ -140,7 +138,7 @@
(** {2 Transitive Closure} *)
(** Transitive closure of phi(x, y, z) over x and y, an MSO formula. *)
-val make_tc : string -> string -> formula -> formula
+val make_mso_tc : string -> string -> formula -> formula
(** First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *)
val make_fo_tc_conj : int -> string -> string -> formula -> formula
@@ -156,16 +154,12 @@
val simplify_re : ?do_pnf: bool -> ?do_formula: bool -> ?ni:int ->
real_expr -> real_expr
-
+(** Prenex normal form. *)
val pnf : formula -> formula
-(** Flatten "and"s and "or"s in a formula --
- i.e. associativity. Remove double negation along the way. *)
-val flatten_formula : formula -> formula
-
(** Formula as a list of conjuncts, with one level of distributing
negation over disjunction and pushing quantifiers inside. *)
-val flatten_ands : formula -> formula list
+val as_conjuncts : formula -> formula list
(** "Erase" indicated subformulas from the formula. *)
val remove_subformulas : (formula -> bool) -> formula -> formula
@@ -186,8 +180,6 @@
val remove_redundant :
?implies:(formula -> formula -> bool) -> formula -> formula
-(** Compute size of a formula (currently w/o descending the real part). *)
-val size : formula -> int
(** {2 TNF} *)
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-01 16:34:53 UTC (rev 1428)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-01 23:21:01 UTC (rev 1429)
@@ -135,17 +135,26 @@
"subst free and all" >::
(fun () ->
- let subst phi = FormulaOps.subst_vars [("x", "a"); ("y", "b")] phi in
- let subst_free_eq phi1 phi2 = formula_eq id phi2 subst phi1 in
- let subst_all_eq phi1 phi2 =
- formula_eq id phi2 (FormulaOps.map_to_atoms subst) phi1 in
+ let subst s phi = FormulaOps.subst_vars s phi in
+ let subst_free_eq ?(sub=[("x", "a"); ("y", "b")]) phi1 phi2 =
+ formula_eq id phi2 (subst sub) phi1 in
+ let subst_all_eq ?(sub=[("x", "a"); ("y", "b")]) phi1 phi2 =
+ formula_eq id phi2 (FormulaOps.map_to_atoms (subst sub)) phi1 in
subst_all_eq "ex x (P(x) and (not R(x, y)))"
"ex x (P(a) and (not R(a, b)))";
subst_free_eq "ex x (P(x) and not R(x, y))"
"ex x (P(x) and (not R(x, b)))";
subst_free_eq "ex a R(x, a)" "ex a0 R(a, a0)";
- formula_eq id "ex a R(a, a)"
- (FormulaOps.subst_vars_nocheck [("x", "a")]) "ex a R(x, a)";
+ subst_free_eq "R(x) and ex x R(x)" "R(a) and ex x R(x)";
+ subst_free_eq "R(x) and ex x (R(x) or R(a))"
+ "R(a) and ex x (R(x) or R(a))";
+ subst_free_eq ~sub:[("x", "m"); ("m", "x")]
+ "R(m) and ex m (S(m) or T(x))" "R(x) and (ex m0 (S(m0) or T(m)))";
...
[truncated message content] |
|
From: <luk...@us...> - 2011-05-01 16:35:00
|
Revision: 1428
http://toss.svn.sourceforge.net/toss/?rev=1428&view=rev
Author: lukaszkaiser
Date: 2011-05-01 16:34:53 +0000 (Sun, 01 May 2011)
Log Message:
-----------
Work on fixed-points in formulas: syntax checks, parsing, maps and folds.
Modified Paths:
--------------
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaParser.mly
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/Formula.ml 2011-05-01 16:34:53 UTC (rev 1428)
@@ -40,6 +40,13 @@
| `SO s -> `SO s
| _ -> failwith ("non SO variable: " ^ s)
+let mso_or_so_var_of_string s : [ mso_var | so_var ] =
+ match var_of_string s with
+ | `MSO s -> `MSO s
+ | `SO s -> `SO s
+ | _ -> failwith ("non (M)SO variable: " ^ s)
+
+
let real_var_of_string s : real_var =
match var_of_string s with
| `Real s -> `Real s
@@ -73,6 +80,8 @@
let to_fo (v : var) : fo_var = fo_var_of_string (var_str v)
let to_mso (v : var) : mso_var = mso_var_of_string (var_str v)
let to_so (v : var) : so_var = so_var_of_string (var_str v)
+let to_mso_or_so (v : var) : [ mso_var | so_var ] =
+ mso_or_so_var_of_string (var_str v)
let to_real (v : var) : real_var = real_var_of_string (var_str v)
(* Cast that is safe provided that tuples are not modified in-place. *)
@@ -97,6 +106,7 @@
| Rel of string * fo_var array
| Eq of fo_var * fo_var
| In of fo_var * mso_var
+ | SO of so_var * fo_var array
| RealExpr of real_expr * sign_op
| Not of formula
| And of formula list
@@ -117,7 +127,7 @@
let is_atom = function
- | Rel _ | Eq _ | In _ | RealExpr _ -> true
+ | Rel _ | Eq _ | In _ | SO _ | RealExpr _ -> true
| _ -> false
@@ -146,7 +156,7 @@
if (is_fo x) then "all1 " ^ (var_str x) ^ ": " else
"all2 " ^ (var_str x) ^ ": ") x)) ^ (mona_str phi)
| _ ->
- failwith "real-valued expressions and fixed-points not supported in MONA"
+ failwith "SO, real-valued terms and fixed-points not supported in MONA"
and f_list_str sep = function
| [] -> "[]"
@@ -164,6 +174,9 @@
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
| Eq (x, y) -> Format.fprintf f "%s = %s" (var_str x) (var_str y)
| In (x, y) -> Format.fprintf f "%s in %s" (var_str x) (var_str y)
+ | SO (r, vars) ->
+ Format.fprintf f "%a(%a)" fprint_var r
+ (Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
| RealExpr (p, s) ->
Format.fprintf f "@[(%a %s)@]" (fprint_real_prec 0) p (sign_op_str s)
| Not phi ->
@@ -191,11 +204,11 @@
Format.fprintf f "@[<1>%sall@ %a@ %a%s@]" lb
(Aux.fprint_sep_list "," fprint_var) x (fprint_prec 2) phi rb
| Lfp (r, vs, fpphi) ->
- Format.fprintf f "@[<1>(lfp %a(%a) = %a)@]" fprint_var r
+ Format.fprintf f "@[<1>lfp %a(%a) = (%a)@]" fprint_var r
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vs)
(fprint_prec prec) fpphi
| Gfp (r, vs, fpphi) ->
- Format.fprintf f "@[<1>(gfp %a(%a) = %a)@]" fprint_var r
+ Format.fprintf f "@[<1>gfp %a(%a) = (%a)@]" fprint_var r
(Aux.fprint_sep_list "," fprint_var) (Array.to_list vs)
(fprint_prec prec) fpphi
@@ -281,12 +294,21 @@
let rec size ?(acc=0) = function
- | Rel _ | Eq _ | In _ | RealExpr _ -> acc + 1
+ | Rel _ | Eq _ | In _ | SO _ -> acc + 1
+ | RealExpr (re, sgn) -> size_real ~acc:(acc + 1) re
| Not phi | Ex (_, phi) | All (_, phi) | Lfp (_,_,phi) | Gfp (_,_,phi) ->
size ~acc:(acc + 1) phi
| And flist | Or flist ->
List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
+and size_real ?(acc=0) = function
+ | RVar _ | Const _ | Fun _ -> acc + 1
+ | Times (r1, r2) | Plus (r1, r2) ->
+ let s1 = size_real ~acc:(acc + 1) r1 in size_real ~acc:s1 r2
+ | Char phi -> size ~acc phi
+ | Sum (_, phi, re) ->
+ let sr = size_real ~acc:(acc + 1) re in size ~acc:sr phi
+
let rec rec_compare phi1 phi2 =
let cmp_lists = compare_lists_lex rec_compare in
match (phi1, phi2) with
@@ -305,6 +327,11 @@
[|(x2 :> var); (y2 :> var)|]
| (In _, _) -> -1
| (_, In _) -> 1
+ | (SO (r1, vs1), SO (r2, vs2)) ->
+ let c = compare_var_tups vs1 vs2 in
+ if c <> 0 then c else String.compare (var_str r1) (var_str r2)
+ | (SO _, _) -> -1
+ | (_, SO _) -> 1
| (RealExpr (re1, s1), RealExpr (re2, s2)) ->
let c = rec_compare_re re1 re2 in
if c <> 0 then c else Pervasives.compare s1 s2
@@ -357,7 +384,7 @@
let rev_collect_conj xl = fold_acc get_conjunctions xl in
let rev_collect_disj xl = fold_acc get_disjunctions xl in
match phi with
- | Rel _ | Eq _ | In _ -> phi
+ | Rel _ | Eq _ | In _ | SO _ -> phi
| RealExpr (re, s) -> RealExpr (flatten_re_f f_or f_and re, s)
| Not phi ->
(match flatten_f f_or f_and phi with
@@ -481,3 +508,38 @@
let clean fl = del_dupl_ord [] (List.sort compare fl) in
flatten_re_f (fun fl -> set_first_lit_or (clean fl))
(fun fl -> set_first_lit_and (clean fl))
+
+
+(* ----- Formula syntax check. ----- *)
+
+(* We check that relations and SO variables appear with unique
+ arities and that fixed-point variables appear only positively. *)
+let rec syntax_ok ?(sg=ref []) ?(fp=[]) ?(pos=true) phi =
+ let ok_sg v arity =
+ try arity = List.assoc v !sg with Not_found ->
+ (sg := (v, arity) :: !sg; true) in
+ match phi with
+ | Eq _ -> true
+ | Rel (r, vs) -> ok_sg r (Array.length vs)
+ | In (_, msov) ->
+ (try List.assoc (var_str msov) fp = pos with Not_found -> true)
+ | SO (v, vs) ->
+ let r = var_str v in
+ (ok_sg r (Array.length vs)) &&
+ (try List.assoc (var_str v) fp = pos with Not_found -> true)
+ | RealExpr (re, _) -> syntax_ok_re ~sg ~fp ~pos re
+ | Not phi -> syntax_ok ~sg ~fp ~pos:(not pos) phi
+ | Or fl | And fl -> List.for_all (syntax_ok ~sg ~fp ~pos) fl
+ | Ex (_, phi) | All (_, phi) -> syntax_ok ~sg ~fp ~pos phi
+ | Lfp (r, vs, phi) | Gfp (r, vs, phi) ->
+ let sgok = if is_mso (r :> var) then Array.length vs = 1 else
+ ok_sg (var_str r) (Array.length vs) in
+ sgok && (syntax_ok ~sg ~fp:(((var_str r), pos) :: fp) ~pos phi)
+
+and syntax_ok_re ?(sg=ref []) ?(fp=[]) ?(pos=true) = function
+ | RVar _ | Const _ | Fun _ -> true
+ | Times (re1, re2) | Plus (re1, re2) ->
+ syntax_ok_re ~sg ~fp ~pos re1 && syntax_ok_re ~sg ~fp ~pos re2
+ | Char phi -> syntax_ok ~sg ~fp ~pos phi
+ | Sum (_, phi, r) ->
+ syntax_ok ~sg ~fp ~pos phi && syntax_ok_re ~sg ~fp ~pos r
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/Formula.mli 2011-05-01 16:34:53 UTC (rev 1428)
@@ -15,6 +15,7 @@
val fo_var_of_string : string -> fo_var
val mso_var_of_string : string -> mso_var
val so_var_of_string : string -> so_var
+val mso_or_so_var_of_string : string -> [ mso_var | so_var ]
val real_var_of_string : string -> real_var
(** Check variable type. *)
@@ -27,6 +28,7 @@
val to_fo : var -> fo_var
val to_mso : var -> mso_var
val to_so : var -> so_var
+val to_mso_or_so : var -> [ mso_var | so_var ]
val to_real : var -> real_var
val var_tup : [< var] array -> var array
@@ -49,6 +51,7 @@
| Rel of string * fo_var array
| Eq of fo_var * fo_var
| In of fo_var * mso_var
+ | SO of so_var * fo_var array
| RealExpr of real_expr * sign_op
| Not of formula
| And of formula list
@@ -59,7 +62,7 @@
| Gfp of [mso_var | so_var] * fo_var array * formula
(** Real-valued terms allow counting, characteristic functions, arithmetic. *)
-and real_expr =
+and real_expr =
| RVar of string
| Const of float
| Times of real_expr * real_expr
@@ -72,6 +75,7 @@
val pow : real_expr -> int -> real_expr
val size : ?acc : int -> formula -> int
+val size_real : ?acc : int -> real_expr -> int
val compare : formula -> formula -> int
@@ -101,6 +105,17 @@
val fprint_prec : int -> Format.formatter -> formula -> unit
val fprint_real_prec : int -> Format.formatter -> real_expr -> unit
+
+(** {2 Formula syntax check} *)
+
+(** We check that relations and SO variables appear with unique
+ arities and that fixed-point variables appear only positively. *)
+val syntax_ok: ?sg: (string * int) list ref -> ?fp: (string * bool) list ->
+ ?pos:bool -> formula -> bool
+val syntax_ok_re: ?sg: (string * int) list ref -> ?fp: (string * bool) list ->
+ ?pos:bool -> real_expr -> bool
+
+
(** {2 Basic flattening functions.} *)
(** Only flatten the formula. *)
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-05-01 16:34:53 UTC (rev 1428)
@@ -25,19 +25,28 @@
(* ------------------------------- NNF ------------------------------------ *)
(* Convert formula to NNF and additionally negate if [neg] is set. *)
-let rec nnf ?(neg=false) psi =
+let rec nnf ?(neg=false) ?(rev=[]) psi =
+ let ng r = if List.mem (var_str (r :> var)) rev then not neg else neg in
match psi with
- | Rel _ | Eq _ | In _ | RealExpr _ as atom -> if neg then Not atom else atom
- | Not phi -> if neg then nnf ~neg:false phi else nnf ~neg:true phi
- | And [f] | Or [f] -> nnf ~neg f
- | And (flist) when neg -> Or (List.map (nnf ~neg:true) flist)
- | And (flist) -> And (List.map (nnf ~neg:false) flist)
- | Or (flist) when neg -> And (List.map (nnf ~neg:true) flist)
- | Or (flist) -> Or (List.map (nnf ~neg:false) flist)
- | Ex (x, phi) when neg -> All (x, nnf ~neg:true phi)
- | Ex (x, phi) -> Ex (x, nnf ~neg:false phi)
- | All (x, phi) when neg -> Ex (x, nnf ~neg:true phi)
- | All (x, phi) -> All (x, nnf ~neg:false phi)
+ | Rel _ | Eq _ | RealExpr _ as atom -> if neg then Not atom else atom
+ | SO (r, _) as atom -> if ng r then Not atom else atom
+ | In (_, r) as atom -> if ng r then Not atom else atom
+ | Not phi -> if neg then nnf ~neg:false ~rev phi else nnf ~neg:true ~rev phi
+ | And [f] | Or [f] -> nnf ~neg ~rev f
+ | And (flist) when neg -> Or (List.map (nnf ~neg:true ~rev) flist)
+ | And (flist) -> And (List.map (nnf ~neg:false ~rev) flist)
+ | Or (flist) when neg -> And (List.map (nnf ~neg:true ~rev) flist)
+ | Or (flist) -> Or (List.map (nnf ~neg:false ~rev) flist)
+ | Ex (x, phi) when neg -> All (x, nnf ~neg:true ~rev phi)
+ | Ex (x, phi) -> Ex (x, nnf ~neg:false ~rev phi)
+ | All (x, phi) when neg -> Ex (x, nnf ~neg:true ~rev phi)
+ | All (x, phi) -> All (x, nnf ~neg:false ~rev phi)
+ | Lfp (r, vs, phi) when neg ->
+ Gfp (r, vs, nnf ~neg:true ~rev:((var_str r) :: rev) phi)
+ | Lfp (r, vs, phi) -> Lfp (r, vs, nnf ~neg:false ~rev phi)
+ | Gfp (r, vs, phi) when neg ->
+ Lfp (r, vs, nnf ~neg:true ~rev:((var_str r) :: rev) phi)
+ | Gfp (r, vs, phi) -> Gfp (r, vs, nnf ~neg:false ~rev phi)
(* -------------------------- FREE VARIABLES -------------------------------- *)
@@ -55,6 +64,8 @@
| Eq (x, y) -> (x :> var) :: (y :> var) :: acc
| Rel (r, vs) -> List.rev_append ((Array.to_list vs) :> var list) acc
| In (x, y) -> (x :> var) :: (y :> var) :: acc
+ | SO (v, vs) ->
+ (v :> var) :: List.rev_append ((Array.to_list vs) :> var list) acc
| RealExpr (p, _) ->
List.rev_append (List.map(fun v -> var_of_string v) (all_vars_real p)) acc
| Not phi -> all_vars_acc acc phi
@@ -83,6 +94,8 @@
| Eq (x, y) -> (x :> var) :: (y :> var) :: acc
| Rel (r, vs) -> List.rev_append (Array.to_list vs :> var list) acc
| In (x, y) -> (x :> var) :: (y :> var) :: acc
+ | SO (v, vs) ->
+ (v :> var) :: List.rev_append ((Array.to_list vs) :> var list) acc
| RealExpr (p, _) ->
List.rev_append (List.map (fun v->var_of_string v) (free_vars_real p)) acc
| Not phi -> free_vars_acc acc phi
@@ -112,7 +125,7 @@
(* Delete top-most ex/all quantification of [vs] in the formula. *)
let rec del_vars_quant vs = function
- | Eq _ | Rel _ | In _ | RealExpr _ as f -> f
+ | Eq _ | Rel _ | In _ | SO _ | RealExpr _ as f -> f
| Not phi -> Not (del_vars_quant vs phi)
| And (flist) -> And (List.map (del_vars_quant vs) flist)
| Or (flist) -> Or (List.map (del_vars_quant vs) flist)
@@ -138,12 +151,15 @@
map_Rel : string -> fo_var array -> formula;
map_Eq : fo_var -> fo_var -> formula;
map_In : fo_var -> mso_var -> formula;
+ map_SO : so_var -> fo_var array -> formula;
map_RealExpr : real_expr -> sign_op -> formula;
map_Not : formula -> formula;
map_And : formula list -> formula;
map_Or : formula list -> formula;
map_Ex : var list -> formula -> formula;
map_All : var list -> formula -> formula;
+ map_Lfp : [ mso_var | so_var ] -> fo_var array -> formula -> formula;
+ map_Gfp : [ mso_var | so_var ] -> fo_var array -> formula -> formula;
map_RVar : string -> real_expr;
map_Const : float -> real_expr;
@@ -158,12 +174,15 @@
map_Rel = (fun rel args -> Rel (rel, args));
map_Eq = (fun x y -> Eq (x, y));
map_In = (fun x ys -> In (x, ys));
+ map_SO = (fun v vs -> SO (v, vs));
map_RealExpr = (fun expr sign -> RealExpr (expr, sign));
map_Not = (fun phi -> Not phi);
map_And = (fun conjs -> And conjs);
map_Or = (fun disjs -> Or disjs);
map_Ex = (fun vs phi -> Ex (vs, phi));
map_All = (fun vs phi -> All (vs, phi));
+ map_Lfp = (fun v vs phi -> Lfp (v, vs, phi));
+ map_Gfp = (fun v vs phi -> Gfp (v, vs, phi));
map_RVar = (fun v -> RVar v);
map_Const = (fun c -> Const c);
@@ -178,6 +197,7 @@
| Rel (rel, args) -> gmap.map_Rel rel args
| Eq (x, y) -> gmap.map_Eq x y
| In (x, ys) -> gmap.map_In x ys
+ | SO (v, vs) -> gmap.map_SO v vs
| RealExpr (expr, sign) ->
gmap.map_RealExpr (map_real_expr gmap expr) sign
| Not phi -> gmap.map_Not (map_formula gmap phi)
@@ -185,6 +205,8 @@
| Or disjs -> gmap.map_Or (List.map (map_formula gmap) disjs)
| Ex (vs, phi) -> gmap.map_Ex vs (map_formula gmap phi)
| All (vs, phi) -> gmap.map_All vs (map_formula gmap phi)
+ | Lfp (v, vs, phi) -> gmap.map_Lfp v vs (map_formula gmap phi)
+ | Gfp (v, vs, phi) -> gmap.map_Gfp v vs (map_formula gmap phi)
and map_real_expr gmap = function
| RVar v -> gmap.map_RVar v
@@ -204,12 +226,15 @@
fold_Rel : string -> fo_var array -> 'a;
fold_Eq : fo_var -> fo_var -> 'a;
fold_In : fo_var -> mso_var -> 'a;
+ fold_SO : so_var -> fo_var array -> 'a;
fold_RealExpr : 'a -> sign_op -> 'a;
fold_Not : 'a -> 'a;
fold_And : 'a -> 'a -> 'a;
fold_Or : 'a -> 'a -> 'a;
fold_Ex : var list -> 'a -> 'a;
fold_All : var list -> 'a -> 'a;
+ fold_Lfp : [ mso_var | so_var ] -> fo_var array -> 'a -> 'a;
+ fold_Gfp : [ mso_var | so_var ] -> fo_var array -> 'a -> 'a;
fold_RVar : string -> 'a;
fold_Const : float -> 'a;
@@ -224,12 +249,15 @@
fold_Rel = (fun _ _ -> empty);
fold_Eq = (fun _ _ -> empty);
fold_In = (fun _ _ -> empty);
+ fold_SO = (fun _ _ -> empty);
fold_RealExpr = (fun expr _ -> expr);
fold_Not = (fun phi -> phi);
fold_And = union;
fold_Or = union;
fold_Ex = (fun _ phi -> phi);
fold_All = (fun _ phi -> phi);
+ fold_Lfp = (fun _ _ phi -> phi);
+ fold_Gfp = (fun _ _ phi -> phi);
fold_RVar = (fun _ -> empty);
fold_Const = (fun _ -> empty);
@@ -246,6 +274,7 @@
| Rel (rel, args) -> gfold.fold_Rel rel args
| Eq (x, y) -> gfold.fold_Eq x y
| In (x, ys) -> gfold.fold_In x ys
+ | SO (v, vs) -> gfold.fold_SO v vs
| RealExpr (expr, sign) ->
gfold.fold_RealExpr (fold_real_expr gfold expr) sign
| Not phi -> gfold.fold_Not (fold_formula gfold phi)
@@ -263,6 +292,8 @@
(fold_formula gfold disj)
| Ex (vs, phi) -> gfold.fold_Ex vs (fold_formula gfold phi)
| All (vs, phi) -> gfold.fold_All vs (fold_formula gfold phi)
+ | Lfp (v, vs, phi) -> gfold.fold_Lfp v vs (fold_formula gfold phi)
+ | Gfp (v, vs, phi) -> gfold.fold_Gfp v vs (fold_formula gfold phi)
and fold_real_expr gfold = function
| RVar v -> gfold.fold_RVar v
@@ -292,7 +323,8 @@
(* Map [f] to all literals (i.e. atoms or not(atom)'s) in the given
formula. Preserves order of subformulas. *)
let rec map_to_literals f g = function
- Rel _ | Eq _ | In _ as x -> f x
+ | Rel _ | Eq _ | In _ | SO _ as x -> f x
+ | RealExpr (r, s) -> RealExpr (map_to_literals_expr f g r, s)
| Not (Rel _) | Not (Eq _) | Not (In _) as x -> f x
| Not (RealExpr (r, s)) -> Not (RealExpr (map_to_literals_expr f g r, s))
| Not phi -> Not (map_to_literals f g phi)
@@ -300,7 +332,8 @@
| And flist -> And (List.map (map_to_literals f g) flist)
| Ex (vs, phi) -> Ex (vs, map_to_literals f g phi)
| All (vs, phi) -> All (vs, map_to_literals f g phi)
- | RealExpr (r, s) -> RealExpr (map_to_literals_expr f g r, s)
+ | Lfp (v, vs, phi) -> Lfp (v, vs, map_to_literals f g phi)
+ | Gfp (v, vs, phi) -> Gfp (v, vs, map_to_literals f g phi)
and map_to_literals_expr f g = function
| RVar _ | Const _ | Fun _ as x -> g x
@@ -351,14 +384,14 @@
let rec fold_over_literals f phi acc =
match phi with
- Rel _ | Eq _ | In _ as x -> f x acc
+ | Rel _ | Eq _ | In _ | SO _ as x -> f x acc
+ | RealExpr (r, _) -> fold_over_literals_expr f r acc
| Not (Rel _) | Not (Eq _) | Not (In _) as x -> f x acc
| Not phi -> fold_over_literals f phi acc
| Or flist
| And flist -> List.fold_right (fold_over_literals f) flist acc
- | Ex (vs, phi)
- | All (vs, phi) -> fold_over_literals f phi acc
- | RealExpr (r, _) -> fold_over_literals_expr f r acc
+ | Ex (_, phi) | All (_, phi) -> fold_over_literals f phi acc
+ | Lfp (_, _, phi) | Gfp (_, _, phi) -> fold_over_literals f phi acc
and fold_over_literals_expr f =
fold_over_formulas_expr (fold_over_literals f)
@@ -369,24 +402,31 @@
(* Map [f] to all variables occurring in the formula. Preserves order
of subformulas. *)
-let rec map_to_all_vars (f : var -> var) = function
- Rel (rn, vl) -> Rel (rn, Array.map (fun x -> to_fo (f (x :> var))) vl)
- | Eq (x, y) -> Eq (to_fo (f (x :> var)), to_fo (f (y :> var)))
- | In (x, y) -> In (to_fo (f (x :> var)), to_mso (f (y :> var)))
- | RealExpr _ -> failwith "re"(* TODO: implement var mapping for realexprs. *)
- | Not phi -> Not (map_to_all_vars f phi)
- | Or flist -> Or (List.map (map_to_all_vars f) flist)
- | And flist -> And (List.map (map_to_all_vars f) flist)
- | Ex (vs, phi) -> Ex (List.map f vs, map_to_all_vars f phi)
- | All (vs, phi) -> All (List.map f vs, map_to_all_vars f phi)
+let rec map_to_all_vars (f : var -> var) phi =
+ let foaf va = Array.map (fun x -> to_fo (f (x :> var))) va in
+ match phi with
+ | Rel (rn, vl) -> Rel (rn, foaf vl)
+ | Eq (x, y) -> Eq (to_fo (f (x :> var)), to_fo (f (y :> var)))
+ | In (x, y) -> In (to_fo (f (x :> var)), to_mso (f (y :> var)))
+ | SO (v, vs) -> SO (to_so (f (v :> var)), foaf vs)
+ | RealExpr _ -> failwith "re"(* TODO: implement var map for realexprs. *)
+ | Not phi -> Not (map_to_all_vars f phi)
+ | Or flist -> Or (List.map (map_to_all_vars f) flist)
+ | And flist -> And (List.map (map_to_all_vars f) flist)
+ | Ex (vs, phi) -> Ex (List.map f vs, map_to_all_vars f phi)
+ | All (vs, phi) -> All (List.map f vs, map_to_all_vars f phi)
+ | Lfp (v, vs, phi) ->
+ Lfp (to_mso_or_so (f (v :> var)), foaf vs, map_to_all_vars f phi)
+ | Gfp (v, vs, phi) ->
+ Gfp (to_mso_or_so (f (v :> var)), foaf vs, map_to_all_vars f phi)
-
(* Helper function: apply subsutitution [subst] to the variable [v]. *)
let var_subst subst v =
let subst_str s = try List.assoc s subst with Not_found -> s in
match v with
- `FO s -> `FO (subst_str s)
+ | `FO s -> `FO (subst_str s)
| `MSO s -> `MSO (subst_str s)
+ | `SO s -> `SO (subst_str s)
| `Real s -> `Real (subst_str s)
let fo_var_subst subst (v : fo_var) = to_fo (var_subst subst v)
@@ -394,21 +434,23 @@
(* Apply substitution [subst] to all free variables in the given
formula. Preserves order of subformulas. *)
let rec subst_vars subst = function
- Rel (rn, vs) -> Rel (rn, Array.map (fo_var_subst subst) vs)
+ | Rel (rn, vs) -> Rel (rn, Array.map (fo_var_subst subst) vs)
| Eq (x, y) -> Eq (fo_var_subst subst x, fo_var_subst subst y)
| In (x, y) -> In (fo_var_subst subst x, to_mso (var_subst subst y))
+ | SO (v, vs) ->
+ SO (to_so (var_subst subst v), Array.map (fo_var_subst subst) vs)
| RealExpr (r, sgn) -> RealExpr (subst_vars_expr subst r, sgn)
| Not phi -> Not (subst_vars subst phi)
| Or flist -> Or (List.map (subst_vars subst) flist)
| And flist -> And (List.map (subst_vars subst) flist)
| Ex (vs, phi) ->
- let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
- let new_vs = List.filter (fun x -> not (in_vs x)) subst in
- if new_vs = [] then Ex (vs, phi) else Ex (vs, subst_vars new_vs phi)
+ let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
+ let new_vs = List.filter (fun x -> not (in_vs x)) subst in
+ if new_vs = [] then Ex (vs, phi) else Ex (vs, subst_vars new_vs phi)
| All (vs, phi) ->
- let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
- let new_vs = List.filter (fun x -> not (in_vs x)) subst in
- if new_vs = [] then All (vs, phi) else All (vs, subst_vars new_vs phi)
+ let in_vs (s, _) = List.exists (fun v -> var_str v = s) vs in
+ let new_vs = List.filter (fun x -> not (in_vs x)) subst in
+ if new_vs = [] then All (vs, phi) else All (vs, subst_vars new_vs phi)
and subst_vars_expr subst = function
| Const _ as x -> x
@@ -423,7 +465,7 @@
if new_vs = [] then Sum(vs, phi, r) else
Sum(vs, subst_vars new_vs phi, subst_vars_expr new_vs r)
-(* Helper function: strip digits from string end except if it starts with one. *)
+(* Helper function: strip digits from string end except if it starts with one.*)
let rec strip_digits s =
if Aux.is_digit s.[0] then s else
let len = String.length s in
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-05-01 16:34:53 UTC (rev 1428)
@@ -6,7 +6,7 @@
(** {2 NNF} *)
(** Convert formula to NNF and additionally negate if [neg] is set. *)
-val nnf : ?neg : bool -> formula -> formula
+val nnf : ?neg: bool -> ?rev: string list -> formula -> formula
(** {2 Vars} *)
@@ -24,12 +24,15 @@
map_Rel : string -> fo_var array -> formula;
map_Eq : fo_var -> fo_var -> formula;
map_In : fo_var -> mso_var -> formula;
+ map_SO : so_var -> fo_var array -> formula;
map_RealExpr : real_expr -> sign_op -> formula;
map_Not : formula -> formula;
map_And : formula list -> formula;
map_Or : formula list -> formula;
map_Ex : var list -> formula -> formula;
map_All : var list -> formula -> formula;
+ map_Lfp : [ mso_var | so_var ] -> fo_var array -> formula -> formula;
+ map_Gfp : [ mso_var | so_var ] -> fo_var array -> formula -> formula;
map_RVar : string -> real_expr;
map_Const : float -> real_expr;
@@ -52,12 +55,15 @@
fold_Rel : string -> fo_var array -> 'a;
fold_Eq : fo_var -> fo_var -> 'a;
fold_In : fo_var -> mso_var -> 'a;
+ fold_SO : so_var -> fo_var array -> 'a;
fold_RealExpr : 'a -> sign_op -> 'a;
fold_Not : 'a -> 'a;
fold_And : 'a -> 'a -> 'a;
fold_Or : 'a -> 'a -> 'a;
fold_Ex : var list -> 'a -> 'a;
fold_All : var list -> 'a -> 'a;
+ fold_Lfp : [ mso_var | so_var ] -> fo_var array -> 'a -> 'a;
+ fold_Gfp : [ mso_var | so_var ] -> fo_var array -> 'a -> 'a;
fold_RVar : string -> 'a;
fold_Const : float -> 'a;
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-01 16:34:53 UTC (rev 1428)
@@ -1,16 +1,14 @@
open OUnit
-FormulaOps.set_debug_level 0 ;;
-BoolFormula.set_debug_level 0 ;;
+FormulaOps.set_debug_level 0
let formula_of_string s =
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-;;
let real_expr_of_string s =
FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)
-;;
+
let formula_eq ?(flatten=true) f1 phi1 f2 phi2 =
if flatten then
assert_equal ~printer:(fun x -> Formula.sprint x)
@@ -19,15 +17,14 @@
else
assert_equal ~printer:(fun x -> Formula.sprint x)
(f1 (formula_of_string phi1)) (f2 (formula_of_string phi2))
-;;
let real_expr_eq f1 re1 f2 re2 =
assert_equal ~printer:(fun x -> Formula.real_str x)
(f1 (real_expr_of_string re1)) (f2 (real_expr_of_string re2))
-;;
-let id x = x ;;
+let id x = x
+
let tests = "FormulaOps" >::: [
"nnf and parsing" >::
(fun () ->
@@ -46,6 +43,10 @@
"ex x :(all y (R (x, y))) > 0";
nnf_eq "set R(x) = ex y C(x, y) in P(x) or R(x)"
"P(x) or ex y C(x, y)";
+ nnf_eq "not lfp T(x) = (P(x) or ex y (E(x, y) and y in T))"
+ "gfp T(x) = (not P(x) and all y (not E(x, y) or y in T))";
+ nnf_eq "not lfp |R(x, y) = (P(x, y) or ex z (E(x, z) and |R(y, z)))"
+ "gfp |R(x, y) = (not P(x, y) and all z (not E(x, z) or |R(y, z)))";
);
"fv" >::
@@ -375,12 +376,11 @@
"not (S(x, y) or P(x))";
);
-] ;;
+]
-let a =
- Aux.run_test_if_target "FormulaOpsTest" tests
-;;
+let exec = Aux.run_test_if_target "FormulaOpsTest" tests
+
(* --------------------------- Reals separation test ----------------------- *)
(* test_tnf
@@ -392,7 +392,7 @@
((ex x (not P(x) and Q(x) and x in X))
<-> (:zx>:rl and :zx<:rr and :zy>:rb and :zy<:rt)) and
((ex x (not P(x) and not Q(x) and x in X))
- <-> (:sx>:rl and :sx<:rr and :sy>:rb and :sy<:rt)))" ;;
+ <-> (:sx>:rl and :sx<:rr and :sy>:rb and :sy<:rt)))"
*)
(* ------------------------------ SL 6 formula test ------------------------ *)
@@ -406,43 +406,43 @@
v2 ^ " = z and " ^ v1 ^ " in F_fz) or (" ^
v1 ^ " = z and " ^ v2 ^ " in B_fz) or (" ^
v2 ^ " = x and " ^ v1 ^ " in F_fx) or (" ^
- v1 ^ " = x and " ^ v2 ^ " in B_fx)" ;;
+ v1 ^ " = x and " ^ v2 ^ " in B_fx)"
let partial_f = "all a,b,c (" ^ (f "a" "b") ^ " and " ^ (f "a" "c") ^ " -> b=c)"
let closed_f h = "all v ( v in " ^ h ^ " and v != y ) -> (all u (" ^
- (f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")";;
+ (f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")"
(* let closed_f h = "all v ( v in " ^ h ^ " ) -> (all u (" ^
- (f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")";; *)
+ (f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")" *)
(*let sl6_f = "all x (Z(x) -> (not x in F_f and not x in B_f)) and " ^
partial_f ^ " and
(ex H_path ((" ^ (closed_f "H_path") ^ ") and (all H_other ((" ^
(closed_f "H_other") ^ ") -> all a (a in H_path -> a in H_other)))
- and y in H_path))";; *)
+ and y in H_path))" *)
let sl6_f = "ex x,y,z,F_f,B_f,L_f,F_fx,B_fx,F_fy,B_fy,F_fz,B_fz
(all u (Z(u) -> (not u in F_f and not u in B_f)) and " ^
partial_f ^ " and
(ex H_path ((" ^ (closed_f "H_path") ^ ") and (all H_other ((" ^
(closed_f "H_other") ^ ") -> all a (a in H_path -> a in H_other)))
- and y in H_path)))";;
+ and y in H_path)))"
-let sl6_phi = Formula.flatten_sort (FormulaOps.nnf (formula_of_string sl6_f));;
+let sl6_phi = Formula.flatten_sort (FormulaOps.nnf (formula_of_string sl6_f))
-print_endline "SL6 = " ;;
-print_endline (Formula.str sl6_phi) ;;
+print_endline "SL6 = "
+print_endline (Formula.str sl6_phi)
"TNF size" FormulaOps.tnf
- (fun f -> print_endline (string_of_int (Formula.size f))) sl6_f ;;
+ (fun f -> print_endline (string_of_int (Formula.size f))) sl6_f
*)
(* ------- Other longer formulas -------- *)
(*
-let formula = "all x (P(x) or ex y E(x,y)) and all x (Q(x) or ex y E(y,x))" ;;
+let formula = "all x (P(x) or ex y E(x,y)) and all x (Q(x) or ex y E(y,x))"
let formula = "(all s (((s in S) or (not Zero(s)))) and all s
((Zero(s) or (s in S) or (not Zero(s)))) and all s (((s in S) or (not
@@ -453,7 +453,7 @@
and ex C, X (all s, t (((not Succ(t, s)) or ((t in X2) and ((t in C)
or (t in X)) and ((t in C) or (not (t in X)))) or ((not (t in X2)) and
(((t in X) and (not (t in C))) or ((not (t in C)) and (not (t in
- X)))))))))))" ;;
+ X)))))))))))"
let formula = "(all s ((not Zero(s))) and all s ((not (s in S))) and
ex X2 ((all s ((((s in S) and (s in X2)) or ((not (s in S)) and (not
@@ -467,7 +467,7 @@
and all s, t (((not Succ(t, s)) or ((t in C) and (t in X2)) or
((not (t in X2)) and
(((t in X) and (not (t in C))) or ((not (t in C)) and (not (t in
-X))))))))))))))" ;;
+X))))))))))))))"
let formula = "(all n (LessEq(zero, n))
@@ -475,7 +475,7 @@
and all s (((s in C) or all t (((not Succ(t, s)) or (not (t in X))))))
and all s (((not (s in C)) or all t (((t in X) or (not Succ(t, s))))))
and all s, t (((not Succ(t, s)) or ((t in C) and (t in S)) or ((not (t in C)) and (not (t in S)))))
-)))" ;;
+)))"
let prenex = "all n
(ex C
@@ -487,6 +487,6 @@
and
((((t in X) or (not Succ(t, s))) or (not (s in C))) and
((((not Succ(t, s)) or (not (t in X))) or (s in C)) and
- (not (zero in C))))))))))" ;;
+ (not (zero in C))))))))))"
*)
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/FormulaParser.mly 2011-05-01 16:34:53 UTC (rev 1428)
@@ -3,6 +3,15 @@
%{
open Lexer
open Formula
+
+ let var_of_s s =
+ try var_of_string s with Failure s -> raise (Parsing_error s)
+ let fo_var_of_s s =
+ try fo_var_of_string s with Failure s -> raise (Parsing_error s)
+ let mso_var_of_s s =
+ try mso_var_of_string s with Failure s -> raise (Parsing_error s)
+ let so_var_of_s s =
+ try so_var_of_string s with Failure s -> raise (Parsing_error s)
%}
%start parse_formula parse_real_expr
@@ -17,21 +26,23 @@
var_list:
- | ID { [var_of_string $1] }
- | COLON ID { [var_of_string (":" ^ $2)] }
- | ID COMMA var_list { (var_of_string $1) :: $3 }
- | COLON ID COMMA var_list { (var_of_string (":" ^ $2)) :: $4 }
+ | ID { [var_of_s $1] }
+ | COLON ID { [var_of_s (":" ^ $2)] }
+ | MID ID { [var_of_s ("|" ^ $2)] }
+ | ID COMMA var_list { (var_of_s $1) :: $3 }
+ | COLON ID COMMA var_list { (var_of_s (":" ^ $2)) :: $4 }
+ | MID ID COMMA var_list { (var_of_s ("|" ^ $2)) :: $4 }
%public fo_var_list:
- | ID { [fo_var_of_string $1] }
- | ID COMMA fo_var_list { (fo_var_of_string $1) :: $3 }
+ | ID { [fo_var_of_s $1] }
+ | ID COMMA fo_var_list { (fo_var_of_s $1) :: $3 }
%public real_expr:
| INT { Const (float_of_int $1) }
| FLOAT { Const ($1) }
| COLON ID { RVar (":" ^ $2) }
- | COLON ID OPEN ID CLOSE { Fun ($2, fo_var_of_string $4) }
+ | COLON ID OPEN ID CLOSE { Fun ($2, fo_var_of_s $4) }
| real_expr FLOAT { Plus ($1, Const $2) } /* in x-1, "-1" is int */
| real_expr INT { Plus ($1, Const (float_of_int $2)) }
| real_expr PLUS real_expr { Plus ($1, $3) }
@@ -67,18 +78,33 @@
| FALSE { Or [] }
| ID OPEN CLOSE { Rel ($1, [||]) }
| ID OPEN fo_var_list CLOSE { Rel ($1, Array.of_list $3) }
+ | MID ID OPEN fo_var_list CLOSE
+ { SO (so_var_of_s ("|" ^ $2), Array.of_list $4) }
| PLUS ID OPEN fo_var_list CLOSE { Rel ("+"^$2, Array.of_list $4) }
| MINUS ID OPEN fo_var_list CLOSE { Rel ("-"^$2, Array.of_list $4) }
- | ID EQ ID { Eq (fo_var_of_string $1, fo_var_of_string $3) }
- | ID NEQ ID { Not(Eq (fo_var_of_string $1,fo_var_of_string $3))}
- | ID IN ID { In (fo_var_of_string $1, mso_var_of_string $3) }
+ | ID EQ ID { Eq (fo_var_of_s $1, fo_var_of_s $3) }
+ | ID NEQ ID { Not(Eq (fo_var_of_s $1,fo_var_of_s $3))}
+ | ID IN ID { In (fo_var_of_s $1, mso_var_of_s $3) }
| real_ineq { let (p, s) = $1 in RealExpr (p, s) }
| NOT formula_expr { Not ($2) }
| EX var_list formula_expr { Ex ($2, $3) }
| ALL var_list formula_expr { All ($2, $3) }
| TC ID COMMA ID formula_expr { FormulaOps.make_tc $2 $4 $5 }
| TC INT ID COMMA ID formula_expr { FormulaOps.make_fo_tc_conj $2 $3 $5 $6 }
- | OPEN formula_expr CLOSE { $2 }
+ | LFP ID OPEN fo_var_list CLOSE EQ formula_expr
+ { let vs = Array.of_list $4 in if Array.length vs <> 1 then
+ raise (Parsing_error "Monadic LFP with not one variable")
+ else Lfp ((mso_var_of_s $2 :> [ mso_var | so_var ]), vs, $7) }
+ | LFP MID ID OPEN fo_var_list CLOSE EQ formula_expr
+ { Lfp ((so_var_of_s ("|" ^ $3) :> [ mso_var | so_var ]),
+ Array.of_list $5, $8) }
+ | GFP ID OPEN fo_var_list CLOSE EQ formula_expr
+ { let vs = Array.of_list $4 in if Array.length vs <> 1 then
+ raise (Parsing_error "Monadic GFP with not one variable")
+ else Gfp ((mso_var_of_s $2 :> [ mso_var | so_var ]), vs, $7) }
+ | GFP MID ID OPEN fo_var_list CLOSE EQ formula_expr
+ { Gfp ((so_var_of_s ("|" ^ $3) :> [ mso_var | so_var ]),
+ Array.of_list $5, $8) }
| formula_expr AND formula_expr { And [$1; $3] }
| formula_expr AMP formula_expr { And [$1; $3] }
| formula_expr OR formula_expr { Or [$1; $3] }
@@ -87,6 +113,7 @@
| formula_expr RARR formula_expr { Or [Not ($1); $3] }
| formula_expr LRARR formula_expr
{ Or [And [Not ($1); Not ($3)]; And [$1; $3]] }
+ | OPEN formula_expr CLOSE { $2 }
formula_with_set_expr:
| formula_expr { $1 }
@@ -98,7 +125,11 @@
parse_formula:
- formula_with_set_expr EOF { $1 };
+ formula_with_set_expr EOF
+ { if Formula.syntax_ok $1 then $1 else
+ raise (Parsing_error "Wrong formula syntax (arities? fixed-points?)") };
parse_real_expr:
- real_expr EOF { $1 };
+ real_expr EOF
+ { if Formula.syntax_ok_re $1 then $1 else
+ raise (Parsing_error "Wrong re syntax (arities? fixed-points?)") };
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/FormulaTest.ml 2011-05-01 16:34:53 UTC (rev 1428)
@@ -1,18 +1,32 @@
open OUnit
+open Formula
+let rel r i = Rel (r, Array.make i (`FO "x"))
+
let tests = "Formula" >::: [
"basic flatten" >::
(fun () ->
- let r s = Formula.Rel ("s", [||]) in
- assert_equal ~printer:(fun x -> Formula.str x)
- (Formula.flatten (
- Formula.And [r "P"; Formula.And [r "Q"; r "S"]]))
- (Formula.And [r "P"; r "Q"; r "S"]);
- assert_equal ~printer:(fun x -> Formula.str x)
- (Formula.flatten (
- Formula.And [Formula.And [r "P"; r "Q"]; Formula.And [r "S"]]))
- (Formula.And [r "P"; r "Q"; r "S"]);
+ assert_equal ~printer:(fun x -> str x)
+ (flatten (And [rel "P" 1; And [rel "Q" 1; rel "S" 1]]))
+ (And [rel "P" 1; rel "Q" 1; rel "S" 1]);
+ assert_equal ~printer:(fun x -> str x)
+ (flatten (And [And [rel "P" 1; rel "Q" 1]; And [rel "S" 1]]))
+ (And [rel "P" 1; rel "Q" 1; rel "S" 1]);
);
+
+ "syntax check" >::
+ (fun () ->
+ assert_equal ~printer:string_of_bool true
+ (syntax_ok (And [rel "R" 1; rel "R" 1]));
+ assert_equal ~printer:string_of_bool false
+ (syntax_ok (And [rel "R" 1; rel "R" 2]));
+ assert_equal ~printer:string_of_bool false
+ (syntax_ok (Lfp (`MSO "X", [|`FO "x"; `FO "y"|], And [])));
+ assert_equal ~printer:string_of_bool true
+ (syntax_ok (Lfp (`MSO "X", [|`FO "x"|], In (`FO "x", `MSO "X"))));
+ assert_equal ~printer:string_of_bool false
+ (syntax_ok (Lfp (`MSO "X", [|`FO "x"|], Not(In (`FO "x", `MSO "X")))));
+ );
]
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/Lexer.mll 2011-05-01 16:34:53 UTC (rev 1428)
@@ -81,6 +81,7 @@
| RIGHT_SPEC
| CLASS
| LFP
+ | GFP
| EOF
let reset_as_file lexbuf s =
@@ -220,6 +221,9 @@
| "LFP" { LFP }
| "lfp" { LFP }
| "mu" { LFP }
+ | "GFP" { GFP }
+ | "gfp" { GFP }
+ | "nu" { GFP }
| ['0'-'9']+ as n { INT (int_of_string n) }
| '-' ['0'-'9']+ as n { INT (int_of_string n) }
| ['0'-'9']* '.' ['0'-'9']+ as x { FLOAT (float_of_string x) }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2011-05-01 00:33:55 UTC (rev 1427)
+++ trunk/Toss/Formula/Tokens.mly 2011-05-01 16:34:53 UTC (rev 1428)
@@ -11,7 +11,7 @@
%token WITH EMB PRE INV POST UPDATE DYNAMICS TRUE FALSE ASSOC COND PAYOFF MOVES
%token ADD_CMD DEL_CMD GET_CMD SET_CMD EVAL_CMD
%token ELEM_MOD REL_MOD ALLOF_MOD SIG_MOD FUN_MOD DATA_MOD LOC_MOD TIMEOUT_MOD TIME_MOD PLAYER_MOD PLAYERS_MOD
-%token MODEL_SPEC RULE_SPEC STATE_SPEC LEFT_SPEC RIGHT_SPEC CLASS LFP EOF
+%token MODEL_SPEC RULE_SPEC STATE_SPEC LEFT_SPEC RIGHT_SPEC CLASS LFP GFP EOF
/* List in order of increasing precedence. */
%nonassoc COND
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-05-01 00:34:04
|
Revision: 1427
http://toss.svn.sourceforge.net/toss/?rev=1427&view=rev
Author: lukaszkaiser
Date: 2011-05-01 00:33:55 +0000 (Sun, 01 May 2011)
Log Message:
-----------
Complete moving ClassTest to OUnit, merge with PresbTest; many cleanups in Formula ml and tests, among others str = sprint now; start implementing functions for fixed-points.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FFTNFTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Server/PictureTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Solver/Class.ml
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Removed Paths:
-------------
trunk/Toss/Solver/PresbTest.ml
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -590,7 +590,7 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"one not opt"
- "(not O(b))-> true"
+ "not O(b)-> true"
(rule_obj_str rule_obj);
let lhs_struc = struc_of_str "[ e | _opt_D (e); O(e) | ]" in
@@ -604,7 +604,7 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"del one not opt"
- "O(b)-> (not O(b))"
+ "O(b)-> not O(b)"
(rule_obj_str rule_obj);
let lhs_struc = struc_of_str "[ e | D (e); _opt_O(e) | ]" in
@@ -618,7 +618,7 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_one_of ~msg:"match defined"
- ["(P(b) or Q(b))-> O(b)"; "(Q(b) or P(b))-> O(b)"]
+ ["P(b) or Q(b)-> O(b)"; "Q(b) or P(b)-> O(b)"]
(rule_obj_str rule_obj);
let lhs_struc = struc_of_str "[ e | D (e); _opt_O(e) | ]" in
@@ -632,14 +632,14 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_one_of ~msg:"match defined 2"
- ["(P(b) or Q(b))-> (O(b) and (not P(b)) and (not Q(b)))";"(Q(b) or P(b))-> (O(b) and (not P(b)) and (not Q(b)))"]
+ ["P(b) or Q(b)-> (O(b) and not P(b) and not Q(b))";
+ "Q(b) or P(b)-> (O(b) and not P(b) and not Q(b))"]
(rule_obj_str rule_obj);
);
"compile_rule: special relations" >::
(fun () ->
-
let lhs_struc = struc_of_str "[ e | _diffthan_D (e); _any_ (e) | ]" in
let rhs_struc = struc_of_str "[ b | _opt_O (b) | ]" in
let signat = ["O", 1; "P", 1; "Q", 1] in
@@ -651,7 +651,7 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"defrel: diffthan P Q"
- "((not P(b)) and (not Q(b)))-> true"
+ "(not P(b) and not Q(b))-> true"
(rule_obj_str rule_obj);
let lhs_struc = struc_of_str "[ e | _del_D (e); O(e) | ]" in
@@ -665,7 +665,10 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_one_of ~msg:"del defrel"
- ["(O(b) and (not P(b)) and (not Q(b)) and (_del_P(b) or _del_Q(b)))-> (P(b) and (not O(b)))";"((_del_Q(b) or _del_P(b)) and O(b) and (not P(b)) and (not Q(b)))-> (P(b) and (not O(b)))";"((_del_P(b) and O(b) and (not P(b)) and (not Q(b))) or (_del_Q(b) and O(b) and (not P(b)) and (not Q(b))))-> (P(b) and (not O(b)))";"((_del_P(b) or _del_Q(b)) and O(b) and (not P(b)) and (not Q(b)))-> (P(b) and (not O(b)))"]
+ ["(O(b) and not P(b) and not Q(b) and (_del_P(b) or _del_Q(b)))-> (P(b) and not O(b))";
+ "((_del_Q(b) or _del_P(b)) and O(b) and not P(b) and not Q(b))-> (P(b) and not O(b))";
+ "((_del_P(b) and O(b) and not P(b) and not Q(b)) or (_del_Q(b) and O(b) and not P(b) and not Q(b)))-> (P(b) and not O(b))";
+ "((_del_P(b) or _del_Q(b)) and O(b) and not P(b) and not Q(b))-> (P(b) and not O(b))"]
(rule_obj_str rule_obj);
let lhs_struc = struc_of_str "[ e | _opt_D (e); _diffthan_P(e) | ]" in
@@ -679,7 +682,7 @@
pre = Formula.And [];
rule_s = [1,1]} in
assert_equal ~printer:(fun x->x) ~msg:"diffthan override"
- "((not O(b)) and (not P(b)))-> (O(b) and (not Q(b)))"
+ "(not O(b) and not P(b))-> (O(b) and not Q(b))"
(rule_obj_str rule_obj);
);
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/Aux.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -589,6 +589,12 @@
(* So that the tests are not run twice while building TossTest. *)
run_if_target target_name f
+let set_optimized_gc () =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
+ }
let rec input_file file =
let buf = Buffer.create 256 in
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/Aux.mli 2011-05-01 00:33:55 UTC (rev 1427)
@@ -289,6 +289,9 @@
(** Run a test suite if the executable name matches the given prefix. *)
val run_test_if_target : string -> OUnit.test -> unit
+(** Set more agressive Gc values optimized for heavier computations. *)
+val set_optimized_gc : unit -> unit
+
(** Input a file to a string. *)
val input_file : in_channel -> string
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -20,8 +20,11 @@
let b_flat = BoolFormula.flatten_sort b_nnf in
BoolFormula.to_reduced_form b_flat
-let assert_eq_string arg msg x y =
+let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ let ws = Str.regexp "[ \n\t]+" in
+ let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
+ let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -56,7 +59,7 @@
test_cnf_bool "P(x)" "P(x)";
test_bool_auxcnf "not P(x)" "-1" "-1" "1";
- test_cnf_bool "not P(x)" "(not P(x))";
+ test_cnf_bool "not P(x)" "not P(x)";
test_bool_auxcnf "P(x) and (P(y) or P(z))"
"((3 or 2) and 1)" "(not (-1 or (not (2 or 3))))"
@@ -73,8 +76,8 @@
" and (7 or 6) and (7 or 3) and (-5 or -4 or -6) and (6 or 5) " ^
"and (6 or 4))");
test_cnf_bool "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
- ("((D(y) or (not P(x)) or (not B(x)) or (not A(x))) and " ^
- "(C(x) or (not P(x)) or (not B(x)) or (not A(x))))");
+ ("((D(y) or not P(x) or not B(x) or not A(x)) and " ^
+ "(C(x) or not P(x) or not B(x) or not A(x)))");
test_bool_auxcnf "(P(x) and P(y)) or (not P(x) and not P(y))"
"((-2 and -1) or (2 and 1))" "((not (-1 or -2)) or (not (1 or 2)))"
@@ -82,7 +85,7 @@
"(-2 or -1 or -4) and (4 or 2) and (4 or 1) and (2 or 1 or -3) " ^
"and (3 or -2) and (3 or -1))");
test_cnf_bool "(P(x) and P(y)) or (not P(x) and not P(y))"
- "((P(y) or (not P(x))) and ((not P(y)) or P(x)))";
+ "((P(y) or not P(x)) and (not P(y) or P(x)))";
);
"Plaisted Greenbaum auxcnf and cnf" >::
@@ -153,14 +156,14 @@
"not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
"-1 | -2 | 3 | 4";
test_cnf_bool "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
- "(Q(z) or P(y) or (not Q(x)) or (not P(x)))";
+ "Q(z) or P(y) or not Q(x) or not P(x)";
test_flat_reduced_cnf_list
"not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
"-1 | -2 | -3 | 4 & -1 | -2 | -3 | 5";
test_cnf_bool "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
- ("((D(y) or (not P(x)) or (not B(x)) or (not A(x))) and " ^
- "(C(x) or (not P(x)) or (not B(x)) or (not A(x))))");
+ ("((D(y) or not P(x) or not B(x) or not A(x)) and " ^
+ "(C(x) or not P(x) or not B(x) or not A(x)))");
test_flat_reduced_cnf_list
("(P(x) and P(a)) or (P(x) and P(b)) or (P(x) and P(c))" ^
@@ -170,7 +173,7 @@
test_cnf_bool ("(P(x) and P(a)) or (P(x) and P(b)) or (P(x) and P(c))" ^
" or (P(x) and P(d)) or (not P(x) and Q(a))" ^
" or (not P(x) and Q(b)) or (not P(x) and Q(c))")
- ("((P(d) or P(c) or P(b) or P(a) or (not P(x))) " ^
+ ("((P(d) or P(c) or P(b) or P(a) or not P(x)) " ^
"and (Q(c) or Q(b) or Q(a) or P(x)))");
);
@@ -413,10 +416,7 @@
let main () =
- Gc.set { (Gc.get()) with
- Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
- Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ Aux.set_optimized_gc ();
let (file) = (ref "") in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_elim true), "be verbose");
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -107,10 +107,7 @@
let main () =
- Gc.set { (Gc.get()) with
- Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
- Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ Aux.set_optimized_gc ();
let (file, print_bool, debug_level) = (ref "", ref false, ref 0) in
let dbg_level i = (debug_level := i; BoolFunction.set_debug_level i) in
let (only_inline, only_fp, nf) = (ref false, ref false, ref 0) in
@@ -128,7 +125,7 @@
"do not compute the goal, but resolve the fixed-points");
] in
Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
- if !file = "" then ignore (OUnit.run_test_tt tests) else
+ if !file = "" then ignore (OUnit.run_test_tt ~verbose:true tests) else
let f = open_in !file in
let file_s = Aux.input_file f in
close_in f;
Modified: trunk/Toss/Formula/FFTNFTest.ml
===================================================================
--- trunk/Toss/Formula/FFTNFTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/FFTNFTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -17,7 +17,7 @@
let winQxyz =
"ex x, y, z ((((Q(x) and Q(y)) and Q(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
let winQzyx =
- "ex z, y, x ((Q(x) and Q(y) and Q(z) and ((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v ((R(x, v) and C(v, y) and R(y, u) and C(u, z))) or ex u, v ((R(x, v) and C(y, v) and R(y, u) and C(z, u))))))"
+ "ex z, y, x (Q(x) and Q(y) and Q(z) and ((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v (R(x, v) and C(v, y) and R(y, u) and C(u, z)) or ex u, v (R(x, v) and C(y, v) and R(y, u) and C(z, u))))"
let winPxyz =
"ex x, y, z ((((P(x) and P(y)) and P(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
@@ -25,12 +25,12 @@
let winQvwxyz =
"ex v, w, x, y, z ((((((Q(v) and Q(w)) and Q(x)) and Q(y)) and Q(z)) and ((((((R(v, w) and R(w, x)) and R(x, y)) and R(y, z)) or (((C(v, w) and C(w, x)) and C(x, y)) and C(y, z))) or ex r, s, t, u ((((((((R(v, r) and C(r, w)) and R(w, s)) and C(s, x)) and R(x, t)) and C(t, y)) and R(y, u)) and C(u, z)))) or ex r, s, t, u ((((((((R(v, r) and C(w, r)) and R(w, s)) and C(x, s)) and R(x, t)) and C(y, t)) and R(y, u)) and C(z, u))))))"
-let breakW_expanded = "ex y8 ((W(y8) and ex y7 ((C(y7, y8) and ex y6 ((C(y6, y7) and ex y5 ((C(y5, y6) and ex y4 ((C(y4, y5) and ex y3 ((C(y3, y4) and ex y2 ((C(y2, y3) and ex y1 (C(y1, y2))))))))))))))))"
+let breakW_expanded = "ex y8 (W(y8) and ex y7 (C(y7, y8) and ex y6 (C(y6, y7) and ex y5 (C(y5, y6) and ex y4 (C(y4, y5) and ex y3 (C(y3, y4) and ex y2 (C(y2, y3) and ex y1 C(y1, y2))))))))"
-let winQvwxyz_expanded = "ex v ((Q(v) and (ex w ((R(v, w) and Q(w) and ex x ((R(w, x) and Q(x) and ex y ((R(x, y) and Q(y) and ex z ((R(y, z) and Q(z))))))))) or ex w ((C(v, w) and Q(w) and ex x ((C(w, x) and Q(x) and ex y ((C(x, y) and Q(y) and ex z ((C(y, z) and Q(z))))))))) or ex r0 ((R(v, r0) and ex w ((C(r0, w) and Q(w) and ex s0 ((R(w, s0) and ex x ((C(s0, x) and Q(x) and ex t0 ((R(x, t0) and ex y ((C(t0, y) and Q(y) and ex u0 ((R(y, u0) and ex z ((C(u0, z) and Q(z))))))))))))))))) or ex r ((R(v, r) and ex w ((C(w, r) and Q(w) and ex s ((R(w, s) and ex x ((C(x, s) and Q(x) and ex t ((R(x, t) and ex y ((C(y, t) and Q(y) and ex u ((R(y, u) and ex z ((C(z, u) and Q(z))))))))))))))))))))"
+let winQvwxyz_expanded = "ex v (Q(v) and (ex w (R(v, w) and Q(w) and ex x (R(w, x) and Q(x) and ex y (R(x, y) and Q(y) and ex z (R(y, z) and Q(z))))) or ex w (C(v, w) and Q(w) and ex x (C(w, x) and Q(x) and ex y (C(x, y) and Q(y) and ex z (C(y, z) and Q(z))))) or ex r0 (R(v, r0) and ex w (C(r0, w) and Q(w) and ex s0 (R(w, s0) and ex x (C(s0, x) and Q(x) and ex t0 (R(x, t0) and ex y (C(t0, y) and Q(y) and ex u0 (R(y, u0) and ex z (C(u0, z) and Q(z))))))))) or ex r (R(v, r) and ex w (C(w, r) and Q(w) and ex s (R(w, s) and ex x (C(x, s) and Q(x) and ex t (R(x, t) and ex y (C(y, t) and Q(y) and ex u (R(y, u) and ex z (C(z, u) and Q(z)))))))))))"
(* Alpha-conversion of the above. *)
-let winQvwxyz_idempotent = "ex v ((Q(v) and (ex w2 ((R(v, w2) and Q(w2) and ex x2 ((R(w2, x2) and Q(x2) and ex y2 ((R(x2, y2) and Q(y2) and ex z2 ((R(y2, z2) and Q(z2))))))))) or ex w1 ((C(v, w1) and Q(w1) and ex x1 ((C(w1, x1) and Q(x1) and ex y1 ((C(x1, y1) and Q(y1) and ex z1 ((C(y1, z1) and Q(z1))))))))) or ex r0 ((R(v, r0) and ex w0 ((C(r0, w0) and Q(w0) and ex s0 ((R(w0, s0) and ex x0 ((C(s0, x0) and Q(x0) and ex t0 ((R(x0, t0) and ex y0 ((C(t0, y0) and Q(y0) and ex u0 ((R(y0, u0) and ex z0 ((C(u0, z0) and Q(z0))))))))))))))))) or ex r ((R(v, r) and ex w ((C(w, r) and Q(w) and ex s ((R(w, s) and ex x ((C(x, s) and Q(x) and ex t ((R(x, t) and ex y ((C(y, t) and Q(y) and ex u ((R(y, u) and ex z ((C(z, u) and Q(z))))))))))))))))))))"
+let winQvwxyz_idempotent = "ex v (Q(v) and (ex w2 (R(v, w2) and Q(w2) and ex x2 (R(w2, x2) and Q(x2) and ex y2 (R(x2, y2) and Q(y2) and ex z2 (R(y2, z2) and Q(z2))))) or ex w1 (C(v, w1) and Q(w1) and ex x1 (C(w1, x1) and Q(x1) and ex y1 (C(x1, y1) and Q(y1) and ex z1 (C(y1, z1) and Q(z1))))) or ex r0 (R(v, r0) and ex w0 (C(r0, w0) and Q(w0) and ex s0 (R(w0, s0) and ex x0 (C(s0, x0) and Q(x0) and ex t0 (R(x0, t0) and ex y0 (C(t0, y0) and Q(y0) and ex u0 (R(y0, u0) and ex z0 (C(u0, z0) and Q(z0))))))))) or ex r (R(v, r) and ex w (C(w, r) and Q(w) and ex s (R(w, s) and ex x (C(x, s) and Q(x) and ex t (R(x, t) and ex y (C(y, t) and Q(y) and ex u (R(y, u) and ex z (C(z, u) and Q(z)))))))))))"
let formula_of_guards posi_frels nega_frels phi =
let guards = FFTNF.ffsep posi_frels nega_frels phi in
@@ -44,24 +44,31 @@
| _ -> Formula.Or parts
+let assert_eq_str ?(msg="") x_in y_in =
+ let ws = Str.regexp "[ \n\t]+" in
+ let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
+ let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ assert_equal ~printer:(fun x -> x) ~msg ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
+
let tests = "FFTNF" >::: [
"pn_nnf: subtasks and renaming" >::
(fun () ->
assert_equal ~printer:(fun x->x) ~msg:"subtask, no renaming"
- "ex x ((P(x) and (not ex x ((not Q(x))))))"
+ "ex x (P(x) and not ex x not Q(x))"
(Formula.str (FFTNF.p_pn_nnf
(formula_of_str "ex x P(x) and all x Q(x)")));
assert_equal ~printer:(fun x->x)
- "ex x, y (all x0 ((P(x) and (not R(x0, y)))))"
+ "ex x, y all x0 (P(x) and not R(x0, y))"
(Formula.str (FFTNF.p_pn_nnf
- (formula_of_str "ex x,y (P(x) and (not (ex x R(x,y))))")));
+ (formula_of_str "ex x,y (P(x) and not ex x R(x,y))")));
(* "subtask": negated existential without free variables *)
assert_equal ~printer:(fun x->x)
- "ex x ((P(x) and (not ex x (Q(x)))))"
+ "ex x (P(x) and not ex x Q(x))"
(Formula.str (FFTNF.p_pn_nnf
- (formula_of_str "ex x (P(x) and (not ex x Q(x)))")));
+ (formula_of_str "ex x (P(x) and not ex x Q(x))")));
assert_equal ~printer:(fun x->x)
- "ex x (ex x0 ((P(x) and (not Q(x0)))))"
+ "ex x ex x0 (P(x) and not Q(x0))"
(Formula.str (FFTNF.p_pn_nnf
(formula_of_str "ex x (P(x) and (not (all x Q(x))))")));
);
@@ -69,19 +76,19 @@
"pn_nnf: subtasks and merging" >::
(fun () ->
assert_equal ~printer:(fun x->x)
- "ex z (((not ex x (all y ((not R(x, y))))) and Q(z)))"
+ "ex z (not ex x all y not R(x, y) and Q(z))"
(Formula.str (FFTNF.p_pn_nnf
(formula_of_str "(all x ex y R(x,y)) and (ex z Q(z))")));
assert_equal ~printer:(fun x->x) ~msg:"one subtask, merge rest"
- "ex y (ex v (all w (all z ((((not ex x ((not P(x)))) and R(y, z)) and C(v, w))))))"
+ "ex y ex v all w all z (not ex x not P(x) and R(y, z) and C(v, w))"
(Formula.str (FFTNF.p_pn_nnf
(formula_of_str "all x P(x) and ex y (all z R(y,z)) and ex v (all w C(v,w))")));
assert_equal ~printer:(fun x->x) ~msg:"subtask breaks PNF"
- "ex y (all z (ex v (((not ex x (all y (ex v (((not Q(v)) or (not R(x, y))))))) and (P(v) and R(y, z))))))"
+ "ex y\n all z\n ex v (not ex x all y ex v (not Q(v) or not R(x, y)) and P(v) and R(y, z))"
(Formula.str (FFTNF.p_pn_nnf
(formula_of_str "all x (ex y (all v (Q(v) and R(x,y)))) and ex y (all z (ex v (P(v) and R(y,z))))")));
assert_equal ~printer:(fun x->x) ~msg:"no subtask: free dependent"
- "ex y (all z (all x (ex y0 (ex v (all v0 ((((P(f) and Q(v0)) and R(x, y0)) and (P(v) and R(y, z)))))))))"
+ "ex y\n all z\n all x ex y0 ex v all v0 (P(f) and Q(v0) and R(x, y0) and P(v) and R(y, z))"
(Formula.str (FFTNF.p_pn_nnf
(formula_of_str "all x (ex y (all v (P(f) and Q(v) and R(x,y)))) and ex y (all z (ex v (P(v) and R(y,z))))")));
);
@@ -132,8 +139,8 @@
(fun () ->
(* R(x, y) comes before Q(y) etc. because x is an older
variable in the result. *)
- assert_equal ~printer:(fun x->x)
- "ex x ((Q(x) and (ex y ((R(x, y) and Q(y) and ex z ((R(y, z) and Q(z))))) or ex y ((C(x, y) and Q(y) and ex z ((C(y, z) and Q(z))))) or ex v0 ((R(x, v0) and ex y ((C(v0, y) and Q(y) and ex u0 ((R(y, u0) and ex z ((C(u0, z) and Q(z))))))))) or ex v ((R(x, v) and ex y ((C(y, v) and Q(y) and ex u ((R(y, u) and ex z ((C(z, u) and Q(z))))))))))))"
+ assert_eq_str
+ "ex x (Q(x) and (ex y (R(x, y) and Q(y) and ex z (R(y, z) and Q(z))) or ex y (C(x, y) and Q(y) and ex z (C(y, z) and Q(z))) or ex v0 (R(x, v0) and ex y (C(v0, y) and Q(y) and ex u0 (R(y, u0) and ex z (C(u0, z) and Q(z))))) or ex v (R(x, v) and ex y (C(y, v) and Q(y) and ex u (R(y, u) and ex z (C(z, u) and Q(z)))))))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str winQxyz)));
@@ -141,15 +148,15 @@
"ffsep: tic-tac-toe" >::
(fun () ->
- assert_equal ~printer:(fun x->x) ~msg:"simple idempotence"
+ assert_eq_str ~msg:"simple idempotence"
winQzyx
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
(formula_of_str winQzyx)));
- assert_equal ~printer:(fun x->x) ~msg:"reversing ff_tnf"
- "(ex z, y, x ((Q(z) and Q(y) and Q(x) and ex u0 ((ex v0 ((R(x, v0) and C(v0, y))) and R(y, u0) and C(u0, z))))) or ex z, y, x ((Q(z) and Q(y) and Q(x) and ex u ((ex v ((R(x, v) and C(y, v))) and R(y, u) and C(z, u))))) or ex z, y, x ((Q(z) and Q(y) and Q(x) and (R(x, y) and R(y, z)))) or ex z, y, x ((Q(z) and Q(y) and Q(x) and (C(x, y) and C(y, z)))))"
+ assert_eq_str ~msg:"reversing ff_tnf"
+ "ex z, y, x (Q(z) and Q(y) and Q(x) and ex u0 (ex v0 (R(x, v0) and C(v0, y)) and R(y, u0) and C(u0, z))) or ex z, y, x (Q(z) and Q(y) and Q(x) and ex u (ex v (R(x, v) and C(y, v)) and R(y, u) and C(z, u))) or ex z, y, x (Q(z) and Q(y) and Q(x) and R(x, y) and R(y, z)) or ex z, y, x (Q(z) and Q(y) and Q(x) and C(x, y) and C(y, z))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
@@ -159,7 +166,7 @@
"ff_tnf: breakthrough" >::
(fun () ->
- assert_equal ~printer:(fun x->x)
+ assert_eq_str
breakW_expanded
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["W"; "B"]))
@@ -168,7 +175,7 @@
"ff_tnf: idempotent breakthrough" >::
(fun () ->
- assert_equal ~printer:(fun x->x)
+ assert_eq_str
breakW_expanded
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["W"; "B"]))
@@ -177,7 +184,7 @@
"ff_tnf: gomoku" >::
(fun () ->
- assert_equal ~printer:(fun x->x)
+ assert_eq_str
winQvwxyz_expanded
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
@@ -186,7 +193,7 @@
"ff_tnf: idempotent gomoku" >::
(fun () ->
- assert_equal ~printer:(fun x->x)
+ assert_eq_str
winQvwxyz_idempotent
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
@@ -196,38 +203,38 @@
"ff_tnf: deep" >::
(fun () ->
(* pulling out P first breaks the disjunction *)
- assert_equal ~printer:(fun x->x) ~msg:"#1"
- "(ex z (((not Q(z)) and ex x, y ((not R(x, y))))) or ex x ((P(x) and ex z (((not Q(z)) and ex y (C(y, z)))))))"
+ assert_eq_str ~msg:"#1"
+ "ex z (not Q(z) and ex x, y not R(x, y)) or ex x (P(x) and ex z (not Q(z) and ex y C(y, z)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y, z ((not R(x,y) or (P(x) and C(y,z))) and not Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#1.5"
- "ex z (((not Q(z)) and (ex y ((C(y, z) and ex x (P(x)))) or ex x, y ((not R(x, y))))))"
+ assert_eq_str ~msg:"#1.5"
+ "ex z (not Q(z) and (ex y (C(y, z) and ex x P(x)) or ex x, y not R(x, y)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y, z (not Q(z) and (not R(x,y) or (P(x) and C(y,z))))")));
- assert_equal ~printer:(fun x->x) ~msg:"#2"
- "(ex z (((not Q(z)) and ex x, y ((not R(x, y))))) or ex x (((not P(x)) and ex z (((not Q(z)) and ex y ((not C(y, z))))))))"
+ assert_eq_str ~msg:"#2"
+ "ex z (not Q(z) and ex x, y not R(x, y)) or ex x (not P(x) and ex z (not Q(z) and ex y not C(y, z)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y, z not ((R(x,y) and (P(x) or C(y,z))) or Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#2.5"
- "ex z (((not Q(z)) and (ex y (((not C(y, z)) and ex x ((not P(x))))) or ex x, y ((not R(x, y))))))"
+ assert_eq_str ~msg:"#2.5"
+ "ex z (not Q(z) and (ex y (not C(y, z) and ex x not P(x)) or ex x, y not R(x, y)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y, z not (Q(z) or (R(x,y) and (P(x) or C(y,z))))")));
- assert_equal ~printer:(fun x->x) ~msg:"#3"
- "(ex x ((P(x) and ex y (R(x, y)))) or ex z ((Q(z) or ex y ((C(y, z) and ex x (R(x, y)))))))"
+ assert_eq_str ~msg:"#3"
+ "ex x (P(x) and ex y R(x, y)) or ex z (Q(z) or ex y (C(y, z) and ex x R(x, y)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y, z ((R(x,y) and (P(x) or C(y,z))) or Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#4"
- "(ex z ((Q(z) and ex x (C(x, z)))) or ex x ((P(x) and ex y ((R(x, y) and ex z (C(x, z)))))) or ex y, z ((C(y, z) and ex x ((C(x, z) and R(x, y))))))"
+ assert_eq_str ~msg:"#4"
+ "ex z (Q(z) and ex x C(x, z)) or ex x (P(x) and ex y (R(x, y) and ex z C(x, z))) or ex y, z (C(y, z) and ex x (C(x, z) and R(x, y)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y, z (C(x, z) and ((R(x,y) and (P(x) or C(y,z))) or Q(z)))")));
@@ -236,30 +243,30 @@
"ffsep: deep" >::
(fun () ->
(* only pulls out positive fluents *)
- assert_equal ~printer:(fun x->x) ~msg:"#1"
- "(ex y, z (((not R(x, y)) and (not Q(z)))) or ex x ((P(x) and ex y, z ((C(y, z) and (not Q(z)))))))"
+ assert_eq_str ~msg:"#1"
+ "ex y, z (not R(x, y) and not Q(z)) or ex x (P(x) and ex y, z (C(y, z) and not Q(z)))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
(formula_of_str "ex x, y, z ((not R(x,y) or (P(x) and C(y,z))) and not Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#2"
- "ex z ((Q(z) and ex x, y ((not (R(x, y) and (P(x) or C(y, z)))))))"
+ assert_eq_str ~msg:"#2"
+ "ex z (Q(z) and ex x, y not (R(x, y) and (P(x) or C(y, z))))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
(formula_of_str "ex x, y, z not ((R(x,y) and (P(x) or C(y,z))) or not Q(z))")));
(* TODO? simplify the result *)
- assert_equal ~printer:(fun x->x) ~msg:"#3"
- "(ex y ((C(y, z) and R(x, y))) or ex z ((Q(z) and ex y (true))) or ex x ((P(x) and ex y (R(x, y)))))"
+ assert_eq_str ~msg:"#3"
+ "ex y (C(y, z) and R(x, y)) or ex z (Q(z) and ex y true) or ex x (P(x) and ex y R(x, y))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
(formula_of_str "ex x, y, z ((R(x,y) and (P(x) or C(y,z))) or Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#4"
- "(ex y ((C(y, z) and R(x, y) and C(x, z))) or ex z ((Q(z) and ex y (C(x, z)))) or ex x ((P(x) and ex y ((R(x, y) and C(x, z))))))"
+ assert_eq_str ~msg:"#4"
+ "ex y (C(y, z) and R(x, y) and C(x, z)) or ex z (Q(z) and ex y C(x, z)) or ex x (P(x) and ex y (R(x, y) and C(x, z)))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"; "Q"])
Aux.Strings.empty
@@ -267,30 +274,30 @@
(* interpretation warning: in cases below, pulled-out "Q" in the
result represents "not Q" actually (a negative literal) *)
- assert_equal ~printer:(fun x->x) ~msg:"#5"
- "(ex z ((Q(z) and ex y ((not R(x, y))))) or ex z, x ((P(x) and Q(z) and ex y (C(y, z)))))"
+ assert_eq_str ~msg:"#5"
+ "ex z (Q(z) and ex y not R(x, y)) or ex z, x (P(x) and Q(z) and ex y C(y, z))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"])
(Aux.strings_of_list ["Q"])
(formula_of_str "ex x, y, z ((not R(x,y) or (P(x) and C(y,z))) and not Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#6"
- "ex x, y, z ((not ((R(x, y) and (P(x) or C(y, z))) or (not Q(z)))))"
+ assert_eq_str ~msg:"#6"
+ "ex x, y, z not ((R(x, y) and (P(x) or C(y, z))) or not Q(z))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"])
(Aux.strings_of_list ["Q"])
(formula_of_str "ex x, y, z not ((R(x,y) and (P(x) or C(y,z))) or not Q(z))")));
(* distributes to extract P, not because of Q *)
- assert_equal ~printer:(fun x->x) ~msg:"#7"
- "(ex y, z ((Q(z) or (C(y, z) and R(x, y)))) or ex x ((P(x) and ex y, z (R(x, y)))))"
+ assert_eq_str ~msg:"#7"
+ "ex y, z (Q(z) or (C(y, z) and R(x, y))) or ex x (P(x) and ex y, z R(x, y))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"])
(Aux.strings_of_list ["Q"])
(formula_of_str "ex x, y, z ((R(x,y) and (P(x) or C(y,z))) or Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#8"
- "(ex y ((C(y, z) and R(x, y) and C(x, z))) or ex z ((Q(z) and ex y (C(x, z)))) or ex x ((P(x) and ex y ((R(x, y) and C(x, z))))))"
+ assert_eq_str ~msg:"#8"
+ "ex y (C(y, z) and R(x, y) and C(x, z)) or ex z (Q(z) and ex y C(x, z)) or ex x (P(x) and ex y (R(x, y) and C(x, z)))"
(Formula.str (
formula_of_guards (Aux.strings_of_list ["P"])
(Aux.strings_of_list ["Q"])
@@ -300,20 +307,20 @@
"ff_tnf: simple subtasks" >::
(fun () ->
- assert_equal ~printer:(fun x->x) ~msg:"#1"
- "(not (ex z (((not Q(z)) and ex x, y ((not R(x, y))))) or ex x (((not P(x)) and ex z (((not Q(z)) and ex y ((not C(y, z)))))))))"
+ assert_eq_str ~msg:"#1"
+ "not (ex z (not Q(z) and ex x, y not R(x, y)) or ex x (not P(x) and ex z (not Q(z) and ex y not C(y, z))))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "all x, y, z ((R(x,y) and (P(x) or C(y,z))) or Q(z))")));
- assert_equal ~printer:(fun x->x) ~msg:"#1.5"
- "(not ex z (((not Q(z)) and (ex y (((not C(y, z)) and ex x ((not P(x))))) or ex x, y ((not R(x, y)))))))"
+ assert_eq_str ~msg:"#1.5"
+ "not ex z (not Q(z) and (ex y (not C(y, z) and ex x not P(x)) or ex x, y not R(x, y)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "all x, y, z (Q(z) or (R(x,y) and (P(x) or C(y,z))))")));
- assert_equal ~printer:(fun x->x) ~msg:"#2"
- "(((not ex z ((not Q(z)))) and ex y (P(y))) or ex x, y (C(x, y)))"
+ assert_eq_str ~msg:"#2"
+ "(not ex z not Q(z) and ex y P(y)) or ex x, y C(x, y)"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str "ex x, y (C(x, y) or (P(y) and all z Q(z)))")));
@@ -330,8 +337,8 @@
ex t, u ((R(y, u) and R(x, t) and C(u, z)
and C(t, y))) or ex t, u ((C(z, u) and
R(y, u) and C(y, t) and R(x, t)))) and P(z) and P(y) and P(x)))))" in
- assert_equal ~printer:(fun x->x)
- "((not ex z ((P(z) and (ex y ((C(y, z) and P(y) and ex x ((C(x, y) and P(x))))) or ex y ((R(y, z) and P(y) and ex x ((R(x, y) and P(x))))) or ex u0 ((C(u0, z) and ex y ((R(y, u0) and P(y) and ex t0 ((C(t0, y) and ex x ((R(x, t0) and P(x))))))))) or ex u ((C(z, u) and ex y ((R(y, u) and P(y) and ex t ((C(y, t) and ex x ((R(x, t) and P(x))))))))))))) and (not P(x)) and (not P(y)) and (not P(z)) and ((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u0 ((C(z, u0) and R(y, u0) and ex t0 ((C(y, t0) and R(x, t0))))) or ex u ((R(y, u) and C(u, z) and ex t ((R(x, t) and C(t, y)))))) and (Q(z) or Q(y) or Q(x)))"
+ assert_eq_str
+ "(not ex z (P(z) and (ex y (C(y, z) and P(y) and ex x (C(x, y) and P(x))) or ex y (R(y, z) and P(y) and ex x (R(x, y) and P(x))) or ex u0 (C(u0, z) and ex y (R(y, u0) and P(y) and ex t0 (C(t0, y) and ex x (R(x, t0) and P(x))))) or ex u (C(z, u) and ex y (R(y, u) and P(y) and ex t (C(y, t) and ex x (R(x, t) and P(x))))))) and not P(x) and not P(y) and not P(z) and ((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u0 (C(z, u0) and R(y, u0) and ex t0 (C(y, t0) and R(x, t0))) or ex u (R(y, u) and C(u, z) and ex t (R(x, t) and C(t, y)))) and (Q(z) or Q(y) or Q(x)))"
(Formula.str (FFTNF.ff_tnf
(FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"]))
(formula_of_str heur_phi)));
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/Formula.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -128,51 +128,28 @@
(* ----------------------- PRINTING FUNCTIONS ------------------------------- *)
-(* Print a formula as a string. *)
-let rec str = function
- Rel (s, vars) -> s ^ "(" ^ (var_tup_str vars) ^ ")"
- | Eq (x, y) -> "(" ^ (var_str x) ^ " = " ^ (var_str y) ^ ")"
- | In (x, y) -> "(" ^ (var_str x) ^ " in " ^ (var_str y) ^ ")"
- | RealExpr (p, s) -> "(" ^ (real_str p) ^ (sign_op_str s) ^ ")"
- | Not phi -> "(not " ^ (str phi) ^ ")"
- | And [] -> "true"
- | Or [] -> "false"
- | And (flist) -> f_list_str " and " flist
- | Or (flist) -> f_list_str " or " flist
- | Ex (x, phi) -> "ex " ^ (var_list_str x) ^ " (" ^ (str phi) ^ ")"
- | All (x, phi) -> "all " ^ (var_list_str x) ^ " ("^ (str phi) ^ ")"
-
-and f_list_str sep = function
- [] -> "[]"
- | [phi] -> str phi
- | lst -> "(" ^ (String.concat sep (List.map str lst)) ^ ")"
-
-and real_str = function
- RVar s -> s
- | Const f -> string_of_float f
- | Times (r1, r2) -> "(" ^ (real_str r1) ^ " * " ^ (real_str r2) ^ ")"
- | Plus (r1, r2) -> "(" ^ (real_str r1) ^ " + " ^ (real_str r2) ^ ")"
- | Fun (s, v) -> ":" ^ s ^ "(" ^ (var_str v) ^ ")"
- | Char phi -> ":(" ^ (str phi) ^ ")"
- | Sum (vl, f, r) ->
- "Sum (" ^ (var_list_str vl) ^ " | " ^ (str f) ^ " : " ^ (real_str r) ^ ")"
-
-
let rec mona_str = function
- Rel (s, vars) -> s ^ "(" ^ (var_tup_str vars) ^ ")"
+ | Rel (s, vars) -> s ^ "(" ^ (var_tup_str vars) ^ ")"
| Eq (x, y) -> "(" ^ (var_str x) ^ " = " ^ (var_str y) ^ ")"
| In (x, y) -> "(" ^ (var_str x) ^ " in " ^ (var_str y) ^ ")"
- | RealExpr (p, s) -> "(" ^ (real_str p) ^ (sign_op_str s) ^ ")"
| Not phi -> "(~ " ^ (mona_str phi) ^ ")"
| And [] -> "true"
| Or [] -> "false"
| And (flist) -> f_list_str " & " flist
| Or (flist) -> f_list_str " | " flist
- | Ex (x, phi) -> (String.concat " " (List.map (fun x -> if (is_fo x) then "ex1 " ^ (var_str x) ^ ": " else "ex2 " ^ (var_str x) ^ ": ") x)) ^ (mona_str phi)
- | All (x, phi) -> (String.concat " " (List.map (fun x -> if (is_fo x) then "all1 " ^ (var_str x) ^ ": " else "all2 " ^ (var_str x) ^ ": ") x)) ^ (mona_str phi)
+ | Ex (x, phi) ->
+ (String.concat " " (List.map (fun x ->
+ if (is_fo x) then "ex1 " ^ (var_str x) ^ ": " else
+ "ex2 " ^ (var_str x) ^ ": ") x)) ^ (mona_str phi)
+ | All (x, phi) ->
+ (String.concat " " (List.map (fun x ->
+ if (is_fo x) then "all1 " ^ (var_str x) ^ ": " else
+ "all2 " ^ (var_str x) ^ ": ") x)) ^ (mona_str phi)
+ | _ ->
+ failwith "real-valued expressions and fixed-points not supported in MONA"
and f_list_str sep = function
- [] -> "[]"
+ | [] -> "[]"
| [phi] -> mona_str phi
| lst -> "(" ^ (String.concat sep (List.map mona_str lst)) ^ ")"
@@ -182,9 +159,9 @@
(* Bracket-savvy encodings: 0 or, 1 and, 2 not ex all *)
let rec fprint_prec prec f = function
- Rel (s, vars) ->
- Format.fprintf f "%s(%a)" s
- (Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
+ | Rel (s, vars) ->
+ Format.fprintf f "%s(%a)" s
+ (Aux.fprint_sep_list "," fprint_var) (Array.to_list vars)
| Eq (x, y) -> Format.fprintf f "%s = %s" (var_str x) (var_str y)
| In (x, y) -> Format.fprintf f "%s in %s" (var_str x) (var_str y)
| RealExpr (p, s) ->
@@ -213,10 +190,18 @@
let lb, rb = if prec > 2 then "(", ")" else "", "" in
Format.fprintf f "@[<1>%sall@ %a@ %a%s@]" lb
(Aux.fprint_sep_list "," fprint_var) x (fprint_prec 2) phi rb
+ | Lfp (r, vs, fpphi) ->
+ Format.fprintf f "@[<1>(lfp %a(%a) = %a)@]" fprint_var r
+ (Aux.fprint_sep_list "," fprint_var) (Array.to_list vs)
+ (fprint_prec prec) fpphi
+ | Gfp (r, vs, fpphi) ->
+ Format.fprintf f "@[<1>(gfp %a(%a) = %a)@]" fprint_var r
+ (Aux.fprint_sep_list "," fprint_var) (Array.to_list vs)
+ (fprint_prec prec) fpphi
(* Bracket-savvy precedences: 0 +, 2 * *)
and fprint_real_prec prec f = function
- RVar s -> Format.fprintf f "%s" s
+ | RVar s -> Format.fprintf f "%s" s
| Const fl -> Format.fprintf f "%F" fl
| Times (r1, r2) ->
let lb, rb =
@@ -249,8 +234,9 @@
Format.fprintf Format.str_formatter "@[%a@]" fprint_real r;
Format.flush_str_formatter ()
+let str = sprint
+let real_str = sprint_real
-
(* ------------------------ ORDER ON FORMULAS ------------------------------- *)
(* Compare two variables. We assume that FO < MSO < SO < Real. *)
@@ -296,7 +282,8 @@
let rec size ?(acc=0) = function
| Rel _ | Eq _ | In _ | RealExpr _ -> acc + 1
- | Not phi | Ex (_, phi) | All (_, phi) -> size ~acc:(acc + 1) phi
+ | Not phi | Ex (_, phi) | All (_, phi) | Lfp (_,_,phi) | Gfp (_,_,phi) ->
+ size ~acc:(acc + 1) phi
| And flist | Or flist ->
List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
@@ -336,6 +323,15 @@
if c <> 0 then c else rec_compare psi1 psi2
| (All _, _) -> -1
| (_, All _) -> 1
+ | (Ex _, _) -> -1
+ | (_, Ex _) -> 1
+ | (Lfp (r1, vs1, psi1), Lfp (r2, vs2, psi2))
+ | (Gfp (r1, vs1, psi1), Gfp (r2, vs2, psi2)) ->
+ let c = compare_vars r1 r2 in if c <> 0 then c else
+ let d = compare_var_tups vs1 vs2 in if d <> 0 then d else
+ rec_compare psi1 psi2
+ | (Lfp _, _) -> -1
+ | (_, Lfp _) -> 1
and rec_compare_re re1 re2 =
match (re1, re2) with
@@ -351,59 +347,6 @@
(* --------------- BASIC HELPER FUNCTIONS USED IN PARSER ------------------- *)
-(* Helper function: delete duplicates in ordered list. *)
-let rec del_dupl_ord acc = function
- [] -> List.rev acc
- | [x] -> List.rev (x :: acc)
- | x :: y :: xs when x = y -> del_dupl_ord acc (y :: xs)
- | x :: y :: xs -> del_dupl_ord (x :: acc) (y :: xs)
-
-let rec is_lit = function
- Rel _ | Eq _ | In _ -> true
- | Not f -> is_lit f
- | _ -> false
-
-let negl = function
- Not f -> f
- | f -> Not f
-
-let rec set_lit_in_f l nl = function
- And flist ->
- let sflist = List.map (set_lit_in_f l nl) flist in
- if List.exists (fun f -> f = nl) sflist then Or[] else
- let nflist = List.filter (fun f -> f <> l) sflist in
- And (del_dupl_ord [] (List.sort compare nflist))
- | Or flist ->
- let sflist = List.map (set_lit_in_f l nl) flist in
- if List.exists (fun f -> f = l) sflist then And[] else
- let nflist = List.filter (fun f -> f <> nl) sflist in
- Or (del_dupl_ord [] (List.sort compare nflist))
- | x -> x
-
-let rec set_lit_or l acc = function
- [] -> (negl l) :: (List.rev acc)
- | v :: vs ->
- let set_v = set_lit_in_f l (negl l) v in
- if set_v = Or[] then set_lit_or l acc vs else set_lit_or l (set_v :: acc) vs
-
-let set_first_lit_or = function
- [] -> []
- | v :: vs when is_lit v -> set_lit_or (negl v) [] vs
- | x -> x
-
-
-let rec set_lit_and l acc = function
- [] -> l :: (List.rev acc)
- | v :: vs ->
- let set_v = set_lit_in_f l (negl l) v in
- if set_v = And[] then set_lit_and l acc vs else set_lit_and l (set_v :: acc) vs
-
-let set_first_lit_and = function
- [] -> []
- | v :: vs when is_lit v -> set_lit_and v [] vs
- | x -> x
-
-
(* Flatten conjunctions and disjunctions, apply f's to the respective lists.
This function also reduces false and true atoms and propagates them. *)
let rec flatten_f f_or f_and phi =
@@ -426,18 +369,28 @@
| Or [phi] -> flatten_f f_or f_and phi
| Or fl when List.exists (fun x -> x = And []) fl -> And []
| Or fl ->
- Or (rev_collect_disj (List.rev_map (flatten_f f_or f_and) fl))
+ let r= f_or (rev_collect_disj (List.rev_map (flatten_f f_or f_and) fl)) in
+ if List.exists (fun x -> x = And []) r then And [] else Or r
| And [phi] -> flatten_f f_or f_and phi
| And fl when List.exists (fun x -> x = Or []) fl -> Or []
| And fl ->
- And (rev_collect_conj (List.rev_map (flatten_f f_or f_and) fl))
- | Ex (_, Or []) | All (_, Or []) -> Or []
- | Ex (_, And []) | All (_, And []) -> And []
+ let r=f_and (rev_collect_conj (List.rev_map (flatten_f f_or f_and) fl)) in
+ if List.exists (fun x -> x = Or []) r then Or [] else And r
| Ex ([], phi) | All ([], phi) -> flatten_f f_or f_and phi
| Ex (xs, Ex (ys, phi)) -> flatten_f f_or f_and (Ex (xs @ ys, phi))
- | Ex (xs, phi) -> Ex (xs, flatten_f f_or f_and phi)
+ | Ex (xs, phi) ->
+ (match flatten_f f_or f_and phi with
+ | Or [] -> Or [] | And [] -> And [] | f -> Ex (xs, f))
| All (xs, All (ys, phi)) -> flatten_f f_or f_and (All (xs @ ys, phi))
- | All (xs, phi) -> All (xs, flatten_f f_or f_and phi)
+ | All (xs, phi) ->
+ (match flatten_f f_or f_and phi with
+ | Or [] -> Or [] | And [] -> And [] | f -> All (xs, f))
+ | Lfp (r, vs, phi) ->
+ (match flatten_f f_or f_and phi with
+ | Or [] -> Or [] | And [] -> And [] | f -> Lfp (r, vs, f))
+ | Gfp (r, vs, phi) ->
+ (match flatten_f f_or f_and phi with
+ | Or [] -> Or [] | And [] -> And [] | f -> Gfp (r, vs, f))
and flatten_re_f f_or f_and = function
| RVar _ | Const _ | Fun _ as re -> re
@@ -454,6 +407,71 @@
let flatten psi = flatten_f (fun x -> x) (fun x -> x) psi
let flatten_re psi = flatten_re_f (fun x -> x) (fun x -> x) psi
+
+
+(* ----- Flattening with very basic simplification and sorting. ----- *)
+
+(* Helper function: delete duplicates in ordered list. *)
+let rec del_dupl_ord acc = function
+ [] -> List.rev acc
+ | [x] -> List.rev (x :: acc)
+ | x :: y :: xs when x = y -> del_dupl_ord acc (y :: xs)
+ | x :: y :: xs -> del_dupl_ord (x :: acc) (y :: xs)
+
+let rec is_lit = function
+ | Rel _ | Eq _ | In _ -> true
+ | Not f -> is_lit f
+ | _ -> false
+
+let negl = function
+ | Not f -> f
+ | f -> Not f
+
+let rec set_lits_in_f lits nlits = function
+ | And flist ->
+ let sflist = List.rev_map (set_lits_in_f lits nlits) flist in
+ if List.exists (fun f -> List.mem f nlits) sflist then Or [] else
+ let nflist = List.filter (fun f -> not (List.mem f lits)) sflist in
+ (match del_dupl_ord [] (List.sort compare nflist) with
+ | [x] -> x
+ | l -> And l)
+ | Or flist ->
+ let sflist = List.rev_map (set_lits_in_f lits nlits) flist in
+ if List.exists (fun f -> List.mem f lits) sflist then And [] else
+ let nflist = List.filter (fun f -> not (List.mem f nlits)) sflist in
+ (match del_dupl_ord [] (List.sort compare nflist) with
+ | [x] -> x
+ | l -> Or l)
+ | x -> x
+
+let set_first_lit_or fl =
+ let rec set_lits_or lits nlits acc = function
+ | [] -> List.sort compare (nlits @ acc)
+ | v :: vs ->
+ let set_v = set_lits_in_f lits nlits v in
+ if set_v = And [] then [And []] else if set_v = Or [] then
+ set_lits_or lits nlits acc vs
+ else set_lits_or lits nlits (set_v :: acc) vs in
+ let (lits, rest) = List.partition is_lit fl in
+ if lits = [] then fl else
+ let nlits = List.rev_map negl lits in
+ if List.exists (fun l -> List.mem l nlits) lits then [And []] else
+ set_lits_or nlits lits [] rest
+
+let set_first_lit_and fl =
+ let rec set_lits_and lits nlits acc = function
+ | [] -> List.sort compare (lits @ acc)
+ | v :: vs ->
+ let set_v = set_lits_in_f lits nlits v in
+ if set_v = Or [] then [Or []] else if set_v = And [] then
+ set_lits_and lits nlits acc vs
+ else set_lits_and lits nlits (set_v :: acc) vs in
+ let (lits, rest) = List.partition is_lit fl in
+ if lits = [] then fl else
+ let nlits = List.rev_map negl lits in
+ if List.exists (fun l -> List.mem l nlits) lits then [Or []] else
+ set_lits_and lits nlits [] rest
+
let flatten_sort =
let clean fl = del_dupl_ord [] (List.sort compare fl) in
flatten_f (fun fl -> set_first_lit_or (clean fl))
@@ -463,72 +481,3 @@
let clean fl = del_dupl_ord [] (List.sort compare fl) in
flatten_re_f (fun fl -> set_first_lit_or (clean fl))
(fun fl -> set_first_lit_and (clean fl))
-
-
-(* Helper function to flatten multiple or's and and's and sort by compare. *)
-let rec flatten_sort = function
- Rel _ | Eq _ | In _ as phi -> phi
- | RealExpr (re, s) -> RealExpr (flatten_sort_re re, s)
- | Not (And []) -> Or[]
- | Not (Or []) -> And[]
- | Not phi -> let f = flatten_sort phi in if f = Or [] then And[] else if f = And[] then Or[] else Not f
- | Or flist_orig ->
- let flist = List.map flatten_sort flist_orig in
- let is_or = function Or _ -> true | _ -> false in
- let (ors_all, non_ors) = List.partition is_or flist in
- let ors = List.filter (fun v -> v <> Or []) ors_all in
- let flat_non_ors = List.rev_map flatten_sort non_ors in
- if List.exists (fun v -> v = And []) flat_non_ors then And [] else
- if ors = [] then
- Or (set_first_lit_or (del_dupl_ord [] (List.sort compare flat_non_ors)))
- else
- let fl = flatten_sort_ors [] ors in
- Or (set_first_lit_or (del_dupl_ord [] (List.sort compare (List.rev_append fl flat_non_ors))))
- | And flist_orig ->
- let flist = List.map flatten_sort flist_orig in
- let is_and = function And _ -> true | _ -> false in
- let (ands_all, non_ands) = List.partition is_and flist in
- let ands = List.filter (fun v -> v <> And []) ands_all in
- let flat_non_ands = List.rev_map flatten_sort non_ands in
- if List.exists (fun v -> v = Or []) flat_non_ands then Or [] else
- if ands = [] then
- And (set_first_lit_and (del_dupl_ord [] (List.sort compare flat_non_ands)))
- else
- let fl = flatten_sort_ands [] ands in
- And (set_first_lit_and (del_dupl_ord [] (List.sort compare (List.rev_append fl flat_non_ands))))
- | Ex (_, And[]) | All(_, And[]) -> And[]
- | Ex (_, Or[]) | All(_, Or[]) -> Or[]
- | Ex ([], phi) | All ([], phi) -> flatten_sort phi
- | Ex (xs, Ex (ys, phi)) -> flatten_sort (Ex (xs @ ys, phi))
- | Ex (xs, phi) -> Ex (xs, flatten_sort phi)
- | All (xs, All (ys, phi)) -> flatten_sort (All (xs @ ys, phi))
- | All (xs, phi) -> All (xs, flatten_sort phi)
-
-and flatten_sort_ors acc = function
- [] -> acc
- | (Or fl) :: ls ->
- let handle accu phi =
- match flatten_sort phi with
- Or fl -> List.rev_append fl accu
- | _ -> phi::accu in
- let new_acc = List.fold_left handle acc fl in
- flatten_sort_ors new_acc ls
- | _ -> failwith "flatten_sort_ors on a non-or"
-
-and flatten_sort_ands acc = function
- [] -> acc
- | (And fl) :: ls ->
- let handle accu phi =
- match flatten_sort phi with
- And fl -> List.rev_append fl accu
- | _ -> phi::accu in
- let new_acc = List.fold_left handle acc fl in
- flatten_sort_ands new_acc ls
- | _ -> failwith "flatten_sort_ands on a non-and"
-
-and flatten_sort_re = function
- RVar _ | Const _ | Fun _ as re -> re
- | Times (re1, re2) -> Times (flatten_sort_re re1, flatten_sort_re re2)
- | Plus (re1, re2) -> Plus (flatten_sort_re re1, flatten_sort_re re2)
- | Char (phi) -> Char (flatten_sort phi)
- | Sum (vl, f, r) -> Sum (vl, flatten_sort f, flatten_sort_re r)
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -27,17 +27,17 @@
(* Convert formula to NNF and additionally negate if [neg] is set. *)
let rec nnf ?(neg=false) psi =
match psi with
- Rel _ | Eq _ | In _ | RealExpr _ as atom -> if neg then Not atom else atom
- | Not phi -> if neg then nnf ~neg:false phi else nnf ~neg:true phi
- | And [f] | Or [f] -> nnf ~neg f
- | And (flist) when neg -> Or (List.map (nnf ~neg:true) flist)
- | And (flist) -> And (List.map (nnf ~neg:false) flist)
- | Or (flist) when neg -> And (List.map (nnf ~neg:true) flist)
- | Or (flist) -> Or (List.map (nnf ~neg:false) flist)
- | Ex (x, phi) when neg -> All (x, nnf ~neg:true phi)
- | Ex (x, phi) -> Ex (x, nnf ~neg:false phi)
- | All (x, phi) when neg -> Ex (x, nnf ~neg:true phi)
- | All (x, phi) -> All (x, nnf ~neg:false phi)
+ | Rel _ | Eq _ | In _ | RealExpr _ as atom -> if neg then Not atom else atom
+ | Not phi -> if neg then nnf ~neg:false phi else nnf ~neg:true phi
+ | And [f] | Or [f] -> nnf ~neg f
+ | And (flist) when neg -> Or (List.map (nnf ~neg:true) flist)
+ | And (flist) -> And (List.map (nnf ~neg:false) flist)
+ | Or (flist) when neg -> And (List.map (nnf ~neg:true) flist)
+ | Or (flist) -> Or (List.map (nnf ~neg:false) flist)
+ | Ex (x, phi) when neg -> All (x, nnf ~neg:true phi)
+ | Ex (x, phi) -> Ex (x, nnf ~neg:false phi)
+ | All (x, phi) when neg -> Ex (x, nnf ~neg:true phi)
+ | All (x, phi) -> All (x, nnf ~neg:false phi)
(* -------------------------- FREE VARIABLES -------------------------------- *)
@@ -52,45 +52,52 @@
| _ -> remove_dup_vars (v1::acc) (v2::vs)
let rec all_vars_acc acc = function
- Eq (x, y) -> (x :> var) :: (y :> var) :: acc
+ | Eq (x, y) -> (x :> var) :: (y :> var) :: acc
| Rel (r, vs) -> List.rev_append ((Array.to_list vs) :> var list) acc
| In (x, y) -> (x :> var) :: (y :> var) :: acc
| RealExpr (p, _) ->
List.rev_append (List.map(fun v -> var_of_string v) (all_vars_real p)) acc
| Not phi -> all_vars_acc acc phi
| And (flist) | Or (flist) ->
- List.fold_left (fun vs phi -> all_vars_acc vs phi) acc flist
+ List.fold_left (fun vs phi -> all_vars_acc vs phi) acc flist
| Ex (vs, phi) | All (vs, phi) ->
- all_vars_acc (List.rev_append (vs :> var list) acc) phi
+ all_vars_acc (List.rev_append (vs :> var list) acc) phi
+ | Lfp (r, vs, phi) | Gfp (r, vs, phi) ->
+ all_vars_acc
+ ((r :> var):: (List.rev_append ((Array.to_list vs) :> var list) acc)) phi
and all_vars_real = function
- RVar s -> [s]
+ | RVar s -> [s]
| Const _ -> []
| Times (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
| Plus (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
| Fun (s, v) -> [var_str v]
| Char phi -> List.rev_map var_str (all_vars_acc [] phi)
| Sum (_, f, r) ->
- List.rev_append (List.rev_map var_str (all_vars_acc [] f)) (all_vars_real r)
+ List.rev_append (List.rev_map var_str (all_vars_acc [] f)) (all_vars_real r)
let all_vars phi =
remove_dup_vars [] (List.sort compare_vars (all_vars_acc [] phi))
let rec free_vars_acc acc = function
- Eq (x, y) -> (x :> var) :: (y :> var) :: acc
+ | Eq (x, y) -> (x :> var) :: (y :> var) :: acc
| Rel (r, vs) -> List.rev_append (Array.to_list vs :> var list) acc
| In (x, y) -> (x :> var) :: (y :> var) :: acc
| RealExpr (p, _) ->
- List.rev_append (List.map (fun v->var_of_string v) (free_vars_real p)) acc
+ List.rev_append (List.map (fun v->var_of_string v) (free_vars_real p)) acc
| Not phi -> free_vars_acc acc phi
| And (flist) | Or (flist) ->
- List.fold_left (fun vs phi -> free_vars_acc vs phi) acc flist
+ List.fold_left (fun vs phi -> free_vars_acc vs phi) acc flist
| Ex (vs, phi) | All (vs, phi) ->
- let fv_phi = free_vars_acc [] phi in
- List.rev_append (List.filter (fun v -> not (List.mem v vs)) fv_phi) acc
+ let fv_phi = free_vars_acc [] phi in
+ List.rev_append (List.filter (fun v -> not (List.mem v vs)) fv_phi) acc
+ | Lfp (r, xs, phi) | Gfp (r, xs, phi) ->
+ let vs = (r :> var) :: ((Array.to_list xs) :> var list) in
+ let fv_phi = free_vars_acc [] phi in
+ List.rev_append (List.filter (fun v -> not (List.mem v vs)) fv_phi) acc
and free_vars_real = function
- RVar s -> [s]
+ | RVar s -> [s]
| Const _ -> []
| Times (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
| Plus (r1, r2) -> List.rev_append (all_vars_real r1) (all_vars_real r2)
@@ -103,19 +110,21 @@
let free_vars phi =
remove_dup_vars [] (List.sort compare_vars (free_vars_acc [] phi))
-(* Delete top-most quantification of [vs] in the formula. *)
+(* Delete top-most ex/all quantification of [vs] in the formula. *)
let rec del_vars_quant vs = function
- Eq _ | Rel _ | In _ | RealExpr _ as f -> f
+ | Eq _ | Rel _ | In _ | RealExpr _ as f -> f
| Not phi -> Not (del_vars_quant vs phi)
| And (flist) -> And (List.map (del_vars_quant vs) flist)
| Or (flist) -> Or (List.map (del_vars_quant vs) flist)
| Ex ([], phi) | All ([], phi) -> del_vars_quant vs phi
| Ex (v :: vr, phi) when List.mem v vs ->
- del_vars_quant (Aux.list_remove v vs) (Ex (vr, phi))
+ del_vars_quant (Aux.list_remove v vs) (Ex (vr, phi))
| Ex (v :: vr, phi) -> Ex ([v], del_vars_quant vs (Ex (vr, phi)))
| All (v :: vr, phi) when List.mem v vs ->
- del_vars_quant (Aux.list_remove v vs) (All (vr, phi))
- | All (v :: vr, phi) -> All ([v], del_vars_quant vs (Ex (vr, phi)))
+ del_vars_quant (Aux.list_remove v vs) (All (vr, phi))
+ | All (v :: vr, phi) -> All ([v], del_vars_quant vs (All (vr, phi)))
+ | Lfp (r, xs, phi) -> Lfp (r, xs, del_vars_quant vs phi)
+ | Gfp (r, xs, phi) -> Gfp (r, xs, del_vars_quant vs phi)
(* ----------------- MAPPING TO ATOMS AND VAR SUBSTITUTION ------------------ *)
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -11,10 +11,14 @@
FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)
;;
-let formula_eq f1 phi1 f2 phi2 =
- assert_equal ~printer:(fun x -> Formula.str x)
- (Formula.flatten (f1 (formula_of_string phi1)))
- (Formula.flatten (f2 (formula_of_string phi2)))
+let formula_eq ?(flatten=true) f1 phi1 f2 phi2 =
+ if flatten then
+ assert_equal ~printer:(fun x -> Formula.sprint x)
+ (Formula.flatten (f1 (formula_of_string phi1)))
+ (Formula.flatten (f2 (formula_of_string phi2)))
+ else
+ assert_equal ~printer:(fun x -> Formula.sprint x)
+ (f1 (formula_of_string phi1)) (f2 (formula_of_string phi2))
;;
let real_expr_eq f1 re1 f2 re2 =
@@ -167,13 +171,18 @@
fts_eq "all t ((t in X) or (not Succ(t, s)) or ((t in C) and (t in X)))"
"all t ((t in X) or (not Succ(t, s)))";
fts_eq "(not (t in X)) and ((t in X) or (not (t in C)))"
- "((not (t in X)) and (not (t in C)))";
+ "((not (t in C)) and (not (t in X)))";
fts_eq "all s ((((not (s in S)) and (not (s in X2))) or
((s in S) and (s in X2))))" "all s ((((s in S) and (s in X2))
or ((not (s in S)) and (not (s in X2)))))";
+ fts_eq "P(x) and Q(x) and (P(x)|R(x)) and (Q(x)|R(x))" "P(x) and Q(x)";
+ fts_eq "P(x) or Q(x) or (P(x)&R(x)) or (Q(x)&R(x))" "P(x) or Q(x)";
+ fts_eq "P(x) and not P(x)" "false";
+ fts_eq "P(x) or not P(x)" "true";
+
let double_fts_eq phi =
- let fts2 phi = Formula.flatten_sort (Formula.flatten_sort phi) in
- formula_eq Formula.flatten_sort phi fts2 phi in
+ let psi = Formula.str (Formula.flatten_sort (formula_of_string phi)) in
+ formula_eq id psi Formula.flatten_sort psi in
double_fts_eq "ex X2 ((all s ((not (s in X2))) and ex zero
((all n (LessEq(zero, n)) and all s (((not (s = zero)) and
(not ex x1 ((Succ(x1, s) and Succ(zero, x1)))))) and ex C
@@ -389,7 +398,7 @@
(* ------------------------------ SL 6 formula test ------------------------ *)
(*
-let f v1 v2 = "(E (" ^ v1 ^ ", " ^ v2 ^ ") and "^ v2 ^ " in F_f) or (E(" ^
+let f v1 v2 = "(Succ (" ^ v1 ^ ", " ^ v2 ^ ") and "^ v2 ^ " in F_f) or (Succ(" ^
v2 ^ ", " ^ v1 ^ ") and " ^ v2 ^ " in B_f) or (" ^ v1 ^ " = " ^ v2 ^ " and " ^
v1 ^ " in L_f) or (" ^
v2 ^ " = y and " ^ v1 ^ " in F_fy ) or (" ^
@@ -399,18 +408,34 @@
v2 ^ " = x and " ^ v1 ^ " in F_fx) or (" ^
v1 ^ " = x and " ^ v2 ^ " in B_fx)" ;;
-(* let closed_f h = "all v ( v in " ^ h ^ " and v != y ) -> (all u (" ^
- (f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")";; *)
+let partial_f = "all a,b,c (" ^ (f "a" "b") ^ " and " ^ (f "a" "c") ^ " -> b=c)"
-let closed_f h = "all v ( v in " ^ h ^ " ) -> (all u (" ^
+let closed_f h = "all v ( v in " ^ h ^ " and v != y ) -> (all u (" ^
(f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")";;
-let sl6_f = "all x (Z(x) -> (not x in F_f and not x in B_f)) and
+(* let closed_f h = "all v ( v in " ^ h ^ " ) -> (all u (" ^
+ (f "v" "u") ^ " -> (u in " ^ h ^ ")) and x in " ^ h ^ ")";; *)
+
+(*let sl6_f = "all x (Z(x) -> (not x in F_f and not x in B_f)) and " ^
+ partial_f ^ " and
(ex H_path ((" ^ (closed_f "H_path") ^ ") and (all H_other ((" ^
(closed_f "H_other") ^ ") -> all a (a in H_path -> a in H_other)))
- and y in H_path))";;
+ and y in H_path))";; *)
-"TNF size" FormulaOps.tnf (fun f -> print_endline (string_of_int (Formula.size f))) sl6_f ;;
+let sl6_f = "ex x,y,z,F_f,B_f,L_f,F_fx,B_fx,F_fy,B_fy,F_fz,B_fz
+ (all u (Z(u) -> (not u in F_f and not u in B_f)) and " ^
+ partial_f ^ " and
+ (ex H_path ((" ^ (closed_f "H_path") ^ ") and (all H_other ((" ^
+ (closed_f "H_other") ^ ") -> all a (a in H_path -> a in H_other)))
+ and y in H_path)))";;
+
+let sl6_phi = Formula.flatten_sort (FormulaOps.nnf (formula_of_string sl6_f));;
+
+print_endline "SL6 = " ;;
+print_endline (Formula.str sl6_phi) ;;
+
+"TNF size" FormulaOps.tnf
+ (fun f -> print_endline (string_of_int (Formula.size f))) sl6_f ;;
*)
(* ------- Other longer formulas -------- *)
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Formula/FormulaTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -1,8 +1,5 @@
open OUnit
-FormulaOps.set_debug_level 0;
-BoolFormula.set_debug_level 0
-
let tests = "Formula" >::: [
"basic flatten" >::
(fun () ->
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-05-01 00:33:55 UTC (rev 1427)
@@ -25,6 +25,12 @@
(Lexing.from_channel f) in
res
+let assert_eq_str ?(msg="") x_in y_in =
+ let ws = Str.regexp "[ \n\t]+" in
+ let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
+ let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ assert_equal ~printer:(fun x -> x) ~msg ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
let winQxyz =
"ex x, y, z ((((Q(x) and Q(y)) and Q(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
@@ -108,8 +114,8 @@
W..W W..W W..W W..W
\"" in
(* Heuristic.debug_level := 7; *)
- assert_equal ~printer:(fun x->x)
- "ex y5, y4, y3, y2, y1, y0, y ((C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, y) and C(y, x)))"
+ assert_eq_str
+ "ex y5, y4, y3, y2, y1, y0, y (C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, y) and C(y, x))"
(Formula.str (Heuristic.expanded_description 5
(Aux.strings_of_list ["B"; "W"])
state (formula_of_str "not ex y C(x, y)")));
@@ -141,8 +147,8 @@
F F F F F F F F
\"" in
- assert_equal ~printer:(fun x->x)
- "ex y7, y6, y5, y4, y3, y2, y1, y0, y ((C(y7, y6) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, x) and C(x, y)))"
+ assert_eq_str
+ "ex y7, y6, y5, y4, y3, y2, y1, y0, y (C(y7, y6) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, x) and C(x, y))"
(Formula.str (Heuristic.expanded_description 5
(Aux.strings_of_list ["B"; "W"])
state (formula_of_str "ex y (C(x, y) and F(y))")));
@@ -174,8 +180,8 @@
F F F F F F F F
\"" in
- assert_equ...
[truncated message content] |
|
From: <luk...@us...> - 2011-04-29 11:37:34
|
Revision: 1426
http://toss.svn.sourceforge.net/toss/?rev=1426&view=rev
Author: lukstafi
Date: 2011-04-29 11:37:27 +0000 (Fri, 29 Apr 2011)
Log Message:
-----------
ReqHandle GDL: bug fix (do not keep old state).
Modified Paths:
--------------
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ServerTest.ml
trunk/Toss/www/reference/reference.tex
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-04-29 09:09:04 UTC (rev 1425)
+++ trunk/Toss/GGP/GDL.ml 2011-04-29 11:37:27 UTC (rev 1426)
@@ -756,9 +756,14 @@
let fprint_gdl_transl_data ?(details=false) ppf gdl =
(* TODO: print more data if needed *)
- Format.fprintf ppf "GDL_DATA@,{@[<1>FLUENTS@ %a;@ PLAYING_AS@ %d;"
- (Aux.fprint_sep_list ";" Format.pp_print_string) gdl.fluents
- gdl.playing_as;
+ Format.fprintf ppf
+ "GDL_DATA@,{@[<1>FLUENTS@ %a;@ PLAYING_AS@ %d;@ NOOPS@ %a;"
+ (Aux.fprint_sep_list "," Format.pp_print_string) gdl.fluents
+ gdl.playing_as
+ (Aux.fprint_sep_list "," Format.pp_print_string)
+ (Array.to_list (Array.mapi (fun i -> function
+ | None -> string_of_int i ^": None"
+ | Some noop -> string_of_int i ^": "^term_str noop) gdl.noop_actions));
Aux.StrMap.iter (fun rname data ->
Format.fprintf ppf "@ @[<1>RULE@ %s:@ LEGAL=@,%s;@ PRECOND=@,%a;@ "
rname (term_str data.lead_legal) Formula.fprint data.precond;
@@ -4403,12 +4408,24 @@
let our_turn gdl state =
let loc = (snd state).Arena.cur_loc in
- gdl.playing_as = Aux.array_argfind (fun l -> l.Arena.moves <> [])
- (fst state).Arena.graph.(loc)
+ let res =
+ gdl.playing_as = Aux.array_argfind (fun l -> l.Arena.moves <> [])
+ (fst state).Arena.graph.(loc) in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "our_turn: %b at loc %d\n%!" res loc
+ );
+ (* }}} *)
+ res
let noop_move ?(force=false) gdl state =
let loc = state.Arena.cur_loc in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "noop_move: loc %d\n%!" loc
+ );
+ (* }}} *)
match gdl.noop_actions.(loc) with
| Some t -> term_str t
| None when force ->
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2011-04-29 09:09:04 UTC (rev 1425)
+++ trunk/Toss/GGP/GDLTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
@@ -243,10 +243,10 @@
]
-let a =
+let a =
Aux.run_test_if_target "GDLTest" tests
-let a =
+let a =
Aux.run_test_if_target "GDLTest" bigtests
let a () =
@@ -263,7 +263,8 @@
| Some tests -> ignore (run_test_tt ~verbose:true tests)
| None -> ()
-let regenerate ?(debug=true) ~game_name ~player =
+let regenerate ~debug ~game_name ~player =
+ Printf.printf "Regenerating %s...\n%!" game_name;
if debug then (
GDL.debug_level := 4;
GameSimpl.debug_level := 4;
@@ -274,7 +275,8 @@
GDL.generate_test_case := None
let a () =
- regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer";
- regenerate ~debug:false ~game_name:"connect5" ~player:"x";
- regenerate ~debug:false ~game_name:"breakthrough" ~player:"white";
+ (* regenerate ~debug:false ~game_name:"tictactoe" ~player:"xplayer"; *)
+ (* regenerate ~debug:false ~game_name:"connect5" ~player:"x"; *)
+ (* regenerate ~debug:false ~game_name:"breakthrough" ~player:"white"; *)
+ regenerate ~debug:true ~game_name:"pawn_whopping" ~player:"x";
(* regen_with_debug ~game_name:"connect4" ~player:"white" *)
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-04-29 09:09:04 UTC (rev 1425)
+++ trunk/Toss/Server/ReqHandler.ml 2011-04-29 11:37:27 UTC (rev 1426)
@@ -65,7 +65,7 @@
let r_name, mtch =
GDL.translate_last_action gdl_transl state actions in
- let new_state =
+ let state =
if r_name <> "" then (
let {Arena.rules=rules; graph=graph} = fst state in
let mv_loc = select_moving graph.((snd state).Arena.cur_loc) in
@@ -98,7 +98,7 @@
else
let mov_msg =
let time_used = time_started -. Unix.gettimeofday () in
- if GDL.our_turn gdl_transl new_state then (
+ if GDL.our_turn gdl_transl state then (
Play.set_timeout (float(playclock) -. time_used -. 0.07);
let heur = match g_heur with
| Some h -> h
@@ -115,4 +115,4 @@
let msg_len = String.length mov_msg in
("HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: "
^ string_of_int msg_len ^ "\r\n\r\n" ^ mov_msg) in
- (g_heur, game_modified, new_state, resp, gdl_transl, playclock)
+ (g_heur, game_modified, state, resp, gdl_transl, playclock)
Modified: trunk/Toss/Server/ServerTest.ml
===================================================================
--- trunk/Toss/Server/ServerTest.ml 2011-04-29 09:09:04 UTC (rev 1425)
+++ trunk/Toss/Server/ServerTest.ml 2011-04-29 11:37:27 UTC (rev 1426)
@@ -22,7 +22,6 @@
"ServerGDLTest.in GDL Tic-Tac-Toe manual" >::
(fun () ->
- GDL.debug_level := 4;
let old_translation = !GDL.manual_translation in
GDL.manual_translation := true;
GDL.manual_game := "tictactoe";
@@ -44,7 +43,6 @@
"ServerGDLTest.in GDL Tic-Tac-Toe automatic" >::
(fun () ->
- GDL.debug_level := 4;
(* todo "real soon now..."; *)
(* Solver.set_debug_level 2; *)
let old_translation = !GDL.manual_translation in
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-04-29 09:09:04 UTC (rev 1425)
+++ trunk/Toss/www/reference/reference.tex 2011-04-29 11:37:27 UTC (rev 1426)
@@ -1730,17 +1730,17 @@
of substituted bodies of the frame clauses and bring this Boolean combination
to disjunctive normal form (DNF), \ie we compute conjunctions $e_1, \dots, e_l$
such that
-\[ \neg( \rho(b_1) \lor \dots \lor \rho(b_{|J|}) \ \equiv \
- (e_1 \lor e_2 \ldots \lor e_l). \]
-As the head of each erasure clause we use $\rho(s_1) = \dots = \rho(s_{|J|})$,
-with the one technical change that we ignore the fluent paths in this term.
-We replace these fluent paths with \texttt{BLANK} and thus allow them
-to be deleted in case they are not preserved by other \texttt{next} clauses
-of the rule, which causes no problems. Let us denote by $h$ the term
-$\rho(s_1)$ after the above replacement. The erasure clauses
-$\calE_{\ol{\calC}, \ol{\calN}}(J) =
- \{ \mathtt{(<=\ h\ e_1)} \dots \mathtt{(<=\ h\ e_l)} \},$
-and we write $\calE_{\ol{\calC}, \ol{\calN}}$ for the union of all
+\[ \neg( \rho(b_1) \lor \dots \lor \rho(b_{|J|})) \ \equiv \ (e_1 \lor
+e_2 \ldots \lor e_l). \]
+As the head of each erasure clause we use
+$\rho(s_1) = \dots = \rho(s_{|J|})$, with the one technical change
+that we ignore the fluent paths in this term. We replace these fluent
+paths with \texttt{BLANK} and thus allow them to be deleted in case
+they are not preserved by other \texttt{next} clauses of the rule. Let
+us denote by $h$ the term $\rho(s_1)$ after the above replacement. The
+erasure clauses $\calE_{\ol{\calC}, \ol{\calN}}(J) = \{ \mathtt{(<=\
+ h\ e_1)} \dots \mathtt{(<=\ h\ e_l)} \},$ and we write
+$\calE_{\ol{\calC}, \ol{\calN}}$ for the union of all
$\calE_{\ol{\calC}, \ol{\calN}}(J)$, \ie for the set of all
$\ol{\calC}, \ol{\calN}$ erasure clauses.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-29 09:09:10
|
Revision: 1425
http://toss.svn.sourceforge.net/toss/?rev=1425&view=rev
Author: lukaszkaiser
Date: 2011-04-29 09:09:04 +0000 (Fri, 29 Apr 2011)
Log Message:
-----------
Player in GDL correction, thinking about fixed-point types.
Modified Paths:
--------------
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Server/ReqHandler.ml
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-04-28 22:09:04 UTC (rev 1424)
+++ trunk/Toss/Formula/Formula.ml 2011-04-29 09:09:04 UTC (rev 1425)
@@ -103,10 +103,8 @@
| Or of formula list
| Ex of var list * formula
| All of var list * formula
- | MLfp of mso_var * fo_var * formula
- | MGfp of mso_var * fo_var * formula
- | Lfp of so_var * fo_var list * formula
- | Gfp of so_var * fo_var list * formula
+ | Lfp of [ mso_var | so_var ] * fo_var array * formula
+ | Gfp of [ mso_var | so_var ] * fo_var array * formula
and real_expr =
| RVar of string
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2011-04-28 22:09:04 UTC (rev 1424)
+++ trunk/Toss/Formula/Formula.mli 2011-04-29 09:09:04 UTC (rev 1425)
@@ -55,10 +55,8 @@
| Or of formula list
| Ex of var list * formula
| All of var list * formula
- | MLfp of mso_var * fo_var * formula
- | MGfp of mso_var * fo_var * formula
- | Lfp of so_var * fo_var list * formula
- | Gfp of so_var * fo_var list * formula
+ | Lfp of [mso_var | so_var] * fo_var array * formula
+ | Gfp of [mso_var | so_var] * fo_var array * formula
(** Real-valued terms allow counting, characteristic functions, arithmetic. *)
and real_expr =
Modified: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml 2011-04-28 22:09:04 UTC (rev 1424)
+++ trunk/Toss/Server/ReqHandler.ml 2011-04-29 09:09:04 UTC (rev 1425)
@@ -98,7 +98,7 @@
else
let mov_msg =
let time_used = time_started -. Unix.gettimeofday () in
- if GDL.our_turn gdl_transl state then (
+ if GDL.our_turn gdl_transl new_state then (
Play.set_timeout (float(playclock) -. time_used -. 0.07);
let heur = match g_heur with
| Some h -> h
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-28 22:09:13
|
Revision: 1424
http://toss.svn.sourceforge.net/toss/?rev=1424&view=rev
Author: lukaszkaiser
Date: 2011-04-28 22:09:04 +0000 (Thu, 28 Apr 2011)
Log Message:
-----------
Create structures from pictures, add SO variable variant, monadic and full least and greatest fixed-point variants, move (part of) ClassTest to OUnit.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FFTNF.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/Formula.mli
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Server/Makefile
trunk/Toss/Solver/Class.ml
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/PresbTest.ml
trunk/Toss/TossTest.ml
Added Paths:
-----------
trunk/Toss/Server/Picture.ml
trunk/Toss/Server/Picture.mli
trunk/Toss/Server/PictureTest.ml
trunk/Toss/www/img/Breakthrough.ppm
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -14,7 +14,7 @@
let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
- let ws = Str.regexp "[ ,\n,\t]+" in
+ let ws = Str.regexp "[ \n\t]+" in
let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
Modified: trunk/Toss/Formula/FFTNF.ml
===================================================================
--- trunk/Toss/Formula/FFTNF.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Formula/FFTNF.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -172,6 +172,7 @@
List.map2 (fun v -> function
| `FO _ -> `FO v
| `MSO _ -> `MSO v
+ | `SO _ -> `SO v
| `Real _ -> `Real v) vs xs in
let update_sb vs vars sb =
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Formula/Formula.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -1,16 +1,17 @@
(* Represent formulas with first-order, mso, and real variables - basic defs.*)
let debug_level = ref 0
-let set_debug_level i = Sat.set_debug_level (i-1); (debug_level := i)
+let set_debug_level i = ( Sat.set_debug_level (i-1); debug_level := i; )
(* ----------------------- BASIC TYPE DEFINITIONS -------------------------- *)
(* Our variables can be first-order, monadic second-order or reals. *)
-type var = [ `FO of string | `MSO of string | `Real of string ] ;;
-type fo_var = [ `FO of string ];;
-type mso_var = [ `MSO of string ];;
-type real_var = [ `Real of string ];;
+type var = [ `FO of string | `MSO of string | `SO of string | `Real of string ]
+type fo_var = [ `FO of string ]
+type mso_var = [ `MSO of string ]
+type so_var = [ `SO of string ]
+type real_var = [ `Real of string ]
(* We recognize if the variable is FO (x, y) or MSO (X, Y) or Real (r1, r2). *)
let var_of_string s : var =
@@ -18,27 +19,34 @@
failwith "empty strings not allowed as vars"
else if s.[0] = ':' then
`Real s
+ else if s.[0] = '|' then
+ `SO s
else if ((Char.uppercase s.[0]) = s.[0]) && (not (Aux.is_digit s.[0])) then
`MSO s
else `FO s
let fo_var_of_string s : fo_var =
match var_of_string s with
- `FO s -> `FO s
+ | `FO s -> `FO s
| _ -> failwith ("non first-order variable: " ^ s)
let mso_var_of_string s : mso_var =
match var_of_string s with
- `MSO s -> `MSO s
+ | `MSO s -> `MSO s
| _ -> failwith ("non MSO variable: " ^ s)
+let so_var_of_string s : so_var =
+ match var_of_string s with
+ | `SO s -> `SO s
+ | _ -> failwith ("non SO variable: " ^ s)
+
let real_var_of_string s : real_var =
match var_of_string s with
- `Real s -> `Real s
+ | `Real s -> `Real s
| _ -> failwith ("non real variable: " ^ s)
(* Print a variable as a string. *)
-let var_str = function `FO s -> s | `MSO s -> s | `Real s -> s
+let var_str = function `FO s -> s | `MSO s -> s | `SO s -> s | `Real s -> s
let print_var v = Format.print_string (var_str v)
(* Print a variable list/array as a string. *)
@@ -58,23 +66,24 @@
(* Check variable type. *)
let is_fo (v : var) = match v with `FO _ -> true | _ -> false
let is_mso (v : var) = match v with `MSO _ -> true | _ -> false
+let is_so (v : var) = match v with `SO _ -> true | _ -> false
let is_real (v : var) = match v with `Real _ -> true | _ -> false
(* Casts to particular variable types. *)
let to_fo (v : var) : fo_var = fo_var_of_string (var_str v)
let to_mso (v : var) : mso_var = mso_var_of_string (var_str v)
+let to_so (v : var) : so_var = so_var_of_string (var_str v)
let to_real (v : var) : real_var = real_var_of_string (var_str v)
(* Cast that is safe provided that tuples are not modified in-place. *)
-let var_tup (vs : [< var ] array) =
- (Obj.magic vs : var array)
+let var_tup (vs : [< var ] array) = (Obj.magic vs : var array)
(* Sign operands. *)
type sign_op = EQZero | GZero | LZero | GEQZero | LEQZero | NEQZero
(* Print a sign_op as string. *)
let sign_op_str = function
- EQZero -> " = 0"
+ | EQZero -> " = 0"
| GZero -> " > 0"
| LZero -> " < 0"
| GEQZero -> " >= 0"
@@ -85,7 +94,7 @@
(* This type describes formulas of relational logic with equality.
We allow only simple boolean junctors, other are resolved during parsing. *)
type formula =
- Rel of string * fo_var array
+ | Rel of string * fo_var array
| Eq of fo_var * fo_var
| In of fo_var * mso_var
| RealExpr of real_expr * sign_op
@@ -94,22 +103,26 @@
| Or of formula list
| Ex of var list * formula
| All of var list * formula
+ | MLfp of mso_var * fo_var * formula
+ | MGfp of mso_var * fo_var * formula
+ | Lfp of so_var * fo_var list * formula
+ | Gfp of so_var * fo_var list * formula
and real_expr =
- RVar of string
+ | RVar of string
| Const of float
| Times of real_expr * real_expr
| Plus of real_expr * real_expr
| Fun of string * fo_var
| Char of formula
| Sum of fo_var list * formula * real_expr
-;;
let is_atom = function
- Rel _ | Eq _ | In _ | RealExpr _ -> true
+ | Rel _ | Eq _ | In _ | RealExpr _ -> true
| _ -> false
+
(* Helper power function, used in parser. *)
let rec pow p n =
if n = 0 then Const 1. else if n = 1 then p else Times (p, pow p (n-1))
@@ -242,26 +255,28 @@
(* ------------------------ ORDER ON FORMULAS ------------------------------- *)
-(* Compare two variables. We assume that FO < MSO < Real. *)
+(* Compare two variables. We assume that FO < MSO < SO < Real. *)
let compare_vars x y =
- if x == y then 0 else
- match (x, y) with
- (`FO x, `FO y) -> String.compare x y
- | (`FO _, _) -> 1
- | (_, `FO _) -> -1
- | (`MSO x, `MSO y) -> String.compare x y
- | (`MSO _, _) -> 1
- | (_, `MSO _) -> -1
- | (`Real x, `Real y) -> String.compare x y
+ if x == y then 0 else match (x, y) with
+ | (`FO x, `FO y) -> String.compare x y
+ | (`FO _, _) -> 1
+ | (_, `FO _) -> -1
+ | (`MSO x, `MSO y) -> String.compare x y
+ | (`MSO _, _) -> 1
+ | (_, `MSO _) -> -1
+ | (`SO x, `SO y) -> String.compare x y
+ | (`SO _, _) -> 1
+ | (_, `SO _) -> -1
+ | (`Real x, `Real y) -> String.compare x y
(* Helper function: compare lists/arrays lexicographically by [cmp]. *)
let rec compare_lists_lex cmp = function
- ([], []) -> 0
+ | ([], []) -> 0
| ([], _) -> -1
| (_, []) -> 1
| (x :: xs, y :: ys) ->
- let c = cmp x y in
- if c <> 0 then c else compare_lists_lex cmp (xs, ys)
+ let c = cmp x y in
+ if c <> 0 then c else compare_lists_lex cmp (xs, ys)
let compare_arrays_lex cmp a b =
let res = ref (Array.length a - Array.length b) in
@@ -285,19 +300,18 @@
| Rel _ | Eq _ | In _ | RealExpr _ -> acc + 1
| Not phi | Ex (_, phi) | All (_, phi) -> size ~acc:(acc + 1) phi
| And flist | Or flist ->
- List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
+ List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
let rec rec_compare phi1 phi2 =
let cmp_lists = compare_lists_lex rec_compare in
match (phi1, phi2) with
- (Rel (r1, vs1), Rel (r2, vs2)) ->
- let c = compare_var_tups vs1
- vs2 in
- if c <> 0 then c else String.compare r1 r2
+ | (Rel (r1, vs1), Rel (r2, vs2)) ->
+ let c = compare_var_tups vs1 vs2 in
+ if c <> 0 then c else String.compare r1 r2
| (Rel (r, vs), Eq (x, y)) ->
- let c = compare_var_tups vs [|x; y|] in if c = 0 then -1 else c
+ let c = compare_var_tups vs [|x; y|] in if c = 0 then -1 else c
| (Eq (x, y), Rel (r, vs)) ->
- let c = compare_var_tups [|x; y|] vs in if c = 0 then 1 else c
+ let c = compare_var_tups [|x; y|] vs in if c = 0 then 1 else c
| (Eq (x1, y1), Eq (x2, y2)) -> compare_var_tups [|x1; y1|] [|x2; y2|]
| (Rel _, _) | (Eq _, _) -> -1
| (_, Rel _) | (_, Eq _) -> 1
@@ -307,8 +321,8 @@
| (In _, _) -> -1
| (_, In _) -> 1
| (RealExpr (re1, s1), RealExpr (re2, s2)) ->
- let c = rec_compare_re re1 re2 in
- if c <> 0 then c else Pervasives.compare s1 s2
+ let c = rec_compare_re re1 re2 in
+ if c <> 0 then c else Pervasives.compare s1 s2
| (RealExpr _, _) -> -1
| (_, RealExpr _) -> 1
| (Not psi1, Not psi2) -> rec_compare psi1 psi2
@@ -320,21 +334,21 @@
| (Or _, _) -> -1
| (_, Or _) -> 1
| (All (vs1, psi1), All (vs2, psi2)) | (Ex (vs1, psi1), Ex (vs2, psi2)) ->
- let c = compare_var_lists vs1 vs2 in
- if c <> 0 then c else rec_compare psi1 psi2
+ let c = compare_var_lists vs1 vs2 in
+ if c <> 0 then c else rec_compare psi1 psi2
| (All _, _) -> -1
| (_, All _) -> 1
and rec_compare_re re1 re2 =
match (re1, re2) with
- (Char phi1, Char phi2) -> rec_compare phi1 phi2
+ | (Char phi1, Char phi2) -> rec_compare phi1 phi2
| (Const x, Const y) -> Pervasives.compare x y
| _ -> Pervasives.compare re1 re2 (* TODO: improve this *)
let compare phi1 phi2 =
if phi1 == phi2 then 0 else
let (s1, s2) = (size phi1, size phi2) in
- if s1 <> s2 then s1 - s2 else rec_compare phi1 phi2
+ if s1 <> s2 then s1 - s2 else rec_compare phi1 phi2
(* --------------- BASIC HELPER FUNCTIONS USED IN PARSER ------------------- *)
Modified: trunk/Toss/Formula/Formula.mli
===================================================================
--- trunk/Toss/Formula/Formula.mli 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Formula/Formula.mli 2011-04-28 22:09:04 UTC (rev 1424)
@@ -3,35 +3,38 @@
(** {2 Basic Type Definitions.} *)
(** Our variables can be first-order, monadic second-order or reals. *)
-type var = [ `FO of string | `MSO of string | `Real of string ] ;;
-type fo_var = [ `FO of string ];;
-type mso_var = [ `MSO of string ];;
-type real_var = [ `Real of string ];;
+type var = [ `FO of string | `MSO of string | `SO of string | `Real of string ]
+type fo_var = [ `FO of string ]
+type mso_var = [ `MSO of string ]
+type so_var = [ `SO of string ]
+type real_var = [ `Real of string ]
-(** We recognize if the variable is FO (x, y) or MSO (X, Y) or Real (r1, r2). *)
+(** We recognize if the variable is FO (x), MSO (X), SO (|x) or Real (:x). *)
val var_of_string : string -> var
val fo_var_of_string : string -> fo_var
val mso_var_of_string : string -> mso_var
+val so_var_of_string : string -> so_var
val real_var_of_string : string -> real_var
(** Check variable type. *)
val is_fo : var -> bool
val is_mso : var -> bool
+val is_so : var -> bool
val is_real : var -> bool
(** Casts to particular variable types. *)
val to_fo : var -> fo_var
val to_mso : var -> mso_var
+val to_so : var -> so_var
val to_real : var -> real_var
val var_tup : [< var] array -> var array
-(** Compare two variables. We assume FO < MSO < Real. *)
+(** Compare two variables. We assume FO < MSO < SO < Real. *)
val compare_vars : ([< var ] as 'a) -> 'a -> int
val compare_var_lists : ([< var ] as 'a) list -> 'a list -> int
-val compare_var_tups :
- ([< var ] as 'a) array -> 'a array -> int
+val compare_var_tups : ([< var ] as 'a) array -> 'a array -> int
(** Sign operands. *)
type sign_op = EQZero | GZero | LZero | GEQZero | LEQZero | NEQZero
@@ -43,7 +46,7 @@
(** This type describes formulas of relational logic with equality.
We allow only simple boolean junctors, other are resolved during parsing. *)
type formula =
- Rel of string * fo_var array
+ | Rel of string * fo_var array
| Eq of fo_var * fo_var
| In of fo_var * mso_var
| RealExpr of real_expr * sign_op
@@ -52,10 +55,14 @@
| Or of formula list
| Ex of var list * formula
| All of var list * formula
+ | MLfp of mso_var * fo_var * formula
+ | MGfp of mso_var * fo_var * formula
+ | Lfp of so_var * fo_var list * formula
+ | Gfp of so_var * fo_var list * formula
-(** Real-valued terms allow counting, characteristic functions and arithmetic. *)
+(** Real-valued terms allow counting, characteristic functions, arithmetic. *)
and real_expr =
- RVar of string
+ | RVar of string
| Const of float
| Times of real_expr * real_expr
| Plus of real_expr * real_expr
@@ -75,11 +82,10 @@
(** {2 Printing Functions} *)
(** Print a variable as a string. *)
-val var_str : [< `FO of string | `MSO of string | `Real of string ] -> string
+val var_str : [< var] -> string
(** Print a variable list as a string. *)
-val var_list_str: [< `FO of string | `MSO of string | `Real of string ] list ->
- string
+val var_list_str: [< var] list -> string
(** Print a formula as a string. *)
val str : formula -> string
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Formula/FormulaTest.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -1,7 +1,7 @@
open OUnit
-FormulaOps.set_debug_level 0 ;;
-BoolFormula.set_debug_level 0 ;;
+FormulaOps.set_debug_level 0;
+BoolFormula.set_debug_level 0
let tests = "Formula" >::: [
"basic flatten" >::
@@ -16,8 +16,7 @@
Formula.And [Formula.And [r "P"; r "Q"]; Formula.And [r "S"]]))
(Formula.And [r "P"; r "Q"; r "S"]);
);
-] ;;
+]
-let a =
- Aux.run_test_if_target "FormulaTest" tests
-;;
+
+let exec = Aux.run_test_if_target "FormulaTest" tests
Modified: trunk/Toss/Server/Makefile
===================================================================
--- trunk/Toss/Server/Makefile 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Server/Makefile 2011-04-28 22:09:04 UTC (rev 1424)
@@ -9,10 +9,12 @@
%TestDebug:
make -C .. Server/$@
+PictureTest:
+PictureTestProfile:
+PictureTestDebug:
+
ServerTest:
-
ServerTestProfile:
-
ServerTestDebug:
tests:
Added: trunk/Toss/Server/Picture.ml
===================================================================
--- trunk/Toss/Server/Picture.ml (rev 0)
+++ trunk/Toss/Server/Picture.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -0,0 +1,235 @@
+(* Processing Pictures to create Structures *)
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i;)
+
+
+(* --------- Basic Picture Functions --------- *)
+
+type picture = (int * int * int) array array
+
+(* Read a picture from a scanning buffer. *)
+let read_pic buf =
+ let (width, height) = Scanf.bscanf buf "P3 %d %d 255" (fun x y -> (x, y)) in
+ let pic = Array.make_matrix width height (0, 0, 0) in
+ for j = 0 to height-1 do
+ for i = 0 to width-1 do
+ pic.(i).(j) <- Scanf.bscanf buf " %d %d %d" (fun x y z -> (x, y, z))
+ done
+ done;
+ pic
+
+(* Print a matrix to the formatter [f], use [elem_f] for elements. *)
+let fprint_matrix f elem_f start mid m =
+ let (width, height) = (Array.length m, Array.length (m.(0))) in
+ Format.fprintf f "%s %d %d %s\n%!" start width height mid;
+ for j = 0 to height-1 do
+ for i = 0 to width-1 do
+ Format.fprintf f "%a" elem_f m.(i).(j);
+ done;
+ Format.fprintf f "\n%!";
+ done
+
+(* Print a picture in the simple PPM format to a formatter. *)
+let fprint_pic f pic =
+ let pr fmt (a, b, c) = Format.fprintf fmt " %d %d %d\n" a b c in
+ fprint_matrix f pr "P3" "255" pic
+
+(* Print a picture in the simple PPM format to standard output. *)
+let print_pic pic = fprint_pic Format.std_formatter pic
+
+
+(* Flip a picture. *)
+let flip pic =
+ let (width, height) = (Array.length pic, Array.length (pic.(0))) in
+ let flpic = Array.make_matrix height width (0, 0, 0) in
+ for i = 0 to width-1 do
+ for j = 0 to height-1 do
+ flpic.(j).(i) <- pic.(i).(j)
+ done
+ done;
+ flpic
+
+
+(* Cut a picture to the given rectangle. *)
+let cut (x1, y1) (x2, y2) pic =
+ let (orig_w, orig_h) = (Array.length pic, Array.length (pic.(0))) in
+ let x2 = if x2 <= 0 then orig_w + x2 - 1 else x2 in
+ let y2 = if y2 <= 0 then orig_h + y2 - 1 else y2 in
+ if x2 < x1+1 || y2 < y1+1 || orig_w<x2+1 || orig_h<y2+1 || x1<0 || y1<0 then
+ failwith (Printf.sprintf "cut: wrong dimensions %i %i %i %i" x1 x2 y1 y2);
+ let cutpic = Array.make_matrix (x2-x1+1) (y2-y1+1) (0, 0, 0) in
+ for i = 0 to x2-x1 do
+ for j = 0 to y2-y1 do
+ cutpic.(i).(j) <- pic.(i+x1).(j+y1)
+ done
+ done;
+ cutpic
+
+
+(* Apply the filter function [f] to each pixel in a picture. *)
+let apply_filter f pic =
+ let (width, height) = (Array.length pic, Array.length (pic.(0))) in
+ let fpic = Array.make_matrix width height (0, 0, 0) in
+ for i = 0 to width-1 do
+ for j = 0 to height-1 do
+ fpic.(i).(j) <- f i j width height pic
+ done
+ done;
+ fpic
+
+
+(* ------------ Change Detection ------------ *)
+
+let diff_filter maxdiff (distx, disty) x y w h pic =
+ let res = ref false in
+ for i = -distx to distx do
+ for j = -disty to disty do
+ if x+i >= 0 && x+i < w && y+j >= 0 && y+j < h then
+ let (r1, g1, b1) = pic.(x).(y) in
+ let (r2, g2, b2) = pic.(x+i).(y+j) in
+ let (rd, gd, bd) = maxdiff in
+ if rd >= abs (r1-r2) && gd >= abs (g1-g2) && bd >= abs (b1-b2) then
+ res := false
+ else res := true
+ done
+ done;
+ if !res then (255, 255, 255) else (0, 0, 0)
+
+(* Calculate color difference, accept maxdiff differences up to dist. *)
+let diff ?(maxdiff=(1,1,1)) ?(dist=(1,1)) =
+ apply_filter (diff_filter maxdiff dist)
+
+
+(* ------------ Simple Segmentation ------------ *)
+
+let all_in_color cl ((x1, y1), (x2, y2)) pic =
+ let (w, h) = (Array.length pic, Array.length (pic.(0))) in
+ if x2 < x1 || y2 < y1 || w < x2+1 || h < y2+1 || x1 < 0 || y1 < 0 then
+ failwith (Printf.sprintf "all_in_color: wrong dim %i %i %i %i" x1 y1 x2 y2);
+ let res = ref true in
+ for i = x1 to x2 do
+ for j = y1 to y2 do
+ if pic.(i).(j) <> cl then res := false
+ done
+ done;
+ !res
+
+let rec next_x cl i j w h pic =
+ if pic.(i).(j) = cl then (i, j) else
+ if i+1 < w then next_x cl (i+1) j w h pic else raise Not_found
+
+let rec next_y cl i j w h pic =
+ if pic.(i).(j) = cl then (i, j) else
+ if j+1 < h then next_y cl i (j+1) w h pic else raise Not_found
+
+let next_color cl i j w h pic =
+ try
+ let (i1, _) = next_x cl i j w h pic in
+ if i1+1 < w && pic.(i1+1).(j) = cl then (i1, j) else raise Not_found
+ with Not_found ->
+ let (_, j1) = next_y cl 0 (j+1) w h pic in
+ if j1+1 < h && pic.(i).(j1+1) = cl then (0, j1) else raise Not_found
+
+(* Make a row-first column-next black-white tour of a picture. *)
+let bw_tour pic =
+ let (width, height) = (Array.length pic, Array.length (pic.(0))) in
+ let (i, j, newi, newj) = (ref 0, ref 0, ref 0, ref 0) in
+ let (rects, intv) = (ref [], ref []) in
+ try
+ while true do
+ intv := [];
+ while !j = !newj do
+ let (ni, nj) = next_color (0, 0, 0) !i !j width height pic in
+ newi := ni;
+ let (nni, nnj) = next_color (255, 255, 255) ni nj width height pic in
+ if nnj = !j then intv := (ni, nni-1) :: !intv;
+ i := nni; j := !newj; newj := nnj;
+ done;
+ if !intv != [] then intv := (!newi, width-1) :: !intv;
+ rects := (List.map (fun v-> v, (!j,!newj-1)) !intv) @ !rects;
+ j := !newj; i := 0
+ done;
+ failwith "bw_tour: unreachable"
+ with Not_found ->
+ if !intv != [] then intv := (!newi, width-1) :: !intv;
+ rects := (List.map (fun v-> v, (!j,height-1)) !intv) @ !rects;
+ List.rev_map (fun ((a, b), (c, d)) -> (a, c), (b, d)) !rects
+
+let rect_dist ((x1, y1), (x2, y2)) ((a1, b1), (a2, b2)) pic =
+ let (w, h, d) = (min (x2-x1) (a2-a1), min (y2-y1) (b2-b1), ref 0) in
+ for i = 0 to w-1 do
+ for j = 0 to h-1 do
+ let (x, y, z), (a, b, c) = pic.(x1+i).(y1+j), pic.(a1+i).(b1+j) in
+ d := !d + (abs (x-a)) + (abs (y-b)) + (abs (z-c))
+ done
+ done;
+ (float !d) /. (float (w*h))
+
+let rect_dist_offset (x, y) ((x1, y1), (x2, y2)) ((a1, b1), (a2, b2)) pic =
+ rect_dist ((x1+x, y1+y), (x2+x, y2+y)) ((a1+x, b1+y), (a2+x, b2+y)) pic
+
+(* Very basic picture segmentation, should work for grids. *)
+let segment offset threshold pic =
+ let df = diff (cut (offset, offset) (-offset, -offset) pic) in
+ let rects = bw_tour df in
+ let assign_name (dict, i, bi) rect =
+ let (a, b), (c, d) = rect in
+ try
+ let (r, n) =
+ List.find (fun (r,_) ->
+ rect_dist_offset (offset, offset) r rect pic < threshold) dict in
+ if !debug_level > 0 then
+ Printf.printf " (%i, %i) - (%i, %i) %s found \n%!" a b c d n;
+ ((rect, n) :: dict, i, bi)
+ with Not_found ->
+ if all_in_color (0, 0, 0) rect df then (
+ let n = Printf.sprintf "B%i" bi in
+ if !debug_level > 0 then
+ Printf.printf " (%i, %i) - (%i, %i) %s assigned \n%!" a b c d n;
+ ((rect, n) :: dict, i, bi+1)
+ ) else (
+ let n = Printf.sprintf "P%i" i in
+ if !debug_level > 0 then
+ Printf.printf " (%i, %i) - (%i, %i) %s assigned \n%!" a b c d n;
+ ((rect, n) :: dict, i+1, bi)
+ ) in
+ let (res, _, _) = List.fold_left assign_name ([], 1, 0) rects in
+ List.rev res
+
+
+(* ------------- Structure from Segmented Data ------------ *)
+
+(* Create a structure from segmented data. *)
+let make_struc dict =
+ let (prev_ys, prev_xs, maxdx, maxdy) =
+ (ref (0, 0), ref (0, 0), ref 0, ref 0) in
+ let add_el (struc, i, j) (((x1, y1), (x2, y2)), pred) =
+ let (ni, nj) =
+ if (y1, y2) = !prev_ys then (
+ maxdx := max !maxdx (abs ((fst !prev_xs) - x1));
+ prev_xs := (x1, x2);
+ (i+1, j)
+ ) else (
+ maxdy := max !maxdy (abs ((fst !prev_ys) - y1));
+ prev_xs := (x1, x2);
+ prev_ys := (y1, y2);
+ (1, j+1)
+ ) in
+ let name = try Structure.board_coords_name (ni, nj) with Not_found ->
+ Printf.sprintf "e%i,%i" ni nj in
+ let (s1, elem) = Structure.add_new_elem struc ~name () in
+ let s2 = Structure.add_fun s1 "x" (elem, float (x1+x2) /. 2.) in
+ let s3 = Structure.add_fun s2 "y" (elem, float (y1+y2) /. (-2.)) in
+ let s4 = Structure.add_fun s3 "x1" (elem, float x1) in
+ let s5 = Structure.add_fun s4 "y1" (elem, float y1) in
+ let s6 = Structure.add_fun s5 "x2" (elem, float x2) in
+ let s7 = Structure.add_fun s6 "y2" (elem, float y2) in
+ let s8 = Structure.add_fun s7 "vx" (elem, 0.) in
+ let new_s = Structure.add_fun s8 "vy" (elem, 0.) in
+ if pred = "B0" then (new_s, ni, nj) else
+ (Structure.add_rel new_s pred [|elem|], ni, nj) in
+ let (s, _, _) =
+ List.fold_left add_el (Structure.empty_structure (), 1, 0) dict in
+ (s, !maxdx, !maxdy)
+
Added: trunk/Toss/Server/Picture.mli
===================================================================
--- trunk/Toss/Server/Picture.mli (rev 0)
+++ trunk/Toss/Server/Picture.mli 2011-04-28 22:09:04 UTC (rev 1424)
@@ -0,0 +1,50 @@
+(** Processing Pictures to create Structures *)
+
+(** {2 Debugging} *)
+
+val set_debug_level : int -> unit
+
+
+(** {2 Basic Picture Functions} *)
+
+type picture = (int * int * int) array array
+
+
+(** Read a picture from a scanning buffer. *)
+val read_pic : Scanf.Scanning.scanbuf -> picture
+
+(** Print a picture in the simple PPM format to a formatter. *)
+val fprint_pic : Format.formatter -> picture -> unit
+
+(** Print a picture in the simple PPM format to standard output. *)
+val print_pic : picture -> unit
+
+(** Flip a picture. *)
+val flip : picture -> picture
+
+(** Cut a picture to the given rectangle. *)
+val cut : int * int -> int * int -> picture -> picture
+
+(** Apply the filter function [f] to each pixel in a picture. *)
+val apply_filter : (int -> int -> int -> int -> picture -> int * int * int) ->
+ picture -> picture
+
+
+(** {2 Change Detection} *)
+
+(** Calculate color difference, accept maxdiff differences up to dist. *)
+val diff : ?maxdiff: int * int * int -> ?dist: int * int -> picture -> picture
+
+
+(** {2 Simple Segmentation} *)
+
+(** Very basic picture segmentation, should work for grids. *)
+val segment : int -> float -> picture ->
+ (((int * int) * (int * int)) * string) list
+
+
+(** {2 Structure from Segmented Data} *)
+
+(** Create a structure from segmented data. *)
+val make_struc : (((int * int) * (int * int)) * string) list ->
+ Structure.structure * int * int
Added: trunk/Toss/Server/PictureTest.ml
===================================================================
--- trunk/Toss/Server/PictureTest.ml (rev 0)
+++ trunk/Toss/Server/PictureTest.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -0,0 +1,50 @@
+open OUnit
+
+Picture.set_debug_level 0
+
+let tests = "Picture" >::: [
+ "segmentation size for breakthrough" >::
+ (fun () ->
+ let fname = "./www/img/Breakthrough.ppm" in
+ let pic = Picture.read_pic (Scanf.Scanning.from_file fname) in
+ let seg = Picture.segment 2 40. pic in
+ assert_equal ~printer:string_of_int 64 (List.length seg)
+ );
+
+ "breakthrough structure P1 size" >::
+ (fun () ->
+ let fname = "./www/img/Breakthrough.ppm" in
+ let pic = Picture.read_pic (Scanf.Scanning.from_file fname) in
+ let seg = Picture.segment 2 40. pic in
+ let (struc, _, _) = Picture.make_struc seg in
+ assert_equal ~printer:string_of_int 16 (Structure.rel_size struc "P1")
+ );
+]
+
+
+let main () =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ let (file) = (ref "") in
+ let dbg_level i = (Picture.set_debug_level i) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose");
+ ("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
+ ("-f", Arg.String (fun s -> file := s), "process file");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ if !file = "" then ignore (OUnit.run_test_tt tests) else (
+ let pic = Picture.read_pic (Scanf.Scanning.from_file !file) in
+ let (struc, dx, dy) = Picture.make_struc (Picture.segment 2 40. pic) in
+ let formula_r = Printf.sprintf
+ ":y(a) = :y(b) and :x(a) < :x(b) and :x(b) < :x(a) + %i.8" dx in
+ let formula_c = Printf.sprintf
+ ":x(a) = :x(b) and :y(b) < :y(a) and :y(a) < :y(b) + %i.8" dy in
+ Printf.printf "MODEL \n %s \n with \n R(a, b) = %s;\n C(a, b) = %s\n\n%!"
+ (Structure.sprint struc) formula_r formula_c;
+ )
+
+
+let _ = Aux.run_if_target "PictureTest" main
Modified: trunk/Toss/Solver/Class.ml
===================================================================
--- trunk/Toss/Solver/Class.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Solver/Class.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -37,19 +37,19 @@
let struct_sum_str = function
Struct s -> Structure.str s
| Sum (comps, rdefs) ->
- let comps_s =
- String.concat " + " (List.map (fun (s, t) -> s ^ ": " ^ t) comps) in
- let defstr (rel, (vars, def)) =
- Formula.str (Rel (rel, Array.of_list vars)) ^
- " <- " ^ (Formula.str def)
- in
- if rdefs = [] then comps_s else
- comps_s ^ " with\n " ^
- (String.concat ";\n " (List.map defstr rdefs))
+ let pstr (s, t) = if s = "_" then t else s ^ ": " ^ t in
+ let comps_s = String.concat " + " (List.map pstr comps) in
+ let defstr (rel, (vars, def)) =
+ Formula.str (Rel (rel, Array.of_list vars)) ^
+ " <- " ^ (Formula.sprint def)
+ in
+ if rdefs = [] then comps_s else
+ comps_s ^ " with\n " ^
+ (String.concat ";\n " (List.map defstr rdefs)) ^ ";"
(* Print an inductive structure class as a string, using its definition. *)
let str cdefs =
- let cdef_s (id, alternatives) = "class " ^ id ^ " =\n " ^
+ let cdef_s (id, alternatives) = (* "class " ^ *) id ^ " =\n " ^
(String.concat "\n | " (List.map struct_sum_str alternatives))
in
String.concat "\nand " (List.map cdef_s cdefs)
@@ -69,36 +69,36 @@
| Sum (ids_l, rels_l) ->
let prefixes s = List.map (fun (i, _) -> s ^ ":" ^ i) ids_l in
let replace_in s = function
- In (fo_v, `MSO w) when w = s ->
- Or (List.map (fun ps -> In (fo_v, `MSO ps)) (prefixes s))
+ | In (fo_v, `MSO w) when w = s ->
+ Or (List.map (fun ps -> In (fo_v, `MSO ps)) (prefixes s))
| x -> x in
let rec split_formula = function
- Ex ([], phi) | All ([], phi) -> split_formula phi
+ | Ex ([], phi) | All ([], phi) -> split_formula phi
| Ex ([v], phi) -> (
- match v with
- `Real _ -> failwith "splitting reals not supported in ex"
- | `MSO s ->
- Ex (List.map (fun x -> `MSO x) (prefixes s),
- split_formula (map_to_atoms (replace_in s) phi))
- | `FO s ->
- let new_phi ps =
- Ex ([`FO ps], split_formula (subst_vars [(s, ps)] phi))
- in
- Or (List.map new_phi (prefixes s))
- )
+ match v with
+ | `Real _ -> failwith "splitting reals not supported (ex)"
+ | `SO _ -> failwith "splitting non-monadic SO not supported (ex)"
+ | `MSO s ->
+ Ex (List.map (fun x -> `MSO x) (prefixes s),
+ split_formula (map_to_atoms (replace_in s) phi))
+ | `FO s ->
+ let new_phi ps =
+ Ex ([`FO ps], split_formula (subst_vars [(s, ps)] phi)) in
+ Or (List.map new_phi (prefixes s))
+ )
| Ex (v::vs, phi) -> split_formula (Ex ([v], Ex (vs, phi)))
| All ([v], phi) -> (
- match v with
- `Real _ -> failwith "splitting reals not supported in forall"
- | `MSO s ->
- All (List.map (fun x -> `MSO x) (prefixes s),
- split_formula (map_to_atoms (replace_in s) phi))
- | `FO s ->
- let new_phi ps =
- All ([`FO ps], split_formula (subst_vars [(s, ps)] phi))
- in
- And (List.map new_phi (prefixes s))
- )
+ match v with
+ | `Real _ -> failwith "splitting reals not supported (all)"
+ | `SO _ -> failwith "splitting non-monadic SO not supported (all)"
+ | `MSO s ->
+ All (List.map (fun x -> `MSO x) (prefixes s),
+ split_formula (map_to_atoms (replace_in s) phi))
+ | `FO s ->
+ let new_phi ps =
+ All ([`FO ps], split_formula (subst_vars [(s, ps)] phi)) in
+ And (List.map new_phi (prefixes s))
+ )
| All (v::vs, phi) -> split_formula (All ([v], All (vs, phi)))
| Or (flist) -> Or (List.rev_map split_formula flist)
| And (flist) -> And (List.rev_map split_formula flist)
@@ -207,37 +207,44 @@
(* Compute a decomposition of a formula on a given class definition. *)
let decompose ?(get_ids=false) phi_in = function
- Struct s as cdef ->
- if !debug_level > 0 then print_endline ("Deciding " ^ (Formula.str phi_in) ^ " on struct");
- [[("", split phi_in cdef)]]
+ | Struct s as cdef ->
+ if !debug_level > 0 then
+ print_endline ("Deciding " ^ (Formula.str phi_in) ^ " on struct");
+ [[("", split phi_in cdef)]]
| Sum (ids_l, rels_r) as cdef ->
- let phi = class_tnf (simplify phi_in) in
- if !debug_level > 0 then
- print_endline ("Decomposing " ^ (Formula.str phi) ^ " on " ^ (struct_sum_str cdef));
- let phi_fv = free_vars phi in
- let split_phi = split (Ex (phi_fv, phi)) cdef in
- let (summand_ids, _) = List.split ids_l in
- let simp_split_phi = map_to_atoms (simplify_atom summand_ids) split_phi in
- match List.rev_map simplify (to_dnf (class_tnf (simplify (simp_split_phi)))) with
- [] -> [[("", Or [])]]
- | fl when List.mem (And []) fl -> [[("", And [])]]
- | fl ->
- let rec del_quant = (function
- Ex (vs, psi) ->
- let was_free v = List.mem v phi_fv in
- let ws= List.filter (fun x -> not (was_free x)) vs in
- if ws = [] then del_quant psi else Ex (ws, psi)
- | And flist -> And (List.map del_quant flist)
- | psi -> psi (* del_quant is applied to conjucts of DNF*) ) in
- let del_quants = List.rev_map (fun (s, f) -> (s, del_quant f)) in
- let process f = rename_extract_conjunction get_ids ids_l f in
- let decomp_lit_str (cid, phi) = "\nsome " ^ cid ^ " |= " ^ (Formula.str phi) in
- let decomp_tuple_str cj =
- "(" ^ String.concat " and " (List.map decomp_lit_str cj) ^ ")" in
- let decomp_str df = String.concat " or " (List.map decomp_tuple_str df) in
- let res = List.rev_map (fun f -> del_quants (process f)) fl in
- if (!debug_level > 1) then print_endline ("DECOMP: " ^ (decomp_str res));
- res
+ let phi = class_tnf (simplify phi_in) in
+ if !debug_level > 0 then
+ print_endline ("Decomposing " ^ (Formula.str phi) ^ " on " ^
+ (struct_sum_str cdef));
+ let phi_fv = free_vars phi in
+ let split_phi = split (Ex (phi_fv, phi)) cdef in
+ let (summand_ids, _) = List.split ids_l in
+ let simp_split_phi = map_to_atoms (simplify_atom summand_ids) split_phi in
+ match List.rev_map simplify
+ (to_dnf (class_tnf (simplify (simp_split_phi)))) with
+ | [] -> [[("", Or [])]]
+ | fl when List.mem (And []) fl -> [[("", And [])]]
+ | fl ->
+ let rec del_quant = (function
+ Ex (vs, psi) ->
+ let was_free v = List.mem v phi_fv in
+ let ws= List.filter (fun x -> not (was_free x)) vs in
+ if ws = [] then del_quant psi else Ex (ws, psi)
+ | And flist -> And (List.map del_quant flist)
+ | psi -> psi (* del_quant is applied to conjucts of DNF*) ) in
+ let del_quants = List.rev_map (fun (s, f) -> (s, del_quant f)) in
+ let process f = rename_extract_conjunction get_ids ids_l f in
+ let decomp_lit_str (cid, phi) =
+ "\nsome " ^ cid ^ " |= " ^ (Formula.str phi) in
+ let decomp_tuple_str cj =
+ "(" ^ String.concat " and " (List.map decomp_lit_str cj) ^ ")" in
+ let decomp_str df =
+ String.concat " or " (List.map decomp_tuple_str df) in
+ let fflat l = List.map (fun (s, f) -> (s, flatten f)) l in
+ let res = List.rev_map (fun f -> fflat (del_quants (process f))) fl in
+ if !debug_level > 1 then
+ print_endline ("DECOMP: " ^ (decomp_str res));
+ res
Modified: trunk/Toss/Solver/ClassTest.ml
===================================================================
--- trunk/Toss/Solver/ClassTest.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Solver/ClassTest.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -1,184 +1,251 @@
-Class.set_debug_level 0 ;;
+open OUnit
+Class.set_debug_level 0
+
let class_of_string s =
ClassParser.parse_class Lexer.lex (Lexing.from_string s)
-;;
+
let formula_of_string s =
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-;;
-let test_sum name f print_f class_str =
- let (_, suml) = List.hd (class_of_string class_str) in
- let sum = List.hd suml in
- print_endline (name ^ " on:\n" ^ (Class.struct_sum_str sum) ^ "\nis:");
- print_endline ((print_f (f sum)) ^"\n");
-;;
+let assert_eq_string arg msg x_in y_in =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ let ws = Str.regexp "[ \n\t]+" in
+ let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
+ let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
-let test name f print_f class_str =
- let cl = class_of_string class_str in
- print_endline (name ^ " on:\n" ^ (Class.str cl) ^ "\nis:");
- print_endline ((print_f (f cl)) ^"\n");
-;;
-(* ----------------- VARIOUS TREE CLASSES AND PARSING TESTS ----------------- *)
+(* ----------------- VARIOUS CLASSES ----------------- *)
let fin_tree_class =
"point =
- [x | Left:2 {} ; Right:2 {} ; Root { x } | ]
+ [x | Left:2 {}; Right:2 {}; Root (x) | ]
and tree =
point
| L: tree + N: point + R: tree with
- Left (x, y) <- Left (x, y) or (N (x) and L (y) and Root (y)) ;
- Right (x, y) <- Right (x, y) or (N(x) and R (y) and Root (y)) ;
- Root (x) <- N (x);"
-;;
+ Left(x, y) <- Left(x, y) or (N(x) and L(y) and Root(y));
+ Right(x, y) <- Right(x, y) or (N(x) and R(y) and Root(y));
+ Root(x) <- N(x);"
-test "Id" (fun x -> x) Class.str "point = [ x | | ]" ;;
-test "Id" (fun x -> x) Class.str fin_tree_class ;;
-
let inf_tree =
"tree =
L: tree + N: point + R: tree with
- Left (x, y) <- Left (x, y) or (N (x) and L (y) and Root (y)) ;
- Right (x, y) <- Right (x, y) or (N(x) and R (y) and Root (y)) ;
- Root (x) <- N (x);
+ Left(x, y) <- Left(x, y) or (N(x) and L(y) and Root(y));
+ Right(x, y) <- Right(x, y) or (N(x) and R(y) and Root(y));
+ Root(x) <- N(x);
and point =
- [x | Left:2 {} ; Right:2 {} ; Root { x } | ]"
-;;
+ [x | Left:2 {}; Right:2 {}; Root (x) | ]"
-test "Id" (fun x -> x) Class.str inf_tree ;;
-let omega =
- "omega =
- Z: point + S: omega with
- LessEq (x, y) <- LessEq (x, y) or Z (x) ;
- Succ (x, y) <- Succ (x, y) or (Z(x) and S (y) and Zero (y)) ;
- Zero (x) <- Z (x) ;
- and point =
- [x | LessEq { (x, x) } ; Succ:2 {} ; Zero { x } | ]"
-;;
-
-test "Id" (fun x -> x) Class.str inf_tree ;;
-test "Id" (fun x -> x) Class.str omega ;;
-
let inf_tree_lr =
"Ttree =
L: Ltree + N: point + R: Rtree with
- Pref (x, y) <- Pref (x, y) or (N(x) and (L(y) or R(y)));
- Left (x) <- Left (x);
- Right (x) <- Right (x);
- Root (x) <- N(x);
+ Pref(x, y) <- Pref(x, y) or (N(x) and (L(y) or R(y)));
+ Left(x) <- Left(x);
+ Right(x) <- Right(x);
+ Root(x) <- N(x);
and Ltree =
L: Ltree + N: point + R: Rtree with
- Pref (x, y) <- Pref (x, y) or (N(x) and (L(y) or R(y)));
- Left (x) <- Left (x) or N(x);
- Right (x) <- Right (x);
- Root (x) <- Root (x);
+ Pref(x, y) <- Pref(x, y) or (N(x) and (L(y) or R(y)));
+ Left(x) <- Left(x) or N(x);
+ Right(x) <- Right(x);
+ Root(x) <- Root(x);
and Rtree =
L: Ltree + N: point + R: Rtree with
- Pref (x, y) <- Pref (x, y) or (N(x) and (L(y) or R(y)));
- Left (x) <- Left (x);
- Right (x) <- Right (x) or N(x);
- Root (x) <- Root (x);
+ Pref(x, y) <- Pref(x, y) or (N(x) and (L(y) or R(y)));
+ Left(x) <- Left(x);
+ Right(x) <- Right(x) or N(x);
+ Root(x) <- Root(x);
and point =
- [x | Left:1 {} ; Right:1 {} ; Pref:2 {} ; Root:1 {} | ]"
-;;
+ [x | Left:1 {}; Pref:2 {}; Right:1 {}; Root:1 {} | ]"
-test "Id" (fun x -> x) Class.str inf_tree_lr ;;
+let omega =
+ "omega =
+ Z: point + S: omega with
+ LessEq(x, y) <- LessEq(x, y) or Z(x);
+ Succ(x, y) <- Succ(x, y) or (Z(x) and S(y) and Zero(y));
+ Zero(x) <- Z(x);
+ and point =
+ [x | LessEq (x, x); Succ:2 {}; Zero (x) | ]"
-(* ----------------------------- SPLIT TESTS -------------------------------- *)
-let test_split phi_s cs =
- let f = formula_of_string phi_s in
- let split_f s = Class.split f s in
- test_sum ("Split of " ^ phi_s) split_f Formula.str cs
-;;
-let test_split_simplify phi_s cs =
- let f = formula_of_string phi_s in
- let split_f s = Class.split_simplify f s in
- test_sum ("Simplified Split of " ^ phi_s) split_f Formula.str cs
-;;
+(* ------------------- UNIT TESTS ------------------- *)
-(* Splits on inf_tree. *)
+let test_sum name f print_f class_str res_str =
+ let (_, suml) = List.hd (class_of_string class_str) in
+ let sum = List.hd suml in
+ let sum_str = Class.struct_sum_str sum in
+ assert_eq_string sum_str name res_str (print_f (f sum))
-test_split "ex x Root (x)" inf_tree ;;
-test_split "ex x, y Left (x, y)" inf_tree ;;
+let tests = "Class" >::: [
+ "parsing and printing" >::
+ (fun () ->
+ let test name f print_f class_str res_str =
+ let cl = class_of_string class_str in
+ assert_eq_string class_str name res_str (print_f (f cl)) in
+ test "Id" (fun x -> x) Class.str "point = [ x | | ]" "point = [x | | ]";
+ test "Id" (fun x -> x) Class.str fin_tree_class fin_tree_class;
+ test "Id" (fun x -> x) Class.str inf_tree inf_tree;
+ test "Id" (fun x -> x) Class.str inf_tree_lr inf_tree_lr;
+ test "Id" (fun x -> x) Class.str omega omega;
+ );
-(* Y is contains all left-successors of X *)
-test_split "all X ex Y all x, y (x in X and Left (x, y) -> y in Y)" inf_tree ;;
+ "split" >::
+ (fun () ->
+ let test_split ?(do_simp=false) phi_s cs res =
+ let f = formula_of_string phi_s in
+ let split_f s =
+ if do_simp then Class.split_simplify f s else Class.split f s in
+ let name = if do_simp then "Simplified Split of " else "Split of " in
+ test_sum (name ^ phi_s) split_f Formula.str cs res in
+ test_split "ex x Root (x)" inf_tree
+ "(ex x:L (N(x:L)) or ex x:N (N(x:N)) or ex x:R (N(x:R)))";
+ test_split "ex x, y Left (x, y)" inf_tree
+ ("(ex x:L ((ex y:L ((Left(x:L, y:L) or ((N(x:L) and L(y:L)) and " ^
+ "Root(y:L)))) or ex y:N ((Left(x:L, y:N) or ((N(x:L) and L(y:N))" ^
+ " and Root(y:N)))) or ex y:R ((Left(x:L, y:R) or ((N(x:L) and " ^
+ "L(y:R)) and Root(y:R)))))) or ex x:N ((ex y:L ((Left(x:N, y:L) " ^
+ "or ((N(x:N) and L(y:L)) and Root(y:L)))) or ex y:N " ^
+ "((Left(x:N, y:N) or ((N(x:N) and L(y:N)) and Root(y:N)))) " ^
+ "or ex y:R ((Left(x:N, y:R) or ((N(x:N) and L(y:R)) and " ^
+ "Root(y:R)))))) or ex x:R ((ex y:L ((Left(x:R, y:L) or ((N(x:R) " ^
+ "and L(y:L)) and Root(y:L)))) or ex y:N ((Left(x:R, y:N) or " ^
+ "((N(x:R) and L(y:N)) and Root(y:N)))) or ex y:R ((Left(x:R, y:R)" ^
+ " or ((N(x:R) and L(y:R)) and Root(y:R)))))))");
+ test_split ~do_simp:true (* Y is contains all left-successors of X *)
+ "all X ex Y all x, y (x in X and Left (x, y) -> y in Y)" inf_tree
+ ("all X:L, X:N, X:R (ex Y:L, Y:N, Y:R ((all x:L (all y:L" ^
+ " (((y:L in Y:L) or (not (Left(x:L, y:L) and (x:L in X:L))))))" ^
+ " and all x:R (all y:R (((y:R in Y:R) or (not (Left(x:R, y:R) " ^
+ "and (x:R in X:R)))))) and all x:N ((all y:N (((y:N in Y:N) or" ^
+ " (not (Left(x:N, y:N) and (x:N in X:N))))) and all y:L " ^
+ "(((y:L in Y:L) or (not ((x:N in X:N) and Root(y:L))))))))))");
-(* Splits on inf_tree_lr. *)
+ test_split "ex x, y Pref (x, y)" inf_tree_lr
+ ("(ex x:L ((ex y:L ((Pref(x:L, y:L) or (N(x:L) and (L(y:L) or " ^
+ "R(y:L))))) or ex y:N ((Pref(x:L, y:N) or (N(x:L) and (L(y:N)" ^
+ " or R(y:N))))) or ex y:R ((Pref(x:L, y:R) or (N(x:L) and " ^
+ "(L(y:R) or R(y:R))))))) or ex x:N ((ex y:L ((Pref(x:N, y:L) or" ^
+ " (N(x:N) and (L(y:L) or R(y:L))))) or ex y:N ((Pref(x:N, y:N)" ^
+ " or (N(x:N) and (L(y:N) or R(y:N))))) or " ^
+ "ex y:R ((Pref(x:N, y:R) or (N(x:N) and (L(y:R) or R(y:R)))))))" ^
+ " or ex x:R ((ex y:L ((Pref(x:R, y:L) or (N(x:R) and (L(y:L) " ^
+ "or R(y:L))))) or ex y:N ((Pref(x:R, y:N) or (N(x:R) and " ^
+ "(L(y:N) or R(y:N))))) or ex y:R ((Pref(x:R, y:R) or (N(x:R) " ^
+ "and (L(y:R) or R(y:R))))))))");
+ test_split ~do_simp:true
+ ("ex X (all x (x in X -> (Left(x) and all y (Pref(y,x) -> " ^
+ "(Root(y) or Right(y))))))") inf_tree_lr
+ ("ex X:L, X:N, X:R ((all x:N ((Left(x:N) or (not (x:N in X:N)))) " ^
+ "and all x:L (((not (x:L in X:L)) or (Left(x:L) and all y:L " ^
+ "((Right(y:L) or (not Pref(y:L, x:L))))))) and all x:R (((not" ^
+ " (x:R in X:R)) or (Left(x:R) and all y:R ((Right(y:R) or " ^
+ "(not Pref(y:R, x:R)))))))))");
+ test_split ~do_simp:true
+ ("ex X (all x (x in X -> (Left(x) and all y (Pref(y,x) -> " ^
+ "(Root(y) or Right(y))))))") inf_tree_lr
+ ("ex X:L, X:N, X:R ((all x:N ((Left(x:N) or (not (x:N in X:N)))) " ^
+ "and all x:L (((not (x:L in X:L)) or (Left(x:L) and all y:L " ^
+ "((Right(y:L) or (not Pref(y:L, x:L))))))) and all x:R (((not" ^
+ " (x:R in X:R)) or (Left(x:R) and all y:R ((Right(y:R) " ^
+ "or (not Pref(y:R, x:R)))))))))");
+ );
-test_split "ex x, y Pref (x, y)" inf_tree_lr ;;
+ "decompose" >::
+ (fun () ->
+ let test_decompose ?(ids=true) phi_s cs res =
+ let f = formula_of_string phi_s in
+ let decompose_f s = Class.decompose ~get_ids:ids f s in
+ let decomp_lit_str (cid, phi) =
+ "Ex " ^ cid ^ " |= " ^ (Formula.sprint phi) in
+ let decomp_tuple_str cj =
+ "(" ^ String.concat " and " (List.map decomp_lit_str cj) ^ ")" in
+ let decomp_str df =
+ String.concat " or " (List.map decomp_tuple_str df) in
+ test_sum ("Decomposition of " ^ phi_s) decompose_f decomp_str cs res in
-test_split ("ex X (all x (x in X -> (Left(x) and all y (Pref(y,x) -> " ^
- "(Root(y) or Right(y))))))") inf_tree_lr ;;
+ (* On omega *)
+ test_decompose "ex x, y LessEq (x, y)" omega "(Ex |= true)";
+ test_decompose
+ ("ex Z (((not all s ((Zero(s) or (not (s in Z))))) and " ^
+ "ex C ((all s (((s in C) or (not Zero(s)))) and " ^
+ "all t (((t in C) or (not (t in Z)))) and " ^
+ "all t (((t in Z) or (not (t in C)))) and " ^
+ "all s (((not (s in C)) or all t ((not Succ(t, s))))) and all s " ^
+ "(((not (s in C)) or all t (((t in C) or (not Succ(t, s))))))))))")
+ omega
+ ("(Ex Z |= (all s, t not Succ(t, s) and ex Z, C (all s s in C and " ^
+ "all t t in C and all t t in Z)) and Ex S |= ex Z (not all s " ^
+ "not s in Z and ex C (all t (t in C or not t in Z) and all t " ^
+ "(t in Z or not t in C) and all s (not s in C or all t (t in C " ^
+ "or not Succ(t, s))) and all s (not s in C or (not Zero(s) and " ^
+ "all t not Succ(t, s)))))) or (Ex Z |= (all s, t not Succ(t, s) " ^
+ "and ex Z, C (all s s in C and all t t in Z)) and Ex S |= ex Z " ^
+ "(not all s not s in Z and ex C (all t (t in C or not t in Z) and" ^
+ " all t (t in Z or not t in C) and all s (not Zero(s) or " ^
+ "not s in C) and all s (not s in C or all t (t in C or not " ^
+ "Succ(t, s))) and all s (not s in C or (not Zero(s) and " ^
+ "all t not Succ(t, s))))))");
-test_split_simplify ("ex X (all x (x in X -> (Left(x) and all y (Pref(y,x) -> " ^
- "(Root(y) or Right(y))))))") inf_tree_lr ;;
+ (* On inf_tree *)
+ test_decompose "ex x Root (x)" inf_tree "(Ex |= true)";
+ test_decompose "x in X" inf_tree
+ "(Ex L |= x in X) or (Ex N |= x in X) or (Ex R |= x in X)";
+ test_decompose "ex x, y Left (x, y)" inf_tree
+ ("(Ex L |= ex x, y Left(x, y)) or (Ex N |= ex x, y Left(x, y))" ^
+ " or (Ex R |= ex x, y Left(x, y)) or (Ex L |= ex y Root(y))");
+ (* On inf_tree_lr *)
+ test_decompose ("ex X (all x (x in X -> (Left(x) and all y (Pref(y,x) " ^
+ "-> (Root(y) or Right(y))))))") inf_tree_lr
+ ("(Ex R |= ex X all x (not x in X or (Left(x) and all y (Right(y) or " ^
+ "not Pref(y, x)))) and Ex N |= ex X all x (Left(x) or not x in X)" ^
+ " and Ex L |= ex X all x (not x in X or (Left(x) and " ^
+ "all y (Right(y) or not Pref(y, x)))))");
+ test_decompose "Left(x) and Right(y)" inf_tree_lr
+ ("(Ex L |= (Left(x) and Right(y))) or (Ex N |= Right(y) and " ^
+ "Ex L |= Left(x)) or (Ex R |= Right(y) and Ex L |= Left(x)) or " ^
+ "(Ex N |= Left(x) and Ex L |= Right(y)) or (Ex N |= (Left(x) " ^
+ "and Right(y))) or (Ex R |= Right(y) and Ex N |= Left(x)) or " ^
+ "(Ex R |= Left(x) and Ex L |= Right(y)) or (Ex R |= Left(x) and " ^
+ "Ex N |= Right(y)) or (Ex R |= (Left(x) and Right(y)))");
+ test_decompose "ex x Left(x)" inf_tree_lr
+ ("(Ex L |= ex x Left(x)) or (Ex N |= ex x Left(x)) or" ^
+ " (Ex R |= ex x Left(x))");
+ test_decompose "Left(x)" inf_tree_lr
+ "(Ex L |= Left(x)) or (Ex N |= Left(x)) or (Ex R |= Left(x))";
+ test_decompose "all y (x=y or Pref(x,y))" inf_tree_lr
+ "(Ex N |= all y (Pref(x, y) or x = y))";
+ test_decompose "Left(x) and Right(y) and all z (Pref(z,x) and Pref(z,y))"
+ inf_tree_lr "(Ex |= false)";
+ test_decompose
+ "ex X ex y( y in X and all z( Pref(y,z) or z in X))" inf_tree_lr
+ ("(Ex N |= ex X, y (y in X and all z (Pref(y, z) or z in X))) or " ^
+ "(Ex R |= ex X, y (y in X and all z (Pref(y, z) or z in X)) and" ^
+ " Ex N |= ex X all z z in X and Ex L |= ex X all z z in X) or " ^
+ "(Ex R |= ex X all z z in X and Ex N |= ex X all z z in X and " ^
+ "Ex L |= ex X, y (y in X and all z (Pref(y, z) or z in X)))");
+ test_decompose
+ "all X ex y( y in X and all z( Pref(y,z) or z in X))" inf_tree_lr
+ ("(Ex N |= all X ex y (y in X and all z (Pref(y, z) or z in X))) or" ^
+ " (Ex L |= all X, z z in X) or (Ex R |= true and Ex L |= " ^
+ "all X, z z in X) or (Ex R |= all X, z z in X and Ex L |= true) " ^
+ "or (Ex R |= all X, z z in X)");
+ );
+]
-(* --------------------------- DECOMPOSE TESTS ------------------------------ *)
-let test_decompose ids phi_s cs =
- let f = formula_of_string phi_s in
- let decompose_f s = Class.decompose ~get_ids:ids f s in
- let decomp_lit_str (cid, phi) = "some " ^ cid ^ " |= " ^ (Formula.str phi) in
- let decomp_tuple_str cj =
- "(" ^ String.concat " and " (List.map decomp_lit_str cj) ^ ")" in
- let decomp_str df = String.concat " or " (List.map decomp_tuple_str df) in
- test_sum ("Decomposition of " ^ phi_s) decompose_f decomp_str cs
-;;
-
-
-(* Decompositions on omega. *)
-
-test_decompose true "ex x, y LessEq (x, y)" omega ;;
-
-
-(* Decompositions on inf_tree. *)
-
-test_decompose true "ex x Root (x)" inf_tree ;;
-
-test_decompose true "x in X" inf_tree ;;
-
-test_decompose true "ex x, y Left (x, y)" inf_tree ;;
-
-test_decompose true ("ex X (all x (x in X -> (Left(x) and all y (Pref(y,x) -> "^
- "(Root(y) or Right(y))))))") inf_tree_lr ;;
-
-test_decompose true "Left(x) and Right(y)" inf_tree_lr ;;
-
-test_decompose true "ex x Left(x)" inf_tree_lr ;;
-
-test_decompose true "Left(x)" inf_tree_lr ;;
-
-test_decompose true "all y (x=y or Pref(x,y))" inf_tree_lr ;;
-
-test_decompose true "Left(x) and Right(y) and all z (Pref(z,x) and Pref(z,y))" inf_tree_lr ;;
-
-
-(* ------------ There is some bug... --------------- *)
-
-(* "ex X ..." works *)
-test_decompose true "ex X ex y( y in X and all z( Pref(y,z) or z in X))" inf_tree_lr ;;
-
-(* but "all X ..." does not *)
-Class.set_debug_level 2 ;;
-test_decompose true "all X ex y( y in X and all z( Pref(y,z) or z in X))" inf_tree_lr ;;
-
-
-
-
(* ------------------------- MODEL CHECKING TESTS -------------------------- *)
let test_check phi_s id cs =
@@ -188,7 +255,6 @@
print_endline "";
;;
-Class.set_debug_level 0 ;;
test_check "all x, y LessEq (x, y)" "omega" omega ;;
@@ -334,16 +400,6 @@
;;
-test_decompose true
- "ex Z (((not all s ((Zero(s) or (not (s in Z))))) and
- ex C ((all s (((s in C) or (not Zero(s)))) and
- all t (((t in C) or (not (t in Z)))) and
- all t (((t in Z) or (not (t in C)))) and
- all s (((not (s in C)) or all t ((not Succ(t, s)))))
- and all s (((not (s in C)) or all t (((t in C) or (not Succ(t, s))))))))))"
- omega ;;
-
-
(* ------------ HORN FORMULA TESTS ------------------ *)
@@ -358,10 +414,6 @@
"ex X (" ^ quant ^ "(" ^ clauses ^ "))"
;;
-FormulaOps.set_debug_level 0 ;;
-Sat.set_debug_level 0;;
-Class.set_debug_level 1 ;;
-
let horn_f = horn 10 ;;
print_endline ("Horn: " ^ horn_f);
@@ -372,7 +424,6 @@
-BoolFormula.set_simplification 6 ;;
(*
print_endline ("Checking non-TNF Horn...");;
@@ -385,9 +436,4 @@
print_endline ("Checking TNF Horn...");;
test_check horn_tnf "omega" omega ;;
-
-let s = Gc.stat () in
-let alloc_w = s.Gc.minor_words +. s.Gc.major_words -. s.Gc.promoted_words in
-print_endline ("Alloc B: " ^ (string_of_float (4. *. alloc_w)));
-print_endline ("Alloc KB: " ^ (string_of_float (alloc_w /. 256. )));
-print_endline ("Alloc MB: " ^ (string_of_float (alloc_w /. (1024. *. 256.))));
+let exec = Aux.run_test_if_target "ClassTest" tests ;;
Modified: trunk/Toss/Solver/PresbTest.ml
===================================================================
--- trunk/Toss/Solver/PresbTest.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/Solver/PresbTest.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -129,7 +129,7 @@
BoolFormula.set_debug_level 0 ;;
BoolFormula.set_simplification 6 ;;
-Class.set_debug_level 1;;
+Class.set_debug_level 0;;
test_check eq "omega" omega ;;
Modified: trunk/Toss/TossTest.ml
===================================================================
--- trunk/Toss/TossTest.ml 2011-04-27 17:44:35 UTC (rev 1423)
+++ trunk/Toss/TossTest.ml 2011-04-28 22:09:04 UTC (rev 1424)
@@ -14,6 +14,7 @@
StructureTest.tests;
AssignmentsTest.tests;
SolverTest.tests;
+ ClassTest.tests;
]
let arena_tests = "Arena" >::: [
@@ -36,6 +37,7 @@
]
let server_tests = "Server" >::: [
+ PictureTest.tests;
ServerTest.tests;
]
Added: trunk/Toss/www/img/Breakthrough.ppm
===================================================================
--- trunk/Toss/www/img/Breakthrough.ppm (rev 0)
+++ trunk/Toss/www/img/Breakthrough.ppm 2011-04-28 22:09:04 UTC (rev 1424)
@@ -0,0 +1,120003 @@
+P3
+200 200
+255
+0
+0
+0
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+43
+0
+21
+47
+0
+19
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+44
+0
+18
+49
+0
+12
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+40
+0
+13
+41
+0
+16
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+41
+0
+20
+41
+0
+20
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+41
+0
+16
+40
+0
+13
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+49
+0
+12
+44
+0
+18
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+47
+0
+19
+43
+0
+21
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+45
+0
+15
+0
+0
+0
+26
+0
+26
+38
+3
+20
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+40
+6
+21
+43
+8
+24
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+52
+17
+30
+44
+9
+24
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+9
+25
+39
+4
+21
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+40
+5
+21
+41
+7
+22
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+48
+13
+27
+45
+10
+25
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+43
+8
+23
+40
+6
+22
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+49
+14
+27
+44
+8
+23
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+45
+11
+26
+38
+3
+20
+26
+0
+26
+26
+0
+26
+39
+4
+21
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+113
+82
+73
+112
+80
+71
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+57
+22
+33
+200
+171
+132
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+197
+167
+130
+54
+20
+31
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+228
+170
+255
+22...
[truncated message content] |
