Thread: [Toss-devel-svn] SF.net SVN: toss:[1405] trunk/Toss (Page 6)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn
|
From: <luk...@us...> - 2011-04-05 15:58:03
|
Revision: 1405
http://toss.svn.sourceforge.net/toss/?rev=1405&view=rev
Author: lukaszkaiser
Date: 2011-04-05 15:57:57 +0000 (Tue, 05 Apr 2011)
Log Message:
-----------
Starting to move some python DB stuff to ocaml.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Makefile
trunk/Toss/README
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/Server/DB.ml
trunk/Toss/Server/DB.mli
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-03-29 17:16:10 UTC (rev 1404)
+++ trunk/Toss/Arena/Arena.ml 2011-04-05 15:57:57 UTC (rev 1405)
@@ -1010,3 +1010,54 @@
((g, s), "STATE SET")
| GetModel -> ((state_game, state), Structure.sprint state.struc)
| GetState -> ((state_game, state), state_str (state_game, state))
+
+
+let can_modify_game = function
+ AddElem _ -> true
+ | AddRel _ -> true
+ | DelElem _ -> true
+ | DelRel _ -> true
+ | GetRelSignature _ -> false
+ | GetFunSignature _ -> false
+ | GetAllTuples _ -> false
+ | GetAllElems _ -> false
+ | SetFun _ -> false (* TODO: rethink when working on dyns *)
+ | GetFun _ -> false
+ | SetData _ -> false
+ | GetData _ -> false
+ | SetArity _ -> true
+ | GetArity _ -> false
+ | RenamePlayer _ -> false
+ | SetLoc i -> true
+ | GetLoc -> false
+ | SetLocPlayer _ -> true
+ | GetLocPlayer _ -> false
+ | SetLocPayoff _ -> true
+ | GetLocPayoff _ -> false
+ | GetCurPayoffs -> false
+ | SetLocMoves _ -> true
+ | GetLocMoves _ -> false
+ | SuggestLocMoves _ -> false
+ | EvalFormula _ -> false
+ | EvalRealExpr _ -> false
+ | SetRule _ -> true
+ | GetRule _ -> false
+ | SetRuleUpd _ -> true
+ | GetRuleUpd _ -> false
+ | SetRuleDyn _ -> true
+ | GetRuleDyn _ -> false
+ | SetRuleCond _ -> true
+ | GetRuleCond _ -> false
+ | SetRuleEmb _ -> true
+ | GetRuleEmb _ -> false
+ | SetRuleAssoc _ -> true
+ | GetRuleAssoc _ -> false
+ | GetRuleMatches _ -> false
+ | ApplyRule _ -> true
+ | ApplyRuleInt _ -> true
+ | GetRuleNames -> false
+ | SetTime _ -> false (* TODO: rethink when working on dyns *)
+ | GetTime -> false
+ | SetState _ -> true
+ | GetModel -> false
+ | GetState -> false
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-03-29 17:16:10 UTC (rev 1404)
+++ trunk/Toss/Arena/Arena.mli 2011-04-05 15:57:57 UTC (rev 1405)
@@ -212,3 +212,5 @@
val handle_request :
game * game_state -> request -> (game * game_state) * string
+
+val can_modify_game : request -> bool
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-03-29 17:16:10 UTC (rev 1404)
+++ trunk/Toss/Makefile 2011-04-05 15:57:57 UTC (rev 1405)
@@ -46,10 +46,10 @@
# -------- MAIN OCAMLBUILD PART --------
OCB_COBJ=../Formula/Sat/minisat/MiniSATWrap.o,../Formula/Sat/minisat/SatSolver.o
-OCB_LFLAG=-lflags -I,+oUnit,-cclib,-lstdc++,$(OCB_COBJ)
-OCB_LFLAGBT=-lflags -I,+oUnit,-custom,$(OCB_COBJ),"-cclib -lstdc++"
-OCB_CFLAG=-cflags -I,+oUnit,-g
-OCB_LIB=-libs str,nums,unix,oUnit
+OCB_LFLAG=-lflags -I,+oUnit,-I,+sqlite3,-cclib,-lstdc++,$(OCB_COBJ)
+OCB_LFLAGBT=-lflags -I,+oUnit,-I,+sqlite3,-custom,$(OCB_COBJ),"-cclib -lstdc++"
+OCB_CFLAG=-cflags -I,+oUnit,-I,+sqlite3,-g
+OCB_LIB=-libs str,nums,unix,oUnit,sqlite3
OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_backtrace.cmo"
OCAMLBUILD=ocamlbuild -log build.log -j 8 -menhir ../menhir_conf $(OCB_PP) \
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
@@ -83,7 +83,7 @@
doc: Formula/Sat/minisat/SatSolver.o Formula/Sat/minisat/MiniSATWrap.o \
caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo
- $(OCAMLBUILDNOPP) -Is +oUnit,$(.INC) Toss.docdir/index.html
+ $(OCAMLBUILDNOPP) -Is +oUnit,+sqlite3,$(.INC) Toss.docdir/index.html
make -C www code_doc_link
Modified: trunk/Toss/README
===================================================================
--- trunk/Toss/README 2011-03-29 17:16:10 UTC (rev 1404)
+++ trunk/Toss/README 2011-04-05 15:57:57 UTC (rev 1405)
@@ -11,7 +11,7 @@
-- Installing dependencies under Ubuntu
Run the following in terminal:
- sudo apt-get install g++ python-qt4 python-dev pyqt4-dev-tools ocaml-findlib menhir libounit-ocaml-dev
+ sudo apt-get install g++ python-qt4 python-dev pyqt4-dev-tools ocaml-findlib menhir libounit-ocaml-dev libsqlite3-ocaml-dev
Finally to compile Toss just type
make
Added: trunk/Toss/Server/DB.ml
===================================================================
--- trunk/Toss/Server/DB.ml (rev 0)
+++ trunk/Toss/Server/DB.ml 2011-04-05 15:57:57 UTC (rev 1405)
@@ -0,0 +1,22 @@
+(* Wrapper around Toss DB interface. We use sqlite for now, see below.
+ http://hg.ocaml.info/release/ocaml-sqlite3/file/0e2f7d2cbd12/sqlite3.mli
+*)
+
+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 get_table dbfile ?(select="") tbl =
+ let (rows, wh_s) = (ref [], if select = "" then "" else " where " ^ select) in
+ let select_s = "select * from " ^ tbl ^ 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
+ ignore (Sqlite3.db_close db);
+ match res with
+ | Sqlite3.Rc.OK -> List.rev !rows
+ | x -> raise (DBError (Sqlite3.Rc.to_string x))
+
+
Added: trunk/Toss/Server/DB.mli
===================================================================
--- trunk/Toss/Server/DB.mli (rev 0)
+++ trunk/Toss/Server/DB.mli 2011-04-05 15:57:57 UTC (rev 1405)
@@ -0,0 +1,7 @@
+exception DBError of string
+
+val print_row : string array -> unit
+
+val print_rows : string array list -> unit
+
+val get_table : string -> ?select : string -> string -> string array list
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-29 17:16:10 UTC (rev 1404)
+++ trunk/Toss/Server/Server.ml 2011-04-05 15:57:57 UTC (rev 1405)
@@ -110,54 +110,8 @@
line
let possibly_modifies_game = function
- Arena.AddElem _ -> true
- | Arena.AddRel _ -> true
- | Arena.DelElem _ -> true
- | Arena.DelRel _ -> true
- | Arena.GetRelSignature _ -> false
- | Arena.GetFunSignature _ -> false
- | Arena.GetAllTuples _ -> false
- | Arena.GetAllElems _ -> false
- | Arena.SetFun _ -> false (* TODO: rethink when working on dyns *)
- | Arena.GetFun _ -> false
- | Arena.SetData _ -> false
- | Arena.GetData _ -> false
- | Arena.SetArity _ -> true
- | Arena.GetArity _ -> false
- | Arena.RenamePlayer _ -> false
| Arena.SetLoc i -> i <> !expected_location
- | Arena.GetLoc -> false
- | Arena.SetLocPlayer _ -> true
- | Arena.GetLocPlayer _ -> false
- | Arena.SetLocPayoff _ -> true
- | Arena.GetLocPayoff _ -> false
- | Arena.GetCurPayoffs -> false
- | Arena.SetLocMoves _ -> true
- | Arena.GetLocMoves _ -> false
- | Arena.SuggestLocMoves _ -> false
- | Arena.EvalFormula _ -> false
- | Arena.EvalRealExpr _ -> false
- | Arena.SetRule _ -> true
- | Arena.GetRule _ -> false
- | Arena.SetRuleUpd _ -> true
- | Arena.GetRuleUpd _ -> false
- | Arena.SetRuleDyn _ -> true
- | Arena.GetRuleDyn _ -> false
- | Arena.SetRuleCond _ -> true
- | Arena.GetRuleCond _ -> false
- | Arena.SetRuleEmb _ -> true
- | Arena.GetRuleEmb _ -> false
- | Arena.SetRuleAssoc _ -> true
- | Arena.GetRuleAssoc _ -> false
- | Arena.GetRuleMatches _ -> false
- | Arena.ApplyRule _ -> true
- | Arena.ApplyRuleInt _ -> true
- | Arena.GetRuleNames -> false
- | Arena.SetTime _ -> false (* TODO: rethink when working on dyns *)
- | Arena.GetTime -> false
- | Arena.SetState _ -> true
- | Arena.GetModel -> false
- | Arena.GetState -> false
+ | r -> Arena.can_modify_game r
exception Found of int
@@ -577,12 +531,14 @@
Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
let (server, port, load_gdl) = (ref "localhost", ref 8110, ref true) in
let (experiment, e_len, e_d1, e_d2) = (ref false, ref 1, ref 2, ref 2) in
+ let sqltest = ref "" in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose");
("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose");
("-nogdl", Arg.Unit (fun () -> load_gdl := false), " don't load GDL");
("-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)");
("-gdl", Arg.String (fun s ->
GDL.manual_game := s; GDL.manual_translation := true),
" GDL game for manual (i.e. hard-coded) translation (tictactoe, breakthrough, etc.)");
@@ -631,6 +587,8 @@
);
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 Host_not_found -> print_endline "The host you specified was not found."
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-13 14:42:46
|
Revision: 1407
http://toss.svn.sourceforge.net/toss/?rev=1407&view=rev
Author: lukaszkaiser
Date: 2011-04-13 14:42:37 +0000 (Wed, 13 Apr 2011)
Log Message:
-----------
Removing Game ml.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Play/Makefile
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/ServerTest.ml
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Removed Paths:
-------------
trunk/Toss/Play/Game.ml
trunk/Toss/Play/GameTest.ml
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-04-05 20:44:16 UTC (rev 1406)
+++ trunk/Toss/Makefile 2011-04-13 14:42:37 UTC (rev 1407)
@@ -129,7 +129,7 @@
Play/HeuristicTest \
Play/MoveTest \
Play/GameTreeTest \
- Play/GameTest
+ Play/PlayTest
# GGP tests
GGP_tests: \
Deleted: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-04-05 20:44:16 UTC (rev 1406)
+++ trunk/Toss/Play/Game.ml 2011-04-13 14:42:37 UTC (rev 1407)
@@ -1,1245 +0,0 @@
-(* Game-related definitions. The UCTS algorithm. *)
-
-open Printf
-
-(* Default effort overshoots to let timeout handle stopping. *)
-let default_effort = ref 10
-
-let debug_level = ref 0
-let set_debug_level i = (debug_level := i)
-
-let deterministic_suggest = ref false
-
-(* A global "hurry up!" switch triggered by the timer alarm. *)
-let timeout = ref false
-let get_timeout () = !timeout
-let cancel_timeout () =
- let remaining = Unix.alarm 0 in
- (* {{{ log entry *)
- if !debug_level > 0 then (
- if !timeout then
- Printf.printf "Computation finished by timeout.\n%!"
- else
- Printf.printf "Computation finished with %d seconds left.\n%!"
- remaining
- );
- (* }}} *)
- timeout := false
-
-let trigger_timeout _ =
- (* if !debug_level > 0 then printf " TIMEOUT %!"; *)
- (* TODO: no output possible from inside handler *)
- timeout := true
-
-let () =
- Sys.set_signal Sys.sigalrm
- (Sys.Signal_handle (fun _ -> timeout := true))
-
-type f_table = float array
-
-(* Cumulative score of players for computing value estimate. *)
-type score = {
- score_table : f_table; (* sum of payoffs *)
- variation_table : f_table; (* sum of squares of payoffs *)
- (* sum of the squares of payoffs *)
- score_obs : int (* number of observations *)
-}
-
-let add_score {score_table=table1; variation_table=vartab1; score_obs=obs1}
- {score_table=table2; variation_table=vartab2; score_obs=obs2} =
- {score_table = Aux.array_map2 (fun sc1 sc2 ->
- sc1+.sc2) table1 table2;
- variation_table = Aux.array_map2 (fun sc1 sc2 ->
- sc1+.sc2) vartab1 vartab2;
- score_obs = abs obs1 + abs obs2}
-
-let score_payoff payoff = {
- score_table = payoff;
- variation_table = Array.map (fun sc-> sc*.sc) payoff;
- score_obs = 1;
-}
-
-let discount n payoffs =
- Array.map (fun payoff ->
- (0.5 +. 1./.((float_of_int n) +. 2.)) *. payoff) payoffs
-
-
-type uctree_node = {
- node_state : Arena.game_state ;
- node_stats : score ; (* playout statistic *)
- node_heuristic : f_table ; (* heuristic table *)
- node_bestheur : int ; (* the subtree from which
- [node_heuristic] is picked *)
- node_endstate : Structure.structure ; (* final game state of a
- playout that originated
- the node (mostly for debugging) *)
- node_subtrees : uctree array ;
-}
-
-(* The game tree for turn-based multiplayer games UCT search. Assumes
- determinism of move generation (the same state and location should
- result in the same array of moves). *)
-and uctree =
- | Node of uctree_node
- | Leaf of Arena.game_state * score * f_table * Structure.structure
- (* once played leaf: state, time, location, score, heuristic, game-end *)
- | Tip of Arena.game_state * f_table
- (* unplayed leaf, with heuristic value (evaluation game
- result) *)
- | Terminal of Arena.game_state * score * f_table * f_table
- (* the score, the cache of the actual payoff table and the
- heuristic *)
- | TEmpty (* to be expanded in any context *)
-
-(* History stored for a play, including caching of computations for
- further use. *)
-type memory =
- | No_memory
- | State_history of Structure.structure list
- (* states visited in reverse order *)
- | UCTree of uctree
-
-(* Effect that heuristics have on the MCTS algorithm. *)
-type mcts_heur_effect =
- | Heuristic_local of float (* TODO: not implemented *)
- (* each tree node only considers the heuristic of its state,
- the parameter is the influence of the heuristic on the tree
- traversal, there is no influence on the actual choice *)
- | Heuristic_mixed of float * float
- (* a node stores a heuristic maximaxed from the leaf states of
- the subtree, [MaximaxMixed (trav, select)] has [trav]
- the influence on the tree traversal, [select] the influence
- on the actual choice *)
- | Heuristic_select of float
- (* a node stores a heuristic maximaxed from the leaf states of
- the subtree, the parameter is the influence on the tree
- traversal, the actual choice is based on the heuristic alone
- and not the Monte-Carlo payoff estimates *)
- | Heuristic_only
- (* a node stores a heuristic maximaxed from the leaf states of
- the subtree, which completely replaces the role of the
- Monte-Carlo payoff estimates from the standard UCT algorithm *)
-
-
-(* Parameters of the Upper Confidence Bounds-based Monte Carlo Tree
- Search. Cooperative (competitive) mode means that of actions with
- equal value for a given player, the one with highest (lowest) sum
- of values is chosen. *)
-type uct_params = {
- cUCB : float ; (* coefficient of the confidence bound component *)
- constK : float ; (* smoothening *)
- iters : int ; (* tree updates per move *)
- horizon : int option ; (* limit on the playout length *)
- heur_effect : mcts_heur_effect ; (* maximaxed vs local heuristic *)
- cooperative : bool ; (* cooperative vs competitive *)
- cLCB : float option ; (* cautious action picking; if present, use
- lower confidence bound with given
- coefficient for action selection *)
-}
-
-(* An evaluation game is a set of games specific to locations, each
- game is used to assess the value of its location. It contains the
- same data as {!play} plus {!play_state} (for initial state) below,
- only without the [struc] and [time] fields, and with some general
- playout parameters. [ev_agents] array can be empty but only if
- every location of the [ev_game] subgame has empty moves list. *)
-type evgame_loc = {
- ev_game : Arena.game;
- ev_agents : agent array; (* player-indexed or empty *)
- ev_delta : float;
- ev_location : int;
- ev_memory : memory array; (* player-indexed *)
- ev_horizon : int option;
-}
-and evaluation_game = evgame_loc array
-
-
-(* How does a player pick moves. *)
-and agent =
- | Random_move
- (* select a random move; avoids rewriting all matches and calling
- evaluation games *)
- | Maximax_evgame of evaluation_game * bool * int * bool
- (* select a move according to evaluation games played in each
- leaf state; in a cooperative/competitive way (see
- {!uct_params}); expand the full game subtree to the given
- depth and propagate evaluation game results from leaves by
- taking cooperative/competitive best move for location's
- player; optional alpha-beta-like pruning, with move
- reordering based on afterstate heuristic value *)
- | Tree_search of evaluation_game * int option * uct_params * agent array
- (* Monte-Carlo tree search; uses the evaluation game to compute
- heuristic values for use within the tree, and the agents for
- playout plays *)
- | External of (string array -> int)
- (* take an array of string representations of resulting structures
- and return the position of the desired state; for interacting
- with external players only *)
-
-(* The evolving state of a play. *)
-type play_state = {
- game_state : Arena.game_state ;
- memory : memory array ; (* player-specific history *)
-}
-
-(* Data defining a play (without the initial play state). TODO:
- remove dependency on [delta] (move it to Arena.game). *)
-type play = {
- game : Arena.game ; (* the game played *)
- agents : agent array ; (* player-indexed *)
- delta : float ; (* expected width of payoffs *)
-}
-
-
-let default_params = {
- cUCB = 1.0 ;
- cLCB = Some 1.0 ;
- constK = 1.0 ;
- iters = 200 ;
- horizon = None ;
- heur_effect = Heuristic_mixed (0.5, 0.2) ;
- cooperative = false ;
-}
-
-
-let default_heuristic = Heuristic.default_heuristic
-
-(* The UCB1-TUNED estimate, modified to extend to the zero- and
- one-observation cases. *)
-let ucb1_tuned ?(lower_bound=false)
- params delta player parent_sc ~heuristic score =
- if parent_sc.score_obs = 0 then failwith
- "ucb1_tuned: parent has no observations";
- let cHEUR = match params.heur_effect with
- | Heuristic_local c when not lower_bound -> c
- | Heuristic_mixed (c, _) when not lower_bound -> c
- | Heuristic_mixed (_, c) when lower_bound -> c
- | Heuristic_select c -> c
- | Heuristic_only -> 1.0
- | _ -> 0.0 in
- let i2f = float_of_int in
- let tot = i2f parent_sc.score_obs in
- let vari = score.variation_table.(player) in
- let obs = i2f score.score_obs in
- let score = score.score_table.(player) in
- let var_est = if obs < 2. then 0. else
- (vari -. score *. score /. obs) /. (obs -. 1.) in
- let var_ucb = if obs < 2. then 0. else
- var_est +. delta *.
- sqrt (2. *. log (tot +. params.constK) /. (obs +. params.constK)) in
- let var_coef = if obs < 2. then 0.25 else
- min 0.25 (var_ucb /. delta) in
- let cb =
- (if lower_bound then
- match params.cLCB with Some lcb -> ~-. lcb | None -> 0.
- else params.cUCB) *. delta *. sqrt
- ((log (tot +. params.constK) /. (obs +. params.constK)) *. var_coef) in
- let mean = if obs < 1. then 0. else score /. obs in
- if params.heur_effect = Heuristic_only then
- heuristic +. cb
- else
- mean +. cb +. cHEUR *. heuristic *. cb
-
-(* The move valuation used when actually making a move using the MCTS-UCT
- algorithm, computed for all players. *)
-let node_values params delta parent_sc heuristics
- ({score_table=table;score_obs=obs} as score) =
- let i2f = float_of_int in
- if params.cLCB <> None && parent_sc.score_obs > 0 then
- Array.mapi (fun player heuristic ->
- ucb1_tuned ~lower_bound:true
- params delta player parent_sc ~heuristic score)
- heuristics
- else
- match params.heur_effect with
- | Heuristic_mixed (_, cHEUR) ->
- if obs = 0 then
- Array.map (fun h -> cHEUR*.h) heuristics
- else
- Array.mapi (fun player score ->
- score /. i2f (abs obs) +.
- cHEUR *. heuristics.(player)) table
- | Heuristic_local _ ->
- if obs = 0 then Array.map (fun _ -> 0.) table
- else
- Array.map (fun score -> score /. i2f (abs obs)) table
- | Heuristic_select _ | Heuristic_only -> heuristics
-
-let uctree_heuristic = function
- | Node node -> node.node_heuristic
- | Leaf (_,_,h,_) -> h
- | Tip (_,h) -> h
- | Terminal (_,_,h,_) -> h
- | TEmpty -> failwith "uctree_heuristic: empty tree"
-
-let uctree_size = function
- | Node node -> node.node_stats.score_obs
- | Leaf (_,_,h,_) -> 1
- | Tip (_,h) -> 1
- | Terminal (_,_,h,_) -> 1
- | TEmpty -> 0
-
-let uctree_location = function
- | Node node -> node.node_state.Arena.cur_loc
- | Leaf (s,_,_,_) -> s.Arena.cur_loc
- | Tip (s,_) -> s.Arena.cur_loc
- | Terminal (s,_,_,_) -> s.Arena.cur_loc
- | _ -> failwith "uctree_location: empty tree"
-
-let uctree_model = function
- | Node node -> node.node_state.Arena.struc
- | Leaf (m,_,_,_) -> m.Arena.struc
- | Tip (m,_) -> m.Arena.struc
- | Terminal (m,_,_,_) -> m.Arena.struc
- | _ -> failwith "uctree_model: empty tree"
-
-let uctree_state = function
- | Node node -> node.node_state
- | Leaf (m,_,_,_) -> m
- | Tip (m,_) -> m
- | Terminal (m,_,_,_) -> m
- | _ -> failwith "uctree_state: empty tree"
-
-(* An unevaluated tree or subtree. *)
-let uctree_empty = function
- | TEmpty | Tip _ -> true
- | _ -> false
-
-let uctree_score ?num_players = function
- | Node node -> node.node_stats
- | Leaf (_,s,_,_) -> s
- | Terminal (_,s,_,_) -> s
- | _ ->
- match num_players with
- | None -> failwith "uctree_score: no score in tree, no num_players"
- | Some n ->
- {score_table= Array.make n 0.0;
- variation_table=Array.make n 0.0; score_obs=0}
-
-(* The result of the game played when the node was first grown. *)
-let uctree_endgame = function
- | Node node -> node.node_endstate
- | Leaf (_,_,_,r) -> r
- | Tip _ -> failwith "uctree_endgame: Tip"
- | Terminal (r,_,_,_) -> r.Arena.struc
- | TEmpty -> failwith "uctree_endgame: TEmpty"
-
-
-let print_score (!) params delta heuristics score =
- !"Values: ";
- let values = node_values params delta score heuristics score in
- Array.iteri (fun player score_v -> !(string_of_int player);
- !" nobs="; !(string_of_int score.score_obs);
- !" score=";
- !(string_of_float score_v);
- !" value=";
- !(sprintf "%2.2f" values.(player));
- !" UCB=";
- !(sprintf "%2.2f"
- (ucb1_tuned params delta player score
- ~heuristic:(heuristics.(player)) score));
- !"; ") score.score_table
-
-(* Print the whole tree. Debugging. *)
-let print_uctree (!) params delta tree =
- let kind = function
- | TEmpty -> "Empty"
- | Tip _ -> "Tip" | Leaf _ -> "Leaf" | Terminal _ -> "Terminal"
- | Node _ -> "Node" in
- let rec pr prefix pos = function
- | Tip _ when debug_level.contents <= 4 -> ()
- | node ->
- let pref_str s =
- Str.global_replace (Str.regexp "\n") ("\n"^prefix) s in
- !prefix;
- let score = uctree_score ~num_players:0 node in
- let heuristic = uctree_heuristic node in
- !(sprintf "pos %d " pos);
- print_score (!) params delta heuristic score;
- !"heuristics";
- Array.iteri (fun player score->
- !(sprintf " %d:%f" player score)) heuristic;
- !"; scores";
- Array.iteri (fun player score->
- !(sprintf " %d:%.2f" player score)) score.score_table;
- !"; ";
- !(kind node); !":\n";
- !prefix;
- !(pref_str (Structure.str (uctree_model node)));
- match node with
- | TEmpty
- | Terminal _ | Tip _ -> !"/\n"
- | Leaf (_,_,_,result) ->
- !"game ended in:\n";
- !prefix; !(pref_str (Structure.str result));
- !"/\n"
- | Node node ->
- !"game ended in:\n";
- !prefix; !(pref_str (Structure.str node.node_endstate));
- !"+\n";
- Array.iteri (fun pos subt ->
- (* !(prefix^"| "); !(print_action act); !"\n"; *)
- pr (prefix^"|") pos subt) node.node_subtrees in
- if tree = TEmpty then !"Empty\n"
- else pr " " 0 tree
-
-let str_payoff payoff =
- String.concat ", "
- (Array.to_list (Array.mapi (fun p v -> sprintf"%d:%f" p v) payoff))
-
-
-let initial_state ?(loc=0) {game=game; agents=agents} model =
- (* {{{ log entry *)
- if !debug_level > 5 then (
- Printf.printf "initial_state: agents #=%d, loc #=%d\n%!"
- (Array.length agents) (Array.length game.Arena.graph);
- );
- (* }}} *)
- let player_memory = Array.map
- (function Tree_search _ -> UCTree TEmpty | _ -> No_memory) agents in
- {
- game_state = {Arena.cur_loc = loc; time = 0.0; struc = model};
- memory = player_memory;
- }
-
-(* TODO: [num_players] not used (remove if not needed). *)
-let update_memory_single num_players state pos = function
- | No_memory -> No_memory
- | State_history history -> State_history (state.Arena.struc::history)
- | UCTree (Node node) ->
- UCTree node.node_subtrees.(pos)
- | UCTree _ -> UCTree TEmpty
-
-let update_memory ~num_players state pos memory =
- Array.map
- (update_memory_single num_players state pos) memory
-
-
-(* Average tables of numbers. *)
-let average_table tables =
- match tables with
- | [] -> failwith "average_table: empty list"
- | [table] -> table
- | hd::tl ->
- let n = float_of_int (List.length tables) in
- let sum = List.fold_left (fun sum table ->
- Aux.array_map2 (fun v1 v2 ->
- v1+.v2) sum table) hd tl in
- Array.map (fun v -> v /. n) sum
-
-(* Find all maximal elements. *)
-let find_all_max cmp l =
- let rec find best acc = function
- | hd::tl ->
- let rel = cmp hd best in
- if rel < 0 then find best acc tl
- else if rel = 0 then find best (hd::acc) tl
- else find hd [hd] tl
- | [] -> List.rev acc in
- match l with
- | [] -> invalid_arg "find_all_max: empty list"
- | hd::tl -> find hd [hd] tl
-
-(* Maximaxing: find the best among subtrees for a player. Pick a best
- entry in the lexicographic product of: maximal [scores] value for
- [player], minimal/maximal sum of [scores] values (resp. competitive
- [cooperative=false] / [cooperative=true] mode), integer accuracy
- measure [subt_sizes]. Return a best position (randomized if
- multiple are optimal) and a best scores table (averaged if multiple
- are optimal). *)
-let find_best_score ?(use_det_setting=false) cooperative player
- scores subt_sizes =
- (* find a new best score *)
- let my_scores = Array.map (fun s->s.(player)) scores in
- let bestsc = Aux.array_argfind_all_max compare my_scores in
- match bestsc with
- | [] ->
- failwith "find_best_score: empty arg max"
- | [bestsc] -> scores.(bestsc), bestsc
- | _ ->
- (* pick cooperative/competitive ones *)
- let sc_sums = List.map
- (fun bh -> bh,
- Array.fold_left (+.) 0. scores.(bh))
- bestsc in
- let cmp_sums : (int * float) -> (int * float) -> int =
- if cooperative
- then fun (_,x) (_,y) -> compare x y
- else fun (_,x) (_,y) -> compare y x in
- let bestsc =
- find_all_max cmp_sums sc_sums in
- match bestsc with
- | [] -> failwith "impossible"
- | [bestsc,_] -> scores.(bestsc), bestsc
- | (bsc,_)::(bsc2,_)::_
- when use_det_setting && !deterministic_suggest ->
- scores.(bsc), bsc
- | _ ->
- (* pick ones from biggest subtrees *)
- let bestsc =
- find_all_max
- (fun (b1,_) (b2,_) -> subt_sizes.(b1) - subt_sizes.(b2))
- bestsc in
- match bestsc with
- | [] -> failwith "impossible"
- | [bestsc,_] -> scores.(bestsc), bestsc
- | _::_ ->
- (* check the number of players
- TODO: perhaps not worth averaging *)
- let randbest, _ =
- List.nth bestsc (Random.int (List.length bestsc)) in
- let bestsc_table = scores.(randbest) in
- if Array.length bestsc_table > 2 then
- average_table
- (List.map (fun (b,_) -> scores.(b))
- bestsc),
- randbest
- else bestsc_table, randbest
-
-let debug_count = ref 0
-
-(* Generate evaluation game score (the whole payoff table). *)
-let rec play_evgame grid_size model time evgame =
- let subloc = evgame.ev_game.Arena.graph.(evgame.ev_location) in
- if subloc.Arena.moves = [] then (* optimization *)
- Array.map (fun expr ->
- Solver.M.get_real_val expr model) subloc.Arena.payoffs
- else
- let state =
- {game_state={Arena.cur_loc=evgame.ev_location; struc=model; time=time};
- memory=evgame.ev_memory} in
- let subplay =
- {game=evgame.ev_game; agents=evgame.ev_agents; delta=evgame.ev_delta} in
- (* ignoring the endgame model *)
- let _, payoff =
- play ~grid_size ?horizon:evgame.ev_horizon subplay state in
- payoff
-
-(* Generate evgame scores for possible moves. *)
-and gen_scores grid_size subgames moves models loc =
- Array.mapi (fun pos mv ->
- let {Arena.struc=model; time=time} = models.(pos) in
- play_evgame grid_size model time subgames.(mv.Move.next_loc)
- ) moves
-
-
-
-(* Make a move in a play, or compute the payoff table when the game
- ended. Return the move chosen and the moves considered. One can use
- only a {!move} to suggest a move, or only the updated {!play_state}
- to follow the best move (or both). Also return the accrued
- computation as updated "memory" for the current state.
-
- Uses [Random_move] for other agents if their "effort" is set to
- zero. Do not use [Random_move] or [effort=0] when the table of
- moves is used for more than extracting the move selected! *)
-and toss ~grid_size ?(just_payoffs=false)
- ({game={Arena.rules=rules; graph=graph; num_players=num_players;
- defined_rels=defined_rels};
- agents=agents; delta=delta} as play_def)
- {game_state=state; memory=memory} =
- let loc = graph.(state.Arena.cur_loc) in
- let moves =
- if just_payoffs then [| |]
- else Move.gen_moves grid_size rules state.Arena.struc loc in
- (* Don't forget to check after generating models as well --
- postconditions! *)
- if moves = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- else
- let agent = agents.(loc.Arena.player) in
- match agent with
-
- | Random_move
- | Maximax_evgame (_, _, 0, _)
- | Tree_search (_, _, {iters=0}, _) ->
- let mlen = Array.length moves in
- let init_pos = Random.int mlen in
- let pos = ref init_pos in
- let nstate = ref None in
- while !nstate = None && (!pos <> init_pos || !pos < mlen) do
- let mv = moves.(!pos mod mlen) in
- let rule = List.assoc mv.Move.rule rules in
- nstate :=
- Aux.map_option
- (fun (model, time, _) ->
- (* ignoring shifts, i.e. animation steps *)
- {Arena.cur_loc=mv.Move.next_loc; struc=model; time=time})
- (ContinuousRule.rewrite_single state.Arena.struc state.Arena.time
- mv.Move.embedding rule mv.Move.mv_time mv.Move.parameters);
- incr pos
- done;
- (match !nstate with
- | None ->
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- | Some state ->
- (* [pos] refers to unfiltered array! use only to extract
- | the move from the returned array *)
- Aux.Left
- (!pos mod mlen, moves, memory,
- {game_state = state;
- memory = update_memory ~num_players state !pos memory}))
-
- | Maximax_evgame (subgames, cooperative, depth, use_pruning) ->
- (* {{{ log entry *)
-
- let nodes_count = ref 0 in
- let size_count = ref 1 in
- let depth0 = depth in
- let debug_playclock = ref 0. in
- if !debug_level > 1 && depth > 1 || !debug_level > 3
- then (
- printf "toss: %s ev game, timer started...\n%!"
- (if use_pruning then "alpha_beta_ord" else "maximax");
- debug_playclock := Sys.time ());
-
- (* }}} *)
- (* full tree search of limited depth by plain recursive
- calls, with optional alpha-beta pruning *)
- (* [betas] are used imperatively *)
- let rec maximax_tree pre_heur prev_player betas depth
- {Arena.cur_loc = loc; struc=model; time=time} =
- (* {{{ log entry *)
- incr nodes_count;
- size_count := !size_count + Array.length moves;
- if (depth0 > 2 || !debug_level > 4)
- && depth > 1 && !debug_level > 0
- then printf "%d,%!" !nodes_count;
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4)
- && (depth > 1 || !debug_level > 3)
- then printf "%s%!"
- (Str.global_replace (Str.regexp "\n")
- ("\n"^String.make (max 0 (depth0-depth)) '|')
- ("\n" ^ Structure.str model));
- (* }}} *)
- if !timeout then (* will be handled by i.deep. *)
- Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
- else if depth < 1 then ( (* leaf position *)
- let res =
- match pre_heur with
- | Some h -> h
- | None ->
- play_evgame grid_size model time subgames.(loc) in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- let player = graph.(loc).Arena.player in
- printf ", leaf %d heur: %F %!" player res.(player)
- );
- (* }}} *)
- res
- ) else
- let location = graph.(loc) in
- let moves =
- Move.gen_moves grid_size rules model location in
- if moves = [| |] then (* terminal position *)
- let res =
- (* *)
- Array.map (fun expr ->
- 100000. *.
- Solver.M.get_real_val expr model)
- location.Arena.payoffs (* see [let payoff] above *)
- (* *
- play_evgame grid_size model time subgames.(loc)
- * *)
- in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- let player = graph.(loc).Arena.player in
- printf ", terminal %d heur: %F %!" player res.(player)
- );
- (* }}} *)
- res
- else if !timeout then
- Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
- else
- let moves, models = Move.gen_models rules model time moves in
- let n = Array.length models in
- if !timeout then
- Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
- else if n = 0 then begin (* terminal after postconditions *)
- let res =
- (* play_evgame grid_size model time subgames.(loc) *)
- (* *)
- Array.map (fun expr ->
- 100000. *.
- Solver.M.get_real_val expr model)
- location.Arena.payoffs
- (* *
- play_evgame grid_size model time subgames.(loc)
- * *)
- in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- let player = graph.(loc).Arena.player in
- printf ", terminal %d heur: %F %!" player res.(player)
- );
- (* }}} *)
- res
- end else
- let player = location.Arena.player in
- let now_pruning = use_pruning && prev_player <> player in
- let new_betas = Array.make num_players infinity in
- let index =
- Array.init (Array.length models) (fun i->i) in
- let heuristics =
- if depth > 1 then begin
- let heuristics =
- gen_scores grid_size subgames moves models location in
- Array.sort (fun j i-> compare
- heuristics.(i).(player) heuristics.(j).(player)) index;
- (* {{{ log entry *)
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) &&
- (depth > 1 || !debug_level > 3)
- then
- printf ", best %d pre-heur: %F %!" player
- heuristics.(index.(0)).(player);
- (* }}} *)
- Some heuristics
- end else None in
- let rec aux best i =
- if i < n && not !timeout then (
- let pos = index.(i) in
- let state = models.(pos) in
- let sub_heur =
- maximax_tree
- (Aux.map_option (fun h->h.(pos)) heuristics)
- player new_betas (depth-1) state in
- (* note strong inequality: don't lose ordering info *)
- if now_pruning && sub_heur.(player) > betas.(player)
- then (
- (* {{{ log entry *)
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) &&
- (depth > 1 || !debug_level > 3)
- then (
- printf ", best cut %d maximax: %F. %!" player
- sub_heur.(player));
- (* }}} *)
- sub_heur)
- else if sub_heur.(player) > best.(player)
- then aux sub_heur (i+1)
- else aux best (i+1))
- else if !timeout then best
- else (
- betas.(player) <- best.(player);
- (* {{{ log entry *)
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) &&
- (depth > 1 || !debug_level > 3)
- then (
- printf ", best %d maximax: %F. %!" player
- best.(player));
- (* }}} *)
- best) in
- let alphas = Array.make num_players neg_infinity in
- aux alphas 0 in
- let betas = Array.make num_players infinity in
- let player = loc.Arena.player in
- let moves, models =
- Move.gen_models rules state.Arena.struc state.Arena.time moves in
- if models = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- else
- let cur_depth = ref 0 in
- (* {{{ log entry *)
- if !debug_level > 1 && (depth > 2 || !debug_level > 3) then (
- Printf.printf "\n\nIterative-deepening: depth %d\n%!"
- (!cur_depth + 1)
- );
- (* }}} *)
- let scores =
- Array.map (maximax_tree None player betas !cur_depth) models in
- incr cur_depth;
- while not !timeout && !cur_depth < depth do
- (* {{{ log entry *)
- if !debug_level > 1 && (depth > 2 || !debug_level > 3) then (
- Printf.printf "\n\nIterative-deepening: depth %d\n%!"
- (!cur_depth + 1)
- );
- (* }}} *)
- let index =
- Array.init (Array.length models) (fun i->i) in
- Array.sort (fun j i-> compare
- scores.(i).(player) scores.(j).(player)) index;
- let betas = Array.make num_players infinity in
- let new_scores =
- Array.map (fun j ->
- maximax_tree None player betas !cur_depth models.(j))
- index in
- incr cur_depth;
- if not !timeout then
- Array.iteri (fun i j ->
- (* inverting the permutation *)
- scores.(j) <- new_scores.(i)) index;
- (* {{{ log entry *)
- if !debug_level > 1 && (depth > 2 || !debug_level > 3) then (
- Printf.printf "\nIterative-deepening: depth %d scores:\n%!"
- !cur_depth;
- Array.iteri (fun i score ->
- Printf.printf "Structure:%s -- score %F\n"
- (Structure.str models.(i).Arena.struc) score.(player)) scores
- );
- (* }}} *)
- done;
- let _, best =
- find_best_score ~use_det_setting:true cooperative player scores
- (Array.map (fun _ -> 1) scores) in
- let state = models.(best) in
- (* {{{ log entry *)
- if !debug_level > 0 && (depth > 1 || !debug_level > 3)
- then printf " %d nodes, %d size, %f elapsed time\n%!"
- !nodes_count !size_count
- (Sys.time () -. !debug_playclock);
- if !debug_level > 1 && (depth > 1 || !debug_level > 3)
- then
- Printf.printf "moving to state\n%s\n%!"
- (Structure.str state.Arena.struc);
- (* }}} *)
- Aux.Left
- (best, moves, memory,
- {game_state=state;
- memory=update_memory ~num_players state best memory})
-
- | Tree_search (subgames, evgame_horizon, params, agents) ->
- (* {{{ log entry *)
- let debug_playclock = ref 0. in
- if !debug_level > 1 then (
- debug_playclock := Sys.time ();
- printf "\ntoss: tree search, timer started\n%!");
- (* }}} *)
- (* the generated moves are wasted, but it's not much *)
- let uctree =
- match memory.(loc.Arena.player) with
- | UCTree uctree -> uctree
- | No_memory -> TEmpty
- | _ -> failwith
- "toss: tree search agent without game tree memory" in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- print_endline "\ntoss: initial tree:";
- print_uctree (print_string)
- params delta uctree; flush stdout);
- if !debug_level > 3 then printf "toss: %d iters\n"
- params.iters;
- (* }}} *)
- (* [grow_uctree] will check if it is not a terminal
- position *)
- let uctree = ref uctree and iteri = ref 0 in
- (* the score update is already stored in the tree *)
- while !iteri < params.iters && not !timeout do
- incr iteri;
- (* {{{ log entry *)
- if !debug_level > 0 then printf "%d,%!" !iteri;
- (* }}} *)
- uctree :=
- snd (grow_uctree grid_size {play_def with agents=agents}
- params subgames evgame_horizon
- ~default_state:{game_state=state; memory=memory} !uctree)
- done;
- (* {{{ log entry *)
- if !debug_level > 2 then (
- print_endline "\ntoss: updated tree:";
- print_uctree (print_string)
- params delta !uctree; flush stdout);
- if !debug_level > 1 then
- printf "elapsed time: %f\n%!"
- (Sys.time () -. !debug_playclock);
- (* }}} *)
- (match !uctree with
- | Node node ->
- let scores = Array.map (fun subtree ->
- node_values params delta
- (uctree_score ~num_players !uctree)
- (uctree_heuristic subtree)
- (uctree_score ~num_players subtree))
- node.node_subtrees in
- let _, best =
- find_best_score ~use_det_setting:true
- params.cooperative loc.Arena.player
- scores (Array.map uctree_size node.node_subtrees) in
- let state = uctree_state node.node_subtrees.(best) in
- (* {{{ log entry *)
- if !debug_level > 1 then
- Printf.printf "moving to state\n%s\n%!"
- (Structure.str state.Arena.struc);
- (* }}} *)
- memory.(loc.Arena.player) <- (UCTree (Node node));
- Aux.Left
- (best, moves, memory,
- {game_state=state;
- memory=
- update_memory num_players state best memory})
-
- | Terminal (game_state, score, heuristic, payoff) ->
- Aux.Right payoff
-
- | _ -> failwith "toss: tree search -- unexpected end of tree")
- | External callback ->
- (* {{{ log entry *)
- if !debug_level > 3 then printf "toss: external\n";
- (* }}} *)
- let moves, models =
- Move.gen_models rules state.Arena.struc state.Arena.time moves in
- if models = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- else
- let descriptions =
- Array.map (fun m -> Structure.str m.Arena.struc) models in
- let best = callback descriptions in
- let state = models.(best) in
- Aux.Left
- (best, moves, memory,
- {game_state=state;
- memory=update_memory num_players state best memory})
-
-
-(* Play a play, by applying {!toss}, till the end. Return the final
- structure and its payoff.
-
- The [set_timer] should be only provided for standalone plays. For
- suggestions, the timer is set by {!Server}. Tests use their own
- timers too, see {!GameTest}. *)
-and play ~grid_size ?set_timer ?horizon ?(plys=0) play_def state =
- let () = match set_timer with
- | None -> ()
- | Some timer ->
- (* {{{ log entry *)
- if !debug_level > 2 then printf "SET ALARM %d\n%!" timer;
- (* }}} *)
- ignore (Unix.alarm timer) in
- let res =
- toss ~grid_size
- ~just_payoffs:(horizon <> None && plys >= Aux.unsome horizon)
- play_def state in
- let () = match set_timer with
- | None -> ()
- | Some _ -> cancel_timeout () in
- match res with
- | Aux.Left (_,_,_,state) ->
- (* {{{ log entry *)
- if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then
- printf "step-state:\n%s\n%!"
- (Structure.str state.game_state.Arena.struc);
- (* }}} *)
- play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state
- | Aux.Right payoff ->
- (* {{{ log entry *)
- if !debug_level > 5 || (!debug_level > 1 && set_timer <> None) then
- printf "payoff-state:\n%a\n%!"
- (Aux.array_fprint (fun f pv->fprintf f "%F" pv)) payoff;
- (* }}} *)
- state.game_state.Arena.struc, discount plys payoff
-
-
-(* Walk up the tree selecting the optimal estimates route, and update
- the estimates and heuristics ("maximax") on the way down.
-
- Currently, timeouts are not handled inside UCT iterations. *)
-and grow_uctree grid_size
- ({game={Arena.rules=rules; graph=graph; num_players=num_players};
- delta=delta} as play_def) params subgames
- evgame_horizon ?default_state =
- (* the state is only used for the empty tree case *)
- function
- | Node {
- node_state=game_state; node_stats=score;
- node_heuristic=heuristic; node_bestheur=old_bestheur;
- node_endstate=endmodel; node_subtrees=subtrees
- } ->
- let player = graph.(game_state.Arena.cur_loc).Arena.player in
- (* compute UCBs and update the best subtree *)
- let ucb_scores = Array.map (fun subtree ->
- let heuristic = uctree_heuristic subtree in
- ucb1_tuned params delta player score
- ~heuristic:(heuristic.(player))
- (uctree_score ~num_players subtree)) subtrees in
- let best = Aux.array_argfind_all_max
- (compare : float -> float -> int) ucb_scores in
- (* no use of prioritizing cooperative/competitive in an
- exploratory context *)
- let best = List.nth best (Random.int (List.length best)) in
- let upscore, subtree =
- grow_uctree grid_size play_def params subgames evgame_horizon
- subtrees.(best) in
- subtrees.(best) <- subtree;
- let score = add_score score upscore in
- (* maximaxing -- update the heuristic if needed *)
- let subtree_heur = uctree_heuristic subtree in
- let heuristic, bestheur =
- if subtree_heur.(player) > heuristic.(player)
- then subtree_heur, best
- else if best <> old_bestheur
- then heuristic, old_bestheur
- else if subtree_heur.(player) = heuristic.(player)
- then subtree_heur, old_bestheur (* update for other players *)
- else
- let heuristics = Array.map uctree_heuristic subtrees in
- let subt_sizes = Array.map (fun subt ->
- (uctree_score ~num_players subt).score_obs) subtrees in
- find_best_score params.cooperative
- player heuristics subt_sizes in
- upscore,
- Node {
- node_state=game_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=endmodel;
- node_subtrees=subtrees; node_bestheur=bestheur;
- }
-
- | Leaf (game_state, score, heuristic, endmodel) ->
- let player = graph.(game_state.Arena.cur_loc).Arena.player in
- expand_uctree grid_size play_def game_state ~score subgames
- evgame_horizon params.heur_effect heuristic params.horizon
- params.cooperative player
-
- | Tip (game_state, heuristic) ->
- let player = graph.(game_state.Arena.cur_loc).Arena.player in
- expand_uctree grid_size play_def game_state subgames evgame_horizon
- params.heur_effect heuristic params.horizon params.cooperative
- player
-
- | Terminal (game_state, score, heuristic, payoff) ->
- let upscore = score_payoff payoff in
- let score = add_score score upscore in
- upscore,
- Terminal (game_state, score, heuristic, payoff)
-
- | TEmpty ->
- let play_state = Aux.unsome default_state in
- let endmodel, payoff =
- play ~grid_size ?horizon:params.horizon play_def play_state in
- let upscore = score_payoff payoff in
- upscore,
- (* the heuristic value of the root can be ignored *)
- Leaf (play_state.game_state, upscore, payoff, endmodel)
-
-(* Expand a leaf of the tree. *)
-and expand_uctree grid_size ({game={Arena.rules=rules; graph=graph;
- num_players=num_players;
- defined_rels=defined_rels};
- delta=delta} as play_def)
- state ?score subgames evgame_horizon heur_effect heuristic
- horizon cooperative player =
- let location = graph.(state.Arena.cur_loc) in
- let moves = Move.gen_moves grid_size rules state.Arena.struc location in
- if moves = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- location.Arena.payoffs in
- let upscore = score_payoff payoff in
- upscore, Terminal (state, upscore, heuristic, payoff)
-
- else
- let moves, models =
- Move.gen_models rules state.Arena.struc state.Arena.time moves in
- if models = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- location.Arena.payoffs in
- let upscore = score_payoff payoff in
- upscore, Terminal (state, upscore, heuristic, payoff)
- else
- let heuristics =
- gen_scores grid_size subgames moves models location in
- let subt_sizes = Array.map (fun _ -> 0) heuristics in
- let heuristic, bestheur =
- find_best_score cooperative player heuristics subt_sizes in
- let scores =
- Array.map (fun payoffs -> payoffs.(location.Arena.player))
- heuristics in
- let subtrees =
- Array.mapi (fun i state -> Tip (state, heuristics.(i)))
- models in
- let best = Aux.array_argfind_all_max
- (compare : float -> float -> int) scores in
- let best = List.nth best (Random.int (List.length best)) in
- let next_state = models.(best) in
- let empty_mem = Array.make num_players No_memory in
- let state =
- {game_state=next_state; memory=empty_mem} in
- if heur_effect = Heuristic_only then
- let upscore = score_payoff (Array.make num_players 0.) in
- (* we maintain score to: (1) count the number of node visits,
- (2) keep info when the search tree hits terminal nodes *)
- let score = match score with
- | None -> upscore
- | Some score -> add_score score upscore in
- subtrees.(best) <-
- Leaf (next_state, upscore, heuristics.(best), next_state.Arena.struc);
- (upscore,
- Node {
- node_state=next_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=next_state.Arena.struc;
- node_subtrees=subtrees; node_bestheur=bestheur;
- })
- else
- let endmodel, payoff = play ~grid_size ?horizon play_def state in
- let upscore = score_payoff payoff in
- let score = match score with
- | None -> upscore
- | Some score -> add_score score upscore in
- subtrees.(best) <-
- Leaf (next_state, upscore, heuristics.(best), endmodel);
- (upscore,
- Node {
- node_state=next_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=endmodel;
- node_subtrees=subtrees; node_bestheur=bestheur;
- })
-
-let evgame_of_heuristic heuristics game =
- let evgame gloc =
- {ev_game =
- {Arena.rules = [];
- player_names = game.Arena.player_names;
- defined_rels = game.Arena.defined_rels;
- data = game.Arena.data;
- graph = [|
- {Arena.id=0; player=gloc.Arena.player;
- payoffs=heuristics.(gloc.Arena.id);
- moves=[]} |];
- num_players = game.Arena.num_players};
- ev_agents = [| |]; ev_delta = 0.0; ev_location = 0;
- ev_horizon = Some 0; ev_memory = [| |]} in
- Array.map evgame game.Arena.graph
-
-(* An UCT-based agent that uses either random playouts (when
- [random_playout] is set to true) or the same location-dependent
- heuristic for maximax search as given for the inside-tree
- (including unevaluated tips) calculation. *)
-let default_treesearch struc ~iters ?heuristic
- ?advr ?(random_playout=false)
- ?(playout_mm_depth=0) ?(heur_effect=default_params.heur_effect)
- ?horizon game =
- (* heuristics are location-id indexed first, then player-indexed *)
- let heuristics = match heuristic with Some h -> h
- | None ->
- default_heuristic ~struc ?advr game in
- let heur_evgame =
- evgame_of_heuristic heuristics game in
- let playout_agents =
- if not (random_playout || heur_effect = Heuristic_only) then
- Array.map (fun _ ->
- Maximax_evgame
- (heur_evgame, false, playout_mm_depth, true))
- game.Arena.graph
- else Array.map (fun _ -> Random_move) game.Arena.graph in
- Tree_search
- (heur_evgame, Some 0,
- {default_params with iters=iters; horizon=horizon;
- heur_effect=heur_effect},
- playout_agents)
-
-(* Plain limited depth maximax tree search. *)
-let default_maximax struc ~depth ?heuristic
- ?advr ?(pruning=true) game =
- let heuristics = match heuristic with Some h -> h
- | None ->
- default_heuristic ~struc ?advr game in
- let heur_evgame =
- evgame_of_heuristic heuristics game in
- Maximax_evgame (heur_evgame, false, depth, pruning)
-
-let initialize_default state ?loc ?effort
- ~search_method ?horizon
- ?advr ?(payoffs_already_tnf=false) ?heuristic () =
- let effort = match effort with
- | None -> !default_effort | Some e -> e in
- let {Arena.rules=rules; graph=graph; num_players=num_players} = fst state in
- let struc = (snd state).Arena.struc in
- (* {{{ log entry *)
- if !debug_level > 0 then printf "\ninitializing game and play\n%!";
- (* }}} *)
- (* TODO: default_heuristic redoes payoff normalization. *)
- let game = fst state in
- let agent =
- match search_method with
- | "maximax" ->
- default_maximax struc ~depth:effort ?heuristic
- ?advr ~pruning:false game
- | "alpha_beta_ord" ->
- default_maximax struc ~depth:effort ?heuristic
- ?advr ~pruning:true game
- | "uct_random_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~random_playout:true game
- | "uct_greedy_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~random_playout:false game
- | "uct_maximax_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~random_playout:false ~playout_mm_depth:1 game
- | "uct_no_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~heur_effect:Heuristic_only game
- | s -> failwith ("Game.initialize: unknown search method "^s)
- in
- let play =
- {game = game; agents=Array.make num_players agent;
- delta = 2.0} in (* FIXME: give/calc delta *)
- (* {{{ log entry *)
- if !debug_level > 2 then printf "play initialized\n%!";
- (* }}} *)
- let init_state = initial_state ?loc play struc in
- play, init_state
-
-let suggest ?effort play play_state =
- let play = match effort with
- | None -> play
- | Some effort ->
- {play with agents=Array.map
- (function
- | Tree_search (subgames, sth, params, agents) ->
- Tree_search (
- subgames, sth, {params with iters=effort},
- agents)
- | Maximax_evgame (
- subgames, cooperative, depth, use_pruning) ->
- Maximax_evgame
- (subgames, cooperative, effort, use_pruning)
- | (Random_move | External _) as agent -> agent
- ) play.agents} in
- (* {{{ log entry *)
- if !debug_level > 2 then printf "\nsuggest:\n%!";
- (* }}} *)
- (match
- toss ~grid_size:Move.cGRID_SIZE play play_state
- with
- | Aux.Left (bpos, moves, memory, _) ->
- (* [suggest] does not update the state, rule application
- should do it *)
- (* {{{ log entry *)
- if !debug_level > 1 then
- printf "suggest: pos %d out of %d -- %s\n%!" bpos
- (Array.length moves)
- (Move.move_gs_str (play.game, play_state.game_state) moves.(bpos));
- (* }}} *)
- Some (moves.(bpos), {play_state with memory=memory})
- | Aux.Right payoffs ->
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "Suggest: found payoffs = %a\n%!"
- (Aux.array_fprint (fun ppf -> Printf.fprintf ppf "%F")) payoffs
- );
- (* }}} *)
- None)
-
Deleted: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-04-05 20:44:16 UTC (rev 1406)
+++ trunk/Toss/Play/GameTest.ml 2011-04-13 14:42:37 UTC (rev 1407)
@@ -1,1063 +0,0 @@
-open OUnit
-open Aux
-
-let assert_one_of str str_list =
- let elements = String.concat ", " str_list in
- assert_bool ("expected one of "^elements^", but got "^str)
- (List.mem str str_list)
-
-let assert_not_one_of str str_list =
- let elements = String.concat ", " str_list in
- assert_bool ("expected disjoint from "^elements^", yet got "^str)
- (not (List.mem str str_list))
-
-let struc_of_str s =
- StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-
-let formula_of_str s =
- FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-
-let real_expr_of_str s =
- FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)
-
-let defstruc_of_str s =
- match
- ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s)
- with Arena.StateStruc struc -> struc
- | _ -> failwith "defstruc_of_str: not a structure"
-
-let state_of_str s =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_string s)
-
-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
-
-module StrMap = Structure.StringMap
-module IntMap = Structure.IntMap
-
-let move_str r s m = Move.move_str_short s m
-let move_gs_str = Move.move_gs_str_short
-
-let update_game ?(defs=false)
- (lazy (horizon, adv_ratio, (state_game, state))) new_struc_s new_loc =
- let new_struc =
- if defs then defstruc_of_str new_struc_s else struc_of_str new_struc_s in
- horizon, adv_ratio,
- (state_game, {state with Arena.struc = new_struc; cur_loc = new_loc})
-
-let get_loc_game ?update_struc
- (lazy (horizon, adv_ratio, (state_game, state))) new_loc =
- horizon, adv_ratio,
- match update_struc with
- | None ->
- (state_game, {state with Arena.cur_loc = new_loc})
- | Some upd ->
- (state_game, {state with
- Arena.struc = upd state.Arena.struc;
- cur_loc = new_loc})
-
-
-let rec binary_to_assoc = function
- | [k;v]::tl -> (k,v)::(binary_to_assoc tl)
- | [] -> []
- | _ -> failwith "binary_to_assoc: arity mismatch"
-
-let rec fix_find f x =
- try fix_find f (f x)
- with Not_found -> x
-
-module RelMap = Structure.StringMap
-module Tuples = Structure.Tuples
-
-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 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))))))"
-let winPvwxyz =
- "ex v, w, x, y, z ((((((P(v) and P(w)) and P(x)) and P(y)) and P(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 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 checkers_1x1_to_3x2 s =
- let r = String.make (8*8*6+8*2) ' ' in
- for i = 1 to 8*2 do
- r.[i*8*3+i-1] <- '\n' done;
- for i = 1 to 8 do
- for j = 1 to 8 do
- if (i+j) mod 2 = 0 then (
- String.blit "..." 0 r
- ((8-j)*8*3*2 + (8-j)*2 + (i-1)*3) 3;
- String.blit "..." 0 r
- ((8-j)*8*3*2 + (8-j)*2 + 8*3 + 1 + (i-1)*3) 3);
- if s.[(8-j)*8 + (8-j) + i-1] <> '.' then
- r.[(8-j)*8*3*2 + (8-j)*2 + 8*3 + 1 + (i-1)*3] <-
- s.[(8-j)*8 + (8-j) + i-1];
- done
- done;
- r
-
-let tictactoe_1x1_to_3x2 s =
- let r = String.make (3*3*6+3*2) ' ' in
- for i = 1 to 3*2 do
- r.[i*3*3+i-1] <- '\n' done;
- for i = 1 to 3 do
- for j = 1 to 3 do
- r.[(3-j)*3*3*2 + (3-j)*2 + 3*3 + 1 + (i-1)*3] <-
- s.[(3-j)*3 + (3-j) + i-1]
- done
- done;
- r
-
-let breakthrough_game =
- lazy (None, 2.0, state_of_file "./examples/Breakthrough.toss")
-
-let breakthrough_simpl_game =
- lazy (None, 2.0, state_of_file "./GGP/tests/breakthrough-simpl.toss")
-
-let tictactoe_game =
- lazy (None, 5.0, state_of_file "./examples/Tic-Tac-Toe.toss")
-
-let gomoku8x8_game =
- lazy (None, 5.0, state_of_file "./examples/Gomoku.toss")
-
-let gomoku19x19_game =
- lazy (None, 5.0, state_of_file "./examples/Gomoku19x19.toss")
-
-let connect4_game =
- lazy (None, 2.0, state_of_file "./examples/Connect4.toss")
-
-let chess_game =
- lazy (Some 400, 2.0, state_of_file "./examples/Chess.toss")
-
-let checkers_game =
- lazy (Some 400, 2.0, state_of_file "./examples/Checkers.toss")
-
-let breakthrough_heur_adv adv_ratio =
- let expanded_win1 =
- "ex y1, y2, y3, y4, y5, y6, y7, y8 (C(y1, y2) and C(y2, y3) and C(y3, y4) and C(y4, y5) and C(y5, y6) and C(y6, y7) and C(y7, y8) and W(y8))" in
- let expanded_win2 =
- "ex y1, y2, y3, y4, y5, y6, y7, y8 (B(y1) and C(y1, y2) and C(y2, y3) and C(y3, y4) and C(y4, y5) and C(y5, y6) and C(y6, y7) and C(y7, y8))" in
- let expanded_payoff1 =
- (Heuristic.of_payoff adv_ratio (strings_of_list ["B"; "W"])
- (real_expr_of_str
- (":("^expanded_win1^") - :("^expanded_win2^")"))) in
- let expanded_payoff2 =
- (Heuristic.of_payoff adv_ratio (strings_of_list ["B"; "W"])
- (real_expr_of_str
- (":("^expanded_win2^") - :("^expanded_win1^")"))) in
- let expanded_payoffs =
- [|expanded_payoff1; expanded_payoff2|] in
- [|expanded_payoffs; expanded_payoffs|]
-
-let breakthrough_heur =
- breakthrough_heur_adv 1.5
-
-let chess_piece_value_heur =
- let white_val =
- "Sum (x | wP(x): 1) + Sum (x | wN(x): 3.2) +
- Sum (x | wB(x): 3.33) + Sum (x | wR(x): 5.1) + Sum (x | wQ(x): 8.8) +
- Sum (x | wK(x): 100)" in
- let black_val =
- "Sum (x | bP(x): 1) + Sum (x | bN(x): 3.2) +
- Sum (x | bB(x): 3.33) + Sum (x | bR(x): 5.1) + Sum (x | bQ(x): 8.8) +
- Sum (x | bK(x): 100)" in
- let white_heur =
- real_expr_of_str ("("^white_val^") - ("^black_val^")") in
- let black_heur =
- real_expr_of_str ("("^black_val^") - ("^white_val^")") in
- let heuristic = [|white_heur; black_heur|] in
- Array.make 32 heuristic
-
-let check_loc_random = function
- | Game.Tree_search (_,_,_,evgames) ->
- if
- Aux.array_for_all (function Game.Random_move -> true | _ -> false)
- evgames
- then true
- else if
- Aux.array_for_all (function Game.Random_move -> false | _ -> true)
- evgames
- then false
- else failwith "check_loc_random: inconsistent"
- | _ -> failwith "check_loc_random: not a Tree_search"
-
-let payoff_str pay =
- String.concat ", "
- (List.map (fun (p,v)->p^": "^string_of_float v) pay)
-
-let try_n_times n (state_game, state) compute_move pred comment =
- let hist = ref 0 in
- let failed = ref [] in
- for i = 1 to n do
- let move, _ = compute_move () in
- let move_str = move_gs_str state move in
- if pred move_str
- then incr hist
- else failed := move_str :: !failed
- done;
- assert_bool
- (Printf.sprintf "%s: only %d out of %d\nFailed moves: %s."
- comment !hist n (String.concat "; " !failed))
- (float_of_int !hist >= float_of_int n *. 0.7)
-
-let compute_try search_method randomize effort timer_sec
- (horizon, advr, state) loc msg pred =
- if search_method = "GameTree"
- then
- let heur = Heuristic.default_heuristic
- ~struc:(snd state).Arena.struc
- ~advr (fst state) in
- Play.set_timeout (float(timer_sec));
- let (move, _) = Play.maximax_unfold_choose effort
- (fst state) (snd state) heur in
- Play.cancel_timeout ();
- let move_str = move_gs_str (snd state) move in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str)
- (pred move_str)
-
- else
- let p,ps = Game.initialize_default
- state ~advr ?horizon ~loc ~effort ~search_method () in
- let compute_move () =
- ignore (Unix.alarm timer_sec);
- let res =
- Aux.unsome (Game.suggest p ps) in
- Game.cancel_timeout ();
- res in
- if randomize then
- try_n_times 5 state compute_move pred msg
- else
- let move, _ = compute_move () in
- let move_str = move_gs_str (snd state) move in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str)
- (pred move_str)
-
-
-
-let misc_tests = "misc" >::: [
-
- "play: breakthrough suggest in game" >::
- (fun () ->
- let horizon, advr, state =
- update_game breakthrough_game
-"[ | | ] \"
- ... ... ... ...
- ... ... ... ...
-... ... ... ...
-...B ... B.. ...
- ... ... ... ...
- B..B B..B B..B B..
-... ... ... ...
-...B B..B B..B B..W
- ... ... ... ...
-W W..W W..B W..W ...
-... ... ... ...
-W..W W.. W.. ...
[truncated message content] |
|
From: <luk...@us...> - 2011-04-14 01:58:34
|
Revision: 1409
http://toss.svn.sourceforge.net/toss/?rev=1409&view=rev
Author: lukaszkaiser
Date: 2011-04-14 01:58:27 +0000 (Thu, 14 Apr 2011)
Log Message:
-----------
More work on PlayTest and GameTree stability.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
Removed Paths:
-------------
trunk/Toss/Play/Game.mli
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Formula/Aux.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -211,6 +211,11 @@
| hd::tl -> hd::(remove_one e tl)
| [] -> []
+let rec remove_last = function
+ | [] -> raise Not_found
+ | [_] -> []
+ | x :: xs -> x :: (remove_last xs)
+
let rec insert_nth n e = function
| l when n<=0 -> e::l
| [] -> raise Not_found
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Formula/Aux.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -136,6 +136,9 @@
(** Remove an occurrence of a value (uses structural equality). *)
val remove_one : 'a -> 'a list -> 'a list
+(** Remove the last element in a list; raise Not_found for []. *)
+val remove_last : 'a list -> 'a list
+
(** Insert as [n]th element of a list (counting from zero). Raise
[Not_found] if the list has less than [n] elements (e.g. inserting
0th element to empty list is OK). *)
Deleted: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Game.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -1,196 +0,0 @@
-(** Game-related definitions. The UCTS algorithm. *)
-
-(** Default effort used in {!Game.initialize_default} when not
- otherwise specified. *)
-val default_effort : int ref
-
-(** A global "hurry up!" switch triggered by the timer alarm. *)
-val get_timeout : unit -> bool
-val cancel_timeout : unit -> unit
-
-(** History stored for a play, including caching of computations for
- further use. *)
-type memory
-
-(** Effect that heuristics have on the MCTS algorithm. *)
-type mcts_heur_effect =
- | Heuristic_local of float (** TODO: not implemented *)
- (** each tree node only considers the heuristic of its state,
- the parameter is the influence of the heuristic on the tree
- traversal, there is no influence on the actual choice *)
- | Heuristic_mixed of float * float
- (** a node stores a heuristic maximaxed from the leaf states of
- the subtree, [MaximaxMixed (trav, select)] has [trav]
- the influence on the tree traversal, [select] the influence
- on the actual choice *)
- | Heuristic_select of float
- (** a node stores a heuristic maximaxed from the leaf states of
- the subtree, the parameter is the influence on the tree
- traversal, the actual choice is based on the heuristic alone
- and not the Monte-Carlo payoff estimates *)
- | Heuristic_only
- (** a node stores a heuristic maximaxed from the leaf states of
- the subtree, which completely replaces the role of the
- Monte-Carlo payoff estimates from the standard UCT algorithm *)
-
-
-
-(** Parameters of the Upper Confidence Bounds-based Monte Carlo Tree
- Search. Cooperative (competitive) mode means that of actions with
- equal value for a given player, the one with highest (lowest) sum
- of values is chosen. *)
-type uct_params = {
- cUCB : float ; (** coefficient of the confidence bound component *)
- constK : float ; (** smoothening *)
- iters : int ; (** tree updates per move *)
- horizon : int option ; (** limit on the playout length *)
- heur_effect : mcts_heur_effect ; (** maximaxed vs local heuristic *)
- cooperative : bool ; (** cooperative vs competitive *)
- cLCB : float option ; (** cautious action picking; if present, use
- lower confidence bound with given
- coefficient for action selection *)
-}
-
-
-(** An evaluation game is a set of games specific to locations, each
- game is used to assess the value of its location. It contains the
- same data as {!play} plus {!play_state} (for initial state) below,
- only without the [model] and [time] fields, and with some general
- playout parameters. *)
-type evgame_loc = {
- ev_game : Arena.game;
- ev_agents : agent array;
- ev_delta : float;
- ev_location : int;
- ev_memory : memory array;
- ev_horizon : int option;
-}
-and evaluation_game = evgame_loc array
-
-(** How does a player pick moves. *)
-and agent =
- | Random_move
- (** select a random move; avoids rewriting all matches and
- calling evaluation games *)
- | Maximax_evgame of evaluation_game * bool * int * bool
- (** select a move according to evaluation games played in each leaf
- state; in a cooperative/competitive way (see {!uct_params});
- expand the full game subtree to the given depth and propagate
- evaluation game results from leaves by taking
- cooperative/competitive best move for location's player; optional
- alpha-beta-like pruning with move reordering based on
- afterstate heuristic value *)
- | Tree_search of evaluation_game * int option * uct_params * agent array
- (** Monte-Carlo tree search; uses the evaluation game to compute
- heuristic values for use within the tree *)
- | External of (string array -> int)
- (** take an array of string representations of resulting
- structures and return the position of the desired state; for
- interacting with external players only *)
-
-(** The evolving state of a play. *)
-type play_state = {
- game_state : Arena.game_state ;
- memory : memory array ; (** player-specific history *)
-}
-
-(** Data defining a play (without the initial play state). *)
-type play = {
- game : Arena.game ; (** the game played *)
- agents : agent array ; (** location.id-indexed *)
- delta : float ; (** expected width of payoffs *)
-}
-
-(** Initial state of the game given a play definition and initial
- structure, assuming the game starts in location at position 0 of
- {!Arena.game}. *)
-val initial_state : ?loc:int -> play -> Structure.structure -> play_state
-
-val default_params : uct_params
-
-(** An UCT-based agent that uses either random playouts (when
- [random_playout] is set to true) or the same location-dependent
- heuristic as an evaluation game as given for the inside-tree
- (including unevaluated tips) calculation. *)
-val default_treesearch : Structure.structure ->
- iters:int -> ?heuristic:Formula.real_expr array array ->
- ?advr:float ->
- ?random_playout:bool -> ?playout_mm_depth:int ->
- ?heur_effect:mcts_heur_effect -> ?horizon:int ->
- Arena.game -> agent
-
-
-(** Plain limited depth maximax tree search. *)
-val default_maximax : Structure.structure -> depth:int ->
- ?heuristic:Formula.real_expr array array ->
- ?advr:float -> ?pruning:bool ->
- Arena.game -> agent
-
-
-(** Update "memory" assuming that the position given corresponds to a
- move selected, as generated by {!gen_moves}. With tree search,
- selects the corresponding subtree of a tree. *)
-val update_memory : num_players:int -> Arena.game_state -> int ->
- memory array -> memory array
-
-(** Make a move in a play, or compute the payoff table when the game
- ended. Return the move chosen and the moves considered. One can
- use only the {!move} to suggest a move, or only the updated
- {!play_state} to follow a move (or both). Note that some
- computations are cached across play states, but that memory is not
- stored in the suggested move. If [just_payoffs] is given true,
- just compute the payoff table without computing available
- moves. *)
-val toss :
- grid_size:int -> ?just_payoffs:bool ->
- play -> play_state ->
- (int * Move.move array * memory array * play_state,
- float array) Aux.choice
-
-(** Play a play, by applying {!toss}, till the end. Return the final
- structure and its payoff. Discretize continuous move parameters
- using [grid_size] nodes per parameter. Limit the length of a play
- that started [plys] ago to no more than [horizon] steps
- overall.
-
- The [set_timer] should be only provided for standalone plays. For
- suggestions, the timer is set by {!Server}. It limits time per
- move, given in seconds. *)
-val play :
- grid_size:int -> ?set_timer:int -> ?horizon:int -> ?plys:int ->
- play -> play_state -> Structure.structure * float array
-
-(** Initialize a play. Optionally, take heuristics for use as simple
- evaluation games -- if not given, heuristics are derived from
- payoffs by {!Heuristic.of_payoff}. Moves suggested using given
- search method ("maximax", "alpha_beta", "alpha_beta_ord",
- "uct_random_playouts",
- "uct_greedy_playouts", "uct_maximax_playouts", "uct_no_playouts").
-
- Construct a default UCT tree search or plain maximax agent for use
- with the general {!toss} function. *)
-val initialize_default :
- Arena.game * Arena.game_state -> ?loc:int -> ?effort:int ->
- search_method:string -> ?horizon:int -> ?advr:float ->
- ?payoffs_already_tnf:bool ->
- ?heuristic:Formula.real_expr array array ->
- unit -> play * play_state
-
-(** Suggest a (currently, single) move for a state, return the same
- state but with accrued computation (i.e. bigger stored search
- trees). *)
-val suggest : ?effort:int ->
- play -> play_state -> (Move.move * play_state) option
-
-
-(* ------------------------- DEBUGGING ------------------------------------- *)
-
-(** Debugging information. At level 0 nothing is printed out.
- At level 1, we print only the number of iterations which passed.
- If > 1, print the updated gametree at each move using
- treesearch. *)
-val set_debug_level : int -> unit
-
-(** If true, do not randomize the final choice of move. Useful mostly
- for debugging. *)
-val deterministic_suggest : bool ref
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/GameTree.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -220,10 +220,9 @@
~choice:(choice_f heur (choice stop_vals))
(* Choose one of the maximizing moves (at random) given a game tree. *)
-let choose_move game = function
+let choose_moves game = function
| Terminal _ -> raise Not_found
- | Leaf (state, _, _) ->
- Aux.random_elem (Array.to_list (Move.list_moves game state))
+ | Leaf (state, _, _) -> Array.to_list (Move.list_moves game state)
| Node (_, p, info, succ) ->
let cmp (_, c1) (_, c2) =
let nval child = (node_values child).(p) in
@@ -236,19 +235,19 @@
Aux.array_find_all (fun (_,c) -> (node_values c).(p) = mval) succ in
let nonleaf = function Leaf _ -> false | _ -> true in
let move_s (m, n) = Move.move_gs_str_short (state n) m in
- if !debug_level > 0 then print_endline
+ if !debug_level > 2 then print_endline
("\nBest Moves: " ^ (String.concat ", " (List.map move_s maxs)));
if List.exists (fun x -> nonleaf (snd x)) maxs then (
- let (m, t) = Aux.random_elem maxs in (m, state t)
+ List.map (fun (m, t) -> (m, state t)) maxs
) else ( (* Do *not* take a shallow leaf if possible. *)
let nonleaves = Aux.array_find_all (fun (_,c) -> nonleaf c) succ in
if nonleaves = [] then (
- let (m, t) = Aux.random_elem maxs in (m, state t)
+ List.map (fun (m, t) -> (m, state t)) maxs
) else (
let upd_max mv (_, c) = max mv (node_values c).(p) in
let sx = (node_values (snd (List.hd nonleaves))).(p) in
let mx = List.fold_left upd_max sx nonleaves in
let mxs = List.filter (fun (_,c) -> (node_values c).(p)=mx) nonleaves in
- let (m, t) = Aux.random_elem mxs in (m, state t)
+ List.map (fun (m, t) -> (m, state t)) mxs
)
)
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/GameTree.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -76,8 +76,9 @@
val node_info : 'a game_tree -> 'a
-(** Choose one of the maximizing moves (at random) given a game tree. *)
-val choose_move : Arena.game -> 'a game_tree -> Move.move * Arena.game_state
+(** Choose all maximizing moves given a game tree. *)
+val choose_moves : Arena.game -> 'a game_tree ->
+ (Move.move * Arena.game_state) list
(** Game tree initialization. *)
Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Play.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -46,31 +46,50 @@
~info_node:(maxdepth_node) ~choice:(maximax_depth_choice ab)
(* Maximax unfolding upto depth. *)
-let rec unfold_maximax_upto ?(ab=false) count game heur t =
- if count = 0 || timed_out () then t else
+let rec unfold_maximax_upto ?(ab=false) count game heur (t, pmvs) =
+ let mvs = (choose_moves game t) :: pmvs in
+ if count = 0 || timed_out () then (t, mvs) else
try
let u = unfold_maximax ~ab:ab game heur t in
if !debug_level > 0 then Printf.printf "%d,%!" (size u);
- unfold_maximax_upto ~ab:ab (count-1) game heur u
+ if !debug_level > 1 then (
+ let move_s (m, n) = Move.move_gs_str_short n m in
+ let mstr = String.concat ", " (List.map move_s (List.hd mvs)) in
+ Printf.printf "(%s),%!" mstr
+ );
+ unfold_maximax_upto ~ab:ab (count-1) game heur (u, mvs)
with
- | Not_found -> t
+ | Not_found -> (t, mvs)
| Aux.Timeout msg ->
if !debug_level > 0 then
- if !debug_level > 0 then Printf.printf "Timeout %f (%s)%!"
+ Printf.printf "Timeout %f (%s)%!"
(Unix.gettimeofday() -. !timeout) msg;
- t
+ (t, mvs)
(* Maximax unfold upto depth and choose move. *)
-let maximax_unfold_choose count game state heur =
+let maximax_unfold_choose ?(check_stable=3) count game state heur =
let ab = Heuristic.is_constant_sum heur in (* TODO: payoffs as well! *)
if !debug_level > 0 then Printf.printf "Using Alpha-Beta: %B\n%!" ab;
if !debug_level > 3 then
Array.iter (fun h -> Array.iter Formula.print_real h) heur;
let t = init game state (fun _ _ _ -> 0) heur in
- let u = unfold_maximax_upto ~ab count game heur t in
- if !debug_level > 1 then
- print_endline (str ~upto:1 ~struc:false string_of_int u);
- choose_move game u
+ try
+ let (u, mvs) = unfold_maximax_upto ~ab count game heur (t, []) in
+ let nbr_to_check = min (2*check_stable + 1) (List.length mvs / 3) in
+ let last_mvs = Aux.take_n (max 1 nbr_to_check) mvs in
+ if !debug_level = 2 then
+ print_endline (str ~upto:1 ~struc:false string_of_int u);
+ if !debug_level > 2 then
+ print_endline (str ~upto:(!debug_level-1) string_of_int u);
+ let rec ord_sub = function
+ | ([], _) -> true
+ | (x :: xs, []) -> false
+ | (x :: xs, y :: ys) when x = y -> ord_sub (xs, ys)
+ | (x :: xs, y :: ys) -> ord_sub (x :: xs, ys) in
+ let nbr mv = List.length (List.filter (fun m -> ord_sub (mv,m)) last_mvs) in
+ let mvs_votes = List.map (fun m -> (m, nbr m)) last_mvs in
+ fst (List.hd (List.stable_sort (fun (_, i) (_, j) -> j - i) mvs_votes))
+ with Not_found -> []
(* -------------------- UCT ------------------ *)
@@ -117,8 +136,8 @@
if parent_sc.score_obs = 0 then failwith
"ucb1_tuned: parent has no observations";
let cHEUR = match params.heur_effect with
- | (c, _) when not lower_bound -> c
- | (_, c) when lower_bound -> c in
+ | (_, c) when lower_bound -> c
+ | (c, _) -> c in
let i2f = float_of_int in
let tot = i2f parent_sc.score_obs in
let vari = score.variation_table.(player) in
Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Play.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -13,11 +13,13 @@
int GameTree.game_tree -> int GameTree.game_tree
-(** Maximax unfolding upto depth. *)
+(** Maximax unfolding upto depth, keep previous moves for stability. *)
val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
Formula.real_expr array array ->
- int GameTree.game_tree -> int GameTree.game_tree
+ int GameTree.game_tree * (Move.move * Arena.game_state) list list ->
+ int GameTree.game_tree * (Move.move * Arena.game_state) list list
(** Maximax unfold upto depth and choose move. *)
-val maximax_unfold_choose : int -> Arena.game -> Arena.game_state ->
- Formula.real_expr array array -> Move.move * Arena.game_state
+val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
+ Arena.game_state -> Formula.real_expr array array ->
+ (Move.move * Arena.game_state) list
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/PlayTest.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -25,24 +25,27 @@
let test_maximax ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
- ~iters gname ?(msg="") ?(nomove=false) check_fun =
- let (g, s) = state_of_file ("./examples/"^gname^".toss") ~struc ~time ~loc in
+ ~iters ~game ?(msg="") ?(nomove=false) cond =
+ let (g, s) = state_of_file ("./examples/"^game^".toss") ~struc ~time ~loc in
GameTree.set_debug_level debug;
Play.set_debug_level debug;
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr g in
- try
- let (m, ns) = Play.maximax_unfold_choose iters g s h in
- let move_str = Move.move_gs_str_short s m in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str) (check_fun move_str)
- with Not_found ->
- if nomove then assert_bool "No Move: Test Passed" true else
- assert_bool "No Move: Test Failed!" false
+ let res_mvs = Play.maximax_unfold_choose iters g s h in
+ if res_mvs <> [] then
+ List.iter (fun (m, ns) ->
+ let move_str = Move.move_gs_str_short s m in
+ assert_bool
+ (Printf.sprintf "%s: Failed move: %s." msg move_str) (cond move_str)
+ ) res_mvs
+ else if nomove then
+ assert_bool "No Move: Test Passed" true
+ else
+ assert_bool "No Move: Test Failed!" false
-let test_algo algo ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
- ~iters gname ?(msg="") ?(nomove=false) check_fun =
+let test_algo algo ~game ~iters ?(advr=4.) ?(debug=0)
+ ?(struc="") ?(time=0.) ?(loc=0) ?(nomove=false) ?(msg="") cond =
if algo = "Maximax" then
- test_maximax ~debug ~advr ~struc ~time ~loc ~iters gname ~nomove check_fun
+ test_maximax ~debug ~advr ~struc ~time ~loc ~iters ~game ~nomove ~msg cond
else failwith "Unsupported play algorithm"
@@ -68,27 +71,21 @@
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
let t = GameTree.init g s (fun _ _ _ -> 0) h in
- let u = Play.unfold_maximax_upto 50 g h t in
+ let (u, _) = Play.unfold_maximax_upto 50 g h (t, []) in
(* print_endline (GameTree.str string_of_int u); *)
assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u);
- let u1 = Play.unfold_maximax_upto ~ab:true 50 g h t in
+ let (u1, _) = Play.unfold_maximax_upto ~ab:true 50 g h (t, []) in
(* print_endline (GameTree.str string_of_int u1); *)
assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u1);
);
- "checkers suggest first move 5 iters" >::
- (fun () ->
- test_maximax "Checkers" ~debug:0 ~iters:5
- ~msg:"make any first move in checkers after 5 iters" (fun s -> true)
- );
]
let tictactoe_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters
- "Tic-Tac-Toe" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Tic-Tac-Toe" ~iters ~advr:5. in
("Tic-Tac-Toe (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
"basic defense" >::
@@ -192,9 +189,8 @@
]
let breakthrough_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:2. ~struc ~time ~loc ~iters
- "Breakthrough" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Breakthrough" ~iters ~advr:2. in
("Breakthrough (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
"avoid endgame" >::
@@ -325,119 +321,16 @@
let gomoku8x8_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters
- "Gomoku" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Gomoku" ~iters ~advr:5. in
("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
- "avoid endgame 1" >::
+ "simple attack" >::
(fun () ->
let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- Q.. P..P ... ...
- ... ... ... ...
- ...Q ... ... ...
- ... ... ... ...
- Q.. ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block"
- (fun mov_s -> "Cross{1:b5}" = mov_s)
- );
-
- "avoid endgame 2" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... Q..Q Q.. ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... P..P ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block with line"
- (fun mov_s -> "Cross{1:f7}" = mov_s);
- );
-
-
- "block gameover" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... P.. ... ...
- ... ... ... ...
- ... ...P P..Q ...
- ... ... ... ...
- ... P..P ...Q ...
- ... ... ... ...
- ...Q Q..Q Q..P ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block"
- (fun mov_s -> "Cross{1:a3}" = mov_s);
- );
-
-
- "more pieces" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- P ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ...P Q..Q Q.. ...
- ... ... ... ...
- ...Q Q..Q P..P ...
- ... ... ... ...
- Q..Q P..Q P.. ...
- ... ... ... ...
- ...P Q..P ...P ...
- ... ... ... ...
- ...P ... P.. ...
- ... ... ... ...
- ... ... ...Q ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block the open line"
- (fun mov_s -> "Cross{1:e7}" = mov_s);
- );
-
- "attack" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
... ...Q ... ...
... ... ... ...
... P..Q P.. ...
@@ -456,13 +349,13 @@
test_do ~struc ~loc:0 ~msg:"P should attack the diagonal"
(fun mov_s -> "Cross{1:d4}" = mov_s);
);
+
]
let connect4_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters
- "Connect4" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Connect4" ~iters ~advr:5. ~debug:0 in
("Connect4 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
"simple attack" >::
@@ -507,7 +400,7 @@
(fun mov_s -> "Cross{1:f3}" <> mov_s);
);
- "endgame" >::
+ (Printf.sprintf "endgame (%i iters)" (30*iters)) >::
(fun () ->
let struc = "MODEL [ | | ] \"
@@ -524,73 +417,152 @@
P P P Q Q . .
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should defend"
+ test_do ~iters:(30*iters) ~struc ~loc:0 ~msg:"P should defend"
(fun mov_s -> "Cross{1:e2}" = mov_s);
);
]
+let checkers_tests algo iters =
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Checkers" ~iters ~advr:2. in
+ ("Checkers (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "any first move" >::
+ (fun () ->
+ test_do ~msg:"make any first move" (fun s -> true)
+ );
+ ]
+
+
+
let tests = "Play" >::: [
basic_tests;
- tictactoe_tests "Maximax" 3;
- breakthrough_tests "Maximax" 5;
+ tictactoe_tests "Maximax" 4;
+ breakthrough_tests "Maximax" 6;
gomoku8x8_tests "Maximax" 4;
- connect4_tests "Maximax" 7;
+ connect4_tests "Maximax" 4;
+ checkers_tests "Maximax" 4;
]
(* ----------------- BIG TESTS ------------- *)
-let chess_tests_big = "ChessBig" >::: [
- "random first move" >::
- (fun () ->
- test_maximax "Chess" ~debug:0 ~iters:0
- ~msg:"make any first move in chess" (fun s -> true)
- );
-
- "first move 1 iter" >::
- (fun () ->
- test_maximax "Chess" ~debug:0 ~iters:1
- ~msg:"make a selected first move in chess" (fun s -> true)
- );
+let gomoku8x8_tests_big algo iters =
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Gomoku" ~advr:5. ~iters in
+ ("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
- "detect draw" >::
- (fun () ->
- let struc =
-"MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+ "avoid endgame 1" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
- ... ... +bN ...
+ ... ... ... ...
... ... ... ...
... ... ... ...
... ... ... ...
- ... bP. ...-bNwK.
+ ... ...P ... ...
... ... ... ...
- ...bP ... ... ...
+ ... ... ... ...
... ... ... ...
- bR. ... ...bQ ...
+ Q.. P..P ... ...
... ... ... ...
- ... ...bK ... ...bP
+ ...Q ... ... ...
... ... ... ...
+ Q.. ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block"
+ (fun mov_s -> "Cross{1:b5}" = mov_s)
+ );
+
+ "avoid endgame 2" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
+ ... ... ... ...
... ... ... ...
+ ... Q..Q Q.. ...
+ ... ... ... ...
+ ... ...P ... ...
... ... ... ...
-\" with
-D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
-D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
- test_maximax "Chess" ~debug:0 ~iters:1 ~struc
- ~msg:"detect draw in chess" ~nomove:true (fun _ -> false)
- );
-]
+ ... ... ... ...
+ ... ... ... ...
+ ... P..P ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block with line"
+ (fun mov_s -> "Cross{1:f7}" = mov_s);
+ );
-let gomoku_tests_big = "GomokuBig" >::: [
- "maximax suggest defense 1" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+
+ "block gameover" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... P.. ... ...
+ ... ... ... ...
+ ... ...P P..Q ...
+ ... ... ... ...
+ ... P..P ...Q ...
+ ... ... ... ...
+ ...Q Q..Q Q..P ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block"
+ (fun mov_s -> "Cross{1:a3}" = mov_s);
+ );
+
+
+ "more pieces" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
+ ... ... ... ...
+ P ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ...P Q..Q Q.. ...
+ ... ... ... ...
+ ...Q Q..Q P..P ...
+ ... ... ... ...
+ Q..Q P..Q P.. ...
+ ... ... ... ...
+ ...P Q..P ...P ...
+ ... ... ... ...
+ ...P ... P.. ...
+ ... ... ... ...
+ ... ... ...Q ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block the open line"
+ (fun mov_s -> "Cross{1:e7}" = mov_s);
+ );
+
+ "defense 1" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
... ...P ... ...
... ... ... ...
... P.. ... ...
@@ -605,14 +577,14 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:160
- (fun s -> s = "Circle{1:d8}");
- );
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:1 ~msg:"Q should defend"
+ (fun s -> s = "Circle{1:d8}");
+ );
- "maximax suggest defense 2" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ "defense 2" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
... ... ... ...
P.. ... ... ...
... ... ... ...
@@ -630,14 +602,14 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:180
- (fun s -> s = "Circle{1:e1}");
- );
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:1 ~msg:"Q should defend"
+ (fun s -> s = "Circle{1:e1}");
+ );
- "maximax suggest defense 3" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ "stability under iterations (long)" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
@@ -655,16 +627,92 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:210
- (fun s -> s = "Circle{1:b6}");
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:1 ~iters:212 ~debug:0 ~msg:"Q should defend"
+ (fun s -> s = "Circle{1:b6}");
+ );
+
+ ]
+
+
+
+let connect4_tests_big algo (i_from, i_to, i_step) =
+ let test_do = test_algo algo ~game:"Connect4" ~advr:5. ~debug:0 in
+ let rec range f t s = if t < f then [] else f :: (range (f+s) t s) in
+ let create_tests test_create_f =
+ (Printf.sprintf "Connect4 (%s %i-%i by %i)" algo i_from i_to i_step) >:::
+ (List.concat (List.map test_create_f (range i_from i_to i_step))) in
+ let make_test i =
+ [(Printf.sprintf "endgame (%i)" i) >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
+
+ . . . . . . .
+
+ . . . . . . .
+
+ Q . . . . . .
+
+ P . . . . . .
+
+ P . +Q Q . . .
+
+ P P P Q Q . .
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~iters:i ~msg:"P should defend"
+ (fun mov_s -> "Cross{1:e2}" = mov_s);
+ );] in
+ create_tests make_test
+
+
+let chess_tests_big algo iters =
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Chess" ~advr:2. ~iters in
+ ("Chess (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "random first move" >::
+ (fun () ->
+ test_do ~iters:0 ~msg:"make a random first move" (fun s -> true)
+ );
+
+ "select any first move" >::
+ (fun () ->
+ test_do ~msg:"make any selected first move" (fun s -> true)
+ );
+
+ "detect draw" >::
+ (fun () ->
+ let struc =
+ "MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+ ... ... ... ...
+ ... ... +bN ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... bP. ...-bNwK.
+ ... ... ... ...
+ ...bP ... ... ...
+ ... ... ... ...
+ bR. ... ...bQ ...
+ ... ... ... ...
+ ... ...bK ... ...bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with
+D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
+D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
+ test_do ~struc ~msg:"detect draw" ~nomove:true (fun _ -> false)
);
]
let bigtests = "PlayBig" >::: [
- chess_tests_big;
- gomoku_tests_big;
+ connect4_tests_big "Maximax" (100, 300, 10);
+ gomoku8x8_tests_big "Maximax" 6;
+ chess_tests_big "Maximax" 1;
]
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Server/Server.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -130,8 +130,9 @@
~struc:(snd !state).Arena.struc
?advr (fst !state));
Aux.unsome !g_heur in
- let (move, _) = Play.maximax_unfold_choose effort
- (fst !state) (snd !state) heur in
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose effort
+ (fst !state) (snd !state) heur) in
Play.cancel_timeout ();
Move.move_gs_str !state move
)
@@ -178,17 +179,11 @@
Printf.printf "ApplyRule: mismatched with play state!\n%!";
state := new_state; resp
with Found pos ->
- let old_struc = (snd !state).Arena.struc in
let (new_state, resp) = Arena.handle_request !state req in
(* Rewriting doesn't handle location update. *)
let new_loc = moves.(pos).Move.next_loc in
state := (fst new_state,
{snd new_state with Arena.cur_loc = new_loc});
- let new_game_state = {
- Arena.struc = (snd new_state).Arena.struc;
- cur_loc = moves.(pos).Move.next_loc;
- time = (snd new_state).Arena.time;
- } in
resp
)
@@ -258,7 +253,6 @@
failwith
"Server GDL Play request: action mismatched with play state"
with Found pos -> pos) in
- let old_struc = (snd !state).Arena.struc in
let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
let (new_state, resp) = Arena.handle_request !state req in
(* Rewriting doesn't handle location update. *)
@@ -280,8 +274,9 @@
let heur = match !g_heur with
| Some h -> h
| None -> failwith "no heuristic for gametree!" in
- let (move, _) = Play.maximax_unfold_choose 5500
- (fst !state) (snd !state) heur in
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose 5500
+ (fst !state) (snd !state) heur) in
GDL.translate_move !gdl_transl !state
move.Move.rule move.Move.embedding
) else (
@@ -359,7 +354,10 @@
failwith "only 2-player games supported in experiments for now" in
let timeo = if pl = 0 then !exp_p1_timeout else !exp_p2_timeout in
let heur = if pl = 0 then heur1 else heur2 in
- let (_, s) = Play.maximax_unfold_choose depth game !cur_state heur in
+ Play.set_timeout (float timeo);
+ let (_, s) =
+ Aux.random_elem (Play.maximax_unfold_choose depth game !cur_state heur) in
+ Play.cancel_timeout ();
cur_state := s;
print_endline ("State: " ^ (Structure.str !cur_state.Arena.struc));
print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter));
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-14 23:57:30
|
Revision: 1410
http://toss.svn.sourceforge.net/toss/?rev=1410&view=rev
Author: lukaszkaiser
Date: 2011-04-14 23:57:24 +0000 (Thu, 14 Apr 2011)
Log Message:
-----------
Main game type change, prepare for concurrency, imperfect information, feature learning. Just breaks things for now, sorry.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/Move.ml
trunk/Toss/Play/Move.mli
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Arena/Arena.ml 2011-04-14 23:57:24 UTC (rev 1410)
@@ -15,20 +15,25 @@
parameters_in : (string * (float * float)) list ;
}
-(* A game has locations from which a player (single for now) can move,
- with a label, to one of the next positions, or get a
- payoff. Players are indexed continuously starting from 0. *)
-type location = {
- id : int ;
- player : int ;
- payoffs : Formula.real_expr array ;
+
+(** A game has locations. In each one, each player has 0 or more
+ possible moves, each with a label, to one of the next locations.
+ We also store the view (see elsewhere) and weights for heuristics.
+ If no moves are possible, everyone gets a payoff.
+ Players are indexed continuously starting from 0. *)
+type player_loc = {
+ payoff : Formula.real_expr ;
moves : (label * int) list ;
+ view : Formula.formula * (string * Formula.formula) list ;
+ heur : float list ;
}
-(* The basic type of Arena. *)
+
+(** The basic type of Arena. *)
type game = {
rules : (string * ContinuousRule.rule) list;
- graph : location array;
+ patterns : Formula.real_expr list;
+ graph : player_loc array array;
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
@@ -46,7 +51,10 @@
let emp_struc = Structure.empty_structure () in
let zero = Formula.Const 0.0 in
{rules = [];
- graph = Array.make 1 { id = 0; player = 0; payoffs = [|zero|]; moves = [] };
+ patterns = [];
+ graph = Array.make 1
+ (Array.make 1
+ { payoff = zero; moves = []; view = (Formula.And [],[]); heur = [] });
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
@@ -70,11 +78,8 @@
(* Rules with which a player with given number can move. *)
let rules_for_player player_no game =
- let rules_of_loc l =
- if l.player = player_no then
- Some (List.map (fun (lab, _) -> lab.rule) l.moves)
- else None in
- List.concat (Aux.map_some rules_of_loc (Array.to_list game.graph))
+ let rules_of_loc l = List.map (fun (lab,_) -> lab.rule) l.(player_no).moves in
+ List.concat (List.map rules_of_loc (Array.to_list game.graph))
(* Add a defined relation to a structure. *)
let add_def_rel_single struc (r_name, vars, def_phi) =
@@ -101,7 +106,7 @@
(string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule)
(* add a rule *)
- | DefLoc of ((string * int) list -> location)
+ | DefLoc of ((string * int) list -> player_loc array)
(* add location to graph *)
| DefPlayers of string list (* add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
@@ -146,11 +151,14 @@
let pname = match pname with None -> "1" | Some p -> p in
fun player_names ->
let player = List.assoc pname player_names in
- let zero = Formula.Const 0.0 in
- let payoffs =
- array_of_players zero player_names payoffs in
- { id = id; player = player; payoffs = payoffs; moves = moves }
+ let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
+ heur = []; moves = [] } in
+ let locs = List.map (fun (pl, poff) ->
+ (pl, { payoff = poff ; view = (Formula.And [], []); heur = [];
+ moves = if pl = pname then moves else [] })) payoffs in
+ array_of_players zero_loc player_names locs
+
open Printf
(* Create a game state, possibly by extending an old state, from a
@@ -239,14 +247,15 @@
let updated_locs =
if old_locs = [] then old_locs
else
- let zero = Formula.Const 0.0 in
- let add_payoffs loc =
- let more = num_players - Array.length loc.payoffs in
- {loc with payoffs = Array.append loc.payoffs (Array.make more zero);} in
- List.map add_payoffs old_locs in
+ let more = num_players - Array.length (List.hd old_locs) in
+ let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
+ heur = []; moves = [] } in
+ let add_more loc = Array.append loc (Array.make more zero_loc) in
+ List.map add_more old_locs in
let add_def_rel loc =
- let ps = Array.map (FormulaOps.subst_rels_expr def_rels_pure) loc.payoffs in
- { loc with payoffs = ps; } in
+ let sub_p l =
+ { l with payoff = FormulaOps.subst_rels_expr def_rels_pure l.payoff } in
+ Array.map sub_p loc in
(* {{{ log entry *)
if !debug_level > 2 then (
printf "process_definition: parsing locations (registering payoffs)...%!";
@@ -259,19 +268,11 @@
printf " parsed\n%!";
);
(* }}} *)
- let graph =
- try
- Aux.array_from_assoc
- (List.map (fun loc->loc.id, loc) locations)
- with Invalid_argument _ ->
- let loc_numbers =
- List.sort compare (List.map (fun loc->loc.id) locations) in
- raise (
- Arena_definition_error (
- "Locations not consecutive from 0: " ^
- String.concat ", " (List.map string_of_int loc_numbers))) in
+ 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 = [];
graph = graph;
num_players = num_players;
player_names = player_names;
@@ -299,15 +300,15 @@
(* Print a move as string. *)
let move_str (lb, i) = "["^ (label_str lb) ^" -> "^ (string_of_int i) ^"]"
-let fprint_loc_body struc pnames f
- {player = player; payoffs = payoffs; moves = moves} =
+let fprint_loc_body_in struc pnames f player
+ {payoff = payoff; moves = moves} =
Format.fprintf f "@[<1>PLAYER@ %s@]@ "
(Aux.rev_assoc pnames player);
Format.fprintf f "@[<1>PAYOFF@ {@,@[<1>%a@]@,}@]@ "
(Aux.fprint_sep_list ";" (fun f (p, ex) ->
Format.fprintf f "@[<1>%s:@ %a@]" (Aux.rev_assoc pnames p)
(Formula.fprint_real(* _nobra 0 *)) ex))
- (Array.to_list (Array.mapi (fun i l->i, l) payoffs));
+ (Array.to_list (Array.mapi (fun i l->i, l) [|payoff|]));
Format.fprintf f "@[<1>MOVES@ %a@]"
(Aux.fprint_sep_list ";" (fun f ({
rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
@@ -320,6 +321,10 @@
Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
Format.fprintf f "@ ->@ %d@]@,]" target)) moves
+
+let fprint_loc_body struc pnames f loc =
+ Array.iteri (fun p l -> fprint_loc_body_in struc pnames f p l) loc
+
let equational_def_style = ref true
let fprint_state_full print_compiled_rules ppf
@@ -357,9 +362,9 @@
List.iter (fun (rname, r) ->
Format.fprintf ppf "@[<1>RULE %s:@ %a@]@ " rname
(ContinuousRule.fprint_full print_compiled_rules) r) rules;
- Array.iter (fun loc ->
+ Array.iteri (fun loc_id loc ->
Format.fprintf ppf "@[<1>LOC %d@ {@,@[<1>@,%a@]@,}@]@ "
- loc.id (fprint_loc_body struc player_names) loc) graph;
+ loc_id (fprint_loc_body struc player_names) loc) graph;
Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
(Structure.fprint ~show_empty:true) struc;
if cur_loc <> 0 then
@@ -388,12 +393,12 @@
let add_new_player (state_game, state) pname =
let player = state_game.num_players in
- let zero = Formula.Const 0.0 in
- let add_payoff loc =
- {loc with payoffs = Array.append loc.payoffs [|zero|]; } in
+ let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
+ heur = []; moves = [] } in
+ let add_more loc = Array.append loc [|zero_loc|] in
let game = {state_game with
num_players = state_game.num_players + 1;
- graph = Array.map add_payoff state_game.graph;
+ graph = Array.map add_more state_game.graph;
player_names = (pname, player)::state_game.player_names;
} in
(game, state), player
@@ -403,11 +408,9 @@
rules = List.map (fun (rn, r) ->
rn, ContinuousRule.map_to_formulas f r
) game.rules;
- graph = Array.map (fun loc ->
- {loc with
- payoffs =
- Array.map (FormulaOps.map_to_formulas_expr f) loc.payoffs;
- }) game.graph;
+ graph = Array.map (fun la -> Array.map (fun loc ->
+ {loc with payoff = FormulaOps.map_to_formulas_expr f loc.payoff;
+ }) la) game.graph;
defined_rels = List.map (fun (drel, (args, def)) ->
drel, (args, f def)) game.defined_rels;
}
@@ -418,9 +421,9 @@
ContinuousRule.fold_over_formulas f r
) game.rules acc in
let acc =
- Array.fold_right (fun loc ->
- Array.fold_right (FormulaOps.fold_over_formulas_expr f) loc.payoffs
- ) game.graph acc in
+ Array.fold_right (fun la -> Array.fold_right
+ (fun loc -> FormulaOps.fold_over_formulas_expr f loc.payoff) la)
+ game.graph acc in
let acc =
if include_defined_rels then
List.fold_right (fun (_, (_, def)) -> f def)
@@ -490,37 +493,32 @@
let pnames2 = List.sort cmp_pn g2.player_names in
if pnames1 <> pnames2 then
raise (Diff_result "Game players are given in different order.");
- Array.iteri (fun i loc1 ->
- let loc2 = g2.graph.(i) in
- let dmoves1 = Aux.list_diff loc1.moves loc2.moves in
- if dmoves1 <> [] then raise (Diff_result (
- let label, dest = List.hd dmoves1 in
- Printf.sprintf
- "At location %d, only the first game has label %s->%d"
- i label.rule dest));
- let dmoves2 = Aux.list_diff loc2.moves loc1.moves in
- if dmoves2 <> [] then raise (Diff_result (
- let label, dest = List.hd dmoves1 in
- Printf.sprintf
- "At location %d, only the second game has label %s->%d"
- i label.rule dest));
- if loc1.player <> loc2.player then raise (Diff_result (
- Printf.sprintf
- "At location %d, the first game has player %d, second %d"
- i loc1.player loc2.player));
- Array.iteri (fun p poff1 ->
+ Array.iteri (fun i locarr1 ->
+ Array.iteri (fun pl loc1 ->
+ let loc2 = g2.graph.(i).(pl) in
+ let dmoves1 = Aux.list_diff loc1.moves loc2.moves in
+ if dmoves1 <> [] then raise (Diff_result (
+ let label, dest = List.hd dmoves1 in
+ Printf.sprintf
+ "At location %d, only the first game has label %s->%d"
+ i label.rule dest));
+ let dmoves2 = Aux.list_diff loc2.moves loc1.moves in
+ if dmoves2 <> [] then raise (Diff_result (
+ let label, dest = List.hd dmoves1 in
+ Printf.sprintf
+ "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
- poff1 in
+ loc1.payoff in
let poff2 =
FormulaOps.map_to_formulas_expr FormulaOps.flatten_formula
- loc2.payoffs.(p) in
+ 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"
- i p (Formula.real_str poff1)
- (Formula.real_str poff2)));
- ) loc1.payoffs
+ i pl (Formula.real_str poff1) (Formula.real_str poff2)));
+ ) locarr1
) g1.graph;
if List.sort Pervasives.compare g1.defined_rels <>
List.sort Pervasives.compare g2.defined_rels
@@ -769,9 +767,10 @@
| SetLoc (i) ->
let l = Array.length state_game.graph in
if i < 0 || i > l then (* make new location and set there *)
- let a = Array.make 1
- { id = l; player=0; payoffs=[| |]; moves=[] } in
- (({state_game with graph=Array.append state_game.graph a},
+ let zero_loc = { payoff = Formula.Const 0. ; heur = []; moves = [] ;
+ view = (Formula.And [], []); } in
+ let a = Array.make (Array.length state_game.graph.(0)) zero_loc in
+ (({state_game with graph = Array.append state_game.graph [|a|]},
{state with cur_loc = l }),
"NEW LOC ADDED AND CUR LOC SET TO " ^ (string_of_int l))
else
@@ -779,22 +778,13 @@
| GetLoc ->
((state_game, state), (string_of_int state.cur_loc) ^ " / " ^
(string_of_int (Array.length state_game.graph)))
- | SetLocPlayer (i, player) ->
- let (state_game, state), player =
- try (state_game, state), List.assoc player state_game.player_names
- with Not_found -> add_new_player (state_game, state) player in
- if i < 0 || i > Array.length state_game.graph then
+ | SetLocPlayer (i, player) -> failwith "unsupported for now, concurrency"
+ (* ((state_game, state), "LOC PLAYER SET") *)
+ | GetLocPlayer (i) -> failwith "unsupported for now, concurrency"
+ (* if i < 0 || i > Array.length state_game.graph then
((state_game, state), "ERR location "^string_of_int i^" not found")
- else (
- state_game.graph.(i) <-
- { state_game.graph.(i) with player = player };
- ((state_game, state), "LOC PLAYER SET")
- )
- | GetLocPlayer (i) ->
- if i < 0 || i > Array.length state_game.graph then
- ((state_game, state), "ERR location "^string_of_int i^" not found")
else ((state_game, state), Aux.rev_assoc state_game.player_names
- state_game.graph.(i).player)
+ state_game.graph.(i).player) *)
| SetLocPayoff (i, player, payoff) ->
let (state_game, state), player =
try (state_game, state), List.assoc player state_game.player_names
@@ -803,7 +793,8 @@
((state_game, state), "ERR location "^string_of_int i^" not found")
else (
let simp_payoff = FormulaOps.tnf_re payoff in
- state_game.graph.(i).payoffs.(player) <- simp_payoff;
+ state_game.graph.(i).(player) <-
+ { state_game.graph.(i).(player) with payoff = simp_payoff };
((state_game, state), "LOC PAYOFF SET")
)
| GetLocPayoff (i, player) ->
@@ -811,31 +802,33 @@
((state_game, state), "ERR location "^string_of_int i^" not found")
else (
try
- ((state_game, state), Formula.real_str
- state_game.graph.(i).payoffs.(List.assoc player
- state_game.player_names))
+ let pno = List.assoc player state_game.player_names in
+ ((state_game, state),
+ Formula.real_str state_game.graph.(i).(pno).payoff)
with Not_found -> ((state_game, state), "0.0")
)
| GetCurPayoffs ->
let payoffs = Array.to_list
- (Array.mapi (fun i v->string_of_int i,v)
- state_game.graph.(state.cur_loc).payoffs) in
+ (Array.mapi (fun i v->string_of_int i, v.payoff)
+ state_game.graph.(state.cur_loc)) in
let ev (p,e) =
p^": "^(string_of_float (Solver.M.get_real_val e struc)) in
((state_game, state),
String.concat ", " (List.sort compare (List.map ev payoffs)))
- | SetLocMoves (i, moves) ->
- if i < 0 || i > Array.length state_game.graph then
+ | SetLocMoves (i, moves) -> failwith "unsupported for now, concurrency"
+ (* if i < 0 || i > Array.length state_game.graph then
((state_game, state), "ERR location "^string_of_int i^" not found")
else (
state_game.graph.(i) <- { state_game.graph.(i) with moves = moves };
((state_game, state), "LOC MOVES SET")
- )
- | GetLocMoves (i) ->
+ ) *)
+ | GetLocMoves (i) -> (* TODO! adapt for concurrency! *)
if i < 0 || i > Array.length state_game.graph then
((state_game, state), "ERR location "^string_of_int i^" not found")
- else ((state_game, state),
- (String.concat "; " (List.map move_str state_game.graph.(i).moves)))
+ 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)))
| SuggestLocMoves _ ->
failwith "handle_req: SuggestLocMoves handled in Server"
| EvalFormula (phi) -> ((state_game, state), "ERR eval not yet implemented")
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Arena/Arena.mli 2011-04-14 23:57:24 UTC (rev 1410)
@@ -10,21 +10,24 @@
parameters_in : (string * (float * float)) list ;
}
-(** A game has locations from which a player (single for now) can move,
- with a label, to one of the next positions, or get a
- payoff. Players are indexed continuously starting from 0. *)
-type location = {
- id : int ;
- player : int ;
- payoffs : Formula.real_expr array ;
+(** A game has locations. In each one, each player has 0 or more
+ possible moves, each with a label, to one of the next locations.
+ We also store the view (see elsewhere) and weights for heuristics.
+ If no moves are possible, everyone gets a payoff.
+ Players are indexed continuously starting from 0. *)
+type player_loc = {
+ payoff : Formula.real_expr ;
moves : (label * int) list ;
+ view : Formula.formula * (string * Formula.formula) list ;
+ heur : float list ;
}
(** The basic type of Arena. *)
type game = {
rules : (string * ContinuousRule.rule) list;
- graph : location array;
+ patterns : Formula.real_expr list;
+ graph : player_loc array array;
num_players : int;
player_names : (string * int) list ;
data : (string * string) list ;
@@ -85,7 +88,7 @@
(string * (string list * Formula.formula)) list -> string ->
ContinuousRule.rule)
(** add a rule *)
- | DefLoc of ((string * int) list -> location)
+ | DefLoc of ((string * int) list -> player_loc array)
(** add location to graph *)
| DefPlayers of string list (** add players (fresh numbers) *)
| DefRel of string * string list * Formula.formula
@@ -109,7 +112,7 @@
[< `Moves of (label * int) list
| `Payoffs of (string * Formula.real_expr) list
| `PlayerName of string ]
- list -> (string * int) list -> location
+ list -> (string * int) list -> player_loc array
(** Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-04-14 23:57:24 UTC (rev 1410)
@@ -12,7 +12,7 @@
%start parse_game_defs parse_game_state parse_request
%type <Arena.request> parse_request request
%type <Arena.struct_loc> struct_location
-%type <(string * int) list -> Arena.location> location
+%type <(string * int) list -> Arena.player_loc array> location
%type <Arena.definition> parse_game_defs
%type <Arena.game * Arena.game_state> parse_game_state game_state
%type <Arena.game * Arena.game_state -> Arena.game * Arena.game_state> extend_game_state
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Play/GameTree.ml 2011-04-14 23:57:24 UTC (rev 1410)
@@ -3,6 +3,9 @@
let debug_level = ref 0
let set_debug_level i = debug_level := i
+(* TODO; FIXME; THIS IS A STUB, TRUE CONCURRENCY SUPPORT NEEDED. *)
+let moving_player = Aux.array_argfind (fun l -> l.Arena.moves <> [])
+
(* Abstract game tree, just stores state and move information. *)
type ('a, 'b) abstract_game_tree =
| Terminal of Arena.game_state * int * 'b (* terminal state with player *)
@@ -55,7 +58,7 @@
(* Abstract game tree initialization. *)
let init_abstract game state info_leaf =
- let player = game.Arena.graph.(state.Arena.cur_loc).Arena.player in
+ let player = moving_player game.Arena.graph.(state.Arena.cur_loc) in
let info = info_leaf game state player in
Leaf (state, player, info)
@@ -80,7 +83,7 @@
Solver.M.clear_timeout();
raise (Aux.Timeout "GameTree.unfold_abstract.lm");
);
- let l_pl = game.Arena.graph.(leaf_s.Arena.cur_loc).Arena.player in
+ 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 = Array.mapi (fun i (m,s) -> (m,leaf_of_move i s)) moves in
@@ -175,8 +178,9 @@
let info_terminal_f f depth game state player leaf_info =
let calc re = Solver.M.get_real_val re state.Arena.struc in
- let payoffs =
- Array.map calc game.Arena.graph.(state.Arena.cur_loc).Arena.payoffs in
+ let payoff_terms = Array.map (fun l -> l.Arena.payoff)
+ game.Arena.graph.(state.Arena.cur_loc) in
+ let payoffs = Array.map calc payoff_terms in
{ payoffs = payoffs; heurs_t = leaf_info.heurs ; info_t = f depth game state }
let info_node_f f depth game state player children =
Modified: trunk/Toss/Play/GameTreeTest.ml
===================================================================
--- trunk/Toss/Play/GameTreeTest.ml 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Play/GameTreeTest.ml 2011-04-14 23:57:24 UTC (rev 1410)
@@ -64,8 +64,9 @@
let ch = (fun _ _ _ _ _ _ _ -> 0) in
let u = GameTree.unfold g h i_l i_n ch t in
(* print_endline (GameTree.str string_of_int u); *)
+ let moving_player = Aux.array_argfind (fun l -> l.Arena.moves <> []) in
assert_equal ~printer:(fun x -> string_of_int x) (GameTree.player u)
- g.Arena.graph.((GameTree.state u).Arena.cur_loc).Arena.player;
+ (moving_player g.Arena.graph.((GameTree.state u).Arena.cur_loc));
);
]
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Play/Heuristic.ml 2011-04-14 23:57:24 UTC (rev 1410)
@@ -1072,7 +1072,7 @@
Array.fold_right (fun x y->Plus (x, y)) ar (Const 0.) in
let all_payoffs =
array_plus (Array.map (fun loc ->
- array_plus loc.Arena.payoffs) graph) in
+ array_plus (Array.map (fun l -> l.Arena.payoff) loc)) graph) in
let posi_poff_rels, nega_poff_rels =
FormulaOps.rels_signs_expr all_payoffs in
let all_poff_rels =
@@ -1136,7 +1136,7 @@
);
(* }}} *)
res)
- node.Arena.payoffs in
+ (Array.map (fun l -> l.Arena.payoff) node) in
if !force_competitive && Array.length res > 1
then
Array.mapi (fun p v ->
Modified: trunk/Toss/Play/Move.ml
===================================================================
--- trunk/Toss/Play/Move.ml 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Play/Move.ml 2011-04-14 23:57:24 UTC (rev 1410)
@@ -115,7 +115,11 @@
Array.of_list moves, Array.of_list models
let list_moves game s =
- let loc = game.Arena.graph.(s.Arena.cur_loc) in
+ 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)
Modified: trunk/Toss/Play/Move.mli
===================================================================
--- trunk/Toss/Play/Move.mli 2011-04-14 01:58:27 UTC (rev 1409)
+++ trunk/Toss/Play/Move.mli 2011-04-14 23:57:24 UTC (rev 1410)
@@ -28,7 +28,7 @@
(** Generate moves available from a state, as an array, in fixed order. *)
val gen_moves : int -> (string * ContinuousRule.rule) list ->
- Structure.structure -> Arena.location -> move array
+ Structure.structure -> Arena.player_loc -> move array
val gen_models : (string * ContinuousRule.rule) list -> Structure.structure ->
float -> move array -> move array * Arena.game_state array
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-15 18:34:24
|
Revision: 1411
http://toss.svn.sourceforge.net/toss/?rev=1411&view=rev
Author: lukaszkaiser
Date: 2011-04-15 18:34:16 +0000 (Fri, 15 Apr 2011)
Log Message:
-----------
Correcting the remaining compilation problems - everything seems to work with the new type now.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/GGP/GDL.ml
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-04-14 23:57:24 UTC (rev 1410)
+++ trunk/Toss/Arena/Arena.ml 2011-04-15 18:34:16 UTC (rev 1411)
@@ -150,7 +150,6 @@
moves? *)
let pname = match pname with None -> "1" | Some p -> p in
fun player_names ->
- let player = List.assoc pname player_names in
let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
heur = []; moves = [] } in
let locs = List.map (fun (pl, poff) ->
@@ -780,11 +779,18 @@
(string_of_int (Array.length state_game.graph)))
| SetLocPlayer (i, player) -> failwith "unsupported for now, concurrency"
(* ((state_game, state), "LOC PLAYER SET") *)
- | GetLocPlayer (i) -> failwith "unsupported for now, concurrency"
- (* if i < 0 || i > Array.length state_game.graph then
+ | GetLocPlayer (i) ->
+ if i < 0 || i > Array.length state_game.graph then
((state_game, state), "ERR location "^string_of_int i^" not found")
- else ((state_game, state), Aux.rev_assoc state_game.player_names
- state_game.graph.(i).player) *)
+ else
+ let players =
+ Aux.array_argfind_all (fun l-> l.moves <> []) state_game.graph.(i) in
+ if List.length players <> 1 then
+ ((state_game, state), "ERR location " ^ string_of_int i ^ " allows "^
+ (string_of_int (List.length players)) ^ " players to move")
+ else
+ let pl = List.hd players in
+ ((state_game, state), Aux.rev_assoc state_game.player_names pl)
| SetLocPayoff (i, player, payoff) ->
let (state_game, state), player =
try (state_game, state), List.assoc player state_game.player_names
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-04-14 23:57:24 UTC (rev 1410)
+++ trunk/Toss/GGP/GDL.ml 2011-04-15 18:34:16 UTC (rev 1411)
@@ -3437,12 +3437,13 @@
label, (rname, rule)
) rules_brs in
let labels, rules = List.split labelled_rules in
- let location = {
- Arena.id = loc;
- player = find_player loc_players.(loc);
- payoffs = payoffs;
- moves = labels} in
- rules, location
+ let player = find_player loc_players.(loc) in
+ let location i = {
+ Arena.payoff = payoffs.(i);
+ moves = if i = player then labels else [];
+ view = (Formula.And [], []);
+ heur = []; } in
+ rules, Array.mapi (fun i _ -> location i) player_terms
) loc_toss_rules in
let rules = Array.map fst rules_and_locations
and locations = Array.map snd rules_and_locations in
@@ -3454,6 +3455,7 @@
let game = {
Arena.rules = rules;
graph = locations;
+ patterns = [];
num_players = players_n;
player_names = player_names;
data = [];
@@ -3542,7 +3544,8 @@
let loc = (snd state).Arena.cur_loc in
let actions = Array.of_list actions in
let location = (fst state).Arena.graph.(loc) in
- let player_action = actions.(location.Arena.player) in
+ let player_action = actions.(Aux.array_argfind (fun l -> l.Arena.moves <> [])
+ location) in
let struc = (snd state).Arena.struc in
(* {{{ log entry *)
if !debug_level > 2 then (
@@ -3723,8 +3726,10 @@
let our_turn gdl state =
let loc = (snd state).Arena.cur_loc in
- gdl.playing_as = (fst state).Arena.graph.(loc).Arena.player
+ gdl.playing_as = Aux.array_argfind (fun l -> l.Arena.moves <> [])
+ (fst state).Arena.graph.(loc)
+
let noop_move ?(force=false) gdl state =
let loc = state.Arena.cur_loc in
match gdl.noop_actions.(loc) with
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-04-14 23:57:24 UTC (rev 1410)
+++ trunk/Toss/Server/Server.ml 2011-04-15 18:34:16 UTC (rev 1411)
@@ -109,6 +109,12 @@
exception Found of int
+(* TODO; FIXME; remove the function below. *)
+let select_moving a = (* temporary func - 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" else
+ if locs = [] then a.(0) else List.hd locs
+
let req_handle in_ch out_ch =
try
let time_started = Unix.gettimeofday () in
@@ -152,9 +158,9 @@
r.ContinuousRule.discrete.DiscreteRule.lhs_struc in
let m =
List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch in
- let moves =
- Move.gen_moves Move.cGRID_SIZE rules
- (snd !state).Arena.struc graph.((snd !state).Arena.cur_loc) in
+ let loc = select_moving graph.((snd !state).Arena.cur_loc) in
+ let moves = Move.gen_moves Move.cGRID_SIZE
+ rules (snd !state).Arena.struc loc in
try
for i = 0 to Array.length moves - 1 do
(* FIXME: handle time and params! *)
@@ -221,9 +227,10 @@
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
let moves =
Move.gen_moves Move.cGRID_SIZE rules
- (snd !state).Arena.struc graph.((snd !state).Arena.cur_loc) in
+ (snd !state).Arena.struc mv_loc in
let pos =
(try
for i = 0 to Array.length moves - 1 do
@@ -349,7 +356,8 @@
let do_play game state depth1 depth2 advr heur1 heur2 =
let cur_state = ref state in
while Array.length (Move.list_moves game !cur_state) > 0 do
- let pl = game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.player in
+ let pl = Aux.array_argfind (fun l -> l.Arena.moves <> [])
+ game.Arena.graph.(!cur_state.Arena.cur_loc) in
let depth = if pl = 0 then depth1 else if pl = 1 then depth2 else
failwith "only 2-player games supported in experiments for now" in
let timeo = if pl = 0 then !exp_p1_timeout else !exp_p2_timeout in
@@ -363,7 +371,8 @@
print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter));
Solver.eval_counter := 0;
done;
- let payoffs = game.Arena.graph.(!cur_state.Arena.cur_loc).Arena.payoffs in
+ 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
;;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-16 14:56:47
|
Revision: 1413
http://toss.svn.sourceforge.net/toss/?rev=1413&view=rev
Author: lukaszkaiser
Date: 2011-04-16 14:56:40 +0000 (Sat, 16 Apr 2011)
Log Message:
-----------
Marshaling computations to a parallel Toss client.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/GGP/Makefile
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-16 00:39:14 UTC (rev 1412)
+++ trunk/Toss/Formula/Aux.ml 2011-04-16 14:56:40 UTC (rev 1413)
@@ -589,3 +589,31 @@
done;
Buffer.add_channel buf file !msg_len;
Buffer.contents buf
+
+
+
+exception Host_not_found
+
+let get_inet_addr addr_s =
+ try
+ Unix.inet_addr_of_string addr_s
+ with Failure _ ->
+ try
+ let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
+ if Array.length addr_arr < 1 then raise Host_not_found else
+ 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
+
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-16 00:39:14 UTC (rev 1412)
+++ trunk/Toss/Formula/Aux.mli 2011-04-16 14:56:40 UTC (rev 1413)
@@ -288,3 +288,12 @@
(** Skip the header extracting the [Content-length] field and input the
content of an HTTP message. *)
val input_http_message : in_channel -> string
+
+(** Exception used in connections when the host is not found. *)
+exception Host_not_found
+
+(** 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]. *)
+val toss_call : int * string -> ('a -> 'b) -> 'a -> (unit -> 'b)
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-04-16 00:39:14 UTC (rev 1412)
+++ trunk/Toss/GGP/Makefile 2011-04-16 14:56:40 UTC (rev 1413)
@@ -17,13 +17,15 @@
%.black: examples/%.gdl ../TossServer
make -C ..
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -d 2 &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -p 8111 -d 2 &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -use-parallel 8111 localhost -d 2 &
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 1 -remote 2 toss localhost 8110 1 | grep results
killall -v TossServer
%.white: examples/%.gdl ../TossServer
make -C ..
- OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -d 2 &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -p 8111 -d 2 &
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ../TossServer -use-parallel 8111 localhost -d 2 &
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-04-16 00:39:14 UTC (rev 1412)
+++ trunk/Toss/Play/GameTree.ml 2011-04-16 14:56:40 UTC (rev 1413)
@@ -6,6 +6,18 @@
(* TODO; FIXME; THIS IS A STUB, TRUE CONCURRENCY SUPPORT NEEDED. *)
let moving_player = Aux.array_argfind (fun l -> l.Arena.moves <> [])
+let parallel_toss = ref (0, "localhost")
+
+let parallel_map f a =
+ if fst !parallel_toss = 0 then Array.map f a else
+ let l = Array.length a in
+ 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)
+ )
+
(* Abstract game tree, just stores state and move information. *)
type ('a, 'b) abstract_game_tree =
| Terminal of Arena.game_state * int * 'b (* terminal state with player *)
@@ -78,7 +90,7 @@
if timeout() then raise (Aux.Timeout "GameTree.unfold_abstract.term");
Terminal (state, player, info_terminal depth game state player info)
) else
- let leaf_of_move i leaf_s =
+ let leaf_of_move leaf_s =
if timeout() then (
Solver.M.clear_timeout();
raise (Aux.Timeout "GameTree.unfold_abstract.lm");
@@ -86,7 +98,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 = Array.mapi (fun i (m,s) -> (m,leaf_of_move i 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) ->
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-04-16 00:39:14 UTC (rev 1412)
+++ trunk/Toss/Play/GameTree.mli 2011-04-16 14:56:40 UTC (rev 1413)
@@ -2,6 +2,12 @@
val set_debug_level : int -> unit
+(** We can parallelize computation to a second running Toss client.
+ The second client must be running on the given port and server.
+ If the port is 0 (default) then we do not parallelize. *)
+val parallel_toss : (int * string) ref
+
+
(** {2 Abstract Game Trees} *)
(** Abstract game tree, just stores state and move information. *)
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-04-16 00:39:14 UTC (rev 1412)
+++ trunk/Toss/Server/Server.ml 2011-04-16 14:56:40 UTC (rev 1413)
@@ -30,25 +30,13 @@
(* -------------------- GENERAL SERVER AND REQUEST HANDLER ------------------ *)
-exception Host_not_found
-
-let get_inet_addr addr_s =
- try
- Unix.inet_addr_of_string addr_s
- with Failure _ ->
- try
- let addr_arr = (Unix.gethostbyname addr_s).Unix.h_addr_list in
- if Array.length addr_arr < 1 then raise Host_not_found else
- addr_arr.(0)
- with Not_found -> raise Host_not_found
-
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! *)
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 (get_inet_addr (addr_s), port));
+ Unix.bind sock (Unix.ADDR_INET (Aux.get_inet_addr (addr_s), port));
Unix.listen sock 99; (* maximally 99 pending requests *)
let timeout = ref (Unix.gettimeofday () +. float (!dtimeout)) in
while !dtimeout < 0 || Unix.gettimeofday () < !timeout do
@@ -73,6 +61,7 @@
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 () =
@@ -93,7 +82,10 @@
then
let msg = Aux.input_http_message in_ch in
if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" msg;
- "GDL " ^ 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? *)
@@ -101,17 +93,18 @@
String.concat "\n"
(Str.split (Str.regexp "\\$") line_in) in
if !debug_level > 0 then Printf.printf "Rcvd: %s\n%!" line;
- line
+ (line, None)
-let possibly_modifies_game = function
- | Arena.SetLoc i -> i <> !expected_location
- | r -> Arena.can_modify_game r
-
let req_handle in_ch out_ch =
try
let time_started = Unix.gettimeofday () in
- let line = read_in_line in_ch 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 = Marshal.to_channel out_ch (f x) [Marshal.Closures] in
+ flush out_ch;
+ ) else
let req = req_of_str line in
let (new_gheur, new_modified, new_state, resp, n_gdl_t, n_playclock) =
ReqHandler.req_handle !g_heur !game_modified !state !gdl_transl
@@ -253,6 +246,12 @@
let (server, port, load_gdl) = (ref "localhost", ref 8110, ref true) 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
+ let set_parallel_server s =
+ let (p, _) = !GameTree.parallel_toss in
+ GameTree.parallel_toss := (p, s) in
let opts = [
("-v", Arg.Unit (fun () -> set_debug_level 1), " make Toss server verbose");
("-vv", Arg.Unit (fun () -> set_debug_level 2), " make Toss server very verbose");
@@ -280,7 +279,10 @@
("-experiment",
Arg.Tuple [Arg.Int (fun i -> experiment := true; e_len := i);
Arg.Int (fun d1 -> e_d1 := d1); Arg.Int (fun d2 -> e_d2 := d2)],
- "run experiment on the open file [i] times with depth [d1, d2]")
+ "run experiment on the open file [i] times with depth [d1, d2]");
+ ("-use-parallel", Arg.Tuple [Arg.Int (fun p -> set_parallel_port p);
+ Arg.String (fun s -> set_parallel_server s)],
+ "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.";
let dir_from_path p =
@@ -311,7 +313,8 @@
DB.print_rows (DB.get_table "WebClient/tossdb.sqlite" !sqltest)
else try
start_server req_handle !port !server
- with Host_not_found -> print_endline "The host you specified was not found."
+ with Aux.Host_not_found ->
+ print_endline "The host you specified was not found."
;;
let _ =
@@ -321,7 +324,7 @@
(String.length p - String.rindex p '/' - 1) in
let test_fname =
let fname = file_from_path Sys.executable_name in
- Printf.printf "fname: %s\n%!" fname;
+ if !debug_level > 0 then Printf.printf "fname: %s\n%!" fname;
Str.string_match (Str.regexp ".*Test.*") fname 0
in
(* so that the server is not started by the test suite. *)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-16 21:05:28
|
Revision: 1414
http://toss.svn.sourceforge.net/toss/?rev=1414&view=rev
Author: lukaszkaiser
Date: 2011-04-16 21:05:20 +0000 (Sat, 16 Apr 2011)
Log Message:
-----------
Changing ArenaParser to handle concurrency, adapting files.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/examples/Breakthrough.toss
trunk/Toss/examples/Checkers.toss
trunk/Toss/examples/Chess.toss
trunk/Toss/examples/Connect4.toss
trunk/Toss/examples/Entanglement.toss
trunk/Toss/examples/Gomoku.toss
trunk/Toss/examples/Gomoku19x19.toss
trunk/Toss/examples/Pawn-Whopping.toss
trunk/Toss/examples/Tic-Tac-Toe.toss
trunk/Toss/examples/bounce.toss
trunk/Toss/examples/rewriting_example.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/Arena.ml 2011-04-16 21:05:20 UTC (rev 1414)
@@ -47,14 +47,16 @@
cur_loc : int ;
}
+let zero_loc = { payoff = Formula.Const 0. ;
+ view = (Formula.And [], []);
+ heur = [];
+ moves = [] }
+
let empty_state =
let emp_struc = Structure.empty_structure () in
- let zero = Formula.Const 0.0 in
{rules = [];
patterns = [];
- graph = Array.make 1
- (Array.make 1
- { payoff = zero; moves = []; view = (Formula.And [],[]); heur = [] });
+ graph = Array.make 1 (Array.make 1 zero_loc);
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
@@ -134,27 +136,19 @@
parameters_in = parameters_in;
}, target_loc
+
+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 make_location id loc_defs =
- let (pname, payoffs, moves) = List.fold_left
- (fun (pname, payoffs, moves) -> function
- | `PlayerName pn ->
- if pname = None then Some pn, payoffs, moves
- else raise (
- Arena_definition_error
- ("Location player redefined from " ^ Aux.unsome pname ^
- " to " ^ pn))
- | `Payoffs poffs -> pname, payoffs @ poffs, moves
- | `Moves mvs -> pname, payoffs, moves @ mvs
- ) (None, [], []) loc_defs in
- (* TODO: sanitize against redefinition in payoffs and equivalence of
- moves? *)
- let pname = match pname with None -> "1" | Some p -> p in
fun player_names ->
- let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
- heur = []; moves = [] } in
- let locs = List.map (fun (pl, poff) ->
- (pl, { payoff = poff ; view = (Formula.And [], []); heur = [];
- moves = if pl = pname then moves else [] })) payoffs in
+ let locs = List.map
+ (fun (pl, pl_loc_defs) -> (pl, make_player_loc pl_loc_defs)) loc_defs in
array_of_players zero_loc player_names locs
@@ -247,8 +241,6 @@
if old_locs = [] then old_locs
else
let more = num_players - Array.length (List.hd old_locs) in
- let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
- heur = []; moves = [] } in
let add_more loc = Array.append loc (Array.make more zero_loc) in
List.map add_more old_locs in
let add_def_rel loc =
@@ -299,27 +291,24 @@
(* Print a move as string. *)
let move_str (lb, i) = "["^ (label_str lb) ^" -> "^ (string_of_int i) ^"]"
-let fprint_loc_body_in struc pnames f player
- {payoff = payoff; moves = moves} =
- Format.fprintf f "@[<1>PLAYER@ %s@]@ "
- (Aux.rev_assoc pnames player);
- Format.fprintf f "@[<1>PAYOFF@ {@,@[<1>%a@]@,}@]@ "
- (Aux.fprint_sep_list ";" (fun f (p, ex) ->
- Format.fprintf f "@[<1>%s:@ %a@]" (Aux.rev_assoc pnames p)
- (Formula.fprint_real(* _nobra 0 *)) ex))
- (Array.to_list (Array.mapi (fun i l->i, l) [|payoff|]));
- Format.fprintf f "@[<1>MOVES@ %a@]"
- (Aux.fprint_sep_list ";" (fun f ({
- rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
- Format.fprintf f "[@,@[<1>%s" r;
- if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
- Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
- if params <> [] then
- Format.fprintf f ",@ %a"
- (Aux.fprint_sep_list "," (fun f (pn, (p_l, p_r)) ->
- Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
- Format.fprintf f "@ ->@ %d@]@,]" target)) moves
-
+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)
+ (fun f (payoff, moves) ->
+ Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
+ (Formula.fprint_real(* _nobra 0 *)) payoff;
+ if moves <> [] then
+ Format.fprintf f "@[<1>MOVES@ %a@]@ "
+ (Aux.fprint_sep_list ";" (fun f ({
+ rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
+ Format.fprintf f "[@,@[<1>%s" r;
+ if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
+ Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
+ if params <> [] then
+ Format.fprintf f ",@ %a"
+ (Aux.fprint_sep_list "," (fun f (pn, (p_l, p_r)) ->
+ Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
+ Format.fprintf f "@ ->@ %d@]@,]" target)) moves
+ ) (in_p, in_m)
let fprint_loc_body struc pnames f loc =
Array.iteri (fun p l -> fprint_loc_body_in struc pnames f p l) loc
@@ -362,7 +351,7 @@
Format.fprintf ppf "@[<1>RULE %s:@ %a@]@ " rname
(ContinuousRule.fprint_full print_compiled_rules) r) rules;
Array.iteri (fun loc_id loc ->
- Format.fprintf ppf "@[<1>LOC %d@ {@,@[<1>@,%a@]@,}@]@ "
+ Format.fprintf ppf "@[<0>LOC@ %d@ {@,@[<2> %a@]@]@,}@ "
loc_id (fprint_loc_body struc player_names) loc) graph;
Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
(Structure.fprint ~show_empty:true) struc;
@@ -392,8 +381,6 @@
let add_new_player (state_game, state) pname =
let player = state_game.num_players in
- let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
- heur = []; moves = [] } in
let add_more loc = Array.append loc [|zero_loc|] in
let game = {state_game with
num_players = state_game.num_players + 1;
@@ -766,8 +753,6 @@
| SetLoc (i) ->
let l = Array.length state_game.graph in
if i < 0 || i > l then (* make new location and set there *)
- let zero_loc = { payoff = Formula.Const 0. ; heur = []; moves = [] ;
- view = (Formula.And [], []); } in
let a = Array.make (Array.length state_game.graph.(0)) zero_loc in
(({state_game with graph = Array.append state_game.graph [|a|]},
{state with cur_loc = l }),
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/Arena.mli 2011-04-16 21:05:20 UTC (rev 1414)
@@ -109,10 +109,9 @@
val make_location :
int ->
- [< `Moves of (label * int) list
- | `Payoffs of (string * Formula.real_expr) list
- | `PlayerName of string ]
- list -> (string * int) list -> player_loc array
+ (string * [< `Moves of (label * int) list
+ | `Payoff of Formula.real_expr ] list) list ->
+ (string * int) list -> player_loc array
(** Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-04-16 21:05:20 UTC (rev 1414)
@@ -51,19 +51,18 @@
"Syntax error in formula expression."
}
-location_defs:
- | PLAYER_MOD pname = id_int { `PlayerName pname }
- | PAYOFF poffs =
- delimited(OPENCUR, separated_list (
- SEMICOLON, separated_pair (id_int, COLON, real_expr_wrapper)), CLOSECUR)
- { `Payoffs poffs }
- | MOVES moves = separated_list (SEMICOLON, move)
- { `Moves moves }
+player_loc_defs:
+ | PAYOFF poff = real_expr_wrapper { `Payoff poff }
+ | MOVES moves = separated_list (SEMICOLON, move) { `Moves moves }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in location field."
}
+location_defs:
+ | PLAYER_MOD pname = id_int OPENCUR defs = list (player_loc_defs) CLOSECUR
+ { (pname, defs) }
+
location:
| ident = INT OPENCUR loc_defs = list (location_defs) CLOSECUR
{ try
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/ArenaTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
@@ -59,11 +59,12 @@
REL Q(x) {ex y R(y, x)}
TIME 7.
LOC 0 {
- PLAYER white PAYOFF {white: :(ex x P(x)); black: 0.7}
- MOVES [RULE finish -> LOC 1]
+ PLAYER white { PAYOFF :(ex x P(x)) MOVES [RULE finish -> LOC 1] }
+ PLAYER black { PAYOFF 0.7 }
}
LOC 1 {
- PLAYER black PAYOFF {white: 0.3; black: :(ex x Q(x))}
+ PLAYER black { PAYOFF :(ex x Q(x)) }
+ PLAYER white { PAYOFF 0.3 }
}
STATE LOC 1" in
let res1 = "REL P(x) {ex y R(x, y)}
@@ -73,10 +74,12 @@
[a, b | R (a, b) | ] -> [a, c, b | R {(a, c); (c, b)} | ] emb R
with [a <- a, b <- b]
LOC 0 {
- PLAYER white PAYOFF {white: :(ex x ex y R(x, y)); black: 0.7}
- MOVES [finish -> 1]
- }
-LOC 1 {PLAYER black PAYOFF {white: 0.3; black: :(ex x ex y R(y, x))} MOVES }
+ PLAYER white { PAYOFF :(ex x ex y R(x, y)) MOVES [finish -> 1] }
+ PLAYER black { PAYOFF 0.7 }
+}
+LOC 1 {
+ PLAYER white { PAYOFF 0.3 } PLAYER black { PAYOFF :(ex x ex y R(y, x)) }
+}
MODEL [a, b | R (a, b) | ]
STATE LOC 1
TIME 7.
@@ -92,10 +95,12 @@
[a, b | R (a, b) | ] -> [a, c, b | R {(a, c); (c, b)} | ] emb R
with [a <- a, b <- b]
LOC 0 {
- PLAYER white PAYOFF {white: :(ex x ex y R(x, y)); black: 0.7}
- MOVES [finish -> 1]
- }
-LOC 1 {PLAYER black PAYOFF {white: 0.3; black: :(ex x ex y R(y, x))} MOVES }
+ PLAYER white { PAYOFF :(ex x ex y R(x, y)) MOVES [finish -> 1] }
+ PLAYER black { PAYOFF 0.7 }
+}
+LOC 1 {
+ PLAYER white { PAYOFF 0.3 } PLAYER black { PAYOFF :(ex x ex y R(y, x)) }
+}
MODEL [a, b | R (a, b) | ]
STATE LOC 1
TIME 7.
Modified: trunk/Toss/GGP/tests/breakthrough-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/breakthrough-simpl.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/GGP/tests/breakthrough-simpl.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -221,9 +221,8 @@
(cellholds_x2_y2_white(cellholds_x377_y369__blank_) and
not control_MV1(cellholds_x377_y369__blank_)))
LOC 0 {
- PLAYER white
- PAYOFF {
- white:
+ PLAYER white {
+ PAYOFF
100. *
:(
ex cellholds_x26_8__blank_
@@ -234,8 +233,13 @@
ex cellholds_x27_y26__blank_
(not control_MV1(cellholds_x27_y26__blank_) and
cellholds_x2_y2_black(cellholds_x27_y26__blank_))
- );
- black:
+ )
+ MOVES [move_x1_y1_x2_y2_0 -> 1]; [move_x1_y1_x2_y2_00 -> 1];
+ [move_x_y1_x_y2_0 -> 1]
+ }
+
+ PLAYER black {
+ PAYOFF
100. *
:(
ex cellholds_x30_1__blank_
@@ -248,25 +252,10 @@
cellholds_x2_y2_white(cellholds_x31_y28__blank_))
)
}
- MOVES [move_x1_y1_x2_y2_0 -> 1]; [move_x1_y1_x2_y2_00 -> 1]; [
- move_x_y1_x_y2_0 -> 1]
}
LOC 1 {
- PLAYER black
- PAYOFF {
- white:
- 100. *
- :(
- ex cellholds_x26_8__blank_
- (cellholds_x2_8_MV1(cellholds_x26_8__blank_) and
- cellholds_x2_y2_white(cellholds_x26_8__blank_) and
- not control_MV1(cellholds_x26_8__blank_)) or
- not
- ex cellholds_x27_y26__blank_
- (not control_MV1(cellholds_x27_y26__blank_) and
- cellholds_x2_y2_black(cellholds_x27_y26__blank_))
- );
- black:
+ PLAYER black {
+ PAYOFF
100. *
:(
ex cellholds_x30_1__blank_
@@ -278,9 +267,24 @@
(not control_MV1(cellholds_x31_y28__blank_) and
cellholds_x2_y2_white(cellholds_x31_y28__blank_))
)
+ MOVES [move_x1_y1_x2_y2_1 -> 0]; [move_x1_y1_x2_y2_10 -> 0];
+ [move_x_y1_x_y2_1 -> 0]
+ }
+
+ PLAYER white {
+ PAYOFF
+ 100. *
+ :(
+ ex cellholds_x26_8__blank_
+ (cellholds_x2_8_MV1(cellholds_x26_8__blank_) and
+ cellholds_x2_y2_white(cellholds_x26_8__blank_) and
+ not control_MV1(cellholds_x26_8__blank_)) or
+ not
+ ex cellholds_x27_y26__blank_
+ (not control_MV1(cellholds_x27_y26__blank_) and
+ cellholds_x2_y2_black(cellholds_x27_y26__blank_))
+ )
}
- MOVES [move_x1_y1_x2_y2_1 -> 0]; [move_x1_y1_x2_y2_10 -> 0]; [
- move_x_y1_x_y2_1 -> 0]
}
MODEL
[control_MV1, cellholds_8_8_MV1, cellholds_8_7_MV1, cellholds_8_6_MV1,
Modified: trunk/Toss/GGP/tests/connect5-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-simpl.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/GGP/tests/connect5-simpl.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -233,9 +233,8 @@
cell_x_y_o(cell_x181_y181__blank_)) and
ex cell_x182_y182__blank_ cell_x_y_b(cell_x182_y182__blank_))
LOC 0 {
- PLAYER x
- PAYOFF {
- x:
+ PLAYER x {
+ PAYOFF
50. +
-50. *
:(
@@ -329,8 +328,12 @@
cell_x_y_x(cell_x48_y48__blank_) and
cell_x_y_x(cell_x47_y47__blank_) and
cell_x_y_x(cell_x46_y46__blank_))
- );
- o:
+ )
+ MOVES [mark_x149_y149_0 -> 1]
+ }
+
+ PLAYER o {
+ PAYOFF
50. +
-50. *
:(
@@ -427,108 +430,11 @@
cell_x_y_o(cell_x47_y47__blank_) and
cell_x_y_o(cell_x46_y46__blank_))
)
- }
- MOVES [mark_x149_y149_0 -> 1]
+ }
}
LOC 1 {
- PLAYER o
- PAYOFF {
- x:
- 50. +
- -50. *
- :(
- ex cell_x51_e7__blank_, cell_x51_d7__blank_, cell_x51_c7__blank_,
- cell_x51_b7__blank_, cell_x51_a7__blank_
- (R(cell_x51_a7__blank_, cell_x51_b7__blank_) and
- R(cell_x51_b7__blank_, cell_x51_c7__blank_) and
- R(cell_x51_c7__blank_, cell_x51_d7__blank_) and
- R(cell_x51_d7__blank_, cell_x51_e7__blank_) and
- cell_x_y_o(cell_x51_a7__blank_) and
- cell_x_y_o(cell_x51_b7__blank_) and
- cell_x_y_o(cell_x51_c7__blank_) and
- cell_x_y_o(cell_x51_d7__blank_) and cell_x_y_o(cell_x51_e7__blank_)) or
- ex cell_e8_y51__blank_, cell_d8_y51__blank_, cell_c8_y51__blank_,
- cell_b8_y51__blank_, cell_a8_y51__blank_
- (R0(cell_a8_y51__blank_, cell_b8_y51__blank_) and
- R0(cell_b8_y51__blank_, cell_c8_y51__blank_) and
- R0(cell_c8_y51__blank_, cell_d8_y51__blank_) and
- R0(cell_d8_y51__blank_, cell_e8_y51__blank_) and
- cell_x_y_o(cell_a8_y51__blank_) and
- cell_x_y_o(cell_b8_y51__blank_) and
- cell_x_y_o(cell_c8_y51__blank_) and
- cell_x_y_o(cell_d8_y51__blank_) and
- cell_x_y_o(cell_e8_y51__blank_)) or
- ex cell_x56_y56__blank_, cell_x55_y55__blank_, cell_x54_y54__blank_,
- cell_x53_y53__blank_, cell_x52_y52__blank_
- (R1(cell_x53_y53__blank_, cell_x52_y52__blank_) and
- R1(cell_x54_y54__blank_, cell_x53_y53__blank_) and
- R1(cell_x55_y55__blank_, cell_x54_y54__blank_) and
- R1(cell_x56_y56__blank_, cell_x55_y55__blank_) and
- cell_x_y_o(cell_x56_y56__blank_) and
- cell_x_y_o(cell_x55_y55__blank_) and
- cell_x_y_o(cell_x54_y54__blank_) and
- cell_x_y_o(cell_x53_y53__blank_) and
- cell_x_y_o(cell_x52_y52__blank_)) or
- ex cell_x61_y61__blank_, cell_x60_y60__blank_, cell_x59_y59__blank_,
- cell_x58_y58__blank_, cell_x57_y57__blank_
- (R2(cell_x58_y58__blank_, cell_x57_y57__blank_) and
- R2(cell_x59_y59__blank_, cell_x58_y58__blank_) and
- R2(cell_x60_y60__blank_, cell_x59_y59__blank_) and
- R2(cell_x61_y61__blank_, cell_x60_y60__blank_) and
- cell_x_y_o(cell_x61_y61__blank_) and
- cell_x_y_o(cell_x60_y60__blank_) and
- cell_x_y_o(cell_x59_y59__blank_) and
- cell_x_y_o(cell_x58_y58__blank_) and
- cell_x_y_o(cell_x57_y57__blank_))
- )
- +
- 50. *
- :(
- ex cell_x40_e5__blank_, cell_x40_d5__blank_, cell_x40_c5__blank_,
- cell_x40_b5__blank_, cell_x40_a5__blank_
- (R(cell_x40_a5__blank_, cell_x40_b5__blank_) and
- R(cell_x40_b5__blank_, cell_x40_c5__blank_) and
- R(cell_x40_c5__blank_, cell_x40_d5__blank_) and
- R(cell_x40_d5__blank_, cell_x40_e5__blank_) and
- cell_x_y_x(cell_x40_a5__blank_) and
- cell_x_y_x(cell_x40_b5__blank_) and
- cell_x_y_x(cell_x40_c5__blank_) and
- cell_x_y_x(cell_x40_d5__blank_) and cell_x_y_x(cell_x40_e5__blank_)) or
- ex cell_e6_y40__blank_, cell_d6_y40__blank_, cell_c6_y40__blank_,
- cell_b6_y40__blank_, cell_a6_y40__blank_
- (R0(cell_a6_y40__blank_, cell_b6_y40__blank_) and
- R0(cell_b6_y40__blank_, cell_c6_y40__blank_) and
- R0(cell_c6_y40__blank_, cell_d6_y40__blank_) and
- R0(cell_d6_y40__blank_, cell_e6_y40__blank_) and
- cell_x_y_x(cell_a6_y40__blank_) and
- cell_x_y_x(cell_b6_y40__blank_) and
- cell_x_y_x(cell_c6_y40__blank_) and
- cell_x_y_x(cell_d6_y40__blank_) and
- cell_x_y_x(cell_e6_y40__blank_)) or
- ex cell_x45_y45__blank_, cell_x44_y44__blank_, cell_x43_y43__blank_,
- cell_x42_y42__blank_, cell_x41_y41__blank_
- (R1(cell_x42_y42__blank_, cell_x41_y41__blank_) and
- R1(cell_x43_y43__blank_, cell_x42_y42__blank_) and
- R1(cell_x44_y44__blank_, cell_x43_y43__blank_) and
- R1(cell_x45_y45__blank_, cell_x44_y44__blank_) and
- cell_x_y_x(cell_x45_y45__blank_) and
- cell_x_y_x(cell_x44_y44__blank_) and
- cell_x_y_x(cell_x43_y43__blank_) and
- cell_x_y_x(cell_x42_y42__blank_) and
- cell_x_y_x(cell_x41_y41__blank_)) or
- ex cell_x50_y50__blank_, cell_x49_y49__blank_, cell_x48_y48__blank_,
- cell_x47_y47__blank_, cell_x46_y46__blank_
- (R2(cell_x47_y47__blank_, cell_x46_y46__blank_) and
- R2(cell_x48_y48__blank_, cell_x47_y47__blank_) and
- R2(cell_x49_y49__blank_, cell_x48_y48__blank_) and
- R2(cell_x50_y50__blank_, cell_x49_y49__blank_) and
- cell_x_y_x(cell_x50_y50__blank_) and
- cell_x_y_x(cell_x49_y49__blank_) and
- cell_x_y_x(cell_x48_y48__blank_) and
- cell_x_y_x(cell_x47_y47__blank_) and
- cell_x_y_x(cell_x46_y46__blank_))
- );
- o:
+ PLAYER o {
+ PAYOFF
50. +
-50. *
:(
@@ -625,8 +531,106 @@
cell_x_y_o(cell_x47_y47__blank_) and
cell_x_y_o(cell_x46_y46__blank_))
)
+ MOVES [mark_x159_y159_1 -> 0]
}
- MOVES [mark_x159_y159_1 -> 0]
+
+ PLAYER x {
+ PAYOFF
+ 50. +
+ -50. *
+ :(
+ ex cell_x51_e7__blank_, cell_x51_d7__blank_, cell_x51_c7__blank_,
+ cell_x51_b7__blank_, cell_x51_a7__blank_
+ (R(cell_x51_a7__blank_, cell_x51_b7__blank_) and
+ R(cell_x51_b7__blank_, cell_x51_c7__blank_) and
+ R(cell_x51_c7__blank_, cell_x51_d7__blank_) and
+ R(cell_x51_d7__blank_, cell_x51_e7__blank_) and
+ cell_x_y_o(cell_x51_a7__blank_) and
+ cell_x_y_o(cell_x51_b7__blank_) and
+ cell_x_y_o(cell_x51_c7__blank_) and
+ cell_x_y_o(cell_x51_d7__blank_) and cell_x_y_o(cell_x51_e7__blank_)) or
+ ex cell_e8_y51__blank_, cell_d8_y51__blank_, cell_c8_y51__blank_,
+ cell_b8_y51__blank_, cell_a8_y51__blank_
+ (R0(cell_a8_y51__blank_, cell_b8_y51__blank_) and
+ R0(cell_b8_y51__blank_, cell_c8_y51__blank_) and
+ R0(cell_c8_y51__blank_, cell_d8_y51__blank_) and
+ R0(cell_d8_y51__blank_, cell_e8_y51__blank_) and
+ cell_x_y_o(cell_a8_y51__blank_) and
+ cell_x_y_o(cell_b8_y51__blank_) and
+ cell_x_y_o(cell_c8_y51__blank_) and
+ cell_x_y_o(cell_d8_y51__blank_) and
+ cell_x_y_o(cell_e8_y51__blank_)) or
+ ex cell_x56_y56__blank_, cell_x55_y55__blank_, cell_x54_y54__blank_,
+ cell_x53_y53__blank_, cell_x52_y52__blank_
+ (R1(cell_x53_y53__blank_, cell_x52_y52__blank_) and
+ R1(cell_x54_y54__blank_, cell_x53_y53__blank_) and
+ R1(cell_x55_y55__blank_, cell_x54_y54__blank_) and
+ R1(cell_x56_y56__blank_, cell_x55_y55__blank_) and
+ cell_x_y_o(cell_x56_y56__blank_) and
+ cell_x_y_o(cell_x55_y55__blank_) and
+ cell_x_y_o(cell_x54_y54__blank_) and
+ cell_x_y_o(cell_x53_y53__blank_) and
+ cell_x_y_o(cell_x52_y52__blank_)) or
+ ex cell_x61_y61__blank_, cell_x60_y60__blank_, cell_x59_y59__blank_,
+ cell_x58_y58__blank_, cell_x57_y57__blank_
+ (R2(cell_x58_y58__blank_, cell_x57_y57__blank_) and
+ R2(cell_x59_y59__blank_, cell_x58_y58__blank_) and
+ R2(cell_x60_y60__blank_, cell_x59_y59__blank_) and
+ R2(cell_x61_y61__blank_, cell_x60_y60__blank_) and
+ cell_x_y_o(cell_x61_y61__blank_) and
+ cell_x_y_o(cell_x60_y60__blank_) and
+ cell_x_y_o(cell_x59_y59__blank_) and
+ cell_x_y_o(cell_x58_y58__blank_) and
+ cell_x_y_o(cell_x57_y57__blank_))
+ )
+ +
+ 50. *
+ :(
+ ex cell_x40_e5__blank_, cell_x40_d5__blank_, cell_x40_c5__blank_,
+ cell_x40_b5__blank_, cell_x40_a5__blank_
+ (R(cell_x40_a5__blank_, cell_x40_b5__blank_) and
+ R(cell_x40_b5__blank_, cell_x40_c5__blank_) and
+ R(cell_x40_c5__blank_, cell_x40_d5__blank_) and
+ R(cell_x40_d5__blank_, cell_x40_e5__blank_) and
+ cell_x_y_x(cell_x40_a5__blank_) and
+ cell_x_y_x(cell_x40_b5__blank_) and
+ cell_x_y_x(cell_x40_c5__blank_) and
+ cell_x_y_x(cell_x40_d5__blank_) and cell_x_y_x(cell_x40_e5__blank_)) or
+ ex cell_e6_y40__blank_, cell_d6_y40__blank_, cell_c6_y40__blank_,
+ cell_b6_y40__blank_, cell_a6_y40__blank_
+ (R0(cell_a6_y40__blank_, cell_b6_y40__blank_) and
+ R0(cell_b6_y40__blank_, cell_c6_y40__blank_) and
+ R0(cell_c6_y40__blank_, cell_d6_y40__blank_) and
+ R0(cell_d6_y40__blank_, cell_e6_y40__blank_) and
+ cell_x_y_x(cell_a6_y40__blank_) and
+ cell_x_y_x(cell_b6_y40__blank_) and
+ cell_x_y_x(cell_c6_y40__blank_) and
+ cell_x_y_x(cell_d6_y40__blank_) and
+ cell_x_y_x(cell_e6_y40__blank_)) or
+ ex cell_x45_y45__blank_, cell_x44_y44__blank_, cell_x43_y43__blank_,
+ cell_x42_y42__blank_, cell_x41_y41__blank_
+ (R1(cell_x42_y42__blank_, cell_x41_y41__blank_) and
+ R1(cell_x43_y43__blank_, cell_x42_y42__blank_) and
+ R1(cell_x44_y44__blank_, cell_x43_y43__blank_) and
+ R1(cell_x45_y45__blank_, cell_x44_y44__blank_) and
+ cell_x_y_x(cell_x45_y45__blank_) and
+ cell_x_y_x(cell_x44_y44__blank_) and
+ cell_x_y_x(cell_x43_y43__blank_) and
+ cell_x_y_x(cell_x42_y42__blank_) and
+ cell_x_y_x(cell_x41_y41__blank_)) or
+ ex cell_x50_y50__blank_, cell_x49_y49__blank_, cell_x48_y48__blank_,
+ cell_x47_y47__blank_, cell_x46_y46__blank_
+ (R2(cell_x47_y47__blank_, cell_x46_y46__blank_) and
+ R2(cell_x48_y48__blank_, cell_x47_y47__blank_) and
+ R2(cell_x49_y49__blank_, cell_x48_y48__blank_) and
+ R2(cell_x50_y50__blank_, cell_x49_y49__blank_) and
+ cell_x_y_x(cell_x50_y50__blank_) and
+ cell_x_y_x(cell_x49_y49__blank_) and
+ cell_x_y_x(cell_x48_y48__blank_) and
+ cell_x_y_x(cell_x47_y47__blank_) and
+ cell_x_y_x(cell_x46_y46__blank_))
+ )
+ }
}
MODEL
[control_MV1, cell_h_h_MV1, cell_h_g_MV1, cell_h_f_MV1, cell_h_e_MV1,
Modified: trunk/Toss/examples/Breakthrough.toss
===================================================================
--- trunk/Toss/examples/Breakthrough.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Breakthrough.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -39,31 +39,30 @@
B
" emb W, B pre not ex x (W(x) and not ex y C(x, y))
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1:
- :(ex x (W(x) and not ex y C(x, y))) +
- -1. * :(ex x (B(x) and not ex y C(y, x)));
- 2:
- :(ex x (B(x) and not ex y C(y, x))) +
- -1. * :(ex x (W(x) and not ex y C(x, y)))
- }
- MOVES [WhiteDiag -> 1]; [WhiteStraight -> 1]
- }
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ MOVES
+ [WhiteDiag -> 1]; [WhiteStraight -> 1]
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ }
+}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1:
- :(ex x (W(x) and not ex y C(x, y))) +
- -1. * :(ex x (B(x) and not ex y C(y, x)));
- 2:
- :(ex x (B(x) and not ex y C(y, x))) +
- -1. * :(ex x (W(x) and not ex y C(x, y)))
- }
- MOVES [BlackDiag -> 0]; [BlackStraight -> 0]
- }
-MODEL [ | |
- ] "
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ MOVES
+ [BlackDiag -> 0]; [BlackStraight -> 0]
+ }
+}
+MODEL [ | | ] "
... ... ... ...
B B..B B..B B..B B..
... ... ... ...
Modified: trunk/Toss/examples/Checkers.toss
===================================================================
--- trunk/Toss/examples/Checkers.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Checkers.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -84,40 +84,47 @@
[ a, b, c | Bq { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
pre Diag2 (a, b, c)
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES
+ [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
+ [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
+ [RedBeatCont -> 2]
}
- MOVES [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
- [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
- [RedBeatCont -> 2]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
}
- MOVES [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
- [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
- [WhiteBeatCont -> 3]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
+ [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
+ [WhiteBeatCont -> 3]
+ }
}
LOC 2 {
- PLAYER 1
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
}
- MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
}
LOC 3 {
- PLAYER 2
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
}
- MOVES [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
+ }
}
MODEL [ | Wq:1 { }; Bq:1 { } |
] "
Modified: trunk/Toss/examples/Chess.toss
===================================================================
--- trunk/Toss/examples/Chess.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Chess.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -313,11 +313,8 @@
...bR bK.
" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) post true
LOC 0 { // both can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 1];
[WhitePawnMoveDbl -> 1];
@@ -336,12 +333,11 @@
[WhiteRightCastle -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 1 { // both can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 0];
[BlackPawnMoveDbl -> 0];
@@ -360,12 +356,11 @@
[BlackRightCastle -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 2 { // w left, b can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 3];
[WhitePawnMoveDbl -> 3];
@@ -383,12 +378,11 @@
[WhiteLeftCastle -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 3 { // w left, b can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 2];
[BlackPawnMoveDbl -> 2];
@@ -407,12 +401,11 @@
[BlackRightCastle -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 4 { // w right, b can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 5];
[WhitePawnMoveDbl -> 5];
@@ -430,12 +423,11 @@
[WhiteRightCastle -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 5 { // w right, b can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 4];
[BlackPawnMoveDbl -> 4];
@@ -454,12 +446,11 @@
[BlackRightCastle -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 6 { // w no, b can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 7];
[WhitePawnMoveDbl -> 7];
@@ -476,12 +467,11 @@
[WhiteQueen -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 7 { // w no, b can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 6];
[BlackPawnMoveDbl -> 6];
@@ -500,12 +490,11 @@
[BlackRightCastle -> 30];
[BlackKing -> 30]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 8 { // w can, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 9];
[WhitePawnMoveDbl -> 9];
@@ -524,12 +513,11 @@
[WhiteRightCastle -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 9 { // w can, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 8];
[BlackPawnMoveDbl -> 8];
@@ -547,12 +535,11 @@
[BlackLeftCastle -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 10 { // w left, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 11];
[WhitePawnMoveDbl -> 11];
@@ -570,12 +557,11 @@
[WhiteLeftCastle -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 11 { // w left, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 10];
[BlackPawnMoveDbl -> 10];
@@ -593,12 +579,11 @@
[BlackLeftCastle -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 12 { // w right, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 13];
[WhitePawnMoveDbl -> 13];
@@ -616,12 +601,11 @@
[WhiteRightCastle -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 13 { // w right, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 12];
[BlackPawnMoveDbl -> 12];
@@ -639,12 +623,11 @@
[BlackLeftCastle -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 14 { // w no, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 15];
[WhitePawnMoveDbl -> 15];
@@ -661,12 +644,11 @@
[WhiteQueen -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 15 { // w no, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 14];
[BlackPawnMoveDbl -> 14];
@@ -684,12 +666,11 @@
[BlackLeftCastle -> 30];
[BlackKing -> 30]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 16 { // w can, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 17];
[WhitePawnMoveDbl -> 17];
@@ -708,12 +689,11 @@
[WhiteRightCastle -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 17 { // w can, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 16];
[BlackPawnMoveDbl -> 16];
@@ -731,12 +711,11 @@
[BlackRightCastle -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 18 { // w left, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 19];
[WhitePawnMoveDbl -> 19];
@@ -754,12 +733,11 @@
[WhiteLeftCastle -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 19 { // w left, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 18];
[BlackPawnMoveDbl -> 18];
@@ -777,12 +755,11 @@
[BlackRightCastle -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 20 { // w right, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 21];
[WhitePawnMoveDbl -> 21];
@@ -800,12 +777,11 @@
[WhiteRightCastle -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 21 { // w right, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 20];
[BlackPawnMoveDbl -> 20];
@@ -823,12 +799,11 @@
[BlackRightCastle -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 22 { // w no, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 23];
[WhitePawnMoveDbl -> 23];
@@ -845,12 +820,11 @@
[WhiteQueen -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 23 { // w no, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 22];
[BlackPawnMoveDbl -> 22];
@@ -868,12 +842,11 @@
[BlackRightCastle -> 30];
[BlackKing -> 30]
}
- LOC 24 { // w can, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
+LOC 24 { // w can, b no castle
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 25];
[WhitePawnMoveDbl -> 25];
@@ -892,12 +865,11 @@
[WhiteRightCastle -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 25 { // w can, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 24];
[BlackPawnMoveDbl -> 24];
@@ -914,12 +886,11 @@
[BlackQueen -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 26 { // w left, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 27];
[WhitePawnMoveDbl -> 27];
@@ -937,12 +908,11 @@
[WhiteLeftCastle -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 27 { // w left, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 26];
[BlackPawnMoveDbl -> 26];
@@ -959,12 +929,11 @@
[BlackQueen -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 28 { // w right, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 29];
[WhitePawnMoveDbl -> 29];
@@ -982,12 +951,11 @@
[WhiteRightCastle -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 29 { // w right, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 28];
[BlackPawnMoveDbl -> 28];
@@ -1004,12 +972,11 @@
[BlackQueen -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 30 { // w no, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 31];
[WhitePawnMoveDbl -> 31];
@@ -1026,12 +993,11 @@
[WhiteQueen -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 31 { // w no, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 30];
[BlackPawnMoveDbl -> 30];
@@ -1048,8 +1014,9 @@
[BlackQueen -> 30];
[BlackKing -> 30]
}
-MODEL [ | |
- ] "
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
+MODEL [ | | ] "
... ... ... ...
bR bN.bB bQ.bK bB.bN bR.
... ... ... ...
Modified: trunk/Toss/examples/Connect4.toss
===================================================================
--- trunk/Toss/examples/Connect4.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Connect4.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -18,23 +18,24 @@
[a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P
pre not EmptyUnder (a) and not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
}
- MOVES [Cross -> 1]
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
}
- MOVES [Circle -> 0]
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
}
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+MODEL [ | P:1 {}; Q:1 {} | ] "
... ... ...
... ... ...
... ... ... ...
Modified: trunk/Toss/examples/Entanglement.toss
===================================================================
--- trunk/Toss/examples/Entanglement.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Entanglement.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -25,22 +25,17 @@
x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ]
emb R, C
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: 0.;
- 2: 0.
+ PLAYER 1 {
+ PAYOFF 0.
+ MOVES [Follow -> 1]; [Wait -> 1]
}
- MOVES
- [Follow -> 1];
- [Wait -> 1]
- }
+ PLAYER 2 { PAYOFF 0. }
+}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: 1.;
- 2: -1.
+ PLAYER 1 { PAYOFF 1. }
+ PLAYER 2 {
+ PAYOFF -1.
+ MOVES [Run -> 0]
}
- MOVES
- [Run -> 0]
}
MODEL [ d4, a2, a1, b1, b2, e4, c2, c1, f4, d2, d1, f1, f2, g1, g2, h1, h2, e1, e2, i1, i2 | C { (d4); (e4); (f4) }; E { (a2, a1); (a2, b2); (a1, a2); (a1, b1); (b1, a1); (b1, b2); (b1, c1); (b2, a2); (b2, b1); (b2, c2); (c2, b2); (c2, c1); (c2, d2); (c1, b1); (c1, c2); (c1, d1); (d2, c2); (d2, d1); (d2, e1); (d1, c1); (d1, d2); (d1, e2); (f1, f2); (f1, g1); (f1, e1); (f2, f1); (f2, g2); (f2, e2); (g1, f1); (g1, g2); (g1, h1); (g2, f2); (g2, g1); (g2, h2); (h1, g1); (h1, h2); (h1, i1); (h2, g2); (h2, h1); (h2, i2); (e1, d2); (e1, f1); (e1, e2); (e2, d1); (e2, f2); (e2, e1); (i1, h1); (i1, i2); (i2, h2); (i2, i1) }; R { (e1) }; _opt_C:1 { } | vx { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; vy { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; x { d4->100., a2->-50., a1->-50., b1->0., b2->0., e4->150., c2->50., c1->50., f4->200., d2->100., d1->100., f1->200., f2->200., g1->250., g2->250., h1->300., h2->300., e1->150., e2->150., i1->350., i2->350. }; y { d4->-150., a2->-100., a1->-50., b1->-50., b2->-100., e4->0., c2->-100., c1->-50., f4->-150., d2->-100., d1->-50., f1->-100., f2->-50., g1->-100., g2->-50., h1->-100., h2->-50., e1->-100., e2->-50., i1->-100., i2->-50. } ]
Modified: trunk/Toss/examples/Gomoku.toss
===================================================================
--- trunk/Toss/examples/Gomoku.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Gomoku.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -1,5 +1,5 @@
PLAYERS 1, 2
-DATA r1: circle, r2: line, adv_ratio: 5, depth: 2
+DATA rCircle: circle, rCross: line, adv_ratio: 5, depth: 2
REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w)
REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w)
REL DiagA5 (x, y, z, v, w) =
@@ -23,23 +23,20 @@
[a1 | P:1 {}; Q (a1) | - ]
emb Q, P pre not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
}
- MOVES [Cross -> 1]
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
}
- MOVES [Circle -> 0]
}
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+MODEL [ | P:1 {}; Q:1 {} | ] "
... ... ... ...
... ... ... ...
... ... ... ...
Modified: trunk/Toss/examples/Gomoku19x19.toss
===================================================================
--- trunk/Toss/examples/Gomoku19x19.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Gomoku19x19.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -1,158 +1,42 @@
PLAYERS 1, 2
-RULE 1:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] ->
- [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- emb Q, P
- pre
- not
- 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))))
-RULE 2:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] ->
- [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- emb Q, P
- pre
- not
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(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))))
+DATA rCircle: circle, rCross: line, adv_ratio: 5, depth: 2
+REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w)
+REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w)
+REL DiagA5 (x, y, z, v, w) =
+ DiagA(x, y) and DiagA(y, z) and DiagA(z, v) and DiagA(v, w)
+REL DiagB5 (x, y, z, v, w) =
+ DiagB(x, y) and DiagB(y, z) and DiagB(z, v) and DiagB(v, w)
+REL Conn5 (x, y, z, v, w) =
+ Row5(x,y,z,v,w) or Col5(x,y,z,v,w) or DiagA5(x,y,z,v,w) or DiagB5(x,y,z,v,w)
+REL WinQ() =
+ ex x,y,z,v,w (Q(x) and Q(y) and Q(z) and Q(v) and Q(w) and Conn5(x,y,z,v,w))
+REL WinP() =
+ ex x,y,z,v,w (P(x) and P(y) and P(z) and P(v) and P(w) and Conn5(x,y,z,v,w))
+RULE Cross:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P (a1); Q:1 {} | - ]
+ emb Q, P pre not WinQ()
+RULE Circle:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P:1 {}; Q (a1) | - ]
+ emb Q, P pre not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1:
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- );
- 2:
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- )
- }
- MOVES [1 -> 1]
- }
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
+ }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
+}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1:
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- );
- 2:
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) 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))))
- )
- }
- MOVES [2 -> 0]
- }
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] "
.......................................................
. . . . . . . . . . . . . . . . . . .
Modified: trunk/Toss/examples/Pawn-Whopping.toss
===================================================================
--- trunk/Toss/examples/Pawn-Whopping.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Pawn-Whopping.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -135,22 +135,22 @@
...?
" emb wP, bP pre not WhiteEnds()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WhiteEnds()) - :(BlackEnds());
- 2: :(BlackEnds()) - :(WhiteEnds())
+ PLAYER 1 {
+ PAYOFF :(WhiteEnds()) - :(BlackEnds())
+ MOVES
+ [WhiteBeat -> 1]; [WhiteMove -> 1]; [WhiteMoveTwo -> 1];
+ [WhiteRightPassant -> 1]; [WhiteLeftPassant -> 1]
}
- MOVES [WhiteBeat -> 1]; [WhiteMove -> 1]; [WhiteMoveTwo -> 1];
- [WhiteRightPassant -> 1]; [WhiteLeftPassant -> 1]
+ PLAYER 2 { PAYOFF :(BlackEnds()) - :(WhiteEnds()) }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WhiteEnds()) - :(BlackEnds());
- 2: :(BlackEnds()) - :(WhiteEnds())
+ PLAYER 1 { PAYOFF :(WhiteEnds()) - :(BlackEnds()) }
+ PLAYER 2 {
+ PAYOFF :(BlackEnds()) - :(WhiteEnds())
+ MOVES
+ [BlackBeat -> 0]; [BlackMove -> 0]; [BlackMoveTwo -> 0];
+ [BlackRightPassant -> 0]; [BlackLeftPassant -> 0]
}
- MOVES [BlackBeat -> 0]; [BlackMove -> 0]; [BlackMoveTwo -> 0];
- [BlackRightPassant -> 0]; [BlackLeftPassant -> 0]
}
MODEL [ | | ] "
... ... ... ...
Modified: trunk/Toss/examples/Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Tic-Tac-Toe.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Tic-Tac-Toe.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -15,23 +15,16 @@
RULE Circle:
[a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
- }
- MOVES [Cross -> 1]
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1] }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
- }
- MOVES [Circle -> 0]
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0] }
}
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+MODEL [ | P:1 {}; Q:1 {} | ] "
. . .
Modified: trunk/Toss/examples/bounce.toss
===================================================================
--- trunk/Toss/examples/bounce.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/bounce.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -18,13 +18,8 @@
(-1. * 0.)) + (-1. * 0.)) < 0)))
post true
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: 0.;
- 2: 0.
- }
- MOVES
- [Move, t: 3. -- 3. -> 0]
+ PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 0] }
+ PLAYER 2 { PAYOFF 0. }
}
MODEL [ 1, 2, 3 | G { (2, 3); (3, 2) } |
vx { 1->0., 2->0., 3->0. }; vy { 1->27., 2->0., 3->0. };
Modified: trunk/Toss/examples/rewriting_example.toss
===================================================================
--- trunk/Toss/examples/rewriting_example.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/rewriting_example.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -35,7 +35,10 @@
x(3) = 2. * x(2) - x(1);
x(2) = x(2);
x(1) = x(1)
-LOC 0 {PLAYER 1 PAYOFF {1: 0.; 2: 0.} MOVES [Rewrite, t: 1. -- 1. -> 0]}
+LOC 0 {
+ PLAYER 1 { PAYOFF 0. MOVES [Rewrite, t: 1. -- 1. -> 0] }
+ PLAYER 2 { PAYOFF 0. }
+}
MODEL
[1, 2, 3, 4, 5, 6, 7, 9, 10, 11 |
R (1, 2);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-17 01:25:25
|
Revision: 1415
http://toss.svn.sourceforge.net/toss/?rev=1415&view=rev
Author: lukaszkaiser
Date: 2011-04-17 01:25:17 +0000 (Sun, 17 Apr 2011)
Log Message:
-----------
Moving all remaining tests to OUnit, removing calls from Makefile and handling them in TossTest and TossFullTest.
Modified Paths:
--------------
trunk/Toss/Arena/Makefile
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/Makefile
trunk/Toss/GGP/Makefile
trunk/Toss/Makefile
trunk/Toss/Play/Makefile
trunk/Toss/Server/Makefile
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/Makefile
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Modified: trunk/Toss/Arena/Makefile
===================================================================
--- trunk/Toss/Arena/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Arena/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -9,7 +9,7 @@
ArenaTest:
tests:
- make -C .. Arena_tests
+ make -C .. ArenaTestsVerbose
.PHONY: clean
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/Aux.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -547,7 +547,8 @@
pr_tail f tl in
Format.fprintf f "%a%a" f_el hd pr_tail tl
-let run_test_if_target target_name tests =
+
+let run_if_target target_name f =
let file_from_path p =
String.sub p (String.rindex p '/'+1)
(String.length p - String.rindex p '/' - 1) in
@@ -555,10 +556,14 @@
let fname = file_from_path Sys.executable_name in
String.length fname >= String.length target_name &&
String.sub fname 0 (String.length target_name) = target_name in
+ if test_fname then f ()
+
+let run_test_if_target target_name tests =
+ let f () = ignore (OUnit.run_test_tt ~verbose:true tests) in
(* So that the tests are not run twice while building TossTest. *)
- if test_fname then
- ignore (OUnit.run_test_tt ~verbose:true tests)
+ run_if_target target_name f
+
let rec input_file file =
let buf = Buffer.create 256 in
(try
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/Aux.mli 2011-04-17 01:25:17 UTC (rev 1415)
@@ -279,6 +279,9 @@
string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a list -> unit
+(** Run a function if the executable name matches the given prefix. *)
+val run_if_target : string -> (unit -> unit) -> unit
+
(** Run a test suite if the executable name matches the given prefix. *)
val run_test_if_target : string -> OUnit.test -> unit
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -1,7 +1,8 @@
+open OUnit
open Formula
open BoolFormula;;
-BoolFormula.set_debug_level 2;;
+BoolFormula.set_debug_level 0;;
BoolFormula.set_simplification 6;; (* w/ resolution: 6; w/o resolution: 2 *)
BoolFormula.set_auxcnf 2;; (* Tseitin: 1 Plaisted-Greenbaum: 2 *)
@@ -13,135 +14,218 @@
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
;;
-let test_bool_simplify form_str =
+let flat_reduce_formula form_str =
let form = formula_of_string form_str in
- print_endline ("Testing simplification of " ^ (Formula.str form));
let b_form = BoolFormula.bool_formula_of_formula form in
- print_endline (" Boolean formula: " ^ (BoolFormula.str b_form));
- let b_simplified = BoolFormula.simplify b_form in
- print_endline (" Simplified formula: " ^ (BoolFormula.str b_simplified));
-;;
-
-let test_bool_auxcnf form_str =
- let form = formula_of_string form_str in
- print_endline ("Testing auxcnf conversion of " ^ (Formula.str form));
- let b_form = BoolFormula.bool_formula_of_formula form in
- print_endline (" Boolean formula: " ^ (BoolFormula.str b_form));
- let b_reduced = BoolFormula.to_reduced_form b_form in
- print_endline (" Boolean formula with or and not: " ^ (BoolFormula.str b_reduced));
- let (_, b_auxcnf) = BoolFormula.auxcnf_of_bool_formula b_reduced in
- print_endline (" Aux CNF for boolean formula:\n " ^ (BoolFormula.str b_auxcnf));
-;;
-
-let test_bool_pg_auxcnf form_str =
- let form = formula_of_string form_str in
- print_endline ("Testing Plaisted Greenbaum auxcnf conversion of " ^ (Formula.str form));
- let b_form = BoolFormula.bool_formula_of_formula form in
- print_endline (" Boolean formula: " ^ (BoolFormula.str b_form));
- let (_, b_auxcnf) = BoolFormula.pg_auxcnf_of_bool_formula b_form in
- print_endline (" Aux CNF for boolean formula:\n " ^ (BoolFormula.str b_auxcnf));
-;;
-
-let test_flat_reduce form_str =
- let form = formula_of_string form_str in
- let b_form = BoolFormula.bool_formula_of_formula form in
let b_nnf = BoolFormula.to_nnf b_form in
let b_flat = BoolFormula.flatten_sort b_nnf in
- let b_reduced = BoolFormula.to_reduced_form b_flat in
- print_endline ("Reduced flattened NNF of:\n " ^ (BoolFormula.str b_form) ^ "\nis:");
- print_endline (" "^ (BoolFormula.str b_reduced) ^"\n");
-;;
+ BoolFormula.to_reduced_form b_flat
-let test name f print_f formula_str =
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
+let test_formula name f print_f formula_str res_str =
let formula = formula_of_string formula_str in
- print_endline (name ^ " of:\n " ^ (Formula.str formula) ^ "\nis:");
- print_endline (" "^ (print_f (f formula) ^"\n"));
-;;
+ assert_eq_string formula_str name res_str (print_f (f formula))
-let test_bool name f print_f formula_str =
- let formula = BoolFormula.bool_formula_of_formula (formula_of_string formula_str) in
- print_endline (name ^ " of:\n " ^ (BoolFormula.str formula) ^ "\nis:");
- print_endline (" "^ (print_f (f formula) ^"\n"));
-;;
+let test_bool_formula name f print_f formula_str res_str =
+ let formula = formula_of_string formula_str in
+ let bool_formula = BoolFormula.bool_formula_of_formula formula in
+ let arg_str = (BoolFormula.str bool_formula) ^ " from " ^ formula_str in
+ assert_eq_string arg_str name res_str (print_f (f bool_formula))
-let test_cnf_bool = test "CNF" BoolFormula.formula_to_cnf Formula.str ;;
-let test_nnf = test_bool "NNF" BoolFormula.to_nnf BoolFormula.str ;;
-let test_flatten = test_bool "Flatten-Sort" BoolFormula.flatten_sort BoolFormula.str ;;
-let test_reduce = test_bool "Reduced form" BoolFormula.to_reduced_form BoolFormula.str ;;
+let tests = "BoolFormula" >::: [
+ "basic auxcnf and cnf" >::
+ (fun () ->
+ let test_bool_auxcnf form_str b_form_s b_reduced_s b_auxcnf_s =
+ let eq_s = assert_eq_string form_str in
+ let form = formula_of_string form_str in
+ let b_form = BoolFormula.bool_formula_of_formula form in
+ eq_s "Boolean formula" b_form_s (BoolFormula.str b_form);
+ let b_reduced = BoolFormula.to_reduced_form b_form in
+ eq_s "Boolean formula with or and not"
+ b_reduced_s (BoolFormula.str b_reduced);
+ let (_, b_auxcnf) = BoolFormula.auxcnf_of_bool_formula b_reduced in
+ eq_s "Aux CNF for boolean formula"
+ b_auxcnf_s (BoolFormula.str b_auxcnf) in
+ let test_cnf_bool =
+ test_formula "CNF" BoolFormula.formula_to_cnf Formula.str in
-test_bool_auxcnf "P(x)" ;;
-test_cnf_bool "P(x)" ;;
+ test_bool_auxcnf "P(x)" "1" "1" "-1";
+ test_cnf_bool "P(x)" "P(x)";
-test_bool_auxcnf "not P(x)" ;;
-test_cnf_bool "not P(x)" ;;
+ test_bool_auxcnf "not P(x)" "-1" "-1" "1";
+ test_cnf_bool "not P(x)" "(not P(x))";
-test_bool_auxcnf "P(x) and (P(y) or P(z))" ;;
-test_cnf_bool "P(x) and (P(y) or P(z))" ;;
+ test_bool_auxcnf "P(x) and (P(y) or P(z))"
+ "((3 or 2) and 1)" "(not (-1 or (not (2 or 3))))"
+ ("(5 and (-4 or -1 or -5) and (5 or 4) and (5 or 1) and " ^
+ "(3 or 2 or -4) and (4 or -3) and (4 or -2))");
+ test_cnf_bool "P(x) and (P(y) or P(z))" "((P(z) or P(y)) and P(x))";
-test_bool_pg_auxcnf "P(x) and (P(y) or P(z))" ;;
-test_cnf_bool "P(x) and (P(y) or P(z))" ;;
-test_bool_pg_auxcnf "(P(x) and P(y)) or P(z)" ;;
-test_cnf_bool "(P(x) and P(y)) or P(z)" ;;
+ test_bool_auxcnf "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
+ "(((5 and 4) or -3) or (not (2 and 1)))"
+ "((-1 or -2) or (-3 or (not (-4 or -5))))"
+ ("(-9 and (7 or 8 or -9) and (9 or -7) and (9 or -8) and " ^
+ "(-2 or -1 or -8) and (8 or 2) and (8 or 1) and (-6 or -3 or -7)" ^
+ " 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))))");
+
+ 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)))"
+ ("(-5 and (-3 or -4 or -5) and (5 or 3) and (5 or 4) and " ^
+ "(-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)))";
+ );
-test_bool_pg_auxcnf "(not (not P(x) or not P(y))) or P(z)" ;;
-test_cnf_bool "(not (not P(x) or not P(y))) or P(z)" ;;
+ "Plaisted Greenbaum auxcnf and cnf" >::
+ (fun () ->
+ let test_bool_pg_auxcnf form_str b_form_s b_auxcnf_s =
+ let eq_s = assert_eq_string form_str in
+ let form = formula_of_string form_str in
+ let b_form = BoolFormula.bool_formula_of_formula form in
+ eq_s "Boolean formula" b_form_s (BoolFormula.str b_form);
+ let (_, b_auxcnf) = BoolFormula.pg_auxcnf_of_bool_formula b_form in
+ eq_s "PG Aux CNF for boolean formula"
+ b_auxcnf_s (BoolFormula.str b_auxcnf) in
+ let test_cnf_bool =
+ test_formula "CNF" BoolFormula.formula_to_cnf Formula.str in
+ test_bool_pg_auxcnf "P(x) and (P(y) or P(z))" "((3 or 2) and 1)"
+ "(-5 and (-1 or -4 or 5) and (4 or -3) and (4 or -2))";
+ test_cnf_bool "P(x) and (P(y) or P(z))" "((P(z) or P(y)) and P(x))";
-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))" ;;
+ test_bool_pg_auxcnf "(P(x) and P(y)) or P(z)" "(3 or (2 and 1))"
+ "(-5 and (5 or -3) and (5 or -4) and (-1 or -2 or 4))";
+ test_cnf_bool "(P(x) and P(y)) or P(z)"
+ "((P(z) or P(y)) and (P(z) or P(x)))";
-let rec seq acc ?(start=0) stop =
- if stop < start then []
- else if stop = start then start :: acc
- else seq (stop :: acc) ~start:start (stop-1)
-;;
+ test_bool_pg_auxcnf "(not (not P(x) or not P(y))) or P(z)"
+ "(3 or (not (-2 or -1)))"
+ "(-5 and (5 or -3) and (5 or 4) and (-2 or -1 or -4))";
+ test_cnf_bool "(not (not P(x) or not P(y))) or P(z)"
+ "((P(z) or P(y)) and (P(z) or P(x)))";
+ );
-let varlist = seq [] ~start:0 5000 ;;
-let negvarlist = seq [] ~start:10000 15000 ;;
+ "nnf, flat, reduce, flat-reduce" >::
+ (fun () ->
+ let test_flat_reduce form_str b_reduced_s =
+ let eq_s = assert_eq_string form_str in
+ let b_reduced = flat_reduce_formula form_str in
+ eq_s "Reduced flattened NNF" b_reduced_s (BoolFormula.str b_reduced) in
+ let test_nnf =
+ test_bool_formula "NNF" BoolFormula.to_nnf BoolFormula.str in
+ let test_flatten = test_bool_formula "Flatten-Sort"
+ BoolFormula.flatten_sort BoolFormula.str in
+ let test_reduce = test_bool_formula "Reduced form"
+ BoolFormula.to_reduced_form BoolFormula.str in
-let long_formula = String.concat " or " (List.map (fun i -> "(Q(x) and P(x" ^ string_of_int i ^ "))") varlist) ;;
-let neg_long_formula = String.concat " or " (List.map (fun i -> "(not Q(x) and P(x" ^ string_of_int i ^ "))") negvarlist) ;;
-(*
-test_cnf_bool (long_formula ^ " or " ^ neg_long_formula) ;;
-*)
+ test_nnf "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "((4 or 3) or (-2 or (-1 or -1)))";
+ test_flatten "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(3 or 4 or (not (1 and 1 and 2)))";
+ test_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(((-1 or -1) or -2) or (3 or 4))";
+ test_flat_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(4 or 3 or -2 or -1 or -1)";
+ );
-(*
-test_bool_auxcnf "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))" ;;
-test_cnf_bool "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))" ;;
+ "cnf, flat-reduced cnf-list" >::
+ (fun () ->
+ let test_flat_reduced_cnf_list form_str cnf_list_s =
+ let eq_s = assert_eq_string form_str in
+ let b_reduced = flat_reduce_formula form_str in
+ let cnflist = BoolFormula.convert b_reduced in
+ let print_ors l = String.concat " | " (List.map string_of_int l) in
+ let print_cnf cnfl = String.concat " & " (List.map print_ors cnfl) in
+ eq_s "CNF-List" cnf_list_s (print_cnf cnflist) in
+ let test_cnf_bool =
+ test_formula "CNF" BoolFormula.formula_to_cnf Formula.str in
-test_bool_auxcnf "(P(x) and P(y)) or (not P(x) and not P(y))" ;;
-test_cnf_bool "(P(x) and P(y)) or (not P(x) and not P(y))" ;;
+ test_flat_reduced_cnf_list
+ "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)))";
-test_cnf_bool "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))))");
-test_nnf "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ test_flat_reduced_cnf_list
+ ("(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))")
+ "1 | 6 | 7 | 8 & -1 | 2 | 3 | 4 | 5";
+ 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))) " ^
+ "and (Q(c) or Q(b) or Q(a) or P(x)))");
+ );
-test_flatten "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ "simplification" >::
+ (fun () ->
+ let test_simplify form_str b_form_s b_simp_s =
+ let eq_s = assert_eq_string form_str in
+ let form = formula_of_string form_str in
+ let b_form = BoolFormula.bool_formula_of_formula form in
+ eq_s "Boolean formula" b_form_s (BoolFormula.str b_form);
+ let b_simplified = BoolFormula.simplify b_form in
+ eq_s "Simplified formula" b_simp_s (BoolFormula.str b_simplified) in
-test_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ test_simplify
+ "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z)) and (P(y) or Q(z))"
+ "(((4 or 3) and (4 or 3)) or (not (2 and (1 and 1))))"
+ "(-1 or -2 or (3 or 4))";
-test_flat_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ test_simplify ("(not P(x) or not Q(x) or P(y) or Q(z))" ^
+ " and (Q(y) or (P(y) and Q(z))) and Q(z)")
+ "(4 and (((4 and 3) or 5) and (4 or (3 or (-2 or -1)))))"
+ "(4 and (5 or 3))";
-let input_form = "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
-let input_form = "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))" ;;
-let form = formula_of_string input_form ;;
-let b_form = BoolFormula.bool_formula_of_formula form ;;
-let b_nnf = BoolFormula.to_nnf b_form ;;
-let b_flat = BoolFormula.flatten_sort b_nnf ;;
-let b_reduced = BoolFormula.to_reduced_form b_flat ;;
+ test_simplify
+ ("(not P(x) or not Q(x) or P(y)) and (not P(x) or Z(x))" ^
+ " and (P(x) or Z(x)) and (Q(x) or not Z(x)) and (Q(x) or P(x))")
+ ("((1 or 2) and ((-4 or 2) and ((4 or 1) and ((4 or -1) and " ^
+ "(3 or (-2 or -1))))))")
+ "(2 and 4 and (-1 or 3))"
+ );
-test_cnf_bool input_form ;;
+ "variable size cnf" >::
+ (fun () ->
+ let test_cnf_string f formula_str =
+ let formula = formula_of_string formula_str in
+ let cnf = BoolFormula.formula_to_cnf formula in
+ let cnf_str = Formula.str cnf in
+ assert_bool "CNF of a formula satisfied" (f cnf_str) in
+ let rec seq acc ?(start=0) stop =
+ if stop < start then [] else
+ if stop = start then start :: acc else
+ seq (stop :: acc) ~start:start (stop-1) in
+ let test_formula n =
+ let vl = seq [] ~start:0 n in
+ let negvl = seq [] ~start:(n + 100) (n + 100 + n) in
+ let long_formula = String.concat " or "
+ (List.map (fun i -> "(Q(x) and P(x" ^ string_of_int i ^ "))") vl) in
+ let neg_long_formula = String.concat " or "
+ (List.map (fun i -> "(not Q(x) and P(x" ^ string_of_int i ^ "))")
+ negvl) in
+ (long_formula ^ " or " ^ neg_long_formula) in
-let cnfllist = BoolFormula.convert b_reduced ;;
-print_endline ("CNF-List: " ^ String.concat " & " (List.map (fun list -> String.concat " | " (List.map string_of_int list)) cnfllist)) ;;
-*)
+ test_cnf_string (fun x -> String.length x > 9) (test_formula 200)
+ );
+]
-
-(*test_bool_simplify "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z)) and (P(y) or Q(z))" ;;*)
-
-(*test_bool_simplify "(not P(x) or not Q(x) or P(y) or Q(z)) and (Q(y) or (P(y) and Q(z))) and Q(z)" ;;*)
-
-BoolFormula.set_debug_level 3;;
-
-test_bool_simplify "(not P(x) or not Q(x) or P(y)) and (not P(x) or Z(x)) and (P(x) or Z(x)) and (Q(x) or not Z(x)) and (Q(x) or P(x))" ;;
+let exec = Aux.run_test_if_target "BoolFormulaTest" tests
Modified: trunk/Toss/Formula/Makefile
===================================================================
--- trunk/Toss/Formula/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -10,7 +10,7 @@
FFTNFTest:
tests:
- make -C .. Formula_tests
+ make -C .. FormulaTestsVerbose
.PHONY: clean
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/GGP/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -1,4 +1,4 @@
-all: tests
+all: tests_all
%Test:
make -C .. GGP/$@
@@ -29,8 +29,9 @@
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
-tests:
- make -C .. GGP_tests
+
+tests_all:
+ make -C .. GGPTestsVerbose
make tictactoe.white
make tictactoe.black
make breakthrough.white
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -92,61 +92,64 @@
%Test: %Test.native
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$<
+%TestVerbose: %Test.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -v
+
%TestDebug: %Test.d.byte
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$<
%TestProfile: %Test.p.native
_build/$<
gprof _build/$< > $@.log
-
+
+# All OUnit tests, aggregate
+TossTest:
+TossTestVerbose:
+TossFullTest:
+TossFullTestVerbose:
+
# Formula tests
-Formula_tests: \
- Formula/AuxTest \
- Formula/FormulaTest \
- Formula/BoolFormulaTest \
- Formula/FormulaOpsTest \
- Formula/FFTNFTest
+FormulaTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -formula
+FormulaTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -formula -v
# Solver tests
-Solver_tests: \
- Solver/StructureTest \
- Solver/AssignmentsTest \
- Solver/SolverTest \
- Solver/FFSolverTest \
- Solver/ClassTest \
- # Solver/Presb_test
+SolverTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -solver
+SolverTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -solver -v
# Arena tests
-Arena_tests: \
- Arena/TermTest \
- Arena/DiscreteRuleTest \
- Arena/ContinuousRuleTest \
- Arena/ArenaTest
+ArenaTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -arena
+ArenaTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -arena -v
# Play tests
-Play_tests: \
- Play/HeuristicTest \
- Play/MoveTest \
- Play/GameTreeTest \
- Play/PlayTest
+PlayTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -play
+PlayTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -play -v
# GGP tests
-GGP_tests: \
- GGP/GDLTest
+GGPTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -ggp
+GGPTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -ggp -v
# Server tests
-Server_tests: \
- Server/ServerTest
+ServerTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -server
+ServerTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -server -v
-# All tests, separate
-tests: Formula_tests Solver_tests Arena_tests Play_tests GGP_tests Server_tests
+# All tests
+tests: TossTest
+tests_all: TossFullTestVerbose
-# All OUnit tests, aggregate
-TossTest:
-TossFullTest:
-
# ------ CLEAN ------
.PHONY: clean
Modified: trunk/Toss/Play/Makefile
===================================================================
--- trunk/Toss/Play/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Play/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -25,7 +25,7 @@
PlayTestDebug:
tests:
- make -C .. Play_tests
+ make -C .. PlayTestsVerbose
.PHONY: clean
Modified: trunk/Toss/Server/Makefile
===================================================================
--- trunk/Toss/Server/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Server/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -16,7 +16,7 @@
ServerTestDebug:
tests:
- make -C .. Server_tests
+ make -C .. ServerTestsVerbose
.PHONY: clean
Modified: trunk/Toss/Solver/AssignmentsTest.ml
===================================================================
--- trunk/Toss/Solver/AssignmentsTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Solver/AssignmentsTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -1,3 +1,4 @@
+open OUnit
open Poly
open Structure
open AssignmentSet
@@ -3,22 +4,22 @@
open Assignments
-let test1 name f print_f aset =
- print_endline (name ^" of\n " ^ (str aset) ^ "\nis:");
- print_endline (" " ^ (print_f (f aset)) ^ "\n");
-;;
-let test2 name f print_f as1 as2 =
- print_endline (name ^" of\n " ^ (str as1) ^ "\nand\n "^ (str as2) ^"\nis:");
- print_endline (" " ^ (print_f (f as1 as2)) ^ "\n");
-;;
+(* ----------- Testing helper functions ----------- *)
-let test_join = test2 "Join" join str ;;
-let test_sum elems =
- test2 "Sum" (sum (ref (List (List.length elems, elems)))) str ;;
-let test_complement elems =
- test1 "Complement" (complement (ref (List (List.length elems, elems)))) str ;;
-let test_project elems v =
- test1 "Project" (project (ref (List (List.length elems, elems))) v) str ;;
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+let test1 name f print_f aset res_str =
+ let aset_str = str aset in
+ assert_eq_string aset_str name res_str (print_f (f aset))
+
+let test2 name f print_f as1 as2 res_str =
+ let (astr1, astr2) = (str as1, str as2) in
+ assert_eq_string (astr1 ^ " and " ^ astr2) name res_str (print_f (f as1 as2))
+
+let test_join = test2 "Join" join str
+
let test_join_tup elems_l (vns1, tps1) (vns2, tps2) =
let elems = ref (List (List.length elems_l, elems_l)) in
@@ -28,59 +29,117 @@
let as1 = assignments_of_list elems (Array.of_list vs1) tps1 in
let as2 = assignments_of_list elems (Array.of_list vs2) tps2 in
test_join as1 as2
-;;
-test_join_tup [1;2;3] (["x"], [[|1|]; [|2|]]) (["y"], [[|2|]; [|3|]]) ;;
+let test_sum elems =
+ test2 "Sum" (sum (ref (List (List.length elems, elems)))) str
-let full = (Elems.empty, Elems.empty) ;;
-let in1 = (Elems.add 1 Elems.empty, Elems.empty) ;;
-let out1 = (Elems.empty, Elems.add 1 Elems.empty) ;;
-let in2 = (Elems.add 2 Elems.empty, Elems.empty) ;;
-let out2 = (Elems.empty, Elems.add 2 Elems.empty) ;;
+let test_complement elems =
+ test1 "Complement" (complement (ref (List (List.length elems, elems)))) str
-test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)])) ;;
+let test_project elems v =
+ test1 "Project" (project (ref (List (List.length elems, elems))) v) str
-test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)])) ;;
+(* ------ Some constants used in tests ------ *)
+
+let full = (Elems.empty, Elems.empty)
+let in1 = (Elems.add 1 Elems.empty, Elems.empty)
+let out1 = (Elems.empty, Elems.add 1 Elems.empty)
+let in2 = (Elems.add 2 Elems.empty, Elems.empty)
+let out2 = (Elems.empty, Elems.add 2 Elems.empty)
+
(* x*z^2 + 2 *)
-let p0 = Plus (Times (Var "x", Times (Var "z", Var "z")), Const 2.) ;;
+let p0 = Plus (Times (Var "x", Times (Var "z", Var "z")), Const 2.)
+
(* x^2 + 3x + 2 *)
let p1 =
- Plus (Times (Var "x", Var "x"), Plus (Times (Const 3., Var "x"), Const 2.)) ;;
+ Plus (Times (Var "x", Var "x"), Plus (Times (Const 3., Var "x"), Const 2.))
-test_join (Real ([[p0,Formula.LZero]])) (Real ([[Var "x",Formula.GZero]]));;
-test_join (Real ([[p1,Formula.LZero]])) (Real ([[Var "x",Formula.LZero]]));;
+(* ---------- The Tests --------- *)
-test_join (Real ([[p0,Formula.LZero]; [Var "z", Formula.GEQZero]]))
- (Real ([[Var "x",Formula.GZero]; [Var "z", Formula.LEQZero]])) ;;
+let tests = "Assignments" >::: [
+ "join" >::
+ (fun () ->
+ test_join_tup [1;2;3] (["x"], [[|1|]; [|2|]]) (["y"], [[|2|]; [|3|]])
+ "{ y->2{ x->1, x->2 } , y->3{ x->1, x->2 } }";
-test_sum [1] (MSO (`MSO "X", [(full, Any)])) (MSO (`MSO "X", [(in1, Any)])) ;;
+ test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)]))
+ "{ X->(inc {1, 2} excl {}) }";
+
+ test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)]))
+ "{}";
-test_sum [1;2] (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)])) ;;
+ test_join (Real([[p0,Formula.LZero]])) (Real([[Var "x",Formula.GZero]]))
+ "{}";
-test_sum [1;2] (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)])) ;;
+ test_join (Real([[p1,Formula.LZero]])) (Real([[Var "x",Formula.LZero]]))
+ "{ ((x*x) + (((3.)*x) + (2.)) < 0 and x < 0) }";
-let inY1, outY1 = MSO (`MSO "Y", [(in1, Any)]), MSO (`MSO "Y", [(out1, Any)]) ;;
-test_sum [1;2] (MSO (`MSO "X", [(in1, inY1)])) (MSO (`MSO "X", [(in1, outY1)])) ;;
+ test_join (Real ([[p0,Formula.LZero]; [Var "z", Formula.GEQZero]]))
+ (Real ([[Var "x",Formula.GZero]; [Var "z", Formula.LEQZero]]))
+ ("{ (z >= 0 and x > 0) or (z >= 0 and z =< 0) or " ^
+ "((x*(z*z)) + (2.) < 0 and z =< 0) }");
+ );
-test_complement [1;2] (MSO (`MSO "X", [(in2, Any)])) ;;
+ "sum" >::
+ (fun () ->
+ test_sum [1]
+ (MSO (`MSO "X", [(full, Any)])) (MSO (`MSO "X", [(in1, Any)]))
+ "T";
-test_complement [1;2] (MSO (`MSO "X", [(in1, Any); (in2, Any)])) ;;
+ test_sum [1;2]
+ (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)]))
+ "{ X->(inc {1} excl {}), X->(inc {2} excl {}) }";
-test_complement [1;2]
- (MSO (`MSO "X", [(in1, MSO (`MSO "Y", [(in2, Any)]));
- (in2, Any)])) ;;
+ test_sum [1;2]
+ (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)]))
+ "T";
-test_complement [1;2] (Real [[(Var "x", Formula.LZero)]]) ;;
+ let inY1 = MSO (`MSO "Y", [(in1, Any)]) in
+ let outY1 = MSO (`MSO "Y", [(out1, Any)]) in
+ test_sum [1;2]
+ (MSO (`MSO "X", [(in1, inY1)])) (MSO (`MSO "X", [(in1, outY1)]))
+ "{ X->(inc {1} excl {}) }";
+ );
-test_complement [1;2] (Real [[(p0, Formula.GZero);(Var "z", Formula.LZero)];
- [(Var "x", Formula.LZero)]]) ;;
+ "complement" >::
+ (fun () ->
+ test_complement [1;2] (MSO (`MSO "X", [(in2, Any)]))
+ "{ X->(inc {} excl {2}) }";
-test_project [1;2] (`FO "x")
- (FO (`FO "x", [(1, FO (`FO "y", [1, Any])); (2, FO (`FO "y", [1, Any]))])) ;;
+ test_complement [1;2] (MSO (`MSO "X", [(in1, Any); (in2, Any)]))
+ "{ X->(inc {} excl {1, 2}) }";
-test_project [1;2] (`Real "z") (Real [[(p0, Formula.LZero)]]) ;;
+ test_complement [1;2]
+ (MSO (`MSO "X", [(in1, MSO (`MSO "Y", [(in2, Any)])); (in2, Any)]))
+ ("{ X->(inc {} excl {1, 2}), X->(inc {} excl {2})" ^
+ "{ Y->(inc {} excl {2}) } }");
-test_project [1;2] (`Real "x")
- (Real [[Var "x",Formula.LZero]; [p1,Formula.LZero]]) ;;
+ test_complement [1;2] (Real [[(Var "x", Formula.LZero)]])
+ "{ (x >= 0) }";
+
+ test_complement [1;2]
+ (Real [[(p0, Formula.GZero);(Var "z", Formula.LZero)];
+ [(Var "x", Formula.LZero)]])
+ "{ (x >= 0 and z >= 0) }";
+ );
+
+ "project" >::
+ (fun () ->
+ test_project [1;2] (`FO "x")
+ (FO (`FO "x", [(1, FO (`FO "y", [1, Any]));
+ (2, FO (`FO "y", [1, Any]))]))
+ "{ y->1 }";
+
+ test_project [1;2] (`Real "z") (Real [[(p0, Formula.LZero)]])
+ "{ (x < 0) }";
+
+ test_project [1;2] (`Real "x")
+ (Real [[Var "x",Formula.LZero]; [p1,Formula.LZero]])
+ "T";
+ );
+]
+
+
+let exec = Aux.run_test_if_target "AssignmentsTest" tests
Modified: trunk/Toss/Solver/Makefile
===================================================================
--- trunk/Toss/Solver/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Solver/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -11,7 +11,7 @@
PresbTest:
tests:
- make -C .. Solver_tests
+ make -C .. SolverTestsVerbose
.PHONY: clean
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/TossFullTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -32,5 +32,32 @@
server_tests;
]
-let a =
- Aux.run_test_if_target "TossFullTest" tests
+
+
+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 (run_tests, debug_level) = (ref tests, ref 0) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> debug_level := 1), " make tests verbose");
+ ("-vv", Arg.Unit (fun () -> debug_level := 2), " make tests very verbose");
+ ("-d", Arg.Int (fun i -> debug_level := i), " set tests debug level");
+ ("-formula", Arg.Unit (fun () -> run_tests := formula_tests),
+ "run only tests for the Formula directory");
+ ("-solver", Arg.Unit (fun () -> run_tests := solver_tests),
+ "run only tests for the Solver directory");
+ ("-arena", Arg.Unit (fun () -> run_tests := arena_tests),
+ "run only tests for the Arena directory");
+ ("-play", Arg.Unit (fun () -> run_tests := play_tests),
+ "run only tests for the Play directory");
+ ("-ggp", Arg.Unit (fun () -> run_tests := ggp_tests),
+ "run only tests for the GGP directory");
+ ("-server", Arg.Unit (fun () -> run_tests := server_tests),
+ "run only tests for the Server directory");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ ignore (OUnit.run_test_tt ~verbose:(!debug_level > 0) !run_tests)
+
+let _ = Aux.run_if_target "TossFullTest" main
Modified: trunk/Toss/TossTest.ml
===================================================================
--- trunk/Toss/TossTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/TossTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -3,12 +3,14 @@
let formula_tests = "Formula" >::: [
AuxTest.tests;
FormulaTest.tests;
+ BoolFormulaTest.tests;
FormulaOpsTest.tests;
FFTNFTest.tests;
]
let solver_tests = "Solver" >::: [
StructureTest.tests;
+ AssignmentsTest.tests;
SolverTest.tests;
]
@@ -44,5 +46,32 @@
server_tests;
]
-let a =
- Aux.run_test_if_target "TossTest" tests
+
+
+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 (run_tests, debug_level) = (ref tests, ref 0) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> debug_level := 1), " make tests verbose");
+ ("-vv", Arg.Unit (fun () -> debug_level := 2), " make tests very verbose");
+ ("-d", Arg.Int (fun i -> debug_level := i), " set tests debug level");
+ ("-formula", Arg.Unit (fun () -> run_tests := formula_tests),
+ "run only tests for the Formula directory");
+ ("-solver", Arg.Unit (fun () -> run_tests := solver_tests),
+ "run only tests for the Solver directory");
+ ("-arena", Arg.Unit (fun () -> run_tests := arena_tests),
+ "run only tests for the Arena directory");
+ ("-play", Arg.Unit (fun () -> run_tests := play_tests),
+ "run only tests for the Play directory");
+ ("-ggp", Arg.Unit (fun () -> run_tests := ggp_tests),
+ "run only tests for the GGP directory");
+ ("-server", Arg.Unit (fun () -> run_tests := server_tests),
+ "run only tests for the Server directory");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ ignore (OUnit.run_test_tt ~verbose:(!debug_level > 0) !run_tests)
+
+let _ = Aux.run_if_target "TossTest" main
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-17 14:05:36
|
Revision: 1416
http://toss.svn.sourceforge.net/toss/?rev=1416&view=rev
Author: lukaszkaiser
Date: 2011-04-17 14:05:28 +0000 (Sun, 17 Apr 2011)
Log Message:
-----------
Moving Sat tests to OUnit and adding to TossTest, code style cleanups in BoolFormula.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/Sat/Makefile
trunk/Toss/Makefile
trunk/Toss/TossTest.ml
Added Paths:
-----------
trunk/Toss/Formula/Sat/SatTest.ml
Removed Paths:
-------------
trunk/Toss/Formula/Sat/Test.ml
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-17 01:25:17 UTC (rev 1415)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-17 14:05:28 UTC (rev 1416)
@@ -5,7 +5,7 @@
(* 0 : no generation is performed and to_cnf transforms a DNF
1 : use Tseitin to construct a CNF with auxiliary variables
- 2 : (default) use Plaisted-Greenbaum to construct a CNF with auxiliary variables *)
+ 2 : use Plaisted-Greenbaum to construct a CNF with auxiliary variables *)
let auxcnf_generation = ref 2
let set_auxcnf i = (auxcnf_generation := i)
@@ -32,7 +32,8 @@
(* ----------------------- BASIC TYPE CONVERSIONS -------------------------- *)
-let int_of_lit lit = match lit with BVar v -> v | _ -> failwith ("This is not a literal!")
+let int_of_lit lit =
+ match lit with BVar v -> v | _ -> failwith ("This is not a literal!")
let lit_of_int v = BVar v
@@ -112,12 +113,17 @@
(* Convert a Boolean combination into reduced form (over 'not' and 'or') *)
let rec to_reduced_form ?(neg=false) = function
BVar v -> if neg then BVar (-1 * v) else BVar v
- | BNot phi -> if neg then to_reduced_form ~neg:false phi else to_reduced_form ~neg:true phi
+ | BNot phi ->
+ if neg then to_reduced_form ~neg:false phi else
+ to_reduced_form ~neg:true phi
| BAnd [f] | BOr [f] -> to_reduced_form ~neg f
- | BOr (bflist) when neg -> BNot (BOr (List.rev_map (to_reduced_form ~neg:false) bflist))
+ | BOr (bflist) when neg ->
+ BNot (BOr (List.rev_map (to_reduced_form ~neg:false) bflist))
| BOr (bflist) -> BOr (List.rev_map (to_reduced_form ~neg:false) bflist)
- | BAnd (bflist) when neg -> BOr (List.rev_map (to_reduced_form ~neg:true) bflist)
- | BAnd (bflist) -> BNot (BOr (List.rev_map (to_reduced_form ~neg:true) bflist))
+ | BAnd (bflist) when neg ->
+ BOr (List.rev_map (to_reduced_form ~neg:true) bflist)
+ | BAnd (bflist) ->
+ BNot (BOr (List.rev_map (to_reduced_form ~neg:true) bflist))
(* Convert a Boolean formula to NNF and additionally negate if [neg] is set. *)
@@ -190,7 +196,8 @@
let id = Hashtbl.find ids phi in if pos then id else -1 * id
with Not_found ->
if !debug_level > 2 then
- print_endline ("Added " ^ (Formula.str phi) ^ " as " ^ (string_of_int !free_id));
+ print_endline ("Added " ^ (Formula.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) (Formula.Not phi);
@@ -199,10 +206,14 @@
let rec bool_formula ?(pos=true) = function
Formula.Not (phi) when pos -> bool_formula ~pos:false phi
| Formula.Not (phi) -> bool_formula ~pos:true phi
- | Formula.And (flist) when pos -> BAnd (List.rev_map (bool_formula ~pos:true) flist)
- | Formula.And (flist) -> BNot (BAnd (List.rev_map (bool_formula ~pos:true) flist))
- | Formula.Or (flist) when pos -> BOr (List.rev_map (bool_formula ~pos:true) flist)
- | Formula.Or (flist) -> BNot (BOr (List.rev_map (bool_formula ~pos:true) flist))
+ | Formula.And (flist) when pos ->
+ BAnd (List.rev_map (bool_formula ~pos:true) flist)
+ | Formula.And (flist) ->
+ BNot (BAnd (List.rev_map (bool_formula ~pos:true) flist))
+ | Formula.Or (flist) when pos ->
+ BOr (List.rev_map (bool_formula ~pos:true) flist)
+ | Formula.Or (flist) ->
+ BNot (BOr (List.rev_map (bool_formula ~pos:true) flist))
| phi -> BVar (get_id ~pos:pos phi) in
bool_formula phi
@@ -217,13 +228,17 @@
let rec formula ?(pos=true) = function
BNot (phi) when pos -> formula ~pos:false phi
| BNot (phi) -> formula ~pos:true phi
- | BAnd (flist) when pos -> Formula.And (List.rev_map (formula ~pos:true) flist)
- | BAnd (flist) -> Formula.Not (Formula.And (List.rev_map (formula ~pos:true) flist))
- | BOr (flist) when pos -> Formula.Or (List.rev_map (formula ~pos:true) flist)
- | BOr (flist) -> Formula.Not (Formula.Or (List.rev_map (formula ~pos:true) flist))
- | BVar id -> try
- (Hashtbl.find rev_ids id)
- with Not_found -> failwith ("Boolean combination contains a non-hashed literal!") in
+ | BAnd (flist) when pos ->
+ Formula.And (List.rev_map (formula ~pos:true) flist)
+ | BAnd (flist) ->
+ Formula.Not (Formula.And (List.rev_map (formula ~pos:true) flist))
+ | BOr (flist) when pos ->
+ Formula.Or (List.rev_map (formula ~pos:true) flist)
+ | BOr (flist) ->
+ Formula.Not (Formula.Or (List.rev_map (formula ~pos:true) flist))
+ | BVar id -> try (Hashtbl.find rev_ids id) with
+ Not_found ->
+ failwith ("Boolean combination contains a non-hashed literal!") in
formula phi
@@ -234,215 +249,257 @@
let is_literal = function BNot (BVar _) | BVar _ -> true | _ -> false in
let rec flatten phi =
match phi with
- BNot (BNot psi) -> psi
+ | BNot (BNot psi) -> psi
| BNot (BVar v) -> BVar (-v)
| BNot psi -> BNot (flatten psi)
| BOr (flist) ->
- if not (List.exists is_disjunction flist)
- then BOr (List.map flatten flist)
- else (BOr (List.flatten (List.map (fun psi -> match psi with
- BOr psis -> List.map flatten psis
- | _ -> [flatten psi] ) flist)))
+ if not (List.exists is_disjunction flist) then
+ BOr (List.map flatten flist)
+ else
+ (BOr (List.flatten (List.map
+ (function
+ | BOr psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
| BAnd (flist) ->
- if not (List.exists is_conjunction flist)
- then BAnd (List.map flatten flist)
- else (BAnd (List.flatten (List.map (fun psi -> match psi with
- BAnd psis -> List.map flatten psis
- | _ -> [flatten psi] ) flist)))
+ if not (List.exists is_conjunction flist) then
+ BAnd (List.map flatten flist)
+ else (BAnd (List.flatten (List.map
+ (function
+ | BAnd psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
| _ -> phi in
let rec neutral_absorbing = function
- BVar _ as lit -> lit
+ | BVar _ as lit -> lit
| BNot psi -> BNot (neutral_absorbing phi)
- | BOr psis -> let filtered = List.filter (fun psi -> psi <> BOr []) psis in
- if (List.exists (fun psi -> psi = BAnd []) filtered)
- then (BAnd []) else BOr (List.map neutral_absorbing filtered)
- | BAnd psis -> let filtered = List.filter (fun psi -> psi <> BAnd []) psis in
- if (List.exists (fun psi -> psi = BOr []) filtered)
- then (BOr []) else BAnd (List.map neutral_absorbing filtered) in
+ | BOr psis ->
+ let filtered = List.filter (fun psi -> psi <> BOr []) psis in
+ if (List.exists (fun psi -> psi = BAnd []) filtered) then (BAnd []) else
+ BOr (List.map neutral_absorbing filtered)
+ | BAnd psis ->
+ let filtered = List.filter (fun psi -> psi <> BAnd []) psis in
+ if (List.exists (fun psi -> psi = BOr []) filtered) then (BOr []) else
+ BAnd (List.map neutral_absorbing filtered) in
let rec singularise unsorted_phi =
let phi = sort unsorted_phi in (* this should be done more elegantly!!! *)
let rec neg_occurrence = function
- (* check whether a _sorted_ "uniqued" list contains a pair (phi,not phi)
- at the moment this only works for literals due to the implementation of compare! *)
- [] | [_] -> false
- | a :: b :: xs -> if (compare a b) = 0 then true else neg_occurrence (b :: xs) in
+ (* check whether a _sorted_ uniqued list contains a pair (phi,not phi)
+ for now only works for literals due to implementation of compare! *)
+ | [] | [_] -> false
+ | a :: b :: xs ->
+ if (compare a b) = 0 then true else neg_occurrence (b :: xs) in
match phi with
- BVar _ -> phi
+ | BVar _ -> phi
| BNot psi -> BNot (singularise psi)
- | BOr psis -> let unique_psis = Aux.unique (=) psis in
- let lits = List.filter is_literal unique_psis in
- if neg_occurrence lits then BAnd [] else BOr (List.map singularise unique_psis)
- | BAnd psis -> let unique_psis = Aux.unique (=) psis in
- let lits = List.filter is_literal unique_psis in
- if neg_occurrence lits then BOr [] else BAnd (List.map singularise unique_psis) in
+ | BOr psis ->
+ let unique_psis = Aux.unique (=) psis in
+ let lits = List.filter is_literal unique_psis in
+ if neg_occurrence lits then BAnd [] else
+ BOr (List.map singularise unique_psis)
+ | BAnd psis ->
+ let unique_psis = Aux.unique (=) psis in
+ let lits = List.filter is_literal unique_psis in
+ if neg_occurrence lits then BOr [] else
+ BAnd (List.map singularise unique_psis) in
let rec subsumption phi =
let subclause a b =
match (a,b) with
- (BOr psis, BOr thetas)
- | (BAnd psis, BAnd thetas) -> List.for_all (fun x -> List.exists (fun y -> y=x) thetas) psis
- | (_, _) -> false in
+ | (BOr psis, BOr thetas)
+ | (BAnd psis, BAnd thetas) ->
+ List.for_all (fun x -> List.exists (fun y -> y=x) thetas) psis
+ | (_, _) -> false in
let subformula psi theta =
match theta with
- BOr thetas
+ | BOr thetas
| BAnd thetas -> List.exists (fun theta -> theta = psi) thetas
- | _ -> false in
+ | _ -> false in
match phi with
- BVar _ | BNot _ -> phi
+ | BVar _ | BNot _ -> phi
| BAnd psis ->
- let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
- BAnd(non_disjnctns @ List.filter
- (fun theta ->
- (List.for_all (fun phi -> phi=theta or not (subformula phi theta)) non_disjnctns)
- & (List.for_all (fun phi -> phi=theta or not (subclause phi theta)) disjnctns))
- disjnctns)
+ let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
+ BAnd(non_disjnctns @ List.filter
+ (fun theta ->
+ (List.for_all (fun phi -> phi=theta or
+ not (subformula phi theta)) non_disjnctns)
+ & (List.for_all (fun phi -> phi=theta or
+ not (subclause phi theta)) disjnctns))
+ disjnctns)
| BOr psis ->
- let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
- BOr(non_conjnctns @ List.filter
+ let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
+ BOr(non_conjnctns @ List.filter
(fun theta ->
- (List.for_all (fun phi -> phi=theta or not (subformula phi theta)) non_conjnctns)
- & (List.for_all (fun phi -> phi=theta or not (subclause phi theta)) conjnctns))
+ (List.for_all (fun phi -> phi=theta or
+ not (subformula phi theta)) non_conjnctns)
+ & (List.for_all (fun phi -> phi=theta or
+ not (subclause phi theta)) conjnctns))
conjnctns) in
let unit_propagation phi =
(* beware that unit_propagation might introduce the subformula true,
- and hence should be followed by neutral_absorbing before starting the next fixed-point iteration *)
+ and hence should be followed by neutral_absorbing before
+ starting the next fixed-point iteration *)
match phi with
- BAnd phis ->
- let units = List.map (fun lit -> match lit with BVar v -> v | _ -> failwith ("not a literal!"))
- (List.filter is_literal phis) in
- let rec propagate units phi =
- match phi with
- BVar v -> if List.exists (fun unit -> v=unit) units then BAnd [] else phi
- | BNot psi -> BNot (propagate units psi)
- | BAnd psis -> BAnd (List.map (propagate units) psis)
- | BOr psis -> BOr (List.map (propagate units) psis) in
- BAnd ((List.map (fun v -> BVar v) units) @ (List.map (propagate units) phis))
+ | BAnd phis ->
+ let units = List.map
+ (function | BVar v -> v | _ -> failwith ("not a literal!"))
+ (List.filter is_literal phis) in
+ let rec propagate units phi =
+ match phi with
+ | BVar v ->
+ if List.exists (fun unit -> v=unit) units then BAnd [] else phi
+ | BNot psi -> BNot (propagate units psi)
+ | BAnd psis -> BAnd (List.map (propagate units) psis)
+ | BOr psis -> BOr (List.map (propagate units) psis) in
+ BAnd ((List.map (fun v -> BVar v) units) @
+ (List.map (propagate units) phis))
| _ -> phi in
let rec resolution phi =
match phi with
- BVar v -> phi
+ | BVar v -> phi
| BNot psi -> BNot (resolution psi)
| BOr psis ->
- let res_psis = List.map resolution psis in
- let neg_phi = to_nnf (BNot (BOr res_psis)) in
- let res_neg_phi = resolution neg_phi in
- to_nnf (BNot res_neg_phi)
+ let res_psis = List.map resolution psis in
+ let neg_phi = to_nnf (BNot (BOr res_psis)) in
+ let res_neg_phi = resolution neg_phi in
+ to_nnf (BNot res_neg_phi)
| BAnd psis ->
- let (clauses,non_clauses) = List.partition (fun psi -> is_disjunction psi or is_literal psi) psis in
- let resolvent cl1 cl2 =
- (* construct the resolvent of clauses cl1 and cl2 and tag it with the reserved literal 0 *)
- let rec split_clause (acc_lits, acc_rest) = function
- BVar v -> (v :: acc_lits, acc_rest)
- | BOr phis -> (match phis with
- [] -> (acc_lits, acc_rest)
- | psi :: psis -> if (is_literal psi)
- then split_clause ((int_of_lit psi)::acc_lits, acc_rest) (BOr psis)
- else split_clause (acc_lits, psi::acc_rest) (BOr psis)
- )
- | _ -> failwith ("this is not a clause feasible for resolution!") in
- let (cl1_lits,cl1_rest) = split_clause ([],[]) cl1 in
- let (cl2_lits,cl2_rest) = split_clause ([],[]) cl2 in
- let res_lits = (* obtain list of feasible pivot-literals *)
- List.filter (fun lit1 -> List.exists (fun lit2 -> lit2 = -lit1) cl2_lits) cl1_lits in
- if !debug_level > 3 then
- print_endline ("res_lits: " ^ String.concat ", " (List.map string_of_int res_lits));
- (* if there is more than one possible pivot-literal, the resulting clause will be
- equivalent to true, so we don't care *)
- if (List.length res_lits) <> 1 then BAnd []
- else (* construct a resolvent and mark it with the unused literal 0 *)
- let lit = List.nth res_lits 0 in (* construct the resolvent of cl1 and cl2 using pivot-literal lit *)
- BOr ((lit_of_int 0) :: (List.map lit_of_int (List.filter (fun lit1 -> lit1 <> lit) cl1_lits
- @ List.filter (fun lit2 -> lit2 <> -lit) cl2_lits))
- @ cl1_rest @ cl2_rest) in
- let res_clauses = ref [] in
- let subsumed = ref [] in
- (* Construct all possible resolvents, and check for each new resolvent whether it is
- subsumed by some existing clause.
- In fact, the following does not work: "If this is the case, we can remove the two initial
- clauses (i.e. add them to the list subsumed)."
+ let (clauses, non_clauses) = List.partition
+ (fun psi -> is_disjunction psi or is_literal psi) psis in
+ let resolvent cl1 cl2 =
+ (* construct the resolvent of clauses cl1 and cl2 and
+ tag it with the reserved literal 0 *)
+ let rec split_clause (acc_lits, acc_rest) = function
+ | BVar v -> (v :: acc_lits, acc_rest)
+ | BOr phis -> (match phis with
+ | [] -> (acc_lits, acc_rest)
+ | psi :: psis ->
+ if (is_literal psi) then
+ split_clause ((int_of_lit psi)::acc_lits, acc_rest)
+ (BOr psis)
+ else split_clause (acc_lits, psi::acc_rest) (BOr psis)
+ )
+ | _ -> failwith ("this is not a clause feasible for resolution!") in
+ let (cl1_lits,cl1_rest) = split_clause ([],[]) cl1 in
+ let (cl2_lits,cl2_rest) = split_clause ([],[]) cl2 in
+ let res_lits = (* obtain list of feasible pivot-literals *)
+ List.filter (fun lit1 ->
+ List.exists (fun lit2 -> lit2 = -lit1) cl2_lits) cl1_lits in
+ if !debug_level > 3 then
+ print_endline ("res_lits: " ^ String.concat ", "
+ (List.map string_of_int res_lits));
+ (* if there is more than one possible pivot-literal, the resulting
+ clause will be equivalent to true, so we don't care *)
+ if (List.length res_lits) <> 1 then BAnd []
+ else (* construct a resolvent and mark it with the unused literal 0 *)
+ let lit = List.nth res_lits 0 in
+ (* construct resolvent of cl1 and cl2 using pivot-literal lit *)
+ BOr ((lit_of_int 0) ::
+ (List.map lit_of_int
+ (List.filter (fun lit1 -> lit1 <> lit) cl1_lits
+ @ List.filter (fun lit2 -> lit2 <> -lit) cl2_lits))
+ @ cl1_rest @ cl2_rest) in
+ let res_clauses = ref [] in
+ let subsumed = ref [] in
+ (* Construct all possible resolvents and check each new resolvent
+ whether it is subsumed by some existing clause.
+ In fact, the following does not work: If this is the case we can
+ remove two initial clauses (ie add them to the list subsumed).
Instead, we discard the resolved but subsumed clause directly.
- *)
- List.iter (fun cl1 -> (List.iter
- (fun cl2 ->
- let cl_res = resolvent cl1 cl2 in
- let subclause a b = (* i.e. a \subseteq b *)
- match (a,b) with
- ((BVar v as lit), BOr thetas)
- | ((BVar v as lit), BAnd thetas) -> List.exists (fun y -> y=lit) thetas
- | (BOr psis, (BVar v as lit))
- | (BAnd psis, (BVar v as lit)) -> List.for_all (fun x -> x=lit) psis
- | (BOr psis, BOr thetas)
- | (BAnd psis, BAnd thetas) -> List.for_all (fun x -> List.exists
- (fun y -> y=x) thetas) psis
- | (_, _) -> false in
- if (List.exists (fun clause -> subclause clause cl_res) clauses)
- then (
- (* do nothing, since the resolvent is useless *)
- (*
- res_clauses := !res_clauses;
- subsumed := cl1 :: cl2 :: !subsumed;
- if !debug_level > 3 then (
- print_endline(" Subsumed clauses: " ^ str cl1 ^ " and " ^ str cl2);
- print_endline(" current resolvents: " ^ String.concat ", " (List.map str !res_clauses));
- print_endline(" current subsumed clauses: " ^ String.concat ", " (List.map str !subsumed))
- )*)
- )
- else
- res_clauses := cl_res :: !res_clauses;
- ) clauses)) clauses;
- if !debug_level > 2 then (
- print_endline("Resolvents: " ^ String.concat ", " (List.map str !res_clauses));
- print_endline("Subsumed clauses: " ^ String.concat ", " (List.map str !subsumed));
- print_endline("Reduced Resolvents: " ^ str (singularise (BAnd !res_clauses)));
- );
- let total = (List.filter (fun clause -> not (List.exists (fun sub -> clause=sub) !subsumed)) clauses)
- @ !res_clauses @ non_clauses in
- singularise (neutral_absorbing (BAnd total)) in
+ *)
+ List.iter (fun cl1 ->
+ (List.iter
+ (fun cl2 ->
+ let cl_res = resolvent cl1 cl2 in
+ let subclause a b = (* i.e. a \subseteq b *)
+ match (a,b) with
+ | ((BVar v as lit), BOr thetas)
+ | ((BVar v as lit), BAnd thetas) ->
+ List.exists (fun y -> y=lit) thetas
+ | (BOr psis, (BVar v as lit))
+ | (BAnd psis, (BVar v as lit)) ->
+ List.for_all (fun x -> x=lit) psis
+ | (BOr psis, BOr thetas)
+ | (BAnd psis, BAnd thetas) ->
+ List.for_all
+ (fun x -> List.exists (fun y -> y=x) thetas) psis
+ | (_, _) -> false in
+ if
+ (List.exists (fun clause -> subclause clause cl_res) clauses)
+ then ( (* do nothing, since the resolvent is useless *) ) else
+ res_clauses := cl_res :: !res_clauses;
+ ) clauses)) clauses;
+ if !debug_level > 2 then (
+ print_endline("Resolvents: " ^
+ String.concat ", " (List.map str !res_clauses));
+ print_endline("Subsumed clauses: " ^
+ String.concat ", " (List.map str !subsumed));
+ print_endline("Reduced Resolvents: " ^
+ str (singularise (BAnd !res_clauses)));
+ );
+ let total =
+ (List.filter
+ (fun clause ->
+ not (List.exists (fun sub -> clause=sub) !subsumed)) clauses)
+ @ !res_clauses @ non_clauses in
+ singularise (neutral_absorbing (BAnd total)) in
let choose_resolvents phi =
(* check the resolvents for "good" ones (at the moment these are clauses
that subsume clauses in the original formula) and discard the rest *)
let rec filter_by_subsumption = function
- BOr psis ->
- let filtered_psis = List.map filter_by_subsumption psis in
- let neg_phi = to_nnf (BNot (BOr filtered_psis)) in
- let filtered_neg_phi = filter_by_subsumption neg_phi in
- to_nnf (BNot filtered_neg_phi)
+ | BOr psis ->
+ let filtered_psis = List.map filter_by_subsumption psis in
+ let neg_phi = to_nnf (BNot (BOr filtered_psis)) in
+ let filtered_neg_phi = filter_by_subsumption neg_phi in
+ to_nnf (BNot filtered_neg_phi)
| BAnd psis ->
- let subclause a b = (* here, a is a resolvent, so we should not consider the literal 0! *)
- match (a,b) with
- ((BVar v as lit), BOr thetas)
- | ((BVar v as lit), BAnd thetas) -> List.exists (fun y -> y=lit) thetas
- | (BOr psis, (BVar v as lit))
- | (BAnd psis, (BVar v as lit)) -> List.for_all (fun x -> x=lit or x=(lit_of_int 0)) psis
- | (BOr psis, BOr thetas)
- | (BAnd psis, BAnd thetas) -> List.for_all (fun x -> x=(lit_of_int 0) or List.exists
- (fun y -> y=x) thetas) psis
- | (_, _) -> false in
- let (clauses,non_clauses) = List.partition (fun phi -> is_disjunction phi or is_literal phi) psis in
- let (resolvents,non_resolvents) = List.partition
- (fun clause ->
- (* actually these clauses do not necessarily contain only literals but maybe
- also more complex subformulas! *)
- let lits = (*print_endline("checking clause: " ^ str clause); *)
- match clause with
- BOr lits -> lits
- | BVar v as lit -> [lit]
- | _ -> failwith("[filter_by_subsumption] This is not a clause!") in
- (is_disjunction clause &&
+ let subclause a b =
+ (* here, a is a resolvent, so we should not consider the literal 0! *)
+ match (a,b) with
+ | ((BVar v as lit), BOr thetas)
+ | ((BVar v as lit), BAnd thetas) ->
+ List.exists (fun y -> y=lit) thetas
+ | (BOr psis, (BVar v as lit))
+ | (BAnd psis, (BVar v as lit)) ->
+ List.for_all (fun x -> x=lit or x=(lit_of_int 0)) psis
+ | (BOr psis, BOr thetas)
+ | (BAnd psis, BAnd thetas) ->
+ List.for_all
+ (fun x -> x=(lit_of_int 0) or List.exists (fun y-> y=x) thetas)
+ psis
+ | (_, _) -> false in
+ let (clauses, non_clauses) =
+ List.partition (fun phi -> is_disjunction phi or is_literal phi)
+ psis in
+ let (resolvents, non_resolvents) = List.partition
+ (fun clause ->
+ (* actually these clauses do not necessarily contain only
+ literals but maybe also more complex subformulas! *)
+ let lits = (*print_endline("checking clause: " ^ str clause); *)
+ match clause with
+ | BOr lits -> lits
+ | BVar v as lit -> [lit]
+ | _ ->
+ failwith("[filter_by_subsumption] This is not a clause!") in
+ (is_disjunction clause &&
List.exists (fun lit -> lit=(lit_of_int 0)) lits)) clauses in
- let useful_resolvents = List.filter
- (fun resolvent -> List.exists (fun phi -> subclause resolvent phi) non_resolvents) resolvents in
- if !debug_level > 2 then
- print_endline("Useful resolvents: " ^ String.concat ", " (List.map str useful_resolvents));
- let new_clauses = List.map (fun resolvent ->
- match resolvent with
- BOr lits -> BOr (List.filter (fun lit -> lit <> (lit_of_int 0)) lits)
- | _ -> failwith ("trying to remove literals from a non-clause!")
- ) useful_resolvents in
- BAnd (new_clauses @ non_resolvents @ (List.map filter_by_subsumption non_clauses))
+ let useful_resolvents = List.filter
+ (fun resolvent ->
+ List.exists (fun phi -> subclause resolvent phi) non_resolvents)
+ resolvents in
+ if !debug_level > 2 then
+ print_endline("Useful resolvents: " ^
+ String.concat ", " (List.map str useful_resolvents));
+ let new_clauses =
+ List.map (function
+ | BOr lits ->
+ BOr (List.filter (fun lit -> lit <> (lit_of_int 0)) lits)
+ | _ -> failwith ("trying to remove literals from a non-clause!")
+ ) useful_resolvents in
+ BAnd (new_clauses @ non_resolvents @
+ (List.map filter_by_subsumption non_clauses))
| BNot psi -> BNot (filter_by_subsumption psi)
- | BVar v as lit -> if (v=0) then failwith ("There should not be empty resolved clauses!") else lit in
- filter_by_subsumption phi
- in
+ | BVar v as lit ->
+ if v=0 then failwith "There should not be empty resolved clauses!" else
+ lit in
+ filter_by_subsumption phi in
let simplified =
let simp_resolution = fun phi ->
if ((!simplification lsr 2) land 1) > 0 then
@@ -450,27 +507,28 @@
else phi in
let simp_fun = fun phi ->
(simp_resolution
- (neutral_absorbing
- (unit_propagation
- (subsumption
- (singularise
- (neutral_absorbing
- (flatten
- (to_nnf phi)))))))) in
+ (neutral_absorbing
+ (unit_propagation
+ (subsumption
+ (singularise
+ (neutral_absorbing
+ (flatten
+ (to_nnf phi)))))))) in
let rec fp f x =
let y = f x in
- if y=x then x else fp f y in
- fp (fun phi -> (simp_fun phi)) phi in
- if !debug_level > 1 then
- print_endline ("Simplification:\nphi " ^ str phi ^ "\nwas simplified to " ^ str simplified);
- simplified
-
+ if y=x then x else fp f y in
+ fp (fun phi -> (simp_fun phi)) phi in
+ if !debug_level > 1 then
+ print_endline ("Simplification:\nphi " ^ str phi ^
+ "\nwas simplified to " ^ str simplified);
+ simplified
-(* Convert a reduced Boolean combination into a CNF with auxiliary variables (Tseitin) *)
+
+(* Convert reduced Boolean combination into CNF with aux variables (Tseitin) *)
let auxcnf_of_bool_formula phi =
let max_abs m lit = if lit < 0 then max m (-lit) else max m lit in
let rec get_max_lit m = function
- BVar v -> max_abs m v
+ | BVar v -> max_abs m v
| BNot phi -> get_max_lit m phi
| BAnd [] | BOr [] -> m
| BAnd (bflist) | BOr (bflist) -> List.fold_left get_max_lit m bflist in
@@ -478,14 +536,15 @@
let (clauses, free_idx) = (ref [], ref max_lit) in
let bv l = List.rev_map (fun i -> BVar i) l in
let rec index_formula = function
- BVar v -> v
+ | BVar v -> v
| BNot phi -> - (index_formula phi)
| BOr bflist ->
- let indlist = List.rev_map index_formula bflist in
- free_idx := !free_idx + 1;
- List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses) indlist;
- clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
- !free_idx
+ let indlist = List.rev_map index_formula bflist in
+ free_idx := !free_idx + 1;
+ List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses)
+ indlist;
+ clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
+ !free_idx
| _ -> failwith "auxcnf_to_bool_formula: converting non-reduced formula" in
let res_var = index_formula (to_reduced_form phi) in
(max_lit + 1, BAnd ((BOr [BVar (- res_var)]) :: !clauses))
@@ -496,7 +555,7 @@
let pg_auxcnf_of_bool_formula phi =
let max_abs m lit = if lit < 0 then max m (-lit) else max m lit in
let rec get_max_lit m = function
- BVar v -> max_abs m v
+ | BVar v -> max_abs m v
| BNot phi -> get_max_lit m phi
| BAnd [] | BOr [] -> m
| BAnd (bflist) | BOr (bflist) -> List.fold_left get_max_lit m bflist in
@@ -504,41 +563,46 @@
let (clauses, free_idx) = (ref [], ref max_lit) in
let bv l = List.rev_map (fun i -> BVar i) l in
let rec index_formula ?(neg=false) = function
- BVar v -> v
+ | BVar v -> v
| BNot phi -> - index_formula ~neg:(not neg) phi
| BOr bflist ->
- let indlist = List.rev_map (index_formula ~neg:neg) bflist in
- free_idx := !free_idx + 1;
- if neg then
- List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses) indlist
- else
- clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
- !free_idx
+ let indlist = List.rev_map (index_formula ~neg:neg) bflist in
+ free_idx := !free_idx + 1;
+ if neg then
+ List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses)
+ indlist
+ else
+ clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
+ !free_idx
| BAnd bflist ->
- let indlist = List.rev_map (index_formula ~neg:neg) bflist in
- free_idx := !free_idx + 1;
- if neg then
- clauses := BOr (bv (!free_idx :: (List.rev_map (fun i -> -i) indlist))) :: !clauses
- else
- List.iter (fun i -> clauses := (BOr (bv [i; (- !free_idx)])) :: !clauses) indlist;
- !free_idx in
+ let indlist = List.rev_map (index_formula ~neg:neg) bflist in
+ free_idx := !free_idx + 1;
+ if neg then
+ clauses :=
+ BOr (bv (!free_idx :: (List.rev_map (fun i -> -i) indlist))) ::
+ !clauses
+ else
+ List.iter
+ (fun i -> clauses := (BOr (bv [i; (- !free_idx)])) :: !clauses)
+ indlist;
+ !free_idx in
let res_var =
match phi with
- BNot psi -> - index_formula ~neg:false psi
+ | BNot psi -> - index_formula ~neg:false psi
| _ -> index_formula ~neg:true phi in
(max_lit + 1, BAnd ((BOr [BVar (- res_var)]) :: !clauses))
let listcnf_of_boolcnf phi =
let int_of_literal = function
- BVar v -> v
+ | BVar v -> v
| _ -> raise (FormulaError "Clauses must not contain non-literals!") in
let list_of_clause = function
- BVar v -> [v]
+ | BVar v -> [v]
| BOr (bflist) -> List.map int_of_literal bflist
| _ -> raise (FormulaError "This is not a clause!") in
match phi with
- BVar v -> [[v]]
+ | BVar v -> [[v]]
| BAnd (bflist) -> List.map list_of_clause bflist
| _ -> raise (FormulaError "This is not a CNF!")
@@ -550,16 +614,17 @@
let convert phi =
- (* input is a Boolean combination; output is a list of list of integers interpreted as a cnf *)
+ (* input is a Boolean combination; output is a list of list of integers
+ interpreted as a cnf *)
let (aux_separator, aux_cnf_formula) =
match !auxcnf_generation with
- 0 -> failwith ("this function must not be called without auxcnf-converion")
+ | 0 -> failwith "this function must not be called w/o auxcnf-converion"
| 1 -> (* use Tseitin conversion *)
- auxcnf_of_bool_formula (to_reduced_form (flatten_sort (to_nnf ~neg:false phi)))
+ auxcnf_of_bool_formula
+ (to_reduced_form (flatten_sort (to_nnf ~neg:false phi)))
| 2 -> (* or Plaisted-Greenbaum conversion *)
- pg_auxcnf_of_bool_formula (flatten_sort (to_nnf ~neg:false phi))
- | _ -> failwith ("undefined parameter value")
- in
+ pg_auxcnf_of_bool_formula (flatten_sort (to_nnf ~neg:false phi))
+ | _ -> failwith "undefined parameter value" in
if !debug_level > 0 then (
print_endline ("Separator is: " ^ string_of_int aux_separator);
print_endline ("Converting Aux-CNF: " ^ str aux_cnf_formula);
@@ -568,25 +633,31 @@
let cnf_llist = Sat.convert_aux_cnf aux_separator aux_cnf in
if !debug_level > 0 then
print_endline ("Converted CNF: " ^ (Sat.cnf_str cnf_llist));
- let simplified = if (!simplification land 1) > 0 then subsumption_filter cnf_llist else cnf_llist in
+ let simplified =
+ if (!simplification land 1) > 0 then
+ subsumption_filter cnf_llist
+ else cnf_llist in
if !debug_level > 1 then (
- if (!simplification land 1) > 0 then print_endline ("Subsumption turned on");
+ if (!simplification land 1) > 0 then
+ print_endline ("Subsumption turned on");
print_endline ("Simplified CNF: " ^ (Sat.cnf_str simplified))
);
- simplified
-
+ simplified
+
(* given a formula, convert to CNF. *)
let formula_to_cnf phi =
let (ids, rev_ids, free_id) = (Hashtbl.create 7, Hashtbl.create 7, ref 1) in
let boolean_phi = bool_formula_of_formula_arg phi (ids, rev_ids, free_id) in
let cnf_llist = convert boolean_phi in
- let bool_cnf = BAnd (List.map (fun literals -> BOr (List.map lit_of_int literals)) cnf_llist) in
- let simplified = if ((!simplification lsr 1) land 1) > 0 then simplify bool_cnf else bool_cnf in
- if !debug_level > 1 then (
- if ((!simplification lsr 1) land 1) > 0 then print_endline ("Simplification turned on");
-(* print_endline ("Simplified CNF: " ^ (Sat.cnf_str simplified))*)
- );
- let formula_cnf = formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
- formula_cnf
+ let bool_cnf =
+ BAnd (List.map (fun literals -> BOr (List.map lit_of_int literals))
+ cnf_llist) in
+ let simplified =
+ if ((!simplification lsr 1) land 1) > 0 then
+ simplify bool_cnf
+ else bool_cnf in
+ let formula_cnf =
+ formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
+ formula_cnf
Modified: trunk/Toss/Formula/Sat/Makefile
===================================================================
--- trunk/Toss/Formula/Sat/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
+++ trunk/Toss/Formula/Sat/Makefile 2011-04-17 14:05:28 UTC (rev 1416)
@@ -1,26 +1,8 @@
MINISATDIR = minisat
-# mode is communicated by top-level make
-#MODE=debug
-
-ifeq ($(MODE),debug)
- # The option -dtypes emits types, e.g. for emacs editing in Tuareg mode
- OCAML = ocamlc -g
-
all: SatSolver.o MiniSATWrap.o
-#all: Sat.cma qbf
-else
- # The option -dtypes emits types, e.g. for emacs editing in Tuareg mode
- OCAML = ocamlopt -g
-all: SatSolver.o MiniSATWrap.o
-#all: Sat.cmxa qbf
-
-endif
-
-
-
SatSolver.o: $(MINISATDIR)/Solver.C
if [ ! -e minisat/SatSolver.o ]; then \
g++ -O2 -fPIC -c -I $(MINISATDIR) $(MINISATDIR)/Solver.C -o SatSolver.o; \
@@ -33,65 +15,18 @@
mv MiniSATWrap.o minisat/; \
fi
-MiniSAT.cmi: MiniSAT.mli
- $(OCAML) -c MiniSAT.mli
+%Test:
+ make -C ../.. Formula/Sat/$@
-MiniSAT.cmx: MiniSAT.ml MiniSAT.cmi
- $(OCAML) -c MiniSAT.ml
+qbf: qbf.ml
+ make -C ../.. Formula/Sat/qbf.native
+ cp ../../qbf.native qbf
-MiniSAT.cmo: MiniSAT.ml MiniSAT.cmi
- $(OCAML) -c MiniSAT.ml
+tests: SatTest
+ ./SatTest
-IntSet.cmi: IntSet.mli
- $(OCAML) -c IntSet.mli
-IntSet.cmx: IntSet.ml IntSet.cmi
- $(OCAML) -c IntSet.ml
-
-IntSet.cmo: IntSet.ml IntSet.cmi
- $(OCAML) -c IntSet.ml
-
-Sat.cmi: Sat.mli
- $(OCAML) -c Sat.mli
-
-Sat.cmx: Sat.ml Sat.cmi MiniSAT.cmi IntSet.cmi
- $(OCAML) -c Sat.ml
-
-Sat.cmxa: Sat.cmx SatSolver.o MiniSATWrap.o MiniSAT.cmx IntSet.cmx
- $(OCAML) -a -cclib -lstdc++ SatSolver.o MiniSATWrap.o MiniSAT.cmx \
- IntSet.cmx Sat.cmx -o Sat.cmxa
-
-Sat.cmo: Sat.ml Sat.cmi MiniSAT.cmi IntSet.cmi
- $(OCAML) -c Sat.ml
-
-Sat.cma: Sat.cmo SatSolver.o MiniSATWrap.o MiniSAT.cmo IntSet.cmo
- $(OCAML) -a -cclib -lstdc++ -custom SatSolver.o MiniSATWrap.o MiniSAT.cmo \
- IntSet.cmo Sat.cmo -o Sat.cma
-
-ifeq ($(MODE),debug)
-qbf: qbf.ml Sat.cma
- $(OCAML) str.cma Sat.cma qbf.ml -o qbf
-
-Test: Test.ml Sat.cma
- $(OCAML) Sat.cma Test.ml -o Test
-
-tests: Test
- ./Test
-
-else
-qbf: qbf.ml Sat.cmxa
- $(OCAML) str.cmxa Sat.cmxa qbf.ml -o qbf
-
-Test: Test.ml Sat.cmxa
- $(OCAML) Sat.cmxa Test.ml -o Test
-
-tests: Test
- ./Test
-
-endif
-
-
clean:
- rm -f *.o *.cmo *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa Test qbf
- rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot Test_debug qbf
+ rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest qbf
+ rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot qbf
rm -f minisat/SatSolver.o minisat/MiniSATWrap.o
Copied: trunk/Toss/Formula/Sat/SatTest.ml (from rev 1415, trunk/Toss/Formula/Sat/Test.ml)
===================================================================
--- trunk/Toss/Formula/Sat/SatTest.ml (rev 0)
+++ trunk/Toss/Formula/Sat/SatTest.ml 2011-04-17 14:05:28 UTC (rev 1416)
@@ -0,0 +1,215 @@
+(* Simple MiniSAT cnf-dnf tests. *)
+open OUnit
+
+Sat.set_debug_level 0 ;;
+
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
+let test phi res_cnf =
+ assert_eq_string (Sat.dnf_str phi) "DNF to CNF conversion"
+ res_cnf (Sat.cnf_str (Sat.convert phi))
+
+let test_nbr_clauses nbr phi =
+ assert_eq_string (Sat.dnf_str phi) "Number of clauses in converted CNF"
+ (string_of_int nbr) (string_of_int (List.length (Sat.convert phi)))
+
+let rec list n = if n < 3 then [n] else n :: list (n-1)
+
+let tests = "Sat" >::: [
+ "basic dnf to cnf" >::
+ (fun () ->
+ test [[1; 2]; [3]] "(2 | 3) & (1 | 3)";
+ test [[1; 2]; [-1; -2]] "(-1 | 2) & (1 | -2)";
+ test [[1; 2; 3]] "(2) & (1) & (3)";
+ test [[1; -1]] "F";
+ test [[1]; [-1; 2]; [-2; 3]; [-3]] "T";
+ test [[1]; [-1; 2]; [-2; 3]; [-3; 4]] "(1 | 2 | 3 | 4)";
+ test [[1; 2]; [3; 4]] "(2 | 3) & (2 | 4) & (1 | 3) & (1 | 4)";
+ );
+
+ "conversion to cnf on larger classes" >::
+ (fun () ->
+ test_nbr_clauses 128
+ [[7]; [8]; [1; 2]; [3; 4]; [5; 6]; [9; 10]; [11;12]; [13;14]; [15;16]];
+
+ test_nbr_clauses 799 [[1]; list 800];
+
+ (* Nice multiply-out tests. *)
+ let p n = [-1 :: (list n); [1; -(n+1)]; [1; -(n+2)]; [-1;n+1; n+2]] in
+ test_nbr_clauses 59 (p 30);
+
+ let q n = [-1 :: (List.map (fun i -> (-i)) (list n));
+ [1; -(n+1)]; [1; -(n+2)]; [-1; n+1; n+2]] in
+ test_nbr_clauses 59 (q 30);
+ );
+
+ "examples from tnf calculations" >::
+ (fun () ->
+ (* A more complex example; all literals positive. *)
+ let t = [[1]; [33]; [2; 3]; [4; 5; 6; 7; 8; 9]; [10; 5; 6; 8; 9];
+ [11; 5; 6; 12; 8; 9]; [13; 5; 6; 12; 8]; [14; 5; 12; 7; 8];
+ [15; 5; 12; 8]; [16; 5; 6; 12; 8; 17]; [18; 5; 12; 8; 17];
+ [19; 5; 6; 12; 8]; [20; 5; 12; 8]; [21; 5; 6; 7; 8];
+ [22; 5; 6; 7]; [23; 5; 6; 12; 7; 8; 17];
+ [24; 5; 6; 12; 8; 17]; [25; 5; 6; 8; 9]; [26; 5; 6; 8];
+ [27; 5; 12; 7; 8; 9]; [21; 5; 12; 7; 8]; [22; 5; 7]; [28; 5];
+ [29; 5; 8; 9]; [28; 5; 9]; [15; 6; 12; 7; 8]; [30; 6; 7; 8];
+ [31; 6; 12; 9]; [32; 6; 9]; [30; 6; 8]; [34; 6; 12; 7; 8];
+ [35; 6; 12; 7]; [36; 6; 7; 8]; [37; 6; 8]; [38; 6; 7; 9];
+ [39; 6; 9]; [40; 12; 7; 8; 17]; [41; 12; 8; 17];
+ [42; 7; 8; 17]; [43; 7; 17]; [44; 5; 6; 12; 7; 8; 9];
+ [4; 5; 12; 7; 8; 9]; [45; 5; 6; 12; 7; 8; 17];
+ [46; 5; 12; 7; 8; 17]; [36; 5; 6; 12; 7; 8];
+ [47; 5; 12; 7; 8]; [48; 5; 6; 12; 8; 17]; [42; 5; 12; 8; 17];
+ [49; 5; 6; 8; 9; 17]; [50; 5; 8; 9; 17];
+ [51; 5; 6; 12; 8; 9]; [15; 5; 6; 12; 8]; [36; 5; 6; 7; 8; 17];
+ [47; 5; 7; 8; 17]; [37; 5; 6; 8; 17]; [30; 5; 8; 17];
+ [52; 5; 6; 7; 17]; [53; 5; 6; 17]; [38; 5; 6; 7; 17];
+ [54; 5; 7; 17]; [55; 5; 6; 8; 9; 17]; [10; 5; 8; 9; 17];
+ [48; 5; 6; 8; 9; 17]; [42; 5; 8; 9; 17];
+ [56; 5; 6; 12; 7; 8; 9]; [57; 5; 6; 12; 7; 8];
+ [58; 5; 6; 12; 9]; [59; 5; 6; 12]; [44; 5; 6; 7; 8; 9];
+ [55; 5; 6; 8; 9]; [60; 5; 12; 7; 8; 9]; [51; 5; 12; 8; 9];
+ [46; 5; 7; 8; 17]; [42; 5; 8; 17]; [61; 5; 7; 17];
+ [43; 5; 17]; [30; 5; 8]; [4; 5; 7; 8; 9]; [62; 5; 7; 9];
+ [47; 5; 7; 8]; [54; 5; 7]; [63; 5; 6; 12; 8; 9; 17];
+ [64; 5; 12; 8; 9; 17]; [65; 5; 6; 12; 7; 8];
+ [66; 5; 12; 7; 8]; [25; 5; 6; 7; 8; 9]; [26; 5; 6; 7; 8];
+ [27; 5; 6; 7; 8; 9]; [67; 5; 6; 7; 9]; [68; 5; 6; 8; 9];
+ [29; 5; 6; 8]; [65; 5; 6; 12; 7; 8; 17];
+ [19; 5; 6; 12; 8; 17]; [69; 5; 6; 7; 8; 9; 17];
+ [70; 5; 6; 7; 9; 17]; [71; 5; 6; 7; 8; 17]; [72; 5; 6; 7; 17];
+ [73; 5; 6; 7; 8]; [57; 5; 6; 7]; [74; 5; 7; 17]; [75; 5; 17];
+ [68; 5; 8; 9]; [76; 5; 9]; [77; 6; 12; 7; 9]; [62; 6; 7; 9];
+ [14; 6; 12; 7; 8]; [47; 6; 7; 8]; [78; 6; 12; 7; 8; 9];
+ [11; 6; 12; 8; 9]; [79; 6; 7; 8; 9; 17]; [80; 6; 8; 9; 17];
+ [54; 6; 7; 9]; [81; 6; 12; 7; 9; 17]; [79; 6; 7; 9; 17];
+ [36; 6; 12; 7; 8]; [38; 6; 12; 7]; [82; 6; 12; 9; 17];
+ [80; 6; 9; 17]; [83; 6; 12; 9]; [84; 6; 9]; [38; 6; 7];
+ [47; 12; 7; 8]; [30; 12; 8]; [54; 12; 7]; [46; 12; 7; 8; 17];
+ [42; 12; 8; 17]; [14; 12; 7; 8; 17]; [15; 12; 8; 17];
+ [62; 12; 7; 9]; [32; 12; 9]; [60; 12; 7; 8; 9];
+ [77; 12; 7; 9]; [51; 12; 8; 9]; [31; 12; 9]; [46; 7; 8; 17];
+ [61; 7; 17]; [10; 8; 9]; [30; 8]; [85; 9; 17]; [43; 17];
+ [32; 9]; [63; 5; 6; 12; 7; 8; 9; 17];
+ [64; 5; 12; 7; 8; 9; 17]; [16; 5; 6; 12; 7; 8; 17];
+ [18; 5; 12; 7; 8; 17]; [34; 5; 6; 12; 7; 8];
+ [86; 5; 6; 7; 9]; [84; 5; 6; 9]; [39; 5; 6; 17];
+ [45; 5; 6; 7; 8; 17]; [48; 5; 6; 8; 17];
+ [70; 5; 6; 12; 7; 9; 17]; [72; 5; 6; 12; 7; 17];
+ [70; 5; 6; 12; 7; 8; 9; 17]; [72; 5; 6; 12; 7; 8; 17];
+ [87; 5; 6; 12; 9; 17]; [88; 5; 6; 12; 17]; [89; 5; 6; 12; 9];
+ [90; 5; 6; 12]; [91; 5; 6; 12; 7; 9; 17];
+ [92; 5; 6; 12; 7; 17]; [93; 5; 12; 7; 8]; [94; 5; 12; 8];
+ [10; 5; 8; 9]; [32; 5; 9]; [71; 5; 6; 12; 7; 8; 17];
+ [95; 5; 12; 7; 8; 17]; [96; 5; 6; 12; 7; 8; 9];
+ [73; 5; 6; 12; 7; 8]; [97; 5; 12; 7; 8; 9];
+ [98; 5; 6; 12; 8; 9]; [99; 5; 12; 8; 9];
+ [100; 5; 12; 7; 8; 17]; [101; 5; 12; 8; 17];
+ [102; 5; 6; 7; 8; 9; 17]; [103; 5; 6; 7; 9; 17];
+ [95; 5; 6; 7; 8; 17]; [74; 5; 6; 7; 17]; [96; 5; 6; 7; 8; 9];
+ [56; 5; 6; 7; 9]; [95; 5; 7; 8; 17]; [18; 5; 8; 17];
+ [21; 5; 7; 8]; [29; 5; 8]; [38; 6; 7; 8; 9]; [39; 6; 8; 9];
+ [44; 6; 12; 7; 8; 9]; [55; 6; 12; 8; 9];
+ [104; 6; 12; 7; 8; 9; 17]; [105; 6; 12; 8; 9; 17];
+ [40; 6; 12; 7; 8; 17]; [46; 6; 7; 8; 17]; [35; 6; 12; 7; 9];
+ [106; 6; 12; 9]; [107; 6; 12; 7; 9; 17]; [108; 6; 7; 9; 17];
+ [109; 6; 12; 9; 17]; [85; 6; 9; 17]; [41; 6; 12; 8; 17];
+ [42; 6; 8; 17]; [110; 6; 12; 17]; [43; 6; 17]; [15; 6; 12; 8];
+ [111; 6; 12]; [112; 6; 12; 7; 8; 9]; [83; 6; 12; 8; 9];
+ [113; 6; 12; 7; 8; 9; 17]; [114; 6; 12; 8; 9; 17];
+ [86; 6; 7; 8; 9]; [84; 6; 8; 9]; [44; 6; 7; 8; 9];
+ [55; 6; 8; 9]; [13; 6; 12; 8]; [106; 6; 12]; [39; 6];
+ [112; 6; 12; 7; 9]; [86; 6; 7; 9]; [4; 12; 7; 8; 9];
+ [10; 12; 8; 9]; [14; 12; 7; 8]; [15; 12; 8]; [115; 12; 7];
+ [111; 12]; [116; 7; 8; 9; 17]; [108; 7; 9; 17]; [50; 8; 9; 17];
+ [42; 8; 17]; [117; 5; 6; 12; 7; 9]; [118; 5; 6; 12; 9];
+ [69; 5; 6; 12; 7; 8; 9; 17]; [102; 5; 12; 7; 8; 9; 17];
+ [104; 5; 6; 12; 7; 8; 17]; [40; 5; 12; 7; 8; 17];
+ [105; 5; 6; 12; 8; 17]; [41; 5; 12; 8; 17];
+ [119; 5; 6; 12; 7; 8; 9]; [36; 5; 6; 7; 8]; [37; 5; 6; 8];
+ [38; 5; 6; 7]; [39; 5; 6]; [79; 5; 6; 7; 9; 17];
+ [108; 5; 7; 9; 17]; [80; 5; 6; 9; 17]; [85; 5; 9; 17];
+ [120; 5; 6; 12; 8; 9; 17]; [121; 5; 6; 12; 8; 17];
+ [56; 5; 6; 12; 7; 9]; [57; 5; 6; 12; 7];
+ [120; 5; 6; 12; 9; 17]; [121; 5; 6; 12; 17];
+ [122; 5; 6; 12; 7; 9]; [123; 5; 6; 12; 7]; [93; 5; 12; 7];
+ [94; 5; 12]; [87; 5; 6; 9; 17]; [88; 5; 6; 17];
+ [63; 5; 6; 8; 9; 17]; [16; 5; 6; 8; 17];
+ [102; 5; 7; 8; 9; 17]; [64; 5; 8; 9; 17]; [103; 5; 7; 9; 17];
+ [124; 5; 9; 17]; [27; 5; 7; 8; 9]; [67; 5; 7; 9];
+ [125; 6; 12; 7; 8; 9; 17]; [49; 6; 12; 8; 9; 17];
+ [115; 6; 12; 7]; [54; 6; 7]; [34; 6; 12; 7; 8; 9];
+ [13; 6; 12; 8; 9]; [126; 6; 12; 7; 9; 17]; [127; 6; 12; 9; 17];
+ [81; 6; 12; 7; 8; 9; 17]; [82; 6; 12; 8; 9; 17];
+ [125; 6; 7; 8; 9; 17]; [49; 6; 8; 9; 17];
+ [104; 6; 12; 7; 8; 17]; [45; 6; 7; 8; 17]; [105; 6; 12; 8; 17];
+ [48; 6; 8; 17]; [127; 6; 12; 17]; [53; 6; 17];
+ [107; 12; 7; 9; 17]; [109; 12; 9; 17]; [128; 12; 7; 8; 9; 17];
+ [129; 12; 8; 9; 17]; [4; 7; 8; 9]; [62; 7; 9]; [47; 7; 8];
+ [54; 7]; [93; 5; 6; 12; 7]; [94; 5; 6; 12];
+ [25; 5; 6; 12; 8; 9]; [68; 5; 12; 8; 9]; [26; 5; 6; 12; 8];
+ [29; 5; 12; 8]; [130; 5; 6; 12; 7; 8; 9; 17];
+ [131; 5; 12; 7; 8; 9; 17]; [132; 5; 6; 12; 8; 9; 17];
+ [133; 5; 12; 8; 9; 17]; [125; 5; 6; 7; 8; 9; 17];
+ [116; 5; 7; 8; 9; 17]; [89; 5; 6; 12; 8; 9];
+ [90; 5; 6; 12; 8]; [117; 5; 12; 7; 9]; [118; 5; 12; 9];
+ [58; 5; 6; 9]; [59; 5; 6]; [53; 6; 9; 17]; [126; 6; 12; 7; 17];
+ [134; 12; 7; 17]; [110; 12; 17]; [135; 5; 12; 7; 17];
+ [136; 5; 12; 17]; [52; 6; 7; 17]; [137; 5; 12; 7; 9; 17];
+ [138; 5; 12; 9; 17] ] in
+ test_nbr_clauses 256 t;
+
+ (* Example from SL6 conversion *)
+ let s =
+ [[2; -1]; [-3];
+ [2; -1]; [-7; -6; -5; -4]; [-11; -10; -9; -4; -8]; [-12; -10; -9; -8];
+ [-13; -6; -5]; [-15; -6; -14; -5; -9; -4; -8]; [-16; -10; -8];
+ [-17; -14; -10; -8]; [-18; -10; -4; -8]; [-19; -14; -5; -9; -4; -8];
+ [-20; -14; -10; -5]; [-21; -6; -14; -10; -5;-8]; [-22;-6;-5;-9;-4;-8];
+ [-23; -6; -4]; [-24; -6; -14; -5; -4]; [-25; -14; -10; -9; -8];
+ [-26; -14; -5; -9; -8]; [-27; -10; -9; -4]; [-28; -6; -10; -4];
+ [-29; -6; -5; -9; -8]; [-30; -6; -14; -5; -9; -8]; [-31;-6;-5;-9;-4];
+ [-32; -10; -4]; [-33; -14; -10]; [-34;-6;-14;-9;-8]; [-35;-10;-5;-8];
+ [-36; -10; -5; -4]; [-37; -14; -10; -9; -4]; [-38; -5; -9; -4];
+ [-39; -6; -14; -5; -9]; [-40; -6; -14; -5]; [-41; -10; -5; -4; -8];
+ [-42; -6; -14; -5; -8]; [-43; -6; -14; -5;-4;-8]; [-44;-14;-9;-4;-8];
+ [-45; -6; -14; -10; -5; -4]; [-46; -6; -10; -9; -8]; [-47; -4];
+ [-48; -6; -9; -4]; [-49; -6; -10; -9; -4; -8]; [-50; -6; -9; -4; -8];
+ [-51; -6; -10; -5; -4]; [-52; -6; -10; -5; -8]; [-53; -14; -5; -9; -4];
+ [-54; -14; -5; -9]; [-55; -14; -5]; [-56; -14; -10; -5; -9; -8];
+ [-57; -6; -10; -5; -9; -8]; [-58;-14;-10;-9;-4;-8]; [-59;-6;-14;-4];
+ [-60; -6; -5; -8]; [-61; -14; -9; -8]; [-62;-14;-9;-4]; [-63;-9;-4];
+ [-64; -6; -5; -9]; [-65; -6; -4; -8]; [-66; -6; -10; -5; -4; -8];
+ [-67; -6; -14; -9]; [-68; -14; -9]; [-69; -14]; [-70;-6;-10;-9;-4];
+ [-71;-14;-5;-4]; [-72;-14;-10;-5;-8]; [-73;-6;-10;-5]; [-74;-6;-10];
+ [-75; -6; -5; -4; -8]; [-76;-5;-4;-8]; [-77;-5;-4]; [-78;-6;-10;-9];
+ [-79; -10; -9]; [-80; -10; -5]; [-81; -6; -10; -5; -9; -4; -8];
+ [-82; -14; -10; -4]; [-83; -14; -10; -5; -4; -8]; [-84; -6; -10; -8];
+ [-85; -6; -9; -8]; [-86; -6; -9]; [-87; -14; -4]; [-88;-14;-5;-4;-8];
+ [-89; -14; -4; -8]; [-90; -14; -5; -8]; [-91; -14; -10; -9];
+ [-92; -6; -14; -10; -9; -8]; [-93; -6; -14; -9; -4; -8]; [-94; -9];
+ [-95; -9; -8]; [-96; -5]; [-97;-14;-10;-5;-4]; [-98;-14;-10;-5;-9;-4];
+ [-99; -14; -8]; [-100; -6; -10; -5; -9; -4]; [-101; -6; -10; -5; -9];
+ [-102; -14; -10; -5; -9]; [-103; -10; -5; -9; -4]; [-104; -10; -5; -9];
+ [-105; -6; -14; -8]; [-106; -14; -10; -4; -8]; [-107;-6;-14;-10;-8];
+ [-108; -6; -14; -4; -8]; [-109;-6;-10;-4;-8]; [-110;-6;-14;-10;-4;-8];
+ [-111; -10; -5; -9; -8]; [-112; -5; -9]; [-113; -5; -9; -8];
+ [-114; -6; -14; -9; -4]; [-115;-6;-14;-10;-4]; [-116;-6;-14;-10;-9;-4];
+ [-117; -6; -14; -10; -9]; [-118; -6; -8]; [-119; -10]; [-120; -5; -8];
+ [-121; -6; -14; -5; -9; -4]; [-122; -6; -14; -10; -9; -4; -8];
+ [-123; -6; -14; -10; -5; -4; -8]; [-124; -6; -14; -10; -5; -9; -8];
+ [-125; -14; -10; -5; -9; -4; -8]; [-126; -10; -5; -9; -4; -8];
+ [-127; -5; -9; -4; -8]; [-128; -9; -4; -8]; [-129; -4; -8]; [-130;-8];
+ [-131]; [-132; -6]; [-133; -6; -14]; [-134; -6; -14; -10];
+ [-135; -6; -14; -10; -5]; [-136; -6; -14; -10; -5; -9];
+ [-137;-6;-14;-10;-5;-9;-4]; [-138;-6;-14;-10;-5;-9;-4;-8]; [-139] ] in
+ test_nbr_clauses 277 s;
+ );
+]
+
+
+let exec = Aux.run_test_if_target "SatTest" tests
Deleted: trunk/Toss/Formula/Sat/Test.ml
===================================================================
--- trunk/Toss/Formula/Sat/Test.ml 2011-04-17 01:25:17 UTC (rev 1415)
+++ trunk/Toss/Formula/Sat/Test.ml 2011-04-17 14:05:28 UTC (rev 1416)
@@ -1,203 +0,0 @@
-(* Simple MiniSAT cnf-dnf tests. *)
-
-let test phi =
- print_endline ("DNF: " ^ Sat.dnf_str phi);
- print_endline ("CNF: " ^ Sat.cnf_str (Sat.convert phi));
- print_endline ""
-;;
-
-Sat.set_debug_level 0 ;;
-
-test [[1; 2]; [3]];;
-
-test [[1; 2]; [-1; -2]];;
-
-test [[1; 2; 3]];;
-
-test [[1; -1]];;
-
-test [[1]; [-1; 2]; [-2; 3]; [-3]];;
-
-test [[1]; [-1; 2]; [-2; 3]; [-3; 4]];;
-
-test [[1; 2]; [3; 4]];;
-
-test [[7]; [8]; [1; 2]; [3; 4]; [5; 6]; [9; 10]; [11; 12]; [13; 14]; [15;16]];;
-
-let rec list n = if n < 3 then [n] else n :: list (n-1) ;;
-
-(* Nice multiply-out test. *)
-let p n = test [-1 :: (list n); [1; -(n+1)]; [1; -(n+2)]; [-1; n+1; n+2]] ;;
-p 30 ;;
-
-let q n = test [-1 :: (List.map (fun i -> (-i)) (list n));
- [1; -(n+1)]; [1; -(n+2)]; [-1; n+1; n+2]] ;;
-q 30 ;;
-
-test [[1]; list 800];;
-
-
-(* A more complex example from TNF calculations; all literals positive. *)
-let t () = test [[1]; [33]; [2; 3]; [4; 5; 6; 7; 8; 9]; [10; 5; 6; 8; 9];
- [11; 5; 6; 12; 8; 9]; [13; 5; 6; 12; 8]; [14; 5; 12; 7; 8];
- [15; 5; 12; 8]; [16; 5; 6; 12; 8; 17]; [18; 5; 12; 8; 17];
- [19; 5; 6; 12; 8]; [20; 5; 12; 8]; [21; 5; 6; 7; 8];
- [22; 5; 6; 7]; [23; 5; 6; 12; 7; 8; 17];
- [24; 5; 6; 12; 8; 17]; [25; 5; 6; 8; 9]; [26; 5; 6; 8];
- [27; 5; 12; 7; 8; 9]; [21; 5; 12; 7; 8]; [22; 5; 7]; [28; 5];
- [29; 5; 8; 9]; [28; 5; 9]; [15; 6; 12; 7; 8]; [30; 6; 7; 8];
- [31; 6; 12; 9]; [32; 6; 9]; [30; 6; 8]; [34; 6; 12; 7; 8];
- [35; 6; 12; 7]; [36; 6; 7; 8]; [37; 6; 8]; [38; 6; 7; 9];
- [39; 6; 9]; [40; 12; 7; 8; 17]; [41; 12; 8; 17];
- [42; 7; 8; 17]; [43; 7; 17]; [44; 5; 6; 12; 7; 8; 9];
- [4; 5; 12; 7; 8; 9]; [45; 5; 6; 12; 7; 8; 17];
- [46; 5; 12; 7; 8; 17]; [36; 5; 6; 12; 7; 8];
- [47; 5; 12; 7; 8]; [48; 5; 6; 12; 8; 17]; [42; 5; 12; 8; 17];
- [49; 5; 6; 8; 9; 17]; [50; 5; 8; 9; 17];
- [51; 5; 6; 12; 8; 9]; [15; 5; 6; 12; 8]; [36; 5; 6; 7; 8; 17];
- [47; 5; 7; 8; 17]; [37; 5; 6; 8; 17]; [30; 5; 8; 17];
- [52; 5; 6; 7; 17]; [53; 5; 6; 17]; [38; 5; 6; 7; 17];
- [54; 5; 7; 17]; [55; 5; 6; 8; 9; 17]; [10; 5; 8; 9; 17];
- [48; 5; 6; 8; 9; 17]; [42; 5; 8; 9; 17];
- [56; 5; 6; 12; 7; 8; 9]; [57; 5; 6; 12; 7; 8];
- [58; 5; 6; 12; 9]; [59; 5; 6; 12]; [44; 5; 6; 7; 8; 9];
- [55; 5; 6; 8; 9]; [60; 5; 12; 7; 8; 9]; [51; 5; 12; 8; 9];
- [46; 5; 7; 8; 17]; [42; 5; 8; 17]; [61; 5; 7; 17];
- [43; 5; 17]; [30; 5; 8]; [4; 5; 7; 8; 9]; [62; 5; 7; 9];
- [47; 5; 7; 8]; [54; 5; 7]; [63; 5; 6; 12; 8; 9; 17];
- [64; 5; 12; 8; 9; 17]; [65; 5; 6; 12; 7; 8];
- [66; 5; 12; 7; 8]; [25; 5; 6; 7; 8; 9]; [26; 5; 6; 7; 8];
- [27; 5; 6; 7; 8; 9]; [67; 5; 6; 7; 9]; [68; 5; 6; 8; 9];
- [29; 5; 6; 8]; [65; 5; 6; 12; 7; 8; 17];
- [19; 5; 6; 12; 8; 17]; [69; 5; 6; 7; 8; 9; 17];
- [70; 5; 6; 7; 9; 17]; [71; 5; 6; 7; 8; 17]; [72; 5; 6; 7; 17];
- [73; 5; 6; 7; 8]; [57; 5; 6; 7]; [74; 5; 7; 17]; [75; 5; 17];
- [68; 5; 8; 9]; [76; 5; 9]; [77; 6; 12; 7; 9]; [62; 6; 7; 9];
- [14; 6; 12; 7; 8]; [47; 6; 7; 8]; [78; 6; 12; 7; 8; 9];
- [11; 6; 12; 8; 9]; [79; 6; 7; 8; 9; 17]; [80; 6; 8; 9; 17];
- [54; 6; 7; 9]; [81; 6; 12; 7; 9; 17]; [79; 6; 7; 9; 17];
- [36; 6; 12; 7; 8]; [38; 6; 12; 7]; [82; 6; 12; 9; 17];
- [80; 6; 9; 17]; [83; 6; 12; 9]; [84; 6; 9]; [38; 6; 7];
- [47; 12; 7; 8]; [30; 12; 8]; [54; 12; 7]; [46; 12; 7; 8; 17];
- [42; 12; 8; 17]; [14; 12; 7; 8; 17]; [15; 12; 8; 17];
- [62; 12; 7; 9]; [32; 12; 9]; [60; 12; 7; 8; 9];
- [77; 12; 7; 9]; [51; 12; 8; 9]; [31; 12; 9]; [46; 7; 8; 17];
- [61; 7; 17]; [10; 8; 9]; [30; 8]; [85; 9; 17]; [43; 17];
- [32; 9]; [63; 5; 6; 12; 7; 8; 9; 17];
- [64; 5; 12; 7; 8; 9; 17]; [16; 5; 6; 12; 7; 8; 17];
- [18; 5; 12; 7; 8; 17]; [34; 5; 6; 12; 7; 8];
- [86; 5; 6; 7; 9]; [84; 5; 6; 9]; [39; 5; 6; 17];
- [45; 5; 6; 7; 8; 17]; [48; 5; 6; 8; 17];
- [70; 5; 6; 12; 7; 9; 17]; [72; 5; 6; 12; 7; 17];
- [70; 5; 6; 12; 7; 8; 9; 17]; [72; 5; 6; 12; 7; 8; 17];
- [87; 5; 6; 12; 9; 17]; [88; 5; 6; 12; 17]; [89; 5; 6; 12; 9];
- [90; 5; 6; 12]; [91; 5; 6; 12; 7; 9; 17];
- [92; 5; 6; 12; 7; 17]; [93; 5; 12; 7; 8]; [94; 5; 12; 8];
- [10; 5; 8; 9]; [32; 5; 9]; [71; 5; 6; 12; 7; 8; 17];
- [95; 5; 12; 7; 8; 17]; [96; 5; 6; 12; 7; 8; 9];
- [73; 5; 6; 12; 7; 8]; [97; 5; 12; 7; 8; 9];
- [98; 5; 6; 12; 8; 9]; [99; 5; 12; 8; 9];
- [100; 5; 12; 7; 8; 17]; [101; 5; 12; 8; 17];
- [102; 5; 6; 7; 8; 9; 17]; [103; 5; 6; 7; 9; 17];
- [95; 5; 6; 7; 8; 17]; [74; 5; 6; 7; 17]; [96; 5; 6; 7; 8; 9];
- [56; 5; 6; 7; 9]; [95; 5; 7; 8; 17]; [18; 5; 8; 17];
- [21; 5; 7; 8]; [29; 5; 8]; [38; 6; 7; 8; 9]; [39; 6; 8; 9];
- [44; 6; 12; 7; 8; 9]; [55; 6; 12; 8; 9];
- [104; 6; 12; 7; 8; 9; 17]; [105; 6; 12; 8; 9; 17];
- [40; 6; 12; 7; 8; 17]; [46; 6; 7; 8; 17]; [35; 6; 12; 7; 9];
- [106; 6; 12; 9]; [107; 6; 12; 7; 9; 17]; [108; 6; 7; 9; 17];
- [109; 6; 12; 9; 17]; [85; 6; 9; 17]; [41; 6; 12; 8; 17];
- [42; 6; 8; 17]; [110; 6; 12; 17]; [43; 6; 17]; [15; 6; 12; 8];
- [111; 6; 12]; [112; 6; 12; 7; 8; 9]; [83; 6; 12; 8; 9];
- [113; 6; 12; 7; 8; 9; 17]; [114; 6; 12; 8; 9; 17];
- [86; 6; 7; 8; 9]; [84; 6; 8; 9]; [44; 6; 7; 8; 9];
- [55; 6; 8; 9]; [13; 6; 12; 8]; [106; 6; 12]; [39; 6];
- [112; 6; 12; 7; 9]; [86; 6; 7; 9]; [4; 12; 7; 8; 9];
- [10; 12; 8; 9]; [14; 12; 7; 8]; [15; 12; 8]; [115; 12; 7];
- [111; 12]; [116; 7; 8; 9; 17]; [108; 7; 9; 17]; [50; 8; 9; 17];
- [42; 8; 17]; [117; 5; 6; 12; 7; 9]; [118; 5; 6; 12; 9];
- [69; 5; 6; 12; 7; 8; 9; 17]; [102; 5; 12; 7; 8; 9; 17];
- [104; 5; 6; 12; 7; 8; 17]; [40; 5; 12; 7; 8; 17];
- [105; 5; 6; 12; 8; 17]; [41; 5; 12; 8; 17];
- [119; 5; 6; 12; 7; 8; 9]; [36; 5; 6; 7; 8]; [37; 5; 6; 8];
- [38; 5; 6; 7]; [39; 5; 6]; [79; 5; 6; 7; 9; 17];
- [108; 5; 7; 9; 17]; [80; 5; 6; 9; 17]; [85; 5; 9; 17];
- [120; 5; 6; 12; 8; 9; 17]; [121; 5; 6; 12; 8; 17];
- [56; 5; 6; 12; 7; 9]; [57; 5; 6; 12; 7];
- [120; 5; 6; 12; 9; 17]; [121; 5; 6; 12; 17];
- [122; 5; 6; 12; 7; 9]; [123; 5; 6; 12; 7]; [93; 5; 12; 7];
- [94; 5; 12]; [87; 5; 6; 9; 17]; [88; 5; 6; 17];
- [63; 5; 6; 8; 9; 17]; [16; 5; 6; 8; 17];
- [102; 5; 7; 8; 9; 17]; [64; 5; 8; 9; 17]; [103; 5; 7; 9; 17];
- [124; 5; 9; 17]; [27; 5; 7; 8; 9]; [67; 5; 7; 9];
- [125; 6; 12; 7; 8; 9; 17]; [49; 6; 12; 8; 9; 17];
- [115; 6; 12; 7]; [54; 6; 7]; [34; 6; 12; 7; 8; 9];
- [13; 6; 12; 8; 9]; [126; 6; 12; 7; 9; 17]; [127; 6; 12; 9; 17];
- [81; 6; 12; 7; 8; 9; 17]; [82; 6; 12; 8; 9; 17];
- [125; 6; 7; 8; 9; 17]; [49; 6; 8; 9; 17];
- [104; 6; 12; 7; 8; 17]; [45; 6; 7; 8; 17]; [105; 6; 12; 8; 17];
- [48; 6; 8; 17]; [127; 6; 12; 17]; [53; 6; 17];
- [107; 12; 7; 9; 17]; [109; 12; 9; 17]; [128; 12; 7; 8; 9; 17];
- [129; 12; 8; 9; 17]; [4; 7; 8; 9]; [62; 7; 9]; [47; 7; 8];
- [54; 7]; [93; 5; 6; 12; 7]; [94; 5; 6; 12];
- [25; 5; 6; 12; 8; 9]; [68; 5; 12; 8; 9]; [26; 5; 6; 12; 8];
- [29; 5; 12; 8]; [130; 5; 6; 12; 7; 8; 9; 17];
- [131; 5; 12; 7; 8; 9; 17]; [132; 5; 6; 12; 8; 9; 17];
- [133; 5; 12; 8; 9; 17]; [125; 5; 6; 7; 8; 9; 17];
- [116; 5; 7; 8; 9; 17]; [89; 5; 6; 12; 8; 9];
- [90; 5; 6; 12; 8]; [117; 5; 12; 7; 9]; [118; 5; 12; 9];
- [58; 5; 6; 9]; [59; 5; 6]; [53; 6; 9; 17]; [126; 6; 12; 7; 17];
- [134; 12; 7; 17]; [110; 12; 17]; [135; 5; 12; 7; 17];
- [136; 5; 12; 17]; [52; 6; 7; 17]; [137; 5; 12; 7; 9; 17];
- [138; 5; 12; 9; 17] ];;
-
-t () ;;
-
-(* Example from SL6 conversion *)
-let s () = test [[2; -1]; [-3];
- [2; -1]; [-7; -6; -5; -4]; [-11; -10; -9; -4; -8]; [-12; -10; -9; -8];
- [-13; -6; -5]; [-15; -6; -14; -5; -9; -4; -8]; [-16; -10; -8];
- [-17; -14; -10; -8]; [-18; -10; -4; -8]; [-19; -14; -5; -9; -4; -8];
- [-20; -14; -10; -5]; [-21; -6; -14; -10; -5; -8]; [-22; -6; -5; -9; -4; -8];
- [-23; -6; -4]; [-24; -6; -14; -5; -4]; [-25; -14; -10; -9; -8];
- [-26; -14; -5; -9; -8]; [-27; -10; -9; -4]; [-28; -6; -10; -4];
- [-29; -6; -5; -9; -8]; [-30; -6; -14; -5; -9; -8]; [-31; -6; -5; -9; -4];
- [-32; -10; -4]; [-33; -14; -10]; [-34; -6; -14; -9; -8]; [-35; -10; -5; -8];
- [-36; -10; -5; -4]; [-37; -14; -10; -9; -4]; [-38; -5; -9; -4];
- [-39; -6; -14; -5; -9]; [-40; -6; -14; -5]; [-41; -10; -5; -4; -8];
- [-42; -6; -14; -5; -8]; [-43; -6; -14; -5; -4; -8]; [-44; -14; -9; -4; -8];
- [-45; -6; -14; -10; -5; -4]; [-46; -6; -10; -9; -8]; [-47; -4];
- [-48; -6; -9; -4]; [-49; -6; -10; -9; -4; -8]; [-50; -6; -9; -4; -8];
- [-51; -6; -10; -5; -4]; [-52; -6; -10; -5; -8]; [-53; -14; -5; -9; -4];
- [-54; -14; -5; -9]; [-55; -14; -5]; [-56; -14; -10; -5; -9; -8];
- [-57; -6; -10; -5; -9; -8]; [-58; -14; -10; -9; -4; -8]; [-59; -6; -14; -4];
- [-60; -6; -5; -8]; [-61; -14; -9; -8]; [-62; -14; -9; -4]; [-63; -9; -4];
- [-64; -6; -5; -9]; [-65; -6; -4; -8]; [-66; -6; -10; -5; -4; -8];
- [-67; -6; -14; -9]; [-68; -14; -9]; [-69; -14]; [-70; -6; -10; -9; -4];
- [-71; -14; -5; -4]; [-72; -14; -10; -5; -8]; [-73; -6; -10; -5]; [-74; -6;-10];
- [-75; -6; -5; -4; -8]; [-76; -5; -4; -8]; [-77; -5; -4]; [-78; -6; -10; -9];
- [-79; -10; -9]; [-80; -10; -5]; [-81; -6; -10; -5; -9; -4; -8];
- [-82; -14; -10; -4]; [-83; -14; -10; -5; -4; -8]; [-84; -6; -10; -8];
- [-85; -6; -9; -8]; [-86; -6; -9]; [-87; -14; -4]; [-88; -14; -5; -4; -8];
- [-89; -14; -4; -8]; [-90; -14; -5; -8]; [-91; -14; -10; -9];
- [-92; -6; -14; -10; -9; -8]; [-93; -6; -14; -9; -4; -8]; [-94; -9];
- [-95; -9; -8]; [-96; -5]; [-97; -14; -10; -5; -4]; [-98; -14; -10; -5; -9; -4];
- [-99; -14; -8]; [-100; -6; -10; -5; -9; -4]; [-101; -6; -10; -5; -9];
- [-102; -14; -10; -5; -9]; [-103; -10; -5; -9; -4]; [-104; -10; -5; -9];
- [-105; -6; -14; -8]; [-106; -14; -10; -4; -8]; [-107; -6; -14; -10; -8];
- [-108; -6; -14; -4; -8]; [-109; -6; -10; -4; -8]; [-110; -6; -14; -10; -4; -8];
- [-111; -10; -5; -9; -8]; [-112;...
[truncated message content] |
|
From: <luk...@us...> - 2011-04-18 18:28:33
|
Revision: 1417
http://toss.svn.sourceforge.net/toss/?rev=1417&view=rev
Author: lukaszkaiser
Date: 2011-04-18 18:28:26 +0000 (Mon, 18 Apr 2011)
Log Message:
-----------
Moving QBF to BoolFormula, adding timeout support in MiniSat, Sat and BoolFormula.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/Sat/Makefile
trunk/Toss/Formula/Sat/MiniSAT.ml
trunk/Toss/Formula/Sat/MiniSAT.mli
trunk/Toss/Formula/Sat/MiniSATWrap.C
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Formula/Sat/Sat.mli
trunk/Toss/Formula/Sat/minisat/Solver.C
trunk/Toss/Formula/Sat/minisat/Solver.h
trunk/Toss/Makefile
trunk/Toss/TossFullTest.ml
Removed Paths:
-------------
trunk/Toss/Formula/Sat/qbf.ml
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,7 +1,12 @@
(* Represent Boolean combinations of integer literals. *)
let debug_level = ref 0
-let set_debug_level i = Sat.set_debug_level (i-1); (debug_level := i)
+let debug_elim = ref false
+let set_debug_level i = (
+ Sat.set_debug_level (i-1);
+ debug_level := i;
+ if i > 0 then debug_elim := true
+)
(* 0 : no generation is performed and to_cnf transforms a DNF
1 : use Tseitin to construct a CNF with auxiliary variables
@@ -9,7 +14,7 @@
let auxcnf_generation = ref 2
let set_auxcnf i = (auxcnf_generation := i)
-let simplification = ref 2
+let simplification = ref 7
let set_simplification i = (simplification := i)
(* bit 0 : subsumption test after cnf conversion
bit 1 : full-fledged simplification
@@ -104,12 +109,21 @@
let rec sort phi =
match phi with
- BVar _ -> phi
+ | BVar _ -> phi
| BNot psi -> BNot (sort psi)
| BOr psis -> BOr (List.sort compare (List.map sort psis))
| BAnd psis -> BAnd (List.sort compare (List.map sort psis))
+let rec subst vars = function
+ | BVar v when (List.mem v vars) -> BAnd []
+ | BVar v when (List.mem (-v) vars) -> BOr []
+ | BVar v -> BVar v
+ | BNot f -> subst vars f
+ | BOr fs -> BOr (List.map (subst vars) fs)
+ | BAnd fs -> BAnd (List.map (subst vars) fs)
+
+
(* Convert a Boolean combination into reduced form (over 'not' and 'or') *)
let rec to_reduced_form ?(neg=false) = function
BVar v -> if neg then BVar (-1 * v) else BVar v
@@ -242,43 +256,56 @@
formula phi
+(* Flatten conjunctions and disjunctions. *)
+let rec flatten phi =
+ let is_conjunction = function BAnd _ -> true | _ -> false in
+ let is_disjunction = function BOr _ -> true | _ -> false in
+ match phi with
+ | BNot (BNot psi) -> psi
+ | BNot (BVar v) -> BVar (-v)
+ | BNot psi -> BNot (flatten psi)
+ | BOr (flist) ->
+ if not (List.exists is_disjunction flist) then
+ BOr (List.map flatten flist)
+ else
+ (BOr (List.flatten (List.map
+ (function
+ | BOr psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
+ | BAnd (flist) ->
+ if not (List.exists is_conjunction flist) then
+ BAnd (List.map flatten flist)
+ else (BAnd (List.flatten (List.map
+ (function
+ | BAnd psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
+ | _ -> phi
+
+
+(* Absorb trues and falses *)
+let rec neutral_absorbing = function
+ | BVar _ as lit -> lit
+ | BNot psi -> BNot (neutral_absorbing psi)
+ | BOr psis ->
+ if (List.exists (fun psi -> psi = BAnd []) psis) then (BAnd []) else
+ let filtered_once = List.filter (fun psi -> psi <> BOr []) psis in
+ let new_psis = List.map neutral_absorbing filtered_once in
+ let filtered = List.filter (fun psi -> psi <> BOr []) new_psis in
+ if (List.exists (fun psi -> psi = BAnd []) filtered) then (BAnd []) else
+ BOr filtered
+ | BAnd psis ->
+ if (List.exists (fun psi -> psi = BOr []) psis) then (BOr []) else
+ let filtered_once = List.filter (fun psi -> psi <> BAnd []) psis in
+ let new_psis = List.map neutral_absorbing filtered_once in
+ let filtered = List.filter (fun psi -> psi <> BAnd []) new_psis in
+ if (List.exists (fun psi -> psi = BOr []) filtered) then (BOr []) else
+ BAnd filtered
+
(* Simplify a Boolean combination *)
let rec simplify phi =
let is_conjunction = function BAnd _ -> true | _ -> false in
let is_disjunction = function BOr _ -> true | _ -> false in
let is_literal = function BNot (BVar _) | BVar _ -> true | _ -> false in
- let rec flatten phi =
- match phi with
- | BNot (BNot psi) -> psi
- | BNot (BVar v) -> BVar (-v)
- | BNot psi -> BNot (flatten psi)
- | BOr (flist) ->
- if not (List.exists is_disjunction flist) then
- BOr (List.map flatten flist)
- else
- (BOr (List.flatten (List.map
- (function
- | BOr psis -> List.map flatten psis
- | psi -> [flatten psi] ) flist)))
- | BAnd (flist) ->
- if not (List.exists is_conjunction flist) then
- BAnd (List.map flatten flist)
- else (BAnd (List.flatten (List.map
- (function
- | BAnd psis -> List.map flatten psis
- | psi -> [flatten psi] ) flist)))
- | _ -> phi in
- let rec neutral_absorbing = function
- | BVar _ as lit -> lit
- | BNot psi -> BNot (neutral_absorbing phi)
- | BOr psis ->
- let filtered = List.filter (fun psi -> psi <> BOr []) psis in
- if (List.exists (fun psi -> psi = BAnd []) filtered) then (BAnd []) else
- BOr (List.map neutral_absorbing filtered)
- | BAnd psis ->
- let filtered = List.filter (fun psi -> psi <> BAnd []) psis in
- if (List.exists (fun psi -> psi = BOr []) filtered) then (BOr []) else
- BAnd (List.map neutral_absorbing filtered) in
let rec singularise unsorted_phi =
let phi = sort unsorted_phi in (* this should be done more elegantly!!! *)
let rec neg_occurrence = function
@@ -318,18 +345,18 @@
let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
BAnd(non_disjnctns @ List.filter
(fun theta ->
- (List.for_all (fun phi -> phi=theta or
+ (List.for_all (fun phi -> phi=theta ||
not (subformula phi theta)) non_disjnctns)
- & (List.for_all (fun phi -> phi=theta or
+ && (List.for_all (fun phi -> phi=theta ||
not (subclause phi theta)) disjnctns))
disjnctns)
| BOr psis ->
let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
BOr(non_conjnctns @ List.filter
(fun theta ->
- (List.for_all (fun phi -> phi=theta or
+ (List.for_all (fun phi -> phi=theta ||
not (subformula phi theta)) non_conjnctns)
- & (List.for_all (fun phi -> phi=theta or
+ && (List.for_all (fun phi -> phi=theta ||
not (subclause phi theta)) conjnctns))
conjnctns) in
let unit_propagation phi =
@@ -362,7 +389,7 @@
to_nnf (BNot res_neg_phi)
| BAnd psis ->
let (clauses, non_clauses) = List.partition
- (fun psi -> is_disjunction psi or is_literal psi) psis in
+ (fun psi -> is_disjunction psi || is_literal psi) psis in
let resolvent cl1 cl2 =
(* construct the resolvent of clauses cl1 and cl2 and
tag it with the reserved literal 0 *)
@@ -458,15 +485,15 @@
List.exists (fun y -> y=lit) thetas
| (BOr psis, (BVar v as lit))
| (BAnd psis, (BVar v as lit)) ->
- List.for_all (fun x -> x=lit or x=(lit_of_int 0)) psis
+ List.for_all (fun x -> x=lit || x=(lit_of_int 0)) psis
| (BOr psis, BOr thetas)
| (BAnd psis, BAnd thetas) ->
List.for_all
- (fun x -> x=(lit_of_int 0) or List.exists (fun y-> y=x) thetas)
+ (fun x -> x=(lit_of_int 0) || List.exists (fun y-> y=x) thetas)
psis
| (_, _) -> false in
let (clauses, non_clauses) =
- List.partition (fun phi -> is_disjunction phi or is_literal phi)
+ List.partition (fun phi -> is_disjunction phi || is_literal phi)
psis in
let (resolvents, non_resolvents) = List.partition
(fun clause ->
@@ -523,6 +550,12 @@
"\nwas simplified to " ^ str simplified);
simplified
+let subst_simp vars f =
+ let mem_simp = !simplification in
+ simplification := 2;
+ let res = simplify (subst vars f) in
+ simplification := mem_simp;
+ res
(* Convert reduced Boolean combination into CNF with aux variables (Tseitin) *)
let auxcnf_of_bool_formula phi =
@@ -661,3 +694,306 @@
formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
formula_cnf
+
+(* ------- Boolean quantifier elimination using CNF conversion ------- *)
+
+let to_cnf_basic phi =
+ let cnf = convert phi in
+ neutral_absorbing
+ (BAnd (List.rev_map (fun lits -> BOr (List.map lit_of_int lits)) cnf))
+
+let to_cnf ?(tm=1200.) phi =
+ try
+ Sat.set_timeout tm;
+ let res = to_cnf_basic phi in
+ Sat.clear_timeout ();
+ Some (res)
+ with Aux.Timeout _ -> None
+
+let try_cnf tm phi =
+ match to_cnf ~tm phi with None -> phi | Some psi -> psi
+
+let to_dnf_basic phi = to_nnf ~neg:true (to_cnf_basic (to_nnf ~neg:true phi))
+
+let to_dnf ?(tm=1200.) phi =
+ match to_cnf ~tm (to_nnf ~neg:true phi) with
+ | None -> None
+ | Some psi -> Some (to_nnf ~neg:true psi)
+
+let try_dnf tm phi =
+ match to_dnf ~tm phi with None -> phi | Some psi -> psi
+
+let univ ?(dbg=0) v phi =
+ if dbg > 0 then Printf.printf "Univ subst in %s\n%!" (str phi);
+ let simp1 = subst_simp [v] phi in
+ if dbg > 0 then Printf.printf "Univ subst POS: %s\n%!" (str simp1);
+ let simp2 = subst_simp [-v] phi in
+ if dbg > 0 then Printf.printf "Univ subst NEG: %s\n%!" (str simp2);
+ BAnd [simp1; simp2]
+
+
+let sort_freq phi vars =
+ let rec occ v acc = function
+ | BVar w -> if abs v = abs w then acc + 1 else acc
+ | BNot f -> occ v acc f
+ | BOr fl | BAnd fl -> List.fold_left (occ v) acc fl in
+ let freqs = Hashtbl.create (List.length vars) in
+ List.iter (fun v -> Hashtbl.add freqs v (occ v 0 phi)) vars;
+ let fq v = Hashtbl.find freqs v in
+ List.sort (fun v w -> (fq v) - (fq w)) vars
+
+let (tm_jump, cutvar, has_vars_mem) = (1.1, 3, Hashtbl.create 31)
+
+let _ = debug_elim := false
+
+(* Returns a quantifier-free formula equivalent to All (vars, phi).
+ The list [vars] contains only positive literals and [phi] is in NNF. *)
+let rec elim_all_rec ?(nocheck=false) prefix tout vars in_phi =
+ if List.length vars = 0 then in_phi else match in_phi with
+ | BVar v -> if List.mem (abs v) vars then BOr [] else (BVar v)
+ | BNot _ -> failwith "error (elim_all_rec): BNot in NNF Boolean formula"
+ | BAnd fs ->
+ if !debug_elim then Printf.printf "%s vars %i list %i (same sign)\n%!"
+ prefix (List.length vars) (List.length fs);
+ let do_elim (acc, i) f =
+ if f = BOr [] || acc = [BOr []] then ([BOr []], i+1) else
+ let new_pref = prefix ^ (string_of_int i) ^ ":" in
+ let elim_f = elim_all_rec new_pref tout vars f in
+ if elim_f = BOr [] then ([BOr []], i+1) else
+ if elim_f = BAnd [] then (acc, i+1) else (elim_f :: acc, i+1) in
+ let (simp_fs, _) = List.fold_left do_elim ([], 0) fs in
+ if !debug_elim then Printf.printf "%s done %!" prefix;
+ let res = match to_dnf ~tm:(5. *. tout) (BAnd simp_fs) with
+ | None ->
+ if !debug_elim then
+ Printf.printf "(non-dnf %i)\n%!" (size (BAnd simp_fs));
+ BAnd simp_fs
+ | Some psi ->
+ if !debug_elim then Printf.printf "(dnf %i)\n%!" (size psi);
+ psi in
+ neutral_absorbing (flatten res)
+ | BOr [] -> BOr []
+ | BOr [f] -> elim_all_rec prefix tout vars f
+ | BOr fs when List.for_all (function BVar _ -> true | _ -> false) fs ->
+ let is_univ_quant = function
+ | BVar v -> List.mem (abs v) vars
+ | _ -> failwith "error (elim_all_rec): non-BVar in BVar-only list" in
+ BOr (List.filter (fun v -> not (is_univ_quant v)) fs)
+ | BOr fs as phi ->
+ let rec has_vars sgn vl = function (* check if any var occurs *)
+ | BVar v -> if sgn then List.mem v vl else List.mem (abs v) vl
+ | BNot f -> has_vars sgn vl f
+ | BOr fl | BAnd fl -> List.exists (has_vars sgn vl) fl in
+ let has_vars_memo sgn vl =
+ try Hashtbl.find has_vars_mem (sgn, vl) with Not_found ->
+ let res = has_vars sgn vl in
+ Hashtbl.add has_vars_mem (sgn, vl) res;
+ res in
+ if !debug_elim && prefix <> "S" then
+ Printf.printf "%s vars %i list %i (partition)\n%!" prefix
+ (List.length vars) (List.length fs);
+ let (fs_yes, fs_no) = List.partition (has_vars_memo false vars) fs in
+ if Hashtbl.length has_vars_mem > 10000 then Hashtbl.clear has_vars_mem;
+ if fs_no <> [] then (
+ let elim_yes = elim_all_rec prefix tout vars (BOr fs_yes) in
+ neutral_absorbing (flatten (BOr (elim_yes :: fs_no)))
+ ) else if List.length vars = 1 then (
+ let sub = univ (List.hd vars) phi in
+ if prefix = "S" then simplify (to_dnf_basic sub) else
+ let (res, msg ) = match to_dnf ~tm:(5. *. tout) sub with
+ | None -> (simplify sub, "no dnf")
+ | Some dnf -> (simplify dnf, "dnf") in
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (%s)\n%!" prefix
+ (List.length vars) (List.length fs) msg;
+ res
+ ) else if List.length vars < cutvar then (
+ let insert psi v = neutral_absorbing (flatten (univ v psi)) in
+ let sub = List.fold_left insert phi vars in
+ let (res, msg ) = match to_dnf ~tm:(3. *. tout) sub with
+ | None -> (simplify sub, "no dnf")
+ | Some dnf -> (simplify dnf, "dnf") in
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (%s)\n%!" prefix
+ (List.length vars) (List.length fs) msg;
+ res
+ ) else (
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (inside %i)\n%!" prefix
+ (List.length vars) (List.length fs) (size phi);
+ try
+ if nocheck then raise (Aux.Timeout "!!out");
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (cnf conv) %!" prefix
+ (List.length vars) (List.length fs);
+ let bool_cnf = match to_cnf ~tm:(3. *. tout) phi with
+ | None -> raise (Aux.Timeout "!!none")
+ | Some psi -> psi in
+ if !debug_elim then Printf.printf "success \n%!";
+ let cnf = elim_all_rec prefix tout vars bool_cnf in
+ let xsize = function BAnd l -> List.length l | _ -> 0 in
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (cnf after conv %i) %!" prefix
+ (List.length vars) (List.length fs) (xsize cnf);
+ match to_dnf ~tm:(5. *. tout) cnf with
+ | None -> if !debug_elim then Printf.printf "\n%!"; cnf
+ | Some dnf ->
+ if !debug_elim then Printf.printf "(dnf) \n%!"; dnf
+ with Aux.Timeout s ->
+ if !debug_elim && s<>"!!out" then Printf.printf "failed\n%!";
+ let elim nbr_left timeout psi v =
+ try
+ if !debug_elim then
+ Printf.printf "%s eliminating %i%!" prefix v;
+ if nbr_left > 2 then (
+ Sat.set_timeout (timeout);
+ ) else ( Sat.set_timeout (3. *. timeout) );
+ let res = elim_all_rec "S" tout [v] psi in
+ Sat.clear_timeout ();
+ if !debug_elim then Printf.printf " success.\n%!";
+ Some res
+ with Aux.Timeout _ ->
+ if !debug_elim then Printf.printf " failed\n%!";
+ None in
+ let try_elim_var timeout (left_vars,cur_phi,elim_nbr,step,all_nbr) v =
+ if not (has_vars_memo true [-v] cur_phi) then (
+ if !debug_elim then
+ Printf.printf "%s elimineted %i (only pos)\n%!" prefix v;
+ (left_vars, subst_simp [-v] cur_phi, elim_nbr+1, step+1, all_nbr)
+ ) else if not (has_vars_memo true [v] cur_phi) then (
+ if !debug_elim then
+ Printf.printf "%s elimineted %i (only neg)\n%!" prefix v;
+ (left_vars, subst_simp [v] cur_phi, elim_nbr+1, step+1, all_nbr)
+ ) else if 2*step > all_nbr && elim_nbr > 0 &&
+ step+2 < all_nbr && all_nbr - elim_nbr > cutvar then
+ (v :: left_vars, cur_phi, elim_nbr, step + 1, all_nbr)
+ else match elim (all_nbr - step) timeout cur_phi v with
+ | None -> (v :: left_vars, cur_phi, elim_nbr, step + 1, all_nbr)
+ | Some psi -> (left_vars, psi, elim_nbr + 1, step + 1, all_nbr) in
+ let (left_vars, new_phi, elim_nbr, _, all_nbr) =
+ List.fold_left (try_elim_var tout) ([], phi,0,0, List.length vars)
+ (sort_freq phi vars) in
+ if elim_nbr > 0 then
+ elim_all_rec prefix tout left_vars new_phi
+ else
+ let (big_v, rest_vars) = (List.hd left_vars, List.tl left_vars) in
+ if !debug_elim then Printf.printf "branch %i\n%!" big_v;
+ elim_all_rec prefix (tm_jump *.tout) rest_vars (univ big_v new_phi)
+ )
+
+(* Returns a quantifier-free formula equivalent to All (vars, phi). *)
+let elim_all vars phi =
+ elim_all_rec " " 0.3 (List.map (fun v -> abs v) vars) (to_nnf phi)
+
+(* Returns a quantifier-free formula equivalent to Ex (vars, phi). *)
+let elim_ex vars phi =
+ to_nnf ~neg:true (elim_all vars (to_nnf ~neg:true phi))
+
+
+(* ------ Reading and reducing QBF --------- *)
+
+(* Type for quantified Boolean formulas. *)
+type qbf =
+ | QFree of bool_formula
+ | QEx of int list * qbf
+ | QAll of int list * qbf
+
+(* Print a QBF formula. *)
+let rec qbf_str = function
+ | QFree phi -> str phi
+ | QEx (vars, phi) ->
+ "(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
+ " " ^ qbf_str phi ^ ")"
+ | QAll (vars, phi) ->
+ "(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
+ " " ^ qbf_str phi ^ ")"
+
+
+(* Read a qdimacs description of a QBF from [in_ch]. *)
+let read_qdimacs in_ch =
+ (* Read the starting 'c' comment lines, and the first 'p' line.
+ Set the number of variables and the number of clauses. *)
+ let rec read_header () =
+ let line = input_line in_ch in
+ if line.[0] = 'c' then read_header () else
+ Scanf.sscanf line "p cnf %i %i" (fun x y -> (x, y)) in
+
+ (* Read one clause from a line. *)
+ let read_clause line =
+ let (s, i, clause) = (ref "", ref 0, ref []) in
+ while (line.[!i] != '0' || line.[!i - 1] != ' ') do
+ if line.[!i] = ' ' then (
+ i := !i + 1;
+ let lit = int_of_string !s in
+ clause := lit :: !clause;
+ s := "";
+ ) else (
+ s := !s ^ (String.make 1 line.[!i]);
+ i := !i + 1;
+ )
+ done;
+ !clause in
+
+ let list_int line =
+ let split = Str.split (Str.regexp "[ \t]+") line in
+ List.rev (List.tl (List.rev_map
+ (fun s -> int_of_string s) (List.tl split))) in
+
+ let read_formula () =
+ let (no_var, no_cl) = read_header () in
+ let rec read_phi () =
+ let line = input_line in_ch in
+ if line.[0] == 'a' then
+ QAll (list_int line, read_phi ())
+ else if line.[0] == 'e' then
+ QEx (list_int line, read_phi ())
+ else (
+ let cls = ref [read_clause (line)] in
+ for i = 1 to (no_cl-1) do
+ cls := (read_clause (input_line in_ch)) :: !cls
+ done;
+ QFree (
+ BAnd (List.map (fun lits -> BOr (List.map lit_of_int lits)) !cls))
+ ) in
+ read_phi () in
+
+ read_formula ()
+
+
+(* Eliminating quantifiers from QBF formulas. *)
+let rec elim_quant = function
+ | QFree (phi) -> phi
+ | QEx (vars, qphi) ->
+ Hashtbl.clear has_vars_mem;
+ let inside, len = elim_quant qphi, List.length vars in
+ if !debug_elim then Printf.printf "EX %i START\n%!" len;
+ let res_raw = elim_ex vars (inside) in
+ let res = match to_dnf ~tm:3. res_raw with
+ | None ->
+ if !debug_elim then (
+ Printf.printf "EX ELIM NO DNF\n%!";
+ Printf.printf "%s \n%!" (str res_raw);
+ );
+ res_raw
+ | Some r ->
+ if !debug_elim then Printf.printf "EX ELIM IN DNF\n%!";
+ r in
+ if !debug_elim then Printf.printf "EX %i FIN\n%!" len;
+ res
+ | QAll (vars, qphi) ->
+ Hashtbl.clear has_vars_mem;
+ let inside, len = elim_quant qphi, List.length vars in
+ if !debug_elim then Printf.printf "ALL %i START\n%!" len;
+ let res_raw = elim_all vars (inside) in
+ let res = match to_cnf ~tm:3. res_raw with
+ | None ->
+ if !debug_elim then (
+ Printf.printf "ALL ELIM NO CNF\n%!";
+ Printf.printf "%s \n%!" (str res_raw);
+ );
+ res_raw
+ | Some r ->
+ if !debug_elim then Printf.printf "ALL ELIM IN CNF\n%!";
+ r in
+ if !debug_elim then Printf.printf "ALL %i FIN\n%!" len;
+ res
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-18 18:28:26 UTC (rev 1417)
@@ -55,13 +55,34 @@
val formula_to_cnf : Formula.formula -> Formula.formula
+(** {2 Boolean Quantifier Elimination and QBF} *)
-(** {2 Debugging.} *)
+(** Returns a quantifier-free formula equivalent to All (vars, phi). *)
+val elim_all : int list -> bool_formula -> bool_formula
+(** Returns a quantifier-free formula equivalent to Ex (vars, phi). *)
+val elim_ex : int list -> bool_formula -> bool_formula
+
+(** Type for quantified Boolean formulas. *)
+type qbf =
+ | QFree of bool_formula
+ | QEx of int list * qbf
+ | QAll of int list * qbf
+
+(** Print a QBF formula. *)
+val qbf_str : qbf -> string
+
+(** Read a qdimacs description of a QBF from [in_ch]. *)
+val read_qdimacs : in_channel -> qbf
+
+(** Eliminating quantifiers from QBF formulas. *)
+val elim_quant : qbf -> bool_formula
+
+
+(** {3 Debugging} *)
+
(** Debugging information. At level 0 nothing is printed out. *)
val set_debug_level : int -> unit
-
-
val set_auxcnf : int -> unit
val set_simplification : int -> unit
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -3,7 +3,6 @@
open BoolFormula;;
BoolFormula.set_debug_level 0;;
-BoolFormula.set_simplification 6;; (* w/ resolution: 6; w/o resolution: 2 *)
BoolFormula.set_auxcnf 2;; (* Tseitin: 1 Plaisted-Greenbaum: 2 *)
let formula_of_string s =
@@ -226,6 +225,188 @@
test_cnf_string (fun x -> String.length x > 9) (test_formula 200)
);
+
+ "basic Boolean quantifier elimination" >::
+ (fun () ->
+ let test_elim_ex form vars res_s =
+ let eq_s = assert_eq_string (BoolFormula.str form) in
+ eq_s "Eliminating ex quantifier" res_s
+ (BoolFormula.str (elim_ex vars form)) in
+
+ (* ex X [ (X or Y) and (not X or Z) ] = (Y or Z) *)
+ let b = BAnd [BOr [BVar 1; BVar 2]; BOr [BVar (-1); BVar 3]] in
+ test_elim_ex b [1] "(2 or 3)";
+ );
]
+
+let bigtests = "BoolFormulaBig" >::: [
+ "simple QBF solving" >::
+ (fun () ->
+ let test_elim qbf res_s =
+ let eq_s = assert_eq_string (qbf_str qbf) in
+ eq_s "Eliminating quantifiers from QBF" res_s
+ (BoolFormula.str (elim_quant qbf)) in
+
+ let s27_d2_s = "p cnf 85 142
+e 4 5 6 7 1 2 3 9 10 11 12 13 14 15 16 17 32 33 34 35 37 38 39 40 41 42 43 44 45 0
+a 18 19 20 21 23 25 26 27 28 29 0
+e 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 0
+-1 0
+-2 0
+-3 0
+4 9 0
+-4 -9 0
+-1 -10 0
+-15 -10 0
+1 15 10 0
+9 -11 0
+2 -11 0
+-9 -2 11 0
+-13 12 0
+-11 12 0
+13 11 -12 0
+-5 -13 0
+-3 -13 0
+5 3 13 0
+-7 14 0
+-11 14 0
+7 11 -14 0
+14 15 0
+12 15 0
+-14 -12 -15 0
+-9 -16 0
+-10 -16 0
+9 10 16 0
+-6 -17 0
+-13 -17 0
+6 13 17 0
+32 37 0
+-32 -37 0
+-16 -38 0
+-43 -38 0
+16 43 38 0
+37 -39 0
+10 -39 0
+-37 -10 39 0
+-41 40 0
+-39 40 0
+41 39 -40 0
+-33 -41 0
+-17 -41 0
+33 17 41 0
+-35 42 0
+-39 42 0
+35 39 -42 0
+42 43 0
+40 43 0
+-42 -40 -43 0
+-37 -44 0
+-38 -44 0
+37 38 44 0
+-34 -45 0
+-41 -45 0
+34 41 45 0
+-18 60 0
+-23 60 0
+18 23 -60 0
+18 61 0
+23 61 0
+-18 -23 -61 0
+1 62 0
+38 62 0
+-1 -38 -62 0
+29 63 0
+38 63 0
+-29 -38 -63 0
+-1 64 0
+-29 64 0
+-38 64 0
+1 29 38 -64 0
+-23 65 0
+25 65 0
+23 -25 -65 0
+-2 66 0
+25 66 0
+2 -25 -66 0
+23 67 0
+2 67 0
+-25 67 0
+-23 -2 25 -67 0
+27 68 0
+-26 68 0
+-27 26 -68 0
+25 69 0
+-26 69 0
+-25 26 -69 0
+-27 70 0
+-25 70 0
+26 70 0
+27 25 -26 -70 0
+19 71 0
+27 71 0
+-19 -27 -71 0
+3 72 0
+27 72 0
+-3 -27 -72 0
+-19 73 0
+-3 73 0
+-27 73 0
+19 3 27 -73 0
+21 74 0
+-28 74 0
+-21 28 -74 0
+25 75 0
+-28 75 0
+-25 28 -75 0
+-21 76 0
+-25 76 0
+28 76 0
+21 25 -28 -76 0
+-28 77 0
+-29 77 0
+28 29 -77 0
+-26 78 0
+-29 78 0
+26 29 -78 0
+28 79 0
+26 79 0
+29 79 0
+-28 -26 -29 -79 0
+23 80 0
+44 80 0
+-23 -44 -80 0
+38 81 0
+44 81 0
+-38 -44 -81 0
+-23 82 0
+-38 82 0
+-44 82 0
+23 38 44 -82 0
+20 83 0
+45 83 0
+-20 -45 -83 0
+27 84 0
+45 84 0
+-27 -45 -84 0
+-20 85 0
+-27 85 0
+-45 85 0
+20 27 45 -85 0
+-60 -61 -62 -63 -64 -65 -66 -67 -68 -69 -70 -71 -72 -73 -74 -75 -76 -77 -78 -79 -80 -81 -82 -83 -84 -85 0
+" in
+
+ let f = open_out "tmp_testfile_28721.bf" in
+ output_string f s27_d2_s;
+ close_out f;
+ let f = open_in "tmp_testfile_28721.bf" in
+ let qbf = read_qdimacs f in
+ close_in f;
+ Sys.remove "tmp_testfile_28721.bf";
+ test_elim qbf "true";
+ );
+]
+
let exec = Aux.run_test_if_target "BoolFormulaTest" tests
+
+let execbig = Aux.run_test_if_target "BoolFormulaTest" bigtests
Modified: trunk/Toss/Formula/Sat/Makefile
===================================================================
--- trunk/Toss/Formula/Sat/Makefile 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/Makefile 2011-04-18 18:28:26 UTC (rev 1417)
@@ -18,15 +18,11 @@
%Test:
make -C ../.. Formula/Sat/$@
-qbf: qbf.ml
- make -C ../.. Formula/Sat/qbf.native
- cp ../../qbf.native qbf
-
tests: SatTest
./SatTest
clean:
- rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest qbf
- rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot qbf
+ rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest
+ rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot
rm -f minisat/SatSolver.o minisat/MiniSATWrap.o
Modified: trunk/Toss/Formula/Sat/MiniSAT.ml
===================================================================
--- trunk/Toss/Formula/Sat/MiniSAT.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/MiniSAT.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,7 +1,7 @@
type var = int
type lit = int
type value = int (* F | T | X *)
-type solution = SAT | UNSAT
+type solution = SAT | UNSAT | TIMEOUT
external reset : unit -> unit = "minisat_reset"
external new_var : unit -> var = "minisat_new_var"
@@ -12,6 +12,7 @@
external solve_with_assumption : lit list -> solution = "minisat_solve_with_assumption"
external value_of : var -> value = "minisat_value_of"
external set_threshold : int -> unit = "minisat_set_threshold"
+external set_timeout : float -> unit = "minisat_set_timeout"
let string_of_value (v: value): string =
match v with
Modified: trunk/Toss/Formula/Sat/MiniSAT.mli
===================================================================
--- trunk/Toss/Formula/Sat/MiniSAT.mli 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/MiniSAT.mli 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,7 +1,7 @@
type var = int
type lit = int
type value = int (* F | T | X *)
-type solution = SAT | UNSAT
+type solution = SAT | UNSAT | TIMEOUT
external reset : unit -> unit = "minisat_reset"
external new_var : unit -> var = "minisat_new_var"
@@ -12,4 +12,5 @@
external solve_with_assumption : lit list -> solution = "minisat_solve_with_assumption"
external value_of : var -> value = "minisat_value_of"
external set_threshold : int -> unit = "minisat_set_threshold"
+external set_timeout : float -> unit = "minisat_set_timeout"
val string_of_value : value -> string
Modified: trunk/Toss/Formula/Sat/MiniSATWrap.C
===================================================================
--- trunk/Toss/Formula/Sat/MiniSATWrap.C 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/MiniSATWrap.C 2011-04-18 18:28:26 UTC (rev 1417)
@@ -47,6 +47,13 @@
return Val_unit;
}
+extern "C" value minisat_set_timeout(value c) {
+ double t = Double_val(c);
+ solver->setTimeout(t);
+
+ return Val_unit;
+}
+
/*extern "C" value minisat_simplify_db(value unit) {
solver->simplifyDB();
@@ -58,8 +65,10 @@
if(solver->solve()) {
r = Val_int(0);
+ } else if (solver->sat_timeout > 0) {
+ r = Val_int(1);
} else {
- r = Val_int(1);
+ r = Val_int(2);
}
return r;
@@ -72,8 +81,10 @@
if(solver->solve(assumption)) {
r = Val_int(0);
+ } else if (solver->sat_timeout > 0) {
+ r = Val_int(1);
} else {
- r = Val_int(1);
+ r = Val_int(2);
}
return r;
Modified: trunk/Toss/Formula/Sat/Sat.ml
===================================================================
--- trunk/Toss/Formula/Sat/Sat.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/Sat.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -3,6 +3,18 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i)
+let timeout = ref 0.
+let minisat_timeout = ref 900.
+let check_timeout msg =
+ if !timeout > 0.5 && Unix.gettimeofday () > !timeout then
+ (timeout := 0.; raise (Aux.Timeout msg))
+
+let set_timeout t =
+ minisat_timeout := 5. *. t; (* if MiniSat does it, it's important *)
+ timeout := Unix.gettimeofday () +. t
+
+let clear_timeout () = (timeout := 0.; minisat_timeout := 900.)
+
module IntSet = Set.Make
(struct type t = int let compare x y = x - y end)
@@ -44,6 +56,7 @@
(* Reset global variables and the minisat state. *)
let reset () =
MiniSAT.reset ();
+ MiniSAT.set_timeout !minisat_timeout;
var_map := Hashtbl.create 32;
var_rev_map := Hashtbl.create 32;
lit_frequencies := Hashtbl.create 32;
@@ -159,7 +172,9 @@
let solve () =
(* MiniSAT.simplify_db (); *)
match MiniSAT.solve () with
- MiniSAT.UNSAT -> None
+ | MiniSAT.UNSAT -> None
+ | MiniSAT.TIMEOUT ->
+ raise (Aux.Timeout "MiniSat")
| MiniSAT.SAT ->
let res = ref [] in
let update mv v =
@@ -206,6 +221,7 @@
(* Recursive formula performing conversion to cnf, accumulates clauses. *)
let rec perform_conversion disc_vars orig_lits orig_phi bound cl_acc =
+ check_timeout "Sat.perform_conversion";
match solve () with
None -> cl_acc
| Some vars ->
Modified: trunk/Toss/Formula/Sat/Sat.mli
===================================================================
--- trunk/Toss/Formula/Sat/Sat.mli 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/Sat.mli 2011-04-18 18:28:26 UTC (rev 1417)
@@ -3,6 +3,12 @@
(* ------- Main functions ------- *)
+(** Set timeout function for conversions. *)
+val set_timeout : float -> unit
+(** Clear timeout function. *)
+val clear_timeout : unit -> unit
+
+
(* Given a list of literals to set to true, simplify the given CNF formula. *)
val simplify : int list -> int list list -> int list list
Modified: trunk/Toss/Formula/Sat/minisat/Solver.C
===================================================================
--- trunk/Toss/Formula/Sat/minisat/Solver.C 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/minisat/Solver.C 2011-04-18 18:28:26 UTC (rev 1417)
@@ -46,6 +46,7 @@
, clauses_literals(0), learnts_literals(0), max_literals(0), tot_literals(0)
, ok (true)
+ , sat_timeout (900)
, cla_inc (1)
, var_inc (1)
, qhead (0)
@@ -79,6 +80,11 @@
//=================================================================================================
// Minor methods:
+bool Solver::setTimeout(double t)
+{
+ sat_timeout = t;
+ return true;
+}
// Creates a new SAT variable in the solver. If 'decision_var' is cleared, variable will not be
// used as a decision variable (NOTE! This has effects on the meaning of a SATISFIABLE result).
@@ -712,17 +718,21 @@
// Search:
while (status == l_Undef){
- if (verbosity >= 1)
- reportf("| %9d | %7d %8d %8d | %8d %8d %6.0f | %6.3f %% %6.3f |\n", (int)conflicts, order_heap.size(), nClauses(), (int)clauses_literals, (int)nof_learnts, nLearnts(), (double)learnts_literals/nLearnts(), progress_estimate*100, ((double)clock()-(double)t)/(double)CLOCKS_PER_SEC), fflush(stdout);
- status = search((int)nof_conflicts, (int)nof_learnts);
- nof_conflicts *= restart_inc;
- nof_learnts *= learntsize_inc;
- if ((double)(clock() - t) / CLOCKS_PER_SEC >= 900) {
+ if (verbosity >= 1)
+ reportf("| %9d | %7d %8d %8d | %8d %8d %6.0f | %6.3f %% %6.3f |\n", (int)conflicts, order_heap.size(), nClauses(), (int)clauses_literals, (int)nof_learnts, nLearnts(), (double)learnts_literals/nLearnts(), progress_estimate*100, ((double)clock()-(double)t)/(double)CLOCKS_PER_SEC), fflush(stdout);
+
+ status = search((int)nof_conflicts, (int)nof_learnts);
+ nof_conflicts *= restart_inc;
+ nof_learnts *= learntsize_inc;
+ if ((double)(clock() - t) / CLOCKS_PER_SEC >= sat_timeout) {
+ sat_timeout = -1;
+ if (verbosity >= 1) {
std::cout << "******************************************\n";
std::cout << "********************TIMEOUT***************\n";
std::cout << "******************************************\n";
- break;
- }
+ };
+ break;
+ }
}
if (verbosity >= 1)
@@ -806,7 +816,7 @@
//reportf("number of solutions: %d\n",numSolutions);
cancelUntil(0);
- return status == l_True;
+ return (status == l_True && sat_timeout > 0);
}
//=================================================================================================
Modified: trunk/Toss/Formula/Sat/minisat/Solver.h
===================================================================
--- trunk/Toss/Formula/Sat/minisat/Solver.h 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/minisat/Solver.h 2011-04-18 18:28:26 UTC (rev 1417)
@@ -42,6 +42,8 @@
~Solver();
int var_threshold;
+ double sat_timeout;
+ bool setTimeout (double t);
// Problem specification:
//
Deleted: trunk/Toss/Formula/Sat/qbf.ml
===================================================================
--- trunk/Toss/Formula/Sat/qbf.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/qbf.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,171 +0,0 @@
-(* ----
- Simple QBF Solver (reads QBF in simplified QDIMACS format)
- ----
-*)
-
-type qbf =
- Cnf of int list list
- | Dnf of int list list
- | Ex of int list * qbf
- | All of int list * qbf
-
-
-(* ---------------------- READING QDIMACS INPUT ---------------------------- *)
-
-let var_freq = ref (Array.make 1 0.)
-let no = ref 0
-
-(* Read the starting 'c' comment lines, and the first 'p' line.
- Set the number of variables and the number of clauses.
-*)
-let rec read_header () =
- let line = read_line () in
- if line.[0] = 'c' then read_header () else
- Scanf.sscanf line "p cnf %i %i" (fun x y -> (x, y))
-
-let read_clause line =
- let (s, i, clause) = (ref "", ref 0, ref []) in
- while (line.[!i] != '0' || line.[!i - 1] != ' ') do
- if line.[!i] = ' ' then (
- i := !i + 1;
- let lit = int_of_string !s in
- clause := lit :: !clause;
- s := "";
- ) else (
- s := !s ^ (String.make 1 line.[!i]);
- i := !i + 1;
- )
- done;
- let len = log (float (List.length !clause)) in
- List.iter (fun l -> !var_freq.(abs l) <- !var_freq.(abs l) +. len) !clause;
- !clause
-
-let update_freq cls =
- for i = 0 to (Array.length !var_freq) - 1 do !var_freq.(i) <- 0. done;
- let update_cl cl =
- let len = log (float (List.length cl)) in
- List.iter (fun l -> !var_freq.(abs l) <- !var_freq.(abs l) +. len) cl in
- List.iter update_cl cls
-
-let list_int line =
- let split = Str.split (Str.regexp "[ \t]+") line in
- List.rev (List.tl (List.rev_map (fun s -> int_of_string s) (List.tl split)))
-
-let read_formula () =
- let (no_var, no_cl) = read_header () in
- var_freq := Array.make (no_var + 1) 0.;
- let rec read_phi () =
- let line = read_line () in
- if line.[0] == 'a' then
- All (list_int line, read_phi ())
- else if line.[0] == 'e' then
- Ex (list_int line, read_phi ())
- else (
- let cls = ref [read_clause (line)] in
- for i = 1 to (no_cl-1) do
- cls := (read_clause (read_line ())) :: !cls
- done;
- Cnf (!cls)
- ) in
- read_phi ()
-
-
-(* ------------------------- PRINTING -------------------------------------- *)
-
-let string_of_cl sep cl =
- "(" ^ (String.concat sep (List.map (fun i -> string_of_int i) cl)) ^ ")"
-
-let rec string_of_formula = function
- Ex (vars, phi) -> "e " ^ (String.concat " " (List.map string_of_int vars)) ^
- " | " ^ (string_of_formula phi)
- | All (vars, phi) -> "a " ^ (String.concat " " (List.map string_of_int vars))^
- " | " ^ (string_of_formula phi)
- | Cnf (cls) ->
- if cls = [] then "T" else if cls = [[]] then "F" else
- String.concat " /\\ " (List.map (string_of_cl " \\/ ") cls)
- | Dnf (cls) ->
- if cls = [] then "F" else if cls = [[]] then "T" else
- String.concat " \\/ " (List.map (string_of_cl " /\\ ") cls)
-
-
-(* ------------------------------ SOLVER ---------------------------------- *)
-
-let covered vars cl = List.exists (fun l -> List.mem (abs l) vars) cl
-
-let sort_freq d vars =
- List.sort (fun v w -> d * (compare !var_freq.(abs v) !var_freq.(abs w))) vars
-
-let filter vars cls =
- List.map (fun cl -> List.filter (fun l -> not (List.mem (abs l) vars)) cl) cls
-
-exception FalseEx
-let conv_bound = ref 40
-
-let elim_var (cls, vacc) v =
- no := !no + 1;
- if !var_freq.(v)>(float !conv_bound)/.2. then (cls, v :: vacc) (*hack*) else (
- print_endline ("ex v. "^(string_of_int v) ^ " (" ^ (string_of_int !no) ^
- ", " ^ (string_of_float !var_freq.(v)) ^ ")");
- let (cls_v, cls_nv) = List.partition (fun cl -> covered [v] cl) cls in
- try
- let conv_v = Sat.convert ~disc_vars:[v] cls_v ~bound:(Some !conv_bound) in
- if conv_v=[] then raise FalseEx else if conv_v = [[]] then (cls_nv, vacc)
- else (List.rev_append cls_nv
- (Sat.convert ~bound:(Some (!conv_bound * 4)) conv_v), vacc)
- with
- Sat.OverBound -> print_endline " elim failed"; (cls, v :: vacc)
- )
-
-let rec solve = function
- Cnf (cls) -> Cnf (cls)
- | Dnf (cls) -> Dnf (cls)
- | Ex ([], phi) ->
- print_endline (" formula ex empty " ^ (string_of_formula phi)); phi
- | All ([], phi) -> phi
- | All (vars, Cnf cls) as phi ->
- print_endline (" formula all " ^ (string_of_formula phi));
- Cnf (filter vars cls)
- | Ex (vars, Dnf cls) as phi ->
- print_endline (" formula ex " ^ (string_of_formula phi));
- Dnf (filter vars cls)
- | Ex (vars, Cnf cls) ->
- if cls = [] then Dnf([]) else if List.mem [] cls then Dnf ([[]]) else
- let len = List.length vars in
- if len < 3 then
- let conv = Sat.convert ~disc_vars:vars cls in
- if conv = [] then Dnf ([]) else Dnf conv
- else (
- update_freq cls;
- no := 0;
- let vs = sort_freq 1 vars in
- try
- let (ecls, left_vs) = List.fold_left elim_var (cls, []) vs in
- if left_vs = [] then Cnf ecls else (
- print_endline (" Left " ^ (string_of_int (List.length left_vs)) ^
- " from " ^ (string_of_int len) ^ " vars.");
- try
- if !conv_bound < 70 then raise Sat.OverBound;
- Sat.set_debug_level 2;
- let conv =
- Sat.convert ~disc_vars:left_vs ~bound:(Some !conv_bound) ecls
- in if conv = [] then Dnf ([]) else Dnf conv
- with Sat.OverBound ->
- Sat.set_debug_level 0;
- conv_bound := (3 * (!conv_bound)) / 2;
- solve (Ex (left_vs, Cnf ecls))
- )
- with FalseEx -> Dnf []
- )
- | All (vars, Dnf (cls)) ->
- if cls = [] then Dnf([]) else if List.mem [] cls then Dnf ([[]]) else
- let conv = Sat.convert ~disc_vars:vars cls in
- if conv = [] then Dnf ([]) else solve (All (vars, Cnf conv))
- | Ex (vars, phi) -> solve (Ex (vars, solve phi))
- | All (vars, phi) -> solve (All (vars, solve phi))
-
-let _ =
- let phi = read_formula () in
- print_endline ("Solving formula " ^ (string_of_formula phi));
- Sat.set_debug_level 0;
- print_endline ("Solved: " ^ (string_of_formula (solve phi)));
-;;
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Makefile 2011-04-18 18:28:26 UTC (rev 1417)
@@ -59,7 +59,7 @@
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
FormulaINCSatINC=Formula
-FormulaINC=Formula/Sat
+FormulaINC=Formula,Formula/Sat
SolverINC=Formula,Formula/Sat,Solver/RealQuantElim
ArenaINC=Formula,Formula/Sat,Solver/RealQuantElim,Solver
PlayINC=Formula,Formula/Sat,Solver/RealQuantElim,Solver,Arena
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/TossFullTest.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,6 +1,14 @@
open OUnit
-let formula_tests = TossTest.formula_tests
+let formula_tests = "Formula" >::: [
+ AuxTest.tests;
+ FormulaTest.tests;
+ SatTest.tests;
+ BoolFormulaTest.tests;
+ BoolFormulaTest.bigtests;
+ FormulaOpsTest.tests;
+ FFTNFTest.tests;
+]
let solver_tests = TossTest.solver_tests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-19 00:36:00
|
Revision: 1418
http://toss.svn.sourceforge.net/toss/?rev=1418&view=rev
Author: lukaszkaiser
Date: 2011-04-19 00:35:53 +0000 (Tue, 19 Apr 2011)
Log Message:
-----------
First attempt at fixed-points, starting slowly with Booleans.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Makefile
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Formula/Tokens.mly
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Added Paths:
-----------
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionParser.mly
trunk/Toss/Formula/BoolFunctionTest.ml
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-19 00:35:53 UTC (rev 1418)
@@ -258,30 +258,22 @@
(* Flatten conjunctions and disjunctions. *)
let rec flatten phi =
- let is_conjunction = function BAnd _ -> true | _ -> false in
- let is_disjunction = function BOr _ -> true | _ -> false in
+ let get_conjunctions = function BAnd fl -> fl | f -> [f] in
+ let get_disjunctions = function BOr fl -> fl | f -> [f] in
+ let fold_acc f xl =
+ List.fold_left (fun acc x -> (f x) @ acc) [] xl in
+ 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
| BNot (BNot psi) -> psi
| BNot (BVar v) -> BVar (-v)
| BNot psi -> BNot (flatten psi)
| BOr (flist) ->
- if not (List.exists is_disjunction flist) then
- BOr (List.map flatten flist)
- else
- (BOr (List.flatten (List.map
- (function
- | BOr psis -> List.map flatten psis
- | psi -> [flatten psi] ) flist)))
+ BOr (rev_collect_disj (List.rev_map flatten flist))
| BAnd (flist) ->
- if not (List.exists is_conjunction flist) then
- BAnd (List.map flatten flist)
- else (BAnd (List.flatten (List.map
- (function
- | BAnd psis -> List.map flatten psis
- | psi -> [flatten psi] ) flist)))
+ BAnd (rev_collect_conj (List.rev_map flatten flist))
| _ -> phi
-
(* Absorb trues and falses *)
let rec neutral_absorbing = function
| BVar _ as lit -> lit
@@ -646,25 +638,29 @@
List.filter (fun x -> List.for_all (fun y -> x=y || not(subset y x)) cnf) cnf
-let convert phi =
+let convert ?(disc_vars=[]) phi =
(* input is a Boolean combination; output is a list of list of integers
interpreted as a cnf *)
let (aux_separator, aux_cnf_formula) =
match !auxcnf_generation with
| 0 -> failwith "this function must not be called w/o auxcnf-converion"
| 1 -> (* use Tseitin conversion *)
- auxcnf_of_bool_formula
- (to_reduced_form (flatten_sort (to_nnf ~neg:false phi)))
+ auxcnf_of_bool_formula
+ (to_reduced_form (flatten (to_nnf ~neg:false phi)))
| 2 -> (* or Plaisted-Greenbaum conversion *)
- pg_auxcnf_of_bool_formula (flatten_sort (to_nnf ~neg:false phi))
+ let arg = flatten (to_nnf ~neg:false phi) in
+ if !debug_level > 0 then print_endline "CNF conv: arg computed";
+ pg_auxcnf_of_bool_formula arg
| _ -> failwith "undefined parameter value" in
if !debug_level > 0 then (
print_endline ("Separator is: " ^ string_of_int aux_separator);
- print_endline ("Converting Aux-CNF: " ^ str aux_cnf_formula);
+ if !debug_level > 1 then
+ print_endline ("Converting Aux-CNF: " ^ str aux_cnf_formula);
);
let aux_cnf = listcnf_of_boolcnf aux_cnf_formula in
- let cnf_llist = Sat.convert_aux_cnf aux_separator aux_cnf in
- if !debug_level > 0 then
+ let cnf_llist = Sat.convert_aux_cnf ~disc_vars aux_separator aux_cnf in
+ if !debug_level > 0 then print_endline ("Converted CNF. ");
+ if !debug_level > 1 then
print_endline ("Converted CNF: " ^ (Sat.cnf_str cnf_llist));
let simplified =
if (!simplification land 1) > 0 then
@@ -697,31 +693,32 @@
(* ------- Boolean quantifier elimination using CNF conversion ------- *)
-let to_cnf_basic phi =
- let cnf = convert phi in
+let to_cnf_basic ?(disc_vars=[]) phi =
+ let cnf = convert ~disc_vars phi in
neutral_absorbing
(BAnd (List.rev_map (fun lits -> BOr (List.map lit_of_int lits)) cnf))
-let to_cnf ?(tm=1200.) phi =
+let to_cnf ?(disc_vars=[]) ?(tm=1200.) phi =
try
Sat.set_timeout tm;
- let res = to_cnf_basic phi in
+ let res = to_cnf_basic ~disc_vars phi in
Sat.clear_timeout ();
Some (res)
with Aux.Timeout _ -> None
-let try_cnf tm phi =
- match to_cnf ~tm phi with None -> phi | Some psi -> psi
+let try_cnf ?(disc_vars=[]) tm phi =
+ match to_cnf ~disc_vars ~tm phi with None -> phi | Some psi -> psi
-let to_dnf_basic phi = to_nnf ~neg:true (to_cnf_basic (to_nnf ~neg:true phi))
+let to_dnf_basic ?(disc_vars=[]) phi =
+ to_nnf ~neg:true (to_cnf_basic ~disc_vars (to_nnf ~neg:true phi))
-let to_dnf ?(tm=1200.) phi =
- match to_cnf ~tm (to_nnf ~neg:true phi) with
+let to_dnf ?(disc_vars=[]) ?(tm=1200.) phi =
+ match to_cnf ~disc_vars ~tm (to_nnf ~neg:true phi) with
| None -> None
| Some psi -> Some (to_nnf ~neg:true psi)
-let try_dnf tm phi =
- match to_dnf ~tm phi with None -> phi | Some psi -> psi
+let try_dnf ?(disc_vars=[]) tm phi =
+ match to_dnf ~disc_vars ~tm phi with None -> phi | Some psi -> psi
let univ ?(dbg=0) v phi =
if dbg > 0 then Printf.printf "Univ subst in %s\n%!" (str phi);
@@ -744,7 +741,7 @@
let (tm_jump, cutvar, has_vars_mem) = (1.1, 3, Hashtbl.create 31)
-let _ = debug_elim := false
+let _ () = debug_elim := true
(* Returns a quantifier-free formula equivalent to All (vars, phi).
The list [vars] contains only positive literals and [phi] is in NNF. *)
@@ -764,7 +761,7 @@
let (simp_fs, _) = List.fold_left do_elim ([], 0) fs in
if !debug_elim then Printf.printf "%s done %!" prefix;
let res = match to_dnf ~tm:(5. *. tout) (BAnd simp_fs) with
- | None ->
+ | None ->
if !debug_elim then
Printf.printf "(non-dnf %i)\n%!" (size (BAnd simp_fs));
BAnd simp_fs
@@ -826,7 +823,7 @@
if !debug_elim then
Printf.printf "%s vars %i list %i (cnf conv) %!" prefix
(List.length vars) (List.length fs);
- let bool_cnf = match to_cnf ~tm:(3. *. tout) phi with
+ let bool_cnf = match to_cnf ~disc_vars:vars ~tm:(3.*.tout) phi with
| None -> raise (Aux.Timeout "!!none")
| Some psi -> psi in
if !debug_elim then Printf.printf "success \n%!";
@@ -972,7 +969,7 @@
| None ->
if !debug_elim then (
Printf.printf "EX ELIM NO DNF\n%!";
- Printf.printf "%s \n%!" (str res_raw);
+ (* Printf.printf "%s \n%!" (str res_raw); *)
);
res_raw
| Some r ->
@@ -989,7 +986,7 @@
| None ->
if !debug_elim then (
Printf.printf "ALL ELIM NO CNF\n%!";
- Printf.printf "%s \n%!" (str res_raw);
+ (* Printf.printf "%s \n%!" (str res_raw); *)
);
res_raw
| Some r ->
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-19 00:35:53 UTC (rev 1418)
@@ -49,7 +49,7 @@
(** Convert a Boolean formula to NNF and additionally negate if [neg] is set. *)
val to_nnf : ?neg : bool -> bool_formula -> bool_formula
-val convert : bool_formula -> int list list
+val convert : ?disc_vars: int list -> bool_formula -> int list list
(** Convert an arbitrary formula to CNF via Boolean combinations. *)
val formula_to_cnf : Formula.formula -> Formula.formula
Added: trunk/Toss/Formula/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml (rev 0)
+++ trunk/Toss/Formula/BoolFunction.ml 2011-04-19 00:35:53 UTC (rev 1418)
@@ -0,0 +1,131 @@
+(* Represent Boolean functions. *)
+
+let debug_level = ref 0
+let set_debug_level i = (debug_level := i;)
+
+
+(* ----------------------- BASIC TYPE DEFINITION -------------------------- *)
+
+(* This type describes Boolean functions *)
+type bool_function =
+ | Fun of string * string list
+ | PosVar of string * string
+ | NegVar of string * string
+ | Not of bool_function
+ | And of bool_function list
+ | Or of bool_function list
+ | Ex of (string * string) list * bool_function
+ | Mu of string * (string * string) list * bool_function
+
+
+(* ----------------------- PRINTING FUNCTIONS ------------------------------- *)
+
+(* Print to formatter. *)
+let rec fprint f = function
+ | Fun (s, vars) ->
+ Format.fprintf f "%s(%a)" s
+ (Aux.fprint_sep_list "," (fun f s -> Format.fprintf f "%s" s)) vars
+ | PosVar (m, n) -> Format.fprintf f "%s.%s=1" m n
+ | NegVar (m, n) -> Format.fprintf f "%s.%s=0" m n
+ | Not phi -> Format.fprintf f "@[<1>!%a@]" fprint phi
+ | And [] -> Format.fprintf f "true"
+ | Or [] -> Format.fprintf f "false"
+ | And [phi] -> fprint f phi
+ | Or [phi] -> fprint f phi
+ | And flist ->
+ Format.fprintf f "@[<1>(%a)@]" (Aux.fprint_sep_list " &" fprint) flist
+ | Or flist ->
+ Format.fprintf f "@[<1>(%a)@]" (Aux.fprint_sep_list " |" fprint) flist
+ | Ex (mod_vars, phi) ->
+ let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn in
+ Format.fprintf f "@[<1>(exists@ %a.@ %a)@]"
+ (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint phi
+ | Mu (name, mod_vars, def) ->
+ let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn in
+ Format.fprintf f "@[<1>mu bool %s(%a)@ %a@]" name
+ (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+
+(* Print to stdout. *)
+let print phi = (
+ Format.print_flush();
+ fprint Format.std_formatter phi;
+ Format.print_flush();
+)
+
+(* Print to string. *)
+let sprint phi =
+ ignore (Format.flush_str_formatter ());
+ Format.fprintf Format.str_formatter "@[%a@]" fprint phi;
+ Format.flush_str_formatter ()
+
+(* Another name for sprint. *)
+let str f = sprint f
+
+(* --------------------- BASIC FUNCTIONS ------------------------ *)
+
+(* Compute the size of a Boolean function. *)
+let rec size ?(acc=0) = function
+ | Fun _ | PosVar _ | NegVar _ -> acc + 1
+ | Not phi | Ex (_, phi) | Mu (_, _, phi) -> size ~acc:(acc + 1) phi
+ | And flist | Or flist ->
+ List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
+
+(* Convert a Boolean function to NNF, additionally negate if [neg] is set. *)
+let rec to_nnf ?(neg=false) = function
+ | Fun (n, a) -> if neg then Not (Fun (n, a)) else Fun (n, a)
+ | PosVar (m, n) -> if neg then NegVar (m, n) else PosVar (m, n)
+ | NegVar (m, n) -> if neg then PosVar (m, n) else NegVar (m, n)
+ | Not phi -> if neg then to_nnf ~neg:false phi else to_nnf ~neg:true phi
+ | And (flist) when neg -> Or (List.map (to_nnf ~neg:true) flist)
+ | And (flist) -> And (List.map (to_nnf ~neg:false) flist)
+ | Or (flist) when neg -> And (List.map (to_nnf ~neg:true) flist)
+ | Or (flist) -> Or (List.map (to_nnf ~neg:false) flist)
+ | x -> if neg then Not x else x
+
+(* Flatten conjunctions and disjunctions, apply [f] to the lists. *)
+let rec flatten_f f phi =
+ let get_conjunctions = function And fl -> fl | f -> [f] in
+ let get_disjunctions = function Or fl -> fl | f -> [f] in
+ let fold_acc f xl =
+ List.fold_left (fun acc x -> (f x) @ acc) [] xl in
+ 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
+ | Not (Not psi) -> psi
+ | Not (PosVar (m, n)) -> NegVar (m, n)
+ | Not (NegVar (m, n)) -> PosVar (m, n)
+ | Not psi -> Not (flatten_f f psi)
+ | Or (flist) ->
+ Or (f (rev_collect_disj (List.rev_map (flatten_f f) flist)))
+ | And (flist) ->
+ And (f (rev_collect_conj (List.rev_map (flatten_f f) flist)))
+ | Ex (vs, phi) -> Ex (vs, flatten_f f phi)
+ | Mu (n, vs, phi) -> Mu (n, vs, flatten_f f phi)
+ | _ -> phi
+
+(* Just Flatten. *)
+let flatten psi = flatten_f (fun x -> x) psi
+
+(* Flatten and sort. *)
+let flatten_sort psi = flatten_f (List.sort Pervasives.compare) psi
+
+(* Flatten and perform trivial simplifications (e.g. absorb true, false) *)
+let rec triv_simp phi = match flatten phi with
+ | Fun _ | PosVar _ | NegVar _ as lit -> lit
+ | Not psi -> Not (triv_simp psi)
+ | Or psis ->
+ if (List.exists (fun psi -> psi = And []) psis) then (And []) else
+ let filtered_once = List.filter (fun psi -> psi <> Or []) psis in
+ let new_psis = List.map triv_simp filtered_once in
+ let filtered = List.filter (fun psi -> psi <> Or []) new_psis in
+ if (List.exists (fun psi -> psi = And []) filtered) then (And []) else
+ Or filtered
+ | And psis ->
+ if (List.exists (fun psi -> psi = Or []) psis) then (Or []) else
+ let filtered_once = List.filter (fun psi -> psi <> And []) psis in
+ let new_psis = List.map triv_simp filtered_once in
+ let filtered = List.filter (fun psi -> psi <> And []) new_psis in
+ if (List.exists (fun psi -> psi = Or []) filtered) then (Or []) else
+ And filtered
+ | Ex (vs, phi) -> Ex (vs, triv_simp phi)
+ | Mu (n, vs, phi) -> Mu (n, vs, triv_simp phi)
Added: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli (rev 0)
+++ trunk/Toss/Formula/BoolFunction.mli 2011-04-19 00:35:53 UTC (rev 1418)
@@ -0,0 +1,47 @@
+(** Represent Boolean functions. *)
+
+(** {2 Debugging} *)
+
+(** Set debugging level. *)
+val set_debug_level : int -> unit
+
+
+(** {2 Basic Type Definition} *)
+
+(** This type describes Boolean functions *)
+type bool_function =
+ | Fun of string * string list
+ | PosVar of string * string
+ | NegVar of string * string
+ | Not of bool_function
+ | And of bool_function list
+ | Or of bool_function list
+ | Ex of (string * string) list * bool_function
+ | Mu of string * (string * string) list * bool_function
+
+
+(** {2 Printing Functions} *)
+
+(** Print to stdout. *)
+val print : bool_function -> unit
+
+(** Print to string. *)
+val sprint : bool_function -> string
+
+(** Another name for sprint. *)
+val str : bool_function -> string
+
+(** Print to formatter. *)
+val fprint : Format.formatter -> bool_function -> unit
+
+
+(** {2 Basic Functions} *)
+
+(** Compute the size of a Boolean function. *)
+val size : ?acc : int -> bool_function -> int
+
+(** Flatten conjunctions and disjunctions. *)
+val flatten : bool_function -> bool_function
+
+(** Flatten and perform trivial simplifications (e.g. absorb true, false) *)
+val triv_simp : bool_function -> bool_function
Added: trunk/Toss/Formula/BoolFunctionParser.mly
===================================================================
--- trunk/Toss/Formula/BoolFunctionParser.mly (rev 0)
+++ trunk/Toss/Formula/BoolFunctionParser.mly 2011-04-19 00:35:53 UTC (rev 1418)
@@ -0,0 +1,46 @@
+/* Tokens taken from Lexer.mll */
+
+%{
+ open Lexer
+ open BoolFunction
+%}
+
+%start parse_bool_function
+%type <BoolFunction.bool_function> parse_bool_function bool_function_expr
+
+
+%%
+
+id_pair:
+ | ID ID { ($1, $2) }
+
+%public bool_function_expr:
+ | TRUE { And [] }
+ | FALSE { Or [] }
+ | bool_function_expr AND bool_function_expr { And [$1; $3] }
+ | bool_function_expr OR bool_function_expr { Or [$1; $3] }
+ | bool_function_expr AMP bool_function_expr { And [$1; $3] }
+ | bool_function_expr MID bool_function_expr { Or [$1; $3] }
+ | bool_function_expr RARR bool_function_expr { Or [Not ($1); $3] }
+ | bool_function_expr LRARR bool_function_expr
+ { Or [And [Not ($1); Not ($3)]; And [$1; $3]] }
+ | bool_function_expr XOR bool_function_expr
+ { And [Or [$1; $3]; Not (And [$1; $3])] }
+ | ID DOT ID EQ INT
+ { if $5 = 0 then NegVar($1, $3) else PosVar($1, $3) }
+ | NOT ID DOT ID { NegVar ($2, $4) }
+ | ID DOT ID { PosVar ($1, $3) }
+ | name = ID args = delimited (OPEN, separated_list (COMMA, ID), CLOSE)
+ { Fun (name, args) }
+ | EX vars = separated_list (COMMA, id_pair) phi = bool_function_expr
+ { Ex (vars, phi) }
+ | EX vars = separated_list (COMMA, id_pair) DOT phi = bool_function_expr
+ { Ex (vars, phi) }
+ | LFP n = ID vars = separated_list (COMMA, id_pair) phi = bool_function_expr
+ { Mu (n, vars, phi) }
+ | NOT bool_function_expr { Not ($2) }
+ | OPEN bool_function_expr CLOSE { $2 }
+
+
+parse_bool_function:
+ | bool_function_expr EOF { triv_simp $1 };
Added: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml (rev 0)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-19 00:35:53 UTC (rev 1418)
@@ -0,0 +1,39 @@
+open OUnit
+open BoolFunction
+
+let _ = ( BoolFunction.set_debug_level 0; )
+
+let bf_of_string s =
+ BoolFunctionParser.parse_bool_function Lexer.lex (Lexing.from_string s)
+
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
+let tests = "BoolFunction" >::: [
+ "parsing and printing" >::
+ (fun () ->
+ let test_parse_print s res =
+ assert_eq_string s "Parse and Print" res (str (bf_of_string s)) in
+
+ test_parse_print "MyRel (m)" "MyRel(m)";
+ test_parse_print "Rel (m) | m.a1 = 0" "(Rel(m) | m.a1=0)";
+ test_parse_print "(R(m)&m.a1=1)|m.a2=0" "((R(m) & m.a1=1) | m.a2=0)";
+ test_parse_print
+ ("(false |((m.a1=0 & m.a2=0 & m.a3=0)) " ^
+ "|((m.a1=0 & m.a2=1 & m.a3=0)) |((m.a1=1 & m.a2=1 & m.a3=0)))")
+ ("((m.a1=0 & m.a2=0 & m.a3=0) | (m.a1=0 & m.a2=1 & m.a3=0) |\n " ^
+ "(m.a1=1 & m.a2=1 & m.a3=0))");
+ test_parse_print "true & !pc.b1 & !pc.b2 & !pc.b3"
+ "(pc.b1=0 & pc.b2=0 & pc.b3=0)";
+ test_parse_print "(false | (true))" "true";
+ test_parse_print ("(exists M t_mod, PC t_pc, Loc tL, Glob tG. (" ^
+ "target(t_mod,t_pc) & Reach(t_mod, t_pc, tL, tG)))")
+ ("(exists M t_mod, PC t_pc, Loc tL, Glob tG.\n " ^
+ "(target(t_mod, t_pc) & Reach(t_mod, t_pc, tL, tG)))");
+ );
+]
+
+let exec = Aux.run_test_if_target "BoolFunctionTest" tests
+
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/Formula/Lexer.mll 2011-04-19 00:35:53 UTC (rev 1418)
@@ -8,6 +8,8 @@
| COLON
| SEMICOLON
| COMMA
+ | DOT
+ | AMP
| MID
| SUM
| PLUS
@@ -77,6 +79,7 @@
| STATE_SPEC
| LEFT_SPEC
| RIGHT_SPEC
+ | LFP
| EOF
let reset_as_file lexbuf s =
@@ -137,6 +140,8 @@
| ':' { COLON }
| ';' { SEMICOLON }
| ',' { COMMA }
+ | '.' { DOT }
+ | '&' { AMP }
| '|' { MID }
| "Sum" { SUM }
| '+' { PLUS }
@@ -151,6 +156,7 @@
| '=' { EQ }
| "<>" { LTGR }
| "!=" { NEQ }
+ | "!" { NOT }
| "<-" { LARR }
| "<=" { LDARR }
| "->" { RARR }
@@ -170,6 +176,7 @@
| "xor" { XOR }
| "not" { NOT }
| "ex" { EX }
+ | "exists" { EX }
| "all" { ALL }
| "tc" { TC }
| "TC" { TC }
@@ -208,6 +215,9 @@
| "STATE" { STATE_SPEC }
| "LEFT" { LEFT_SPEC }
| "RIGHT" { RIGHT_SPEC }
+ | "LFP" { LFP }
+ | "lfp" { LFP }
+ | "mu" { LFP }
| ['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/Makefile
===================================================================
--- trunk/Toss/Formula/Makefile 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/Formula/Makefile 2011-04-19 00:35:53 UTC (rev 1418)
@@ -6,6 +6,7 @@
AuxTest:
FormulaTest:
BoolFormulaTest:
+BoolFunctionTest:
FormulaOpsTest:
FFTNFTest:
Modified: trunk/Toss/Formula/Sat/Sat.ml
===================================================================
--- trunk/Toss/Formula/Sat/Sat.ml 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/Formula/Sat/Sat.ml 2011-04-19 00:35:53 UTC (rev 1418)
@@ -259,16 +259,18 @@
let convert_aux_cnf ?(disc_vars=[]) ?(bound=None) aux_separator aux_cnf =
(match bound with Some i -> max_clause := i | None -> max_clause := -1;);
cur_clause := 0;
- if !debug_level > 0 then print_endline (" converting: " ^ (cnf_str aux_cnf));
+ if !debug_level > 0 then print_endline (" converting in Sat ");
+ if !debug_level > 1 then print_endline (" converting: " ^ (cnf_str aux_cnf));
let (bound, cnf_form) = (aux_separator, aux_cnf) in
- if !debug_level > 2 then
- print_endline (" formula for sat: " ^ (cnf_str cnf_form));
register_new_formula cnf_form;
MiniSAT.set_threshold bound;
let rec lit_set acc = function
[] -> acc
| x :: xs -> lit_set (List.fold_left (fun s i-> IntSet.add i s) acc x) xs in
- let f = perform_conversion disc_vars (lit_set IntSet.empty cnf_form) cnf_form bound [] in
+ let literals = (lit_set IntSet.empty cnf_form) in
+ if !debug_level > 0 then print_endline (" starting converting in Sat ");
+ let f = perform_conversion disc_vars literals cnf_form bound [] in
let form = List.rev_map (fun cl -> List.map (fun v -> -v) cl) f in
- if !debug_level > 0 then print_endline (" converted: " ^ (cnf_str form));
+ if !debug_level > 0 then print_endline (" converted in Sat ");
+ if !debug_level > 1 then print_endline (" converted: " ^ (cnf_str form));
simplify [] (simplify [] form)
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/Formula/Tokens.mly 2011-04-19 00:35:53 UTC (rev 1418)
@@ -3,7 +3,7 @@
%token <float> FLOAT
%token <string> BOARD_STRING
%token APOSTROPHE
-%token COLON SEMICOLON COMMA MID
+%token COLON SEMICOLON COMMA DOT AMP MID
%token SUM PLUS MINUS TIMES DIV POW GR GREQ LT EQLT EQ LTGR NEQ
%token LARR LDARR RARR RDARR LRARR LRDARR INTERV
%token OPENCUR CLOSECUR OPENSQ CLOSESQ OPEN CLOSE
@@ -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 EOF
+%token MODEL_SPEC RULE_SPEC STATE_SPEC LEFT_SPEC RIGHT_SPEC LFP EOF
/* List in order of increasing precedence. */
%nonassoc COND
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/TossFullTest.ml 2011-04-19 00:35:53 UTC (rev 1418)
@@ -6,6 +6,7 @@
SatTest.tests;
BoolFormulaTest.tests;
BoolFormulaTest.bigtests;
+ BoolFunctionTest.tests;
FormulaOpsTest.tests;
FFTNFTest.tests;
]
Modified: trunk/Toss/TossTest.ml
===================================================================
--- trunk/Toss/TossTest.ml 2011-04-18 18:28:26 UTC (rev 1417)
+++ trunk/Toss/TossTest.ml 2011-04-19 00:35:53 UTC (rev 1418)
@@ -5,6 +5,7 @@
FormulaTest.tests;
SatTest.tests;
BoolFormulaTest.tests;
+ BoolFunctionTest.tests;
FormulaOpsTest.tests;
FFTNFTest.tests;
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-21 00:48:56
|
Revision: 1422
http://toss.svn.sourceforge.net/toss/?rev=1422&view=rev
Author: lukaszkaiser
Date: 2011-04-21 00:48:48 +0000 (Thu, 21 Apr 2011)
Log Message:
-----------
Starting to move features from Boolean formulas to Formula (but no fixed-points yet), adding paper stuff.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/www/Publications/all.bib
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/www/pub/gdl_to_toss_translation.pdf
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -730,6 +730,13 @@
BAnd [simp1; simp2]
+let to_sat ?(tm=1200.) phi =
+ let rec all_vars acc = function
+ | BVar v -> (abs v) :: acc
+ | BNot f -> all_vars acc f
+ | BOr fl | BAnd fl -> List.fold_left all_vars acc fl in
+ to_dnf ~disc_vars:(all_vars [] phi) ~tm phi
+
let sort_freq phi vars =
let rec occ v acc = function
| BVar w -> if abs v = abs w then acc + 1 else acc
@@ -740,7 +747,7 @@
let fq v = Hashtbl.find freqs v in
List.sort (fun v w -> (fq v) - (fq w)) vars
-let (tm_jump, cutvar, has_vars_mem) = (1.1, 3, Hashtbl.create 31)
+let (tm_jump, cutvar, has_vars_mem) = (1.1, 2, Hashtbl.create 31)
let _ () = debug_elim := true
@@ -886,7 +893,7 @@
(* Returns a quantifier-free formula equivalent to All (vars, phi). *)
let elim_all vars phi =
- elim_all_rec " " 0.3 (List.map (fun v -> abs v) vars) (to_nnf phi)
+ elim_all_rec " " 0.4 (List.map (fun v -> abs v) vars) (to_nnf phi)
(* Returns a quantifier-free formula equivalent to Ex (vars, phi). *)
let elim_ex vars phi =
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-21 00:48:48 UTC (rev 1422)
@@ -63,7 +63,10 @@
val to_dnf : ?disc_vars: int list -> ?tm: float ->
bool_formula -> bool_formula option
+(** Convert a Boolean formula to Sat-equivalent form, "BOr []" on Unsat. *)
+val to_sat : ?tm: float -> bool_formula -> bool_formula option
+
(** {2 Boolean Quantifier Elimination and QBF} *)
(** Returns a quantifier-free formula equivalent to All (vars, phi). *)
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -407,6 +407,28 @@
);
]
-let exec = Aux.run_test_if_target "BoolFormulaTest" tests
+let exec () = Aux.run_test_if_target "BoolFormulaTest" tests
-let execbig = Aux.run_test_if_target "BoolFormulaTest" bigtests
+let execbig ()= Aux.run_test_if_target "BoolFormulaTest" bigtests
+
+
+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 opts = [
+ ("-v", Arg.Unit (fun () -> set_debug_elim true), "be verbose");
+ ("-d", Arg.Int (fun i -> set_debug_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 ( exec (); execbig (); ) else (
+ let f = open_in !file in
+ let qbf = read_qdimacs f in
+ close_in f;
+ print_endline (BoolFormula.str (elim_quant qbf))
+ )
+
+let _ = Aux.run_if_target "BoolFormulaTest" main
Modified: trunk/Toss/Formula/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFunction.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -263,8 +263,8 @@
if new_defs = defs then defs else inline_defs new_defs
-(* Convert a function to DNF with eliminated quantifiers. *)
-let dnf classes f =
+(* Apply [boolf] to the formula with eliminated quantifiers; [msg] debugging.*)
+let apply_bool_elim boolf msg classes f =
let (nbrs, names, free) = (Hashtbl.create 31, Hashtbl.create 31, ref 1) in
let nbr (m, n) =
try Hashtbl.find nbrs (m, n) with Not_found ->
@@ -293,7 +293,7 @@
| And fl -> And (List.map elim_quant fl)
| Or fl -> Or (List.map elim_quant fl)
| Ex (vs, f) ->
- let elim = elim_quant f in
+ let elim = to_nnf (triv_simp (elim_quant f)) in
if !debug_level > 1 then Format.printf "Eliminating@ Ex@ %a@ .@ %a@\n%!"
fprint_mod_var_list vs fprint elim;
let elim_bool = to_bool elim in
@@ -305,21 +305,41 @@
fprint res;
res in
let elim_simp = elim_quant (triv_simp (to_nnf f)) in
- if !debug_level > 0 then Format.printf "BoolFunction: Converting to DNF@\n%!";
- let res = from_bool (Aux.unsome (to_dnf (to_bool elim_simp))) in
if !debug_level > 0 then
- Format.printf "BoolFunction: Computed DNF:@\n%a@\n%!" fprint res;
- triv_simp res
+ Format.printf "BoolFunction: Computing %s@\n%!" msg;
+ match boolf (to_bool elim_simp) with
+ | None -> if !debug_level > 0 then Format.printf "Failed.@\n%!"; None
+ | Some boolphi ->
+ let res = triv_simp (from_bool boolphi) in
+ if !debug_level > 0 then
+ Format.printf "BoolFunction: Computed %s:@\n%a@\n%!" msg fprint res;
+ Some (res)
+(* Convert a function to DNF with eliminated quantifiers. *)
+let dnf ?(tm=1200.) = apply_bool_elim (to_dnf ~tm) "DNF"
+
+(* Convert a function to CNF with eliminated quantifiers. *)
+let cnf ?(tm=1200.) = apply_bool_elim (to_cnf ~tm) "CNF"
+
+(* Convert a function to SAT-form with eliminated quantifiers. *)
+let sat cls f = Aux.unsome (apply_bool_elim to_sat "SAT" cls f)
+
+let nonf ?(tm=1200.) = apply_bool_elim (fun x -> Some (simplify x)) "ELIM"
+
(* Solve fixed-points in the definitions. *)
-let solve_lfp cls all_defs =
+let solve_lfp ?(nf=0) cls all_defs =
let (deffp, defsimp) =
List.partition (fun (_, fp, _, _) -> fp) (inline_defs all_defs) in
let defs = List.map (fun (_, _, _, f) -> f) deffp in
let subst2 = List.map2 (fun (n, _, a, _) f -> (n, false, a, f)) deffp in
let startdef = subst2 (List.map (fun _ -> Or []) deffp) in
- let next df = subst2 (List.map (fun f-> dnf cls (apply_defs df f)) defs) in
- let rec fp acc df =
- let nx = next df in (* We have weak reduction, must memoize for now. *)
- if List.mem nx (df :: acc) then df else fp (df :: acc) nx in
- defsimp @ (fp [] startdef)
+ let xnf c f =
+ Aux.unsome (if nf=0 then nonf c f else if nf=1 then cnf c f else dnf c f) in
+ let next df = subst2 (List.map (fun f-> xnf cls (apply_defs df f)) defs) in
+ let rec fp df =
+ let nx = next df in
+ let ((_,_,_,nxf), (_,_,_,dff)) = (List.hd nx, List.hd df) in
+ match sat cls (And [nxf; Not (dff)]) with
+ | Or [] -> df
+ | _ -> fp nx in
+ defsimp @ (fp startdef)
Modified: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFunction.mli 2011-04-21 00:48:48 UTC (rev 1422)
@@ -82,7 +82,9 @@
val inline_defs : bool_def list -> bool_def list
(** Convert a function to DNF with eliminated quantifiers. *)
-val dnf : (string * string list) list -> bool_function -> bool_function
+val dnf : ?tm:float ->
+ (string * string list) list -> bool_function -> bool_function option
(** Inline and solve fixed-points in the definitions. *)
-val solve_lfp : (string * string list) list -> bool_def list -> bool_def list
+val solve_lfp : ?nf:int ->
+ (string * string list) list -> bool_def list -> bool_def list
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -113,12 +113,15 @@
Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
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) = (ref false, ref false) in
+ let (only_inline, only_fp, nf) = (ref false, ref false, ref 0) in
let opts = [
("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose (= -d 1)");
("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
("-b", Arg.Unit (fun () -> print_bool := true), "print bool's");
("-f", Arg.String (fun s -> file := s), "process file");
+ ("-nonf", Arg.Unit (fun () -> nf := 0), "use no immediate form (default)");
+ ("-cnf", Arg.Unit (fun () -> nf := 1), "use cnf as immediate form");
+ ("-dnf", Arg.Unit (fun () -> nf := 2), "use dnf as immediate form");
("-only-inline", Arg.Unit (fun () -> only_inline := true),
"do not compute the fixed-points or goals, only inline definitions");
("-only-fixedpoint", Arg.Unit (fun () -> only_fp := true),
@@ -138,11 +141,12 @@
try
let (cl, dl, goal) = defs_goal_of_string res_s in
let new_defs =
- if !only_inline then (cl, inline_defs dl) else (cl, solve_lfp cl dl) in
+ if !only_inline then (cl, inline_defs dl) else
+ (cl, solve_lfp ~nf:(!nf) cl dl) in
let inline_goal = triv_simp (apply_defs (snd new_defs) goal) in
let new_goal =
if !only_inline || !only_fp then inline_goal else
- dnf cl inline_goal in
+ Aux.unsome (dnf cl inline_goal) in
if !only_inline || !only_fp || !debug_level > 0 then
print_defs ~print_bool:!print_bool new_defs;
print_endline "\n\n// GOAL FORMULA\n";
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/Formula.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -392,42 +392,67 @@
| 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 =
+ let get_conjunctions = function And fl -> fl | f -> [f] in
+ let get_disjunctions = function Or fl -> fl | f -> [f] in
+ let fold_acc f xl =
+ List.fold_left (fun acc x -> (f x) @ acc) [] xl in
+ 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
+ | RealExpr (re, s) -> RealExpr (flatten_re_f f_or f_and re, s)
+ | Not phi ->
+ (match flatten_f f_or f_and phi with
+ | Or [] -> And []
+ | And [] -> Or []
+ | Not f -> f
+ | f -> Not f
+ )
+ | 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))
+ | 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 []
+ | 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)
+ | 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)
+
+and flatten_re_f f_or f_and = function
+ | RVar _ | Const _ | Fun _ as re -> re
+ | Times (re1, re2) ->
+ Times (flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2)
+ | Plus (re1, re2) ->
+ Plus (flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2)
+ | Char (phi) -> Char (flatten_f f_or f_and phi)
+ | Sum (vl, phi, r) ->
+ Sum (vl, flatten_f f_or f_and phi, flatten_re_f f_or f_and r)
+
+
(* Basic function to flatten formulas. *)
-let rec flatten = function
- Rel _ | Eq _ | In _ as phi -> phi
- | RealExpr (re, s) -> RealExpr (flatten_re re, s)
- | Not phi ->
- (match flatten phi with Not f -> f | f -> Not f)
- | Or [phi] -> flatten phi
- | Or flist_orig ->
- let flist = List.rev_map flatten flist_orig in
- let rec add_res acc = function
- | [] -> acc
- | (Or l) :: xs -> add_res (l @ acc) xs
- | f :: xs -> add_res (f :: acc) xs in
- Or (add_res [] flist)
- | And [phi] -> flatten phi
- | And flist_orig ->
- let flist = List.rev_map flatten flist_orig in
- let rec add_res acc = function
- | [] -> acc
- | (And l) :: xs -> add_res (l @ acc) xs
- | f :: xs -> add_res (f :: acc) xs in
- And (add_res [] flist)
- | Ex ([], phi) | All ([], phi) -> flatten phi
- | Ex (xs, Ex (ys, phi)) -> flatten (Ex (xs @ ys, phi))
- | Ex (xs, phi) -> Ex (xs, flatten phi)
- | All (xs, All (ys, phi)) -> flatten (All (xs @ ys, phi))
- | All (xs, phi) -> All (xs, flatten phi)
+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
-and flatten_re = function
- RVar _ | Const _ | Fun _ as re -> re
- | Times (re1, re2) -> Times (flatten_re re1, flatten_re re2)
- | Plus (re1, re2) -> Plus (flatten_re re1, flatten_re re2)
- | Char (phi) -> Char (flatten phi)
- | Sum (vl, f, r) -> Sum (vl, flatten f, flatten_re r)
+let flatten_sort =
+ let clean fl = del_dupl_ord [] (List.sort compare fl) in
+ flatten_f (fun fl -> set_first_lit_or (clean fl))
+ (fun fl -> set_first_lit_and (clean fl))
+let flatten_sort_re =
+ 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
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -146,7 +146,7 @@
"assign emptyset" >::
(fun () ->
let asg s = FormulaOps.assign_emptyset s in
- let asg_eq s phi1 phi2 = formula_eq id phi2 (asg s) phi1 in
+ let asg_eq s phi1 phi2 = formula_eq Formula.flatten phi2 (asg s) phi1 in
asg_eq "X" "ex x (x in X and P(x) and (Q(y) or R(x)))"
"ex x ((false and P(x)) and (Q(y) or R(x)))";
let plus = "ex X ex zero (all n (LessEq(zero,n)) and
@@ -154,9 +154,9 @@
((s in C) <-> (t in X)))))" in
asg_eq "X" plus "ex X, zero ((all n (LessEq(zero, n)) and ex C
(((not (zero in C)) and all t, s (((not Succ(t, s)) or
- (not s in C and not false) or (s in C and false)))))))";
+ (not s in C and true) or (s in C and false)))))))";
let plus_empty_X =
- Formula.str (Formula.flatten_sort (asg "C" (formula_of_string plus))) in
+ Formula.str (Formula.flatten_sort(asg "C" (formula_of_string plus))) in
asg_eq "C" plus_empty_X "ex X, zero ((all n (LessEq(zero, n)) and ex C
(all t, s (((not Succ(t, s)) or (not (t in X)))))))";
);
Modified: trunk/Toss/www/Publications/all.bib
===================================================================
--- trunk/Toss/www/Publications/all.bib 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/www/Publications/all.bib 2011-04-21 00:48:48 UTC (rev 1422)
@@ -97,11 +97,28 @@
# ARTICLES
+@inproceedings{KS11transl,
+ author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak},
+ title = {Translating the Game Description Langauge to Toss},
+ year = {2011},
+ booktitle = {to appear},
+ url = {/pub/gdl_to_toss_translation.pdf},
+ abstract = {
+We show how to translate games defined in the Game Description
+Language (GDL) into the Toss format. GDL is a variant of Datalog
+used to specify games in the General Game Playing Competition.
+Specifications in Toss are more declarative than in GDL and make
+it easier to capture certain useful game characteristics.
+The presented translation detects structural properties of games
+which are not directly visible in the GDL specification.
+ }
+}
+
@inproceedings{KS11,
author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak},
title = {First-Order Logic with Counting for General Game Playing},
year = {2011},
- booktitle = {review},
+ booktitle = {Proceedings of the 25th AAAI Conference},
url = {/pub/first_order_counting_ggp.pdf},
abstract = {
General Game Players (GGPs) are programs which can play an arbitrary game
Added: trunk/Toss/www/pub/gdl_to_toss_translation.pdf
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/www/pub/gdl_to_toss_translation.pdf
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/www/reference/reference.tex 2011-04-21 00:48:48 UTC (rev 1422)
@@ -57,6 +57,7 @@
% Packages
\usepackage{amsmath,amssymb,amsthm}
+\usepackage{MnSymbol}
\usepackage{enumerate}
\usepackage{xspace}
\usepackage{tikz}
@@ -86,6 +87,9 @@
\newcommand{\fv}{\ensuremath{\mathtt{FreeVar}}\xspace}
\newcommand{\rank}{\ensuremath{\mathtt{rank}}\xspace}
\newcommand{\hitrank}{\ensuremath{\mathtt{hit}\text{-}\mathtt{rank}}\xspace}
+\newcommand{\mgu}{\ensuremath{\mathrm{MGU}}}
+\newcommand{\ot}{\leftarrow}
+\newcommand{\tpos}{\downharpoonleft}
% Theorem environments
\theoremstyle{plain}
@@ -1103,6 +1107,762 @@
only push predicates to the front.
+\chapter{GDL to Toss Translation}
+
+\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.
+
+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
+limited height. The moves of the game, \ie the transition function
+between the states, are described using Datalog rules --- clauses
+define which predicates hold in the subsequent state. In this way
+a transition system is specified in a compact way. Additionally,
+there are 8 special relations in GDL: \texttt{role, init, true, does,
+next, legal, goal} and \texttt{terminal}, which are used to describe
+the game: initial state, the players, their goals, and thus like.
+
+We say that \emph{GDL state terms} are the terms that are possible arguments
+of \texttt{true}, \texttt{next} and \texttt{init} relations in a GDL
+specification, \ie those terms which can define the state
+of the game. The \emph{GDL move terms} are ground instances of
+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}
+give natural examples of a formalisation, similar to several other games.
+
+
+\begin{figure}
+%\begin{center}
+\begin{verbatim}
+(role x)
+(role o)
+(init (cell a a b))
+(init (cell b a b))
+(init (cell c a b))
+(init (cell a b b))
+(init (cell b b b))
+(init (cell c b b))
+(init (cell a c b))
+(init (cell b c b))
+(init (cell c c b))
+(init (control x))
+(<= (next (control ?r)) (does ?r noop))
+(<= (next (cell ?x ?y ?r))
+ (does ?r (mark ?x ?y)))
+(<= (next (cell ?x ?y ?c))
+ (true (cell ?x ?y ?c))
+ (does ?r (mark ?x1 ?y1))
+ (or (distinct ?x ?x1) (distinct ?y ?y1)))
+(<= (legal ?r (mark ?x ?y))
+ (true (control ?r))
+ (true (cell ?x ?y b)))
+(<= (legal ?r noop) (role ?r)
+ (not (true (control ?r))))
+(<= (goal ?r 100) (conn3 ?r))
+(<= (goal ?r 50) (role ?r)
+ (not exists_line3))
+(<= (goal x 0) (conn3 o))
+(<= (goal o 0) (conn3 x))
+(<= terminal exists_line3)
+(<= terminal (not exists_blank))
+(<= exists_blank (true (cell ?x ?y b)))
+(<= exists_line3 (role ?r) (conn3 ?r))
+(<= (conn3 ?r) (or (col ?r) (row ?r)
+ (diag1 ?r) (diag2 ?r)))
+(<= (row ?r)
+ (true (cell ?a ?y ?r)) (nextcol ?a ?b)
+ (true (cell ?b ?y ?r)) (nextcol ?b ?c)
+ (true (cell ?c ?y ?r)))
+(<= (col ?r)
+ (true (cell ?x ?a ?r)) (nextcol ?a ?b)
+ (true (cell ?x ?b ?r)) (nextcol ?b ?c)
+ (true (cell ?x ?c ?r)))
+(<= (diag1 ?r)
+ (true (cell ?x1 ?y1 ?r))
+ (nextcol ?x1 ?x2) (nextcol ?y1 ?y2)
+ (true (cell ?x2 ?y2 ?r))
+ (nextcol ?x2 ?x3) (nextcol ?y2 ?y3)
+ (true (cell ?x3 ?y3 ?r)))
+(<= (diag2 ?r)
+ (true (cell ?x1 ?y5 ?r))
+ (nextcol ?x1 ?x2) (nextcol ?y4 ?y5)
+ (true (cell ?x2 ?y4 ?r))
+ (nextcol ?x2 ?x3) (nextcol ?y3 ?y4)
+ (true (cell ?x3 ?y3 ?r)))
+(nextcol a b)
+(nextcol b c)
+\end{verbatim}
+%\end{center}
+\caption{Tic-tac-toe in the Game Description Language.}
+\label{fig-ttt-gdl}
+\end{figure}
+
+\subsection{Notions Related to Terms}
+
+Since GDL is a term-based formalism, we will use the standard term
+notions, as \eg in the preliminaries of \cite{tata2007}.
+We understand terms as finite trees with ordered successors and
+labelled by the symbols used in the current game, with leafs
+possibly labelled by variables.
+
+\vskip 0.5em \noindent \textbf{Substitutions.}
+A \emph{substitution} is an assignment of terms to variables.
+Given a substitution $\sigma$ and a term $t$ we write $\sigma(t)$
+to denote the result of applying $\sigma$ to $t$, \ie of replacing all
+variables in $t$ which also occur in $\sigma$ by the corresponding terms.
+We extend this notation to tuples in the natural way.
+
+\noindent \textbf{MGU.}
+We say that a tuple of terms $\ol{t}$ is \emph{more general} than another
+tuple $\ol{s}$ of equal length, written $\ol{s} \leq \ol{t}$,
+if there is a substitution $\sigma$ such that $\ol{s} = \sigma(\ol{t})$.
+Given two tuples of terms $\ol{s}$ and $\ol{t}$ we write $\ol{s} \dot{=} \ol{t}$
+to denote that these tuples \emph{unify}, \ie that there exists
+a substitution $\sigma$ such that $\sigma(\ol{s}) = \sigma(\ol{t})$. In such
+case there exists a most general substitution of this kind,
+and we denote it by $\mgu(\ol{s}, \ol{t})$.
+
+\noindent \textbf{Paths.}
+A \emph{path} in a term is a sequence of pairs of function symbols and natural
+numbers denoting which successor to take in turn, \eg $p = (f,1)(g,2)$
+denotes the second child of a node labelled by $g$, which is the first
+child of a node labelled by $f$. For a term $t$ we write $t\tpos_p$ to
+denote the subterm of $t$ at path $p$, and that $t$ has a path $p$,
+i.e. that the respective sequence of nodes exists in $t$ with exactly
+the specified labels. Using $p = (f,1)(g,2)$ as an example,
+$f(g(a,b),c)\tpos_p = b$, but $g(f(a,b),c)\tpos_p$ is false.
+Similarly, for a formula $\phi$, we write $\phi(t\tpos_p)$
+to denote that $t$ has path $p$ and the subterm $r = t\tpos_p$
+satisfies $\phi(r)$. A path can be an empty sequence $\epsilon$ and
+$t\tpos_\epsilon = t$ for all terms $t$.
+
+For any terms $t, s$ and any path $p$ existing in $t$, we write $t[p \ot s]$
+to denote the result of \emph{placing $s$ at path $p$ in $t$}, \ie the term
+$t'$ such that $t'\tpos_p = s$ and on all other paths $q$, \ie ones which
+neither are prefixes of $p$ nor contain $p$ as a prefix, $t'$ is equal to $t$,
+\ie $t'\tpos_q = t\tpos_q$. We extend this notation to sets of paths as well:
+%$t[\{p_1, \ldots, p_n\} \ot s] = t[p_1 \ot s][p_2 \ot s] \cdots [p_n \ot s]$.
+$t[P \ot s]$ places $s$ at all paths from $P$ in $t$.
+
+
+
+\section{Translation} \label{sec-translate}
+
+In this section, we describe our main construction. Given a GDL specification
+of a game $G$, which satisfies the restrictions described in
+Section~\ref{sec-discussion}, we construct a Toss game $T(G)$ which
+represents exactly the same game. Moreover, we define a bijection $\mu$
+between the moves possible in $G$ and in $T(G)$ in each reachable state,
+so that the following correctness theorem holds.
+
+\begin{theorem}[Correctness] ~\\
+%For every GDL game specification $G$ satisfying the restrictions from
+%Section~\ref{sec-discussion}, the constructed Toss game $T(G)$ and move
+%translation functions $\mu$ satisfy the following conditions.
+Let $S$ be any state of $G$ reached from the initial one by a sequence
+of moves $m_1 \ldots m_n$. We write $\mu(S)$ for the state of $T(G)$
+reached by $\mu(m_1) \ldots \mu(m_n)$. The following conditions are satisfied.
+\begin{itemize}
+\item The function $\mu$ defines a bijection between the moves possible
+ in $S$ and in $\mu(S)$ for each player.
+\item If no move is possible in $S$ (and in $\mu(S)$), then the payoffs
+ in $G$ evaluate to the same value as those in $T(G)$.
+\end{itemize}
+\end{theorem}
+
+%The elements in $A$ will correspond to subsets of GDL state terms,
+%and the relations in $\frakA$ will correspond to various relations
+%that hold between the terms from the respective subsets, as explained later.
+%Each GDL move term will correspond to a rule--embedding pair
+%$(\frakL \to_s \frakR, \sigma)$ and each legal move $m$ in $G$ will
+%in this way induce a rule application $\hat{m}$ in Toss. We will also
+%translate the \texttt{goal} terms from $G$ to Toss payoffs $p(G)$ such
+%that the following theorem holds.
+
+We will not prove this theorem here, but the construction presented
+below should make it clear why the exact correspondence holds. For the
+rest of this section let us fix the GDL game specification $G$ we will
+translate. We begin by transforming $G$ itself: eliminating variables
+clearly referring to players (\ie arguments of positive \texttt{role}
+atoms, first arguments to positive \texttt{does} atoms and to
+\texttt{legal}) by substituting them by players of $G$ (\ie arguments
+of \texttt{role} facts), duplicating the clauses. From this transformed
+specification, we derive the elements of the Toss structure
+(Section~\ref{subsec-elems}), the relations (Section~\ref{subsec-rels}),
+the rewriting rules (Section~\ref{subsec-rules}) and finally the move
+translation function (Section~\ref{subsec-move-tr}).
+
+
+\subsection{Elements of the Toss Structure} \label{subsec-elems}
+
+By definition of GDL, the state of the game is described by a set
+of propositions true in that state. Let us denote by $\calS$ the set
+of all GDL state terms which are true at some game state reachable
+from the initial state of $G$.
+
+For us, it is enough to approximate $\calS$ from above. To approximate $\calS$
+and determine the location structure of the Toss game, we currently perform
+an \emph{aggregate playout}, \ie a symbolic play in where all players take
+all their legal moves in a state. Since an approximation is sufficient,
+we check only the positive part of the legality condition of each move.
+
+%The \emph{noop move} of a player in a
+%location is the only move available to her, determining them gives the
+%player of a turn. In the future, instead of an aggregate playout we
+%might use a form of type inference to approximate $\calS$.
+
+To construct the elements of the structure from state terms,
+and to make that structure a good representation of the game in Toss,
+we first determine which state terms always have common subtrees.
+
+\begin{definition} \label{def-merge}
+For two terms $s$ and $t$ we say that a set of paths $P$ \emph{merges}
+$s$ and $t$ if each $p \in P$ exists both in $s$ and $t$ and
+$t[P \ot c] = s[P \ot c]$ for all terms $c$. We denote by $d\calP(s,t)$
+the unique set $P$ of paths merging $s$ and $t$ for which the size of
+$t[P \ot c]$ is maximal and no subset of which merges $s$ and $t$.
+Intuitively, $t[d\calP(s,t) \ot c]$ is the largest common subtree
+of $s$ and $t$, the bigger its size the more similar $s$ and $t$ are.
+\end{definition}
+
+Let $\mathrm{Next}_{e}$ be the set of \texttt{next} clauses in $G$ with all
+atoms of \texttt{does} expanded (inlined) by the \texttt{legal}
+clause definitions, duplicating the \texttt{next} clause when more
+than one head of \texttt{legal} unifies with the \texttt{does} atom.
+Intuitively, these are expanded forms of clauses defining game state change.
+
+For each clause $\calC \in \mathrm{Next}_{e}$, we select two terms
+$s_\calC$ and $t_\calC$ in the following way. The term $s_\calC$ is
+simply the second part of the head of the clause \texttt{(next
+ $s_\calC$)}. The term $t_\calC$ is the argument of \texttt{true} in
+the body of $\calC$ which is most similar to $s$ in the sense of
+Definition~\ref{def-merge}, and of equally similar has smallest
+$d\calP(s,t)$ (if there are several, we pick one arbitrarily).
+
+We often use the word \emph{fluent} for changing objects, and so we
+define the set of \emph{fluent paths}, $\calP_f$, in the following way.
+We say that a term $t$ is a \emph{negative true} in a clause $\calC$ if
+it is the argument of a negative occurrence of \texttt{true} in $\calC$.
+We write $\calL(t)$ for the set of path to all constant leaves in $t$.
+The set
+\[ \calP_f \ = \
+ \bigcup_{\calC \in \mathrm{Next}_{e}} d\calP(s_\calC, t_\calC) \ \cup \
+ \bigcup_{\calC \in \mathrm{Next}_{e},\
+ t_\calC \text{ negative true in } \calC} \calL(t_\calC).
+ \]
+Note that $\calP_f$ contains all merge sets for the selected terms in
+$\mathrm{Next}_e$ clauses, and additionally, when $t_\calC$ is a negative true,
+we add the paths to all constant leaves in $t_\calC$.
+
+
+\begin{example}
+There are three \texttt{next} clauses in Figure~\ref{fig-ttt-gdl}.
+ $\calC_1$:
+\begin{verbatim}
+(<= (next (cell ?x ?y ?c))
+ (true (cell ?x ?y ?c))
+ (does ?r (mark ?x1 ?y1))
+ (or (distinct ?x ?x1) (distinct ?y ?y1)))
+\end{verbatim}
+ does not lead to any fluent paths, since \texttt{(cell ?x ?y ?c)} is
+ $s_{\calC_1} = t_{\calC_1}$ and thus $d\calP(s_{\calC_1}, t_{\calC_1}) = \emptyset$.
+ The clause:
+\begin{verbatim}
+(<= (next (cell ?x ?y ?r))
+ (does ?r (mark ?x ?y)))
+\end{verbatim}
+ expands to:
+\begin{verbatim}
+(<= (next (cell ?x ?y x))
+ (true (control x))
+ (true (cell ?x ?y b)))
+(<= (next (cell ?x ?y o))
+ (true (control o))
+ (true (cell ?x ?y b)))
+\end{verbatim}
+ These generate the fluent path $(\mathtt{cell},3)$. The clause:
+\begin{verbatim}
+(<= (next (control ?r)) (does ?r noop))
+\end{verbatim}
+ expands to:
+\begin{verbatim}
+(<= (next (control x))
+ (not (true (control x))))
+(<= (next (control o))
+ (not (true (control o))))
+\end{verbatim}
+ These generate the fluent path $(\mathtt{control},1)$ since
+ \texttt{(control x)} and \texttt{(control o)} are negative trues. In the end
+ $\calP_f = \{(\mathtt{cell},3), (\mathtt{control},1)\}$.
+\end{example}
+
+The fluent paths define the partition of GDL state terms into elements
+of the Toss structures in the following way.
+
+\begin{definition}
+We define the \emph{element mask equivalence} $\sim$ by:
+\[ t \sim s \quad \Leftrightarrow \quad
+ t[P_f \ot c] = s[P_f \ot c] \text{ for all terms } c.\]
+The set of elements $A$ of the initial Toss structure $\frakA$ consists
+of equivalence classes of $\sim$. For $a \in A$ we write $\lsem a \rsem$
+to denote the corresponding subset of equivalent terms from $\calS$.
+\end{definition}
+
+We define \emph{paths within mask} $\calP_m$ as such paths $p$ that,
+for all $a \in A$, if, for any $t \in \lsem a \rsem$, $t\tpos_p$,
+then for all $s,t\in \lsem a \rsem$, $s\tpos_p = t\tpos_p$.
+For $p \in \calP_m$ we can therefore define
+the \emph{mask subterm} $a\tpos^m_p$ as $t\tpos_p$ for $t \in \lsem a \rsem$.
+
+\begin{example}
+Continuing the example of the Tic-tac-toe specification
+from Figure~\ref{fig-ttt-gdl}, we construct the set $A$.
+The terms in $\calS$ are either $(\mathtt{cell}\ s\ t\ p)$ or
+$(\mathtt{control}\ q)$, where $s$ and $t$ range over \texttt{a, b, c},
+$p$ over \texttt{x, o, b} and $q$ can be \texttt{x} or \texttt{o}.
+Since $\calP_f = \{(\mathtt{cell},3), (\mathtt{control},1)\}$,
+we consider as $\sim$-equivalent all \texttt{cell} terms which differ
+only on $p$ and all \texttt{control} terms which differ on $q$.
+Thus, the set $A$ consists of $10$ elements: the element $a_{ctrl}$ for
+the single equivalence class of \texttt{control} terms, and $9$ elements
+$a_{s,t}$ for the equivalence classes of $(\mathtt{cell}\ s\ t\ p)$ with
+fixed $s$ and $t$. %We can write this set as follows
+\begin{align*}
+ A \ = \ \{ a_{ctrl}, \quad
+ & a_{\mathtt{a},\mathtt{a}},\ a_{\mathtt{a},\mathtt{b}},\ a_{\mathtt{a},\mathtt{c}}, \\
+ & a_{\mathtt{b},\mathtt{a}},\ a_{\mathtt{b},\mathtt{b}},\ a_{\mathtt{b},\mathtt{c}}, \\
+ & a_{\mathtt{c},\mathtt{a}},\ a_{\mathtt{c},\mathtt{b}},\ a_{\mathtt{c},\mathtt{c}} \}.
+\end{align*}
+Note the similarity to the starting structure in Figure~\ref{fig-tic-tac-toe},
+up to the control element. The set of paths within masks for this specification
+is $\calP_m = \{(\mathtt{cell},1), (\mathtt{cell},2)\}$.
+\end{example}
+
+
+\subsection{Relations in the Structure} \label{subsec-rels}
+
+Having defined the elements $A$ as equivalence classes of state terms,
+let us now define the relations in the initial structure $\frakA$.
+
+\vskip 0.5em
+\noindent \textbf{Subterm equality relations.}
+For all pairs of paths $p,q \in \calP_m$ we introduce
+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{Anchor predicates.}
+For all paths $p \in \calP_m$ and subterms $s = t\tpos_p, t \in \calS$,
+we introduce the \emph{anchor predicate} $Anch^s_p(a)$:
+\[ Anch^s_p(a) \ \ \iff \ \ a\tpos^m_p\ =\ s. \]
+
+\noindent \textbf{Fluent predicates.}
+Let $\calS^{\text{init}} = \{ s \mid \mathtt{init}(s) \in G \}$
+be the set of state terms under \texttt{init}. For all paths
+$p \in \calP_f$ and subterms $s = t\tpos_p, t \in \calS$,
+we introduce the \emph{fluent predicate} $Flu^s_p(a)$:
+\[ Flu^s_p(a) \ \ \iff \ \ t\tpos_p\ =\ s \text{ for some }
+ t \in \lsem a \rsem \cap \calS^{\text{init}}. \]
+
+\noindent \textbf{Mask predicates.}
+We say that a term $m$ is a \emph{mask term} if the paths to all variables
+of $m$ are contained in $\calP_m \cup \calP_f$ and for each
+$p \in \calP_m \cup \calP_f$ if $p$ exists in $m$ then $m \tpos_p$ is
+a variable. We say that $m$ \emph{masks} a terms $t$ if there exists
+a substitution $\sigma$ such that $\sigma(m) = t$. For all mask terms
+$m \in \calS$ we introduce the \emph{mask predicate} $Mask_m$.
+Mask predicates are similar to the anchor predicates, but instead of
+matching against a subterm, they match against the mask.
+\[ Mask_m(a) \ \ \iff \ \ m \text{ masks all } t \in \lsem a \rsem. \]
+
+%Elements $a \in A$ can be represented as tuples consisting of a mask
+%term $m_a$ such that $Mask_{m_a}(a)$ and terms $s_p = a\tpos^m_p$ for
+%every within mask path $p \in \calP_m$ in $m$.
+
+\begin{example}
+To list the relations derived for the Tic-tac-toe specification, recall that
+$\calP_m = \{(\mathtt{cell},1), (\mathtt{cell},2)\}$ consists of two paths.
+To shorten notation, we will just use the index $i$ for $(\mathtt{cell},i)$.
+
+\emph{Subterm equality relations.}
+The relation $Eq_{i, j}$ contains all pairs of elements for which
+the $i$th coordinate of the first one equals the $j$th coordinate
+of the second one. For example
+\begin{align*}
+ Eq_{1,1} = \{
+ & (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{a}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{b}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{c}}), \\
+ & \dots \\
+ & (a_{\mathtt{c},\mathtt{c}}, a_{\mathtt{c},\mathtt{a}}),
+ (a_{\mathtt{c},\mathtt{c}}, a_{\mathtt{c},\mathtt{b}}),
+ (a_{\mathtt{c},\mathtt{c}}, a_{\mathtt{c},\mathtt{c}}) \}
+\end{align*}
+describes the identity of the first coordinate of two cells.
+%which on Figure~\ref{fig-ttt} would be pairs of elements in the same row.
+
+
+\emph{Fact relations.}
+The only predicate in the example specification is \texttt{nextcol}
+and we thus get the relations $\mathtt{nextcol}_{i, j}$.
+For example, the relation
+\begin{align*}
+ \mathtt{nextcol}_{2,2} = \{
+ & (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{b}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{b},\mathtt{b}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{c},\mathtt{b}}), \\
+ & \dots, \\
+ & (a_{\mathtt{c},\mathtt{b}}, a_{\mathtt{a},\mathtt{c}}),
+ (a_{\mathtt{c},\mathtt{b}}, a_{\mathtt{b},\mathtt{c}}),
+ (a_{\mathtt{c},\mathtt{b}}, a_{\mathtt{c},\mathtt{c}}) \}
+\end{align*}
+contains pairs in which the second element is in the successive row
+of the first one. Note that, for example, the formula
+$Eq_{1,1}(x_1,x_2) \land \mathtt{nextcol}_{2,2}(x_1,x_2)$
+specifies that $x_2$ is directly right of $x_1$ in the same row.
+
+\emph{Anchor predicates.}
+Since the terms inside \texttt{cell} at positions $1$ and $2$ range
+over \texttt{a, b, c}, we get $6$ anchor predicates
+$Anch^{\mathtt{a}}_{i}, Anch^{\mathtt{b}}_{i}, Anch^{\mathtt{c}}_{i}$ for $i=1,2$.
+They mark the corresponding terms, \eg
+\[
+ Anch^{\mathtt{a}}_{2} \ = \ \{
+ a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{b},\mathtt{a}}, a_{\mathtt{c},\mathtt{a}} \}
+\]
+describes the bottom row.
+
+\emph{Fluent predicates.}
+The fluent paths $\calP_f = \{(\mathtt{cell},3), (\mathtt{control},1)\}$ and
+the terms appearing there are \texttt{b, x, o} for $(\mathtt{cell},3)$ and
+\texttt{x, o} for $(\mathtt{control},1)$, resulting in $5$ fluent predicates.
+For example, $Flu^{\mathtt{o}}_{(\mathtt{cell},3)}(a)$ will hold exactly for
+the elements $a$ which are marked by the player $\mathtt{o}$.
+In the initial structure, the only nonempty fluent predicates are
+\[ Flu^{\mathtt{b}}_{(\mathtt{cell},3)} = A \setminus \{a_{ctrl}\} \ \
+ \text{ and } \ \ Flu^{\mathtt{x}}_{(\mathtt{control},1)} = \{a_{ctrl}\}. \]
+
+\emph{Mask predicates.}
+For the specification we consider, there are two mask terms:
+$m_1 = (\mathtt{control}\ x)$ and $m_2 = (\mathtt{cell}\ x\ y\ z)$.
+The predicate $Mask_{m_1} \ = \ \{ a_{ctrl} \}$ holds exactly for
+the control element, and $Mask_{m_2} = A \setminus \{a_{ctrl}\}$ contains these
+elements of $A$ which are not the control element, \ie the board elements.
+\end{example}
+
+In Toss, \emph{stable relations} are relations that do not change in
+the course of the game, and \emph{fluents} are relations that do
+change. Roughly speaking, a fluent occurs in the symmetric
+difference of the sides of a structure rewrite rule.
+In the translation, the fluent predicates $Flu^s_p$ are the only
+introduced fluents, \ie these predicates will change when players
+play the game and all other predicates will remain intact.
+
+
+%Let $\calM$ be any legal state of $G$. Let $\calS^\calM \coloneq \{s |
+%true(s) \in \calM \}$ be the set of state terms at state $\calM$, note
+%that $\calS = \bigcup_\calM \calS^\calM$.
+%
+%We will introduce the interpretation $\lsem \cdot \rsem^\calM_I$ of
+%formulas with respect to $\calM$ under an assignment of
+%variables $I : V \rightarrow A$, to describe the translation (which
+%goes in the opposite direction) declaratively.
+%
+%\begin{definition}
+% $\lsem Flu^s_p(x) \rsem ^\calM_I$ iff there exists $t \in \lsem
+% I(x) \rsem \cap \calS^\calM$ such that $t\tpos_p = s$.
+%
+% For other atoms $R(x_1,\ldots,x_n)$, $\lsem R(x_1,\ldots,x_n)
+% \rsem^\calM_I$ iff $R(I(x_1),\ldots,I(x_n)) \in \frakA$.
+%
+% $\lsem \cdot \rsem^\calM_I$ extends naturally to any
+% formulas.
+%\end{definition}
+
+\subsection{Structure Rewriting Rules}
+
+To create the structure rewriting rule for the Toss game,
+we first construct two types of clauses and then transform
+them into structure rewriting rules. Let $(p_1,\ldots,p_n)$
+be the players in $G$, \ie let there be \texttt{(role $p_1$)}
+up to \texttt{(role $p_n$)} facts in $G$, in this order.
+
+
+\subsubsection{Move Clauses}
+
+By GDL specification, a legal joint move of the players is a tuple of
+player term -- move term pairs which satisfy the \texttt{legal}
+relation. For a joint move $(m_1,\ldots,m_n)$ to be allowed,
+it is necessary that there is a tuple of \texttt{legal}
+clauses $(\calC_1,...,\calC_n)$, with head of $\calC_i$ being
+\texttt{(legal $p_i$ $l_i$)}, and the \texttt{legal} arguments tuple
+being more general than the joint move tuple, \ie
+$m_i \leq l_i$ for each $i = 1, \ldots, n$.
+
+The move transition is computed from the \texttt{next}
+clauses whose all \texttt{does} relations are matched by respective
+joint move tuple elements as follows.
+
+\begin{definition}
+Let $\calN$ be a \texttt{next} clause. The \emph{$\calN$ does facts},
+$d_1(\calN), \ldots, d_n(\calN)$, are terms, one for each player,
+constructed from $\calN$ in the following way.
+Let \texttt{(does $p_i$ $d_i^j$)} be all \texttt{does} facts in $\calN$.
+\begin{itemize}
+\item If there is exactly one $d_i$ for player $p_i$ we set
+ $d_i(\calN) = d_i$.
+\item If there is no \texttt{does} fact for player $p_i$ in $\calN$
+ we set $d_i(\calN)$ to a fresh variable.
+\item If there are multiple $d_i^1, \dots, d_i^k$ for player $p_i$ we
+ compute $\sigma = \mgu(d_i^1, \dots, d_i^k)$ and set
+ $d_i(\calN) = \sigma(d_i^1)$.
+\end{itemize}
+\end{definition}
+
+
+We have $m_i \leq d_i(\calN)$ for each \texttt{next} clause $\calN$
+contributing to the move transition, since otherwise the body of $\calN$
+would not match the state enhanced with \texttt{(does $p_i$ $m_i$)} facts.
+
+\begin{example}
+In the Tic-tac-toe example, there are three clauses where the control player
+is \texttt{o}, which after renaming of variables look as follows.
+\begin{align*}
+\calN_1 = \mathtt{(<=\ (} & \mathtt{next\ (control\ x))\ (does\ x\ noop))},\\
+\calN_2 = \mathtt{(<=\ (} & \mathtt{next\ (cell\ ?x2\ ?y2\ o))} \\
+ & \mathtt{(does\ o\ (mark\ ?x2\ ?y2)))}, \\
+\calN_3 = \mathtt{(<=\ (} & \mathtt{next\ (cell\ ?x3\ ?y3\ ?c))} \\
+ & \mathtt{(true\ (cell\ ?x3\ ?y3\ ?c))} \\
+ & \mathtt{(does\ o\ (mark\ ?x1\ ?y1))} \\
+ & \mathtt{(or\ (distinct\ ?x3\ ?x1)\ (distinct\ ?y3\ ?y1)))}.
+\end{align*}
+The does facts are, respectively,
+\begin{align*}
+& d_1(\calN_1) = \mathtt{noop} & \text{ and } & \quad
+ d_2(\calN_1) = x_{f_1},\\
+& d_1(\calN_2) = x_{f_2} & \text{ and } & \quad
+ d_2(\calN_2) = (\mathtt{mark}\ x_2\ y_2),\\
+& d_1(\calN_3) = x_{f_3} & \text{ and } & \quad
+ d_2(\calN_3) = (\mathtt{mark}\ x_1\ y_1).
+\end{align*}
+\end{example}
+
+Each rewrite rule of the translated game is generated from a tuple of
+\texttt{legal} clauses $\calC_1,\ldots,\calC_n$ and a selection of
+\texttt{next} clauses $\calN_1,\ldots,\calN_m$, with variables renamed
+so that no variable occurs in multiple clauses, and such that
+\[ l_i \ \dot{=} \ d_i(\calN_1) \ \dot{=} \ \dots \ \dot{=} \ d_i(\calN_m) \]
+for each player $p_i$. We will consider all tuples $\ol{\calC}, \ol{\calN}$
+for which the the above MGU exists and we will denote it by
+$\sigma_{\ol{\calC},\ol{\calN}}$. We apply $\sigma_{\ol{\calC},\ol{\calN}}$
+to the clauses and we will refer to the result simply as
+\emph{the \texttt{legal} and \texttt{next} clauses of the rule}.
+
+Technically, for completeness, we need to generate a rule for a set of
+\texttt{next} clauses even if we generate a rule for its superset, and
+then for correctness, we need to preclude application of the first
+(more general) rule when the more concrete rule is applicable, adding
+\texttt{distinct} conditions to clauses of the otherwise more general
+rule. In the current implementation, we only consider maximal sets of
+\texttt{next} clauses.
+
+\begin{example}
+Let $\calC_1 = \mathtt{noop}$ and $\calC_2 = (\mathtt{mark}\ x\ y)$.
+The clauses $\calN_1, \calN_2, \calN_3$ introduced above form a maximal set,
+\begin{align*}
+\sigma_{\ol{\calC},\ol{\calN}} = \{
+ & x_{f_1} \mapsto (\mathtt{mark}\ x\ y),\quad x_{f_2} \mapsto \mathtt{noop},\\
+ & x_2 \mapsto x,\quad y_2 \mapsto y,\quad
+ x_1 \mapsto x,\quad y_1 \mapsto y \}.
+\end{align*}
+\end{example}
+
+With all tuples $\ol{\calC}, \ol{\calN}$ selected and the MGU
+$\sigma_{\ol{\calC},\ol{\calN}}$ computed, we are almost ready to construct
+the rewriting rules. Still, for a fixed tuple $\ol{\calC}, \ol{\calN}$,
+we first need to compute erasure clauses to prevent constructing
+too general rules in the end.
+
+
+\subsubsection{Erasure Clauses}
+
+So far, we have not accounted for the fact that rewrite rules of Toss
+only affect the matched part of the structure, while the GDL game
+definition explicitly describes the construction of the whole successive
+structure. We will say that a \texttt{next} clause is a \emph{frame clause}
+if and only if it contains a \texttt{true} relation applied to a term
+equal to the \texttt{next} argument. Negating the frame clauses from
+the tuple $\ol{\calN}$ and transforming them into \emph{erasure clauses}
+will keep track of the elements that possibly lose fluents and ensure
+correct translation.
+
+From the frame clauses in $\sigma_{\ol{\calC}, \ol{\calN}}(\calN_1), \dots,
+\sigma_{\ol{\calC}, \ol{\calN}}(\calN_m)$, we select all (maximal) subsets $J$
+such that, clauses in $J$ having the form $\mathtt{(<= (next\ s_i)\ b_i)}$,
+it holds
+\[ s_1 \ \dot{=}_f \ \ldots \ \dot{=}_f \ s_{|J|}, \]
+\ie the arguments of \texttt{next} unify. Note that we use $\dot{=}_f$
+instead of the standard unification, and by that we mean that the variables
+shared with the \texttt{legal} clauses $\ol{\calC}$ are treated as constants.
+The reason is that these variables are not local to the clauses and must
+therefore remain intact.
+
+Intuitively, the selected sets $J$ describe a partition of the state terms
+that could possibly be copied without change by the rule we will generate
+for $\ol{\calC}, \ol{\calN}$.
+
+Let us write $\rho$ for the $f$-MGU of $s_1, \dots, s_{|J|}$.
+To compute the bodies of the erasure clauses, we negate the disjunction
+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
+$\calE_{\ol{\calC}, \ol{\calN}}(J)$, \ie for the set of all
+$\ol{\calC}, \ol{\calN}$ erasure clauses.
+
+
+\begin{example}
+In our example, $\calN_3$ and its counterpart for the other player
+are the only frame clauses in $G$. After negation, $\sigma(\calN_3)$
+splits into several clauses $e_i$. The relevant one is
+\texttt{(<= (next (cell ?x3 ?y3 ?c)) (?x3 = ?x) (?y3 = ?y))}, \ie
+\texttt{(<= (next (cell ?x ?y ?c)))}. The resulting erasure clause is
+\texttt{(<= (next (cell ?x ?y BLANK)))}. If no other clause had
+the form \texttt{(<= (next (cell ?x ?y ...)) ...)}, this clause would
+cause the erasure of any fluent at coordinates $(x,y)$. Other erasure clauses
+derived from $\sigma(\calN_3)$ turn out to be contradictory with remaining
+clauses, and thus will not contribute to any rewrite rule in the
+translation, due to filtering described below.
+\end{example}
+
+
+\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 a given a partition of GDL atoms into true and false ones,
+we will construct the candidate rule in two steps.
+
+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.
+
+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.
+
+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.
+
+
+\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$
+into Toss rule embeddings for $T(G)$, and conversely,
+the rule embeddings from $T(G)$ into moves of $G$.
+
+In the incoming move case, we augment the Toss rewrite rules with constraints
+provided in the incoming move, try to embed each of the augmented
+rules, and return the single rule that matches and its unique embedding.
+Augmenting the rule is done in the following simple way:
+If the head of a \texttt{legal} clause of the rule contains
+a variable $v$ at path $q$, a Toss variable $x$ was derived from
+a game state term $t$ such that $t\tpos_p = v$, and the incoming move
+has term $s$ at path $q$, then we add $Anch^s_p(x)$ to the precondition.
+
+To translate the outgoing move, we recall the heads of the
+\texttt{legal} clauses of the rule that is selected, as we only need to
+substitute all their variables. To eliminate a variable $v$ contained in
+the head of a \texttt{legal} clause of the rule, we look at the rule
+embedding; if $x\mapsto a$, $x$ was derived from a game state term $t$
+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.
+
+
+\section{Game Simplification in Toss}
+
+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.
+%and some of the introduced ones are not sparse.
+
+Both problems are remedied by joining co-occurring relations. Relations
+which always occur together in a conjunction are replaced by their join
+when they are over the same tuple. Analogically, we eliminate pairs of
+atoms when the arguments of one relation are reversed arguments of the other.
+
+In an additional simplification, we remove an atom of a stable relation
+which is included in, or which includes, another relation, when an atom of
+the other relation already states a stronger fact. For example, if
+$Positive \subseteq Number$, then $Positive(x) \wedge Number(x)$
+simplifies to $Positive(x)$, and $Positive(x) \vee Number(x)$
+simplifies to $Number(x)$.
+
+The above simplifications can be applied to any Toss definition.
+We perform one more simplification targeted specifically at translated
+games: We eliminate $Eq_{p,q}(x,y)$ atoms when we detect that
+$Eq_{p,q}$-equivalence of $x$ and $y$ can be deduced from the
+remaining parts of the formula. % being simplified.
+
+The described simplifications are stated in terms of manipulating
+formulas; besides formulas, we also apply analogous simplifications to
+the structures of the Toss game: the initial game state structure, and
+the $\frakL$ and $\frakR$ structures of the rules.
+
+
+
+
+
\chapter{Design}
\section{Organization of Code}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-27 17:44:43
|
Revision: 1423
http://toss.svn.sourceforge.net/toss/?rev=1423&view=rev
Author: lukstafi
Date: 2011-04-27 17:44:35 +0000 (Wed, 27 Apr 2011)
Log Message:
-----------
FormulaOps: satisfiability check in [remove_redundant]. GameSimpl: better glueing, bug fixes. GDL translation: two options for stronger pruning (for experiments); fix translating sets of clauses: when they are interpreted conjunctively, instead of filtering, raise [Unsatisfiable] if any branch is not satisfiable.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/GameSimpl.mli
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
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Server/ServerTest.ml
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -1019,6 +1019,12 @@
let rewritable args =
Aux.array_for_all (fun v -> List.mem (Formula.var_str v) struc_elems)
args in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ FormulaOps.set_debug_level !debug_level;
+ Printf.printf "translate_from_precond:\n%!"
+ );
+ (* }}} *)
let conjs =
FormulaOps.flatten_ands (FormulaOps.remove_redundant precond) in
let posi, conjs = Aux.partition_map (function
@@ -1031,18 +1037,19 @@
Left (rel,args)
| phi -> Right phi) conjs in
let lhs_extracted = posi @ nega in
- let precond = Formula.And conjs in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "translate_from_precond:\nposi=\n%s\nnega=\n%s\nprecond=\n%s\n%!"
+ "translate_from_precond:\nposi:\n%s\nnega:\n%s\norig-precond:\n%s\nsimpl-precond:%s\n%!"
(Formula.sprint (Formula.And (List.map (fun (rel,args) ->
Formula.Rel (rel,args)) posi)))
(Formula.sprint (Formula.And (List.map (fun (rel,args) ->
Formula.Rel (rel,args)) nega)))
(Formula.sprint precond)
+ (Formula.sprint (Formula.And conjs))
);
(* }}} *)
+ let precond = Formula.And conjs in
let fvars = FormulaOps.free_vars precond in
let local_vars =
List.filter (fun v->
@@ -1096,6 +1103,12 @@
let rhs_struc = add_rels rhs_struc add in
let lhs_struc = add_rels lhs_struc posi_s in
let lhs_struc = add_rels lhs_struc opt_s in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ FormulaOps.set_debug_level 0;
+ Printf.printf "translate_from_precond: end\n%!"
+ );
+ (* }}} *)
{
lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/Aux.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -54,6 +54,9 @@
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
+let map_fst f (a,b) = f a, b
+let map_snd f (a,b) = a, f b
+
module BasicOperators = struct
let (-|) f g x = f (g x)
let (<|) f x = f x
@@ -306,6 +309,24 @@
done;
res
+let array_mapi_some f a =
+ let r = Array.mapi f a in
+ let rl = ref (Array.length r) in
+ for i=0 to Array.length a - 1 do
+ if r.(i) = None then decr rl
+ done;
+ if !rl = 0 then [||]
+ else
+ let pos = ref 0 in
+ while r.(!pos) = None do incr pos done;
+ let res = Array.create !rl (unsome r.(!pos)) in
+ incr pos;
+ for i=1 to !rl -1 do
+ while r.(!pos) = None do incr pos done;
+ res.(i) <- unsome r.(!pos); incr pos
+ done;
+ res
+
let array_map2 f a b =
let l = Array.length a in
if l <> Array.length b then
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/Aux.mli 2011-04-27 17:44:35 UTC (rev 1423)
@@ -39,6 +39,9 @@
val snd3 : 'a * 'b * 'c -> 'b
val trd3 : 'a * 'b * 'c -> 'c
+val map_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
+val map_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
+
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
@@ -187,6 +190,7 @@
(** Map an array filtering out some elements. *)
val array_map_some : ('a -> 'b option) -> 'a array -> 'b array
+val array_mapi_some : (int -> 'a -> 'b option) -> 'a array -> 'b array
(** Map a function over two arrays index-wise. Raises
[Invalid_argument] if the arrays are of different lengths. *)
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -954,9 +954,13 @@
track of the sign (variance) of a position. (Does not descend the
real part currently.) [implies] is applied to atoms only. Repeat
the removal till fixpoint since it can "unpack" literals e.g. from
- conjunctions to disjunctions.
+ 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
+ returned instead. *)
let remove_redundant ?(implies=(=)) phi =
let implied_by x y = implies y x in
let literal neg phis =
@@ -983,6 +987,17 @@
(String.concat "; " (List.map Formula.str more_negbase))
);
(* }}} *)
+ (* detect contradiction *)
+ List.iter (fun prem ->
+ List.iter (fun concl ->
+ if implies prem concl
+ then raise Unsatisfiable
+ ) more_negbase) (more_posbase @ posbase);
+ List.iter (fun prem ->
+ List.iter (fun concl ->
+ if implies prem concl
+ then raise Unsatisfiable
+ ) (more_negbase @ negbase)) more_posbase;
(* remove redundant *)
let more_posbase = List.filter
(fun more -> not (List.exists (implied_by more) posbase))
@@ -1038,8 +1053,14 @@
(String.concat "; " (List.map Formula.str neglits))
);
(* }}} *)
- literal neg poslits @ literal (not neg) neglits @
- List.map (aux posbase negbase neg) subtasks
+ let subresults =
+ Aux.map_some (fun disj ->
+ try Some (aux posbase negbase neg disj)
+ with Unsatisfiable -> None) subtasks in
+ let results =
+ literal neg poslits @ literal (not neg) neglits @ subresults in
+ if results = [] then raise Unsatisfiable
+ else results
and aux posbase negbase neg = function
| And conjs when not neg ->
@@ -1065,7 +1086,8 @@
(* }}} *)
let res = aux [] [] false (flatten_formula phi) in
if res = phi then res else fixpoint res in
- fixpoint phi
+ try fixpoint phi
+ with Unsatisfiable -> Or []
(* Compute size of a formula (currently w/o descending the real part). *)
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-04-27 17:44:35 UTC (rev 1423)
@@ -174,7 +174,9 @@
track of the sign (variance) of a position. (Does not descend the
real part currently.) [implies] is applied to atoms only. Repeat
the removal till fixpoint since it can "unpack" literals e.g. from
- conjunctions to disjunctions. *)
+ conjunctions to disjunctions. Also perform a very basic check for
+ satisfiability. Returns [Or []] if the formula is obviously
+ unsatisfiable (does not do any unification). *)
val remove_redundant :
?implies:(formula -> formula -> bool) -> formula -> formula
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/GGP/GDL.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -60,8 +60,7 @@
processed in (3a)-(3b) are already expanded by (6).
(3a) Element terms are collected from the aggregate playout: the
- sum of state terms (the "control" function could be dropped but we
- are not taking the effort to identify it).
+ sum of state terms.
(3b) Element masks are generated by generalization from all "next"
rules where the "does" relations are expanded by all unifying
@@ -80,11 +79,19 @@
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
@@ -133,6 +140,9 @@
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
@@ -190,8 +200,9 @@
/\ not exist vars_n (args = params_n /\ body_n)]
(6b1) If the relation has negative subformulas in any of [body_i],
- we first negate the definition and then expand the negation as in
- the positive case.
+ 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.
@@ -298,10 +309,16 @@
contain some fixed variables or no variables at all, and other
containing only unfixed variables.
- (7f1) Branches with (only) unfixed variables in "next" atoms that
- are "identities" are the "frame" branches. "Identity" here means
- the "next" atom is equal to one of the positive "true" atoms.
+ (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),
@@ -319,6 +336,10 @@
(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.)
@@ -326,11 +347,11 @@
substituted with the "not distinct" unifier to proper equivalence
classes (remove equivalence classes that become empty).
- (7g) Instantiate remaining unfixed variables: Duplicate non-frame
- rules with unfixed variables for each instantiation of the unfixed
- variables warranted by the aggregate playout. (Perhaps can be done
- "symbolically" to avoid explosion.)
+ (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
@@ -368,9 +389,13 @@
subterms that instantiate (ordinary) variables in the mask
corresponding to the "next"/"true" atom.
- (7i0) Heuristic (reason for unsoundness): for "distinct", only
- check whether its arguments are syntactically equal.
+ (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.
@@ -408,8 +433,12 @@
(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).
+ 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
@@ -420,26 +449,50 @@
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).
+ translated game when making a move). The lattice is built by
+ summing rule bodies.
- (7l1) Since all variables are fixed, the lattice is built by
- summing rule bodies. To avoid contradictions and have a complete
- partition, we construct the set of all bit vectors indexed by all
- atoms occurring in the bodies. With every index-bit value we
- associate the set of branches that do not allow such literal. For
- every vector we calculate the complement of the sum of branch sets
- associated with every bit. The unique resulting sets are exactly
- the Toss rules precursors. Heuristic (FIXME: needed?): We only use
- atoms that are deterministically present or absent in at least
- some branch for indexing.
+ (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.
- (7l3) Filter out rule candidates that contradict all states
+ 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).
@@ -537,15 +590,50 @@
let debug_level = ref 0
let aggregate_drop_negative = ref false
let aggregate_fixpoint = ref true
-(** Expand static relations that do not have ground facts and have
- arity above the threshold. *)
+
+(** Expand static relations that do not have ground facts, are not
+ directly recursive, and have arity above the threshold. *)
let expand_arity_above = ref 0
-(** Generate all tuples for equivalences, to faciliate further
+(** Treat "next" clauses which introduce metavariables only for
+ variable-variable mismatch, as non-erasing frame clauses (to be
+ ignored). ("Wave" refers to the process of "propagating the frame
+ condition" that these clauses are assumed to do, if
+ [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
@@ -658,6 +746,7 @@
and terms_vars args =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map term_vars args)
+
let fact_of_atom = function
| Distinct args -> assert false
@@ -722,6 +811,34 @@
module Atoms = Set.Make (
struct type t = string * term list let compare = Pervasives.compare end)
+
+let lit_def_br_vars (head, body, neg_body : lit_def_branch) =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map terms_vars
+ (head::List.map snd body @
+ List.map (snd -| snd) neg_body))
+
+let exp_def_br_vars (head, body, neg_body : exp_def_branch) =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map terms_vars
+ (head::List.map snd body @
+ Aux.concat_map (List.map snd -| snd) neg_body))
+
+let lit_def_brs_vars brs =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map lit_def_br_vars brs)
+
+let exp_def_brs_vars brs =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map exp_def_br_vars brs)
+
+let sdef_br_vars (head, body, neg_body) =
+ exp_def_br_vars ([head], body, neg_body)
+
+let sdef_brs_vars brs =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map sdef_br_vars brs)
+
(*
let branch_vars (args, body, neg_body) =
*)
@@ -935,27 +1052,27 @@
let fresh_count = ref 0 in
let rec loop pf terms1 terms2 =
match terms1, terms2 with
- | [], [] -> (0, 0), []
+ | [], [] -> (0, 0), [], []
| (Const a as cst)::terms1, Const b::terms2 when a=b ->
- let (good_vars, good_csts), gens = loop pf terms1 terms2 in
- (good_vars, good_csts+1), cst::gens
+ let (good_vars, good_csts), mism, gens = loop pf terms1 terms2 in
+ (good_vars, good_csts+1), mism, cst::gens
| Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
- let (good_vars1, good_csts1), gen_args = loop f args1 args2 in
- let (good_vars2, good_csts2), gens = loop pf terms1 terms2 in
- (good_vars1+good_vars2, good_csts1+good_csts2),
+ let (good_vars1, good_csts1), mism1, gen_args = loop f args1 args2 in
+ let (good_vars2, good_csts2), mism2, gens = loop pf terms1 terms2 in
+ (good_vars1+good_vars2, good_csts1+good_csts2), mism1 @ mism2,
(Func (f,gen_args))::gens
| (Var x as var)::terms1, Var y::terms2 when x=y ->
- let (good_vars, good_csts), gens = loop pf terms1 terms2 in
- (good_vars+1, good_csts), var::gens
- | _::terms1, _::terms2 ->
- let measure, gens = loop pf terms1 terms2 in
+ let (good_vars, good_csts), mism, gens = loop pf terms1 terms2 in
+ (good_vars+1, good_csts), mism, var::gens
+ | t1::terms1, t2::terms2 ->
+ let measure, mism, gens = loop pf terms1 terms2 in
incr fresh_count;
- measure, MVar ("MV"^string_of_int !fresh_count)::gens
+ measure, (t1,t2)::mism, MVar ("MV"^string_of_int !fresh_count)::gens
| _::_, [] | [], _::_ -> raise
(Lexer.Parsing_error
("GDL.generalize: arity mismatch at function "^pf)) in
- let measure, gens = loop "impossible" [term1] [term2] in
- measure, !fresh_count, List.hd gens
+ let measure, mism, gens = loop "impossible" [term1] [term2] in
+ measure, !fresh_count, mism, List.hd gens
(* 3c2 *)
let abstract_consts fresh_count term =
@@ -1215,8 +1332,8 @@
List.map map_rel body,
List.map map_neg neg_body
-let freshen_def_branches =
- List.map freshen_branch
+let freshen_def_branches brs =
+ List.map freshen_branch brs
(* [args] are the actual, instatiated, arguments. *)
let negate_def uni_vs args neg_def =
@@ -1270,8 +1387,10 @@
(* 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 > 4 then (
+ if !debug_level > 3 then (
Printf.printf "Expanding branch %s\n%!" (lit_def_str ("BRANCH", [br]));
);
(* }}} *)
@@ -1281,7 +1400,7 @@
(let try def =
freshen_def_branches (List.assoc rel defs) in
(* {{{ log entry *)
- if !debug_level > 4 then (
+ if !debug_level > 3 then (
Printf.printf "Expanding positive %s by %s\n%!" rel
(exp_def_str (rel, def))
);
@@ -1312,7 +1431,6 @@
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
@@ -1322,11 +1440,50 @@
(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%!"
@@ -1338,19 +1495,19 @@
(* 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)
+ (* {{{ 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 *)
@@ -1374,7 +1531,7 @@
) def
| None -> (* rel not in defs *)
[uni_vs, [atom]]
- ) neg_body_flat in
+ ) (more_neg_flat @ neg_body_flat) in
List.rev pos_sol, List.rev_append neg_sol more_neg_sol, sb
) sols in
let res =
@@ -1419,44 +1576,63 @@
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_args, legal_body, legal_neg_body : exp_def_branch)
- (head, body, neg_body : exp_def_branch)
+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
- Some (
- (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),
- (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)))
+ 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.concat_map (fun br ->
- List.map snd
- (Aux.map_some (fun def -> subst_legal_rule def br) 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 *)
@@ -1666,11 +1842,12 @@
(* Expand branch variables. If [freshen_unfixed=Right fixed], expand
- all variables that don't belong to [fixed]. If
- [freshen_unfixed=Left freshen], then expand all variables below
- meta-variables of masks. If [freshen] is true, rename other
- (i.e. non-expanded) variables while duplicating branches. (When
- [freshen] is false, all remaining variables should be fixed.)
+ 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???
@@ -1681,16 +1858,32 @@
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 is_inst_var =
- match freshen_unfixed with
- | Aux.Left _ ->
- let mask, sb, m_sb, blank = term_to_blank masks arg in
- let ivars = Aux.concat_map (fun (_,t) ->
- Aux.Strings.elements (term_vars t)) m_sb in
- (fun v -> List.mem v ivars)
- | Aux.Right fixed -> fun v -> not (List.mem v fixed) in
+ 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
@@ -1727,19 +1920,37 @@
(if head = Const "_IGNORE_RHS_" then [[], head]
else expand [] head)
| _ -> assert false) brs in
+ (* {{{ log entry *)
+if !debug_level > 4 then (
+ Printf.printf "expand_branch_vars: substitutions=\n%s\n%!"
+ (String.concat ";; " (List.map (sb_str -| fst) brs))
+);
+(* }}} *)
match freshen_unfixed with
| Aux.Left true ->
List.map (fun (sb, br) -> sb, freshen_branch br) brs
| _ -> brs
-let translate_branches struc masks playout_terms static_rnames dyn_rels
+(* (7l5)-related exception. *)
+exception Failed_branch
+
+let translate_branches ?(conjunctive=false) struc masks playout_terms
+ static_rnames dyn_rels
(brs : exp_def_branch list) =
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "Translating-branches:\n%s\n%!"
+ (exp_def_str ("translating", brs));
+ );
+ (* }}} *)
(* 7i *)
+ (* the state terms are positive, the relation can be positive or
+ negative -- negate atoms after generation if the atom was negative *)
let pos_conjs_4a pos_state_subterms (rel, args) =
let ptups = List.map (fun arg ->
Aux.assoc_all arg pos_state_subterms) args in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "pos_conjs_4a: of %s = subterms %s\n%!"
(fact_str (rel,args)) (String.concat "; " (
List.map (fun l -> String.concat ", "
@@ -1757,12 +1968,14 @@
Formula.Rel (rname, Array.of_list tup)) ptups in
let res = Aux.unique_sorted res in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "pos_conjs_4a: of %s = %s\n%!"
(fact_str (rel,args)) (Formula.str (Formula.And res))
);
(* }}} *)
res in
+ (* some of the state terms are always negative, the relation can be
+ positive or negative but always negate resulting atoms *)
let neg_conjs_4a pos_state_subterms
neg_state_terms neg_state_subterms (rel, args) =
let ptups = List.map (fun arg ->
@@ -1782,13 +1995,15 @@
Formula.Rel (rname, Array.of_list tup)) ptups in
let res = Aux.unique_sorted res in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "neg_conjs_4a: of %s = %s\n%!"
(fact_str (rel,args)) (Formula.str (Formula.And res))
);
(* }}} *)
res in
(* 7i-4b *)
+ (* FIXME: abandon filtering-out rendundant mask variables during
+ translation -- this is the job of GameSimplify! *)
let constrained_vars = ref [] in
let pos_conjs_4b pos_path_subterms =
Aux.unique_sorted (Aux.concat_map (fun ((mask, v), terms) ->
@@ -1813,6 +2028,8 @@
(* (4b) are equivalences, so we just build a "star" *)
match vars with [] -> []
| v::vs -> List.map (fun w -> [|v; w|]) vs in
+ if !equivalences_ordered then
+ List.iter (Array.sort Pervasives.compare) tups;
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
) pos_path_subterms) in
@@ -1843,6 +2060,8 @@
Aux.map_some (fun v ->
if v = ntossvar then None
else Some [|v; ntossvar|]) tossvars in
+ if !equivalences_ordered then
+ List.iter (Array.sort Pervasives.compare) tups;
List.map (fun tup -> Formula.Rel (rname, tup)) tups
| _ -> []
) pos_path_subterms in
@@ -1862,7 +2081,7 @@
) Terms.empty brs in
let pos_state_terms = Terms.elements pos_state_terms in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "pos_state_terms: %s\n%!"
(String.concat ", " (List.map term_str pos_state_terms))
);
@@ -1891,10 +2110,10 @@
let mask, sb, m_sb, blanked = term_to_blank masks next_arg in
let rname = term_to_name mask in
let _, svar = toss_var masks next_arg in
- if List.mem svar !constrained_vars then []
- else
- let phi = Formula.Rel (rname, [|svar|]) in
- [phi] in
+ (* if List.mem svar !constrained_vars then [] *)
+ (* else *)
+ let phi = Formula.Rel (rname, [|svar|]) in
+ [phi] in
let conjs =
Aux.concat_map (fun (rel, args as fact) ->
if rel = "true" then
@@ -1910,8 +2129,9 @@
| v, t as v_sb ->
let rname = term_to_name (subst_one v_sb mask) in
Some (Formula.Rel (rname, [|svar|]))) sb in
- if conjs <> [] || List.mem svar !constrained_vars
- then conjs else [phi]
+ phi::conjs
+ (* if conjs <> [] || List.mem svar !constrained_vars *)
+ (* then conjs else [phi] *)
else if List.mem rel static_rnames then
(* 7i-4a *)
pos_conjs_4a pos_state_subterms fact
@@ -1923,8 +2143,15 @@
let neg_conjs =
Aux.concat_map (function
| _, [rel, args as fact] ->
- if rel = "true" then []
- else if rel = "_DOES_PLACEHOLDER_"
+ if rel = "true" && !mask_anchors_of_neg = Positive_anch
+ then
+ (* 7i-4c *)
+ let true_arg = List.hd args in
+ let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
+ let rname = term_to_name mask in
+ let _, svar = toss_var masks true_arg in
+ [Formula.Rel (rname, [|svar|])]
+ else if rel = "true" || rel = "_DOES_PLACEHOLDER_"
then []
else if List.mem rel static_rnames then
(* 7i-4a *)
@@ -1932,6 +2159,7 @@
(pos_conjs_4a pos_state_subterms fact)
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -1940,27 +2168,43 @@
"translate_game: (7i) unexpected dynamic %s\n%!" rel;
assert false)
| _ -> []) neg_body in
- let all_conjs = phi @ conjs @ pconjs_4b @ neg_conjs in
- let phi = Formula.And all_conjs in
+ let all_conjs = phi @ conjs @ neg_conjs in
+ (* filter 4b not to do unnecessary work in solver *)
+ let used_vars = FormulaOps.free_vars (Formula.And all_conjs) in
+ let local_4b =
+ List.filter (fun f ->
+ List.for_all (fun v->List.mem v used_vars)
+ (FormulaOps.free_vars f)) pconjs_4b in
+ let phi = Formula.And (all_conjs @ local_4b) in
let phi = Formula.Ex (FormulaOps.free_vars phi, phi) in
(* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "evaluating:\nbranch=%s\nphi=%s\n%!"
+ if !debug_level > 4 then (
+ Printf.printf "translate-evaluating:\nbranch=%s\nphi=%s\n%!"
(exp_def_str ("eval", [br]))
- (Formula.str phi)
+ (Formula.sprint phi)
);
(* }}} *)
if Solver.M.check struc phi
then (
(* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "holds\n%!"
+ if !debug_level > 4 then (
+ Printf.printf "translate-holds\n%!"
);
(* }}} *)
Some (next_arg,body,neg_body))
- else None
+ else (
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "translate-doesn't hold\n%!"
+ );
+ (* }}} *)
+ if conjunctive
+ then raise Failed_branch
+ else None)
| _ -> assert false) brs in
+
(* 7j *)
+ (* FIXME: shouldn't the result of expansion be used? *)
let check_brs =
expand_branch_vars masks playout_terms
~freshen_unfixed:(Aux.Left false)
@@ -1971,7 +2215,7 @@
("GDL.translate_game: expanding variables resulting in "^
"duplicating Toss rules not implemented yet");
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "Filtered-branches:\n%s\n%!"
(exp_def_str ("filtered",
List.map (fun (next_arg,body,neg_body) ->
@@ -1994,7 +2238,7 @@
) Terms.empty brs in
let pos_state_terms = Terms.elements pos_state_terms in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "pos_state_terms: %s\n%!"
(String.concat ", " (List.map term_str pos_state_terms))
);
@@ -2022,10 +2266,10 @@
let mask, sb, m_sb, blanked = term_to_blank masks next_arg in
let rname = term_to_name mask in
let _, svar = toss_var masks next_arg in
- if List.mem svar !constrained_vars then []
- else
- let phi = Formula.Rel (rname, [|svar|]) in
- [phi] in
+ (* if List.mem svar !constrained_vars then [] *)
+ (* else *)
+ let phi = Formula.Rel (rname, [|svar|]) in
+ [phi] in
let conjs =
Aux.concat_map (fun (rel, args as fact) ->
if rel = "true" then
@@ -2041,8 +2285,9 @@
| v, t as v_sb ->
let rname = term_to_name (subst_one v_sb mask) in
Some (Formula.Rel (rname, [|svar|]))) sb in
- if conjs <> [] || List.mem svar !constrained_vars
- then conjs else [phi]
+ phi::conjs
+ (*if conjs <> [] || List.mem svar !constrained_vars
+ then conjs else [phi] *)
else if List.mem rel static_rnames then
(* 7i-4a *)
pos_conjs_4a pos_state_subterms fact
@@ -2063,6 +2308,7 @@
(pos_conjs_4a pos_state_subterms fact)
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -2106,6 +2352,7 @@
then []
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -2113,6 +2360,36 @@
(* dynamic relations have been expanded *)
assert false)
) body in
+ let pos_of_neg_conjs =
+ Aux.concat_map (function
+ | _, [rel, args (* as fact *)] ->
+ if rel = "true" && !mask_anchors_of_neg = Positive_anch
+ then
+ (* 7i-4c *)
+ let true_arg = List.hd args in
+ let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
+ let rname = term_to_name mask in
+ let _, svar = toss_var masks true_arg in
+ [Formula.Rel (rname, [|svar|])]
+ else []
+ (* FIXME: is the rest handled properly as [neg_conjs]? *)
+ (*if rel = "true" || rel = "_DOES_PLACEHOLDER_"
+ then []
+ else if List.mem rel static_rnames then
+ (* 7i-4a *)
+ List.map (fun c -> Formula.Not c)
+ (pos_conjs_4a pos_state_subterms fact)
+ else if rel = "distinct" then
+ (* 7i0 *)
+ (* TODO! *)
+ if Aux.not_unique args then [Formula.Or []]
+ else []
+ else (
+ (* dynamic relations have been expanded *)
+ Printf.printf
+ "translate_game: (7i) unexpected dynamic %s\n%!" rel;
+ assert false)*)
+ | _ -> []) neg_body in
let neg_conjs =
Aux.map_some (fun (local_vs, neg_conjs) ->
(* 7k-4a-1 *)
@@ -2170,6 +2447,8 @@
| Pairs_star ->
match vars with [] -> []
| v::vs -> List.map (fun w -> [|v; w|]) vs in
+ if !equivalences_ordered then
+ List.iter (Array.sort Pervasives.compare) tups;
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
) neg_path_subterms in
@@ -2205,7 +2484,9 @@
Formula.Rel (rname, [|svar|])) m_sb in
let conjs =
conjs_4b @ conjs_4c @ conjs_5 in
- if conjs = [] then [phi] else conjs
+ if conjs = [] && !mask_anchors_of_neg = Negative_anch
+ then [phi]
+ else conjs
else if rel = "_DOES_PLACEHOLDER_"
then []
else if List.mem rel static_rnames then
@@ -2223,6 +2504,7 @@
conjs_4a_2 @ conjs_4a_3
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -2241,7 +2523,8 @@
else Formula.Not (Formula.Ex (
(uni_toss_vars :> Formula.var list), phi))) res
) neg_body in
- let all_conjs = !static_conjs @ dyn_conjs @ neg_conjs in
+ let all_conjs =
+ !static_conjs @ dyn_conjs @ pos_of_neg_conjs @ neg_conjs in
(rhs_pos_preds, !static_conjs, all_conjs),
(next_arg, body, neg_body)) brs in
pconjs_4b, brs
@@ -2373,7 +2656,9 @@
let static_rules, exp_static_rules =
List.partition (fun ((rel,args), _, _) ->
List.length args <= !expand_arity_above ||
- List.exists (function ((r,_),[],[]) when rel=r-> true
+ List.exists (function
+ | ((r,_),[],[]) when rel=r-> true
+ | ((r,_),body,_) when rel=r && List.mem_assoc r body-> true
| _ -> false) static_rules
) static_rules in
(* {{{ log entry *)
@@ -2385,6 +2670,7 @@
let static_exp_defs = expand_def_rules exp_static_rules in
let static_rules = Aux.unique_sorted
(List.map Aux.fst3 static_rules) in
+ let static_rnames = List.map fst static_rules in
let exp_defs =
expand_def_rules ~more_defs:static_exp_defs dynamic_rules in
@@ -2399,18 +2685,33 @@
let next_rules = List.assoc "next" exp_defs in
let terminal_rules = List.assoc "terminal" exp_defs in
let goal_rules = List.assoc "goal" exp_defs in
+ let legal_rules =
+ Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule]
+ | [Var v; lterm], body, neg_body ->
+ Array.to_list
+ (Array.map (fun player ->
+ let sb = [v, player] in
+ [player; subst sb lterm],
+ subst_rels sb body,
+ List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body)
+ player_terms)
+ | [Func _; lterm], _, _ ->
+ (* TODO: easy to fix *)
+ failwith "GDL.translate_game: bigger player terms not handled yet"
+ | _ -> assert false) legal_rules in
(* 3b *)
let exp_next = subst_legal_rules legal_rules next_rules in
-
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "translate_game: \"next\" rules with \"does\"<-\"legal\":\n%s\n%!"
- (exp_def_str ("next", exp_next))
+ (exp_def_str ("next", List.map snd exp_next))
);
(* }}} *)
(* 3c *)
- let masks = List.map (function
- | [next_arg], body, neg_body ->
+ (* [remove_orig]: branches with "nasty" fluents, ignoring them
+ (assuming they are nonerasing frame branches) *)
+ let remove_orig, masks = Aux.partition_map (function
+ | orig_br, ([next_arg], body, neg_body) ->
let collect = Aux.map_some
(function "true", [arg] -> Some arg
| "true", _ -> raise
@@ -2423,22 +2724,33 @@
let pos_gens = List.map (generalize next_arg) pos_cands in
let neg_gens = List.map (generalize next_arg) neg_cands in
(* using the fact that Pervasives.compare is lexicographic *)
- let pos_gen = List.fold_left max ((-1,0),0,Const "") pos_gens in
- let neg_gen = List.fold_left max ((-1,0),0,Const "") neg_gens in
- let (_, fresh_count, mask as gen) = max pos_gen neg_gen in
- if gen == pos_gen then mask
- else abstract_consts fresh_count mask
+ let pos_gen = List.fold_left max ((-1,0),0,[],Const "") pos_gens in
+ let neg_gen = List.fold_left max ((-1,0),0,[],Const "") neg_gens in
+ let (_, fresh_count, mism, mask as gen) = max pos_gen neg_gen in
+ (* 3c3 *)
+ if !nonerasing_frame_wave &&
+ List.exists (function Var _, _ -> true | _ -> false) mism
+ then Aux.Left orig_br
+ else if gen == pos_gen then Aux.Right mask
+ (* 3c2 *)
+ else Aux.Right (abstract_consts fresh_count mask)
| _ -> raise
(Lexer.Parsing_error
("GDL.initialize_game: invalid arity of \"next\" atom")))
exp_next in
+ (* exp_next is not used anymore *)
+ (* 3c3 *)
+ let next_rules = Aux.list_diff next_rules remove_orig in
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "translate_game: Generalized element terms (mask candidates):\n%s\n%!"
- (String.concat " " (List.map term_str masks))
+ (String.concat " " (List.map term_str masks));
+ Printf.printf "translate_game: removing \"next\" rules:\n%s\nfiltered \"next\" rules:\n%s\n%!"
+ (exp_def_str ("next", remove_orig)) (exp_def_str ("next", next_rules))
);
(* }}} *)
(* find minimal *)
+ (* TODO: generalize more, like in the paper *)
let masks = Aux.maximal (fun t1 t2->cmp_masks t2 t1) masks in
(* {{{ log entry *)
if !debug_level > 1 then (
@@ -2453,7 +2765,10 @@
Aux.map_try (fun mask ->
mask, match_meta [] [] [term] [mask]) masks
with [mask, (sb, m_sb)] -> mask, sb, m_sb
- | _ -> assert false in (* masks are minimal *)
+ | cur_masks ->
+ Printf.printf "conflicting masks: %s for %s\n%!"
+ (terms_str (List.map fst cur_masks)) (term_str term);
+ assert false in (* masks are minimal *)
let sbs, elements =
try Aux.pop_assoc mask elements
with Not_found -> [], elements in
@@ -2647,20 +2962,6 @@
List.map (fun (path, subts) -> path, Aux.unique_sorted subts)
(Aux.collect dyn_rels) in
(* 7a *)
- let legal_rules =
- Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule]
- | [Var v; lterm], body, neg_body ->
- Array.to_list
- (Array.map (fun player ->
- let sb = [v, player] in
- [player; subst sb lterm],
- subst_rels sb body,
- List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body)
- player_terms)
- | [Func _; lterm], _, _ ->
- (* TODO: easy to fix *)
- failwith "GDL.translate_game: bigger player terms not handled yet"
- | _ -> assert false) legal_rules in
(* expanded "next" branches indexed by locations, then "legal"
branches, then by MGUs for unifier equivalence classes *)
let loc_lead_legal, loc_noop_legal =
@@ -2705,7 +3006,7 @@
if ply mod loc_n = i then
loc_actions := actions @ !loc_actions) agg_actions;
(* {{{ log entry *)
- if !debug_level > 4 then (
+ if !debug_level > 3 then (
Printf.printf "Possible actions in location %d:\n%s\n%!"
i (String.concat "; "
(List.map (fun a -> term_str (Func ("legal", a))) !loc_actions))
@@ -2771,13 +3072,33 @@
(* now, continue with the lead player *)
let unifs = Aux.map_some (* and substituted legal br-es *)
(fun next_br ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "matching-next-legal:\n%s\n%!"
+ (exp_def_str ("orig-br", [next_br]))
+ );
+ (* }}} *)
match
subst_legal_rule lead_legal (freshen_branch next_br)
with None -> None
| Some (([_; lead],lead_body,lead_neg_body), br) ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "matching-next-legal-result:\n%s\n%!"
+ (exp_def_str ("matched-br", [br]))
+ );
+ (* }}} *)
Some ((lead,lead_body,lead_neg_body), br)
| _ -> assert false)
next_rules in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf
+ "Rule precursors for loc %d:\nprecursor-branches:\n%s\n%!"
+ loc (exp_def_str ("precursor", List.map snd unifs));
+ );
+ (* }}} *)
+
(* building "Hasse layers" imperatively *)
let unifs = ref unifs in
let hasse_layer () =
@@ -2817,6 +3138,13 @@
let rules_brs =
List.map (fun ((lead_head, lead_body, lead_neg_body),
branches) ->
+ let branches =
+ expand_branch_vars masks element_terms
+ (* ~freshen_unfixed:(Aux.Right fixed_vars) *)
+ (* ~freshen_unfixed:(Aux.Left true) *)
+ ~freshen_unfixed:(Aux.Left false)
+ branches in
+ let branches = List.map snd branches in
let lead_does =
"_DOES_PLACEHOLDER_", [loc_players.(loc); lead_head] in
let lead_body = lead_does::lead_body in
@@ -2826,6 +3154,7 @@
| [next_arg],_,_ ->
Aux.Strings.subset (term_vars next_arg) fixed_vars
| _ -> assert false) branches in
+ (* TODO: see (7f1) TODO *)
let frame_brs, to_expand = List.partition
(function
| [next_arg],_,_ ->
@@ -2838,14 +3167,11 @@
List.exists
(fun (rel, r_args) -> rel="true" && r_args=args) body
) frame_brs in
- let unfixed_brs =
+ (* FIXME: it's called expanded because initially unfixed
+ variables (outside frame branches) were eliminated --
+ clean up *)
+ let expanded_brs =
to_expand @ more_to_expand in
- (* 7g *)
- let expanded_brs =
- expand_branch_vars masks element_terms
- ~freshen_unfixed:(Aux.Right (Aux.Strings.elements fixed_vars))
- unfixed_brs in
- let expanded_brs = List.map snd expanded_brs in
(* 7f2 *)
let leq3 (head1, _, _) (head2, _, _) =
try
@@ -2859,7 +3185,7 @@
List.filter (fun cl->leq3 cl repr) frame_brs)
frame_brs) in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "frames: heads partitioning =\n%s\n%!"
(String.concat "\n"
(List.map (fun l ->
@@ -2887,7 +3213,7 @@
repr_head, multi_body
) frames in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "frames: heads = %s\n%!"
(String.concat ", " (List.map (function [h],_ ->term_str h
| _ -> assert false) frames))
@@ -2901,11 +3227,11 @@
| [next_arg] as next_args,multi_body ->
let mask, _, _, blank_arg = term_to_blank masks next_arg in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "Blanking-out of %s by %s\n%!"
(term_str next_arg) (term_str mask)
);
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "Frame multibody:\n%s\n%!"
( String.concat "\n" (List.map (
fun (body, neg_body) ->
@@ -2922,7 +3248,8 @@
then Some (Aux.Left (rel, args))
else None) body in
let neg_body =
- List.map
+ (* we drop failed equality from the disjuction *)
+ Aux.map_try
(function
| _, ["distinct", []] -> assert false
| _, ["distinct", arg::more_args] ->
@@ -2943,9 +3270,21 @@
| _, conj ->
Aux.Right (Aux.Left conj))
neg_body in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "body length = %d; neg_body length = %d\n%!"
+ (List.length body) (List.length neg_body)
+ );
+ (* }}} *)
body @ neg_body) multi_body in
let erasures = List.map Aux.partition_choice
(Aux.unique_sorted (Aux.product multi_body)) in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "initial erasures length = %d\n%!"
+ (List.length erasures)
+ );
+ (* }}} *)
let erasures =
Aux.map_some (fun (neg_body, body) ->
try
@@ -2994,99 +3333,228 @@
Some ([head], lead_body @ body,
lead_neg_body @ neg_body)
(*or not
- Some ([head], body, neg_body)*)
+ Some ([head], body, neg_body)*)
)
- else None
+ else (
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "unsatisfiable-erasure:\n%s\n%s\n%!"
+ (lit_def_str ("erasure", [
+ [head], body, neg_body]))
+ (exp_def_str ("lead", [
+ [lead_head], lead_body, lead_neg_body]))
+ );
+ (* }}} *)
+ None)
with Not_found -> None) erasures in
let erasures = Aux.unique_sorted
(List.map (fun (head, body, neg_body) ->
head, Aux.unique_sorted body,
Aux.unique_sorted neg_body) erasures) in
+ ...
[truncated message content] |
|
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] |
|
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-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-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-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-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-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-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-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-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-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-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.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X