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
- ...
[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 ...
+ ... ... .....
[truncated message content] |
|
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()) - :(C...
[truncated message content] |
|
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 2...
[truncated message content] |
|
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 fo...
[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 @@...
[truncated message content] |
|
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 f...
[truncated message content] |
|
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
+ ("_DO...
[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)"
+ ...
[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...
[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...
[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_sin...
[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 r...
[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/WebClie...
[truncated message content] |
|
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...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X