toss-devel-svn Mailing List for Toss (Page 14)
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
toss-devel-svn — Toss development: svn commits
You can subscribe to this list here.
| 2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(25) |
Dec
(62) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2011 |
Jan
(26) |
Feb
(38) |
Mar
(67) |
Apr
(22) |
May
(41) |
Jun
(30) |
Jul
(24) |
Aug
(32) |
Sep
(29) |
Oct
(34) |
Nov
(18) |
Dec
(2) |
| 2012 |
Jan
(19) |
Feb
(25) |
Mar
(16) |
Apr
(2) |
May
(18) |
Jun
(21) |
Jul
(11) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <luk...@us...> - 2011-04-27 17:44:43
|
Revision: 1423
http://toss.svn.sourceforge.net/toss/?rev=1423&view=rev
Author: lukstafi
Date: 2011-04-27 17:44:35 +0000 (Wed, 27 Apr 2011)
Log Message:
-----------
FormulaOps: satisfiability check in [remove_redundant]. GameSimpl: better glueing, bug fixes. GDL translation: two options for stronger pruning (for experiments); fix translating sets of clauses: when they are interpreted conjunctively, instead of filtering, raise [Unsatisfiable] if any branch is not satisfiable.
Modified Paths:
--------------
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/FormulaOps.ml
trunk/Toss/Formula/FormulaOps.mli
trunk/Toss/GGP/GDL.ml
trunk/Toss/GGP/GDL.mli
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/GGP/GameSimpl.mli
trunk/Toss/GGP/tests/breakthrough-raw.toss
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect5-raw.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/GGP/tests/tictactoe-raw.toss
trunk/Toss/GGP/tests/tictactoe-simpl.toss
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Server/ServerTest.ml
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -1019,6 +1019,12 @@
let rewritable args =
Aux.array_for_all (fun v -> List.mem (Formula.var_str v) struc_elems)
args in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ FormulaOps.set_debug_level !debug_level;
+ Printf.printf "translate_from_precond:\n%!"
+ );
+ (* }}} *)
let conjs =
FormulaOps.flatten_ands (FormulaOps.remove_redundant precond) in
let posi, conjs = Aux.partition_map (function
@@ -1031,18 +1037,19 @@
Left (rel,args)
| phi -> Right phi) conjs in
let lhs_extracted = posi @ nega in
- let precond = Formula.And conjs in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
- "translate_from_precond:\nposi=\n%s\nnega=\n%s\nprecond=\n%s\n%!"
+ "translate_from_precond:\nposi:\n%s\nnega:\n%s\norig-precond:\n%s\nsimpl-precond:%s\n%!"
(Formula.sprint (Formula.And (List.map (fun (rel,args) ->
Formula.Rel (rel,args)) posi)))
(Formula.sprint (Formula.And (List.map (fun (rel,args) ->
Formula.Rel (rel,args)) nega)))
(Formula.sprint precond)
+ (Formula.sprint (Formula.And conjs))
);
(* }}} *)
+ let precond = Formula.And conjs in
let fvars = FormulaOps.free_vars precond in
let local_vars =
List.filter (fun v->
@@ -1096,6 +1103,12 @@
let rhs_struc = add_rels rhs_struc add in
let lhs_struc = add_rels lhs_struc posi_s in
let lhs_struc = add_rels lhs_struc opt_s in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ FormulaOps.set_debug_level 0;
+ Printf.printf "translate_from_precond: end\n%!"
+ );
+ (* }}} *)
{
lhs_struc = lhs_struc;
rhs_struc = rhs_struc;
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/Aux.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -54,6 +54,9 @@
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
+let map_fst f (a,b) = f a, b
+let map_snd f (a,b) = a, f b
+
module BasicOperators = struct
let (-|) f g x = f (g x)
let (<|) f x = f x
@@ -306,6 +309,24 @@
done;
res
+let array_mapi_some f a =
+ let r = Array.mapi f a in
+ let rl = ref (Array.length r) in
+ for i=0 to Array.length a - 1 do
+ if r.(i) = None then decr rl
+ done;
+ if !rl = 0 then [||]
+ else
+ let pos = ref 0 in
+ while r.(!pos) = None do incr pos done;
+ let res = Array.create !rl (unsome r.(!pos)) in
+ incr pos;
+ for i=1 to !rl -1 do
+ while r.(!pos) = None do incr pos done;
+ res.(i) <- unsome r.(!pos); incr pos
+ done;
+ res
+
let array_map2 f a b =
let l = Array.length a in
if l <> Array.length b then
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/Aux.mli 2011-04-27 17:44:35 UTC (rev 1423)
@@ -39,6 +39,9 @@
val snd3 : 'a * 'b * 'c -> 'b
val trd3 : 'a * 'b * 'c -> 'c
+val map_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
+val map_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
+
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
@@ -187,6 +190,7 @@
(** Map an array filtering out some elements. *)
val array_map_some : ('a -> 'b option) -> 'a array -> 'b array
+val array_mapi_some : (int -> 'a -> 'b option) -> 'a array -> 'b array
(** Map a function over two arrays index-wise. Raises
[Invalid_argument] if the arrays are of different lengths. *)
Modified: trunk/Toss/Formula/FormulaOps.ml
===================================================================
--- trunk/Toss/Formula/FormulaOps.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/FormulaOps.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -954,9 +954,13 @@
track of the sign (variance) of a position. (Does not descend the
real part currently.) [implies] is applied to atoms only. Repeat
the removal till fixpoint since it can "unpack" literals e.g. from
- conjunctions to disjunctions.
+ conjunctions to disjunctions. Also perform a very basic check for
+ satisfiability of disjuncts.
TODO: traverse the real part too. *)
+exception Unsatisfiable
+(* [Unsatisfiable] does not escape the function -- [Or []] is
+ returned instead. *)
let remove_redundant ?(implies=(=)) phi =
let implied_by x y = implies y x in
let literal neg phis =
@@ -983,6 +987,17 @@
(String.concat "; " (List.map Formula.str more_negbase))
);
(* }}} *)
+ (* detect contradiction *)
+ List.iter (fun prem ->
+ List.iter (fun concl ->
+ if implies prem concl
+ then raise Unsatisfiable
+ ) more_negbase) (more_posbase @ posbase);
+ List.iter (fun prem ->
+ List.iter (fun concl ->
+ if implies prem concl
+ then raise Unsatisfiable
+ ) (more_negbase @ negbase)) more_posbase;
(* remove redundant *)
let more_posbase = List.filter
(fun more -> not (List.exists (implied_by more) posbase))
@@ -1038,8 +1053,14 @@
(String.concat "; " (List.map Formula.str neglits))
);
(* }}} *)
- literal neg poslits @ literal (not neg) neglits @
- List.map (aux posbase negbase neg) subtasks
+ let subresults =
+ Aux.map_some (fun disj ->
+ try Some (aux posbase negbase neg disj)
+ with Unsatisfiable -> None) subtasks in
+ let results =
+ literal neg poslits @ literal (not neg) neglits @ subresults in
+ if results = [] then raise Unsatisfiable
+ else results
and aux posbase negbase neg = function
| And conjs when not neg ->
@@ -1065,7 +1086,8 @@
(* }}} *)
let res = aux [] [] false (flatten_formula phi) in
if res = phi then res else fixpoint res in
- fixpoint phi
+ try fixpoint phi
+ with Unsatisfiable -> Or []
(* Compute size of a formula (currently w/o descending the real part). *)
Modified: trunk/Toss/Formula/FormulaOps.mli
===================================================================
--- trunk/Toss/Formula/FormulaOps.mli 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/Formula/FormulaOps.mli 2011-04-27 17:44:35 UTC (rev 1423)
@@ -174,7 +174,9 @@
track of the sign (variance) of a position. (Does not descend the
real part currently.) [implies] is applied to atoms only. Repeat
the removal till fixpoint since it can "unpack" literals e.g. from
- conjunctions to disjunctions. *)
+ conjunctions to disjunctions. Also perform a very basic check for
+ satisfiability. Returns [Or []] if the formula is obviously
+ unsatisfiable (does not do any unification). *)
val remove_redundant :
?implies:(formula -> formula -> bool) -> formula -> formula
Modified: trunk/Toss/GGP/GDL.ml
===================================================================
--- trunk/Toss/GGP/GDL.ml 2011-04-21 00:48:48 UTC (rev 1422)
+++ trunk/Toss/GGP/GDL.ml 2011-04-27 17:44:35 UTC (rev 1423)
@@ -60,8 +60,7 @@
processed in (3a)-(3b) are already expanded by (6).
(3a) Element terms are collected from the aggregate playout: the
- sum of state terms (the "control" function could be dropped but we
- are not taking the effort to identify it).
+ sum of state terms.
(3b) Element masks are generated by generalization from all "next"
rules where the "does" relations are expanded by all unifying
@@ -80,11 +79,19 @@
heuristic is a reason for unsoundness -- search for a workaround
once a real counterexample is encountered.
+ (3c3) When [nonerasing_frame_wave] is set to [true], remove
+ branches that have a variable/variable mismatch at proposed fluent
+ position.(TODO)
+
(3d) The masks are all the minimal w.r.t. matching (substitution)
of the generalized terms, with only meta-variable positions of the
mask matching meta-variable positions of a generalized
term.
+ TODO: this is wrong! Generates too many masks compared to the
+ paper method (using fluent paths). Should generalize masks that
+ do not differ at constant/functor-constant/functor positions.
+
(3e) The elements are the equivalence classes of element terms,
where terms are equivalent when they both match a single mask and
their matching substitutions differ only at
@@ -133,6 +140,9 @@
semantics: "matches the mask and has the constant at the path
position".
+ Optionally, also include a positive mask predicate for negative
+ state terms (rather than a negative one).
+
(5) (Mostly) dynamic relations ("fluents": their tuples change
during the game), relations derived from all below-meta-variable
subterms of element terms, initialized by those that appear in the
@@ -190,8 +200,9 @@
/\ not exist vars_n (args = params_n /\ body_n)]
(6b1) If the relation has negative subformulas in any of [body_i],
- we first negate the definition and then expand the negation as in
- the positive case.
+ unless all the negative subformulas are just "distinct" checks
+ that become ground, we first negate the definition and then expand
+ the negation as in the positive case.
(6b1a) Eliminate [args = params_i] by substituting-out variables
from [params_i] whenever possible.
@@ -298,10 +309,16 @@
contain some fixed variables or no variables at all, and other
containing only unfixed variables.
- (7f1) Branches with (only) unfixed variables in "next" atoms that
- are "identities" are the "frame" branches. "Identity" here means
- the "next" atom is equal to one of the positive "true" atoms.
+ (7f1) Branches with only (TODO: some? (x)) unfixed variables in "next"
+ atoms that are "identities" are the "frame" branches. "Identity"
+ here means the "next" atom is equal to one of the positive "true"
+ atoms.
+ (x) It is probably better to not expand "identity" branches that
+ have both fixed and unfixed variables in the head, as they will be
+ correctly handled (translated to erasure branches) in the
+ following code.
+
(7f2) Transform the "frame" branches into "erasure" branches:
distribute them into equivalence classes of head terms
(w.r.t. substitution but treating fixed variables as constants),
@@ -319,6 +336,10 @@
(i.e. universally quantified) (while the local variables of old
negated subformulas are "let free").
+ FIXME: it is probably wrongly assumed in the implementation that
+ negated "distinct" unifies all terms, instead of disjunction of
+ pairwise unification, check that.
+
(7f4) Drop the erasure branches that contradict the "legal"
condition of their rule. (Add the "legal" condition for early pruning.)
@@ -326,11 +347,11 @@
substituted with the "not distinct" unifier to proper equivalence
classes (remove equivalence classes that become empty).
- (7g) Instantiate remaining unfixed variables: Duplicate non-frame
- rules with unfixed variables for each instantiation of the unfixed
- variables warranted by the aggregate playout. (Perhaps can be done
- "symbolically" to avoid explosion.)
+ (7f6) Filter-out branches that are not satisfiable by their static
+ part (in the initial structure).
+ (7g) NOOP (Was eliminating unfixed variables.)
+
(7h) Introduce a new element variable for each class of "next" and
"true" terms equal modulo mask (i.e. there is a mask matching them
and they differ only at-or-below metavariables). (Remember the
@@ -368,9 +389,13 @@
subterms that instantiate (ordinary) variables in the mask
corresponding to the "next"/"true" atom.
- (7i0) Heuristic (reason for unsoundness): for "distinct", only
- check whether its arguments are syntactically equal.
+ (7i0) For "distinct", negate the anchors of the constants at mask
+ paths of the variables, and equivalences of the variables (if
+ there are multiple variables).
+ TODO: currently only checks whether "distinct" arguments are
+ syntactically equal.
+
(7i1) Remove branches that are unsatisfiable by their static
relations (4a), (4b) and (positive) (4c) alone.
@@ -408,8 +433,12 @@
(7k-4b) It is essentially a special case of (7k-4a-1). Introduce
equivalences as in (7i-4b), but with tuples containing at least
one element from the current negation (no elements from other
- negations).
+ negations). Generate the same set of equivalence tuples as a
+ positive occurrence would so that they can be pruned when
+ possible.
+ TODO: handle "distinct" that contains variable(s)!
+
(7l) Build a pre-lattice of branch bodies w.r.t. subsumption,
in a manner similar to (7b). The subsumption test has to say "no"
when there exists a game state where the antecedent holds but the
@@ -420,26 +449,50 @@
branches strictly above more specific -- so that the classes form
a partition of the nonterminal game states (it is semantically
necessary so that all applicable changes are applied in the
- translated game when making a move).
+ translated game when making a move). The lattice is built by
+ summing rule bodies.
- (7l1) Since all variables are fixed, the lattice is built by
- summing rule bodies. To avoid contradictions and have a complete
- partition, we construct the set of all bit vectors indexed by all
- atoms occurring in the bodies. With every index-bit value we
- associate the set of branches that do not allow such literal. For
- every vector we calculate the complement of the sum of branch sets
- associated with every bit. The unique resulting sets are exactly
- the Toss rules precursors. Heuristic (FIXME: needed?): We only use
- atoms that are deterministically present or absent in at least
- some branch for indexing.
+ (7l0) To avoid contradictions and have a complete partition, we
+ construct the set of all bit vectors indexed by all atoms
+ occurring in the bodies (optionally, all atoms in bodies of
+ branches containing "does" atoms). We collapse atoms that have the
+ same pattern of occurrence in the branches as single index.
+ (7l1) With every index-bit value we associate the set of branches
+ that do not allow such literal. For every vector we calculate the
+ complement of the sum of branch sets associated with every
+ bit. The unique resulting sets are exactly the Toss rules
+ precursors. Heuristic (FIXME: needed?): We only use atoms that are
+ deterministically present or absent in at least some branch for
+ indexing.
+
(7l2) Filter rule candidates so that each has a "does"-specific
branch.
- (7l3) Filter out rule candidates that contradict all states
+ TODO: perhaps should be optional -- perhaps there are "default
+ all noop rules" in some games.
+
+ (7l3) Optionally, remove synthetic branches that do not have (a)
+ gdl variables (i.e. Toss equivalence relations) or (b) state terms
+ (i.e. Toss variables) in common with the non-synthetic branches of
+ the rule candidate.
+
+ Only translate the formulas after (7l3).
+
+ (7l3b) In this optional case, only keep synthetic branches that
+ either have non-state-term atoms with gdl variables common with
+ base branches, or actually have state terms in common with base
+ branches. (E.g. do not keep a branch with "(R ?x ?y) (true (ST ?v ?x))
+ (true (ST ?v ?y))" when only "v" is in common with base branches.)
+
+ (7l4) Filter out rule candidates that contradict all states
from the current location plys of aggregate playout (by their
"true" atoms -- "not true" are not valid in the aggregate playout).
+ (7l5) Here a set of branches has conjunctive interpretation, since
+ they are the "next" clauses that simultaneously match. If a branch
+ fails, the whole case fails.
+
(7m) Filter the final rule candidates by satisfiability of the
static part (same as (7i1) conjoined).
@@ -537,15 +590,50 @@
let debug_level = ref 0
let aggregate_drop_negative = ref false
let aggregate_fixpoint = ref true
-(** Expand static relations that do not have ground facts and have
- arity above the threshold. *)
+
+(** Expand static relations that do not have ground facts, are not
+ directly recursive, and have arity above the threshold. *)
let expand_arity_above = ref 0
-(** Generate all tuples for equivalences, to faciliate further
+(** Treat "next" clauses which introduce metavariables only for
+ variable-variable mismatch, as non-erasing frame clauses (to be
+ ignored). ("Wave" refers to the process of "propagating the frame
+ condition" that these clauses are assumed to do, if
+ [nonerasing_frame_wave] is set to [true].) *)
+let nonerasing_frame_wave = ref true
+
+(** Include mask predicates (first part of (4c)) of negative state
+ term atoms as either positive or negated atoms. *)
+type mask_anchors_of_neg = Positive_anch | Negative_anch | No_anch
+let mask_anchors_of_neg = ref (* Positive_anch *) Negative_anch
+
+(** Approximate rule preconditions by dropping parts of "partition
+ guards" of (7l) -- parts of conditions introduced merely to
+ distinguish rules that should not be available at the same time. *)
+type approximate_rule_preconds =
+ | Exact (** keep all conditions *)
+ | Connected (** keep all connected to
+ variables appearing in the
+ rest, i.e. containing
+ common gdl variables *)
+ | TightConnected (** keep connected but
+ ignoring equivalence
+ links, i.e. containing
+ common gdl state terms *)
+ | DropAll
+let approximate_rule_preconds = ref (* Connected *) Exact
+
+(** Filter rule candidates by the stable part of precondition either
+ before or after game simplification. *)
+type prune_rulecands = Before_simpl | After_simpl | Never
+let prune_rulecands_at = ref (* Before_simpl *) Never
+
+(** Perhaps generate all tuples for equivalences, to faciliate further
transformations of formulas in the game definition (outside of
translation). *)
type pair_matrix = Pairs_all | Pairs_triang | Pairs_star
let equivalences_all_tuples = ref Pairs_triang
+let equivalences_ordered = ref true
(** Generate test case for the given game name. *)
let generate_test_case = ref None
@@ -658,6 +746,7 @@
and terms_vars args =
List.fold_left Aux.Strings.union Aux.Strings.empty
(List.map term_vars args)
+
let fact_of_atom = function
| Distinct args -> assert false
@@ -722,6 +811,34 @@
module Atoms = Set.Make (
struct type t = string * term list let compare = Pervasives.compare end)
+
+let lit_def_br_vars (head, body, neg_body : lit_def_branch) =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map terms_vars
+ (head::List.map snd body @
+ List.map (snd -| snd) neg_body))
+
+let exp_def_br_vars (head, body, neg_body : exp_def_branch) =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map terms_vars
+ (head::List.map snd body @
+ Aux.concat_map (List.map snd -| snd) neg_body))
+
+let lit_def_brs_vars brs =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map lit_def_br_vars brs)
+
+let exp_def_brs_vars brs =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map exp_def_br_vars brs)
+
+let sdef_br_vars (head, body, neg_body) =
+ exp_def_br_vars ([head], body, neg_body)
+
+let sdef_brs_vars brs =
+ List.fold_left Aux.Strings.union Aux.Strings.empty
+ (List.map sdef_br_vars brs)
+
(*
let branch_vars (args, body, neg_body) =
*)
@@ -935,27 +1052,27 @@
let fresh_count = ref 0 in
let rec loop pf terms1 terms2 =
match terms1, terms2 with
- | [], [] -> (0, 0), []
+ | [], [] -> (0, 0), [], []
| (Const a as cst)::terms1, Const b::terms2 when a=b ->
- let (good_vars, good_csts), gens = loop pf terms1 terms2 in
- (good_vars, good_csts+1), cst::gens
+ let (good_vars, good_csts), mism, gens = loop pf terms1 terms2 in
+ (good_vars, good_csts+1), mism, cst::gens
| Func (f,args1)::terms1, Func (g,args2)::terms2 when f=g ->
- let (good_vars1, good_csts1), gen_args = loop f args1 args2 in
- let (good_vars2, good_csts2), gens = loop pf terms1 terms2 in
- (good_vars1+good_vars2, good_csts1+good_csts2),
+ let (good_vars1, good_csts1), mism1, gen_args = loop f args1 args2 in
+ let (good_vars2, good_csts2), mism2, gens = loop pf terms1 terms2 in
+ (good_vars1+good_vars2, good_csts1+good_csts2), mism1 @ mism2,
(Func (f,gen_args))::gens
| (Var x as var)::terms1, Var y::terms2 when x=y ->
- let (good_vars, good_csts), gens = loop pf terms1 terms2 in
- (good_vars+1, good_csts), var::gens
- | _::terms1, _::terms2 ->
- let measure, gens = loop pf terms1 terms2 in
+ let (good_vars, good_csts), mism, gens = loop pf terms1 terms2 in
+ (good_vars+1, good_csts), mism, var::gens
+ | t1::terms1, t2::terms2 ->
+ let measure, mism, gens = loop pf terms1 terms2 in
incr fresh_count;
- measure, MVar ("MV"^string_of_int !fresh_count)::gens
+ measure, (t1,t2)::mism, MVar ("MV"^string_of_int !fresh_count)::gens
| _::_, [] | [], _::_ -> raise
(Lexer.Parsing_error
("GDL.generalize: arity mismatch at function "^pf)) in
- let measure, gens = loop "impossible" [term1] [term2] in
- measure, !fresh_count, List.hd gens
+ let measure, mism, gens = loop "impossible" [term1] [term2] in
+ measure, !fresh_count, mism, List.hd gens
(* 3c2 *)
let abstract_consts fresh_count term =
@@ -1215,8 +1332,8 @@
List.map map_rel body,
List.map map_neg neg_body
-let freshen_def_branches =
- List.map freshen_branch
+let freshen_def_branches brs =
+ List.map freshen_branch brs
(* [args] are the actual, instatiated, arguments. *)
let negate_def uni_vs args neg_def =
@@ -1270,8 +1387,10 @@
(* assumption: [defs] bodies are already clean of defined relations *)
let subst_def_branch (defs : exp_def list)
(head, body, neg_body as br : lit_def_branch) : exp_def_branch list =
+ var_support := Aux.Strings.union !var_support
+ (lit_def_br_vars br);
(* {{{ log entry *)
- if !debug_level > 4 then (
+ if !debug_level > 3 then (
Printf.printf "Expanding branch %s\n%!" (lit_def_str ("BRANCH", [br]));
);
(* }}} *)
@@ -1281,7 +1400,7 @@
(let try def =
freshen_def_branches (List.assoc rel defs) in
(* {{{ log entry *)
- if !debug_level > 4 then (
+ if !debug_level > 3 then (
Printf.printf "Expanding positive %s by %s\n%!" rel
(exp_def_str (rel, def))
);
@@ -1312,7 +1431,6 @@
then Aux.Left (neg_lit, Some def)
else (
(* {{{ log entry *)
-
if !debug_level > 3 then (
let _,_,def_neg_body =
List.find (fun (_,_,negb) -> negb <> []) def in
@@ -1322,11 +1440,50 @@
(String.concat " and not "
(List.map facts_str (List.map snd def_neg_body)))
);
-
(* }}} *)
Aux.Right (neg_lit, def))
with Not_found -> Aux.Left (neg_lit, None))
) neg_body in
+ (* checking if all negative bodies are just already satisfied
+ "distinct" atoms; we could refine the split per-solution, but it
+ isn't worth the effort *)
+ let more_neg_flat, neg_body_rec =
+ Aux.partition_map (fun (_, (_, args) as neg_lit, def as neg_case) ->
+ if List.for_all (function
+ | _,_,[] -> true
+ |_,_,neg_body ->
+ List.for_all (function
+ | _, ["distinct", _] -> true | _ -> false) neg_body
+ ) def
+ then
+ if List.for_all (function
+ | _,_,[] -> true
+ |params,_,neg_body ->
+ List.for_all (function
+ | _, ["distinct", terms] ->
+ List.for_all (fun (_,_,sb) ->
+ let args = List.map (subst sb) args in
+ let sb1 = unify [] params args in
+ let terms = List.map (subst sb1) terms in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf
+ "Checking distinctness of %s after sb=%s; sb1=%s\n%!"
+ (terms_str terms)
+ (sb_str sb) (sb_str sb1)
+ );
+ (* }}} *)
+ Aux.Strings.is_empty (terms_vars terms)
+ && List.length (Aux.unique_sorted terms) > 1
+ ) sols
+ | _ -> false) neg_body) def
+ then
+ let def = List.map (fun (params, body, neg_body) ->
+ params, body, []) def in
+ Aux.Left (neg_lit, Some def)
+ else Aux.Right neg_case
+ else Aux.Right neg_case
+ ) neg_body_rec in
(* {{{ log entry *)
if !debug_level > 3 then (
Printf.printf "Expanding (%s) negative part: flat %s; rec %s\n%!"
@@ -1338,19 +1495,19 @@
(* 6b1 *)
let sols =
List.fold_left (fun sols ((uni_vs, (rel, args)), neg_def) ->
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "Expanding rec-negative %s by %s\n%!" rel
- (exp_def_str (rel, neg_def))
- );
- (* }}} *)
- (* we don't keep the substitution from the negated match *)
- Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
- let args = List.map (subst sb) args in
- let branches = negate_def uni_vs args neg_def in
- List.map (fun (dbody, dneg_body) ->
- dbody @ pos_sol, dneg_body @ neg_sol, sb) branches
- ) sols)
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "Expanding rec-negative %s by %s\n%!" rel
+ (exp_def_str (rel, neg_def))
+ );
+ (* }}} *)
+ (* we don't keep the substitution from the negated match *)
+ Aux.concat_map (fun (pos_sol, neg_sol, sb) ->
+ let args = List.map (subst sb) args in
+ let branches = negate_def uni_vs args neg_def in
+ List.map (fun (dbody, dneg_body) ->
+ dbody @ pos_sol, dneg_body @ neg_sol, sb) branches
+ ) sols)
sols neg_body_rec in
(* 6b2 *)
@@ -1374,7 +1531,7 @@
) def
| None -> (* rel not in defs *)
[uni_vs, [atom]]
- ) neg_body_flat in
+ ) (more_neg_flat @ neg_body_flat) in
List.rev pos_sol, List.rev_append neg_sol more_neg_sol, sb
) sols in
let res =
@@ -1419,44 +1576,63 @@
loop (exp_defs_of_lit_defs def_base) def_strata
| def_strata -> loop more_defs def_strata
-
(* As [subst_def_branch], but specifically for "legal" definition and
result structured by "legal" definition branches. *)
(* 7b *)
-let subst_legal_rule
- (legal_args, legal_body, legal_neg_body : exp_def_branch)
- (head, body, neg_body : exp_def_branch)
+let subst_legal_rule legal
+ (head, body, neg_body as br)
: (exp_def_branch * exp_def_branch) option =
+ var_support := Aux.Strings.union !var_support
+ (exp_def_br_vars br);
+ let legal = freshen_branch legal in
+ let legal_args, legal_body, legal_neg_body = legal in
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "subst_legal_rule:\n%s\n%s\n%!"
+ (exp_def_str ("legal", [legal]))
+ (exp_def_str ("branch", [br]))
+ );
+ (* }}} *)
if List.exists (fun (_,neg_conjs) ->
List.exists (fun (rel,_)->rel="does") neg_conjs) neg_body
then failwith
"GDL.translate_game: negated \"does\" conditions not implemented yet";
try
let body, more_neg_body, sb =
- List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) ->
- if rel = "does" then
- ("_DOES_PLACEHOLDER_", args) :: List.rev_append legal_body body,
- List.rev_append legal_neg_body more_neg_body,
- unify sb legal_args args
- else atom::body, more_neg_body, sb) ([],[],[]) body in
- Some (
- (List.map (subst sb) legal_args,
- subst_rels sb legal_body,
- List.map (fun (uni_vs,neg_conjs) ->
- (* local variables so cannot be touched *)
- uni_vs, subst_rels sb neg_conjs)
- legal_neg_body),
- (List.map (subst sb) head,
- subst_rels sb (List.rev body),
- List.map (fun (uni_vs, neg_conjs) ->
- uni_vs, subst_rels sb neg_conjs)
- (List.rev_append more_neg_body neg_body)))
+ List.fold_left (fun (body,more_neg_body,sb) (rel, args as atom) ->
+ if rel = "does" then
+ ("_DOES_PLACEHOLDER_", args) :: List.rev_append legal_body body,
+ List.rev_append legal_neg_body more_neg_body,
+ unify sb legal_args args
+ else atom::body, more_neg_body, sb) ([],[],[]) body in
+ let legal_res =
+ List.map (subst sb) legal_args,
+ subst_rels sb legal_body,
+ List.map (fun (uni_vs,neg_conjs) ->
+ (* local variables so cannot be touched *)
+ uni_vs, subst_rels sb neg_conjs)
+ legal_neg_body in
+ let br_res =
+ List.map (subst sb) head,
+ subst_rels sb (List.rev body),
+ List.map (fun (uni_vs, neg_conjs) ->
+ uni_vs, subst_rels sb neg_conjs)
+ (List.rev_append more_neg_body neg_body) in
+ (* {{{ log entry *)
+if !debug_level > 3 then (
+ Printf.printf "%s\n%s\n"
+ (exp_def_str ("legal-res", [legal_res]))
+ (exp_def_str ("br-res", [br_res]))
+);
+(* }}} *)
+ Some (legal_res, br_res)
with Not_found -> None
let subst_legal_rules def_brs brs =
- Aux.concat_map (fun br ->
- List.map snd
- (Aux.map_some (fun def -> subst_legal_rule def br) def_brs)) brs
+ Aux.unique_sorted
+ (Aux.concat_map (fun br ->
+ List.map (fun (_,x) -> br, x)
+ (Aux.map_some (fun def -> subst_legal_rule def br) def_brs)) brs)
(* 1 *)
@@ -1666,11 +1842,12 @@
(* Expand branch variables. If [freshen_unfixed=Right fixed], expand
- all variables that don't belong to [fixed]. If
- [freshen_unfixed=Left freshen], then expand all variables below
- meta-variables of masks. If [freshen] is true, rename other
- (i.e. non-expanded) variables while duplicating branches. (When
- [freshen] is false, all remaining variables should be fixed.)
+ all variables that don't belong to [fixed] and appear in the head
+ of some branch. If [freshen_unfixed=Left freshen], then expand all
+ variables below meta-variables of masks. If [freshen] is true,
+ rename other (i.e. non-expanded) variables while duplicating
+ branches. (When [freshen] is false, all remaining variables should
+ be fixed.)
With each branch, also return the instantiation used to derive it???
@@ -1681,16 +1858,32 @@
instantiations kept local to the subformula. Final substitution is
re-applied to catch up with later instantiations. *)
let expand_branch_vars masks playout_terms ~freshen_unfixed brs =
+ let head_vars = List.fold_left (fun acc -> function [head],_,_ ->
+ Aux.Strings.union acc (term_vars head)
+ | _ -> assert false) Aux.Strings.empty brs in
+ let use_fixed, fixed =
+ match freshen_unfixed with
+ | Aux.Left _ -> false, Aux.Strings.empty
+ | Aux.Right fixed -> true, fixed in
+(* {{{ log entry *)
+if !debug_level > 4 then (
+ Printf.printf "expand_branch_vars: head_vars: %s; fixed vars: %s; before=\n%s\n%!"
+ (String.concat ","(Aux.Strings.elements head_vars))
+ (String.concat ","(Aux.Strings.elements fixed))
+ (exp_def_str ("before", brs))
+);
+(* }}} *)
let expand sb arg =
let arg = subst sb arg in
- let is_inst_var =
- match freshen_unfixed with
- | Aux.Left _ ->
- let mask, sb, m_sb, blank = term_to_blank masks arg in
- let ivars = Aux.concat_map (fun (_,t) ->
- Aux.Strings.elements (term_vars t)) m_sb in
- (fun v -> List.mem v ivars)
- | Aux.Right fixed -> fun v -> not (List.mem v fixed) in
+ let mask, _, m_sb, blank = term_to_blank masks arg in
+ let ivars = Aux.concat_map (fun (_,t) ->
+ Aux.Strings.elements (term_vars t)) m_sb in
+ let is_inst_var v =
+ (*if use_fixed
+ then
+ (Aux.Strings.mem v head_vars || List.mem v ivars)
+ && not (Aux.Strings.mem v fixed)
+ else*) List.mem v ivars in
Aux.unique_sorted
(Aux.map_try (fun term ->
let sb1, _ = match_meta [] [] [term] [arg] in
@@ -1727,19 +1920,37 @@
(if head = Const "_IGNORE_RHS_" then [[], head]
else expand [] head)
| _ -> assert false) brs in
+ (* {{{ log entry *)
+if !debug_level > 4 then (
+ Printf.printf "expand_branch_vars: substitutions=\n%s\n%!"
+ (String.concat ";; " (List.map (sb_str -| fst) brs))
+);
+(* }}} *)
match freshen_unfixed with
| Aux.Left true ->
List.map (fun (sb, br) -> sb, freshen_branch br) brs
| _ -> brs
-let translate_branches struc masks playout_terms static_rnames dyn_rels
+(* (7l5)-related exception. *)
+exception Failed_branch
+
+let translate_branches ?(conjunctive=false) struc masks playout_terms
+ static_rnames dyn_rels
(brs : exp_def_branch list) =
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "Translating-branches:\n%s\n%!"
+ (exp_def_str ("translating", brs));
+ );
+ (* }}} *)
(* 7i *)
+ (* the state terms are positive, the relation can be positive or
+ negative -- negate atoms after generation if the atom was negative *)
let pos_conjs_4a pos_state_subterms (rel, args) =
let ptups = List.map (fun arg ->
Aux.assoc_all arg pos_state_subterms) args in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "pos_conjs_4a: of %s = subterms %s\n%!"
(fact_str (rel,args)) (String.concat "; " (
List.map (fun l -> String.concat ", "
@@ -1757,12 +1968,14 @@
Formula.Rel (rname, Array.of_list tup)) ptups in
let res = Aux.unique_sorted res in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "pos_conjs_4a: of %s = %s\n%!"
(fact_str (rel,args)) (Formula.str (Formula.And res))
);
(* }}} *)
res in
+ (* some of the state terms are always negative, the relation can be
+ positive or negative but always negate resulting atoms *)
let neg_conjs_4a pos_state_subterms
neg_state_terms neg_state_subterms (rel, args) =
let ptups = List.map (fun arg ->
@@ -1782,13 +1995,15 @@
Formula.Rel (rname, Array.of_list tup)) ptups in
let res = Aux.unique_sorted res in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "neg_conjs_4a: of %s = %s\n%!"
(fact_str (rel,args)) (Formula.str (Formula.And res))
);
(* }}} *)
res in
(* 7i-4b *)
+ (* FIXME: abandon filtering-out rendundant mask variables during
+ translation -- this is the job of GameSimplify! *)
let constrained_vars = ref [] in
let pos_conjs_4b pos_path_subterms =
Aux.unique_sorted (Aux.concat_map (fun ((mask, v), terms) ->
@@ -1813,6 +2028,8 @@
(* (4b) are equivalences, so we just build a "star" *)
match vars with [] -> []
| v::vs -> List.map (fun w -> [|v; w|]) vs in
+ if !equivalences_ordered then
+ List.iter (Array.sort Pervasives.compare) tups;
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
) pos_path_subterms) in
@@ -1843,6 +2060,8 @@
Aux.map_some (fun v ->
if v = ntossvar then None
else Some [|v; ntossvar|]) tossvars in
+ if !equivalences_ordered then
+ List.iter (Array.sort Pervasives.compare) tups;
List.map (fun tup -> Formula.Rel (rname, tup)) tups
| _ -> []
) pos_path_subterms in
@@ -1862,7 +2081,7 @@
) Terms.empty brs in
let pos_state_terms = Terms.elements pos_state_terms in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "pos_state_terms: %s\n%!"
(String.concat ", " (List.map term_str pos_state_terms))
);
@@ -1891,10 +2110,10 @@
let mask, sb, m_sb, blanked = term_to_blank masks next_arg in
let rname = term_to_name mask in
let _, svar = toss_var masks next_arg in
- if List.mem svar !constrained_vars then []
- else
- let phi = Formula.Rel (rname, [|svar|]) in
- [phi] in
+ (* if List.mem svar !constrained_vars then [] *)
+ (* else *)
+ let phi = Formula.Rel (rname, [|svar|]) in
+ [phi] in
let conjs =
Aux.concat_map (fun (rel, args as fact) ->
if rel = "true" then
@@ -1910,8 +2129,9 @@
| v, t as v_sb ->
let rname = term_to_name (subst_one v_sb mask) in
Some (Formula.Rel (rname, [|svar|]))) sb in
- if conjs <> [] || List.mem svar !constrained_vars
- then conjs else [phi]
+ phi::conjs
+ (* if conjs <> [] || List.mem svar !constrained_vars *)
+ (* then conjs else [phi] *)
else if List.mem rel static_rnames then
(* 7i-4a *)
pos_conjs_4a pos_state_subterms fact
@@ -1923,8 +2143,15 @@
let neg_conjs =
Aux.concat_map (function
| _, [rel, args as fact] ->
- if rel = "true" then []
- else if rel = "_DOES_PLACEHOLDER_"
+ if rel = "true" && !mask_anchors_of_neg = Positive_anch
+ then
+ (* 7i-4c *)
+ let true_arg = List.hd args in
+ let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
+ let rname = term_to_name mask in
+ let _, svar = toss_var masks true_arg in
+ [Formula.Rel (rname, [|svar|])]
+ else if rel = "true" || rel = "_DOES_PLACEHOLDER_"
then []
else if List.mem rel static_rnames then
(* 7i-4a *)
@@ -1932,6 +2159,7 @@
(pos_conjs_4a pos_state_subterms fact)
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -1940,27 +2168,43 @@
"translate_game: (7i) unexpected dynamic %s\n%!" rel;
assert false)
| _ -> []) neg_body in
- let all_conjs = phi @ conjs @ pconjs_4b @ neg_conjs in
- let phi = Formula.And all_conjs in
+ let all_conjs = phi @ conjs @ neg_conjs in
+ (* filter 4b not to do unnecessary work in solver *)
+ let used_vars = FormulaOps.free_vars (Formula.And all_conjs) in
+ let local_4b =
+ List.filter (fun f ->
+ List.for_all (fun v->List.mem v used_vars)
+ (FormulaOps.free_vars f)) pconjs_4b in
+ let phi = Formula.And (all_conjs @ local_4b) in
let phi = Formula.Ex (FormulaOps.free_vars phi, phi) in
(* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "evaluating:\nbranch=%s\nphi=%s\n%!"
+ if !debug_level > 4 then (
+ Printf.printf "translate-evaluating:\nbranch=%s\nphi=%s\n%!"
(exp_def_str ("eval", [br]))
- (Formula.str phi)
+ (Formula.sprint phi)
);
(* }}} *)
if Solver.M.check struc phi
then (
(* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "holds\n%!"
+ if !debug_level > 4 then (
+ Printf.printf "translate-holds\n%!"
);
(* }}} *)
Some (next_arg,body,neg_body))
- else None
+ else (
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "translate-doesn't hold\n%!"
+ );
+ (* }}} *)
+ if conjunctive
+ then raise Failed_branch
+ else None)
| _ -> assert false) brs in
+
(* 7j *)
+ (* FIXME: shouldn't the result of expansion be used? *)
let check_brs =
expand_branch_vars masks playout_terms
~freshen_unfixed:(Aux.Left false)
@@ -1971,7 +2215,7 @@
("GDL.translate_game: expanding variables resulting in "^
"duplicating Toss rules not implemented yet");
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "Filtered-branches:\n%s\n%!"
(exp_def_str ("filtered",
List.map (fun (next_arg,body,neg_body) ->
@@ -1994,7 +2238,7 @@
) Terms.empty brs in
let pos_state_terms = Terms.elements pos_state_terms in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "pos_state_terms: %s\n%!"
(String.concat ", " (List.map term_str pos_state_terms))
);
@@ -2022,10 +2266,10 @@
let mask, sb, m_sb, blanked = term_to_blank masks next_arg in
let rname = term_to_name mask in
let _, svar = toss_var masks next_arg in
- if List.mem svar !constrained_vars then []
- else
- let phi = Formula.Rel (rname, [|svar|]) in
- [phi] in
+ (* if List.mem svar !constrained_vars then [] *)
+ (* else *)
+ let phi = Formula.Rel (rname, [|svar|]) in
+ [phi] in
let conjs =
Aux.concat_map (fun (rel, args as fact) ->
if rel = "true" then
@@ -2041,8 +2285,9 @@
| v, t as v_sb ->
let rname = term_to_name (subst_one v_sb mask) in
Some (Formula.Rel (rname, [|svar|]))) sb in
- if conjs <> [] || List.mem svar !constrained_vars
- then conjs else [phi]
+ phi::conjs
+ (*if conjs <> [] || List.mem svar !constrained_vars
+ then conjs else [phi] *)
else if List.mem rel static_rnames then
(* 7i-4a *)
pos_conjs_4a pos_state_subterms fact
@@ -2063,6 +2308,7 @@
(pos_conjs_4a pos_state_subterms fact)
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -2106,6 +2352,7 @@
then []
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -2113,6 +2360,36 @@
(* dynamic relations have been expanded *)
assert false)
) body in
+ let pos_of_neg_conjs =
+ Aux.concat_map (function
+ | _, [rel, args (* as fact *)] ->
+ if rel = "true" && !mask_anchors_of_neg = Positive_anch
+ then
+ (* 7i-4c *)
+ let true_arg = List.hd args in
+ let mask, sb, m_sb, blanked = term_to_blank masks true_arg in
+ let rname = term_to_name mask in
+ let _, svar = toss_var masks true_arg in
+ [Formula.Rel (rname, [|svar|])]
+ else []
+ (* FIXME: is the rest handled properly as [neg_conjs]? *)
+ (*if rel = "true" || rel = "_DOES_PLACEHOLDER_"
+ then []
+ else if List.mem rel static_rnames then
+ (* 7i-4a *)
+ List.map (fun c -> Formula.Not c)
+ (pos_conjs_4a pos_state_subterms fact)
+ else if rel = "distinct" then
+ (* 7i0 *)
+ (* TODO! *)
+ if Aux.not_unique args then [Formula.Or []]
+ else []
+ else (
+ (* dynamic relations have been expanded *)
+ Printf.printf
+ "translate_game: (7i) unexpected dynamic %s\n%!" rel;
+ assert false)*)
+ | _ -> []) neg_body in
let neg_conjs =
Aux.map_some (fun (local_vs, neg_conjs) ->
(* 7k-4a-1 *)
@@ -2170,6 +2447,8 @@
| Pairs_star ->
match vars with [] -> []
| v::vs -> List.map (fun w -> [|v; w|]) vs in
+ if !equivalences_ordered then
+ List.iter (Array.sort Pervasives.compare) tups;
List.map (fun tup -> Formula.Rel (rname, tup)) tups
) terms
) neg_path_subterms in
@@ -2205,7 +2484,9 @@
Formula.Rel (rname, [|svar|])) m_sb in
let conjs =
conjs_4b @ conjs_4c @ conjs_5 in
- if conjs = [] then [phi] else conjs
+ if conjs = [] && !mask_anchors_of_neg = Negative_anch
+ then [phi]
+ else conjs
else if rel = "_DOES_PLACEHOLDER_"
then []
else if List.mem rel static_rnames then
@@ -2223,6 +2504,7 @@
conjs_4a_2 @ conjs_4a_3
else if rel = "distinct" then
(* 7i0 *)
+ (* TODO! *)
if Aux.not_unique args then [Formula.Or []]
else []
else (
@@ -2241,7 +2523,8 @@
else Formula.Not (Formula.Ex (
(uni_toss_vars :> Formula.var list), phi))) res
) neg_body in
- let all_conjs = !static_conjs @ dyn_conjs @ neg_conjs in
+ let all_conjs =
+ !static_conjs @ dyn_conjs @ pos_of_neg_conjs @ neg_conjs in
(rhs_pos_preds, !static_conjs, all_conjs),
(next_arg, body, neg_body)) brs in
pconjs_4b, brs
@@ -2373,7 +2656,9 @@
let static_rules, exp_static_rules =
List.partition (fun ((rel,args), _, _) ->
List.length args <= !expand_arity_above ||
- List.exists (function ((r,_),[],[]) when rel=r-> true
+ List.exists (function
+ | ((r,_),[],[]) when rel=r-> true
+ | ((r,_),body,_) when rel=r && List.mem_assoc r body-> true
| _ -> false) static_rules
) static_rules in
(* {{{ log entry *)
@@ -2385,6 +2670,7 @@
let static_exp_defs = expand_def_rules exp_static_rules in
let static_rules = Aux.unique_sorted
(List.map Aux.fst3 static_rules) in
+ let static_rnames = List.map fst static_rules in
let exp_defs =
expand_def_rules ~more_defs:static_exp_defs dynamic_rules in
@@ -2399,18 +2685,33 @@
let next_rules = List.assoc "next" exp_defs in
let terminal_rules = List.assoc "terminal" exp_defs in
let goal_rules = List.assoc "goal" exp_defs in
+ let legal_rules =
+ Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule]
+ | [Var v; lterm], body, neg_body ->
+ Array.to_list
+ (Array.map (fun player ->
+ let sb = [v, player] in
+ [player; subst sb lterm],
+ subst_rels sb body,
+ List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body)
+ player_terms)
+ | [Func _; lterm], _, _ ->
+ (* TODO: easy to fix *)
+ failwith "GDL.translate_game: bigger player terms not handled yet"
+ | _ -> assert false) legal_rules in
(* 3b *)
let exp_next = subst_legal_rules legal_rules next_rules in
-
(* {{{ log entry *)
if !debug_level > 0 then (
Printf.printf "translate_game: \"next\" rules with \"does\"<-\"legal\":\n%s\n%!"
- (exp_def_str ("next", exp_next))
+ (exp_def_str ("next", List.map snd exp_next))
);
(* }}} *)
(* 3c *)
- let masks = List.map (function
- | [next_arg], body, neg_body ->
+ (* [remove_orig]: branches with "nasty" fluents, ignoring them
+ (assuming they are nonerasing frame branches) *)
+ let remove_orig, masks = Aux.partition_map (function
+ | orig_br, ([next_arg], body, neg_body) ->
let collect = Aux.map_some
(function "true", [arg] -> Some arg
| "true", _ -> raise
@@ -2423,22 +2724,33 @@
let pos_gens = List.map (generalize next_arg) pos_cands in
let neg_gens = List.map (generalize next_arg) neg_cands in
(* using the fact that Pervasives.compare is lexicographic *)
- let pos_gen = List.fold_left max ((-1,0),0,Const "") pos_gens in
- let neg_gen = List.fold_left max ((-1,0),0,Const "") neg_gens in
- let (_, fresh_count, mask as gen) = max pos_gen neg_gen in
- if gen == pos_gen then mask
- else abstract_consts fresh_count mask
+ let pos_gen = List.fold_left max ((-1,0),0,[],Const "") pos_gens in
+ let neg_gen = List.fold_left max ((-1,0),0,[],Const "") neg_gens in
+ let (_, fresh_count, mism, mask as gen) = max pos_gen neg_gen in
+ (* 3c3 *)
+ if !nonerasing_frame_wave &&
+ List.exists (function Var _, _ -> true | _ -> false) mism
+ then Aux.Left orig_br
+ else if gen == pos_gen then Aux.Right mask
+ (* 3c2 *)
+ else Aux.Right (abstract_consts fresh_count mask)
| _ -> raise
(Lexer.Parsing_error
("GDL.initialize_game: invalid arity of \"next\" atom")))
exp_next in
+ (* exp_next is not used anymore *)
+ (* 3c3 *)
+ let next_rules = Aux.list_diff next_rules remove_orig in
(* {{{ log entry *)
if !debug_level > 1 then (
Printf.printf "translate_game: Generalized element terms (mask candidates):\n%s\n%!"
- (String.concat " " (List.map term_str masks))
+ (String.concat " " (List.map term_str masks));
+ Printf.printf "translate_game: removing \"next\" rules:\n%s\nfiltered \"next\" rules:\n%s\n%!"
+ (exp_def_str ("next", remove_orig)) (exp_def_str ("next", next_rules))
);
(* }}} *)
(* find minimal *)
+ (* TODO: generalize more, like in the paper *)
let masks = Aux.maximal (fun t1 t2->cmp_masks t2 t1) masks in
(* {{{ log entry *)
if !debug_level > 1 then (
@@ -2453,7 +2765,10 @@
Aux.map_try (fun mask ->
mask, match_meta [] [] [term] [mask]) masks
with [mask, (sb, m_sb)] -> mask, sb, m_sb
- | _ -> assert false in (* masks are minimal *)
+ | cur_masks ->
+ Printf.printf "conflicting masks: %s for %s\n%!"
+ (terms_str (List.map fst cur_masks)) (term_str term);
+ assert false in (* masks are minimal *)
let sbs, elements =
try Aux.pop_assoc mask elements
with Not_found -> [], elements in
@@ -2647,20 +2962,6 @@
List.map (fun (path, subts) -> path, Aux.unique_sorted subts)
(Aux.collect dyn_rels) in
(* 7a *)
- let legal_rules =
- Aux.concat_map (function [Const _; _], _, _ as lrule -> [lrule]
- | [Var v; lterm], body, neg_body ->
- Array.to_list
- (Array.map (fun player ->
- let sb = [v, player] in
- [player; subst sb lterm],
- subst_rels sb body,
- List.map (fun (uni_vs,neg) -> uni_vs, subst_rels sb neg) neg_body)
- player_terms)
- | [Func _; lterm], _, _ ->
- (* TODO: easy to fix *)
- failwith "GDL.translate_game: bigger player terms not handled yet"
- | _ -> assert false) legal_rules in
(* expanded "next" branches indexed by locations, then "legal"
branches, then by MGUs for unifier equivalence classes *)
let loc_lead_legal, loc_noop_legal =
@@ -2705,7 +3006,7 @@
if ply mod loc_n = i then
loc_actions := actions @ !loc_actions) agg_actions;
(* {{{ log entry *)
- if !debug_level > 4 then (
+ if !debug_level > 3 then (
Printf.printf "Possible actions in location %d:\n%s\n%!"
i (String.concat "; "
(List.map (fun a -> term_str (Func ("legal", a))) !loc_actions))
@@ -2771,13 +3072,33 @@
(* now, continue with the lead player *)
let unifs = Aux.map_some (* and substituted legal br-es *)
(fun next_br ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "matching-next-legal:\n%s\n%!"
+ (exp_def_str ("orig-br", [next_br]))
+ );
+ (* }}} *)
match
subst_legal_rule lead_legal (freshen_branch next_br)
with None -> None
| Some (([_; lead],lead_body,lead_neg_body), br) ->
+ (* {{{ log entry *)
+ if !debug_level > 3 then (
+ Printf.printf "matching-next-legal-result:\n%s\n%!"
+ (exp_def_str ("matched-br", [br]))
+ );
+ (* }}} *)
Some ((lead,lead_body,lead_neg_body), br)
| _ -> assert false)
next_rules in
+ (* {{{ log entry *)
+ if !debug_level > 1 then (
+ Printf.printf
+ "Rule precursors for loc %d:\nprecursor-branches:\n%s\n%!"
+ loc (exp_def_str ("precursor", List.map snd unifs));
+ );
+ (* }}} *)
+
(* building "Hasse layers" imperatively *)
let unifs = ref unifs in
let hasse_layer () =
@@ -2817,6 +3138,13 @@
let rules_brs =
List.map (fun ((lead_head, lead_body, lead_neg_body),
branches) ->
+ let branches =
+ expand_branch_vars masks element_terms
+ (* ~freshen_unfixed:(Aux.Right fixed_vars) *)
+ (* ~freshen_unfixed:(Aux.Left true) *)
+ ~freshen_unfixed:(Aux.Left false)
+ branches in
+ let branches = List.map snd branches in
let lead_does =
"_DOES_PLACEHOLDER_", [loc_players.(loc); lead_head] in
let lead_body = lead_does::lead_body in
@@ -2826,6 +3154,7 @@
| [next_arg],_,_ ->
Aux.Strings.subset (term_vars next_arg) fixed_vars
| _ -> assert false) branches in
+ (* TODO: see (7f1) TODO *)
let frame_brs, to_expand = List.partition
(function
| [next_arg],_,_ ->
@@ -2838,14 +3167,11 @@
List.exists
(fun (rel, r_args) -> rel="true" && r_args=args) body
) frame_brs in
- let unfixed_brs =
+ (* FIXME: it's called expanded because initially unfixed
+ variables (outside frame branches) were eliminated --
+ clean up *)
+ let expanded_brs =
to_expand @ more_to_expand in
- (* 7g *)
- let expanded_brs =
- expand_branch_vars masks element_terms
- ~freshen_unfixed:(Aux.Right (Aux.Strings.elements fixed_vars))
- unfixed_brs in
- let expanded_brs = List.map snd expanded_brs in
(* 7f2 *)
let leq3 (head1, _, _) (head2, _, _) =
try
@@ -2859,7 +3185,7 @@
List.filter (fun cl->leq3 cl repr) frame_brs)
frame_brs) in
(* {{{ log entry *)
- if !debug_level > 3 then (
+ if !debug_level > 4 then (
Printf.printf "frames: heads partitioning =\n%s\n%!"
(String.concat "\n"
(List.map (fun l ->
@@ -2887,7 +3213,7 @@
repr_head, multi_body
) frames in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "frames: heads = %s\n%!"
(String.concat ", " (List.map (function [h],_ ->term_str h
| _ -> assert false) frames))
@@ -2901,11 +3227,11 @@
| [next_arg] as next_args,multi_body ->
let mask, _, _, blank_arg = term_to_blank masks next_arg in
(* {{{ log entry *)
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "Blanking-out of %s by %s\n%!"
(term_str next_arg) (term_str mask)
);
- if !debug_level > 2 then (
+ if !debug_level > 4 then (
Printf.printf "Frame multibody:\n%s\n%!"
( String.concat "\n" (List.map (
fun (body, neg_body) ->
@@ -2922,7 +3248,8 @@
then Some (Aux.Left (rel, args))
else None) body in
let neg_body =
- List.map
+ (* we drop failed equality from the disjuction *)
+ Aux.map_try
(function
| _, ["distinct", []] -> assert false
| _, ["distinct", arg::more_args] ->
@@ -2943,9 +3270,21 @@
| _, conj ->
Aux.Right (Aux.Left conj))
neg_body in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "body length = %d; neg_body length = %d\n%!"
+ (List.length body) (List.length neg_body)
+ );
+ (* }}} *)
body @ neg_body) multi_body in
let erasures = List.map Aux.partition_choice
(Aux.unique_sorted (Aux.product multi_body)) in
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "initial erasures length = %d\n%!"
+ (List.length erasures)
+ );
+ (* }}} *)
let erasures =
Aux.map_some (fun (neg_body, body) ->
try
@@ -2994,99 +3333,228 @@
Some ([head], lead_body @ body,
lead_neg_body @ neg_body)
(*or not
- Some ([head], body, neg_body)*)
+ Some ([head], body, neg_body)*)
)
- else None
+ else (
+ (* {{{ log entry *)
+ if !debug_level > 4 then (
+ Printf.printf "unsatisfiable-erasure:\n%s\n%s\n%!"
+ (lit_def_str ("erasure", [
+ [head], body, neg_body]))
+ (exp_def_str ("lead", [
+ [lead_head], lead_body, lead_neg_body]))
+ );
+ (* }}} *)
+ None)
with Not_found -> None) erasures in
let erasures = Aux.unique_sorted
(List.map (fun (head, body, neg_body) ->
head, Aux.unique_sorted body,
Aux.unique_sorted neg_body) erasures) in
+ ...
[truncated message content] |
|
From: <luk...@us...> - 2011-04-21 00:48:56
|
Revision: 1422
http://toss.svn.sourceforge.net/toss/?rev=1422&view=rev
Author: lukaszkaiser
Date: 2011-04-21 00:48:48 +0000 (Thu, 21 Apr 2011)
Log Message:
-----------
Starting to move features from Boolean formulas to Formula (but no fixed-points yet), adding paper stuff.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/Formula.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/www/Publications/all.bib
trunk/Toss/www/reference/reference.tex
Added Paths:
-----------
trunk/Toss/www/pub/gdl_to_toss_translation.pdf
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -730,6 +730,13 @@
BAnd [simp1; simp2]
+let to_sat ?(tm=1200.) phi =
+ let rec all_vars acc = function
+ | BVar v -> (abs v) :: acc
+ | BNot f -> all_vars acc f
+ | BOr fl | BAnd fl -> List.fold_left all_vars acc fl in
+ to_dnf ~disc_vars:(all_vars [] phi) ~tm phi
+
let sort_freq phi vars =
let rec occ v acc = function
| BVar w -> if abs v = abs w then acc + 1 else acc
@@ -740,7 +747,7 @@
let fq v = Hashtbl.find freqs v in
List.sort (fun v w -> (fq v) - (fq w)) vars
-let (tm_jump, cutvar, has_vars_mem) = (1.1, 3, Hashtbl.create 31)
+let (tm_jump, cutvar, has_vars_mem) = (1.1, 2, Hashtbl.create 31)
let _ () = debug_elim := true
@@ -886,7 +893,7 @@
(* Returns a quantifier-free formula equivalent to All (vars, phi). *)
let elim_all vars phi =
- elim_all_rec " " 0.3 (List.map (fun v -> abs v) vars) (to_nnf phi)
+ elim_all_rec " " 0.4 (List.map (fun v -> abs v) vars) (to_nnf phi)
(* Returns a quantifier-free formula equivalent to Ex (vars, phi). *)
let elim_ex vars phi =
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-21 00:48:48 UTC (rev 1422)
@@ -63,7 +63,10 @@
val to_dnf : ?disc_vars: int list -> ?tm: float ->
bool_formula -> bool_formula option
+(** Convert a Boolean formula to Sat-equivalent form, "BOr []" on Unsat. *)
+val to_sat : ?tm: float -> bool_formula -> bool_formula option
+
(** {2 Boolean Quantifier Elimination and QBF} *)
(** Returns a quantifier-free formula equivalent to All (vars, phi). *)
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -407,6 +407,28 @@
);
]
-let exec = Aux.run_test_if_target "BoolFormulaTest" tests
+let exec () = Aux.run_test_if_target "BoolFormulaTest" tests
-let execbig = Aux.run_test_if_target "BoolFormulaTest" bigtests
+let execbig ()= Aux.run_test_if_target "BoolFormulaTest" bigtests
+
+
+let main () =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ let (file) = (ref "") in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> set_debug_elim true), "be verbose");
+ ("-d", Arg.Int (fun i -> set_debug_level i), "set debug level");
+ ("-f", Arg.String (fun s -> file := s), "process file");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ if !file = "" then ( exec (); execbig (); ) else (
+ let f = open_in !file in
+ let qbf = read_qdimacs f in
+ close_in f;
+ print_endline (BoolFormula.str (elim_quant qbf))
+ )
+
+let _ = Aux.run_if_target "BoolFormulaTest" main
Modified: trunk/Toss/Formula/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFunction.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -263,8 +263,8 @@
if new_defs = defs then defs else inline_defs new_defs
-(* Convert a function to DNF with eliminated quantifiers. *)
-let dnf classes f =
+(* Apply [boolf] to the formula with eliminated quantifiers; [msg] debugging.*)
+let apply_bool_elim boolf msg classes f =
let (nbrs, names, free) = (Hashtbl.create 31, Hashtbl.create 31, ref 1) in
let nbr (m, n) =
try Hashtbl.find nbrs (m, n) with Not_found ->
@@ -293,7 +293,7 @@
| And fl -> And (List.map elim_quant fl)
| Or fl -> Or (List.map elim_quant fl)
| Ex (vs, f) ->
- let elim = elim_quant f in
+ let elim = to_nnf (triv_simp (elim_quant f)) in
if !debug_level > 1 then Format.printf "Eliminating@ Ex@ %a@ .@ %a@\n%!"
fprint_mod_var_list vs fprint elim;
let elim_bool = to_bool elim in
@@ -305,21 +305,41 @@
fprint res;
res in
let elim_simp = elim_quant (triv_simp (to_nnf f)) in
- if !debug_level > 0 then Format.printf "BoolFunction: Converting to DNF@\n%!";
- let res = from_bool (Aux.unsome (to_dnf (to_bool elim_simp))) in
if !debug_level > 0 then
- Format.printf "BoolFunction: Computed DNF:@\n%a@\n%!" fprint res;
- triv_simp res
+ Format.printf "BoolFunction: Computing %s@\n%!" msg;
+ match boolf (to_bool elim_simp) with
+ | None -> if !debug_level > 0 then Format.printf "Failed.@\n%!"; None
+ | Some boolphi ->
+ let res = triv_simp (from_bool boolphi) in
+ if !debug_level > 0 then
+ Format.printf "BoolFunction: Computed %s:@\n%a@\n%!" msg fprint res;
+ Some (res)
+(* Convert a function to DNF with eliminated quantifiers. *)
+let dnf ?(tm=1200.) = apply_bool_elim (to_dnf ~tm) "DNF"
+
+(* Convert a function to CNF with eliminated quantifiers. *)
+let cnf ?(tm=1200.) = apply_bool_elim (to_cnf ~tm) "CNF"
+
+(* Convert a function to SAT-form with eliminated quantifiers. *)
+let sat cls f = Aux.unsome (apply_bool_elim to_sat "SAT" cls f)
+
+let nonf ?(tm=1200.) = apply_bool_elim (fun x -> Some (simplify x)) "ELIM"
+
(* Solve fixed-points in the definitions. *)
-let solve_lfp cls all_defs =
+let solve_lfp ?(nf=0) cls all_defs =
let (deffp, defsimp) =
List.partition (fun (_, fp, _, _) -> fp) (inline_defs all_defs) in
let defs = List.map (fun (_, _, _, f) -> f) deffp in
let subst2 = List.map2 (fun (n, _, a, _) f -> (n, false, a, f)) deffp in
let startdef = subst2 (List.map (fun _ -> Or []) deffp) in
- let next df = subst2 (List.map (fun f-> dnf cls (apply_defs df f)) defs) in
- let rec fp acc df =
- let nx = next df in (* We have weak reduction, must memoize for now. *)
- if List.mem nx (df :: acc) then df else fp (df :: acc) nx in
- defsimp @ (fp [] startdef)
+ let xnf c f =
+ Aux.unsome (if nf=0 then nonf c f else if nf=1 then cnf c f else dnf c f) in
+ let next df = subst2 (List.map (fun f-> xnf cls (apply_defs df f)) defs) in
+ let rec fp df =
+ let nx = next df in
+ let ((_,_,_,nxf), (_,_,_,dff)) = (List.hd nx, List.hd df) in
+ match sat cls (And [nxf; Not (dff)]) with
+ | Or [] -> df
+ | _ -> fp nx in
+ defsimp @ (fp startdef)
Modified: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFunction.mli 2011-04-21 00:48:48 UTC (rev 1422)
@@ -82,7 +82,9 @@
val inline_defs : bool_def list -> bool_def list
(** Convert a function to DNF with eliminated quantifiers. *)
-val dnf : (string * string list) list -> bool_function -> bool_function
+val dnf : ?tm:float ->
+ (string * string list) list -> bool_function -> bool_function option
(** Inline and solve fixed-points in the definitions. *)
-val solve_lfp : (string * string list) list -> bool_def list -> bool_def list
+val solve_lfp : ?nf:int ->
+ (string * string list) list -> bool_def list -> bool_def list
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -113,12 +113,15 @@
Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
let (file, print_bool, debug_level) = (ref "", ref false, ref 0) in
let dbg_level i = (debug_level := i; BoolFunction.set_debug_level i) in
- let (only_inline, only_fp) = (ref false, ref false) in
+ let (only_inline, only_fp, nf) = (ref false, ref false, ref 0) in
let opts = [
("-v", Arg.Unit (fun () -> dbg_level 1), "be verbose (= -d 1)");
("-d", Arg.Int (fun i -> dbg_level i), "set debug level");
("-b", Arg.Unit (fun () -> print_bool := true), "print bool's");
("-f", Arg.String (fun s -> file := s), "process file");
+ ("-nonf", Arg.Unit (fun () -> nf := 0), "use no immediate form (default)");
+ ("-cnf", Arg.Unit (fun () -> nf := 1), "use cnf as immediate form");
+ ("-dnf", Arg.Unit (fun () -> nf := 2), "use dnf as immediate form");
("-only-inline", Arg.Unit (fun () -> only_inline := true),
"do not compute the fixed-points or goals, only inline definitions");
("-only-fixedpoint", Arg.Unit (fun () -> only_fp := true),
@@ -138,11 +141,12 @@
try
let (cl, dl, goal) = defs_goal_of_string res_s in
let new_defs =
- if !only_inline then (cl, inline_defs dl) else (cl, solve_lfp cl dl) in
+ if !only_inline then (cl, inline_defs dl) else
+ (cl, solve_lfp ~nf:(!nf) cl dl) in
let inline_goal = triv_simp (apply_defs (snd new_defs) goal) in
let new_goal =
if !only_inline || !only_fp then inline_goal else
- dnf cl inline_goal in
+ Aux.unsome (dnf cl inline_goal) in
if !only_inline || !only_fp || !debug_level > 0 then
print_defs ~print_bool:!print_bool new_defs;
print_endline "\n\n// GOAL FORMULA\n";
Modified: trunk/Toss/Formula/Formula.ml
===================================================================
--- trunk/Toss/Formula/Formula.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/Formula.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -392,42 +392,67 @@
| x -> x
+(* Flatten conjunctions and disjunctions, apply f's to the respective lists.
+ This function also reduces false and true atoms and propagates them. *)
+let rec flatten_f f_or f_and phi =
+ let get_conjunctions = function And fl -> fl | f -> [f] in
+ let get_disjunctions = function Or fl -> fl | f -> [f] in
+ let fold_acc f xl =
+ List.fold_left (fun acc x -> (f x) @ acc) [] xl in
+ let rev_collect_conj xl = fold_acc get_conjunctions xl in
+ let rev_collect_disj xl = fold_acc get_disjunctions xl in
+ match phi with
+ | Rel _ | Eq _ | In _ -> phi
+ | RealExpr (re, s) -> RealExpr (flatten_re_f f_or f_and re, s)
+ | Not phi ->
+ (match flatten_f f_or f_and phi with
+ | Or [] -> And []
+ | And [] -> Or []
+ | Not f -> f
+ | f -> Not f
+ )
+ | Or [phi] -> flatten_f f_or f_and phi
+ | Or fl when List.exists (fun x -> x = And []) fl -> And []
+ | Or fl ->
+ Or (rev_collect_disj (List.rev_map (flatten_f f_or f_and) fl))
+ | And [phi] -> flatten_f f_or f_and phi
+ | And fl when List.exists (fun x -> x = Or []) fl -> Or []
+ | And fl ->
+ And (rev_collect_conj (List.rev_map (flatten_f f_or f_and) fl))
+ | Ex (_, Or []) | All (_, Or []) -> Or []
+ | Ex (_, And []) | All (_, And []) -> And []
+ | Ex ([], phi) | All ([], phi) -> flatten_f f_or f_and phi
+ | Ex (xs, Ex (ys, phi)) -> flatten_f f_or f_and (Ex (xs @ ys, phi))
+ | Ex (xs, phi) -> Ex (xs, flatten_f f_or f_and phi)
+ | All (xs, All (ys, phi)) -> flatten_f f_or f_and (All (xs @ ys, phi))
+ | All (xs, phi) -> All (xs, flatten_f f_or f_and phi)
+
+and flatten_re_f f_or f_and = function
+ | RVar _ | Const _ | Fun _ as re -> re
+ | Times (re1, re2) ->
+ Times (flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2)
+ | Plus (re1, re2) ->
+ Plus (flatten_re_f f_or f_and re1, flatten_re_f f_or f_and re2)
+ | Char (phi) -> Char (flatten_f f_or f_and phi)
+ | Sum (vl, phi, r) ->
+ Sum (vl, flatten_f f_or f_and phi, flatten_re_f f_or f_and r)
+
+
(* Basic function to flatten formulas. *)
-let rec flatten = function
- Rel _ | Eq _ | In _ as phi -> phi
- | RealExpr (re, s) -> RealExpr (flatten_re re, s)
- | Not phi ->
- (match flatten phi with Not f -> f | f -> Not f)
- | Or [phi] -> flatten phi
- | Or flist_orig ->
- let flist = List.rev_map flatten flist_orig in
- let rec add_res acc = function
- | [] -> acc
- | (Or l) :: xs -> add_res (l @ acc) xs
- | f :: xs -> add_res (f :: acc) xs in
- Or (add_res [] flist)
- | And [phi] -> flatten phi
- | And flist_orig ->
- let flist = List.rev_map flatten flist_orig in
- let rec add_res acc = function
- | [] -> acc
- | (And l) :: xs -> add_res (l @ acc) xs
- | f :: xs -> add_res (f :: acc) xs in
- And (add_res [] flist)
- | Ex ([], phi) | All ([], phi) -> flatten phi
- | Ex (xs, Ex (ys, phi)) -> flatten (Ex (xs @ ys, phi))
- | Ex (xs, phi) -> Ex (xs, flatten phi)
- | All (xs, All (ys, phi)) -> flatten (All (xs @ ys, phi))
- | All (xs, phi) -> All (xs, flatten phi)
+let flatten psi = flatten_f (fun x -> x) (fun x -> x) psi
+let flatten_re psi = flatten_re_f (fun x -> x) (fun x -> x) psi
-and flatten_re = function
- RVar _ | Const _ | Fun _ as re -> re
- | Times (re1, re2) -> Times (flatten_re re1, flatten_re re2)
- | Plus (re1, re2) -> Plus (flatten_re re1, flatten_re re2)
- | Char (phi) -> Char (flatten phi)
- | Sum (vl, f, r) -> Sum (vl, flatten f, flatten_re r)
+let flatten_sort =
+ let clean fl = del_dupl_ord [] (List.sort compare fl) in
+ flatten_f (fun fl -> set_first_lit_or (clean fl))
+ (fun fl -> set_first_lit_and (clean fl))
+let flatten_sort_re =
+ let clean fl = del_dupl_ord [] (List.sort compare fl) in
+ flatten_re_f (fun fl -> set_first_lit_or (clean fl))
+ (fun fl -> set_first_lit_and (clean fl))
+
(* Helper function to flatten multiple or's and and's and sort by compare. *)
let rec flatten_sort = function
Rel _ | Eq _ | In _ as phi -> phi
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2011-04-21 00:48:48 UTC (rev 1422)
@@ -146,7 +146,7 @@
"assign emptyset" >::
(fun () ->
let asg s = FormulaOps.assign_emptyset s in
- let asg_eq s phi1 phi2 = formula_eq id phi2 (asg s) phi1 in
+ let asg_eq s phi1 phi2 = formula_eq Formula.flatten phi2 (asg s) phi1 in
asg_eq "X" "ex x (x in X and P(x) and (Q(y) or R(x)))"
"ex x ((false and P(x)) and (Q(y) or R(x)))";
let plus = "ex X ex zero (all n (LessEq(zero,n)) and
@@ -154,9 +154,9 @@
((s in C) <-> (t in X)))))" in
asg_eq "X" plus "ex X, zero ((all n (LessEq(zero, n)) and ex C
(((not (zero in C)) and all t, s (((not Succ(t, s)) or
- (not s in C and not false) or (s in C and false)))))))";
+ (not s in C and true) or (s in C and false)))))))";
let plus_empty_X =
- Formula.str (Formula.flatten_sort (asg "C" (formula_of_string plus))) in
+ Formula.str (Formula.flatten_sort(asg "C" (formula_of_string plus))) in
asg_eq "C" plus_empty_X "ex X, zero ((all n (LessEq(zero, n)) and ex C
(all t, s (((not Succ(t, s)) or (not (t in X)))))))";
);
Modified: trunk/Toss/www/Publications/all.bib
===================================================================
--- trunk/Toss/www/Publications/all.bib 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/www/Publications/all.bib 2011-04-21 00:48:48 UTC (rev 1422)
@@ -97,11 +97,28 @@
# ARTICLES
+@inproceedings{KS11transl,
+ author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak},
+ title = {Translating the Game Description Langauge to Toss},
+ year = {2011},
+ booktitle = {to appear},
+ url = {/pub/gdl_to_toss_translation.pdf},
+ abstract = {
+We show how to translate games defined in the Game Description
+Language (GDL) into the Toss format. GDL is a variant of Datalog
+used to specify games in the General Game Playing Competition.
+Specifications in Toss are more declarative than in GDL and make
+it easier to capture certain useful game characteristics.
+The presented translation detects structural properties of games
+which are not directly visible in the GDL specification.
+ }
+}
+
@inproceedings{KS11,
author = {\L{}ukasz Kaiser and \L{}ukasz Stafiniak},
title = {First-Order Logic with Counting for General Game Playing},
year = {2011},
- booktitle = {review},
+ booktitle = {Proceedings of the 25th AAAI Conference},
url = {/pub/first_order_counting_ggp.pdf},
abstract = {
General Game Players (GGPs) are programs which can play an arbitrary game
Added: trunk/Toss/www/pub/gdl_to_toss_translation.pdf
===================================================================
(Binary files differ)
Property changes on: trunk/Toss/www/pub/gdl_to_toss_translation.pdf
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/Toss/www/reference/reference.tex
===================================================================
--- trunk/Toss/www/reference/reference.tex 2011-04-20 12:27:15 UTC (rev 1421)
+++ trunk/Toss/www/reference/reference.tex 2011-04-21 00:48:48 UTC (rev 1422)
@@ -57,6 +57,7 @@
% Packages
\usepackage{amsmath,amssymb,amsthm}
+\usepackage{MnSymbol}
\usepackage{enumerate}
\usepackage{xspace}
\usepackage{tikz}
@@ -86,6 +87,9 @@
\newcommand{\fv}{\ensuremath{\mathtt{FreeVar}}\xspace}
\newcommand{\rank}{\ensuremath{\mathtt{rank}}\xspace}
\newcommand{\hitrank}{\ensuremath{\mathtt{hit}\text{-}\mathtt{rank}}\xspace}
+\newcommand{\mgu}{\ensuremath{\mathrm{MGU}}}
+\newcommand{\ot}{\leftarrow}
+\newcommand{\tpos}{\downharpoonleft}
% Theorem environments
\theoremstyle{plain}
@@ -1103,6 +1107,762 @@
only push predicates to the front.
+\chapter{GDL to Toss Translation}
+
+\section{Game Description Language}
+
+The game description language, GDL, is a variant of Datalog used to
+specify games in a compact, prolog-like way. The GDL syntax and semantics
+are defined in \cite{GLP05,LHHSG08}, we refer the reader there for the
+definition and will only recapitulate some notions here.
+
+The state of the game in GDL is defined by the set of propositions
+true in that state. These propositions are represented by terms of
+limited height. The moves of the game, \ie the transition function
+between the states, are described using Datalog rules --- clauses
+define which predicates hold in the subsequent state. In this way
+a transition system is specified in a compact way. Additionally,
+there are 8 special relations in GDL: \texttt{role, init, true, does,
+next, legal, goal} and \texttt{terminal}, which are used to describe
+the game: initial state, the players, their goals, and thus like.
+
+We say that \emph{GDL state terms} are the terms that are possible arguments
+of \texttt{true}, \texttt{next} and \texttt{init} relations in a GDL
+specification, \ie those terms which can define the state
+of the game. The \emph{GDL move terms} are ground instances of
+the second arguments of \texttt{legal} and \texttt{does} relations,
+\ie those terms which are used to specify the moves of the players.
+
+The complete Tic-tac-toe specification in GDL is given in
+Figure~\ref{fig-ttt-gdl}. While games can be formalised in various
+ways in both systems, Figures \ref{fig-ttt-code} and \ref{fig-ttt-gdl}
+give natural examples of a formalisation, similar to several other games.
+
+
+\begin{figure}
+%\begin{center}
+\begin{verbatim}
+(role x)
+(role o)
+(init (cell a a b))
+(init (cell b a b))
+(init (cell c a b))
+(init (cell a b b))
+(init (cell b b b))
+(init (cell c b b))
+(init (cell a c b))
+(init (cell b c b))
+(init (cell c c b))
+(init (control x))
+(<= (next (control ?r)) (does ?r noop))
+(<= (next (cell ?x ?y ?r))
+ (does ?r (mark ?x ?y)))
+(<= (next (cell ?x ?y ?c))
+ (true (cell ?x ?y ?c))
+ (does ?r (mark ?x1 ?y1))
+ (or (distinct ?x ?x1) (distinct ?y ?y1)))
+(<= (legal ?r (mark ?x ?y))
+ (true (control ?r))
+ (true (cell ?x ?y b)))
+(<= (legal ?r noop) (role ?r)
+ (not (true (control ?r))))
+(<= (goal ?r 100) (conn3 ?r))
+(<= (goal ?r 50) (role ?r)
+ (not exists_line3))
+(<= (goal x 0) (conn3 o))
+(<= (goal o 0) (conn3 x))
+(<= terminal exists_line3)
+(<= terminal (not exists_blank))
+(<= exists_blank (true (cell ?x ?y b)))
+(<= exists_line3 (role ?r) (conn3 ?r))
+(<= (conn3 ?r) (or (col ?r) (row ?r)
+ (diag1 ?r) (diag2 ?r)))
+(<= (row ?r)
+ (true (cell ?a ?y ?r)) (nextcol ?a ?b)
+ (true (cell ?b ?y ?r)) (nextcol ?b ?c)
+ (true (cell ?c ?y ?r)))
+(<= (col ?r)
+ (true (cell ?x ?a ?r)) (nextcol ?a ?b)
+ (true (cell ?x ?b ?r)) (nextcol ?b ?c)
+ (true (cell ?x ?c ?r)))
+(<= (diag1 ?r)
+ (true (cell ?x1 ?y1 ?r))
+ (nextcol ?x1 ?x2) (nextcol ?y1 ?y2)
+ (true (cell ?x2 ?y2 ?r))
+ (nextcol ?x2 ?x3) (nextcol ?y2 ?y3)
+ (true (cell ?x3 ?y3 ?r)))
+(<= (diag2 ?r)
+ (true (cell ?x1 ?y5 ?r))
+ (nextcol ?x1 ?x2) (nextcol ?y4 ?y5)
+ (true (cell ?x2 ?y4 ?r))
+ (nextcol ?x2 ?x3) (nextcol ?y3 ?y4)
+ (true (cell ?x3 ?y3 ?r)))
+(nextcol a b)
+(nextcol b c)
+\end{verbatim}
+%\end{center}
+\caption{Tic-tac-toe in the Game Description Language.}
+\label{fig-ttt-gdl}
+\end{figure}
+
+\subsection{Notions Related to Terms}
+
+Since GDL is a term-based formalism, we will use the standard term
+notions, as \eg in the preliminaries of \cite{tata2007}.
+We understand terms as finite trees with ordered successors and
+labelled by the symbols used in the current game, with leafs
+possibly labelled by variables.
+
+\vskip 0.5em \noindent \textbf{Substitutions.}
+A \emph{substitution} is an assignment of terms to variables.
+Given a substitution $\sigma$ and a term $t$ we write $\sigma(t)$
+to denote the result of applying $\sigma$ to $t$, \ie of replacing all
+variables in $t$ which also occur in $\sigma$ by the corresponding terms.
+We extend this notation to tuples in the natural way.
+
+\noindent \textbf{MGU.}
+We say that a tuple of terms $\ol{t}$ is \emph{more general} than another
+tuple $\ol{s}$ of equal length, written $\ol{s} \leq \ol{t}$,
+if there is a substitution $\sigma$ such that $\ol{s} = \sigma(\ol{t})$.
+Given two tuples of terms $\ol{s}$ and $\ol{t}$ we write $\ol{s} \dot{=} \ol{t}$
+to denote that these tuples \emph{unify}, \ie that there exists
+a substitution $\sigma$ such that $\sigma(\ol{s}) = \sigma(\ol{t})$. In such
+case there exists a most general substitution of this kind,
+and we denote it by $\mgu(\ol{s}, \ol{t})$.
+
+\noindent \textbf{Paths.}
+A \emph{path} in a term is a sequence of pairs of function symbols and natural
+numbers denoting which successor to take in turn, \eg $p = (f,1)(g,2)$
+denotes the second child of a node labelled by $g$, which is the first
+child of a node labelled by $f$. For a term $t$ we write $t\tpos_p$ to
+denote the subterm of $t$ at path $p$, and that $t$ has a path $p$,
+i.e. that the respective sequence of nodes exists in $t$ with exactly
+the specified labels. Using $p = (f,1)(g,2)$ as an example,
+$f(g(a,b),c)\tpos_p = b$, but $g(f(a,b),c)\tpos_p$ is false.
+Similarly, for a formula $\phi$, we write $\phi(t\tpos_p)$
+to denote that $t$ has path $p$ and the subterm $r = t\tpos_p$
+satisfies $\phi(r)$. A path can be an empty sequence $\epsilon$ and
+$t\tpos_\epsilon = t$ for all terms $t$.
+
+For any terms $t, s$ and any path $p$ existing in $t$, we write $t[p \ot s]$
+to denote the result of \emph{placing $s$ at path $p$ in $t$}, \ie the term
+$t'$ such that $t'\tpos_p = s$ and on all other paths $q$, \ie ones which
+neither are prefixes of $p$ nor contain $p$ as a prefix, $t'$ is equal to $t$,
+\ie $t'\tpos_q = t\tpos_q$. We extend this notation to sets of paths as well:
+%$t[\{p_1, \ldots, p_n\} \ot s] = t[p_1 \ot s][p_2 \ot s] \cdots [p_n \ot s]$.
+$t[P \ot s]$ places $s$ at all paths from $P$ in $t$.
+
+
+
+\section{Translation} \label{sec-translate}
+
+In this section, we describe our main construction. Given a GDL specification
+of a game $G$, which satisfies the restrictions described in
+Section~\ref{sec-discussion}, we construct a Toss game $T(G)$ which
+represents exactly the same game. Moreover, we define a bijection $\mu$
+between the moves possible in $G$ and in $T(G)$ in each reachable state,
+so that the following correctness theorem holds.
+
+\begin{theorem}[Correctness] ~\\
+%For every GDL game specification $G$ satisfying the restrictions from
+%Section~\ref{sec-discussion}, the constructed Toss game $T(G)$ and move
+%translation functions $\mu$ satisfy the following conditions.
+Let $S$ be any state of $G$ reached from the initial one by a sequence
+of moves $m_1 \ldots m_n$. We write $\mu(S)$ for the state of $T(G)$
+reached by $\mu(m_1) \ldots \mu(m_n)$. The following conditions are satisfied.
+\begin{itemize}
+\item The function $\mu$ defines a bijection between the moves possible
+ in $S$ and in $\mu(S)$ for each player.
+\item If no move is possible in $S$ (and in $\mu(S)$), then the payoffs
+ in $G$ evaluate to the same value as those in $T(G)$.
+\end{itemize}
+\end{theorem}
+
+%The elements in $A$ will correspond to subsets of GDL state terms,
+%and the relations in $\frakA$ will correspond to various relations
+%that hold between the terms from the respective subsets, as explained later.
+%Each GDL move term will correspond to a rule--embedding pair
+%$(\frakL \to_s \frakR, \sigma)$ and each legal move $m$ in $G$ will
+%in this way induce a rule application $\hat{m}$ in Toss. We will also
+%translate the \texttt{goal} terms from $G$ to Toss payoffs $p(G)$ such
+%that the following theorem holds.
+
+We will not prove this theorem here, but the construction presented
+below should make it clear why the exact correspondence holds. For the
+rest of this section let us fix the GDL game specification $G$ we will
+translate. We begin by transforming $G$ itself: eliminating variables
+clearly referring to players (\ie arguments of positive \texttt{role}
+atoms, first arguments to positive \texttt{does} atoms and to
+\texttt{legal}) by substituting them by players of $G$ (\ie arguments
+of \texttt{role} facts), duplicating the clauses. From this transformed
+specification, we derive the elements of the Toss structure
+(Section~\ref{subsec-elems}), the relations (Section~\ref{subsec-rels}),
+the rewriting rules (Section~\ref{subsec-rules}) and finally the move
+translation function (Section~\ref{subsec-move-tr}).
+
+
+\subsection{Elements of the Toss Structure} \label{subsec-elems}
+
+By definition of GDL, the state of the game is described by a set
+of propositions true in that state. Let us denote by $\calS$ the set
+of all GDL state terms which are true at some game state reachable
+from the initial state of $G$.
+
+For us, it is enough to approximate $\calS$ from above. To approximate $\calS$
+and determine the location structure of the Toss game, we currently perform
+an \emph{aggregate playout}, \ie a symbolic play in where all players take
+all their legal moves in a state. Since an approximation is sufficient,
+we check only the positive part of the legality condition of each move.
+
+%The \emph{noop move} of a player in a
+%location is the only move available to her, determining them gives the
+%player of a turn. In the future, instead of an aggregate playout we
+%might use a form of type inference to approximate $\calS$.
+
+To construct the elements of the structure from state terms,
+and to make that structure a good representation of the game in Toss,
+we first determine which state terms always have common subtrees.
+
+\begin{definition} \label{def-merge}
+For two terms $s$ and $t$ we say that a set of paths $P$ \emph{merges}
+$s$ and $t$ if each $p \in P$ exists both in $s$ and $t$ and
+$t[P \ot c] = s[P \ot c]$ for all terms $c$. We denote by $d\calP(s,t)$
+the unique set $P$ of paths merging $s$ and $t$ for which the size of
+$t[P \ot c]$ is maximal and no subset of which merges $s$ and $t$.
+Intuitively, $t[d\calP(s,t) \ot c]$ is the largest common subtree
+of $s$ and $t$, the bigger its size the more similar $s$ and $t$ are.
+\end{definition}
+
+Let $\mathrm{Next}_{e}$ be the set of \texttt{next} clauses in $G$ with all
+atoms of \texttt{does} expanded (inlined) by the \texttt{legal}
+clause definitions, duplicating the \texttt{next} clause when more
+than one head of \texttt{legal} unifies with the \texttt{does} atom.
+Intuitively, these are expanded forms of clauses defining game state change.
+
+For each clause $\calC \in \mathrm{Next}_{e}$, we select two terms
+$s_\calC$ and $t_\calC$ in the following way. The term $s_\calC$ is
+simply the second part of the head of the clause \texttt{(next
+ $s_\calC$)}. The term $t_\calC$ is the argument of \texttt{true} in
+the body of $\calC$ which is most similar to $s$ in the sense of
+Definition~\ref{def-merge}, and of equally similar has smallest
+$d\calP(s,t)$ (if there are several, we pick one arbitrarily).
+
+We often use the word \emph{fluent} for changing objects, and so we
+define the set of \emph{fluent paths}, $\calP_f$, in the following way.
+We say that a term $t$ is a \emph{negative true} in a clause $\calC$ if
+it is the argument of a negative occurrence of \texttt{true} in $\calC$.
+We write $\calL(t)$ for the set of path to all constant leaves in $t$.
+The set
+\[ \calP_f \ = \
+ \bigcup_{\calC \in \mathrm{Next}_{e}} d\calP(s_\calC, t_\calC) \ \cup \
+ \bigcup_{\calC \in \mathrm{Next}_{e},\
+ t_\calC \text{ negative true in } \calC} \calL(t_\calC).
+ \]
+Note that $\calP_f$ contains all merge sets for the selected terms in
+$\mathrm{Next}_e$ clauses, and additionally, when $t_\calC$ is a negative true,
+we add the paths to all constant leaves in $t_\calC$.
+
+
+\begin{example}
+There are three \texttt{next} clauses in Figure~\ref{fig-ttt-gdl}.
+ $\calC_1$:
+\begin{verbatim}
+(<= (next (cell ?x ?y ?c))
+ (true (cell ?x ?y ?c))
+ (does ?r (mark ?x1 ?y1))
+ (or (distinct ?x ?x1) (distinct ?y ?y1)))
+\end{verbatim}
+ does not lead to any fluent paths, since \texttt{(cell ?x ?y ?c)} is
+ $s_{\calC_1} = t_{\calC_1}$ and thus $d\calP(s_{\calC_1}, t_{\calC_1}) = \emptyset$.
+ The clause:
+\begin{verbatim}
+(<= (next (cell ?x ?y ?r))
+ (does ?r (mark ?x ?y)))
+\end{verbatim}
+ expands to:
+\begin{verbatim}
+(<= (next (cell ?x ?y x))
+ (true (control x))
+ (true (cell ?x ?y b)))
+(<= (next (cell ?x ?y o))
+ (true (control o))
+ (true (cell ?x ?y b)))
+\end{verbatim}
+ These generate the fluent path $(\mathtt{cell},3)$. The clause:
+\begin{verbatim}
+(<= (next (control ?r)) (does ?r noop))
+\end{verbatim}
+ expands to:
+\begin{verbatim}
+(<= (next (control x))
+ (not (true (control x))))
+(<= (next (control o))
+ (not (true (control o))))
+\end{verbatim}
+ These generate the fluent path $(\mathtt{control},1)$ since
+ \texttt{(control x)} and \texttt{(control o)} are negative trues. In the end
+ $\calP_f = \{(\mathtt{cell},3), (\mathtt{control},1)\}$.
+\end{example}
+
+The fluent paths define the partition of GDL state terms into elements
+of the Toss structures in the following way.
+
+\begin{definition}
+We define the \emph{element mask equivalence} $\sim$ by:
+\[ t \sim s \quad \Leftrightarrow \quad
+ t[P_f \ot c] = s[P_f \ot c] \text{ for all terms } c.\]
+The set of elements $A$ of the initial Toss structure $\frakA$ consists
+of equivalence classes of $\sim$. For $a \in A$ we write $\lsem a \rsem$
+to denote the corresponding subset of equivalent terms from $\calS$.
+\end{definition}
+
+We define \emph{paths within mask} $\calP_m$ as such paths $p$ that,
+for all $a \in A$, if, for any $t \in \lsem a \rsem$, $t\tpos_p$,
+then for all $s,t\in \lsem a \rsem$, $s\tpos_p = t\tpos_p$.
+For $p \in \calP_m$ we can therefore define
+the \emph{mask subterm} $a\tpos^m_p$ as $t\tpos_p$ for $t \in \lsem a \rsem$.
+
+\begin{example}
+Continuing the example of the Tic-tac-toe specification
+from Figure~\ref{fig-ttt-gdl}, we construct the set $A$.
+The terms in $\calS$ are either $(\mathtt{cell}\ s\ t\ p)$ or
+$(\mathtt{control}\ q)$, where $s$ and $t$ range over \texttt{a, b, c},
+$p$ over \texttt{x, o, b} and $q$ can be \texttt{x} or \texttt{o}.
+Since $\calP_f = \{(\mathtt{cell},3), (\mathtt{control},1)\}$,
+we consider as $\sim$-equivalent all \texttt{cell} terms which differ
+only on $p$ and all \texttt{control} terms which differ on $q$.
+Thus, the set $A$ consists of $10$ elements: the element $a_{ctrl}$ for
+the single equivalence class of \texttt{control} terms, and $9$ elements
+$a_{s,t}$ for the equivalence classes of $(\mathtt{cell}\ s\ t\ p)$ with
+fixed $s$ and $t$. %We can write this set as follows
+\begin{align*}
+ A \ = \ \{ a_{ctrl}, \quad
+ & a_{\mathtt{a},\mathtt{a}},\ a_{\mathtt{a},\mathtt{b}},\ a_{\mathtt{a},\mathtt{c}}, \\
+ & a_{\mathtt{b},\mathtt{a}},\ a_{\mathtt{b},\mathtt{b}},\ a_{\mathtt{b},\mathtt{c}}, \\
+ & a_{\mathtt{c},\mathtt{a}},\ a_{\mathtt{c},\mathtt{b}},\ a_{\mathtt{c},\mathtt{c}} \}.
+\end{align*}
+Note the similarity to the starting structure in Figure~\ref{fig-tic-tac-toe},
+up to the control element. The set of paths within masks for this specification
+is $\calP_m = \{(\mathtt{cell},1), (\mathtt{cell},2)\}$.
+\end{example}
+
+
+\subsection{Relations in the Structure} \label{subsec-rels}
+
+Having defined the elements $A$ as equivalence classes of state terms,
+let us now define the relations in the initial structure $\frakA$.
+
+\vskip 0.5em
+\noindent \textbf{Subterm equality relations.}
+For all pairs of paths $p,q \in \calP_m$ we introduce
+the \emph{subterm equality relation} $Eq_{p,q}$:
+\[ Eq_{p,q}(a_1,a_2) \ \ \iff \ \ a_1\tpos^m_{p}\ =\ a_2\tpos^m_{q}. \]
+
+\noindent \textbf{Fact relations.}
+For all predicates $R$ of $G$ that do not (directly or indirectly) depend
+on the state, and all pairs of paths $p,q \in \calP_m$, we introduce
+the \emph{fact relation} $R_{p,q}$:
+\[ R_{p,q}(a_1,a_2) \ \ \iff \ \ R(a_1\tpos^m_{p},\ a_2\tpos^m_{q})
+ \text{ in any state}. \]
+
+\noindent \textbf{Anchor predicates.}
+For all paths $p \in \calP_m$ and subterms $s = t\tpos_p, t \in \calS$,
+we introduce the \emph{anchor predicate} $Anch^s_p(a)$:
+\[ Anch^s_p(a) \ \ \iff \ \ a\tpos^m_p\ =\ s. \]
+
+\noindent \textbf{Fluent predicates.}
+Let $\calS^{\text{init}} = \{ s \mid \mathtt{init}(s) \in G \}$
+be the set of state terms under \texttt{init}. For all paths
+$p \in \calP_f$ and subterms $s = t\tpos_p, t \in \calS$,
+we introduce the \emph{fluent predicate} $Flu^s_p(a)$:
+\[ Flu^s_p(a) \ \ \iff \ \ t\tpos_p\ =\ s \text{ for some }
+ t \in \lsem a \rsem \cap \calS^{\text{init}}. \]
+
+\noindent \textbf{Mask predicates.}
+We say that a term $m$ is a \emph{mask term} if the paths to all variables
+of $m$ are contained in $\calP_m \cup \calP_f$ and for each
+$p \in \calP_m \cup \calP_f$ if $p$ exists in $m$ then $m \tpos_p$ is
+a variable. We say that $m$ \emph{masks} a terms $t$ if there exists
+a substitution $\sigma$ such that $\sigma(m) = t$. For all mask terms
+$m \in \calS$ we introduce the \emph{mask predicate} $Mask_m$.
+Mask predicates are similar to the anchor predicates, but instead of
+matching against a subterm, they match against the mask.
+\[ Mask_m(a) \ \ \iff \ \ m \text{ masks all } t \in \lsem a \rsem. \]
+
+%Elements $a \in A$ can be represented as tuples consisting of a mask
+%term $m_a$ such that $Mask_{m_a}(a)$ and terms $s_p = a\tpos^m_p$ for
+%every within mask path $p \in \calP_m$ in $m$.
+
+\begin{example}
+To list the relations derived for the Tic-tac-toe specification, recall that
+$\calP_m = \{(\mathtt{cell},1), (\mathtt{cell},2)\}$ consists of two paths.
+To shorten notation, we will just use the index $i$ for $(\mathtt{cell},i)$.
+
+\emph{Subterm equality relations.}
+The relation $Eq_{i, j}$ contains all pairs of elements for which
+the $i$th coordinate of the first one equals the $j$th coordinate
+of the second one. For example
+\begin{align*}
+ Eq_{1,1} = \{
+ & (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{a}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{b}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{c}}), \\
+ & \dots \\
+ & (a_{\mathtt{c},\mathtt{c}}, a_{\mathtt{c},\mathtt{a}}),
+ (a_{\mathtt{c},\mathtt{c}}, a_{\mathtt{c},\mathtt{b}}),
+ (a_{\mathtt{c},\mathtt{c}}, a_{\mathtt{c},\mathtt{c}}) \}
+\end{align*}
+describes the identity of the first coordinate of two cells.
+%which on Figure~\ref{fig-ttt} would be pairs of elements in the same row.
+
+
+\emph{Fact relations.}
+The only predicate in the example specification is \texttt{nextcol}
+and we thus get the relations $\mathtt{nextcol}_{i, j}$.
+For example, the relation
+\begin{align*}
+ \mathtt{nextcol}_{2,2} = \{
+ & (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{a},\mathtt{b}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{b},\mathtt{b}}),
+ (a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{c},\mathtt{b}}), \\
+ & \dots, \\
+ & (a_{\mathtt{c},\mathtt{b}}, a_{\mathtt{a},\mathtt{c}}),
+ (a_{\mathtt{c},\mathtt{b}}, a_{\mathtt{b},\mathtt{c}}),
+ (a_{\mathtt{c},\mathtt{b}}, a_{\mathtt{c},\mathtt{c}}) \}
+\end{align*}
+contains pairs in which the second element is in the successive row
+of the first one. Note that, for example, the formula
+$Eq_{1,1}(x_1,x_2) \land \mathtt{nextcol}_{2,2}(x_1,x_2)$
+specifies that $x_2$ is directly right of $x_1$ in the same row.
+
+\emph{Anchor predicates.}
+Since the terms inside \texttt{cell} at positions $1$ and $2$ range
+over \texttt{a, b, c}, we get $6$ anchor predicates
+$Anch^{\mathtt{a}}_{i}, Anch^{\mathtt{b}}_{i}, Anch^{\mathtt{c}}_{i}$ for $i=1,2$.
+They mark the corresponding terms, \eg
+\[
+ Anch^{\mathtt{a}}_{2} \ = \ \{
+ a_{\mathtt{a},\mathtt{a}}, a_{\mathtt{b},\mathtt{a}}, a_{\mathtt{c},\mathtt{a}} \}
+\]
+describes the bottom row.
+
+\emph{Fluent predicates.}
+The fluent paths $\calP_f = \{(\mathtt{cell},3), (\mathtt{control},1)\}$ and
+the terms appearing there are \texttt{b, x, o} for $(\mathtt{cell},3)$ and
+\texttt{x, o} for $(\mathtt{control},1)$, resulting in $5$ fluent predicates.
+For example, $Flu^{\mathtt{o}}_{(\mathtt{cell},3)}(a)$ will hold exactly for
+the elements $a$ which are marked by the player $\mathtt{o}$.
+In the initial structure, the only nonempty fluent predicates are
+\[ Flu^{\mathtt{b}}_{(\mathtt{cell},3)} = A \setminus \{a_{ctrl}\} \ \
+ \text{ and } \ \ Flu^{\mathtt{x}}_{(\mathtt{control},1)} = \{a_{ctrl}\}. \]
+
+\emph{Mask predicates.}
+For the specification we consider, there are two mask terms:
+$m_1 = (\mathtt{control}\ x)$ and $m_2 = (\mathtt{cell}\ x\ y\ z)$.
+The predicate $Mask_{m_1} \ = \ \{ a_{ctrl} \}$ holds exactly for
+the control element, and $Mask_{m_2} = A \setminus \{a_{ctrl}\}$ contains these
+elements of $A$ which are not the control element, \ie the board elements.
+\end{example}
+
+In Toss, \emph{stable relations} are relations that do not change in
+the course of the game, and \emph{fluents} are relations that do
+change. Roughly speaking, a fluent occurs in the symmetric
+difference of the sides of a structure rewrite rule.
+In the translation, the fluent predicates $Flu^s_p$ are the only
+introduced fluents, \ie these predicates will change when players
+play the game and all other predicates will remain intact.
+
+
+%Let $\calM$ be any legal state of $G$. Let $\calS^\calM \coloneq \{s |
+%true(s) \in \calM \}$ be the set of state terms at state $\calM$, note
+%that $\calS = \bigcup_\calM \calS^\calM$.
+%
+%We will introduce the interpretation $\lsem \cdot \rsem^\calM_I$ of
+%formulas with respect to $\calM$ under an assignment of
+%variables $I : V \rightarrow A$, to describe the translation (which
+%goes in the opposite direction) declaratively.
+%
+%\begin{definition}
+% $\lsem Flu^s_p(x) \rsem ^\calM_I$ iff there exists $t \in \lsem
+% I(x) \rsem \cap \calS^\calM$ such that $t\tpos_p = s$.
+%
+% For other atoms $R(x_1,\ldots,x_n)$, $\lsem R(x_1,\ldots,x_n)
+% \rsem^\calM_I$ iff $R(I(x_1),\ldots,I(x_n)) \in \frakA$.
+%
+% $\lsem \cdot \rsem^\calM_I$ extends naturally to any
+% formulas.
+%\end{definition}
+
+\subsection{Structure Rewriting Rules}
+
+To create the structure rewriting rule for the Toss game,
+we first construct two types of clauses and then transform
+them into structure rewriting rules. Let $(p_1,\ldots,p_n)$
+be the players in $G$, \ie let there be \texttt{(role $p_1$)}
+up to \texttt{(role $p_n$)} facts in $G$, in this order.
+
+
+\subsubsection{Move Clauses}
+
+By GDL specification, a legal joint move of the players is a tuple of
+player term -- move term pairs which satisfy the \texttt{legal}
+relation. For a joint move $(m_1,\ldots,m_n)$ to be allowed,
+it is necessary that there is a tuple of \texttt{legal}
+clauses $(\calC_1,...,\calC_n)$, with head of $\calC_i$ being
+\texttt{(legal $p_i$ $l_i$)}, and the \texttt{legal} arguments tuple
+being more general than the joint move tuple, \ie
+$m_i \leq l_i$ for each $i = 1, \ldots, n$.
+
+The move transition is computed from the \texttt{next}
+clauses whose all \texttt{does} relations are matched by respective
+joint move tuple elements as follows.
+
+\begin{definition}
+Let $\calN$ be a \texttt{next} clause. The \emph{$\calN$ does facts},
+$d_1(\calN), \ldots, d_n(\calN)$, are terms, one for each player,
+constructed from $\calN$ in the following way.
+Let \texttt{(does $p_i$ $d_i^j$)} be all \texttt{does} facts in $\calN$.
+\begin{itemize}
+\item If there is exactly one $d_i$ for player $p_i$ we set
+ $d_i(\calN) = d_i$.
+\item If there is no \texttt{does} fact for player $p_i$ in $\calN$
+ we set $d_i(\calN)$ to a fresh variable.
+\item If there are multiple $d_i^1, \dots, d_i^k$ for player $p_i$ we
+ compute $\sigma = \mgu(d_i^1, \dots, d_i^k)$ and set
+ $d_i(\calN) = \sigma(d_i^1)$.
+\end{itemize}
+\end{definition}
+
+
+We have $m_i \leq d_i(\calN)$ for each \texttt{next} clause $\calN$
+contributing to the move transition, since otherwise the body of $\calN$
+would not match the state enhanced with \texttt{(does $p_i$ $m_i$)} facts.
+
+\begin{example}
+In the Tic-tac-toe example, there are three clauses where the control player
+is \texttt{o}, which after renaming of variables look as follows.
+\begin{align*}
+\calN_1 = \mathtt{(<=\ (} & \mathtt{next\ (control\ x))\ (does\ x\ noop))},\\
+\calN_2 = \mathtt{(<=\ (} & \mathtt{next\ (cell\ ?x2\ ?y2\ o))} \\
+ & \mathtt{(does\ o\ (mark\ ?x2\ ?y2)))}, \\
+\calN_3 = \mathtt{(<=\ (} & \mathtt{next\ (cell\ ?x3\ ?y3\ ?c))} \\
+ & \mathtt{(true\ (cell\ ?x3\ ?y3\ ?c))} \\
+ & \mathtt{(does\ o\ (mark\ ?x1\ ?y1))} \\
+ & \mathtt{(or\ (distinct\ ?x3\ ?x1)\ (distinct\ ?y3\ ?y1)))}.
+\end{align*}
+The does facts are, respectively,
+\begin{align*}
+& d_1(\calN_1) = \mathtt{noop} & \text{ and } & \quad
+ d_2(\calN_1) = x_{f_1},\\
+& d_1(\calN_2) = x_{f_2} & \text{ and } & \quad
+ d_2(\calN_2) = (\mathtt{mark}\ x_2\ y_2),\\
+& d_1(\calN_3) = x_{f_3} & \text{ and } & \quad
+ d_2(\calN_3) = (\mathtt{mark}\ x_1\ y_1).
+\end{align*}
+\end{example}
+
+Each rewrite rule of the translated game is generated from a tuple of
+\texttt{legal} clauses $\calC_1,\ldots,\calC_n$ and a selection of
+\texttt{next} clauses $\calN_1,\ldots,\calN_m$, with variables renamed
+so that no variable occurs in multiple clauses, and such that
+\[ l_i \ \dot{=} \ d_i(\calN_1) \ \dot{=} \ \dots \ \dot{=} \ d_i(\calN_m) \]
+for each player $p_i$. We will consider all tuples $\ol{\calC}, \ol{\calN}$
+for which the the above MGU exists and we will denote it by
+$\sigma_{\ol{\calC},\ol{\calN}}$. We apply $\sigma_{\ol{\calC},\ol{\calN}}$
+to the clauses and we will refer to the result simply as
+\emph{the \texttt{legal} and \texttt{next} clauses of the rule}.
+
+Technically, for completeness, we need to generate a rule for a set of
+\texttt{next} clauses even if we generate a rule for its superset, and
+then for correctness, we need to preclude application of the first
+(more general) rule when the more concrete rule is applicable, adding
+\texttt{distinct} conditions to clauses of the otherwise more general
+rule. In the current implementation, we only consider maximal sets of
+\texttt{next} clauses.
+
+\begin{example}
+Let $\calC_1 = \mathtt{noop}$ and $\calC_2 = (\mathtt{mark}\ x\ y)$.
+The clauses $\calN_1, \calN_2, \calN_3$ introduced above form a maximal set,
+\begin{align*}
+\sigma_{\ol{\calC},\ol{\calN}} = \{
+ & x_{f_1} \mapsto (\mathtt{mark}\ x\ y),\quad x_{f_2} \mapsto \mathtt{noop},\\
+ & x_2 \mapsto x,\quad y_2 \mapsto y,\quad
+ x_1 \mapsto x,\quad y_1 \mapsto y \}.
+\end{align*}
+\end{example}
+
+With all tuples $\ol{\calC}, \ol{\calN}$ selected and the MGU
+$\sigma_{\ol{\calC},\ol{\calN}}$ computed, we are almost ready to construct
+the rewriting rules. Still, for a fixed tuple $\ol{\calC}, \ol{\calN}$,
+we first need to compute erasure clauses to prevent constructing
+too general rules in the end.
+
+
+\subsubsection{Erasure Clauses}
+
+So far, we have not accounted for the fact that rewrite rules of Toss
+only affect the matched part of the structure, while the GDL game
+definition explicitly describes the construction of the whole successive
+structure. We will say that a \texttt{next} clause is a \emph{frame clause}
+if and only if it contains a \texttt{true} relation applied to a term
+equal to the \texttt{next} argument. Negating the frame clauses from
+the tuple $\ol{\calN}$ and transforming them into \emph{erasure clauses}
+will keep track of the elements that possibly lose fluents and ensure
+correct translation.
+
+From the frame clauses in $\sigma_{\ol{\calC}, \ol{\calN}}(\calN_1), \dots,
+\sigma_{\ol{\calC}, \ol{\calN}}(\calN_m)$, we select all (maximal) subsets $J$
+such that, clauses in $J$ having the form $\mathtt{(<= (next\ s_i)\ b_i)}$,
+it holds
+\[ s_1 \ \dot{=}_f \ \ldots \ \dot{=}_f \ s_{|J|}, \]
+\ie the arguments of \texttt{next} unify. Note that we use $\dot{=}_f$
+instead of the standard unification, and by that we mean that the variables
+shared with the \texttt{legal} clauses $\ol{\calC}$ are treated as constants.
+The reason is that these variables are not local to the clauses and must
+therefore remain intact.
+
+Intuitively, the selected sets $J$ describe a partition of the state terms
+that could possibly be copied without change by the rule we will generate
+for $\ol{\calC}, \ol{\calN}$.
+
+Let us write $\rho$ for the $f$-MGU of $s_1, \dots, s_{|J|}$.
+To compute the bodies of the erasure clauses, we negate the disjunction
+of substituted bodies of the frame clauses and bring this Boolean combination
+to disjunctive normal form (DNF), \ie we compute conjunctions $e_1, \dots, e_l$
+such that
+\[ \neg( \rho(b_1) \lor \dots \lor \rho(b_{|J|}) \ \equiv \
+ (e_1 \lor e_2 \ldots \lor e_l). \]
+As the head of each erasure clause we use $\rho(s_1) = \dots = \rho(s_{|J|})$,
+with the one technical change that we ignore the fluent paths in this term.
+We replace these fluent paths with \texttt{BLANK} and thus allow them
+to be deleted in case they are not preserved by other \texttt{next} clauses
+of the rule, which causes no problems. Let us denote by $h$ the term
+$\rho(s_1)$ after the above replacement. The erasure clauses
+$\calE_{\ol{\calC}, \ol{\calN}}(J) =
+ \{ \mathtt{(<=\ h\ e_1)} \dots \mathtt{(<=\ h\ e_l)} \},$
+and we write $\calE_{\ol{\calC}, \ol{\calN}}$ for the union of all
+$\calE_{\ol{\calC}, \ol{\calN}}(J)$, \ie for the set of all
+$\ol{\calC}, \ol{\calN}$ erasure clauses.
+
+
+\begin{example}
+In our example, $\calN_3$ and its counterpart for the other player
+are the only frame clauses in $G$. After negation, $\sigma(\calN_3)$
+splits into several clauses $e_i$. The relevant one is
+\texttt{(<= (next (cell ?x3 ?y3 ?c)) (?x3 = ?x) (?y3 = ?y))}, \ie
+\texttt{(<= (next (cell ?x ?y ?c)))}. The resulting erasure clause is
+\texttt{(<= (next (cell ?x ?y BLANK)))}. If no other clause had
+the form \texttt{(<= (next (cell ?x ?y ...)) ...)}, this clause would
+cause the erasure of any fluent at coordinates $(x,y)$. Other erasure clauses
+derived from $\sigma(\calN_3)$ turn out to be contradictory with remaining
+clauses, and thus will not contribute to any rewrite rule in the
+translation, due to filtering described below.
+\end{example}
+
+
+\subsubsection{Rewriting Rule Creation} \label{subsec-rules}
+
+For each suitable tuple $\ol{\calC}, \ol{\calN}$ we have now
+created the unifier $\sigma_{\ol{\calC}, \ol{\calN}}$ and computed
+the erasure clauses $\calE_{\ol{\calC}, \ol{\calN}}$. To create the rules,
+we first collect all atoms in the bodies of
+$\sigma_{\ol{\calC}, \ol{\calN}}(\calC_i), \sigma_{\ol{\calC}, \ol{\calN}}(\calN_i)$
+and $\calE_{\ol{\calC}, \ol{\calN}}$. We generate a Toss rule candidate for
+every partition of atoms into true and false ones, and later \emph{filter}
+these candidates by checking for satisfiability in the initial structure
+of the stable part of the rule matching criteria and precondition.
+
+For a given a partition of GDL atoms into true and false ones,
+we will construct the candidate rule in two steps.
+
+In the first step, we transform the GDL atoms into Toss clauses.
+This translation follows the definitions of atomic relations
+presented in Section~\ref{subsec-rels}, and the relations there were
+chosen so as to suffice for this translation. Due to space constraints
+we omit further technical details of this step here.
+%Before creating the rules, we currently expand (inline)
+%relations of $G$ that directly or indirectly depend on game state, and
+%we instantiate variables at fluent paths. We translate state terms
+%as Toss variables, so that terms are translated as the same variable
+%iff they are syntactically equal or differ only at fluent paths.
+
+In the second step, we use Toss clauses to construct the structures
+for the rule. The $\frakL$-structure and precondition of a Toss rewrite rule
+is built by first translating the existential closure of conjunctions of
+bodies of \texttt{next} clauses of the rule. Based on the heads of
+\texttt{next} clauses, the relevant information is extracted from the
+resulting precondition formula and quantification over variables
+corresponding to $\frakL$ elements is dropped. The right-hand
+structure is constructed similarly.
+
+Having constructed and filtered the rewriting rule candidates,
+we have almost completed the definition of $T(G)$. The rules
+are assigned to locations based on who moves in which location,
+as we only translate turn-based games for now. Payoff formulas
+are derived by instantiating variables standing for the \texttt{goal}
+values. The formulas defining the \texttt{terminal} condition and
+specific \texttt{goal} value conditions are existential closures of
+disjunctions of bodies of their respective clauses.
+
+
+\subsection{Translating Moves between Toss and GDL} \label{subsec-move-tr}
+
+To play as a GDL client, we need to translate legal moves from $G$
+into Toss rule embeddings for $T(G)$, and conversely,
+the rule embeddings from $T(G)$ into moves of $G$.
+
+In the incoming move case, we augment the Toss rewrite rules with constraints
+provided in the incoming move, try to embed each of the augmented
+rules, and return the single rule that matches and its unique embedding.
+Augmenting the rule is done in the following simple way:
+If the head of a \texttt{legal} clause of the rule contains
+a variable $v$ at path $q$, a Toss variable $x$ was derived from
+a game state term $t$ such that $t\tpos_p = v$, and the incoming move
+has term $s$ at path $q$, then we add $Anch^s_p(x)$ to the precondition.
+
+To translate the outgoing move, we recall the heads of the
+\texttt{legal} clauses of the rule that is selected, as we only need to
+substitute all their variables. To eliminate a variable $v$ contained in
+the head of a \texttt{legal} clause of the rule, we look at the rule
+embedding; if $x\mapsto a$, $x$ was derived from a game state term $t$
+such that $t\tpos_p = v$, and $a\tpos^m_p = s$, then we substitute
+$v$ by $s$. The move translation function $\mu$ is thus constructed.
+
+
+\section{Game Simplification in Toss}
+
+Games automatically translated from GDL, as described above, are verbose
+compared to games defined manually for Toss. They are also inefficient,
+since the current solver in Toss works fast only for sparse relations.
+%and some of the introduced ones are not sparse.
+
+Both problems are remedied by joining co-occurring relations. Relations
+which always occur together in a conjunction are replaced by their join
+when they are over the same tuple. Analogically, we eliminate pairs of
+atoms when the arguments of one relation are reversed arguments of the other.
+
+In an additional simplification, we remove an atom of a stable relation
+which is included in, or which includes, another relation, when an atom of
+the other relation already states a stronger fact. For example, if
+$Positive \subseteq Number$, then $Positive(x) \wedge Number(x)$
+simplifies to $Positive(x)$, and $Positive(x) \vee Number(x)$
+simplifies to $Number(x)$.
+
+The above simplifications can be applied to any Toss definition.
+We perform one more simplification targeted specifically at translated
+games: We eliminate $Eq_{p,q}(x,y)$ atoms when we detect that
+$Eq_{p,q}$-equivalence of $x$ and $y$ can be deduced from the
+remaining parts of the formula. % being simplified.
+
+The described simplifications are stated in terms of manipulating
+formulas; besides formulas, we also apply analogous simplifications to
+the structures of the Toss game: the initial game state structure, and
+the $\frakL$ and $\frakR$ structures of the rules.
+
+
+
+
+
\chapter{Design}
\section{Organization of Code}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-20 12:27:21
|
Revision: 1421
http://toss.svn.sourceforge.net/toss/?rev=1421&view=rev
Author: lukaszkaiser
Date: 2011-04-20 12:27:15 +0000 (Wed, 20 Apr 2011)
Log Message:
-----------
Correcting Boolean fixed-points.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FormulaParser.mly
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-20 00:51:06 UTC (rev 1420)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-20 12:27:15 UTC (rev 1421)
@@ -7,6 +7,7 @@
debug_level := i;
if i > 0 then debug_elim := true
)
+let set_debug_elim b = (debug_elim := b;)
(* 0 : no generation is performed and to_cnf transforms a DNF
1 : use Tseitin to construct a CNF with auxiliary variables
@@ -750,8 +751,9 @@
| 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);
+ if !debug_elim && prefix.[0] <> 'S' 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
@@ -759,14 +761,16 @@
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;
+ if !debug_elim && prefix.[0] <> 'S' then
+ Printf.printf "%s done %!" prefix;
let res = match to_dnf ~tm:(5. *. tout) (BAnd simp_fs) with
| None ->
- if !debug_elim then
+ if !debug_elim && prefix.[0] <> 'S' 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);
+ if !debug_elim && prefix.[0] <> 'S' then
+ Printf.printf "(dnf %i)\n%!" (size psi);
psi in
neutral_absorbing (flatten res)
| BOr [] -> BOr []
@@ -786,7 +790,7 @@
let res = has_vars sgn vl in
Hashtbl.add has_vars_mem (sgn, vl) res;
res in
- if !debug_elim && prefix <> "S" then
+ if !debug_elim && prefix.[0] <> '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
@@ -796,7 +800,7 @@
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
+ if prefix.[0] = '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
@@ -829,13 +833,15 @@
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
+ if !debug_elim && prefix.[0] <> 'S' 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
+ | None ->
+ if !debug_elim && prefix.[0] <> 'S' then Printf.printf "\n%!"; cnf
| Some dnf ->
- if !debug_elim then Printf.printf "(dnf) \n%!"; dnf
+ if !debug_elim && prefix.[0] <> 'S' 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 =
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-20 00:51:06 UTC (rev 1420)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-20 12:27:15 UTC (rev 1421)
@@ -10,6 +10,7 @@
| BAnd of bool_formula list
| BOr of bool_formula list
+
(** {2 Printing functions.} *)
(** Print a variable as a string. *)
@@ -87,10 +88,12 @@
val elim_quant : qbf -> bool_formula
-(** {3 Debugging} *)
+(** {2 Debugging} *)
(** Debugging information. At level 0 nothing is printed out. *)
val set_debug_level : int -> unit
+val set_debug_elim : bool -> unit
+
val set_auxcnf : int -> unit
val set_simplification : int -> unit
Modified: trunk/Toss/Formula/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml 2011-04-20 00:51:06 UTC (rev 1420)
+++ trunk/Toss/Formula/BoolFunction.ml 2011-04-20 12:27:15 UTC (rev 1421)
@@ -2,7 +2,10 @@
open BoolFormula
let debug_level = ref 0
-let set_debug_level i = (debug_level := i;)
+let set_debug_level i = (
+ debug_level := i;
+ if i > 2 then BoolFormula.set_debug_elim true;
+)
(* ----------------------- BASIC TYPE DEFINITION -------------------------- *)
@@ -24,6 +27,10 @@
(* ----------------------- PRINTING FUNCTIONS ------------------------------- *)
+let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn
+
+let fprint_mod_var_list = Aux.fprint_sep_list "," fprint_mod_var
+
(* Print to formatter. *)
let rec fprint f = function
| Fun (s, vars) ->
@@ -45,9 +52,8 @@
| 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
+ fprint_mod_var_list mod_vars fprint phi
(* Print to stdout, template from formatter printing. *)
let make_print fprint_fun x = (
@@ -71,22 +77,20 @@
(* Print definition to formatter. *)
let rec fprint_def ?(print_bool=false) f (name, is_fp, mod_vars, def) =
- let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn in
if is_fp then
- let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn in
if print_bool then
Format.fprintf f "@[<1>mu@ bool@ %s(%a)@ (%a)@]" name
- (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ fprint_mod_var_list mod_vars fprint def
else
Format.fprintf f "@[<1>mu@ %s(%a)@ (%a)@]" name
- (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ fprint_mod_var_list mod_vars fprint def
else
if print_bool then
Format.fprintf f "@[<1>bool@ %s(%a)@ (%a)@]" name
- (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ fprint_mod_var_list mod_vars fprint def
else
Format.fprintf f "@[<1>%s(%a)@ (%a)@]" name
- (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ fprint_mod_var_list mod_vars fprint def
(* Print definition to stdout. *)
let print_def ?(print_bool=false) = make_print (fprint_def ~print_bool)
@@ -259,6 +263,7 @@
if new_defs = defs then defs else inline_defs new_defs
+(* Convert a function to DNF with eliminated quantifiers. *)
let dnf classes f =
let (nbrs, names, free) = (Hashtbl.create 31, Hashtbl.create 31, ref 1) in
let nbr (m, n) =
@@ -288,12 +293,22 @@
| And fl -> And (List.map elim_quant fl)
| Or fl -> Or (List.map elim_quant fl)
| Ex (vs, f) ->
- let elim_bool = to_bool (elim_quant f) in
- let cvars (c,_) = List.map (fun v -> (c, v)) (List.assoc c classes) in
+ let elim = 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
+ let cvars (c, n) = List.map (fun v -> (n, v)) (List.assoc c classes) in
let ex_vars = List.map nbr (List.flatten (List.map cvars vs)) in
- from_bool (elim_ex ex_vars elim_bool) in
+ let noquant_bool = elim_ex ex_vars elim_bool in
+ let res = from_bool (BoolFormula.flatten_sort (simplify noquant_bool)) in
+ if !debug_level > 1 then Format.printf "Eliminated@ :@ %a@\n%!"
+ 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
(* Solve fixed-points in the definitions. *)
@@ -304,5 +319,7 @@
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 df = let nx = next df in if nx = df then df else fp nx in
- defsimp @ (fp startdef)
+ 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)
Modified: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli 2011-04-20 00:51:06 UTC (rev 1420)
+++ trunk/Toss/Formula/BoolFunction.mli 2011-04-20 12:27:15 UTC (rev 1421)
@@ -81,5 +81,8 @@
(** Inline all non-fixed-point definitions. *)
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
+
(** Inline and solve fixed-points in the definitions. *)
val solve_lfp : (string * string list) list -> bool_def list -> bool_def list
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-20 00:51:06 UTC (rev 1420)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-20 12:27:15 UTC (rev 1421)
@@ -111,12 +111,18 @@
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, print_bool) = (ref "", ref false) in
+ 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 opts = [
- ("-v", Arg.Unit (fun () -> BoolFunction.set_debug_level 1), "verbose");
- ("-d", Arg.Int (fun i -> BoolFunction.set_debug_level i), "debug level");
+ ("-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");
+ ("-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),
+ "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
@@ -131,9 +137,16 @@
let res_s = Str.global_replace (Str.regexp "/\\*.*\\*/") "" cleaned_s5 in
try
let (cl, dl, goal) = defs_goal_of_string res_s in
- print_defs ~print_bool:!print_bool (cl, solve_lfp cl dl);
+ let new_defs =
+ if !only_inline then (cl, inline_defs dl) else (cl, solve_lfp 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
+ if !only_inline || !only_fp || !debug_level > 0 then
+ print_defs ~print_bool:!print_bool new_defs;
print_endline "\n\n// GOAL FORMULA\n";
- print goal;
+ print new_goal;
print_endline ";\n";
with Lexer.Parsing_error err -> (
print_endline res_s;
Modified: trunk/Toss/Formula/FormulaParser.mly
===================================================================
--- trunk/Toss/Formula/FormulaParser.mly 2011-04-20 00:51:06 UTC (rev 1420)
+++ trunk/Toss/Formula/FormulaParser.mly 2011-04-20 12:27:15 UTC (rev 1421)
@@ -80,7 +80,9 @@
| TC INT ID COMMA ID formula_expr { FormulaOps.make_fo_tc_conj $2 $3 $5 $6 }
| OPEN formula_expr CLOSE { $2 }
| formula_expr AND formula_expr { And [$1; $3] }
+ | formula_expr AMP formula_expr { And [$1; $3] }
| formula_expr OR formula_expr { Or [$1; $3] }
+ | formula_expr MID formula_expr { Or [$1; $3] }
| formula_expr XOR formula_expr { And [Or [$1; $3]; Not (And [$1; $3])] }
| formula_expr RARR formula_expr { Or [Not ($1); $3] }
| formula_expr LRARR formula_expr
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-20 00:51:12
|
Revision: 1420
http://toss.svn.sourceforge.net/toss/?rev=1420&view=rev
Author: lukaszkaiser
Date: 2011-04-20 00:51:06 +0000 (Wed, 20 Apr 2011)
Log Message:
-----------
More work on Boolean fixed-points.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.mli
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.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-19 17:32:04 UTC (rev 1419)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-20 00:51:06 UTC (rev 1420)
@@ -54,7 +54,15 @@
(** Convert an arbitrary formula to CNF via Boolean combinations. *)
val formula_to_cnf : Formula.formula -> Formula.formula
+(** Convert a Boolean formula to CNF, fail on timeout. *)
+val to_cnf : ?disc_vars: int list -> ?tm: float ->
+ bool_formula -> bool_formula option
+(** Convert a Boolean formula to DNF, fail on timeout. *)
+val to_dnf : ?disc_vars: int list -> ?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/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml 2011-04-19 17:32:04 UTC (rev 1419)
+++ trunk/Toss/Formula/BoolFunction.ml 2011-04-20 00:51:06 UTC (rev 1420)
@@ -1,12 +1,10 @@
(* Represent Boolean functions. *)
+open BoolFormula
let debug_level = ref 0
let set_debug_level i = (debug_level := i;)
-(* Some functions are not total yet. *)
-exception Unsupported of string
-
(* ----------------------- BASIC TYPE DEFINITION -------------------------- *)
(* This type describes Boolean functions *)
@@ -177,6 +175,8 @@
(* 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 (Or []) -> And []
+ | Not (And []) -> Or []
| Not psi -> Not (triv_simp psi)
| Or psis ->
if (List.exists (fun psi -> psi = And []) psis) then (And []) else
@@ -192,7 +192,11 @@
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)
+ | Ex (vs, phi) ->
+ match triv_simp phi with
+ | Or [] -> Or []
+ | And [] -> And []
+ | psi -> Ex (vs, psi)
(* Trivial simplification of Boolean definitions. *)
@@ -211,8 +215,94 @@
| Or fl -> Or (List.map (subst_mod_vars dict) fl)
| And fl -> And (List.map (subst_mod_vars dict) fl)
| Ex (mod_vs, psi) ->
- let vs = List.map (fun (cl, v) -> v) mod_vs in
+ let vs = List.map (fun (_, v) -> v) mod_vs in
let new_dict = List.filter (fun (v, _) -> not (List.mem v vs)) dict in
- if List.exists (fun (_, new_v) -> List.mem new_v vs) new_dict then
- raise (Unsupported "substitution aliased by exists")
- else Ex (mod_vs, subst_mod_vars new_dict psi)
+ let in_new_dict v = List.exists (fun (_,new_v) -> v=new_v) new_dict in
+ let (bad_vs,ok_vs) = List.partition (fun (_, v)-> in_new_dict v) mod_vs in
+ if bad_vs = [] then Ex (mod_vs, subst_mod_vars new_dict psi) else
+ let rec new_name v i =
+ let vi = v ^ (string_of_int i) in
+ if in_new_dict vi then new_name v (i+1) else vi in
+ let new_b (cl, v) =
+ let vi = new_name v 0 in
+ (cl, vi), (v, vi) in
+ let (new_bad, bad_subst) = List.split (List.map new_b bad_vs) in
+ Ex (new_bad @ ok_vs, subst_mod_vars (bad_subst @ new_dict) psi)
+
+
+(* Insert non-fixed-point definitions into a function. *)
+let rec apply_defs defs = function
+ | PosVar _ | NegVar _ as x -> x
+ | Not f -> Not (apply_defs defs f)
+ | Or fl -> Or (List.map (apply_defs defs) fl)
+ | And fl -> And (List.map (apply_defs defs) fl)
+ | Ex (vs, f) -> Ex (vs, apply_defs defs f)
+ | Fun (name, args) ->
+ let ndefs = List.filter (fun (n, fp, _, _) -> (not fp) && name=n) defs in
+ if ndefs = [] then Fun (name, args) else if List.length ndefs > 1 then
+ failwith ("BoolFunction.apply_defs: redefinition of " ^ name)
+ else
+ let (_, _, defargs, defphi) = List.hd ndefs in
+ if List.length defargs <> List.length args then
+ failwith (Printf.sprintf "BoolFunction.apply_defs: lengths %i <> %i"
+ (List.length defargs) (List.length args))
+ else
+ let dargs = List.map (fun (_, m) -> m) defargs in
+ subst_mod_vars (List.combine dargs args) defphi
+
+
+(* Inline all non-fixed-point definitions. *)
+let rec inline_defs defs =
+ let subst_def (n, fp, a, f) =
+ (n, fp, a, to_nnf (triv_simp (apply_defs defs f))) in
+ let new_defs = List.map subst_def defs in
+ if new_defs = defs then defs else inline_defs new_defs
+
+
+let dnf 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 ->
+ Hashtbl.add nbrs (m, n) !free;
+ Hashtbl.add names !free (m, n);
+ incr free;
+ !free - 1 in
+ let name i = Hashtbl.find names i in
+ let rec to_bool = function
+ | PosVar (m, n) -> BVar (nbr (m, n))
+ | NegVar (m, n) -> BVar (-1 * (nbr (m, n)))
+ | Not f -> BNot (to_bool f)
+ | Or fl -> BOr (List.map to_bool fl)
+ | And fl -> BAnd (List.map to_bool fl)
+ | _ -> failwith "BoolFunction.nnf: non-simple function in to_bool" in
+ let rec from_bool = function
+ | BVar v when v > 0 -> let (m, n) = name v in PosVar (m, n)
+ | BVar v when v < 0 -> let (m, n) = name (-v) in NegVar (m, n)
+ | BVar _ -> failwith "BoolFunction.nnf: v=0 in from_bool"
+ | BNot f -> Not (from_bool f)
+ | BOr fl -> Or (List.map from_bool fl)
+ | BAnd fl -> And (List.map from_bool fl) in
+ let rec elim_quant = function
+ | PosVar _ | NegVar _ | Fun _ as x -> x
+ | Not f -> Not (elim_quant f)
+ | And fl -> And (List.map elim_quant fl)
+ | Or fl -> Or (List.map elim_quant fl)
+ | Ex (vs, f) ->
+ let elim_bool = to_bool (elim_quant f) in
+ let cvars (c,_) = List.map (fun v -> (c, v)) (List.assoc c classes) in
+ let ex_vars = List.map nbr (List.flatten (List.map cvars vs)) in
+ from_bool (elim_ex ex_vars elim_bool) in
+ let elim_simp = elim_quant (triv_simp (to_nnf f)) in
+ let res = from_bool (Aux.unsome (to_dnf (to_bool elim_simp))) in
+ triv_simp res
+
+(* Solve fixed-points in the definitions. *)
+let solve_lfp 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 df = let nx = next df in if nx = df then df else fp nx in
+ defsimp @ (fp startdef)
Modified: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli 2011-04-19 17:32:04 UTC (rev 1419)
+++ trunk/Toss/Formula/BoolFunction.mli 2011-04-20 00:51:06 UTC (rev 1420)
@@ -5,10 +5,7 @@
(** Set debugging level. *)
val set_debug_level : int -> unit
-(** Some functions are not total yet. *)
-exception Unsupported of string
-
(** {2 Basic Type Definition} *)
(** This type describes Boolean functions *)
@@ -77,3 +74,12 @@
(** Substitute module variables. Simple, fails on quantifier conflicts. *)
val subst_mod_vars : (string * string) list -> bool_function -> bool_function
+
+(** Insert non-fixed-point definitions into a function. *)
+val apply_defs : bool_def list -> bool_function -> bool_function
+
+(** Inline all non-fixed-point definitions. *)
+val inline_defs : bool_def list -> bool_def list
+
+(** Inline and solve fixed-points in the definitions. *)
+val solve_lfp : (string * string list) list -> bool_def list -> bool_def list
Modified: trunk/Toss/Formula/BoolFunctionParser.mly
===================================================================
--- trunk/Toss/Formula/BoolFunctionParser.mly 2011-04-19 17:32:04 UTC (rev 1419)
+++ trunk/Toss/Formula/BoolFunctionParser.mly 2011-04-20 00:51:06 UTC (rev 1420)
@@ -68,7 +68,7 @@
"Syntax error in definition parsing." }
id_sc_list:
- | ID SEMICOLON { [$1] }
+ | ID SEMICOLON { [$1] }
| ID SEMICOLON id_sc_list { $1 :: $3 }
class_def:
@@ -82,6 +82,7 @@
| class_def SEMICOLON { [(Some $1, None)] }
| class_def SEMICOLON bool_defs_expr { (Some $1, None) :: $3 }
| bool_def SEMICOLON { [(None, Some $1)] }
+ | bool_def { [(None, Some $1)] }
| bool_def SEMICOLON bool_defs_expr { (None, Some $1) :: $3 }
| error
{ Lexer.report_parsing_error $startpos $endpos
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-19 17:32:04 UTC (rev 1419)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-20 00:51:06 UTC (rev 1420)
@@ -73,22 +73,39 @@
"substitution of module variables" >::
(fun () ->
- let test_mod_subst ?(failok=false) s dict res =
- try
- assert_eq_string s "Substituting module variables"
- res (str (subst_mod_vars dict (bf_of_string s)))
- with Unsupported msg ->
- if failok then assert true else raise (Unsupported msg) in
+ let test_mod_subst s dict res =
+ assert_eq_string s "Substituting module variables"
+ res (str (subst_mod_vars dict (bf_of_string s))) in
test_mod_subst "R(m) & m.n1=0" [("m", "n")] "(R(n) & n.n1=0)";
test_mod_subst "R(m) & ex M m R(m)" [("m", "n")]
"(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 ~failok:true "ex M m R(x)" [("x", "m")] "";
+ test_mod_subst "ex M m R(x)" [("x", "m")] "(exists M m0. R(m))";
+ 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))))";
);
+
+ "substituting and inlining definitions" >::
+ (fun () ->
+ let test_apply_defs f_s defs_s res =
+ let (f, defs) = (bf_of_string f_s, defs_of_string defs_s) in
+ assert_eq_string f_s "Substituting definitions"
+ res (str (apply_defs (snd defs) f)) in
+ let test_inline_defs defs res =
+ assert_eq_string defs "Inlining definitions"
+ res (str_defs ([], (inline_defs (snd (defs_of_string defs))))) in
+
+ test_apply_defs "R(x)" "R(M m) (m.a1=0)" "x.a1=0";
+ test_apply_defs "R(x)" "mu R(M m) (m.a1=0 | R(m))" "R(x)";
+
+ test_inline_defs "R(M m) (m.a1=0); Q(M m) (m.a0=0 & R(m))"
+ "R(M m) (m.a1=0); Q(M m) ((m.a0=0 & m.a1=0));"
+ );
]
+
let main () =
Gc.set { (Gc.get()) with
Gc.space_overhead = 300; (* 300% instead of 80% std *)
@@ -114,7 +131,7 @@
let res_s = Str.global_replace (Str.regexp "/\\*.*\\*/") "" cleaned_s5 in
try
let (cl, dl, goal) = defs_goal_of_string res_s in
- print_defs ~print_bool:!print_bool (cl, dl);
+ print_defs ~print_bool:!print_bool (cl, solve_lfp cl dl);
print_endline "\n\n// GOAL FORMULA\n";
print goal;
print_endline ";\n";
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-19 17:32:11
|
Revision: 1419
http://toss.svn.sourceforge.net/toss/?rev=1419&view=rev
Author: lukaszkaiser
Date: 2011-04-19 17:32:04 +0000 (Tue, 19 Apr 2011)
Log Message:
-----------
Work on Fixed-Points for Boolean functions.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/BoolFunction.ml
trunk/Toss/Formula/BoolFunction.mli
trunk/Toss/Formula/BoolFunctionParser.mly
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/Lexer.mll
trunk/Toss/Formula/Tokens.mly
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/Aux.ml 2011-04-19 17:32:04 UTC (rev 1419)
@@ -535,7 +535,7 @@
Printf.fprintf outchan "|]"
end
-let fprint_sep_list sep f_el f l =
+let fprint_sep_list ?(newline=0) sep f_el f l =
match l with
| [] -> ()
| [hd] -> f_el f hd
@@ -543,7 +543,12 @@
let rec pr_tail f = function
| [] -> ()
| hd::tl ->
- Format.fprintf f "%s@ %a" sep f_el hd;
+ if newline = 0 then
+ Format.fprintf f "%s@ %a" sep f_el hd
+ else if newline = 1 then
+ Format.fprintf f "%s@\n%a" sep f_el hd
+ else (* TODO; FIXME; how to do this right in general? *)
+ Format.fprintf f "%s@\n@\n%a" sep f_el hd;
pr_tail f tl in
Format.fprintf f "%a%a" f_el hd pr_tail tl
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/Aux.mli 2011-04-19 17:32:04 UTC (rev 1419)
@@ -276,7 +276,7 @@
(** Print an unboxed separated list, with breaks after the separator. *)
val fprint_sep_list :
- string -> (Format.formatter -> 'a -> unit) ->
+ ?newline : int -> string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a list -> unit
(** Run a function if the executable name matches the given prefix. *)
Modified: trunk/Toss/Formula/BoolFunction.ml
===================================================================
--- trunk/Toss/Formula/BoolFunction.ml 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/BoolFunction.ml 2011-04-19 17:32:04 UTC (rev 1419)
@@ -3,7 +3,10 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i;)
+(* Some functions are not total yet. *)
+exception Unsupported of string
+
(* ----------------------- BASIC TYPE DEFINITION -------------------------- *)
(* This type describes Boolean functions *)
@@ -15,9 +18,12 @@
| 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
+(* Boolean definition of a function, knows whether it is a fixed-point. *)
+type bool_def = string * bool * (string * string) list * bool_function
+
+
(* ----------------------- PRINTING FUNCTIONS ------------------------------- *)
(* Print to formatter. *)
@@ -32,6 +38,10 @@
| Or [] -> Format.fprintf f "false"
| And [phi] -> fprint f phi
| Or [phi] -> fprint f phi
+ | Or [And [NegVar (m1, n1); NegVar (m2, n2)];
+ And [PosVar (m1a, n1a); PosVar (m2a, n2a)]]
+ when n1 = n1a && n2 = n2a && m1 = m1a && m2 = m2a ->
+ Format.fprintf f "%s.%s=%s.%s" m1 n1 m2 n2
| And flist ->
Format.fprintf f "@[<1>(%a)@]" (Aux.fprint_sep_list " &" fprint) flist
| Or flist ->
@@ -40,33 +50,87 @@
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 = (
+(* Print to stdout, template from formatter printing. *)
+let make_print fprint_fun x = (
Format.print_flush();
- fprint Format.std_formatter phi;
+ fprint_fun Format.std_formatter x;
Format.print_flush();
)
-(* Print to string. *)
-let sprint phi =
+(* Print to string, template from formatter printing. *)
+let make_sprint fprint_fun x =
ignore (Format.flush_str_formatter ());
- Format.fprintf Format.str_formatter "@[%a@]" fprint phi;
+ Format.fprintf Format.str_formatter "@[%a@]" fprint_fun x;
Format.flush_str_formatter ()
+(* Print to stdout. *)
+let print = make_print fprint
+(* Print to string. *)
+let sprint = make_sprint fprint
(* Another name for sprint. *)
-let str f = sprint f
+let str = sprint
+(* Print definition to formatter. *)
+let rec fprint_def ?(print_bool=false) f (name, is_fp, mod_vars, def) =
+ let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn in
+ if is_fp then
+ let fprint_mod_var f (md, vn) = Format.fprintf f "%s %s" md vn in
+ if print_bool then
+ Format.fprintf f "@[<1>mu@ bool@ %s(%a)@ (%a)@]" name
+ (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ else
+ Format.fprintf f "@[<1>mu@ %s(%a)@ (%a)@]" name
+ (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ else
+ if print_bool then
+ Format.fprintf f "@[<1>bool@ %s(%a)@ (%a)@]" name
+ (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+ else
+ Format.fprintf f "@[<1>%s(%a)@ (%a)@]" name
+ (Aux.fprint_sep_list "," fprint_mod_var) mod_vars fprint def
+
+(* Print definition to stdout. *)
+let print_def ?(print_bool=false) = make_print (fprint_def ~print_bool)
+(* Print definition to string. *)
+let sprint_def ?(print_bool=false) = make_sprint (fprint_def ~print_bool)
+(* Another name for sprint_def. *)
+let str_def = sprint_def
+
+(* Print class and definition list to formatter. *)
+let rec fprint_defs ?(print_bool=false) f (cl, dl) =
+ let fprint_class f (name, vars) =
+ let fp_str f s =
+ if print_bool then Format.fprintf f "bool %s" s else
+ Format.fprintf f "%s" s in
+ if print_bool then
+ Format.fprintf f "@[<1>class@ %s@ {@\n%a;@\n}@]" name
+ (Aux.fprint_sep_list ~newline:1 ";" fp_str) vars
+ else
+ Format.fprintf f "@[<1>class@ %s@ {@ %a;@ }@]" name
+ (Aux.fprint_sep_list ";" fp_str) vars in
+ if cl <> [] then
+ Format.fprintf f "@[<1> %a;@\n@]"
+ (Aux.fprint_sep_list ~newline:2 ";" fprint_class) cl;
+ if cl <> [] && dl <> [] then Format.fprintf f "@\n@\n";
+ if dl <> [] then
+ Format.fprintf f "@[<1> %a;@]"
+ (Aux.fprint_sep_list ~newline:2 ";" (fprint_def ~print_bool)) dl
+
+(* Print definitions to stdout. *)
+let print_defs ?(print_bool=false) = make_print (fprint_defs ~print_bool)
+(* Print definitions to string. *)
+let sprint_defs ?(print_bool=false) = make_sprint (fprint_defs ~print_bool)
+(* Another name for sprint_defs. *)
+let str_defs = sprint_defs
+
+
(* --------------------- 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
+ | Not phi | Ex (_, phi) -> size ~acc:(acc + 1) phi
| And flist | Or flist ->
List.fold_left (fun i f -> size ~acc:i f) (acc + 1) flist
@@ -80,7 +144,9 @@
| 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
+ | Ex (v, x)->
+ let nf = Ex (v, to_nnf ~neg:false x) in
+ if neg then Not nf else nf
(* Flatten conjunctions and disjunctions, apply [f] to the lists. *)
let rec flatten_f f phi =
@@ -91,6 +157,7 @@
let rev_collect_conj xl = fold_acc get_conjunctions xl in
let rev_collect_disj xl = fold_acc get_disjunctions xl in
match phi with
+ | NegVar _ | PosVar _ | Fun _ -> phi
| Not (Not psi) -> psi
| Not (PosVar (m, n)) -> NegVar (m, n)
| Not (NegVar (m, n)) -> PosVar (m, n)
@@ -100,8 +167,6 @@
| 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
@@ -128,4 +193,26 @@
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)
+
+
+(* Trivial simplification of Boolean definitions. *)
+let triv_simp_defs defs =
+ List.map (fun (n, fp, a, d) -> (n, fp, a, triv_simp d)) defs
+
+
+(* Substitute module variables. Simple, fails on quantifier conflicts. *)
+let rec subst_mod_vars dict phi =
+ let subst_var v = try List.assoc v dict with Not_found -> v in
+ match phi with
+ | PosVar (m, n) -> PosVar (subst_var m, n)
+ | NegVar (m, n) -> NegVar (subst_var m, n)
+ | Fun (n, a) -> Fun (n, List.map subst_var a)
+ | Not psi -> Not (subst_mod_vars dict psi)
+ | Or fl -> Or (List.map (subst_mod_vars dict) fl)
+ | And fl -> And (List.map (subst_mod_vars dict) fl)
+ | Ex (mod_vs, psi) ->
+ let vs = List.map (fun (cl, v) -> v) mod_vs in
+ let new_dict = List.filter (fun (v, _) -> not (List.mem v vs)) dict in
+ if List.exists (fun (_, new_v) -> List.mem new_v vs) new_dict then
+ raise (Unsupported "substitution aliased by exists")
+ else Ex (mod_vs, subst_mod_vars new_dict psi)
Modified: trunk/Toss/Formula/BoolFunction.mli
===================================================================
--- trunk/Toss/Formula/BoolFunction.mli 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/BoolFunction.mli 2011-04-19 17:32:04 UTC (rev 1419)
@@ -5,7 +5,10 @@
(** Set debugging level. *)
val set_debug_level : int -> unit
+(** Some functions are not total yet. *)
+exception Unsupported of string
+
(** {2 Basic Type Definition} *)
(** This type describes Boolean functions *)
@@ -17,24 +20,47 @@
| 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
+(** Boolean definition of a function, knows whether it is a fixed-point. *)
+type bool_def = string * bool * (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
+(** Print definition to stdout. *)
+val print_def : ?print_bool : bool -> bool_def -> unit
+(** Print definition to string. *)
+val sprint_def : ?print_bool : bool -> bool_def -> string
+(** Another name for sprint_def. *)
+val str_def : ?print_bool : bool -> bool_def -> string
+(** Print definition to formatter. *)
+val fprint_def : ?print_bool : bool -> Format.formatter -> bool_def -> unit
+
+(** Print definitions to stdout. *)
+val print_defs : ?print_bool : bool ->
+ (string * string list) list * bool_def list -> unit
+(** Print definitions to string. *)
+val sprint_defs : ?print_bool : bool ->
+ (string * string list) list * bool_def list -> string
+(** Another name for sprint_defs. *)
+val str_defs : ?print_bool : bool ->
+ (string * string list) list * bool_def list -> string
+(** Print definitions to formatter. *)
+val fprint_defs : ?print_bool : bool -> Format.formatter ->
+ (string * string list) list * bool_def list -> unit
+
+
(** {2 Basic Functions} *)
(** Compute the size of a Boolean function. *)
@@ -45,3 +71,9 @@
(** Flatten and perform trivial simplifications (e.g. absorb true, false) *)
val triv_simp : bool_function -> bool_function
+
+(** Trivial simplification of Boolean definitions. *)
+val triv_simp_defs : bool_def list -> bool_def list
+
+(** Substitute module variables. Simple, fails on quantifier conflicts. *)
+val subst_mod_vars : (string * string) list -> bool_function -> bool_function
Modified: trunk/Toss/Formula/BoolFunctionParser.mly
===================================================================
--- trunk/Toss/Formula/BoolFunctionParser.mly 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/BoolFunctionParser.mly 2011-04-19 17:32:04 UTC (rev 1419)
@@ -5,7 +5,11 @@
open BoolFunction
%}
-%start parse_bool_function
+%start parse_bool_defs_goal parse_bool_defs parse_bool_function
+%type <(string * string list)list *
+ BoolFunction.bool_def list * BoolFunction.bool_function>
+ parse_bool_defs_goal
+%type <(string * string list)list * BoolFunction.bool_def list> parse_bool_defs
%type <BoolFunction.bool_function> parse_bool_function bool_function_expr
@@ -20,27 +24,82 @@
| 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 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
+ | ID DOT ID EQ ID DOT ID
+ { Or [And [NegVar ($1, $3); NegVar ($5, $7)];
+ And [PosVar ($1, $3); PosVar ($5, $7)]] }
+ | 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) }
+ | ID DOT ID EQ TRUE { PosVar($1, $3) }
+ | ID DOT ID EQ FALSE { NegVar($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 }
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in Boolean function definition." }
-
parse_bool_function:
| bool_function_expr EOF { triv_simp $1 };
+
+bool_def:
+ | n = ID
+ vars = delimited (OPEN, separated_list (COMMA, id_pair), CLOSE)
+ phi = bool_function_expr
+ { (n, false, vars, phi) }
+ | LFP n = ID OPEN
+ vars = separated_list (COMMA, id_pair) CLOSE
+ phi = bool_function_expr
+ { (n, true, vars, phi) }
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in definition parsing." }
+
+id_sc_list:
+ | ID SEMICOLON { [$1] }
+ | ID SEMICOLON id_sc_list { $1 :: $3 }
+
+class_def:
+ | CLASS n = ID OPENCUR vars = id_sc_list CLOSECUR
+ { (n, vars) }
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in class parsing." }
+
+bool_defs_expr:
+ | class_def SEMICOLON { [(Some $1, None)] }
+ | class_def SEMICOLON bool_defs_expr { (Some $1, None) :: $3 }
+ | bool_def SEMICOLON { [(None, Some $1)] }
+ | bool_def SEMICOLON bool_defs_expr { (None, Some $1) :: $3 }
+ | error
+ { Lexer.report_parsing_error $startpos $endpos
+ "Syntax error in parsing list of definitions." }
+
+parse_bool_defs:
+ | dl = bool_defs_expr EOF
+ { let (classes_l, defs_l) = List.split dl in
+ let unsome_list l =
+ List.flatten (List.map (function Some x -> [x] | None -> []) l) in
+ let (classes, defs) = (unsome_list classes_l, unsome_list defs_l) in
+ (classes, triv_simp_defs defs) };
+
+parse_bool_defs_goal:
+ | dl = bool_defs_expr goal = bool_function_expr SEMICOLON EOF
+ | dl = bool_defs_expr goal = bool_function_expr EOF
+ { let (classes_l, defs_l) = List.split dl in
+ let unsome_list l =
+ List.flatten (List.map (function Some x -> [x] | None -> []) l) in
+ let (classes, defs) = (unsome_list classes_l, unsome_list defs_l) in
+ (classes, triv_simp_defs defs, triv_simp goal) };
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2011-04-19 17:32:04 UTC (rev 1419)
@@ -6,34 +6,124 @@
let bf_of_string s =
BoolFunctionParser.parse_bool_function Lexer.lex (Lexing.from_string s)
-let assert_eq_string arg msg x y =
+let defs_of_string s =
+ BoolFunctionParser.parse_bool_defs Lexer.lex (Lexing.from_string s)
+
+let defs_goal_of_string s =
+ BoolFunctionParser.parse_bool_defs_goal Lexer.lex (Lexing.from_string s)
+
+let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ let ws = Str.regexp "[ ,\n,\t]+" in
+ let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
+ let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
let 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
+ let test_parse_print_bf s res =
+ assert_eq_string s "Parse and print Boolean function"
+ res (str (bf_of_string s)) in
+ let test_parse_print_defs ?(print_bool=false) s res =
+ assert_eq_string s "Parse and print Boolean definitions"
+ res (str_defs ~print_bool (defs_of_string s)) in
+
+ test_parse_print_bf "MyRel (m)" "MyRel(m)";
+ test_parse_print_bf "Rel (m) | m.a1 = 0" "(Rel(m) | m.a1=0)";
+ test_parse_print_bf "m.a1=m.a2" "m.a1=m.a2";
+ test_parse_print_bf "m.a1=true & m.a2=false" "(m.a1=1 & m.a2=0)";
+ test_parse_print_bf "(R(m)&m.a1=1)|m.a2=0" "((R(m) & m.a1=1) | m.a2=0)";
+ test_parse_print_bf
("(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"
+ test_parse_print_bf "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)))")
+ test_parse_print_bf "(false | (true))" "true";
+ test_parse_print_bf
+ ("(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)))");
+
+ test_parse_print_defs "Copy (M m, Loc c) (false | (m.a1 = 0));"
+ " Copy(M m, Loc c) (m.a1=0);";
+ test_parse_print_defs
+ ("Copy (M m, Loc c) (false | (m.a1 = 0)); // comment \n" ^
+ "Lopy (M m, Loc c) (false | !m.a2) ;\n ")
+ " Copy(M m, Loc c) (m.a1=0);\n\n Lopy(M m, Loc c) (m.a2=0);";
+ test_parse_print_defs "class M { a1;a2 ; };" " class M { a1; a2; };";
+ test_parse_print_defs
+ ("class M { a1;a2; };\n" ^
+ "Copy (M m, Loc c) (false | (m.a1 = 0)); // comment \n" ^
+ "Lopy (M m, Loc c) (false | !m.a2) ;\n ")
+ ("class M { a1; a2; };\n" ^
+ "Copy(M m, Loc c) (m.a1=0);\nLopy(M m, Loc c) (m.a2=0);");
+ test_parse_print_defs ~print_bool:true
+ ("class M { a1;a2; };\n" ^
+ "Copy (M m, Loc c) (false | (m.a1 = 0)); // comment \n" ^
+ "Lopy (M m, Loc c) (false | !m.a2) ;\n ")
+ ("class M { bool a1; bool a2; };\n" ^
+ "bool Copy(M m, Loc c) (m.a1=0);\n" ^
+ "bool Lopy(M m, Loc c) (m.a2=0);");
);
+
+ "substitution of module variables" >::
+ (fun () ->
+ let test_mod_subst ?(failok=false) s dict res =
+ try
+ assert_eq_string s "Substituting module variables"
+ res (str (subst_mod_vars dict (bf_of_string s)))
+ with Unsupported msg ->
+ if failok then assert true else raise (Unsupported msg) in
+
+ test_mod_subst "R(m) & m.n1=0" [("m", "n")] "(R(n) & n.n1=0)";
+ test_mod_subst "R(m) & ex M m R(m)" [("m", "n")]
+ "(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 ~failok:true "ex M m R(x)" [("x", "m")] "";
+ );
]
-let exec = Aux.run_test_if_target "BoolFunctionTest" tests
-
+let main () =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ let (file, print_bool) = (ref "", ref false) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> BoolFunction.set_debug_level 1), "verbose");
+ ("-d", Arg.Int (fun i -> BoolFunction.set_debug_level i), "debug level");
+ ("-b", Arg.Unit (fun () -> print_bool := true), "print bool's");
+ ("-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 f = open_in !file in
+ let file_s = Aux.input_file f in
+ close_in f;
+ let cleaned_s1 = Str.global_replace (Str.regexp "bool") "" file_s in
+ let cleaned_s2 = Str.global_replace (Str.regexp "^.*<.*$") "" cleaned_s1 in
+ let cleaned_s3 = Str.global_replace (Str.regexp "^.*~+.*$") "" cleaned_s2 in
+ let cleaned_s4 = Str.global_replace (Str.regexp "^#.*$") "" cleaned_s3 in
+ let cleaned_s5 = Str.global_replace (Str.regexp "^//.*$") "" cleaned_s4 in
+ let res_s = Str.global_replace (Str.regexp "/\\*.*\\*/") "" cleaned_s5 in
+ try
+ let (cl, dl, goal) = defs_goal_of_string res_s in
+ print_defs ~print_bool:!print_bool (cl, dl);
+ print_endline "\n\n// GOAL FORMULA\n";
+ print goal;
+ print_endline ";\n";
+ with Lexer.Parsing_error err -> (
+ print_endline res_s;
+ let msg_raw = String.sub err 9 ((String.length err)-9) in
+ let msg = Str.global_replace (Str.regexp "\n") "\n// " msg_raw in
+ print_endline ("// ERROR: NOT PARSED\n//\n// " ^ msg ^ "\n");
+ )
+
+
+let _ = Aux.run_if_target "BoolFunctionTest" main
Modified: trunk/Toss/Formula/Lexer.mll
===================================================================
--- trunk/Toss/Formula/Lexer.mll 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/Lexer.mll 2011-04-19 17:32:04 UTC (rev 1419)
@@ -79,6 +79,7 @@
| STATE_SPEC
| LEFT_SPEC
| RIGHT_SPEC
+ | CLASS
| LFP
| EOF
@@ -215,6 +216,7 @@
| "STATE" { STATE_SPEC }
| "LEFT" { LEFT_SPEC }
| "RIGHT" { RIGHT_SPEC }
+ | "class" { CLASS }
| "LFP" { LFP }
| "lfp" { LFP }
| "mu" { LFP }
Modified: trunk/Toss/Formula/Tokens.mly
===================================================================
--- trunk/Toss/Formula/Tokens.mly 2011-04-19 00:35:53 UTC (rev 1418)
+++ trunk/Toss/Formula/Tokens.mly 2011-04-19 17:32:04 UTC (rev 1419)
@@ -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 LFP EOF
+%token MODEL_SPEC RULE_SPEC STATE_SPEC LEFT_SPEC RIGHT_SPEC CLASS LFP EOF
/* List in order of increasing precedence. */
%nonassoc COND
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-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-18 18:28:33
|
Revision: 1417
http://toss.svn.sourceforge.net/toss/?rev=1417&view=rev
Author: lukaszkaiser
Date: 2011-04-18 18:28:26 +0000 (Mon, 18 Apr 2011)
Log Message:
-----------
Moving QBF to BoolFormula, adding timeout support in MiniSat, Sat and BoolFormula.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormula.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/Sat/Makefile
trunk/Toss/Formula/Sat/MiniSAT.ml
trunk/Toss/Formula/Sat/MiniSAT.mli
trunk/Toss/Formula/Sat/MiniSATWrap.C
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Formula/Sat/Sat.mli
trunk/Toss/Formula/Sat/minisat/Solver.C
trunk/Toss/Formula/Sat/minisat/Solver.h
trunk/Toss/Makefile
trunk/Toss/TossFullTest.ml
Removed Paths:
-------------
trunk/Toss/Formula/Sat/qbf.ml
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,7 +1,12 @@
(* Represent Boolean combinations of integer literals. *)
let debug_level = ref 0
-let set_debug_level i = Sat.set_debug_level (i-1); (debug_level := i)
+let debug_elim = ref false
+let set_debug_level i = (
+ Sat.set_debug_level (i-1);
+ debug_level := i;
+ if i > 0 then debug_elim := true
+)
(* 0 : no generation is performed and to_cnf transforms a DNF
1 : use Tseitin to construct a CNF with auxiliary variables
@@ -9,7 +14,7 @@
let auxcnf_generation = ref 2
let set_auxcnf i = (auxcnf_generation := i)
-let simplification = ref 2
+let simplification = ref 7
let set_simplification i = (simplification := i)
(* bit 0 : subsumption test after cnf conversion
bit 1 : full-fledged simplification
@@ -104,12 +109,21 @@
let rec sort phi =
match phi with
- BVar _ -> phi
+ | BVar _ -> phi
| BNot psi -> BNot (sort psi)
| BOr psis -> BOr (List.sort compare (List.map sort psis))
| BAnd psis -> BAnd (List.sort compare (List.map sort psis))
+let rec subst vars = function
+ | BVar v when (List.mem v vars) -> BAnd []
+ | BVar v when (List.mem (-v) vars) -> BOr []
+ | BVar v -> BVar v
+ | BNot f -> subst vars f
+ | BOr fs -> BOr (List.map (subst vars) fs)
+ | BAnd fs -> BAnd (List.map (subst vars) fs)
+
+
(* Convert a Boolean combination into reduced form (over 'not' and 'or') *)
let rec to_reduced_form ?(neg=false) = function
BVar v -> if neg then BVar (-1 * v) else BVar v
@@ -242,43 +256,56 @@
formula phi
+(* Flatten conjunctions and disjunctions. *)
+let rec flatten phi =
+ let is_conjunction = function BAnd _ -> true | _ -> false in
+ let is_disjunction = function BOr _ -> true | _ -> false in
+ match phi with
+ | BNot (BNot psi) -> psi
+ | BNot (BVar v) -> BVar (-v)
+ | BNot psi -> BNot (flatten psi)
+ | BOr (flist) ->
+ if not (List.exists is_disjunction flist) then
+ BOr (List.map flatten flist)
+ else
+ (BOr (List.flatten (List.map
+ (function
+ | BOr psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
+ | BAnd (flist) ->
+ if not (List.exists is_conjunction flist) then
+ BAnd (List.map flatten flist)
+ else (BAnd (List.flatten (List.map
+ (function
+ | BAnd psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
+ | _ -> phi
+
+
+(* Absorb trues and falses *)
+let rec neutral_absorbing = function
+ | BVar _ as lit -> lit
+ | BNot psi -> BNot (neutral_absorbing psi)
+ | BOr psis ->
+ if (List.exists (fun psi -> psi = BAnd []) psis) then (BAnd []) else
+ let filtered_once = List.filter (fun psi -> psi <> BOr []) psis in
+ let new_psis = List.map neutral_absorbing filtered_once in
+ let filtered = List.filter (fun psi -> psi <> BOr []) new_psis in
+ if (List.exists (fun psi -> psi = BAnd []) filtered) then (BAnd []) else
+ BOr filtered
+ | BAnd psis ->
+ if (List.exists (fun psi -> psi = BOr []) psis) then (BOr []) else
+ let filtered_once = List.filter (fun psi -> psi <> BAnd []) psis in
+ let new_psis = List.map neutral_absorbing filtered_once in
+ let filtered = List.filter (fun psi -> psi <> BAnd []) new_psis in
+ if (List.exists (fun psi -> psi = BOr []) filtered) then (BOr []) else
+ BAnd filtered
+
(* Simplify a Boolean combination *)
let rec simplify phi =
let is_conjunction = function BAnd _ -> true | _ -> false in
let is_disjunction = function BOr _ -> true | _ -> false in
let is_literal = function BNot (BVar _) | BVar _ -> true | _ -> false in
- let rec flatten phi =
- match phi with
- | BNot (BNot psi) -> psi
- | BNot (BVar v) -> BVar (-v)
- | BNot psi -> BNot (flatten psi)
- | BOr (flist) ->
- if not (List.exists is_disjunction flist) then
- BOr (List.map flatten flist)
- else
- (BOr (List.flatten (List.map
- (function
- | BOr psis -> List.map flatten psis
- | psi -> [flatten psi] ) flist)))
- | BAnd (flist) ->
- if not (List.exists is_conjunction flist) then
- BAnd (List.map flatten flist)
- else (BAnd (List.flatten (List.map
- (function
- | BAnd psis -> List.map flatten psis
- | psi -> [flatten psi] ) flist)))
- | _ -> phi in
- let rec neutral_absorbing = function
- | BVar _ as lit -> lit
- | BNot psi -> BNot (neutral_absorbing phi)
- | BOr psis ->
- let filtered = List.filter (fun psi -> psi <> BOr []) psis in
- if (List.exists (fun psi -> psi = BAnd []) filtered) then (BAnd []) else
- BOr (List.map neutral_absorbing filtered)
- | BAnd psis ->
- let filtered = List.filter (fun psi -> psi <> BAnd []) psis in
- if (List.exists (fun psi -> psi = BOr []) filtered) then (BOr []) else
- BAnd (List.map neutral_absorbing filtered) in
let rec singularise unsorted_phi =
let phi = sort unsorted_phi in (* this should be done more elegantly!!! *)
let rec neg_occurrence = function
@@ -318,18 +345,18 @@
let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
BAnd(non_disjnctns @ List.filter
(fun theta ->
- (List.for_all (fun phi -> phi=theta or
+ (List.for_all (fun phi -> phi=theta ||
not (subformula phi theta)) non_disjnctns)
- & (List.for_all (fun phi -> phi=theta or
+ && (List.for_all (fun phi -> phi=theta ||
not (subclause phi theta)) disjnctns))
disjnctns)
| BOr psis ->
let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
BOr(non_conjnctns @ List.filter
(fun theta ->
- (List.for_all (fun phi -> phi=theta or
+ (List.for_all (fun phi -> phi=theta ||
not (subformula phi theta)) non_conjnctns)
- & (List.for_all (fun phi -> phi=theta or
+ && (List.for_all (fun phi -> phi=theta ||
not (subclause phi theta)) conjnctns))
conjnctns) in
let unit_propagation phi =
@@ -362,7 +389,7 @@
to_nnf (BNot res_neg_phi)
| BAnd psis ->
let (clauses, non_clauses) = List.partition
- (fun psi -> is_disjunction psi or is_literal psi) psis in
+ (fun psi -> is_disjunction psi || is_literal psi) psis in
let resolvent cl1 cl2 =
(* construct the resolvent of clauses cl1 and cl2 and
tag it with the reserved literal 0 *)
@@ -458,15 +485,15 @@
List.exists (fun y -> y=lit) thetas
| (BOr psis, (BVar v as lit))
| (BAnd psis, (BVar v as lit)) ->
- List.for_all (fun x -> x=lit or x=(lit_of_int 0)) psis
+ List.for_all (fun x -> x=lit || x=(lit_of_int 0)) psis
| (BOr psis, BOr thetas)
| (BAnd psis, BAnd thetas) ->
List.for_all
- (fun x -> x=(lit_of_int 0) or List.exists (fun y-> y=x) thetas)
+ (fun x -> x=(lit_of_int 0) || List.exists (fun y-> y=x) thetas)
psis
| (_, _) -> false in
let (clauses, non_clauses) =
- List.partition (fun phi -> is_disjunction phi or is_literal phi)
+ List.partition (fun phi -> is_disjunction phi || is_literal phi)
psis in
let (resolvents, non_resolvents) = List.partition
(fun clause ->
@@ -523,6 +550,12 @@
"\nwas simplified to " ^ str simplified);
simplified
+let subst_simp vars f =
+ let mem_simp = !simplification in
+ simplification := 2;
+ let res = simplify (subst vars f) in
+ simplification := mem_simp;
+ res
(* Convert reduced Boolean combination into CNF with aux variables (Tseitin) *)
let auxcnf_of_bool_formula phi =
@@ -661,3 +694,306 @@
formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
formula_cnf
+
+(* ------- Boolean quantifier elimination using CNF conversion ------- *)
+
+let to_cnf_basic phi =
+ let cnf = convert phi in
+ neutral_absorbing
+ (BAnd (List.rev_map (fun lits -> BOr (List.map lit_of_int lits)) cnf))
+
+let to_cnf ?(tm=1200.) phi =
+ try
+ Sat.set_timeout tm;
+ let res = to_cnf_basic phi in
+ Sat.clear_timeout ();
+ Some (res)
+ with Aux.Timeout _ -> None
+
+let try_cnf tm phi =
+ match to_cnf ~tm phi with None -> phi | Some psi -> psi
+
+let to_dnf_basic phi = to_nnf ~neg:true (to_cnf_basic (to_nnf ~neg:true phi))
+
+let to_dnf ?(tm=1200.) phi =
+ match to_cnf ~tm (to_nnf ~neg:true phi) with
+ | None -> None
+ | Some psi -> Some (to_nnf ~neg:true psi)
+
+let try_dnf tm phi =
+ match to_dnf ~tm phi with None -> phi | Some psi -> psi
+
+let univ ?(dbg=0) v phi =
+ if dbg > 0 then Printf.printf "Univ subst in %s\n%!" (str phi);
+ let simp1 = subst_simp [v] phi in
+ if dbg > 0 then Printf.printf "Univ subst POS: %s\n%!" (str simp1);
+ let simp2 = subst_simp [-v] phi in
+ if dbg > 0 then Printf.printf "Univ subst NEG: %s\n%!" (str simp2);
+ BAnd [simp1; simp2]
+
+
+let sort_freq phi vars =
+ let rec occ v acc = function
+ | BVar w -> if abs v = abs w then acc + 1 else acc
+ | BNot f -> occ v acc f
+ | BOr fl | BAnd fl -> List.fold_left (occ v) acc fl in
+ let freqs = Hashtbl.create (List.length vars) in
+ List.iter (fun v -> Hashtbl.add freqs v (occ v 0 phi)) vars;
+ let fq v = Hashtbl.find freqs v in
+ List.sort (fun v w -> (fq v) - (fq w)) vars
+
+let (tm_jump, cutvar, has_vars_mem) = (1.1, 3, Hashtbl.create 31)
+
+let _ = debug_elim := false
+
+(* Returns a quantifier-free formula equivalent to All (vars, phi).
+ The list [vars] contains only positive literals and [phi] is in NNF. *)
+let rec elim_all_rec ?(nocheck=false) prefix tout vars in_phi =
+ if List.length vars = 0 then in_phi else match in_phi with
+ | BVar v -> if List.mem (abs v) vars then BOr [] else (BVar v)
+ | BNot _ -> failwith "error (elim_all_rec): BNot in NNF Boolean formula"
+ | BAnd fs ->
+ if !debug_elim then Printf.printf "%s vars %i list %i (same sign)\n%!"
+ prefix (List.length vars) (List.length fs);
+ let do_elim (acc, i) f =
+ if f = BOr [] || acc = [BOr []] then ([BOr []], i+1) else
+ let new_pref = prefix ^ (string_of_int i) ^ ":" in
+ let elim_f = elim_all_rec new_pref tout vars f in
+ if elim_f = BOr [] then ([BOr []], i+1) else
+ if elim_f = BAnd [] then (acc, i+1) else (elim_f :: acc, i+1) in
+ let (simp_fs, _) = List.fold_left do_elim ([], 0) fs in
+ if !debug_elim then Printf.printf "%s done %!" prefix;
+ let res = match to_dnf ~tm:(5. *. tout) (BAnd simp_fs) with
+ | None ->
+ if !debug_elim then
+ Printf.printf "(non-dnf %i)\n%!" (size (BAnd simp_fs));
+ BAnd simp_fs
+ | Some psi ->
+ if !debug_elim then Printf.printf "(dnf %i)\n%!" (size psi);
+ psi in
+ neutral_absorbing (flatten res)
+ | BOr [] -> BOr []
+ | BOr [f] -> elim_all_rec prefix tout vars f
+ | BOr fs when List.for_all (function BVar _ -> true | _ -> false) fs ->
+ let is_univ_quant = function
+ | BVar v -> List.mem (abs v) vars
+ | _ -> failwith "error (elim_all_rec): non-BVar in BVar-only list" in
+ BOr (List.filter (fun v -> not (is_univ_quant v)) fs)
+ | BOr fs as phi ->
+ let rec has_vars sgn vl = function (* check if any var occurs *)
+ | BVar v -> if sgn then List.mem v vl else List.mem (abs v) vl
+ | BNot f -> has_vars sgn vl f
+ | BOr fl | BAnd fl -> List.exists (has_vars sgn vl) fl in
+ let has_vars_memo sgn vl =
+ try Hashtbl.find has_vars_mem (sgn, vl) with Not_found ->
+ let res = has_vars sgn vl in
+ Hashtbl.add has_vars_mem (sgn, vl) res;
+ res in
+ if !debug_elim && prefix <> "S" then
+ Printf.printf "%s vars %i list %i (partition)\n%!" prefix
+ (List.length vars) (List.length fs);
+ let (fs_yes, fs_no) = List.partition (has_vars_memo false vars) fs in
+ if Hashtbl.length has_vars_mem > 10000 then Hashtbl.clear has_vars_mem;
+ if fs_no <> [] then (
+ let elim_yes = elim_all_rec prefix tout vars (BOr fs_yes) in
+ neutral_absorbing (flatten (BOr (elim_yes :: fs_no)))
+ ) else if List.length vars = 1 then (
+ let sub = univ (List.hd vars) phi in
+ if prefix = "S" then simplify (to_dnf_basic sub) else
+ let (res, msg ) = match to_dnf ~tm:(5. *. tout) sub with
+ | None -> (simplify sub, "no dnf")
+ | Some dnf -> (simplify dnf, "dnf") in
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (%s)\n%!" prefix
+ (List.length vars) (List.length fs) msg;
+ res
+ ) else if List.length vars < cutvar then (
+ let insert psi v = neutral_absorbing (flatten (univ v psi)) in
+ let sub = List.fold_left insert phi vars in
+ let (res, msg ) = match to_dnf ~tm:(3. *. tout) sub with
+ | None -> (simplify sub, "no dnf")
+ | Some dnf -> (simplify dnf, "dnf") in
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (%s)\n%!" prefix
+ (List.length vars) (List.length fs) msg;
+ res
+ ) else (
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (inside %i)\n%!" prefix
+ (List.length vars) (List.length fs) (size phi);
+ try
+ if nocheck then raise (Aux.Timeout "!!out");
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (cnf conv) %!" prefix
+ (List.length vars) (List.length fs);
+ let bool_cnf = match to_cnf ~tm:(3. *. tout) phi with
+ | None -> raise (Aux.Timeout "!!none")
+ | Some psi -> psi in
+ if !debug_elim then Printf.printf "success \n%!";
+ let cnf = elim_all_rec prefix tout vars bool_cnf in
+ let xsize = function BAnd l -> List.length l | _ -> 0 in
+ if !debug_elim then
+ Printf.printf "%s vars %i list %i (cnf after conv %i) %!" prefix
+ (List.length vars) (List.length fs) (xsize cnf);
+ match to_dnf ~tm:(5. *. tout) cnf with
+ | None -> if !debug_elim then Printf.printf "\n%!"; cnf
+ | Some dnf ->
+ if !debug_elim then Printf.printf "(dnf) \n%!"; dnf
+ with Aux.Timeout s ->
+ if !debug_elim && s<>"!!out" then Printf.printf "failed\n%!";
+ let elim nbr_left timeout psi v =
+ try
+ if !debug_elim then
+ Printf.printf "%s eliminating %i%!" prefix v;
+ if nbr_left > 2 then (
+ Sat.set_timeout (timeout);
+ ) else ( Sat.set_timeout (3. *. timeout) );
+ let res = elim_all_rec "S" tout [v] psi in
+ Sat.clear_timeout ();
+ if !debug_elim then Printf.printf " success.\n%!";
+ Some res
+ with Aux.Timeout _ ->
+ if !debug_elim then Printf.printf " failed\n%!";
+ None in
+ let try_elim_var timeout (left_vars,cur_phi,elim_nbr,step,all_nbr) v =
+ if not (has_vars_memo true [-v] cur_phi) then (
+ if !debug_elim then
+ Printf.printf "%s elimineted %i (only pos)\n%!" prefix v;
+ (left_vars, subst_simp [-v] cur_phi, elim_nbr+1, step+1, all_nbr)
+ ) else if not (has_vars_memo true [v] cur_phi) then (
+ if !debug_elim then
+ Printf.printf "%s elimineted %i (only neg)\n%!" prefix v;
+ (left_vars, subst_simp [v] cur_phi, elim_nbr+1, step+1, all_nbr)
+ ) else if 2*step > all_nbr && elim_nbr > 0 &&
+ step+2 < all_nbr && all_nbr - elim_nbr > cutvar then
+ (v :: left_vars, cur_phi, elim_nbr, step + 1, all_nbr)
+ else match elim (all_nbr - step) timeout cur_phi v with
+ | None -> (v :: left_vars, cur_phi, elim_nbr, step + 1, all_nbr)
+ | Some psi -> (left_vars, psi, elim_nbr + 1, step + 1, all_nbr) in
+ let (left_vars, new_phi, elim_nbr, _, all_nbr) =
+ List.fold_left (try_elim_var tout) ([], phi,0,0, List.length vars)
+ (sort_freq phi vars) in
+ if elim_nbr > 0 then
+ elim_all_rec prefix tout left_vars new_phi
+ else
+ let (big_v, rest_vars) = (List.hd left_vars, List.tl left_vars) in
+ if !debug_elim then Printf.printf "branch %i\n%!" big_v;
+ elim_all_rec prefix (tm_jump *.tout) rest_vars (univ big_v new_phi)
+ )
+
+(* Returns a quantifier-free formula equivalent to All (vars, phi). *)
+let elim_all vars phi =
+ elim_all_rec " " 0.3 (List.map (fun v -> abs v) vars) (to_nnf phi)
+
+(* Returns a quantifier-free formula equivalent to Ex (vars, phi). *)
+let elim_ex vars phi =
+ to_nnf ~neg:true (elim_all vars (to_nnf ~neg:true phi))
+
+
+(* ------ Reading and reducing QBF --------- *)
+
+(* Type for quantified Boolean formulas. *)
+type qbf =
+ | QFree of bool_formula
+ | QEx of int list * qbf
+ | QAll of int list * qbf
+
+(* Print a QBF formula. *)
+let rec qbf_str = function
+ | QFree phi -> str phi
+ | QEx (vars, phi) ->
+ "(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
+ " " ^ qbf_str phi ^ ")"
+ | QAll (vars, phi) ->
+ "(ex " ^ (String.concat ", " (List.map string_of_int vars)) ^
+ " " ^ qbf_str phi ^ ")"
+
+
+(* Read a qdimacs description of a QBF from [in_ch]. *)
+let read_qdimacs in_ch =
+ (* Read the starting 'c' comment lines, and the first 'p' line.
+ Set the number of variables and the number of clauses. *)
+ let rec read_header () =
+ let line = input_line in_ch in
+ if line.[0] = 'c' then read_header () else
+ Scanf.sscanf line "p cnf %i %i" (fun x y -> (x, y)) in
+
+ (* Read one clause from a line. *)
+ let read_clause line =
+ let (s, i, clause) = (ref "", ref 0, ref []) in
+ while (line.[!i] != '0' || line.[!i - 1] != ' ') do
+ if line.[!i] = ' ' then (
+ i := !i + 1;
+ let lit = int_of_string !s in
+ clause := lit :: !clause;
+ s := "";
+ ) else (
+ s := !s ^ (String.make 1 line.[!i]);
+ i := !i + 1;
+ )
+ done;
+ !clause in
+
+ let list_int line =
+ let split = Str.split (Str.regexp "[ \t]+") line in
+ List.rev (List.tl (List.rev_map
+ (fun s -> int_of_string s) (List.tl split))) in
+
+ let read_formula () =
+ let (no_var, no_cl) = read_header () in
+ let rec read_phi () =
+ let line = input_line in_ch in
+ if line.[0] == 'a' then
+ QAll (list_int line, read_phi ())
+ else if line.[0] == 'e' then
+ QEx (list_int line, read_phi ())
+ else (
+ let cls = ref [read_clause (line)] in
+ for i = 1 to (no_cl-1) do
+ cls := (read_clause (input_line in_ch)) :: !cls
+ done;
+ QFree (
+ BAnd (List.map (fun lits -> BOr (List.map lit_of_int lits)) !cls))
+ ) in
+ read_phi () in
+
+ read_formula ()
+
+
+(* Eliminating quantifiers from QBF formulas. *)
+let rec elim_quant = function
+ | QFree (phi) -> phi
+ | QEx (vars, qphi) ->
+ Hashtbl.clear has_vars_mem;
+ let inside, len = elim_quant qphi, List.length vars in
+ if !debug_elim then Printf.printf "EX %i START\n%!" len;
+ let res_raw = elim_ex vars (inside) in
+ let res = match to_dnf ~tm:3. res_raw with
+ | None ->
+ if !debug_elim then (
+ Printf.printf "EX ELIM NO DNF\n%!";
+ Printf.printf "%s \n%!" (str res_raw);
+ );
+ res_raw
+ | Some r ->
+ if !debug_elim then Printf.printf "EX ELIM IN DNF\n%!";
+ r in
+ if !debug_elim then Printf.printf "EX %i FIN\n%!" len;
+ res
+ | QAll (vars, qphi) ->
+ Hashtbl.clear has_vars_mem;
+ let inside, len = elim_quant qphi, List.length vars in
+ if !debug_elim then Printf.printf "ALL %i START\n%!" len;
+ let res_raw = elim_all vars (inside) in
+ let res = match to_cnf ~tm:3. res_raw with
+ | None ->
+ if !debug_elim then (
+ Printf.printf "ALL ELIM NO CNF\n%!";
+ Printf.printf "%s \n%!" (str res_raw);
+ );
+ res_raw
+ | Some r ->
+ if !debug_elim then Printf.printf "ALL ELIM IN CNF\n%!";
+ r in
+ if !debug_elim then Printf.printf "ALL %i FIN\n%!" len;
+ res
Modified: trunk/Toss/Formula/BoolFormula.mli
===================================================================
--- trunk/Toss/Formula/BoolFormula.mli 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/BoolFormula.mli 2011-04-18 18:28:26 UTC (rev 1417)
@@ -55,13 +55,34 @@
val formula_to_cnf : Formula.formula -> Formula.formula
+(** {2 Boolean Quantifier Elimination and QBF} *)
-(** {2 Debugging.} *)
+(** Returns a quantifier-free formula equivalent to All (vars, phi). *)
+val elim_all : int list -> bool_formula -> bool_formula
+(** Returns a quantifier-free formula equivalent to Ex (vars, phi). *)
+val elim_ex : int list -> bool_formula -> bool_formula
+
+(** Type for quantified Boolean formulas. *)
+type qbf =
+ | QFree of bool_formula
+ | QEx of int list * qbf
+ | QAll of int list * qbf
+
+(** Print a QBF formula. *)
+val qbf_str : qbf -> string
+
+(** Read a qdimacs description of a QBF from [in_ch]. *)
+val read_qdimacs : in_channel -> qbf
+
+(** Eliminating quantifiers from QBF formulas. *)
+val elim_quant : qbf -> bool_formula
+
+
+(** {3 Debugging} *)
+
(** Debugging information. At level 0 nothing is printed out. *)
val set_debug_level : int -> unit
-
-
val set_auxcnf : int -> unit
val set_simplification : int -> unit
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -3,7 +3,6 @@
open BoolFormula;;
BoolFormula.set_debug_level 0;;
-BoolFormula.set_simplification 6;; (* w/ resolution: 6; w/o resolution: 2 *)
BoolFormula.set_auxcnf 2;; (* Tseitin: 1 Plaisted-Greenbaum: 2 *)
let formula_of_string s =
@@ -226,6 +225,188 @@
test_cnf_string (fun x -> String.length x > 9) (test_formula 200)
);
+
+ "basic Boolean quantifier elimination" >::
+ (fun () ->
+ let test_elim_ex form vars res_s =
+ let eq_s = assert_eq_string (BoolFormula.str form) in
+ eq_s "Eliminating ex quantifier" res_s
+ (BoolFormula.str (elim_ex vars form)) in
+
+ (* ex X [ (X or Y) and (not X or Z) ] = (Y or Z) *)
+ let b = BAnd [BOr [BVar 1; BVar 2]; BOr [BVar (-1); BVar 3]] in
+ test_elim_ex b [1] "(2 or 3)";
+ );
]
+
+let bigtests = "BoolFormulaBig" >::: [
+ "simple QBF solving" >::
+ (fun () ->
+ let test_elim qbf res_s =
+ let eq_s = assert_eq_string (qbf_str qbf) in
+ eq_s "Eliminating quantifiers from QBF" res_s
+ (BoolFormula.str (elim_quant qbf)) in
+
+ let s27_d2_s = "p cnf 85 142
+e 4 5 6 7 1 2 3 9 10 11 12 13 14 15 16 17 32 33 34 35 37 38 39 40 41 42 43 44 45 0
+a 18 19 20 21 23 25 26 27 28 29 0
+e 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 0
+-1 0
+-2 0
+-3 0
+4 9 0
+-4 -9 0
+-1 -10 0
+-15 -10 0
+1 15 10 0
+9 -11 0
+2 -11 0
+-9 -2 11 0
+-13 12 0
+-11 12 0
+13 11 -12 0
+-5 -13 0
+-3 -13 0
+5 3 13 0
+-7 14 0
+-11 14 0
+7 11 -14 0
+14 15 0
+12 15 0
+-14 -12 -15 0
+-9 -16 0
+-10 -16 0
+9 10 16 0
+-6 -17 0
+-13 -17 0
+6 13 17 0
+32 37 0
+-32 -37 0
+-16 -38 0
+-43 -38 0
+16 43 38 0
+37 -39 0
+10 -39 0
+-37 -10 39 0
+-41 40 0
+-39 40 0
+41 39 -40 0
+-33 -41 0
+-17 -41 0
+33 17 41 0
+-35 42 0
+-39 42 0
+35 39 -42 0
+42 43 0
+40 43 0
+-42 -40 -43 0
+-37 -44 0
+-38 -44 0
+37 38 44 0
+-34 -45 0
+-41 -45 0
+34 41 45 0
+-18 60 0
+-23 60 0
+18 23 -60 0
+18 61 0
+23 61 0
+-18 -23 -61 0
+1 62 0
+38 62 0
+-1 -38 -62 0
+29 63 0
+38 63 0
+-29 -38 -63 0
+-1 64 0
+-29 64 0
+-38 64 0
+1 29 38 -64 0
+-23 65 0
+25 65 0
+23 -25 -65 0
+-2 66 0
+25 66 0
+2 -25 -66 0
+23 67 0
+2 67 0
+-25 67 0
+-23 -2 25 -67 0
+27 68 0
+-26 68 0
+-27 26 -68 0
+25 69 0
+-26 69 0
+-25 26 -69 0
+-27 70 0
+-25 70 0
+26 70 0
+27 25 -26 -70 0
+19 71 0
+27 71 0
+-19 -27 -71 0
+3 72 0
+27 72 0
+-3 -27 -72 0
+-19 73 0
+-3 73 0
+-27 73 0
+19 3 27 -73 0
+21 74 0
+-28 74 0
+-21 28 -74 0
+25 75 0
+-28 75 0
+-25 28 -75 0
+-21 76 0
+-25 76 0
+28 76 0
+21 25 -28 -76 0
+-28 77 0
+-29 77 0
+28 29 -77 0
+-26 78 0
+-29 78 0
+26 29 -78 0
+28 79 0
+26 79 0
+29 79 0
+-28 -26 -29 -79 0
+23 80 0
+44 80 0
+-23 -44 -80 0
+38 81 0
+44 81 0
+-38 -44 -81 0
+-23 82 0
+-38 82 0
+-44 82 0
+23 38 44 -82 0
+20 83 0
+45 83 0
+-20 -45 -83 0
+27 84 0
+45 84 0
+-27 -45 -84 0
+-20 85 0
+-27 85 0
+-45 85 0
+20 27 45 -85 0
+-60 -61 -62 -63 -64 -65 -66 -67 -68 -69 -70 -71 -72 -73 -74 -75 -76 -77 -78 -79 -80 -81 -82 -83 -84 -85 0
+" in
+
+ let f = open_out "tmp_testfile_28721.bf" in
+ output_string f s27_d2_s;
+ close_out f;
+ let f = open_in "tmp_testfile_28721.bf" in
+ let qbf = read_qdimacs f in
+ close_in f;
+ Sys.remove "tmp_testfile_28721.bf";
+ test_elim qbf "true";
+ );
+]
+
let exec = Aux.run_test_if_target "BoolFormulaTest" tests
+
+let execbig = Aux.run_test_if_target "BoolFormulaTest" bigtests
Modified: trunk/Toss/Formula/Sat/Makefile
===================================================================
--- trunk/Toss/Formula/Sat/Makefile 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/Makefile 2011-04-18 18:28:26 UTC (rev 1417)
@@ -18,15 +18,11 @@
%Test:
make -C ../.. Formula/Sat/$@
-qbf: qbf.ml
- make -C ../.. Formula/Sat/qbf.native
- cp ../../qbf.native qbf
-
tests: SatTest
./SatTest
clean:
- rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest qbf
- rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot qbf
+ rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest
+ rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot
rm -f minisat/SatSolver.o minisat/MiniSATWrap.o
Modified: trunk/Toss/Formula/Sat/MiniSAT.ml
===================================================================
--- trunk/Toss/Formula/Sat/MiniSAT.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/MiniSAT.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,7 +1,7 @@
type var = int
type lit = int
type value = int (* F | T | X *)
-type solution = SAT | UNSAT
+type solution = SAT | UNSAT | TIMEOUT
external reset : unit -> unit = "minisat_reset"
external new_var : unit -> var = "minisat_new_var"
@@ -12,6 +12,7 @@
external solve_with_assumption : lit list -> solution = "minisat_solve_with_assumption"
external value_of : var -> value = "minisat_value_of"
external set_threshold : int -> unit = "minisat_set_threshold"
+external set_timeout : float -> unit = "minisat_set_timeout"
let string_of_value (v: value): string =
match v with
Modified: trunk/Toss/Formula/Sat/MiniSAT.mli
===================================================================
--- trunk/Toss/Formula/Sat/MiniSAT.mli 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/MiniSAT.mli 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,7 +1,7 @@
type var = int
type lit = int
type value = int (* F | T | X *)
-type solution = SAT | UNSAT
+type solution = SAT | UNSAT | TIMEOUT
external reset : unit -> unit = "minisat_reset"
external new_var : unit -> var = "minisat_new_var"
@@ -12,4 +12,5 @@
external solve_with_assumption : lit list -> solution = "minisat_solve_with_assumption"
external value_of : var -> value = "minisat_value_of"
external set_threshold : int -> unit = "minisat_set_threshold"
+external set_timeout : float -> unit = "minisat_set_timeout"
val string_of_value : value -> string
Modified: trunk/Toss/Formula/Sat/MiniSATWrap.C
===================================================================
--- trunk/Toss/Formula/Sat/MiniSATWrap.C 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/MiniSATWrap.C 2011-04-18 18:28:26 UTC (rev 1417)
@@ -47,6 +47,13 @@
return Val_unit;
}
+extern "C" value minisat_set_timeout(value c) {
+ double t = Double_val(c);
+ solver->setTimeout(t);
+
+ return Val_unit;
+}
+
/*extern "C" value minisat_simplify_db(value unit) {
solver->simplifyDB();
@@ -58,8 +65,10 @@
if(solver->solve()) {
r = Val_int(0);
+ } else if (solver->sat_timeout > 0) {
+ r = Val_int(1);
} else {
- r = Val_int(1);
+ r = Val_int(2);
}
return r;
@@ -72,8 +81,10 @@
if(solver->solve(assumption)) {
r = Val_int(0);
+ } else if (solver->sat_timeout > 0) {
+ r = Val_int(1);
} else {
- r = Val_int(1);
+ r = Val_int(2);
}
return r;
Modified: trunk/Toss/Formula/Sat/Sat.ml
===================================================================
--- trunk/Toss/Formula/Sat/Sat.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/Sat.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -3,6 +3,18 @@
let debug_level = ref 0
let set_debug_level i = (debug_level := i)
+let timeout = ref 0.
+let minisat_timeout = ref 900.
+let check_timeout msg =
+ if !timeout > 0.5 && Unix.gettimeofday () > !timeout then
+ (timeout := 0.; raise (Aux.Timeout msg))
+
+let set_timeout t =
+ minisat_timeout := 5. *. t; (* if MiniSat does it, it's important *)
+ timeout := Unix.gettimeofday () +. t
+
+let clear_timeout () = (timeout := 0.; minisat_timeout := 900.)
+
module IntSet = Set.Make
(struct type t = int let compare x y = x - y end)
@@ -44,6 +56,7 @@
(* Reset global variables and the minisat state. *)
let reset () =
MiniSAT.reset ();
+ MiniSAT.set_timeout !minisat_timeout;
var_map := Hashtbl.create 32;
var_rev_map := Hashtbl.create 32;
lit_frequencies := Hashtbl.create 32;
@@ -159,7 +172,9 @@
let solve () =
(* MiniSAT.simplify_db (); *)
match MiniSAT.solve () with
- MiniSAT.UNSAT -> None
+ | MiniSAT.UNSAT -> None
+ | MiniSAT.TIMEOUT ->
+ raise (Aux.Timeout "MiniSat")
| MiniSAT.SAT ->
let res = ref [] in
let update mv v =
@@ -206,6 +221,7 @@
(* Recursive formula performing conversion to cnf, accumulates clauses. *)
let rec perform_conversion disc_vars orig_lits orig_phi bound cl_acc =
+ check_timeout "Sat.perform_conversion";
match solve () with
None -> cl_acc
| Some vars ->
Modified: trunk/Toss/Formula/Sat/Sat.mli
===================================================================
--- trunk/Toss/Formula/Sat/Sat.mli 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/Sat.mli 2011-04-18 18:28:26 UTC (rev 1417)
@@ -3,6 +3,12 @@
(* ------- Main functions ------- *)
+(** Set timeout function for conversions. *)
+val set_timeout : float -> unit
+(** Clear timeout function. *)
+val clear_timeout : unit -> unit
+
+
(* Given a list of literals to set to true, simplify the given CNF formula. *)
val simplify : int list -> int list list -> int list list
Modified: trunk/Toss/Formula/Sat/minisat/Solver.C
===================================================================
--- trunk/Toss/Formula/Sat/minisat/Solver.C 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/minisat/Solver.C 2011-04-18 18:28:26 UTC (rev 1417)
@@ -46,6 +46,7 @@
, clauses_literals(0), learnts_literals(0), max_literals(0), tot_literals(0)
, ok (true)
+ , sat_timeout (900)
, cla_inc (1)
, var_inc (1)
, qhead (0)
@@ -79,6 +80,11 @@
//=================================================================================================
// Minor methods:
+bool Solver::setTimeout(double t)
+{
+ sat_timeout = t;
+ return true;
+}
// Creates a new SAT variable in the solver. If 'decision_var' is cleared, variable will not be
// used as a decision variable (NOTE! This has effects on the meaning of a SATISFIABLE result).
@@ -712,17 +718,21 @@
// Search:
while (status == l_Undef){
- if (verbosity >= 1)
- reportf("| %9d | %7d %8d %8d | %8d %8d %6.0f | %6.3f %% %6.3f |\n", (int)conflicts, order_heap.size(), nClauses(), (int)clauses_literals, (int)nof_learnts, nLearnts(), (double)learnts_literals/nLearnts(), progress_estimate*100, ((double)clock()-(double)t)/(double)CLOCKS_PER_SEC), fflush(stdout);
- status = search((int)nof_conflicts, (int)nof_learnts);
- nof_conflicts *= restart_inc;
- nof_learnts *= learntsize_inc;
- if ((double)(clock() - t) / CLOCKS_PER_SEC >= 900) {
+ if (verbosity >= 1)
+ reportf("| %9d | %7d %8d %8d | %8d %8d %6.0f | %6.3f %% %6.3f |\n", (int)conflicts, order_heap.size(), nClauses(), (int)clauses_literals, (int)nof_learnts, nLearnts(), (double)learnts_literals/nLearnts(), progress_estimate*100, ((double)clock()-(double)t)/(double)CLOCKS_PER_SEC), fflush(stdout);
+
+ status = search((int)nof_conflicts, (int)nof_learnts);
+ nof_conflicts *= restart_inc;
+ nof_learnts *= learntsize_inc;
+ if ((double)(clock() - t) / CLOCKS_PER_SEC >= sat_timeout) {
+ sat_timeout = -1;
+ if (verbosity >= 1) {
std::cout << "******************************************\n";
std::cout << "********************TIMEOUT***************\n";
std::cout << "******************************************\n";
- break;
- }
+ };
+ break;
+ }
}
if (verbosity >= 1)
@@ -806,7 +816,7 @@
//reportf("number of solutions: %d\n",numSolutions);
cancelUntil(0);
- return status == l_True;
+ return (status == l_True && sat_timeout > 0);
}
//=================================================================================================
Modified: trunk/Toss/Formula/Sat/minisat/Solver.h
===================================================================
--- trunk/Toss/Formula/Sat/minisat/Solver.h 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/minisat/Solver.h 2011-04-18 18:28:26 UTC (rev 1417)
@@ -42,6 +42,8 @@
~Solver();
int var_threshold;
+ double sat_timeout;
+ bool setTimeout (double t);
// Problem specification:
//
Deleted: trunk/Toss/Formula/Sat/qbf.ml
===================================================================
--- trunk/Toss/Formula/Sat/qbf.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Formula/Sat/qbf.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,171 +0,0 @@
-(* ----
- Simple QBF Solver (reads QBF in simplified QDIMACS format)
- ----
-*)
-
-type qbf =
- Cnf of int list list
- | Dnf of int list list
- | Ex of int list * qbf
- | All of int list * qbf
-
-
-(* ---------------------- READING QDIMACS INPUT ---------------------------- *)
-
-let var_freq = ref (Array.make 1 0.)
-let no = ref 0
-
-(* Read the starting 'c' comment lines, and the first 'p' line.
- Set the number of variables and the number of clauses.
-*)
-let rec read_header () =
- let line = read_line () in
- if line.[0] = 'c' then read_header () else
- Scanf.sscanf line "p cnf %i %i" (fun x y -> (x, y))
-
-let read_clause line =
- let (s, i, clause) = (ref "", ref 0, ref []) in
- while (line.[!i] != '0' || line.[!i - 1] != ' ') do
- if line.[!i] = ' ' then (
- i := !i + 1;
- let lit = int_of_string !s in
- clause := lit :: !clause;
- s := "";
- ) else (
- s := !s ^ (String.make 1 line.[!i]);
- i := !i + 1;
- )
- done;
- let len = log (float (List.length !clause)) in
- List.iter (fun l -> !var_freq.(abs l) <- !var_freq.(abs l) +. len) !clause;
- !clause
-
-let update_freq cls =
- for i = 0 to (Array.length !var_freq) - 1 do !var_freq.(i) <- 0. done;
- let update_cl cl =
- let len = log (float (List.length cl)) in
- List.iter (fun l -> !var_freq.(abs l) <- !var_freq.(abs l) +. len) cl in
- List.iter update_cl cls
-
-let list_int line =
- let split = Str.split (Str.regexp "[ \t]+") line in
- List.rev (List.tl (List.rev_map (fun s -> int_of_string s) (List.tl split)))
-
-let read_formula () =
- let (no_var, no_cl) = read_header () in
- var_freq := Array.make (no_var + 1) 0.;
- let rec read_phi () =
- let line = read_line () in
- if line.[0] == 'a' then
- All (list_int line, read_phi ())
- else if line.[0] == 'e' then
- Ex (list_int line, read_phi ())
- else (
- let cls = ref [read_clause (line)] in
- for i = 1 to (no_cl-1) do
- cls := (read_clause (read_line ())) :: !cls
- done;
- Cnf (!cls)
- ) in
- read_phi ()
-
-
-(* ------------------------- PRINTING -------------------------------------- *)
-
-let string_of_cl sep cl =
- "(" ^ (String.concat sep (List.map (fun i -> string_of_int i) cl)) ^ ")"
-
-let rec string_of_formula = function
- Ex (vars, phi) -> "e " ^ (String.concat " " (List.map string_of_int vars)) ^
- " | " ^ (string_of_formula phi)
- | All (vars, phi) -> "a " ^ (String.concat " " (List.map string_of_int vars))^
- " | " ^ (string_of_formula phi)
- | Cnf (cls) ->
- if cls = [] then "T" else if cls = [[]] then "F" else
- String.concat " /\\ " (List.map (string_of_cl " \\/ ") cls)
- | Dnf (cls) ->
- if cls = [] then "F" else if cls = [[]] then "T" else
- String.concat " \\/ " (List.map (string_of_cl " /\\ ") cls)
-
-
-(* ------------------------------ SOLVER ---------------------------------- *)
-
-let covered vars cl = List.exists (fun l -> List.mem (abs l) vars) cl
-
-let sort_freq d vars =
- List.sort (fun v w -> d * (compare !var_freq.(abs v) !var_freq.(abs w))) vars
-
-let filter vars cls =
- List.map (fun cl -> List.filter (fun l -> not (List.mem (abs l) vars)) cl) cls
-
-exception FalseEx
-let conv_bound = ref 40
-
-let elim_var (cls, vacc) v =
- no := !no + 1;
- if !var_freq.(v)>(float !conv_bound)/.2. then (cls, v :: vacc) (*hack*) else (
- print_endline ("ex v. "^(string_of_int v) ^ " (" ^ (string_of_int !no) ^
- ", " ^ (string_of_float !var_freq.(v)) ^ ")");
- let (cls_v, cls_nv) = List.partition (fun cl -> covered [v] cl) cls in
- try
- let conv_v = Sat.convert ~disc_vars:[v] cls_v ~bound:(Some !conv_bound) in
- if conv_v=[] then raise FalseEx else if conv_v = [[]] then (cls_nv, vacc)
- else (List.rev_append cls_nv
- (Sat.convert ~bound:(Some (!conv_bound * 4)) conv_v), vacc)
- with
- Sat.OverBound -> print_endline " elim failed"; (cls, v :: vacc)
- )
-
-let rec solve = function
- Cnf (cls) -> Cnf (cls)
- | Dnf (cls) -> Dnf (cls)
- | Ex ([], phi) ->
- print_endline (" formula ex empty " ^ (string_of_formula phi)); phi
- | All ([], phi) -> phi
- | All (vars, Cnf cls) as phi ->
- print_endline (" formula all " ^ (string_of_formula phi));
- Cnf (filter vars cls)
- | Ex (vars, Dnf cls) as phi ->
- print_endline (" formula ex " ^ (string_of_formula phi));
- Dnf (filter vars cls)
- | Ex (vars, Cnf cls) ->
- if cls = [] then Dnf([]) else if List.mem [] cls then Dnf ([[]]) else
- let len = List.length vars in
- if len < 3 then
- let conv = Sat.convert ~disc_vars:vars cls in
- if conv = [] then Dnf ([]) else Dnf conv
- else (
- update_freq cls;
- no := 0;
- let vs = sort_freq 1 vars in
- try
- let (ecls, left_vs) = List.fold_left elim_var (cls, []) vs in
- if left_vs = [] then Cnf ecls else (
- print_endline (" Left " ^ (string_of_int (List.length left_vs)) ^
- " from " ^ (string_of_int len) ^ " vars.");
- try
- if !conv_bound < 70 then raise Sat.OverBound;
- Sat.set_debug_level 2;
- let conv =
- Sat.convert ~disc_vars:left_vs ~bound:(Some !conv_bound) ecls
- in if conv = [] then Dnf ([]) else Dnf conv
- with Sat.OverBound ->
- Sat.set_debug_level 0;
- conv_bound := (3 * (!conv_bound)) / 2;
- solve (Ex (left_vs, Cnf ecls))
- )
- with FalseEx -> Dnf []
- )
- | All (vars, Dnf (cls)) ->
- if cls = [] then Dnf([]) else if List.mem [] cls then Dnf ([[]]) else
- let conv = Sat.convert ~disc_vars:vars cls in
- if conv = [] then Dnf ([]) else solve (All (vars, Cnf conv))
- | Ex (vars, phi) -> solve (Ex (vars, solve phi))
- | All (vars, phi) -> solve (All (vars, solve phi))
-
-let _ =
- let phi = read_formula () in
- print_endline ("Solving formula " ^ (string_of_formula phi));
- Sat.set_debug_level 0;
- print_endline ("Solved: " ^ (string_of_formula (solve phi)));
-;;
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/Makefile 2011-04-18 18:28:26 UTC (rev 1417)
@@ -59,7 +59,7 @@
$(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG)
FormulaINCSatINC=Formula
-FormulaINC=Formula/Sat
+FormulaINC=Formula,Formula/Sat
SolverINC=Formula,Formula/Sat,Solver/RealQuantElim
ArenaINC=Formula,Formula/Sat,Solver/RealQuantElim,Solver
PlayINC=Formula,Formula/Sat,Solver/RealQuantElim,Solver,Arena
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-04-17 14:05:28 UTC (rev 1416)
+++ trunk/Toss/TossFullTest.ml 2011-04-18 18:28:26 UTC (rev 1417)
@@ -1,6 +1,14 @@
open OUnit
-let formula_tests = TossTest.formula_tests
+let formula_tests = "Formula" >::: [
+ AuxTest.tests;
+ FormulaTest.tests;
+ SatTest.tests;
+ BoolFormulaTest.tests;
+ BoolFormulaTest.bigtests;
+ FormulaOpsTest.tests;
+ FFTNFTest.tests;
+]
let solver_tests = TossTest.solver_tests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-17 14:05:36
|
Revision: 1416
http://toss.svn.sourceforge.net/toss/?rev=1416&view=rev
Author: lukaszkaiser
Date: 2011-04-17 14:05:28 +0000 (Sun, 17 Apr 2011)
Log Message:
-----------
Moving Sat tests to OUnit and adding to TossTest, code style cleanups in BoolFormula.
Modified Paths:
--------------
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/Sat/Makefile
trunk/Toss/Makefile
trunk/Toss/TossTest.ml
Added Paths:
-----------
trunk/Toss/Formula/Sat/SatTest.ml
Removed Paths:
-------------
trunk/Toss/Formula/Sat/Test.ml
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2011-04-17 01:25:17 UTC (rev 1415)
+++ trunk/Toss/Formula/BoolFormula.ml 2011-04-17 14:05:28 UTC (rev 1416)
@@ -5,7 +5,7 @@
(* 0 : no generation is performed and to_cnf transforms a DNF
1 : use Tseitin to construct a CNF with auxiliary variables
- 2 : (default) use Plaisted-Greenbaum to construct a CNF with auxiliary variables *)
+ 2 : use Plaisted-Greenbaum to construct a CNF with auxiliary variables *)
let auxcnf_generation = ref 2
let set_auxcnf i = (auxcnf_generation := i)
@@ -32,7 +32,8 @@
(* ----------------------- BASIC TYPE CONVERSIONS -------------------------- *)
-let int_of_lit lit = match lit with BVar v -> v | _ -> failwith ("This is not a literal!")
+let int_of_lit lit =
+ match lit with BVar v -> v | _ -> failwith ("This is not a literal!")
let lit_of_int v = BVar v
@@ -112,12 +113,17 @@
(* Convert a Boolean combination into reduced form (over 'not' and 'or') *)
let rec to_reduced_form ?(neg=false) = function
BVar v -> if neg then BVar (-1 * v) else BVar v
- | BNot phi -> if neg then to_reduced_form ~neg:false phi else to_reduced_form ~neg:true phi
+ | BNot phi ->
+ if neg then to_reduced_form ~neg:false phi else
+ to_reduced_form ~neg:true phi
| BAnd [f] | BOr [f] -> to_reduced_form ~neg f
- | BOr (bflist) when neg -> BNot (BOr (List.rev_map (to_reduced_form ~neg:false) bflist))
+ | BOr (bflist) when neg ->
+ BNot (BOr (List.rev_map (to_reduced_form ~neg:false) bflist))
| BOr (bflist) -> BOr (List.rev_map (to_reduced_form ~neg:false) bflist)
- | BAnd (bflist) when neg -> BOr (List.rev_map (to_reduced_form ~neg:true) bflist)
- | BAnd (bflist) -> BNot (BOr (List.rev_map (to_reduced_form ~neg:true) bflist))
+ | BAnd (bflist) when neg ->
+ BOr (List.rev_map (to_reduced_form ~neg:true) bflist)
+ | BAnd (bflist) ->
+ BNot (BOr (List.rev_map (to_reduced_form ~neg:true) bflist))
(* Convert a Boolean formula to NNF and additionally negate if [neg] is set. *)
@@ -190,7 +196,8 @@
let id = Hashtbl.find ids phi in if pos then id else -1 * id
with Not_found ->
if !debug_level > 2 then
- print_endline ("Added " ^ (Formula.str phi) ^ " as " ^ (string_of_int !free_id));
+ print_endline ("Added " ^ (Formula.str phi) ^ " as " ^
+ (string_of_int !free_id));
Hashtbl.add ids phi (!free_id);
Hashtbl.add rev_ids (!free_id) phi;
Hashtbl.add rev_ids (-1 * !free_id) (Formula.Not phi);
@@ -199,10 +206,14 @@
let rec bool_formula ?(pos=true) = function
Formula.Not (phi) when pos -> bool_formula ~pos:false phi
| Formula.Not (phi) -> bool_formula ~pos:true phi
- | Formula.And (flist) when pos -> BAnd (List.rev_map (bool_formula ~pos:true) flist)
- | Formula.And (flist) -> BNot (BAnd (List.rev_map (bool_formula ~pos:true) flist))
- | Formula.Or (flist) when pos -> BOr (List.rev_map (bool_formula ~pos:true) flist)
- | Formula.Or (flist) -> BNot (BOr (List.rev_map (bool_formula ~pos:true) flist))
+ | Formula.And (flist) when pos ->
+ BAnd (List.rev_map (bool_formula ~pos:true) flist)
+ | Formula.And (flist) ->
+ BNot (BAnd (List.rev_map (bool_formula ~pos:true) flist))
+ | Formula.Or (flist) when pos ->
+ BOr (List.rev_map (bool_formula ~pos:true) flist)
+ | Formula.Or (flist) ->
+ BNot (BOr (List.rev_map (bool_formula ~pos:true) flist))
| phi -> BVar (get_id ~pos:pos phi) in
bool_formula phi
@@ -217,13 +228,17 @@
let rec formula ?(pos=true) = function
BNot (phi) when pos -> formula ~pos:false phi
| BNot (phi) -> formula ~pos:true phi
- | BAnd (flist) when pos -> Formula.And (List.rev_map (formula ~pos:true) flist)
- | BAnd (flist) -> Formula.Not (Formula.And (List.rev_map (formula ~pos:true) flist))
- | BOr (flist) when pos -> Formula.Or (List.rev_map (formula ~pos:true) flist)
- | BOr (flist) -> Formula.Not (Formula.Or (List.rev_map (formula ~pos:true) flist))
- | BVar id -> try
- (Hashtbl.find rev_ids id)
- with Not_found -> failwith ("Boolean combination contains a non-hashed literal!") in
+ | BAnd (flist) when pos ->
+ Formula.And (List.rev_map (formula ~pos:true) flist)
+ | BAnd (flist) ->
+ Formula.Not (Formula.And (List.rev_map (formula ~pos:true) flist))
+ | BOr (flist) when pos ->
+ Formula.Or (List.rev_map (formula ~pos:true) flist)
+ | BOr (flist) ->
+ Formula.Not (Formula.Or (List.rev_map (formula ~pos:true) flist))
+ | BVar id -> try (Hashtbl.find rev_ids id) with
+ Not_found ->
+ failwith ("Boolean combination contains a non-hashed literal!") in
formula phi
@@ -234,215 +249,257 @@
let is_literal = function BNot (BVar _) | BVar _ -> true | _ -> false in
let rec flatten phi =
match phi with
- BNot (BNot psi) -> psi
+ | BNot (BNot psi) -> psi
| BNot (BVar v) -> BVar (-v)
| BNot psi -> BNot (flatten psi)
| BOr (flist) ->
- if not (List.exists is_disjunction flist)
- then BOr (List.map flatten flist)
- else (BOr (List.flatten (List.map (fun psi -> match psi with
- BOr psis -> List.map flatten psis
- | _ -> [flatten psi] ) flist)))
+ if not (List.exists is_disjunction flist) then
+ BOr (List.map flatten flist)
+ else
+ (BOr (List.flatten (List.map
+ (function
+ | BOr psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
| BAnd (flist) ->
- if not (List.exists is_conjunction flist)
- then BAnd (List.map flatten flist)
- else (BAnd (List.flatten (List.map (fun psi -> match psi with
- BAnd psis -> List.map flatten psis
- | _ -> [flatten psi] ) flist)))
+ if not (List.exists is_conjunction flist) then
+ BAnd (List.map flatten flist)
+ else (BAnd (List.flatten (List.map
+ (function
+ | BAnd psis -> List.map flatten psis
+ | psi -> [flatten psi] ) flist)))
| _ -> phi in
let rec neutral_absorbing = function
- BVar _ as lit -> lit
+ | BVar _ as lit -> lit
| BNot psi -> BNot (neutral_absorbing phi)
- | BOr psis -> let filtered = List.filter (fun psi -> psi <> BOr []) psis in
- if (List.exists (fun psi -> psi = BAnd []) filtered)
- then (BAnd []) else BOr (List.map neutral_absorbing filtered)
- | BAnd psis -> let filtered = List.filter (fun psi -> psi <> BAnd []) psis in
- if (List.exists (fun psi -> psi = BOr []) filtered)
- then (BOr []) else BAnd (List.map neutral_absorbing filtered) in
+ | BOr psis ->
+ let filtered = List.filter (fun psi -> psi <> BOr []) psis in
+ if (List.exists (fun psi -> psi = BAnd []) filtered) then (BAnd []) else
+ BOr (List.map neutral_absorbing filtered)
+ | BAnd psis ->
+ let filtered = List.filter (fun psi -> psi <> BAnd []) psis in
+ if (List.exists (fun psi -> psi = BOr []) filtered) then (BOr []) else
+ BAnd (List.map neutral_absorbing filtered) in
let rec singularise unsorted_phi =
let phi = sort unsorted_phi in (* this should be done more elegantly!!! *)
let rec neg_occurrence = function
- (* check whether a _sorted_ "uniqued" list contains a pair (phi,not phi)
- at the moment this only works for literals due to the implementation of compare! *)
- [] | [_] -> false
- | a :: b :: xs -> if (compare a b) = 0 then true else neg_occurrence (b :: xs) in
+ (* check whether a _sorted_ uniqued list contains a pair (phi,not phi)
+ for now only works for literals due to implementation of compare! *)
+ | [] | [_] -> false
+ | a :: b :: xs ->
+ if (compare a b) = 0 then true else neg_occurrence (b :: xs) in
match phi with
- BVar _ -> phi
+ | BVar _ -> phi
| BNot psi -> BNot (singularise psi)
- | BOr psis -> let unique_psis = Aux.unique (=) psis in
- let lits = List.filter is_literal unique_psis in
- if neg_occurrence lits then BAnd [] else BOr (List.map singularise unique_psis)
- | BAnd psis -> let unique_psis = Aux.unique (=) psis in
- let lits = List.filter is_literal unique_psis in
- if neg_occurrence lits then BOr [] else BAnd (List.map singularise unique_psis) in
+ | BOr psis ->
+ let unique_psis = Aux.unique (=) psis in
+ let lits = List.filter is_literal unique_psis in
+ if neg_occurrence lits then BAnd [] else
+ BOr (List.map singularise unique_psis)
+ | BAnd psis ->
+ let unique_psis = Aux.unique (=) psis in
+ let lits = List.filter is_literal unique_psis in
+ if neg_occurrence lits then BOr [] else
+ BAnd (List.map singularise unique_psis) in
let rec subsumption phi =
let subclause a b =
match (a,b) with
- (BOr psis, BOr thetas)
- | (BAnd psis, BAnd thetas) -> List.for_all (fun x -> List.exists (fun y -> y=x) thetas) psis
- | (_, _) -> false in
+ | (BOr psis, BOr thetas)
+ | (BAnd psis, BAnd thetas) ->
+ List.for_all (fun x -> List.exists (fun y -> y=x) thetas) psis
+ | (_, _) -> false in
let subformula psi theta =
match theta with
- BOr thetas
+ | BOr thetas
| BAnd thetas -> List.exists (fun theta -> theta = psi) thetas
- | _ -> false in
+ | _ -> false in
match phi with
- BVar _ | BNot _ -> phi
+ | BVar _ | BNot _ -> phi
| BAnd psis ->
- let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
- BAnd(non_disjnctns @ List.filter
- (fun theta ->
- (List.for_all (fun phi -> phi=theta or not (subformula phi theta)) non_disjnctns)
- & (List.for_all (fun phi -> phi=theta or not (subclause phi theta)) disjnctns))
- disjnctns)
+ let (disjnctns,non_disjnctns) = List.partition is_disjunction psis in
+ BAnd(non_disjnctns @ List.filter
+ (fun theta ->
+ (List.for_all (fun phi -> phi=theta or
+ not (subformula phi theta)) non_disjnctns)
+ & (List.for_all (fun phi -> phi=theta or
+ not (subclause phi theta)) disjnctns))
+ disjnctns)
| BOr psis ->
- let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
- BOr(non_conjnctns @ List.filter
+ let (conjnctns,non_conjnctns) = List.partition is_conjunction psis in
+ BOr(non_conjnctns @ List.filter
(fun theta ->
- (List.for_all (fun phi -> phi=theta or not (subformula phi theta)) non_conjnctns)
- & (List.for_all (fun phi -> phi=theta or not (subclause phi theta)) conjnctns))
+ (List.for_all (fun phi -> phi=theta or
+ not (subformula phi theta)) non_conjnctns)
+ & (List.for_all (fun phi -> phi=theta or
+ not (subclause phi theta)) conjnctns))
conjnctns) in
let unit_propagation phi =
(* beware that unit_propagation might introduce the subformula true,
- and hence should be followed by neutral_absorbing before starting the next fixed-point iteration *)
+ and hence should be followed by neutral_absorbing before
+ starting the next fixed-point iteration *)
match phi with
- BAnd phis ->
- let units = List.map (fun lit -> match lit with BVar v -> v | _ -> failwith ("not a literal!"))
- (List.filter is_literal phis) in
- let rec propagate units phi =
- match phi with
- BVar v -> if List.exists (fun unit -> v=unit) units then BAnd [] else phi
- | BNot psi -> BNot (propagate units psi)
- | BAnd psis -> BAnd (List.map (propagate units) psis)
- | BOr psis -> BOr (List.map (propagate units) psis) in
- BAnd ((List.map (fun v -> BVar v) units) @ (List.map (propagate units) phis))
+ | BAnd phis ->
+ let units = List.map
+ (function | BVar v -> v | _ -> failwith ("not a literal!"))
+ (List.filter is_literal phis) in
+ let rec propagate units phi =
+ match phi with
+ | BVar v ->
+ if List.exists (fun unit -> v=unit) units then BAnd [] else phi
+ | BNot psi -> BNot (propagate units psi)
+ | BAnd psis -> BAnd (List.map (propagate units) psis)
+ | BOr psis -> BOr (List.map (propagate units) psis) in
+ BAnd ((List.map (fun v -> BVar v) units) @
+ (List.map (propagate units) phis))
| _ -> phi in
let rec resolution phi =
match phi with
- BVar v -> phi
+ | BVar v -> phi
| BNot psi -> BNot (resolution psi)
| BOr psis ->
- let res_psis = List.map resolution psis in
- let neg_phi = to_nnf (BNot (BOr res_psis)) in
- let res_neg_phi = resolution neg_phi in
- to_nnf (BNot res_neg_phi)
+ let res_psis = List.map resolution psis in
+ let neg_phi = to_nnf (BNot (BOr res_psis)) in
+ let res_neg_phi = resolution neg_phi in
+ to_nnf (BNot res_neg_phi)
| BAnd psis ->
- let (clauses,non_clauses) = List.partition (fun psi -> is_disjunction psi or is_literal psi) psis in
- let resolvent cl1 cl2 =
- (* construct the resolvent of clauses cl1 and cl2 and tag it with the reserved literal 0 *)
- let rec split_clause (acc_lits, acc_rest) = function
- BVar v -> (v :: acc_lits, acc_rest)
- | BOr phis -> (match phis with
- [] -> (acc_lits, acc_rest)
- | psi :: psis -> if (is_literal psi)
- then split_clause ((int_of_lit psi)::acc_lits, acc_rest) (BOr psis)
- else split_clause (acc_lits, psi::acc_rest) (BOr psis)
- )
- | _ -> failwith ("this is not a clause feasible for resolution!") in
- let (cl1_lits,cl1_rest) = split_clause ([],[]) cl1 in
- let (cl2_lits,cl2_rest) = split_clause ([],[]) cl2 in
- let res_lits = (* obtain list of feasible pivot-literals *)
- List.filter (fun lit1 -> List.exists (fun lit2 -> lit2 = -lit1) cl2_lits) cl1_lits in
- if !debug_level > 3 then
- print_endline ("res_lits: " ^ String.concat ", " (List.map string_of_int res_lits));
- (* if there is more than one possible pivot-literal, the resulting clause will be
- equivalent to true, so we don't care *)
- if (List.length res_lits) <> 1 then BAnd []
- else (* construct a resolvent and mark it with the unused literal 0 *)
- let lit = List.nth res_lits 0 in (* construct the resolvent of cl1 and cl2 using pivot-literal lit *)
- BOr ((lit_of_int 0) :: (List.map lit_of_int (List.filter (fun lit1 -> lit1 <> lit) cl1_lits
- @ List.filter (fun lit2 -> lit2 <> -lit) cl2_lits))
- @ cl1_rest @ cl2_rest) in
- let res_clauses = ref [] in
- let subsumed = ref [] in
- (* Construct all possible resolvents, and check for each new resolvent whether it is
- subsumed by some existing clause.
- In fact, the following does not work: "If this is the case, we can remove the two initial
- clauses (i.e. add them to the list subsumed)."
+ let (clauses, non_clauses) = List.partition
+ (fun psi -> is_disjunction psi or is_literal psi) psis in
+ let resolvent cl1 cl2 =
+ (* construct the resolvent of clauses cl1 and cl2 and
+ tag it with the reserved literal 0 *)
+ let rec split_clause (acc_lits, acc_rest) = function
+ | BVar v -> (v :: acc_lits, acc_rest)
+ | BOr phis -> (match phis with
+ | [] -> (acc_lits, acc_rest)
+ | psi :: psis ->
+ if (is_literal psi) then
+ split_clause ((int_of_lit psi)::acc_lits, acc_rest)
+ (BOr psis)
+ else split_clause (acc_lits, psi::acc_rest) (BOr psis)
+ )
+ | _ -> failwith ("this is not a clause feasible for resolution!") in
+ let (cl1_lits,cl1_rest) = split_clause ([],[]) cl1 in
+ let (cl2_lits,cl2_rest) = split_clause ([],[]) cl2 in
+ let res_lits = (* obtain list of feasible pivot-literals *)
+ List.filter (fun lit1 ->
+ List.exists (fun lit2 -> lit2 = -lit1) cl2_lits) cl1_lits in
+ if !debug_level > 3 then
+ print_endline ("res_lits: " ^ String.concat ", "
+ (List.map string_of_int res_lits));
+ (* if there is more than one possible pivot-literal, the resulting
+ clause will be equivalent to true, so we don't care *)
+ if (List.length res_lits) <> 1 then BAnd []
+ else (* construct a resolvent and mark it with the unused literal 0 *)
+ let lit = List.nth res_lits 0 in
+ (* construct resolvent of cl1 and cl2 using pivot-literal lit *)
+ BOr ((lit_of_int 0) ::
+ (List.map lit_of_int
+ (List.filter (fun lit1 -> lit1 <> lit) cl1_lits
+ @ List.filter (fun lit2 -> lit2 <> -lit) cl2_lits))
+ @ cl1_rest @ cl2_rest) in
+ let res_clauses = ref [] in
+ let subsumed = ref [] in
+ (* Construct all possible resolvents and check each new resolvent
+ whether it is subsumed by some existing clause.
+ In fact, the following does not work: If this is the case we can
+ remove two initial clauses (ie add them to the list subsumed).
Instead, we discard the resolved but subsumed clause directly.
- *)
- List.iter (fun cl1 -> (List.iter
- (fun cl2 ->
- let cl_res = resolvent cl1 cl2 in
- let subclause a b = (* i.e. a \subseteq b *)
- match (a,b) with
- ((BVar v as lit), BOr thetas)
- | ((BVar v as lit), BAnd thetas) -> List.exists (fun y -> y=lit) thetas
- | (BOr psis, (BVar v as lit))
- | (BAnd psis, (BVar v as lit)) -> List.for_all (fun x -> x=lit) psis
- | (BOr psis, BOr thetas)
- | (BAnd psis, BAnd thetas) -> List.for_all (fun x -> List.exists
- (fun y -> y=x) thetas) psis
- | (_, _) -> false in
- if (List.exists (fun clause -> subclause clause cl_res) clauses)
- then (
- (* do nothing, since the resolvent is useless *)
- (*
- res_clauses := !res_clauses;
- subsumed := cl1 :: cl2 :: !subsumed;
- if !debug_level > 3 then (
- print_endline(" Subsumed clauses: " ^ str cl1 ^ " and " ^ str cl2);
- print_endline(" current resolvents: " ^ String.concat ", " (List.map str !res_clauses));
- print_endline(" current subsumed clauses: " ^ String.concat ", " (List.map str !subsumed))
- )*)
- )
- else
- res_clauses := cl_res :: !res_clauses;
- ) clauses)) clauses;
- if !debug_level > 2 then (
- print_endline("Resolvents: " ^ String.concat ", " (List.map str !res_clauses));
- print_endline("Subsumed clauses: " ^ String.concat ", " (List.map str !subsumed));
- print_endline("Reduced Resolvents: " ^ str (singularise (BAnd !res_clauses)));
- );
- let total = (List.filter (fun clause -> not (List.exists (fun sub -> clause=sub) !subsumed)) clauses)
- @ !res_clauses @ non_clauses in
- singularise (neutral_absorbing (BAnd total)) in
+ *)
+ List.iter (fun cl1 ->
+ (List.iter
+ (fun cl2 ->
+ let cl_res = resolvent cl1 cl2 in
+ let subclause a b = (* i.e. a \subseteq b *)
+ match (a,b) with
+ | ((BVar v as lit), BOr thetas)
+ | ((BVar v as lit), BAnd thetas) ->
+ List.exists (fun y -> y=lit) thetas
+ | (BOr psis, (BVar v as lit))
+ | (BAnd psis, (BVar v as lit)) ->
+ List.for_all (fun x -> x=lit) psis
+ | (BOr psis, BOr thetas)
+ | (BAnd psis, BAnd thetas) ->
+ List.for_all
+ (fun x -> List.exists (fun y -> y=x) thetas) psis
+ | (_, _) -> false in
+ if
+ (List.exists (fun clause -> subclause clause cl_res) clauses)
+ then ( (* do nothing, since the resolvent is useless *) ) else
+ res_clauses := cl_res :: !res_clauses;
+ ) clauses)) clauses;
+ if !debug_level > 2 then (
+ print_endline("Resolvents: " ^
+ String.concat ", " (List.map str !res_clauses));
+ print_endline("Subsumed clauses: " ^
+ String.concat ", " (List.map str !subsumed));
+ print_endline("Reduced Resolvents: " ^
+ str (singularise (BAnd !res_clauses)));
+ );
+ let total =
+ (List.filter
+ (fun clause ->
+ not (List.exists (fun sub -> clause=sub) !subsumed)) clauses)
+ @ !res_clauses @ non_clauses in
+ singularise (neutral_absorbing (BAnd total)) in
let choose_resolvents phi =
(* check the resolvents for "good" ones (at the moment these are clauses
that subsume clauses in the original formula) and discard the rest *)
let rec filter_by_subsumption = function
- BOr psis ->
- let filtered_psis = List.map filter_by_subsumption psis in
- let neg_phi = to_nnf (BNot (BOr filtered_psis)) in
- let filtered_neg_phi = filter_by_subsumption neg_phi in
- to_nnf (BNot filtered_neg_phi)
+ | BOr psis ->
+ let filtered_psis = List.map filter_by_subsumption psis in
+ let neg_phi = to_nnf (BNot (BOr filtered_psis)) in
+ let filtered_neg_phi = filter_by_subsumption neg_phi in
+ to_nnf (BNot filtered_neg_phi)
| BAnd psis ->
- let subclause a b = (* here, a is a resolvent, so we should not consider the literal 0! *)
- match (a,b) with
- ((BVar v as lit), BOr thetas)
- | ((BVar v as lit), BAnd thetas) -> List.exists (fun y -> y=lit) thetas
- | (BOr psis, (BVar v as lit))
- | (BAnd psis, (BVar v as lit)) -> List.for_all (fun x -> x=lit or x=(lit_of_int 0)) psis
- | (BOr psis, BOr thetas)
- | (BAnd psis, BAnd thetas) -> List.for_all (fun x -> x=(lit_of_int 0) or List.exists
- (fun y -> y=x) thetas) psis
- | (_, _) -> false in
- let (clauses,non_clauses) = List.partition (fun phi -> is_disjunction phi or is_literal phi) psis in
- let (resolvents,non_resolvents) = List.partition
- (fun clause ->
- (* actually these clauses do not necessarily contain only literals but maybe
- also more complex subformulas! *)
- let lits = (*print_endline("checking clause: " ^ str clause); *)
- match clause with
- BOr lits -> lits
- | BVar v as lit -> [lit]
- | _ -> failwith("[filter_by_subsumption] This is not a clause!") in
- (is_disjunction clause &&
+ let subclause a b =
+ (* here, a is a resolvent, so we should not consider the literal 0! *)
+ match (a,b) with
+ | ((BVar v as lit), BOr thetas)
+ | ((BVar v as lit), BAnd thetas) ->
+ List.exists (fun y -> y=lit) thetas
+ | (BOr psis, (BVar v as lit))
+ | (BAnd psis, (BVar v as lit)) ->
+ List.for_all (fun x -> x=lit or x=(lit_of_int 0)) psis
+ | (BOr psis, BOr thetas)
+ | (BAnd psis, BAnd thetas) ->
+ List.for_all
+ (fun x -> x=(lit_of_int 0) or List.exists (fun y-> y=x) thetas)
+ psis
+ | (_, _) -> false in
+ let (clauses, non_clauses) =
+ List.partition (fun phi -> is_disjunction phi or is_literal phi)
+ psis in
+ let (resolvents, non_resolvents) = List.partition
+ (fun clause ->
+ (* actually these clauses do not necessarily contain only
+ literals but maybe also more complex subformulas! *)
+ let lits = (*print_endline("checking clause: " ^ str clause); *)
+ match clause with
+ | BOr lits -> lits
+ | BVar v as lit -> [lit]
+ | _ ->
+ failwith("[filter_by_subsumption] This is not a clause!") in
+ (is_disjunction clause &&
List.exists (fun lit -> lit=(lit_of_int 0)) lits)) clauses in
- let useful_resolvents = List.filter
- (fun resolvent -> List.exists (fun phi -> subclause resolvent phi) non_resolvents) resolvents in
- if !debug_level > 2 then
- print_endline("Useful resolvents: " ^ String.concat ", " (List.map str useful_resolvents));
- let new_clauses = List.map (fun resolvent ->
- match resolvent with
- BOr lits -> BOr (List.filter (fun lit -> lit <> (lit_of_int 0)) lits)
- | _ -> failwith ("trying to remove literals from a non-clause!")
- ) useful_resolvents in
- BAnd (new_clauses @ non_resolvents @ (List.map filter_by_subsumption non_clauses))
+ let useful_resolvents = List.filter
+ (fun resolvent ->
+ List.exists (fun phi -> subclause resolvent phi) non_resolvents)
+ resolvents in
+ if !debug_level > 2 then
+ print_endline("Useful resolvents: " ^
+ String.concat ", " (List.map str useful_resolvents));
+ let new_clauses =
+ List.map (function
+ | BOr lits ->
+ BOr (List.filter (fun lit -> lit <> (lit_of_int 0)) lits)
+ | _ -> failwith ("trying to remove literals from a non-clause!")
+ ) useful_resolvents in
+ BAnd (new_clauses @ non_resolvents @
+ (List.map filter_by_subsumption non_clauses))
| BNot psi -> BNot (filter_by_subsumption psi)
- | BVar v as lit -> if (v=0) then failwith ("There should not be empty resolved clauses!") else lit in
- filter_by_subsumption phi
- in
+ | BVar v as lit ->
+ if v=0 then failwith "There should not be empty resolved clauses!" else
+ lit in
+ filter_by_subsumption phi in
let simplified =
let simp_resolution = fun phi ->
if ((!simplification lsr 2) land 1) > 0 then
@@ -450,27 +507,28 @@
else phi in
let simp_fun = fun phi ->
(simp_resolution
- (neutral_absorbing
- (unit_propagation
- (subsumption
- (singularise
- (neutral_absorbing
- (flatten
- (to_nnf phi)))))))) in
+ (neutral_absorbing
+ (unit_propagation
+ (subsumption
+ (singularise
+ (neutral_absorbing
+ (flatten
+ (to_nnf phi)))))))) in
let rec fp f x =
let y = f x in
- if y=x then x else fp f y in
- fp (fun phi -> (simp_fun phi)) phi in
- if !debug_level > 1 then
- print_endline ("Simplification:\nphi " ^ str phi ^ "\nwas simplified to " ^ str simplified);
- simplified
-
+ if y=x then x else fp f y in
+ fp (fun phi -> (simp_fun phi)) phi in
+ if !debug_level > 1 then
+ print_endline ("Simplification:\nphi " ^ str phi ^
+ "\nwas simplified to " ^ str simplified);
+ simplified
-(* Convert a reduced Boolean combination into a CNF with auxiliary variables (Tseitin) *)
+
+(* Convert reduced Boolean combination into CNF with aux variables (Tseitin) *)
let auxcnf_of_bool_formula phi =
let max_abs m lit = if lit < 0 then max m (-lit) else max m lit in
let rec get_max_lit m = function
- BVar v -> max_abs m v
+ | BVar v -> max_abs m v
| BNot phi -> get_max_lit m phi
| BAnd [] | BOr [] -> m
| BAnd (bflist) | BOr (bflist) -> List.fold_left get_max_lit m bflist in
@@ -478,14 +536,15 @@
let (clauses, free_idx) = (ref [], ref max_lit) in
let bv l = List.rev_map (fun i -> BVar i) l in
let rec index_formula = function
- BVar v -> v
+ | BVar v -> v
| BNot phi -> - (index_formula phi)
| BOr bflist ->
- let indlist = List.rev_map index_formula bflist in
- free_idx := !free_idx + 1;
- List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses) indlist;
- clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
- !free_idx
+ let indlist = List.rev_map index_formula bflist in
+ free_idx := !free_idx + 1;
+ List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses)
+ indlist;
+ clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
+ !free_idx
| _ -> failwith "auxcnf_to_bool_formula: converting non-reduced formula" in
let res_var = index_formula (to_reduced_form phi) in
(max_lit + 1, BAnd ((BOr [BVar (- res_var)]) :: !clauses))
@@ -496,7 +555,7 @@
let pg_auxcnf_of_bool_formula phi =
let max_abs m lit = if lit < 0 then max m (-lit) else max m lit in
let rec get_max_lit m = function
- BVar v -> max_abs m v
+ | BVar v -> max_abs m v
| BNot phi -> get_max_lit m phi
| BAnd [] | BOr [] -> m
| BAnd (bflist) | BOr (bflist) -> List.fold_left get_max_lit m bflist in
@@ -504,41 +563,46 @@
let (clauses, free_idx) = (ref [], ref max_lit) in
let bv l = List.rev_map (fun i -> BVar i) l in
let rec index_formula ?(neg=false) = function
- BVar v -> v
+ | BVar v -> v
| BNot phi -> - index_formula ~neg:(not neg) phi
| BOr bflist ->
- let indlist = List.rev_map (index_formula ~neg:neg) bflist in
- free_idx := !free_idx + 1;
- if neg then
- List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses) indlist
- else
- clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
- !free_idx
+ let indlist = List.rev_map (index_formula ~neg:neg) bflist in
+ free_idx := !free_idx + 1;
+ if neg then
+ List.iter (fun i -> clauses := (BOr (bv [-i; !free_idx])) :: !clauses)
+ indlist
+ else
+ clauses := BOr (bv ((- !free_idx) :: indlist)) :: !clauses;
+ !free_idx
| BAnd bflist ->
- let indlist = List.rev_map (index_formula ~neg:neg) bflist in
- free_idx := !free_idx + 1;
- if neg then
- clauses := BOr (bv (!free_idx :: (List.rev_map (fun i -> -i) indlist))) :: !clauses
- else
- List.iter (fun i -> clauses := (BOr (bv [i; (- !free_idx)])) :: !clauses) indlist;
- !free_idx in
+ let indlist = List.rev_map (index_formula ~neg:neg) bflist in
+ free_idx := !free_idx + 1;
+ if neg then
+ clauses :=
+ BOr (bv (!free_idx :: (List.rev_map (fun i -> -i) indlist))) ::
+ !clauses
+ else
+ List.iter
+ (fun i -> clauses := (BOr (bv [i; (- !free_idx)])) :: !clauses)
+ indlist;
+ !free_idx in
let res_var =
match phi with
- BNot psi -> - index_formula ~neg:false psi
+ | BNot psi -> - index_formula ~neg:false psi
| _ -> index_formula ~neg:true phi in
(max_lit + 1, BAnd ((BOr [BVar (- res_var)]) :: !clauses))
let listcnf_of_boolcnf phi =
let int_of_literal = function
- BVar v -> v
+ | BVar v -> v
| _ -> raise (FormulaError "Clauses must not contain non-literals!") in
let list_of_clause = function
- BVar v -> [v]
+ | BVar v -> [v]
| BOr (bflist) -> List.map int_of_literal bflist
| _ -> raise (FormulaError "This is not a clause!") in
match phi with
- BVar v -> [[v]]
+ | BVar v -> [[v]]
| BAnd (bflist) -> List.map list_of_clause bflist
| _ -> raise (FormulaError "This is not a CNF!")
@@ -550,16 +614,17 @@
let convert phi =
- (* input is a Boolean combination; output is a list of list of integers interpreted as a cnf *)
+ (* input is a Boolean combination; output is a list of list of integers
+ interpreted as a cnf *)
let (aux_separator, aux_cnf_formula) =
match !auxcnf_generation with
- 0 -> failwith ("this function must not be called without auxcnf-converion")
+ | 0 -> failwith "this function must not be called w/o auxcnf-converion"
| 1 -> (* use Tseitin conversion *)
- auxcnf_of_bool_formula (to_reduced_form (flatten_sort (to_nnf ~neg:false phi)))
+ auxcnf_of_bool_formula
+ (to_reduced_form (flatten_sort (to_nnf ~neg:false phi)))
| 2 -> (* or Plaisted-Greenbaum conversion *)
- pg_auxcnf_of_bool_formula (flatten_sort (to_nnf ~neg:false phi))
- | _ -> failwith ("undefined parameter value")
- in
+ pg_auxcnf_of_bool_formula (flatten_sort (to_nnf ~neg:false phi))
+ | _ -> failwith "undefined parameter value" in
if !debug_level > 0 then (
print_endline ("Separator is: " ^ string_of_int aux_separator);
print_endline ("Converting Aux-CNF: " ^ str aux_cnf_formula);
@@ -568,25 +633,31 @@
let cnf_llist = Sat.convert_aux_cnf aux_separator aux_cnf in
if !debug_level > 0 then
print_endline ("Converted CNF: " ^ (Sat.cnf_str cnf_llist));
- let simplified = if (!simplification land 1) > 0 then subsumption_filter cnf_llist else cnf_llist in
+ let simplified =
+ if (!simplification land 1) > 0 then
+ subsumption_filter cnf_llist
+ else cnf_llist in
if !debug_level > 1 then (
- if (!simplification land 1) > 0 then print_endline ("Subsumption turned on");
+ if (!simplification land 1) > 0 then
+ print_endline ("Subsumption turned on");
print_endline ("Simplified CNF: " ^ (Sat.cnf_str simplified))
);
- simplified
-
+ simplified
+
(* given a formula, convert to CNF. *)
let formula_to_cnf phi =
let (ids, rev_ids, free_id) = (Hashtbl.create 7, Hashtbl.create 7, ref 1) in
let boolean_phi = bool_formula_of_formula_arg phi (ids, rev_ids, free_id) in
let cnf_llist = convert boolean_phi in
- let bool_cnf = BAnd (List.map (fun literals -> BOr (List.map lit_of_int literals)) cnf_llist) in
- let simplified = if ((!simplification lsr 1) land 1) > 0 then simplify bool_cnf else bool_cnf in
- if !debug_level > 1 then (
- if ((!simplification lsr 1) land 1) > 0 then print_endline ("Simplification turned on");
-(* print_endline ("Simplified CNF: " ^ (Sat.cnf_str simplified))*)
- );
- let formula_cnf = formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
- formula_cnf
+ let bool_cnf =
+ BAnd (List.map (fun literals -> BOr (List.map lit_of_int literals))
+ cnf_llist) in
+ let simplified =
+ if ((!simplification lsr 1) land 1) > 0 then
+ simplify bool_cnf
+ else bool_cnf in
+ let formula_cnf =
+ formula_of_bool_formula_arg simplified (ids, rev_ids, free_id) in
+ formula_cnf
Modified: trunk/Toss/Formula/Sat/Makefile
===================================================================
--- trunk/Toss/Formula/Sat/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
+++ trunk/Toss/Formula/Sat/Makefile 2011-04-17 14:05:28 UTC (rev 1416)
@@ -1,26 +1,8 @@
MINISATDIR = minisat
-# mode is communicated by top-level make
-#MODE=debug
-
-ifeq ($(MODE),debug)
- # The option -dtypes emits types, e.g. for emacs editing in Tuareg mode
- OCAML = ocamlc -g
-
all: SatSolver.o MiniSATWrap.o
-#all: Sat.cma qbf
-else
- # The option -dtypes emits types, e.g. for emacs editing in Tuareg mode
- OCAML = ocamlopt -g
-all: SatSolver.o MiniSATWrap.o
-#all: Sat.cmxa qbf
-
-endif
-
-
-
SatSolver.o: $(MINISATDIR)/Solver.C
if [ ! -e minisat/SatSolver.o ]; then \
g++ -O2 -fPIC -c -I $(MINISATDIR) $(MINISATDIR)/Solver.C -o SatSolver.o; \
@@ -33,65 +15,18 @@
mv MiniSATWrap.o minisat/; \
fi
-MiniSAT.cmi: MiniSAT.mli
- $(OCAML) -c MiniSAT.mli
+%Test:
+ make -C ../.. Formula/Sat/$@
-MiniSAT.cmx: MiniSAT.ml MiniSAT.cmi
- $(OCAML) -c MiniSAT.ml
+qbf: qbf.ml
+ make -C ../.. Formula/Sat/qbf.native
+ cp ../../qbf.native qbf
-MiniSAT.cmo: MiniSAT.ml MiniSAT.cmi
- $(OCAML) -c MiniSAT.ml
+tests: SatTest
+ ./SatTest
-IntSet.cmi: IntSet.mli
- $(OCAML) -c IntSet.mli
-IntSet.cmx: IntSet.ml IntSet.cmi
- $(OCAML) -c IntSet.ml
-
-IntSet.cmo: IntSet.ml IntSet.cmi
- $(OCAML) -c IntSet.ml
-
-Sat.cmi: Sat.mli
- $(OCAML) -c Sat.mli
-
-Sat.cmx: Sat.ml Sat.cmi MiniSAT.cmi IntSet.cmi
- $(OCAML) -c Sat.ml
-
-Sat.cmxa: Sat.cmx SatSolver.o MiniSATWrap.o MiniSAT.cmx IntSet.cmx
- $(OCAML) -a -cclib -lstdc++ SatSolver.o MiniSATWrap.o MiniSAT.cmx \
- IntSet.cmx Sat.cmx -o Sat.cmxa
-
-Sat.cmo: Sat.ml Sat.cmi MiniSAT.cmi IntSet.cmi
- $(OCAML) -c Sat.ml
-
-Sat.cma: Sat.cmo SatSolver.o MiniSATWrap.o MiniSAT.cmo IntSet.cmo
- $(OCAML) -a -cclib -lstdc++ -custom SatSolver.o MiniSATWrap.o MiniSAT.cmo \
- IntSet.cmo Sat.cmo -o Sat.cma
-
-ifeq ($(MODE),debug)
-qbf: qbf.ml Sat.cma
- $(OCAML) str.cma Sat.cma qbf.ml -o qbf
-
-Test: Test.ml Sat.cma
- $(OCAML) Sat.cma Test.ml -o Test
-
-tests: Test
- ./Test
-
-else
-qbf: qbf.ml Sat.cmxa
- $(OCAML) str.cmxa Sat.cmxa qbf.ml -o qbf
-
-Test: Test.ml Sat.cmxa
- $(OCAML) Sat.cmxa Test.ml -o Test
-
-tests: Test
- ./Test
-
-endif
-
-
clean:
- rm -f *.o *.cmo *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa Test qbf
- rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot Test_debug qbf
+ rm -f *.cma *.cmi *~ *.cmxa *.cmx *.a *.annot Sat.cmxa SatTest qbf
+ rm -f *.o *.cmo *.cmo *.cmi *~ *.cma *.cmo *.a *.annot qbf
rm -f minisat/SatSolver.o minisat/MiniSATWrap.o
Copied: trunk/Toss/Formula/Sat/SatTest.ml (from rev 1415, trunk/Toss/Formula/Sat/Test.ml)
===================================================================
--- trunk/Toss/Formula/Sat/SatTest.ml (rev 0)
+++ trunk/Toss/Formula/Sat/SatTest.ml 2011-04-17 14:05:28 UTC (rev 1416)
@@ -0,0 +1,215 @@
+(* Simple MiniSAT cnf-dnf tests. *)
+open OUnit
+
+Sat.set_debug_level 0 ;;
+
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
+let test phi res_cnf =
+ assert_eq_string (Sat.dnf_str phi) "DNF to CNF conversion"
+ res_cnf (Sat.cnf_str (Sat.convert phi))
+
+let test_nbr_clauses nbr phi =
+ assert_eq_string (Sat.dnf_str phi) "Number of clauses in converted CNF"
+ (string_of_int nbr) (string_of_int (List.length (Sat.convert phi)))
+
+let rec list n = if n < 3 then [n] else n :: list (n-1)
+
+let tests = "Sat" >::: [
+ "basic dnf to cnf" >::
+ (fun () ->
+ test [[1; 2]; [3]] "(2 | 3) & (1 | 3)";
+ test [[1; 2]; [-1; -2]] "(-1 | 2) & (1 | -2)";
+ test [[1; 2; 3]] "(2) & (1) & (3)";
+ test [[1; -1]] "F";
+ test [[1]; [-1; 2]; [-2; 3]; [-3]] "T";
+ test [[1]; [-1; 2]; [-2; 3]; [-3; 4]] "(1 | 2 | 3 | 4)";
+ test [[1; 2]; [3; 4]] "(2 | 3) & (2 | 4) & (1 | 3) & (1 | 4)";
+ );
+
+ "conversion to cnf on larger classes" >::
+ (fun () ->
+ test_nbr_clauses 128
+ [[7]; [8]; [1; 2]; [3; 4]; [5; 6]; [9; 10]; [11;12]; [13;14]; [15;16]];
+
+ test_nbr_clauses 799 [[1]; list 800];
+
+ (* Nice multiply-out tests. *)
+ let p n = [-1 :: (list n); [1; -(n+1)]; [1; -(n+2)]; [-1;n+1; n+2]] in
+ test_nbr_clauses 59 (p 30);
+
+ let q n = [-1 :: (List.map (fun i -> (-i)) (list n));
+ [1; -(n+1)]; [1; -(n+2)]; [-1; n+1; n+2]] in
+ test_nbr_clauses 59 (q 30);
+ );
+
+ "examples from tnf calculations" >::
+ (fun () ->
+ (* A more complex example; all literals positive. *)
+ let t = [[1]; [33]; [2; 3]; [4; 5; 6; 7; 8; 9]; [10; 5; 6; 8; 9];
+ [11; 5; 6; 12; 8; 9]; [13; 5; 6; 12; 8]; [14; 5; 12; 7; 8];
+ [15; 5; 12; 8]; [16; 5; 6; 12; 8; 17]; [18; 5; 12; 8; 17];
+ [19; 5; 6; 12; 8]; [20; 5; 12; 8]; [21; 5; 6; 7; 8];
+ [22; 5; 6; 7]; [23; 5; 6; 12; 7; 8; 17];
+ [24; 5; 6; 12; 8; 17]; [25; 5; 6; 8; 9]; [26; 5; 6; 8];
+ [27; 5; 12; 7; 8; 9]; [21; 5; 12; 7; 8]; [22; 5; 7]; [28; 5];
+ [29; 5; 8; 9]; [28; 5; 9]; [15; 6; 12; 7; 8]; [30; 6; 7; 8];
+ [31; 6; 12; 9]; [32; 6; 9]; [30; 6; 8]; [34; 6; 12; 7; 8];
+ [35; 6; 12; 7]; [36; 6; 7; 8]; [37; 6; 8]; [38; 6; 7; 9];
+ [39; 6; 9]; [40; 12; 7; 8; 17]; [41; 12; 8; 17];
+ [42; 7; 8; 17]; [43; 7; 17]; [44; 5; 6; 12; 7; 8; 9];
+ [4; 5; 12; 7; 8; 9]; [45; 5; 6; 12; 7; 8; 17];
+ [46; 5; 12; 7; 8; 17]; [36; 5; 6; 12; 7; 8];
+ [47; 5; 12; 7; 8]; [48; 5; 6; 12; 8; 17]; [42; 5; 12; 8; 17];
+ [49; 5; 6; 8; 9; 17]; [50; 5; 8; 9; 17];
+ [51; 5; 6; 12; 8; 9]; [15; 5; 6; 12; 8]; [36; 5; 6; 7; 8; 17];
+ [47; 5; 7; 8; 17]; [37; 5; 6; 8; 17]; [30; 5; 8; 17];
+ [52; 5; 6; 7; 17]; [53; 5; 6; 17]; [38; 5; 6; 7; 17];
+ [54; 5; 7; 17]; [55; 5; 6; 8; 9; 17]; [10; 5; 8; 9; 17];
+ [48; 5; 6; 8; 9; 17]; [42; 5; 8; 9; 17];
+ [56; 5; 6; 12; 7; 8; 9]; [57; 5; 6; 12; 7; 8];
+ [58; 5; 6; 12; 9]; [59; 5; 6; 12]; [44; 5; 6; 7; 8; 9];
+ [55; 5; 6; 8; 9]; [60; 5; 12; 7; 8; 9]; [51; 5; 12; 8; 9];
+ [46; 5; 7; 8; 17]; [42; 5; 8; 17]; [61; 5; 7; 17];
+ [43; 5; 17]; [30; 5; 8]; [4; 5; 7; 8; 9]; [62; 5; 7; 9];
+ [47; 5; 7; 8]; [54; 5; 7]; [63; 5; 6; 12; 8; 9; 17];
+ [64; 5; 12; 8; 9; 17]; [65; 5; 6; 12; 7; 8];
+ [66; 5; 12; 7; 8]; [25; 5; 6; 7; 8; 9]; [26; 5; 6; 7; 8];
+ [27; 5; 6; 7; 8; 9]; [67; 5; 6; 7; 9]; [68; 5; 6; 8; 9];
+ [29; 5; 6; 8]; [65; 5; 6; 12; 7; 8; 17];
+ [19; 5; 6; 12; 8; 17]; [69; 5; 6; 7; 8; 9; 17];
+ [70; 5; 6; 7; 9; 17]; [71; 5; 6; 7; 8; 17]; [72; 5; 6; 7; 17];
+ [73; 5; 6; 7; 8]; [57; 5; 6; 7]; [74; 5; 7; 17]; [75; 5; 17];
+ [68; 5; 8; 9]; [76; 5; 9]; [77; 6; 12; 7; 9]; [62; 6; 7; 9];
+ [14; 6; 12; 7; 8]; [47; 6; 7; 8]; [78; 6; 12; 7; 8; 9];
+ [11; 6; 12; 8; 9]; [79; 6; 7; 8; 9; 17]; [80; 6; 8; 9; 17];
+ [54; 6; 7; 9]; [81; 6; 12; 7; 9; 17]; [79; 6; 7; 9; 17];
+ [36; 6; 12; 7; 8]; [38; 6; 12; 7]; [82; 6; 12; 9; 17];
+ [80; 6; 9; 17]; [83; 6; 12; 9]; [84; 6; 9]; [38; 6; 7];
+ [47; 12; 7; 8]; [30; 12; 8]; [54; 12; 7]; [46; 12; 7; 8; 17];
+ [42; 12; 8; 17]; [14; 12; 7; 8; 17]; [15; 12; 8; 17];
+ [62; 12; 7; 9]; [32; 12; 9]; [60; 12; 7; 8; 9];
+ [77; 12; 7; 9]; [51; 12; 8; 9]; [31; 12; 9]; [46; 7; 8; 17];
+ [61; 7; 17]; [10; 8; 9]; [30; 8]; [85; 9; 17]; [43; 17];
+ [32; 9]; [63; 5; 6; 12; 7; 8; 9; 17];
+ [64; 5; 12; 7; 8; 9; 17]; [16; 5; 6; 12; 7; 8; 17];
+ [18; 5; 12; 7; 8; 17]; [34; 5; 6; 12; 7; 8];
+ [86; 5; 6; 7; 9]; [84; 5; 6; 9]; [39; 5; 6; 17];
+ [45; 5; 6; 7; 8; 17]; [48; 5; 6; 8; 17];
+ [70; 5; 6; 12; 7; 9; 17]; [72; 5; 6; 12; 7; 17];
+ [70; 5; 6; 12; 7; 8; 9; 17]; [72; 5; 6; 12; 7; 8; 17];
+ [87; 5; 6; 12; 9; 17]; [88; 5; 6; 12; 17]; [89; 5; 6; 12; 9];
+ [90; 5; 6; 12]; [91; 5; 6; 12; 7; 9; 17];
+ [92; 5; 6; 12; 7; 17]; [93; 5; 12; 7; 8]; [94; 5; 12; 8];
+ [10; 5; 8; 9]; [32; 5; 9]; [71; 5; 6; 12; 7; 8; 17];
+ [95; 5; 12; 7; 8; 17]; [96; 5; 6; 12; 7; 8; 9];
+ [73; 5; 6; 12; 7; 8]; [97; 5; 12; 7; 8; 9];
+ [98; 5; 6; 12; 8; 9]; [99; 5; 12; 8; 9];
+ [100; 5; 12; 7; 8; 17]; [101; 5; 12; 8; 17];
+ [102; 5; 6; 7; 8; 9; 17]; [103; 5; 6; 7; 9; 17];
+ [95; 5; 6; 7; 8; 17]; [74; 5; 6; 7; 17]; [96; 5; 6; 7; 8; 9];
+ [56; 5; 6; 7; 9]; [95; 5; 7; 8; 17]; [18; 5; 8; 17];
+ [21; 5; 7; 8]; [29; 5; 8]; [38; 6; 7; 8; 9]; [39; 6; 8; 9];
+ [44; 6; 12; 7; 8; 9]; [55; 6; 12; 8; 9];
+ [104; 6; 12; 7; 8; 9; 17]; [105; 6; 12; 8; 9; 17];
+ [40; 6; 12; 7; 8; 17]; [46; 6; 7; 8; 17]; [35; 6; 12; 7; 9];
+ [106; 6; 12; 9]; [107; 6; 12; 7; 9; 17]; [108; 6; 7; 9; 17];
+ [109; 6; 12; 9; 17]; [85; 6; 9; 17]; [41; 6; 12; 8; 17];
+ [42; 6; 8; 17]; [110; 6; 12; 17]; [43; 6; 17]; [15; 6; 12; 8];
+ [111; 6; 12]; [112; 6; 12; 7; 8; 9]; [83; 6; 12; 8; 9];
+ [113; 6; 12; 7; 8; 9; 17]; [114; 6; 12; 8; 9; 17];
+ [86; 6; 7; 8; 9]; [84; 6; 8; 9]; [44; 6; 7; 8; 9];
+ [55; 6; 8; 9]; [13; 6; 12; 8]; [106; 6; 12]; [39; 6];
+ [112; 6; 12; 7; 9]; [86; 6; 7; 9]; [4; 12; 7; 8; 9];
+ [10; 12; 8; 9]; [14; 12; 7; 8]; [15; 12; 8]; [115; 12; 7];
+ [111; 12]; [116; 7; 8; 9; 17]; [108; 7; 9; 17]; [50; 8; 9; 17];
+ [42; 8; 17]; [117; 5; 6; 12; 7; 9]; [118; 5; 6; 12; 9];
+ [69; 5; 6; 12; 7; 8; 9; 17]; [102; 5; 12; 7; 8; 9; 17];
+ [104; 5; 6; 12; 7; 8; 17]; [40; 5; 12; 7; 8; 17];
+ [105; 5; 6; 12; 8; 17]; [41; 5; 12; 8; 17];
+ [119; 5; 6; 12; 7; 8; 9]; [36; 5; 6; 7; 8]; [37; 5; 6; 8];
+ [38; 5; 6; 7]; [39; 5; 6]; [79; 5; 6; 7; 9; 17];
+ [108; 5; 7; 9; 17]; [80; 5; 6; 9; 17]; [85; 5; 9; 17];
+ [120; 5; 6; 12; 8; 9; 17]; [121; 5; 6; 12; 8; 17];
+ [56; 5; 6; 12; 7; 9]; [57; 5; 6; 12; 7];
+ [120; 5; 6; 12; 9; 17]; [121; 5; 6; 12; 17];
+ [122; 5; 6; 12; 7; 9]; [123; 5; 6; 12; 7]; [93; 5; 12; 7];
+ [94; 5; 12]; [87; 5; 6; 9; 17]; [88; 5; 6; 17];
+ [63; 5; 6; 8; 9; 17]; [16; 5; 6; 8; 17];
+ [102; 5; 7; 8; 9; 17]; [64; 5; 8; 9; 17]; [103; 5; 7; 9; 17];
+ [124; 5; 9; 17]; [27; 5; 7; 8; 9]; [67; 5; 7; 9];
+ [125; 6; 12; 7; 8; 9; 17]; [49; 6; 12; 8; 9; 17];
+ [115; 6; 12; 7]; [54; 6; 7]; [34; 6; 12; 7; 8; 9];
+ [13; 6; 12; 8; 9]; [126; 6; 12; 7; 9; 17]; [127; 6; 12; 9; 17];
+ [81; 6; 12; 7; 8; 9; 17]; [82; 6; 12; 8; 9; 17];
+ [125; 6; 7; 8; 9; 17]; [49; 6; 8; 9; 17];
+ [104; 6; 12; 7; 8; 17]; [45; 6; 7; 8; 17]; [105; 6; 12; 8; 17];
+ [48; 6; 8; 17]; [127; 6; 12; 17]; [53; 6; 17];
+ [107; 12; 7; 9; 17]; [109; 12; 9; 17]; [128; 12; 7; 8; 9; 17];
+ [129; 12; 8; 9; 17]; [4; 7; 8; 9]; [62; 7; 9]; [47; 7; 8];
+ [54; 7]; [93; 5; 6; 12; 7]; [94; 5; 6; 12];
+ [25; 5; 6; 12; 8; 9]; [68; 5; 12; 8; 9]; [26; 5; 6; 12; 8];
+ [29; 5; 12; 8]; [130; 5; 6; 12; 7; 8; 9; 17];
+ [131; 5; 12; 7; 8; 9; 17]; [132; 5; 6; 12; 8; 9; 17];
+ [133; 5; 12; 8; 9; 17]; [125; 5; 6; 7; 8; 9; 17];
+ [116; 5; 7; 8; 9; 17]; [89; 5; 6; 12; 8; 9];
+ [90; 5; 6; 12; 8]; [117; 5; 12; 7; 9]; [118; 5; 12; 9];
+ [58; 5; 6; 9]; [59; 5; 6]; [53; 6; 9; 17]; [126; 6; 12; 7; 17];
+ [134; 12; 7; 17]; [110; 12; 17]; [135; 5; 12; 7; 17];
+ [136; 5; 12; 17]; [52; 6; 7; 17]; [137; 5; 12; 7; 9; 17];
+ [138; 5; 12; 9; 17] ] in
+ test_nbr_clauses 256 t;
+
+ (* Example from SL6 conversion *)
+ let s =
+ [[2; -1]; [-3];
+ [2; -1]; [-7; -6; -5; -4]; [-11; -10; -9; -4; -8]; [-12; -10; -9; -8];
+ [-13; -6; -5]; [-15; -6; -14; -5; -9; -4; -8]; [-16; -10; -8];
+ [-17; -14; -10; -8]; [-18; -10; -4; -8]; [-19; -14; -5; -9; -4; -8];
+ [-20; -14; -10; -5]; [-21; -6; -14; -10; -5;-8]; [-22;-6;-5;-9;-4;-8];
+ [-23; -6; -4]; [-24; -6; -14; -5; -4]; [-25; -14; -10; -9; -8];
+ [-26; -14; -5; -9; -8]; [-27; -10; -9; -4]; [-28; -6; -10; -4];
+ [-29; -6; -5; -9; -8]; [-30; -6; -14; -5; -9; -8]; [-31;-6;-5;-9;-4];
+ [-32; -10; -4]; [-33; -14; -10]; [-34;-6;-14;-9;-8]; [-35;-10;-5;-8];
+ [-36; -10; -5; -4]; [-37; -14; -10; -9; -4]; [-38; -5; -9; -4];
+ [-39; -6; -14; -5; -9]; [-40; -6; -14; -5]; [-41; -10; -5; -4; -8];
+ [-42; -6; -14; -5; -8]; [-43; -6; -14; -5;-4;-8]; [-44;-14;-9;-4;-8];
+ [-45; -6; -14; -10; -5; -4]; [-46; -6; -10; -9; -8]; [-47; -4];
+ [-48; -6; -9; -4]; [-49; -6; -10; -9; -4; -8]; [-50; -6; -9; -4; -8];
+ [-51; -6; -10; -5; -4]; [-52; -6; -10; -5; -8]; [-53; -14; -5; -9; -4];
+ [-54; -14; -5; -9]; [-55; -14; -5]; [-56; -14; -10; -5; -9; -8];
+ [-57; -6; -10; -5; -9; -8]; [-58;-14;-10;-9;-4;-8]; [-59;-6;-14;-4];
+ [-60; -6; -5; -8]; [-61; -14; -9; -8]; [-62;-14;-9;-4]; [-63;-9;-4];
+ [-64; -6; -5; -9]; [-65; -6; -4; -8]; [-66; -6; -10; -5; -4; -8];
+ [-67; -6; -14; -9]; [-68; -14; -9]; [-69; -14]; [-70;-6;-10;-9;-4];
+ [-71;-14;-5;-4]; [-72;-14;-10;-5;-8]; [-73;-6;-10;-5]; [-74;-6;-10];
+ [-75; -6; -5; -4; -8]; [-76;-5;-4;-8]; [-77;-5;-4]; [-78;-6;-10;-9];
+ [-79; -10; -9]; [-80; -10; -5]; [-81; -6; -10; -5; -9; -4; -8];
+ [-82; -14; -10; -4]; [-83; -14; -10; -5; -4; -8]; [-84; -6; -10; -8];
+ [-85; -6; -9; -8]; [-86; -6; -9]; [-87; -14; -4]; [-88;-14;-5;-4;-8];
+ [-89; -14; -4; -8]; [-90; -14; -5; -8]; [-91; -14; -10; -9];
+ [-92; -6; -14; -10; -9; -8]; [-93; -6; -14; -9; -4; -8]; [-94; -9];
+ [-95; -9; -8]; [-96; -5]; [-97;-14;-10;-5;-4]; [-98;-14;-10;-5;-9;-4];
+ [-99; -14; -8]; [-100; -6; -10; -5; -9; -4]; [-101; -6; -10; -5; -9];
+ [-102; -14; -10; -5; -9]; [-103; -10; -5; -9; -4]; [-104; -10; -5; -9];
+ [-105; -6; -14; -8]; [-106; -14; -10; -4; -8]; [-107;-6;-14;-10;-8];
+ [-108; -6; -14; -4; -8]; [-109;-6;-10;-4;-8]; [-110;-6;-14;-10;-4;-8];
+ [-111; -10; -5; -9; -8]; [-112; -5; -9]; [-113; -5; -9; -8];
+ [-114; -6; -14; -9; -4]; [-115;-6;-14;-10;-4]; [-116;-6;-14;-10;-9;-4];
+ [-117; -6; -14; -10; -9]; [-118; -6; -8]; [-119; -10]; [-120; -5; -8];
+ [-121; -6; -14; -5; -9; -4]; [-122; -6; -14; -10; -9; -4; -8];
+ [-123; -6; -14; -10; -5; -4; -8]; [-124; -6; -14; -10; -5; -9; -8];
+ [-125; -14; -10; -5; -9; -4; -8]; [-126; -10; -5; -9; -4; -8];
+ [-127; -5; -9; -4; -8]; [-128; -9; -4; -8]; [-129; -4; -8]; [-130;-8];
+ [-131]; [-132; -6]; [-133; -6; -14]; [-134; -6; -14; -10];
+ [-135; -6; -14; -10; -5]; [-136; -6; -14; -10; -5; -9];
+ [-137;-6;-14;-10;-5;-9;-4]; [-138;-6;-14;-10;-5;-9;-4;-8]; [-139] ] in
+ test_nbr_clauses 277 s;
+ );
+]
+
+
+let exec = Aux.run_test_if_target "SatTest" tests
Deleted: trunk/Toss/Formula/Sat/Test.ml
===================================================================
--- trunk/Toss/Formula/Sat/Test.ml 2011-04-17 01:25:17 UTC (rev 1415)
+++ trunk/Toss/Formula/Sat/Test.ml 2011-04-17 14:05:28 UTC (rev 1416)
@@ -1,203 +0,0 @@
-(* Simple MiniSAT cnf-dnf tests. *)
-
-let test phi =
- print_endline ("DNF: " ^ Sat.dnf_str phi);
- print_endline ("CNF: " ^ Sat.cnf_str (Sat.convert phi));
- print_endline ""
-;;
-
-Sat.set_debug_level 0 ;;
-
-test [[1; 2]; [3]];;
-
-test [[1; 2]; [-1; -2]];;
-
-test [[1; 2; 3]];;
-
-test [[1; -1]];;
-
-test [[1]; [-1; 2]; [-2; 3]; [-3]];;
-
-test [[1]; [-1; 2]; [-2; 3]; [-3; 4]];;
-
-test [[1; 2]; [3; 4]];;
-
-test [[7]; [8]; [1; 2]; [3; 4]; [5; 6]; [9; 10]; [11; 12]; [13; 14]; [15;16]];;
-
-let rec list n = if n < 3 then [n] else n :: list (n-1) ;;
-
-(* Nice multiply-out test. *)
-let p n = test [-1 :: (list n); [1; -(n+1)]; [1; -(n+2)]; [-1; n+1; n+2]] ;;
-p 30 ;;
-
-let q n = test [-1 :: (List.map (fun i -> (-i)) (list n));
- [1; -(n+1)]; [1; -(n+2)]; [-1; n+1; n+2]] ;;
-q 30 ;;
-
-test [[1]; list 800];;
-
-
-(* A more complex example from TNF calculations; all literals positive. *)
-let t () = test [[1]; [33]; [2; 3]; [4; 5; 6; 7; 8; 9]; [10; 5; 6; 8; 9];
- [11; 5; 6; 12; 8; 9]; [13; 5; 6; 12; 8]; [14; 5; 12; 7; 8];
- [15; 5; 12; 8]; [16; 5; 6; 12; 8; 17]; [18; 5; 12; 8; 17];
- [19; 5; 6; 12; 8]; [20; 5; 12; 8]; [21; 5; 6; 7; 8];
- [22; 5; 6; 7]; [23; 5; 6; 12; 7; 8; 17];
- [24; 5; 6; 12; 8; 17]; [25; 5; 6; 8; 9]; [26; 5; 6; 8];
- [27; 5; 12; 7; 8; 9]; [21; 5; 12; 7; 8]; [22; 5; 7]; [28; 5];
- [29; 5; 8; 9]; [28; 5; 9]; [15; 6; 12; 7; 8]; [30; 6; 7; 8];
- [31; 6; 12; 9]; [32; 6; 9]; [30; 6; 8]; [34; 6; 12; 7; 8];
- [35; 6; 12; 7]; [36; 6; 7; 8]; [37; 6; 8]; [38; 6; 7; 9];
- [39; 6; 9]; [40; 12; 7; 8; 17]; [41; 12; 8; 17];
- [42; 7; 8; 17]; [43; 7; 17]; [44; 5; 6; 12; 7; 8; 9];
- [4; 5; 12; 7; 8; 9]; [45; 5; 6; 12; 7; 8; 17];
- [46; 5; 12; 7; 8; 17]; [36; 5; 6; 12; 7; 8];
- [47; 5; 12; 7; 8]; [48; 5; 6; 12; 8; 17]; [42; 5; 12; 8; 17];
- [49; 5; 6; 8; 9; 17]; [50; 5; 8; 9; 17];
- [51; 5; 6; 12; 8; 9]; [15; 5; 6; 12; 8]; [36; 5; 6; 7; 8; 17];
- [47; 5; 7; 8; 17]; [37; 5; 6; 8; 17]; [30; 5; 8; 17];
- [52; 5; 6; 7; 17]; [53; 5; 6; 17]; [38; 5; 6; 7; 17];
- [54; 5; 7; 17]; [55; 5; 6; 8; 9; 17]; [10; 5; 8; 9; 17];
- [48; 5; 6; 8; 9; 17]; [42; 5; 8; 9; 17];
- [56; 5; 6; 12; 7; 8; 9]; [57; 5; 6; 12; 7; 8];
- [58; 5; 6; 12; 9]; [59; 5; 6; 12]; [44; 5; 6; 7; 8; 9];
- [55; 5; 6; 8; 9]; [60; 5; 12; 7; 8; 9]; [51; 5; 12; 8; 9];
- [46; 5; 7; 8; 17]; [42; 5; 8; 17]; [61; 5; 7; 17];
- [43; 5; 17]; [30; 5; 8]; [4; 5; 7; 8; 9]; [62; 5; 7; 9];
- [47; 5; 7; 8]; [54; 5; 7]; [63; 5; 6; 12; 8; 9; 17];
- [64; 5; 12; 8; 9; 17]; [65; 5; 6; 12; 7; 8];
- [66; 5; 12; 7; 8]; [25; 5; 6; 7; 8; 9]; [26; 5; 6; 7; 8];
- [27; 5; 6; 7; 8; 9]; [67; 5; 6; 7; 9]; [68; 5; 6; 8; 9];
- [29; 5; 6; 8]; [65; 5; 6; 12; 7; 8; 17];
- [19; 5; 6; 12; 8; 17]; [69; 5; 6; 7; 8; 9; 17];
- [70; 5; 6; 7; 9; 17]; [71; 5; 6; 7; 8; 17]; [72; 5; 6; 7; 17];
- [73; 5; 6; 7; 8]; [57; 5; 6; 7]; [74; 5; 7; 17]; [75; 5; 17];
- [68; 5; 8; 9]; [76; 5; 9]; [77; 6; 12; 7; 9]; [62; 6; 7; 9];
- [14; 6; 12; 7; 8]; [47; 6; 7; 8]; [78; 6; 12; 7; 8; 9];
- [11; 6; 12; 8; 9]; [79; 6; 7; 8; 9; 17]; [80; 6; 8; 9; 17];
- [54; 6; 7; 9]; [81; 6; 12; 7; 9; 17]; [79; 6; 7; 9; 17];
- [36; 6; 12; 7; 8]; [38; 6; 12; 7]; [82; 6; 12; 9; 17];
- [80; 6; 9; 17]; [83; 6; 12; 9]; [84; 6; 9]; [38; 6; 7];
- [47; 12; 7; 8]; [30; 12; 8]; [54; 12; 7]; [46; 12; 7; 8; 17];
- [42; 12; 8; 17]; [14; 12; 7; 8; 17]; [15; 12; 8; 17];
- [62; 12; 7; 9]; [32; 12; 9]; [60; 12; 7; 8; 9];
- [77; 12; 7; 9]; [51; 12; 8; 9]; [31; 12; 9]; [46; 7; 8; 17];
- [61; 7; 17]; [10; 8; 9]; [30; 8]; [85; 9; 17]; [43; 17];
- [32; 9]; [63; 5; 6; 12; 7; 8; 9; 17];
- [64; 5; 12; 7; 8; 9; 17]; [16; 5; 6; 12; 7; 8; 17];
- [18; 5; 12; 7; 8; 17]; [34; 5; 6; 12; 7; 8];
- [86; 5; 6; 7; 9]; [84; 5; 6; 9]; [39; 5; 6; 17];
- [45; 5; 6; 7; 8; 17]; [48; 5; 6; 8; 17];
- [70; 5; 6; 12; 7; 9; 17]; [72; 5; 6; 12; 7; 17];
- [70; 5; 6; 12; 7; 8; 9; 17]; [72; 5; 6; 12; 7; 8; 17];
- [87; 5; 6; 12; 9; 17]; [88; 5; 6; 12; 17]; [89; 5; 6; 12; 9];
- [90; 5; 6; 12]; [91; 5; 6; 12; 7; 9; 17];
- [92; 5; 6; 12; 7; 17]; [93; 5; 12; 7; 8]; [94; 5; 12; 8];
- [10; 5; 8; 9]; [32; 5; 9]; [71; 5; 6; 12; 7; 8; 17];
- [95; 5; 12; 7; 8; 17]; [96; 5; 6; 12; 7; 8; 9];
- [73; 5; 6; 12; 7; 8]; [97; 5; 12; 7; 8; 9];
- [98; 5; 6; 12; 8; 9]; [99; 5; 12; 8; 9];
- [100; 5; 12; 7; 8; 17]; [101; 5; 12; 8; 17];
- [102; 5; 6; 7; 8; 9; 17]; [103; 5; 6; 7; 9; 17];
- [95; 5; 6; 7; 8; 17]; [74; 5; 6; 7; 17]; [96; 5; 6; 7; 8; 9];
- [56; 5; 6; 7; 9]; [95; 5; 7; 8; 17]; [18; 5; 8; 17];
- [21; 5; 7; 8]; [29; 5; 8]; [38; 6; 7; 8; 9]; [39; 6; 8; 9];
- [44; 6; 12; 7; 8; 9]; [55; 6; 12; 8; 9];
- [104; 6; 12; 7; 8; 9; 17]; [105; 6; 12; 8; 9; 17];
- [40; 6; 12; 7; 8; 17]; [46; 6; 7; 8; 17]; [35; 6; 12; 7; 9];
- [106; 6; 12; 9]; [107; 6; 12; 7; 9; 17]; [108; 6; 7; 9; 17];
- [109; 6; 12; 9; 17]; [85; 6; 9; 17]; [41; 6; 12; 8; 17];
- [42; 6; 8; 17]; [110; 6; 12; 17]; [43; 6; 17]; [15; 6; 12; 8];
- [111; 6; 12]; [112; 6; 12; 7; 8; 9]; [83; 6; 12; 8; 9];
- [113; 6; 12; 7; 8; 9; 17]; [114; 6; 12; 8; 9; 17];
- [86; 6; 7; 8; 9]; [84; 6; 8; 9]; [44; 6; 7; 8; 9];
- [55; 6; 8; 9]; [13; 6; 12; 8]; [106; 6; 12]; [39; 6];
- [112; 6; 12; 7; 9]; [86; 6; 7; 9]; [4; 12; 7; 8; 9];
- [10; 12; 8; 9]; [14; 12; 7; 8]; [15; 12; 8]; [115; 12; 7];
- [111; 12]; [116; 7; 8; 9; 17]; [108; 7; 9; 17]; [50; 8; 9; 17];
- [42; 8; 17]; [117; 5; 6; 12; 7; 9]; [118; 5; 6; 12; 9];
- [69; 5; 6; 12; 7; 8; 9; 17]; [102; 5; 12; 7; 8; 9; 17];
- [104; 5; 6; 12; 7; 8; 17]; [40; 5; 12; 7; 8; 17];
- [105; 5; 6; 12; 8; 17]; [41; 5; 12; 8; 17];
- [119; 5; 6; 12; 7; 8; 9]; [36; 5; 6; 7; 8]; [37; 5; 6; 8];
- [38; 5; 6; 7]; [39; 5; 6]; [79; 5; 6; 7; 9; 17];
- [108; 5; 7; 9; 17]; [80; 5; 6; 9; 17]; [85; 5; 9; 17];
- [120; 5; 6; 12; 8; 9; 17]; [121; 5; 6; 12; 8; 17];
- [56; 5; 6; 12; 7; 9]; [57; 5; 6; 12; 7];
- [120; 5; 6; 12; 9; 17]; [121; 5; 6; 12; 17];
- [122; 5; 6; 12; 7; 9]; [123; 5; 6; 12; 7]; [93; 5; 12; 7];
- [94; 5; 12]; [87; 5; 6; 9; 17]; [88; 5; 6; 17];
- [63; 5; 6; 8; 9; 17]; [16; 5; 6; 8; 17];
- [102; 5; 7; 8; 9; 17]; [64; 5; 8; 9; 17]; [103; 5; 7; 9; 17];
- [124; 5; 9; 17]; [27; 5; 7; 8; 9]; [67; 5; 7; 9];
- [125; 6; 12; 7; 8; 9; 17]; [49; 6; 12; 8; 9; 17];
- [115; 6; 12; 7]; [54; 6; 7]; [34; 6; 12; 7; 8; 9];
- [13; 6; 12; 8; 9]; [126; 6; 12; 7; 9; 17]; [127; 6; 12; 9; 17];
- [81; 6; 12; 7; 8; 9; 17]; [82; 6; 12; 8; 9; 17];
- [125; 6; 7; 8; 9; 17]; [49; 6; 8; 9; 17];
- [104; 6; 12; 7; 8; 17]; [45; 6; 7; 8; 17]; [105; 6; 12; 8; 17];
- [48; 6; 8; 17]; [127; 6; 12; 17]; [53; 6; 17];
- [107; 12; 7; 9; 17]; [109; 12; 9; 17]; [128; 12; 7; 8; 9; 17];
- [129; 12; 8; 9; 17]; [4; 7; 8; 9]; [62; 7; 9]; [47; 7; 8];
- [54; 7]; [93; 5; 6; 12; 7]; [94; 5; 6; 12];
- [25; 5; 6; 12; 8; 9]; [68; 5; 12; 8; 9]; [26; 5; 6; 12; 8];
- [29; 5; 12; 8]; [130; 5; 6; 12; 7; 8; 9; 17];
- [131; 5; 12; 7; 8; 9; 17]; [132; 5; 6; 12; 8; 9; 17];
- [133; 5; 12; 8; 9; 17]; [125; 5; 6; 7; 8; 9; 17];
- [116; 5; 7; 8; 9; 17]; [89; 5; 6; 12; 8; 9];
- [90; 5; 6; 12; 8]; [117; 5; 12; 7; 9]; [118; 5; 12; 9];
- [58; 5; 6; 9]; [59; 5; 6]; [53; 6; 9; 17]; [126; 6; 12; 7; 17];
- [134; 12; 7; 17]; [110; 12; 17]; [135; 5; 12; 7; 17];
- [136; 5; 12; 17]; [52; 6; 7; 17]; [137; 5; 12; 7; 9; 17];
- [138; 5; 12; 9; 17] ];;
-
-t () ;;
-
-(* Example from SL6 conversion *)
-let s () = test [[2; -1]; [-3];
- [2; -1]; [-7; -6; -5; -4]; [-11; -10; -9; -4; -8]; [-12; -10; -9; -8];
- [-13; -6; -5]; [-15; -6; -14; -5; -9; -4; -8]; [-16; -10; -8];
- [-17; -14; -10; -8]; [-18; -10; -4; -8]; [-19; -14; -5; -9; -4; -8];
- [-20; -14; -10; -5]; [-21; -6; -14; -10; -5; -8]; [-22; -6; -5; -9; -4; -8];
- [-23; -6; -4]; [-24; -6; -14; -5; -4]; [-25; -14; -10; -9; -8];
- [-26; -14; -5; -9; -8]; [-27; -10; -9; -4]; [-28; -6; -10; -4];
- [-29; -6; -5; -9; -8]; [-30; -6; -14; -5; -9; -8]; [-31; -6; -5; -9; -4];
- [-32; -10; -4]; [-33; -14; -10]; [-34; -6; -14; -9; -8]; [-35; -10; -5; -8];
- [-36; -10; -5; -4]; [-37; -14; -10; -9; -4]; [-38; -5; -9; -4];
- [-39; -6; -14; -5; -9]; [-40; -6; -14; -5]; [-41; -10; -5; -4; -8];
- [-42; -6; -14; -5; -8]; [-43; -6; -14; -5; -4; -8]; [-44; -14; -9; -4; -8];
- [-45; -6; -14; -10; -5; -4]; [-46; -6; -10; -9; -8]; [-47; -4];
- [-48; -6; -9; -4]; [-49; -6; -10; -9; -4; -8]; [-50; -6; -9; -4; -8];
- [-51; -6; -10; -5; -4]; [-52; -6; -10; -5; -8]; [-53; -14; -5; -9; -4];
- [-54; -14; -5; -9]; [-55; -14; -5]; [-56; -14; -10; -5; -9; -8];
- [-57; -6; -10; -5; -9; -8]; [-58; -14; -10; -9; -4; -8]; [-59; -6; -14; -4];
- [-60; -6; -5; -8]; [-61; -14; -9; -8]; [-62; -14; -9; -4]; [-63; -9; -4];
- [-64; -6; -5; -9]; [-65; -6; -4; -8]; [-66; -6; -10; -5; -4; -8];
- [-67; -6; -14; -9]; [-68; -14; -9]; [-69; -14]; [-70; -6; -10; -9; -4];
- [-71; -14; -5; -4]; [-72; -14; -10; -5; -8]; [-73; -6; -10; -5]; [-74; -6;-10];
- [-75; -6; -5; -4; -8]; [-76; -5; -4; -8]; [-77; -5; -4]; [-78; -6; -10; -9];
- [-79; -10; -9]; [-80; -10; -5]; [-81; -6; -10; -5; -9; -4; -8];
- [-82; -14; -10; -4]; [-83; -14; -10; -5; -4; -8]; [-84; -6; -10; -8];
- [-85; -6; -9; -8]; [-86; -6; -9]; [-87; -14; -4]; [-88; -14; -5; -4; -8];
- [-89; -14; -4; -8]; [-90; -14; -5; -8]; [-91; -14; -10; -9];
- [-92; -6; -14; -10; -9; -8]; [-93; -6; -14; -9; -4; -8]; [-94; -9];
- [-95; -9; -8]; [-96; -5]; [-97; -14; -10; -5; -4]; [-98; -14; -10; -5; -9; -4];
- [-99; -14; -8]; [-100; -6; -10; -5; -9; -4]; [-101; -6; -10; -5; -9];
- [-102; -14; -10; -5; -9]; [-103; -10; -5; -9; -4]; [-104; -10; -5; -9];
- [-105; -6; -14; -8]; [-106; -14; -10; -4; -8]; [-107; -6; -14; -10; -8];
- [-108; -6; -14; -4; -8]; [-109; -6; -10; -4; -8]; [-110; -6; -14; -10; -4; -8];
- [-111; -10; -5; -9; -8]; [-112;...
[truncated message content] |
|
From: <luk...@us...> - 2011-04-17 01:25:25
|
Revision: 1415
http://toss.svn.sourceforge.net/toss/?rev=1415&view=rev
Author: lukaszkaiser
Date: 2011-04-17 01:25:17 +0000 (Sun, 17 Apr 2011)
Log Message:
-----------
Moving all remaining tests to OUnit, removing calls from Makefile and handling them in TossTest and TossFullTest.
Modified Paths:
--------------
trunk/Toss/Arena/Makefile
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/Makefile
trunk/Toss/GGP/Makefile
trunk/Toss/Makefile
trunk/Toss/Play/Makefile
trunk/Toss/Server/Makefile
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/Makefile
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Modified: trunk/Toss/Arena/Makefile
===================================================================
--- trunk/Toss/Arena/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Arena/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -9,7 +9,7 @@
ArenaTest:
tests:
- make -C .. Arena_tests
+ make -C .. ArenaTestsVerbose
.PHONY: clean
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/Aux.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -547,7 +547,8 @@
pr_tail f tl in
Format.fprintf f "%a%a" f_el hd pr_tail tl
-let run_test_if_target target_name tests =
+
+let run_if_target target_name f =
let file_from_path p =
String.sub p (String.rindex p '/'+1)
(String.length p - String.rindex p '/' - 1) in
@@ -555,10 +556,14 @@
let fname = file_from_path Sys.executable_name in
String.length fname >= String.length target_name &&
String.sub fname 0 (String.length target_name) = target_name in
+ if test_fname then f ()
+
+let run_test_if_target target_name tests =
+ let f () = ignore (OUnit.run_test_tt ~verbose:true tests) in
(* So that the tests are not run twice while building TossTest. *)
- if test_fname then
- ignore (OUnit.run_test_tt ~verbose:true tests)
+ run_if_target target_name f
+
let rec input_file file =
let buf = Buffer.create 256 in
(try
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/Aux.mli 2011-04-17 01:25:17 UTC (rev 1415)
@@ -279,6 +279,9 @@
string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a list -> unit
+(** Run a function if the executable name matches the given prefix. *)
+val run_if_target : string -> (unit -> unit) -> unit
+
(** Run a test suite if the executable name matches the given prefix. *)
val run_test_if_target : string -> OUnit.test -> unit
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -1,7 +1,8 @@
+open OUnit
open Formula
open BoolFormula;;
-BoolFormula.set_debug_level 2;;
+BoolFormula.set_debug_level 0;;
BoolFormula.set_simplification 6;; (* w/ resolution: 6; w/o resolution: 2 *)
BoolFormula.set_auxcnf 2;; (* Tseitin: 1 Plaisted-Greenbaum: 2 *)
@@ -13,135 +14,218 @@
FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
;;
-let test_bool_simplify form_str =
+let flat_reduce_formula form_str =
let form = formula_of_string form_str in
- print_endline ("Testing simplification of " ^ (Formula.str form));
let b_form = BoolFormula.bool_formula_of_formula form in
- print_endline (" Boolean formula: " ^ (BoolFormula.str b_form));
- let b_simplified = BoolFormula.simplify b_form in
- print_endline (" Simplified formula: " ^ (BoolFormula.str b_simplified));
-;;
-
-let test_bool_auxcnf form_str =
- let form = formula_of_string form_str in
- print_endline ("Testing auxcnf conversion of " ^ (Formula.str form));
- let b_form = BoolFormula.bool_formula_of_formula form in
- print_endline (" Boolean formula: " ^ (BoolFormula.str b_form));
- let b_reduced = BoolFormula.to_reduced_form b_form in
- print_endline (" Boolean formula with or and not: " ^ (BoolFormula.str b_reduced));
- let (_, b_auxcnf) = BoolFormula.auxcnf_of_bool_formula b_reduced in
- print_endline (" Aux CNF for boolean formula:\n " ^ (BoolFormula.str b_auxcnf));
-;;
-
-let test_bool_pg_auxcnf form_str =
- let form = formula_of_string form_str in
- print_endline ("Testing Plaisted Greenbaum auxcnf conversion of " ^ (Formula.str form));
- let b_form = BoolFormula.bool_formula_of_formula form in
- print_endline (" Boolean formula: " ^ (BoolFormula.str b_form));
- let (_, b_auxcnf) = BoolFormula.pg_auxcnf_of_bool_formula b_form in
- print_endline (" Aux CNF for boolean formula:\n " ^ (BoolFormula.str b_auxcnf));
-;;
-
-let test_flat_reduce form_str =
- let form = formula_of_string form_str in
- let b_form = BoolFormula.bool_formula_of_formula form in
let b_nnf = BoolFormula.to_nnf b_form in
let b_flat = BoolFormula.flatten_sort b_nnf in
- let b_reduced = BoolFormula.to_reduced_form b_flat in
- print_endline ("Reduced flattened NNF of:\n " ^ (BoolFormula.str b_form) ^ "\nis:");
- print_endline (" "^ (BoolFormula.str b_reduced) ^"\n");
-;;
+ BoolFormula.to_reduced_form b_flat
-let test name f print_f formula_str =
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+
+let test_formula name f print_f formula_str res_str =
let formula = formula_of_string formula_str in
- print_endline (name ^ " of:\n " ^ (Formula.str formula) ^ "\nis:");
- print_endline (" "^ (print_f (f formula) ^"\n"));
-;;
+ assert_eq_string formula_str name res_str (print_f (f formula))
-let test_bool name f print_f formula_str =
- let formula = BoolFormula.bool_formula_of_formula (formula_of_string formula_str) in
- print_endline (name ^ " of:\n " ^ (BoolFormula.str formula) ^ "\nis:");
- print_endline (" "^ (print_f (f formula) ^"\n"));
-;;
+let test_bool_formula name f print_f formula_str res_str =
+ let formula = formula_of_string formula_str in
+ let bool_formula = BoolFormula.bool_formula_of_formula formula in
+ let arg_str = (BoolFormula.str bool_formula) ^ " from " ^ formula_str in
+ assert_eq_string arg_str name res_str (print_f (f bool_formula))
-let test_cnf_bool = test "CNF" BoolFormula.formula_to_cnf Formula.str ;;
-let test_nnf = test_bool "NNF" BoolFormula.to_nnf BoolFormula.str ;;
-let test_flatten = test_bool "Flatten-Sort" BoolFormula.flatten_sort BoolFormula.str ;;
-let test_reduce = test_bool "Reduced form" BoolFormula.to_reduced_form BoolFormula.str ;;
+let tests = "BoolFormula" >::: [
+ "basic auxcnf and cnf" >::
+ (fun () ->
+ let test_bool_auxcnf form_str b_form_s b_reduced_s b_auxcnf_s =
+ let eq_s = assert_eq_string form_str in
+ let form = formula_of_string form_str in
+ let b_form = BoolFormula.bool_formula_of_formula form in
+ eq_s "Boolean formula" b_form_s (BoolFormula.str b_form);
+ let b_reduced = BoolFormula.to_reduced_form b_form in
+ eq_s "Boolean formula with or and not"
+ b_reduced_s (BoolFormula.str b_reduced);
+ let (_, b_auxcnf) = BoolFormula.auxcnf_of_bool_formula b_reduced in
+ eq_s "Aux CNF for boolean formula"
+ b_auxcnf_s (BoolFormula.str b_auxcnf) in
+ let test_cnf_bool =
+ test_formula "CNF" BoolFormula.formula_to_cnf Formula.str in
-test_bool_auxcnf "P(x)" ;;
-test_cnf_bool "P(x)" ;;
+ test_bool_auxcnf "P(x)" "1" "1" "-1";
+ test_cnf_bool "P(x)" "P(x)";
-test_bool_auxcnf "not P(x)" ;;
-test_cnf_bool "not P(x)" ;;
+ test_bool_auxcnf "not P(x)" "-1" "-1" "1";
+ test_cnf_bool "not P(x)" "(not P(x))";
-test_bool_auxcnf "P(x) and (P(y) or P(z))" ;;
-test_cnf_bool "P(x) and (P(y) or P(z))" ;;
+ test_bool_auxcnf "P(x) and (P(y) or P(z))"
+ "((3 or 2) and 1)" "(not (-1 or (not (2 or 3))))"
+ ("(5 and (-4 or -1 or -5) and (5 or 4) and (5 or 1) and " ^
+ "(3 or 2 or -4) and (4 or -3) and (4 or -2))");
+ test_cnf_bool "P(x) and (P(y) or P(z))" "((P(z) or P(y)) and P(x))";
-test_bool_pg_auxcnf "P(x) and (P(y) or P(z))" ;;
-test_cnf_bool "P(x) and (P(y) or P(z))" ;;
-test_bool_pg_auxcnf "(P(x) and P(y)) or P(z)" ;;
-test_cnf_bool "(P(x) and P(y)) or P(z)" ;;
+ test_bool_auxcnf "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
+ "(((5 and 4) or -3) or (not (2 and 1)))"
+ "((-1 or -2) or (-3 or (not (-4 or -5))))"
+ ("(-9 and (7 or 8 or -9) and (9 or -7) and (9 or -8) and " ^
+ "(-2 or -1 or -8) and (8 or 2) and (8 or 1) and (-6 or -3 or -7)" ^
+ " and (7 or 6) and (7 or 3) and (-5 or -4 or -6) and (6 or 5) " ^
+ "and (6 or 4))");
+ test_cnf_bool "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
+ ("((D(y) or (not P(x)) or (not B(x)) or (not A(x))) and " ^
+ "(C(x) or (not P(x)) or (not B(x)) or (not A(x))))");
+
+ test_bool_auxcnf "(P(x) and P(y)) or (not P(x) and not P(y))"
+ "((-2 and -1) or (2 and 1))" "((not (-1 or -2)) or (not (1 or 2)))"
+ ("(-5 and (-3 or -4 or -5) and (5 or 3) and (5 or 4) and " ^
+ "(-2 or -1 or -4) and (4 or 2) and (4 or 1) and (2 or 1 or -3) " ^
+ "and (3 or -2) and (3 or -1))");
+ test_cnf_bool "(P(x) and P(y)) or (not P(x) and not P(y))"
+ "((P(y) or (not P(x))) and ((not P(y)) or P(x)))";
+ );
-test_bool_pg_auxcnf "(not (not P(x) or not P(y))) or P(z)" ;;
-test_cnf_bool "(not (not P(x) or not P(y))) or P(z)" ;;
+ "Plaisted Greenbaum auxcnf and cnf" >::
+ (fun () ->
+ let test_bool_pg_auxcnf form_str b_form_s b_auxcnf_s =
+ let eq_s = assert_eq_string form_str in
+ let form = formula_of_string form_str in
+ let b_form = BoolFormula.bool_formula_of_formula form in
+ eq_s "Boolean formula" b_form_s (BoolFormula.str b_form);
+ let (_, b_auxcnf) = BoolFormula.pg_auxcnf_of_bool_formula b_form in
+ eq_s "PG Aux CNF for boolean formula"
+ b_auxcnf_s (BoolFormula.str b_auxcnf) in
+ let test_cnf_bool =
+ test_formula "CNF" BoolFormula.formula_to_cnf Formula.str in
+ test_bool_pg_auxcnf "P(x) and (P(y) or P(z))" "((3 or 2) and 1)"
+ "(-5 and (-1 or -4 or 5) and (4 or -3) and (4 or -2))";
+ test_cnf_bool "P(x) and (P(y) or P(z))" "((P(z) or P(y)) and P(x))";
-test_cnf_bool "(P(x) and P(a)) or (P(x) and P(b)) or (P(x) and P(c)) or (P(x) and P(d))
- or (not P(x) and Q(a)) or (not P(x) and Q(b)) or (not P(x) and Q(c))" ;;
+ test_bool_pg_auxcnf "(P(x) and P(y)) or P(z)" "(3 or (2 and 1))"
+ "(-5 and (5 or -3) and (5 or -4) and (-1 or -2 or 4))";
+ test_cnf_bool "(P(x) and P(y)) or P(z)"
+ "((P(z) or P(y)) and (P(z) or P(x)))";
-let rec seq acc ?(start=0) stop =
- if stop < start then []
- else if stop = start then start :: acc
- else seq (stop :: acc) ~start:start (stop-1)
-;;
+ test_bool_pg_auxcnf "(not (not P(x) or not P(y))) or P(z)"
+ "(3 or (not (-2 or -1)))"
+ "(-5 and (5 or -3) and (5 or 4) and (-2 or -1 or -4))";
+ test_cnf_bool "(not (not P(x) or not P(y))) or P(z)"
+ "((P(z) or P(y)) and (P(z) or P(x)))";
+ );
-let varlist = seq [] ~start:0 5000 ;;
-let negvarlist = seq [] ~start:10000 15000 ;;
+ "nnf, flat, reduce, flat-reduce" >::
+ (fun () ->
+ let test_flat_reduce form_str b_reduced_s =
+ let eq_s = assert_eq_string form_str in
+ let b_reduced = flat_reduce_formula form_str in
+ eq_s "Reduced flattened NNF" b_reduced_s (BoolFormula.str b_reduced) in
+ let test_nnf =
+ test_bool_formula "NNF" BoolFormula.to_nnf BoolFormula.str in
+ let test_flatten = test_bool_formula "Flatten-Sort"
+ BoolFormula.flatten_sort BoolFormula.str in
+ let test_reduce = test_bool_formula "Reduced form"
+ BoolFormula.to_reduced_form BoolFormula.str in
-let long_formula = String.concat " or " (List.map (fun i -> "(Q(x) and P(x" ^ string_of_int i ^ "))") varlist) ;;
-let neg_long_formula = String.concat " or " (List.map (fun i -> "(not Q(x) and P(x" ^ string_of_int i ^ "))") negvarlist) ;;
-(*
-test_cnf_bool (long_formula ^ " or " ^ neg_long_formula) ;;
-*)
+ test_nnf "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "((4 or 3) or (-2 or (-1 or -1)))";
+ test_flatten "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(3 or 4 or (not (1 and 1 and 2)))";
+ test_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(((-1 or -1) or -2) or (3 or 4))";
+ test_flat_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(4 or 3 or -2 or -1 or -1)";
+ );
-(*
-test_bool_auxcnf "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))" ;;
-test_cnf_bool "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))" ;;
+ "cnf, flat-reduced cnf-list" >::
+ (fun () ->
+ let test_flat_reduced_cnf_list form_str cnf_list_s =
+ let eq_s = assert_eq_string form_str in
+ let b_reduced = flat_reduce_formula form_str in
+ let cnflist = BoolFormula.convert b_reduced in
+ let print_ors l = String.concat " | " (List.map string_of_int l) in
+ let print_cnf cnfl = String.concat " & " (List.map print_ors cnfl) in
+ eq_s "CNF-List" cnf_list_s (print_cnf cnflist) in
+ let test_cnf_bool =
+ test_formula "CNF" BoolFormula.formula_to_cnf Formula.str in
-test_bool_auxcnf "(P(x) and P(y)) or (not P(x) and not P(y))" ;;
-test_cnf_bool "(P(x) and P(y)) or (not P(x) and not P(y))" ;;
+ test_flat_reduced_cnf_list
+ "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "-1 | -2 | 3 | 4";
+ test_cnf_bool "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))"
+ "(Q(z) or P(y) or (not Q(x)) or (not P(x)))";
-test_cnf_bool "P(x)" ;;
+ test_flat_reduced_cnf_list
+ "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
+ "-1 | -2 | -3 | 4 & -1 | -2 | -3 | 5";
+ test_cnf_bool "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))"
+ ("((D(y) or (not P(x)) or (not B(x)) or (not A(x))) and " ^
+ "(C(x) or (not P(x)) or (not B(x)) or (not A(x))))");
-test_nnf "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ test_flat_reduced_cnf_list
+ ("(P(x) and P(a)) or (P(x) and P(b)) or (P(x) and P(c))" ^
+ " or (P(x) and P(d)) or (not P(x) and Q(a))" ^
+ " or (not P(x) and Q(b)) or (not P(x) and Q(c))")
+ "1 | 6 | 7 | 8 & -1 | 2 | 3 | 4 | 5";
+ test_cnf_bool ("(P(x) and P(a)) or (P(x) and P(b)) or (P(x) and P(c))" ^
+ " or (P(x) and P(d)) or (not P(x) and Q(a))" ^
+ " or (not P(x) and Q(b)) or (not P(x) and Q(c))")
+ ("((P(d) or P(c) or P(b) or P(a) or (not P(x))) " ^
+ "and (Q(c) or Q(b) or Q(a) or P(x)))");
+ );
-test_flatten "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ "simplification" >::
+ (fun () ->
+ let test_simplify form_str b_form_s b_simp_s =
+ let eq_s = assert_eq_string form_str in
+ let form = formula_of_string form_str in
+ let b_form = BoolFormula.bool_formula_of_formula form in
+ eq_s "Boolean formula" b_form_s (BoolFormula.str b_form);
+ let b_simplified = BoolFormula.simplify b_form in
+ eq_s "Simplified formula" b_simp_s (BoolFormula.str b_simplified) in
-test_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ test_simplify
+ "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z)) and (P(y) or Q(z))"
+ "(((4 or 3) and (4 or 3)) or (not (2 and (1 and 1))))"
+ "(-1 or -2 or (3 or 4))";
-test_flat_reduce "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
+ test_simplify ("(not P(x) or not Q(x) or P(y) or Q(z))" ^
+ " and (Q(y) or (P(y) and Q(z))) and Q(z)")
+ "(4 and (((4 and 3) or 5) and (4 or (3 or (-2 or -1)))))"
+ "(4 and (5 or 3))";
-let input_form = "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z))" ;;
-let input_form = "not (A(x) and B(x)) or (not P(x) or (C(x) and D(y)))" ;;
-let form = formula_of_string input_form ;;
-let b_form = BoolFormula.bool_formula_of_formula form ;;
-let b_nnf = BoolFormula.to_nnf b_form ;;
-let b_flat = BoolFormula.flatten_sort b_nnf ;;
-let b_reduced = BoolFormula.to_reduced_form b_flat ;;
+ test_simplify
+ ("(not P(x) or not Q(x) or P(y)) and (not P(x) or Z(x))" ^
+ " and (P(x) or Z(x)) and (Q(x) or not Z(x)) and (Q(x) or P(x))")
+ ("((1 or 2) and ((-4 or 2) and ((4 or 1) and ((4 or -1) and " ^
+ "(3 or (-2 or -1))))))")
+ "(2 and 4 and (-1 or 3))"
+ );
-test_cnf_bool input_form ;;
+ "variable size cnf" >::
+ (fun () ->
+ let test_cnf_string f formula_str =
+ let formula = formula_of_string formula_str in
+ let cnf = BoolFormula.formula_to_cnf formula in
+ let cnf_str = Formula.str cnf in
+ assert_bool "CNF of a formula satisfied" (f cnf_str) in
+ let rec seq acc ?(start=0) stop =
+ if stop < start then [] else
+ if stop = start then start :: acc else
+ seq (stop :: acc) ~start:start (stop-1) in
+ let test_formula n =
+ let vl = seq [] ~start:0 n in
+ let negvl = seq [] ~start:(n + 100) (n + 100 + n) in
+ let long_formula = String.concat " or "
+ (List.map (fun i -> "(Q(x) and P(x" ^ string_of_int i ^ "))") vl) in
+ let neg_long_formula = String.concat " or "
+ (List.map (fun i -> "(not Q(x) and P(x" ^ string_of_int i ^ "))")
+ negvl) in
+ (long_formula ^ " or " ^ neg_long_formula) in
-let cnfllist = BoolFormula.convert b_reduced ;;
-print_endline ("CNF-List: " ^ String.concat " & " (List.map (fun list -> String.concat " | " (List.map string_of_int list)) cnfllist)) ;;
-*)
+ test_cnf_string (fun x -> String.length x > 9) (test_formula 200)
+ );
+]
-
-(*test_bool_simplify "not ((P(x) and P(x)) and Q(x)) or (P(y) or Q(z)) and (P(y) or Q(z))" ;;*)
-
-(*test_bool_simplify "(not P(x) or not Q(x) or P(y) or Q(z)) and (Q(y) or (P(y) and Q(z))) and Q(z)" ;;*)
-
-BoolFormula.set_debug_level 3;;
-
-test_bool_simplify "(not P(x) or not Q(x) or P(y)) and (not P(x) or Z(x)) and (P(x) or Z(x)) and (Q(x) or not Z(x)) and (Q(x) or P(x))" ;;
+let exec = Aux.run_test_if_target "BoolFormulaTest" tests
Modified: trunk/Toss/Formula/Makefile
===================================================================
--- trunk/Toss/Formula/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Formula/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -10,7 +10,7 @@
FFTNFTest:
tests:
- make -C .. Formula_tests
+ make -C .. FormulaTestsVerbose
.PHONY: clean
Modified: trunk/Toss/GGP/Makefile
===================================================================
--- trunk/Toss/GGP/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/GGP/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -1,4 +1,4 @@
-all: tests
+all: tests_all
%Test:
make -C .. GGP/$@
@@ -29,8 +29,9 @@
java -jar gamecontroller-cli.jar play $< 600 10 1 -random 2 -remote 1 toss localhost 8110 1 | grep results
killall -v TossServer
-tests:
- make -C .. GGP_tests
+
+tests_all:
+ make -C .. GGPTestsVerbose
make tictactoe.white
make tictactoe.black
make breakthrough.white
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -92,61 +92,64 @@
%Test: %Test.native
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$<
+%TestVerbose: %Test.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -v
+
%TestDebug: %Test.d.byte
OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$<
%TestProfile: %Test.p.native
_build/$<
gprof _build/$< > $@.log
-
+
+# All OUnit tests, aggregate
+TossTest:
+TossTestVerbose:
+TossFullTest:
+TossFullTestVerbose:
+
# Formula tests
-Formula_tests: \
- Formula/AuxTest \
- Formula/FormulaTest \
- Formula/BoolFormulaTest \
- Formula/FormulaOpsTest \
- Formula/FFTNFTest
+FormulaTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -formula
+FormulaTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -formula -v
# Solver tests
-Solver_tests: \
- Solver/StructureTest \
- Solver/AssignmentsTest \
- Solver/SolverTest \
- Solver/FFSolverTest \
- Solver/ClassTest \
- # Solver/Presb_test
+SolverTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -solver
+SolverTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -solver -v
# Arena tests
-Arena_tests: \
- Arena/TermTest \
- Arena/DiscreteRuleTest \
- Arena/ContinuousRuleTest \
- Arena/ArenaTest
+ArenaTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -arena
+ArenaTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -arena -v
# Play tests
-Play_tests: \
- Play/HeuristicTest \
- Play/MoveTest \
- Play/GameTreeTest \
- Play/PlayTest
+PlayTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -play
+PlayTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -play -v
# GGP tests
-GGP_tests: \
- GGP/GDLTest
+GGPTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -ggp
+GGPTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -ggp -v
# Server tests
-Server_tests: \
- Server/ServerTest
+ServerTests: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -server
+ServerTestsVerbose: TossFullTest.native
+ OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< -server -v
-# All tests, separate
-tests: Formula_tests Solver_tests Arena_tests Play_tests GGP_tests Server_tests
+# All tests
+tests: TossTest
+tests_all: TossFullTestVerbose
-# All OUnit tests, aggregate
-TossTest:
-TossFullTest:
-
# ------ CLEAN ------
.PHONY: clean
Modified: trunk/Toss/Play/Makefile
===================================================================
--- trunk/Toss/Play/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Play/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -25,7 +25,7 @@
PlayTestDebug:
tests:
- make -C .. Play_tests
+ make -C .. PlayTestsVerbose
.PHONY: clean
Modified: trunk/Toss/Server/Makefile
===================================================================
--- trunk/Toss/Server/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Server/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -16,7 +16,7 @@
ServerTestDebug:
tests:
- make -C .. Server_tests
+ make -C .. ServerTestsVerbose
.PHONY: clean
Modified: trunk/Toss/Solver/AssignmentsTest.ml
===================================================================
--- trunk/Toss/Solver/AssignmentsTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Solver/AssignmentsTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -1,3 +1,4 @@
+open OUnit
open Poly
open Structure
open AssignmentSet
@@ -3,22 +4,22 @@
open Assignments
-let test1 name f print_f aset =
- print_endline (name ^" of\n " ^ (str aset) ^ "\nis:");
- print_endline (" " ^ (print_f (f aset)) ^ "\n");
-;;
-let test2 name f print_f as1 as2 =
- print_endline (name ^" of\n " ^ (str as1) ^ "\nand\n "^ (str as2) ^"\nis:");
- print_endline (" " ^ (print_f (f as1 as2)) ^ "\n");
-;;
+(* ----------- Testing helper functions ----------- *)
-let test_join = test2 "Join" join str ;;
-let test_sum elems =
- test2 "Sum" (sum (ref (List (List.length elems, elems)))) str ;;
-let test_complement elems =
- test1 "Complement" (complement (ref (List (List.length elems, elems)))) str ;;
-let test_project elems v =
- test1 "Project" (project (ref (List (List.length elems, elems))) v) str ;;
+let assert_eq_string arg msg x y =
+ let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
+ assert_equal ~printer:(fun x -> x) ~msg:full_msg
+ ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
+let test1 name f print_f aset res_str =
+ let aset_str = str aset in
+ assert_eq_string aset_str name res_str (print_f (f aset))
+
+let test2 name f print_f as1 as2 res_str =
+ let (astr1, astr2) = (str as1, str as2) in
+ assert_eq_string (astr1 ^ " and " ^ astr2) name res_str (print_f (f as1 as2))
+
+let test_join = test2 "Join" join str
+
let test_join_tup elems_l (vns1, tps1) (vns2, tps2) =
let elems = ref (List (List.length elems_l, elems_l)) in
@@ -28,59 +29,117 @@
let as1 = assignments_of_list elems (Array.of_list vs1) tps1 in
let as2 = assignments_of_list elems (Array.of_list vs2) tps2 in
test_join as1 as2
-;;
-test_join_tup [1;2;3] (["x"], [[|1|]; [|2|]]) (["y"], [[|2|]; [|3|]]) ;;
+let test_sum elems =
+ test2 "Sum" (sum (ref (List (List.length elems, elems)))) str
-let full = (Elems.empty, Elems.empty) ;;
-let in1 = (Elems.add 1 Elems.empty, Elems.empty) ;;
-let out1 = (Elems.empty, Elems.add 1 Elems.empty) ;;
-let in2 = (Elems.add 2 Elems.empty, Elems.empty) ;;
-let out2 = (Elems.empty, Elems.add 2 Elems.empty) ;;
+let test_complement elems =
+ test1 "Complement" (complement (ref (List (List.length elems, elems)))) str
-test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)])) ;;
+let test_project elems v =
+ test1 "Project" (project (ref (List (List.length elems, elems))) v) str
-test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)])) ;;
+(* ------ Some constants used in tests ------ *)
+
+let full = (Elems.empty, Elems.empty)
+let in1 = (Elems.add 1 Elems.empty, Elems.empty)
+let out1 = (Elems.empty, Elems.add 1 Elems.empty)
+let in2 = (Elems.add 2 Elems.empty, Elems.empty)
+let out2 = (Elems.empty, Elems.add 2 Elems.empty)
+
(* x*z^2 + 2 *)
-let p0 = Plus (Times (Var "x", Times (Var "z", Var "z")), Const 2.) ;;
+let p0 = Plus (Times (Var "x", Times (Var "z", Var "z")), Const 2.)
+
(* x^2 + 3x + 2 *)
let p1 =
- Plus (Times (Var "x", Var "x"), Plus (Times (Const 3., Var "x"), Const 2.)) ;;
+ Plus (Times (Var "x", Var "x"), Plus (Times (Const 3., Var "x"), Const 2.))
-test_join (Real ([[p0,Formula.LZero]])) (Real ([[Var "x",Formula.GZero]]));;
-test_join (Real ([[p1,Formula.LZero]])) (Real ([[Var "x",Formula.LZero]]));;
+(* ---------- The Tests --------- *)
-test_join (Real ([[p0,Formula.LZero]; [Var "z", Formula.GEQZero]]))
- (Real ([[Var "x",Formula.GZero]; [Var "z", Formula.LEQZero]])) ;;
+let tests = "Assignments" >::: [
+ "join" >::
+ (fun () ->
+ test_join_tup [1;2;3] (["x"], [[|1|]; [|2|]]) (["y"], [[|2|]; [|3|]])
+ "{ y->2{ x->1, x->2 } , y->3{ x->1, x->2 } }";
-test_sum [1] (MSO (`MSO "X", [(full, Any)])) (MSO (`MSO "X", [(in1, Any)])) ;;
+ test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)]))
+ "{ X->(inc {1, 2} excl {}) }";
+
+ test_join (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)]))
+ "{}";
-test_sum [1;2] (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)])) ;;
+ test_join (Real([[p0,Formula.LZero]])) (Real([[Var "x",Formula.GZero]]))
+ "{}";
-test_sum [1;2] (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)])) ;;
+ test_join (Real([[p1,Formula.LZero]])) (Real([[Var "x",Formula.LZero]]))
+ "{ ((x*x) + (((3.)*x) + (2.)) < 0 and x < 0) }";
-let inY1, outY1 = MSO (`MSO "Y", [(in1, Any)]), MSO (`MSO "Y", [(out1, Any)]) ;;
-test_sum [1;2] (MSO (`MSO "X", [(in1, inY1)])) (MSO (`MSO "X", [(in1, outY1)])) ;;
+ test_join (Real ([[p0,Formula.LZero]; [Var "z", Formula.GEQZero]]))
+ (Real ([[Var "x",Formula.GZero]; [Var "z", Formula.LEQZero]]))
+ ("{ (z >= 0 and x > 0) or (z >= 0 and z =< 0) or " ^
+ "((x*(z*z)) + (2.) < 0 and z =< 0) }");
+ );
-test_complement [1;2] (MSO (`MSO "X", [(in2, Any)])) ;;
+ "sum" >::
+ (fun () ->
+ test_sum [1]
+ (MSO (`MSO "X", [(full, Any)])) (MSO (`MSO "X", [(in1, Any)]))
+ "T";
-test_complement [1;2] (MSO (`MSO "X", [(in1, Any); (in2, Any)])) ;;
+ test_sum [1;2]
+ (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(in2, Any)]))
+ "{ X->(inc {1} excl {}), X->(inc {2} excl {}) }";
-test_complement [1;2]
- (MSO (`MSO "X", [(in1, MSO (`MSO "Y", [(in2, Any)]));
- (in2, Any)])) ;;
+ test_sum [1;2]
+ (MSO (`MSO "X", [(in1, Any)])) (MSO (`MSO "X", [(out1, Any)]))
+ "T";
-test_complement [1;2] (Real [[(Var "x", Formula.LZero)]]) ;;
+ let inY1 = MSO (`MSO "Y", [(in1, Any)]) in
+ let outY1 = MSO (`MSO "Y", [(out1, Any)]) in
+ test_sum [1;2]
+ (MSO (`MSO "X", [(in1, inY1)])) (MSO (`MSO "X", [(in1, outY1)]))
+ "{ X->(inc {1} excl {}) }";
+ );
-test_complement [1;2] (Real [[(p0, Formula.GZero);(Var "z", Formula.LZero)];
- [(Var "x", Formula.LZero)]]) ;;
+ "complement" >::
+ (fun () ->
+ test_complement [1;2] (MSO (`MSO "X", [(in2, Any)]))
+ "{ X->(inc {} excl {2}) }";
-test_project [1;2] (`FO "x")
- (FO (`FO "x", [(1, FO (`FO "y", [1, Any])); (2, FO (`FO "y", [1, Any]))])) ;;
+ test_complement [1;2] (MSO (`MSO "X", [(in1, Any); (in2, Any)]))
+ "{ X->(inc {} excl {1, 2}) }";
-test_project [1;2] (`Real "z") (Real [[(p0, Formula.LZero)]]) ;;
+ test_complement [1;2]
+ (MSO (`MSO "X", [(in1, MSO (`MSO "Y", [(in2, Any)])); (in2, Any)]))
+ ("{ X->(inc {} excl {1, 2}), X->(inc {} excl {2})" ^
+ "{ Y->(inc {} excl {2}) } }");
-test_project [1;2] (`Real "x")
- (Real [[Var "x",Formula.LZero]; [p1,Formula.LZero]]) ;;
+ test_complement [1;2] (Real [[(Var "x", Formula.LZero)]])
+ "{ (x >= 0) }";
+
+ test_complement [1;2]
+ (Real [[(p0, Formula.GZero);(Var "z", Formula.LZero)];
+ [(Var "x", Formula.LZero)]])
+ "{ (x >= 0 and z >= 0) }";
+ );
+
+ "project" >::
+ (fun () ->
+ test_project [1;2] (`FO "x")
+ (FO (`FO "x", [(1, FO (`FO "y", [1, Any]));
+ (2, FO (`FO "y", [1, Any]))]))
+ "{ y->1 }";
+
+ test_project [1;2] (`Real "z") (Real [[(p0, Formula.LZero)]])
+ "{ (x < 0) }";
+
+ test_project [1;2] (`Real "x")
+ (Real [[Var "x",Formula.LZero]; [p1,Formula.LZero]])
+ "T";
+ );
+]
+
+
+let exec = Aux.run_test_if_target "AssignmentsTest" tests
Modified: trunk/Toss/Solver/Makefile
===================================================================
--- trunk/Toss/Solver/Makefile 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/Solver/Makefile 2011-04-17 01:25:17 UTC (rev 1415)
@@ -11,7 +11,7 @@
PresbTest:
tests:
- make -C .. Solver_tests
+ make -C .. SolverTestsVerbose
.PHONY: clean
Modified: trunk/Toss/TossFullTest.ml
===================================================================
--- trunk/Toss/TossFullTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/TossFullTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -32,5 +32,32 @@
server_tests;
]
-let a =
- Aux.run_test_if_target "TossFullTest" tests
+
+
+let main () =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ let (run_tests, debug_level) = (ref tests, ref 0) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> debug_level := 1), " make tests verbose");
+ ("-vv", Arg.Unit (fun () -> debug_level := 2), " make tests very verbose");
+ ("-d", Arg.Int (fun i -> debug_level := i), " set tests debug level");
+ ("-formula", Arg.Unit (fun () -> run_tests := formula_tests),
+ "run only tests for the Formula directory");
+ ("-solver", Arg.Unit (fun () -> run_tests := solver_tests),
+ "run only tests for the Solver directory");
+ ("-arena", Arg.Unit (fun () -> run_tests := arena_tests),
+ "run only tests for the Arena directory");
+ ("-play", Arg.Unit (fun () -> run_tests := play_tests),
+ "run only tests for the Play directory");
+ ("-ggp", Arg.Unit (fun () -> run_tests := ggp_tests),
+ "run only tests for the GGP directory");
+ ("-server", Arg.Unit (fun () -> run_tests := server_tests),
+ "run only tests for the Server directory");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ ignore (OUnit.run_test_tt ~verbose:(!debug_level > 0) !run_tests)
+
+let _ = Aux.run_if_target "TossFullTest" main
Modified: trunk/Toss/TossTest.ml
===================================================================
--- trunk/Toss/TossTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
+++ trunk/Toss/TossTest.ml 2011-04-17 01:25:17 UTC (rev 1415)
@@ -3,12 +3,14 @@
let formula_tests = "Formula" >::: [
AuxTest.tests;
FormulaTest.tests;
+ BoolFormulaTest.tests;
FormulaOpsTest.tests;
FFTNFTest.tests;
]
let solver_tests = "Solver" >::: [
StructureTest.tests;
+ AssignmentsTest.tests;
SolverTest.tests;
]
@@ -44,5 +46,32 @@
server_tests;
]
-let a =
- Aux.run_test_if_target "TossTest" tests
+
+
+let main () =
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *) };
+ let (run_tests, debug_level) = (ref tests, ref 0) in
+ let opts = [
+ ("-v", Arg.Unit (fun () -> debug_level := 1), " make tests verbose");
+ ("-vv", Arg.Unit (fun () -> debug_level := 2), " make tests very verbose");
+ ("-d", Arg.Int (fun i -> debug_level := i), " set tests debug level");
+ ("-formula", Arg.Unit (fun () -> run_tests := formula_tests),
+ "run only tests for the Formula directory");
+ ("-solver", Arg.Unit (fun () -> run_tests := solver_tests),
+ "run only tests for the Solver directory");
+ ("-arena", Arg.Unit (fun () -> run_tests := arena_tests),
+ "run only tests for the Arena directory");
+ ("-play", Arg.Unit (fun () -> run_tests := play_tests),
+ "run only tests for the Play directory");
+ ("-ggp", Arg.Unit (fun () -> run_tests := ggp_tests),
+ "run only tests for the GGP directory");
+ ("-server", Arg.Unit (fun () -> run_tests := server_tests),
+ "run only tests for the Server directory");
+ ] in
+ Arg.parse opts (fun _ -> ()) "Try -help for help or one of the following.";
+ ignore (OUnit.run_test_tt ~verbose:(!debug_level > 0) !run_tests)
+
+let _ = Aux.run_if_target "TossTest" main
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-16 21:05:28
|
Revision: 1414
http://toss.svn.sourceforge.net/toss/?rev=1414&view=rev
Author: lukaszkaiser
Date: 2011-04-16 21:05:20 +0000 (Sat, 16 Apr 2011)
Log Message:
-----------
Changing ArenaParser to handle concurrency, adapting files.
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/Arena.mli
trunk/Toss/Arena/ArenaParser.mly
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/GGP/tests/breakthrough-simpl.toss
trunk/Toss/GGP/tests/connect5-simpl.toss
trunk/Toss/examples/Breakthrough.toss
trunk/Toss/examples/Checkers.toss
trunk/Toss/examples/Chess.toss
trunk/Toss/examples/Connect4.toss
trunk/Toss/examples/Entanglement.toss
trunk/Toss/examples/Gomoku.toss
trunk/Toss/examples/Gomoku19x19.toss
trunk/Toss/examples/Pawn-Whopping.toss
trunk/Toss/examples/Tic-Tac-Toe.toss
trunk/Toss/examples/bounce.toss
trunk/Toss/examples/rewriting_example.toss
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/Arena.ml 2011-04-16 21:05:20 UTC (rev 1414)
@@ -47,14 +47,16 @@
cur_loc : int ;
}
+let zero_loc = { payoff = Formula.Const 0. ;
+ view = (Formula.And [], []);
+ heur = [];
+ moves = [] }
+
let empty_state =
let emp_struc = Structure.empty_structure () in
- let zero = Formula.Const 0.0 in
{rules = [];
patterns = [];
- graph = Array.make 1
- (Array.make 1
- { payoff = zero; moves = []; view = (Formula.And [],[]); heur = [] });
+ graph = Array.make 1 (Array.make 1 zero_loc);
player_names = ["1", 0] ;
data = [] ;
defined_rels = [] ;
@@ -134,27 +136,19 @@
parameters_in = parameters_in;
}, target_loc
+
+let make_player_loc defs =
+ let (payoff, moves) = List.fold_left
+ (fun (payoff, moves) -> function
+ | `Payoff poff -> (poff, moves)
+ | `Moves mvs -> (payoff, moves @ mvs)
+ ) (Formula.Const 0., []) defs in
+ { zero_loc with payoff = payoff ; moves = moves }
+
let make_location id loc_defs =
- let (pname, payoffs, moves) = List.fold_left
- (fun (pname, payoffs, moves) -> function
- | `PlayerName pn ->
- if pname = None then Some pn, payoffs, moves
- else raise (
- Arena_definition_error
- ("Location player redefined from " ^ Aux.unsome pname ^
- " to " ^ pn))
- | `Payoffs poffs -> pname, payoffs @ poffs, moves
- | `Moves mvs -> pname, payoffs, moves @ mvs
- ) (None, [], []) loc_defs in
- (* TODO: sanitize against redefinition in payoffs and equivalence of
- moves? *)
- let pname = match pname with None -> "1" | Some p -> p in
fun player_names ->
- let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
- heur = []; moves = [] } in
- let locs = List.map (fun (pl, poff) ->
- (pl, { payoff = poff ; view = (Formula.And [], []); heur = [];
- moves = if pl = pname then moves else [] })) payoffs in
+ let locs = List.map
+ (fun (pl, pl_loc_defs) -> (pl, make_player_loc pl_loc_defs)) loc_defs in
array_of_players zero_loc player_names locs
@@ -247,8 +241,6 @@
if old_locs = [] then old_locs
else
let more = num_players - Array.length (List.hd old_locs) in
- let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
- heur = []; moves = [] } in
let add_more loc = Array.append loc (Array.make more zero_loc) in
List.map add_more old_locs in
let add_def_rel loc =
@@ -299,27 +291,24 @@
(* Print a move as string. *)
let move_str (lb, i) = "["^ (label_str lb) ^" -> "^ (string_of_int i) ^"]"
-let fprint_loc_body_in struc pnames f player
- {payoff = payoff; moves = moves} =
- Format.fprintf f "@[<1>PLAYER@ %s@]@ "
- (Aux.rev_assoc pnames player);
- Format.fprintf f "@[<1>PAYOFF@ {@,@[<1>%a@]@,}@]@ "
- (Aux.fprint_sep_list ";" (fun f (p, ex) ->
- Format.fprintf f "@[<1>%s:@ %a@]" (Aux.rev_assoc pnames p)
- (Formula.fprint_real(* _nobra 0 *)) ex))
- (Array.to_list (Array.mapi (fun i l->i, l) [|payoff|]));
- Format.fprintf f "@[<1>MOVES@ %a@]"
- (Aux.fprint_sep_list ";" (fun f ({
- rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
- Format.fprintf f "[@,@[<1>%s" r;
- if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
- Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
- if params <> [] then
- Format.fprintf f ",@ %a"
- (Aux.fprint_sep_list "," (fun f (pn, (p_l, p_r)) ->
- Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
- Format.fprintf f "@ ->@ %d@]@,]" target)) moves
-
+let fprint_loc_body_in struc pnames f player {payoff = in_p; moves = in_m} =
+ Format.fprintf f "@ @[<0>PLAYER@ %s@ {@ %a}@]@," (Aux.rev_assoc pnames player)
+ (fun f (payoff, moves) ->
+ Format.fprintf f "@[<1>PAYOFF@ @[<1>%a@]@]@ "
+ (Formula.fprint_real(* _nobra 0 *)) payoff;
+ if moves <> [] then
+ Format.fprintf f "@[<1>MOVES@ %a@]@ "
+ (Aux.fprint_sep_list ";" (fun f ({
+ rule=r; time_in=(t_l, t_r); parameters_in=params}, target) ->
+ Format.fprintf f "[@,@[<1>%s" r;
+ if t_l <> cDEFAULT_TIMESTEP || t_r <> cDEFAULT_TIMESTEP then
+ Format.fprintf f ",@ @[<1>t:@ %F@ --@ %F@]" t_l t_r;
+ if params <> [] then
+ Format.fprintf f ",@ %a"
+ (Aux.fprint_sep_list "," (fun f (pn, (p_l, p_r)) ->
+ Format.fprintf f "@[<1>%s:@ %F@ --@ %F@]" pn p_l p_r)) params;
+ Format.fprintf f "@ ->@ %d@]@,]" target)) moves
+ ) (in_p, in_m)
let fprint_loc_body struc pnames f loc =
Array.iteri (fun p l -> fprint_loc_body_in struc pnames f p l) loc
@@ -362,7 +351,7 @@
Format.fprintf ppf "@[<1>RULE %s:@ %a@]@ " rname
(ContinuousRule.fprint_full print_compiled_rules) r) rules;
Array.iteri (fun loc_id loc ->
- Format.fprintf ppf "@[<1>LOC %d@ {@,@[<1>@,%a@]@,}@]@ "
+ Format.fprintf ppf "@[<0>LOC@ %d@ {@,@[<2> %a@]@]@,}@ "
loc_id (fprint_loc_body struc player_names) loc) graph;
Format.fprintf ppf "@[<1>MODEL@ %a@]@ "
(Structure.fprint ~show_empty:true) struc;
@@ -392,8 +381,6 @@
let add_new_player (state_game, state) pname =
let player = state_game.num_players in
- let zero_loc = { payoff = Formula.Const 0. ; view = (Formula.And [], []);
- heur = []; moves = [] } in
let add_more loc = Array.append loc [|zero_loc|] in
let game = {state_game with
num_players = state_game.num_players + 1;
@@ -766,8 +753,6 @@
| SetLoc (i) ->
let l = Array.length state_game.graph in
if i < 0 || i > l then (* make new location and set there *)
- let zero_loc = { payoff = Formula.Const 0. ; heur = []; moves = [] ;
- view = (Formula.And [], []); } in
let a = Array.make (Array.length state_game.graph.(0)) zero_loc in
(({state_game with graph = Array.append state_game.graph [|a|]},
{state with cur_loc = l }),
Modified: trunk/Toss/Arena/Arena.mli
===================================================================
--- trunk/Toss/Arena/Arena.mli 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/Arena.mli 2011-04-16 21:05:20 UTC (rev 1414)
@@ -109,10 +109,9 @@
val make_location :
int ->
- [< `Moves of (label * int) list
- | `Payoffs of (string * Formula.real_expr) list
- | `PlayerName of string ]
- list -> (string * int) list -> player_loc array
+ (string * [< `Moves of (label * int) list
+ | `Payoff of Formula.real_expr ] list) list ->
+ (string * int) list -> player_loc array
(** Create a game state, possibly by extending an old state, from a
list of definitions (usually corresponding to a ".toss" file.) *)
Modified: trunk/Toss/Arena/ArenaParser.mly
===================================================================
--- trunk/Toss/Arena/ArenaParser.mly 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/ArenaParser.mly 2011-04-16 21:05:20 UTC (rev 1414)
@@ -51,19 +51,18 @@
"Syntax error in formula expression."
}
-location_defs:
- | PLAYER_MOD pname = id_int { `PlayerName pname }
- | PAYOFF poffs =
- delimited(OPENCUR, separated_list (
- SEMICOLON, separated_pair (id_int, COLON, real_expr_wrapper)), CLOSECUR)
- { `Payoffs poffs }
- | MOVES moves = separated_list (SEMICOLON, move)
- { `Moves moves }
+player_loc_defs:
+ | PAYOFF poff = real_expr_wrapper { `Payoff poff }
+ | MOVES moves = separated_list (SEMICOLON, move) { `Moves moves }
| error
{ Lexer.report_parsing_error $startpos $endpos
"Syntax error in location field."
}
+location_defs:
+ | PLAYER_MOD pname = id_int OPENCUR defs = list (player_loc_defs) CLOSECUR
+ { (pname, defs) }
+
location:
| ident = INT OPENCUR loc_defs = list (location_defs) CLOSECUR
{ try
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/Arena/ArenaTest.ml 2011-04-16 21:05:20 UTC (rev 1414)
@@ -59,11 +59,12 @@
REL Q(x) {ex y R(y, x)}
TIME 7.
LOC 0 {
- PLAYER white PAYOFF {white: :(ex x P(x)); black: 0.7}
- MOVES [RULE finish -> LOC 1]
+ PLAYER white { PAYOFF :(ex x P(x)) MOVES [RULE finish -> LOC 1] }
+ PLAYER black { PAYOFF 0.7 }
}
LOC 1 {
- PLAYER black PAYOFF {white: 0.3; black: :(ex x Q(x))}
+ PLAYER black { PAYOFF :(ex x Q(x)) }
+ PLAYER white { PAYOFF 0.3 }
}
STATE LOC 1" in
let res1 = "REL P(x) {ex y R(x, y)}
@@ -73,10 +74,12 @@
[a, b | R (a, b) | ] -> [a, c, b | R {(a, c); (c, b)} | ] emb R
with [a <- a, b <- b]
LOC 0 {
- PLAYER white PAYOFF {white: :(ex x ex y R(x, y)); black: 0.7}
- MOVES [finish -> 1]
- }
-LOC 1 {PLAYER black PAYOFF {white: 0.3; black: :(ex x ex y R(y, x))} MOVES }
+ PLAYER white { PAYOFF :(ex x ex y R(x, y)) MOVES [finish -> 1] }
+ PLAYER black { PAYOFF 0.7 }
+}
+LOC 1 {
+ PLAYER white { PAYOFF 0.3 } PLAYER black { PAYOFF :(ex x ex y R(y, x)) }
+}
MODEL [a, b | R (a, b) | ]
STATE LOC 1
TIME 7.
@@ -92,10 +95,12 @@
[a, b | R (a, b) | ] -> [a, c, b | R {(a, c); (c, b)} | ] emb R
with [a <- a, b <- b]
LOC 0 {
- PLAYER white PAYOFF {white: :(ex x ex y R(x, y)); black: 0.7}
- MOVES [finish -> 1]
- }
-LOC 1 {PLAYER black PAYOFF {white: 0.3; black: :(ex x ex y R(y, x))} MOVES }
+ PLAYER white { PAYOFF :(ex x ex y R(x, y)) MOVES [finish -> 1] }
+ PLAYER black { PAYOFF 0.7 }
+}
+LOC 1 {
+ PLAYER white { PAYOFF 0.3 } PLAYER black { PAYOFF :(ex x ex y R(y, x)) }
+}
MODEL [a, b | R (a, b) | ]
STATE LOC 1
TIME 7.
Modified: trunk/Toss/GGP/tests/breakthrough-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/breakthrough-simpl.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/GGP/tests/breakthrough-simpl.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -221,9 +221,8 @@
(cellholds_x2_y2_white(cellholds_x377_y369__blank_) and
not control_MV1(cellholds_x377_y369__blank_)))
LOC 0 {
- PLAYER white
- PAYOFF {
- white:
+ PLAYER white {
+ PAYOFF
100. *
:(
ex cellholds_x26_8__blank_
@@ -234,8 +233,13 @@
ex cellholds_x27_y26__blank_
(not control_MV1(cellholds_x27_y26__blank_) and
cellholds_x2_y2_black(cellholds_x27_y26__blank_))
- );
- black:
+ )
+ MOVES [move_x1_y1_x2_y2_0 -> 1]; [move_x1_y1_x2_y2_00 -> 1];
+ [move_x_y1_x_y2_0 -> 1]
+ }
+
+ PLAYER black {
+ PAYOFF
100. *
:(
ex cellholds_x30_1__blank_
@@ -248,25 +252,10 @@
cellholds_x2_y2_white(cellholds_x31_y28__blank_))
)
}
- MOVES [move_x1_y1_x2_y2_0 -> 1]; [move_x1_y1_x2_y2_00 -> 1]; [
- move_x_y1_x_y2_0 -> 1]
}
LOC 1 {
- PLAYER black
- PAYOFF {
- white:
- 100. *
- :(
- ex cellholds_x26_8__blank_
- (cellholds_x2_8_MV1(cellholds_x26_8__blank_) and
- cellholds_x2_y2_white(cellholds_x26_8__blank_) and
- not control_MV1(cellholds_x26_8__blank_)) or
- not
- ex cellholds_x27_y26__blank_
- (not control_MV1(cellholds_x27_y26__blank_) and
- cellholds_x2_y2_black(cellholds_x27_y26__blank_))
- );
- black:
+ PLAYER black {
+ PAYOFF
100. *
:(
ex cellholds_x30_1__blank_
@@ -278,9 +267,24 @@
(not control_MV1(cellholds_x31_y28__blank_) and
cellholds_x2_y2_white(cellholds_x31_y28__blank_))
)
+ MOVES [move_x1_y1_x2_y2_1 -> 0]; [move_x1_y1_x2_y2_10 -> 0];
+ [move_x_y1_x_y2_1 -> 0]
+ }
+
+ PLAYER white {
+ PAYOFF
+ 100. *
+ :(
+ ex cellholds_x26_8__blank_
+ (cellholds_x2_8_MV1(cellholds_x26_8__blank_) and
+ cellholds_x2_y2_white(cellholds_x26_8__blank_) and
+ not control_MV1(cellholds_x26_8__blank_)) or
+ not
+ ex cellholds_x27_y26__blank_
+ (not control_MV1(cellholds_x27_y26__blank_) and
+ cellholds_x2_y2_black(cellholds_x27_y26__blank_))
+ )
}
- MOVES [move_x1_y1_x2_y2_1 -> 0]; [move_x1_y1_x2_y2_10 -> 0]; [
- move_x_y1_x_y2_1 -> 0]
}
MODEL
[control_MV1, cellholds_8_8_MV1, cellholds_8_7_MV1, cellholds_8_6_MV1,
Modified: trunk/Toss/GGP/tests/connect5-simpl.toss
===================================================================
--- trunk/Toss/GGP/tests/connect5-simpl.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/GGP/tests/connect5-simpl.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -233,9 +233,8 @@
cell_x_y_o(cell_x181_y181__blank_)) and
ex cell_x182_y182__blank_ cell_x_y_b(cell_x182_y182__blank_))
LOC 0 {
- PLAYER x
- PAYOFF {
- x:
+ PLAYER x {
+ PAYOFF
50. +
-50. *
:(
@@ -329,8 +328,12 @@
cell_x_y_x(cell_x48_y48__blank_) and
cell_x_y_x(cell_x47_y47__blank_) and
cell_x_y_x(cell_x46_y46__blank_))
- );
- o:
+ )
+ MOVES [mark_x149_y149_0 -> 1]
+ }
+
+ PLAYER o {
+ PAYOFF
50. +
-50. *
:(
@@ -427,108 +430,11 @@
cell_x_y_o(cell_x47_y47__blank_) and
cell_x_y_o(cell_x46_y46__blank_))
)
- }
- MOVES [mark_x149_y149_0 -> 1]
+ }
}
LOC 1 {
- PLAYER o
- PAYOFF {
- x:
- 50. +
- -50. *
- :(
- ex cell_x51_e7__blank_, cell_x51_d7__blank_, cell_x51_c7__blank_,
- cell_x51_b7__blank_, cell_x51_a7__blank_
- (R(cell_x51_a7__blank_, cell_x51_b7__blank_) and
- R(cell_x51_b7__blank_, cell_x51_c7__blank_) and
- R(cell_x51_c7__blank_, cell_x51_d7__blank_) and
- R(cell_x51_d7__blank_, cell_x51_e7__blank_) and
- cell_x_y_o(cell_x51_a7__blank_) and
- cell_x_y_o(cell_x51_b7__blank_) and
- cell_x_y_o(cell_x51_c7__blank_) and
- cell_x_y_o(cell_x51_d7__blank_) and cell_x_y_o(cell_x51_e7__blank_)) or
- ex cell_e8_y51__blank_, cell_d8_y51__blank_, cell_c8_y51__blank_,
- cell_b8_y51__blank_, cell_a8_y51__blank_
- (R0(cell_a8_y51__blank_, cell_b8_y51__blank_) and
- R0(cell_b8_y51__blank_, cell_c8_y51__blank_) and
- R0(cell_c8_y51__blank_, cell_d8_y51__blank_) and
- R0(cell_d8_y51__blank_, cell_e8_y51__blank_) and
- cell_x_y_o(cell_a8_y51__blank_) and
- cell_x_y_o(cell_b8_y51__blank_) and
- cell_x_y_o(cell_c8_y51__blank_) and
- cell_x_y_o(cell_d8_y51__blank_) and
- cell_x_y_o(cell_e8_y51__blank_)) or
- ex cell_x56_y56__blank_, cell_x55_y55__blank_, cell_x54_y54__blank_,
- cell_x53_y53__blank_, cell_x52_y52__blank_
- (R1(cell_x53_y53__blank_, cell_x52_y52__blank_) and
- R1(cell_x54_y54__blank_, cell_x53_y53__blank_) and
- R1(cell_x55_y55__blank_, cell_x54_y54__blank_) and
- R1(cell_x56_y56__blank_, cell_x55_y55__blank_) and
- cell_x_y_o(cell_x56_y56__blank_) and
- cell_x_y_o(cell_x55_y55__blank_) and
- cell_x_y_o(cell_x54_y54__blank_) and
- cell_x_y_o(cell_x53_y53__blank_) and
- cell_x_y_o(cell_x52_y52__blank_)) or
- ex cell_x61_y61__blank_, cell_x60_y60__blank_, cell_x59_y59__blank_,
- cell_x58_y58__blank_, cell_x57_y57__blank_
- (R2(cell_x58_y58__blank_, cell_x57_y57__blank_) and
- R2(cell_x59_y59__blank_, cell_x58_y58__blank_) and
- R2(cell_x60_y60__blank_, cell_x59_y59__blank_) and
- R2(cell_x61_y61__blank_, cell_x60_y60__blank_) and
- cell_x_y_o(cell_x61_y61__blank_) and
- cell_x_y_o(cell_x60_y60__blank_) and
- cell_x_y_o(cell_x59_y59__blank_) and
- cell_x_y_o(cell_x58_y58__blank_) and
- cell_x_y_o(cell_x57_y57__blank_))
- )
- +
- 50. *
- :(
- ex cell_x40_e5__blank_, cell_x40_d5__blank_, cell_x40_c5__blank_,
- cell_x40_b5__blank_, cell_x40_a5__blank_
- (R(cell_x40_a5__blank_, cell_x40_b5__blank_) and
- R(cell_x40_b5__blank_, cell_x40_c5__blank_) and
- R(cell_x40_c5__blank_, cell_x40_d5__blank_) and
- R(cell_x40_d5__blank_, cell_x40_e5__blank_) and
- cell_x_y_x(cell_x40_a5__blank_) and
- cell_x_y_x(cell_x40_b5__blank_) and
- cell_x_y_x(cell_x40_c5__blank_) and
- cell_x_y_x(cell_x40_d5__blank_) and cell_x_y_x(cell_x40_e5__blank_)) or
- ex cell_e6_y40__blank_, cell_d6_y40__blank_, cell_c6_y40__blank_,
- cell_b6_y40__blank_, cell_a6_y40__blank_
- (R0(cell_a6_y40__blank_, cell_b6_y40__blank_) and
- R0(cell_b6_y40__blank_, cell_c6_y40__blank_) and
- R0(cell_c6_y40__blank_, cell_d6_y40__blank_) and
- R0(cell_d6_y40__blank_, cell_e6_y40__blank_) and
- cell_x_y_x(cell_a6_y40__blank_) and
- cell_x_y_x(cell_b6_y40__blank_) and
- cell_x_y_x(cell_c6_y40__blank_) and
- cell_x_y_x(cell_d6_y40__blank_) and
- cell_x_y_x(cell_e6_y40__blank_)) or
- ex cell_x45_y45__blank_, cell_x44_y44__blank_, cell_x43_y43__blank_,
- cell_x42_y42__blank_, cell_x41_y41__blank_
- (R1(cell_x42_y42__blank_, cell_x41_y41__blank_) and
- R1(cell_x43_y43__blank_, cell_x42_y42__blank_) and
- R1(cell_x44_y44__blank_, cell_x43_y43__blank_) and
- R1(cell_x45_y45__blank_, cell_x44_y44__blank_) and
- cell_x_y_x(cell_x45_y45__blank_) and
- cell_x_y_x(cell_x44_y44__blank_) and
- cell_x_y_x(cell_x43_y43__blank_) and
- cell_x_y_x(cell_x42_y42__blank_) and
- cell_x_y_x(cell_x41_y41__blank_)) or
- ex cell_x50_y50__blank_, cell_x49_y49__blank_, cell_x48_y48__blank_,
- cell_x47_y47__blank_, cell_x46_y46__blank_
- (R2(cell_x47_y47__blank_, cell_x46_y46__blank_) and
- R2(cell_x48_y48__blank_, cell_x47_y47__blank_) and
- R2(cell_x49_y49__blank_, cell_x48_y48__blank_) and
- R2(cell_x50_y50__blank_, cell_x49_y49__blank_) and
- cell_x_y_x(cell_x50_y50__blank_) and
- cell_x_y_x(cell_x49_y49__blank_) and
- cell_x_y_x(cell_x48_y48__blank_) and
- cell_x_y_x(cell_x47_y47__blank_) and
- cell_x_y_x(cell_x46_y46__blank_))
- );
- o:
+ PLAYER o {
+ PAYOFF
50. +
-50. *
:(
@@ -625,8 +531,106 @@
cell_x_y_o(cell_x47_y47__blank_) and
cell_x_y_o(cell_x46_y46__blank_))
)
+ MOVES [mark_x159_y159_1 -> 0]
}
- MOVES [mark_x159_y159_1 -> 0]
+
+ PLAYER x {
+ PAYOFF
+ 50. +
+ -50. *
+ :(
+ ex cell_x51_e7__blank_, cell_x51_d7__blank_, cell_x51_c7__blank_,
+ cell_x51_b7__blank_, cell_x51_a7__blank_
+ (R(cell_x51_a7__blank_, cell_x51_b7__blank_) and
+ R(cell_x51_b7__blank_, cell_x51_c7__blank_) and
+ R(cell_x51_c7__blank_, cell_x51_d7__blank_) and
+ R(cell_x51_d7__blank_, cell_x51_e7__blank_) and
+ cell_x_y_o(cell_x51_a7__blank_) and
+ cell_x_y_o(cell_x51_b7__blank_) and
+ cell_x_y_o(cell_x51_c7__blank_) and
+ cell_x_y_o(cell_x51_d7__blank_) and cell_x_y_o(cell_x51_e7__blank_)) or
+ ex cell_e8_y51__blank_, cell_d8_y51__blank_, cell_c8_y51__blank_,
+ cell_b8_y51__blank_, cell_a8_y51__blank_
+ (R0(cell_a8_y51__blank_, cell_b8_y51__blank_) and
+ R0(cell_b8_y51__blank_, cell_c8_y51__blank_) and
+ R0(cell_c8_y51__blank_, cell_d8_y51__blank_) and
+ R0(cell_d8_y51__blank_, cell_e8_y51__blank_) and
+ cell_x_y_o(cell_a8_y51__blank_) and
+ cell_x_y_o(cell_b8_y51__blank_) and
+ cell_x_y_o(cell_c8_y51__blank_) and
+ cell_x_y_o(cell_d8_y51__blank_) and
+ cell_x_y_o(cell_e8_y51__blank_)) or
+ ex cell_x56_y56__blank_, cell_x55_y55__blank_, cell_x54_y54__blank_,
+ cell_x53_y53__blank_, cell_x52_y52__blank_
+ (R1(cell_x53_y53__blank_, cell_x52_y52__blank_) and
+ R1(cell_x54_y54__blank_, cell_x53_y53__blank_) and
+ R1(cell_x55_y55__blank_, cell_x54_y54__blank_) and
+ R1(cell_x56_y56__blank_, cell_x55_y55__blank_) and
+ cell_x_y_o(cell_x56_y56__blank_) and
+ cell_x_y_o(cell_x55_y55__blank_) and
+ cell_x_y_o(cell_x54_y54__blank_) and
+ cell_x_y_o(cell_x53_y53__blank_) and
+ cell_x_y_o(cell_x52_y52__blank_)) or
+ ex cell_x61_y61__blank_, cell_x60_y60__blank_, cell_x59_y59__blank_,
+ cell_x58_y58__blank_, cell_x57_y57__blank_
+ (R2(cell_x58_y58__blank_, cell_x57_y57__blank_) and
+ R2(cell_x59_y59__blank_, cell_x58_y58__blank_) and
+ R2(cell_x60_y60__blank_, cell_x59_y59__blank_) and
+ R2(cell_x61_y61__blank_, cell_x60_y60__blank_) and
+ cell_x_y_o(cell_x61_y61__blank_) and
+ cell_x_y_o(cell_x60_y60__blank_) and
+ cell_x_y_o(cell_x59_y59__blank_) and
+ cell_x_y_o(cell_x58_y58__blank_) and
+ cell_x_y_o(cell_x57_y57__blank_))
+ )
+ +
+ 50. *
+ :(
+ ex cell_x40_e5__blank_, cell_x40_d5__blank_, cell_x40_c5__blank_,
+ cell_x40_b5__blank_, cell_x40_a5__blank_
+ (R(cell_x40_a5__blank_, cell_x40_b5__blank_) and
+ R(cell_x40_b5__blank_, cell_x40_c5__blank_) and
+ R(cell_x40_c5__blank_, cell_x40_d5__blank_) and
+ R(cell_x40_d5__blank_, cell_x40_e5__blank_) and
+ cell_x_y_x(cell_x40_a5__blank_) and
+ cell_x_y_x(cell_x40_b5__blank_) and
+ cell_x_y_x(cell_x40_c5__blank_) and
+ cell_x_y_x(cell_x40_d5__blank_) and cell_x_y_x(cell_x40_e5__blank_)) or
+ ex cell_e6_y40__blank_, cell_d6_y40__blank_, cell_c6_y40__blank_,
+ cell_b6_y40__blank_, cell_a6_y40__blank_
+ (R0(cell_a6_y40__blank_, cell_b6_y40__blank_) and
+ R0(cell_b6_y40__blank_, cell_c6_y40__blank_) and
+ R0(cell_c6_y40__blank_, cell_d6_y40__blank_) and
+ R0(cell_d6_y40__blank_, cell_e6_y40__blank_) and
+ cell_x_y_x(cell_a6_y40__blank_) and
+ cell_x_y_x(cell_b6_y40__blank_) and
+ cell_x_y_x(cell_c6_y40__blank_) and
+ cell_x_y_x(cell_d6_y40__blank_) and
+ cell_x_y_x(cell_e6_y40__blank_)) or
+ ex cell_x45_y45__blank_, cell_x44_y44__blank_, cell_x43_y43__blank_,
+ cell_x42_y42__blank_, cell_x41_y41__blank_
+ (R1(cell_x42_y42__blank_, cell_x41_y41__blank_) and
+ R1(cell_x43_y43__blank_, cell_x42_y42__blank_) and
+ R1(cell_x44_y44__blank_, cell_x43_y43__blank_) and
+ R1(cell_x45_y45__blank_, cell_x44_y44__blank_) and
+ cell_x_y_x(cell_x45_y45__blank_) and
+ cell_x_y_x(cell_x44_y44__blank_) and
+ cell_x_y_x(cell_x43_y43__blank_) and
+ cell_x_y_x(cell_x42_y42__blank_) and
+ cell_x_y_x(cell_x41_y41__blank_)) or
+ ex cell_x50_y50__blank_, cell_x49_y49__blank_, cell_x48_y48__blank_,
+ cell_x47_y47__blank_, cell_x46_y46__blank_
+ (R2(cell_x47_y47__blank_, cell_x46_y46__blank_) and
+ R2(cell_x48_y48__blank_, cell_x47_y47__blank_) and
+ R2(cell_x49_y49__blank_, cell_x48_y48__blank_) and
+ R2(cell_x50_y50__blank_, cell_x49_y49__blank_) and
+ cell_x_y_x(cell_x50_y50__blank_) and
+ cell_x_y_x(cell_x49_y49__blank_) and
+ cell_x_y_x(cell_x48_y48__blank_) and
+ cell_x_y_x(cell_x47_y47__blank_) and
+ cell_x_y_x(cell_x46_y46__blank_))
+ )
+ }
}
MODEL
[control_MV1, cell_h_h_MV1, cell_h_g_MV1, cell_h_f_MV1, cell_h_e_MV1,
Modified: trunk/Toss/examples/Breakthrough.toss
===================================================================
--- trunk/Toss/examples/Breakthrough.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Breakthrough.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -39,31 +39,30 @@
B
" emb W, B pre not ex x (W(x) and not ex y C(x, y))
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1:
- :(ex x (W(x) and not ex y C(x, y))) +
- -1. * :(ex x (B(x) and not ex y C(y, x)));
- 2:
- :(ex x (B(x) and not ex y C(y, x))) +
- -1. * :(ex x (W(x) and not ex y C(x, y)))
- }
- MOVES [WhiteDiag -> 1]; [WhiteStraight -> 1]
- }
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ MOVES
+ [WhiteDiag -> 1]; [WhiteStraight -> 1]
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ }
+}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1:
- :(ex x (W(x) and not ex y C(x, y))) +
- -1. * :(ex x (B(x) and not ex y C(y, x)));
- 2:
- :(ex x (B(x) and not ex y C(y, x))) +
- -1. * :(ex x (W(x) and not ex y C(x, y)))
- }
- MOVES [BlackDiag -> 0]; [BlackStraight -> 0]
- }
-MODEL [ | |
- ] "
+ PLAYER 1 {
+ PAYOFF
+ :(ex x (W(x) and not ex y C(x, y))) - :(ex x (B(x) and not ex y C(y, x)))
+ }
+ PLAYER 2 {
+ PAYOFF
+ :(ex x (B(x) and not ex y C(y, x))) - :(ex x (W(x) and not ex y C(x, y)))
+ MOVES
+ [BlackDiag -> 0]; [BlackStraight -> 0]
+ }
+}
+MODEL [ | | ] "
... ... ... ...
B B..B B..B B..B B..
... ... ... ...
Modified: trunk/Toss/examples/Checkers.toss
===================================================================
--- trunk/Toss/examples/Checkers.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Checkers.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -84,40 +84,47 @@
[ a, b, c | Bq { a }; w { b } | - ] -> [ a, b, c | Bq { c } | - ] emb w, b
pre Diag2 (a, b, c)
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES
+ [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
+ [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
+ [RedBeatCont -> 2]
}
- MOVES [RedMove -> 1]; [RedPromote -> 1]; [RedQMove -> 1];
- [RedBeat -> 1]; [RedBeatPromote -> 1]; [RedQBeat -> 1];
- [RedBeatCont -> 2]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
}
- MOVES [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
- [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
- [WhiteBeatCont -> 3]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteMove -> 0]; [WhitePromote -> 0]; [WhiteQMove -> 0];
+ [WhiteBeat -> 0]; [WhiteBeatPromote -> 0]; [WhiteQBeat -> 0];
+ [WhiteBeatCont -> 3]
+ }
}
LOC 2 {
- PLAYER 1
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
+ MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
}
- MOVES [RedBeatBoth -> 1]; [RedBeatPromote -> 1]; [RedBeatBothCont -> 2]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ }
}
LOC 3 {
- PLAYER 2
- PAYOFF {
- 1: :(ex x w(x)) - :(ex x b(x));
- 2: :(ex x b(x)) - :(ex x w(x))
+ PLAYER 1 {
+ PAYOFF :(ex x w(x)) - :(ex x b(x))
}
- MOVES [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
+ PLAYER 2 {
+ PAYOFF :(ex x b(x)) - :(ex x w(x))
+ MOVES
+ [WhiteBeatBoth -> 0]; [WhiteBeatPromote -> 0]; [WhiteBeatBothCont -> 3]
+ }
}
MODEL [ | Wq:1 { }; Bq:1 { } |
] "
Modified: trunk/Toss/examples/Chess.toss
===================================================================
--- trunk/Toss/examples/Chess.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Chess.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -313,11 +313,8 @@
...bR bK.
" emb w,b pre not (wBeats(a1) or wBeats(b1) or wBeats(c1)) post true
LOC 0 { // both can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 1];
[WhitePawnMoveDbl -> 1];
@@ -336,12 +333,11 @@
[WhiteRightCastle -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 1 { // both can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 0];
[BlackPawnMoveDbl -> 0];
@@ -360,12 +356,11 @@
[BlackRightCastle -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 2 { // w left, b can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 3];
[WhitePawnMoveDbl -> 3];
@@ -383,12 +378,11 @@
[WhiteLeftCastle -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 3 { // w left, b can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 2];
[BlackPawnMoveDbl -> 2];
@@ -407,12 +401,11 @@
[BlackRightCastle -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 4 { // w right, b can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 5];
[WhitePawnMoveDbl -> 5];
@@ -430,12 +423,11 @@
[WhiteRightCastle -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 5 { // w right, b can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 4];
[BlackPawnMoveDbl -> 4];
@@ -454,12 +446,11 @@
[BlackRightCastle -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 6 { // w no, b can castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 7];
[WhitePawnMoveDbl -> 7];
@@ -476,12 +467,11 @@
[WhiteQueen -> 7];
[WhiteKing -> 7]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 7 { // w no, b can castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 6];
[BlackPawnMoveDbl -> 6];
@@ -500,12 +490,11 @@
[BlackRightCastle -> 30];
[BlackKing -> 30]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 8 { // w can, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 9];
[WhitePawnMoveDbl -> 9];
@@ -524,12 +513,11 @@
[WhiteRightCastle -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 9 { // w can, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 8];
[BlackPawnMoveDbl -> 8];
@@ -547,12 +535,11 @@
[BlackLeftCastle -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 10 { // w left, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 11];
[WhitePawnMoveDbl -> 11];
@@ -570,12 +557,11 @@
[WhiteLeftCastle -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 11 { // w left, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 10];
[BlackPawnMoveDbl -> 10];
@@ -593,12 +579,11 @@
[BlackLeftCastle -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 12 { // w right, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 13];
[WhitePawnMoveDbl -> 13];
@@ -616,12 +601,11 @@
[WhiteRightCastle -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 13 { // w right, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 12];
[BlackPawnMoveDbl -> 12];
@@ -639,12 +623,11 @@
[BlackLeftCastle -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 14 { // w no, b left castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 15];
[WhitePawnMoveDbl -> 15];
@@ -661,12 +644,11 @@
[WhiteQueen -> 15];
[WhiteKing -> 15]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 15 { // w no, b left castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 14];
[BlackPawnMoveDbl -> 14];
@@ -684,12 +666,11 @@
[BlackLeftCastle -> 30];
[BlackKing -> 30]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 16 { // w can, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 17];
[WhitePawnMoveDbl -> 17];
@@ -708,12 +689,11 @@
[WhiteRightCastle -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 17 { // w can, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 16];
[BlackPawnMoveDbl -> 16];
@@ -731,12 +711,11 @@
[BlackRightCastle -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 18 { // w left, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 19];
[WhitePawnMoveDbl -> 19];
@@ -754,12 +733,11 @@
[WhiteLeftCastle -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 19 { // w left, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 18];
[BlackPawnMoveDbl -> 18];
@@ -777,12 +755,11 @@
[BlackRightCastle -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 20 { // w right, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 21];
[WhitePawnMoveDbl -> 21];
@@ -800,12 +777,11 @@
[WhiteRightCastle -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 21 { // w right, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 20];
[BlackPawnMoveDbl -> 20];
@@ -823,12 +799,11 @@
[BlackRightCastle -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 22 { // w no, b right castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 23];
[WhitePawnMoveDbl -> 23];
@@ -845,12 +820,11 @@
[WhiteQueen -> 23];
[WhiteKing -> 23]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 23 { // w no, b right castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 22];
[BlackPawnMoveDbl -> 22];
@@ -868,12 +842,11 @@
[BlackRightCastle -> 30];
[BlackKing -> 30]
}
- LOC 24 { // w can, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
+LOC 24 { // w can, b no castle
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 25];
[WhitePawnMoveDbl -> 25];
@@ -892,12 +865,11 @@
[WhiteRightCastle -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 25 { // w can, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 24];
[BlackPawnMoveDbl -> 24];
@@ -914,12 +886,11 @@
[BlackQueen -> 24];
[BlackKing -> 24]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 26 { // w left, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 27];
[WhitePawnMoveDbl -> 27];
@@ -937,12 +908,11 @@
[WhiteLeftCastle -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 27 { // w left, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 26];
[BlackPawnMoveDbl -> 26];
@@ -959,12 +929,11 @@
[BlackQueen -> 26];
[BlackKing -> 26]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 28 { // w right, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 29];
[WhitePawnMoveDbl -> 29];
@@ -982,12 +951,11 @@
[WhiteRightCastle -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 29 { // w right, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 28];
[BlackPawnMoveDbl -> 28];
@@ -1004,12 +972,11 @@
[BlackQueen -> 28];
[BlackKing -> 28]
}
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
LOC 30 { // w no, b no castle
- PLAYER 1
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 1 {
+ PAYOFF :(CheckB()) - :(CheckW())
MOVES
[WhitePawnMove -> 31];
[WhitePawnMoveDbl -> 31];
@@ -1026,12 +993,11 @@
[WhiteQueen -> 31];
[WhiteKing -> 31]
}
+ PLAYER 2 { PAYOFF :(CheckW()) - :(CheckB()) }
+}
LOC 31 { // w no, b no castle
- PLAYER 2
- PAYOFF {
- 1: :(CheckB()) - :(CheckW());
- 2: :(CheckW()) - :(CheckB())
- }
+ PLAYER 2 {
+ PAYOFF :(CheckW()) - :(CheckB())
MOVES
[BlackPawnMove -> 30];
[BlackPawnMoveDbl -> 30];
@@ -1048,8 +1014,9 @@
[BlackQueen -> 30];
[BlackKing -> 30]
}
-MODEL [ | |
- ] "
+ PLAYER 1 { PAYOFF :(CheckB()) - :(CheckW()) }
+}
+MODEL [ | | ] "
... ... ... ...
bR bN.bB bQ.bK bB.bN bR.
... ... ... ...
Modified: trunk/Toss/examples/Connect4.toss
===================================================================
--- trunk/Toss/examples/Connect4.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Connect4.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -18,23 +18,24 @@
[a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P
pre not EmptyUnder (a) and not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
}
- MOVES [Cross -> 1]
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
}
- MOVES [Circle -> 0]
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
}
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+MODEL [ | P:1 {}; Q:1 {} | ] "
... ... ...
... ... ...
... ... ... ...
Modified: trunk/Toss/examples/Entanglement.toss
===================================================================
--- trunk/Toss/examples/Entanglement.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Entanglement.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -25,22 +25,17 @@
x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ]
emb R, C
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: 0.;
- 2: 0.
+ PLAYER 1 {
+ PAYOFF 0.
+ MOVES [Follow -> 1]; [Wait -> 1]
}
- MOVES
- [Follow -> 1];
- [Wait -> 1]
- }
+ PLAYER 2 { PAYOFF 0. }
+}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: 1.;
- 2: -1.
+ PLAYER 1 { PAYOFF 1. }
+ PLAYER 2 {
+ PAYOFF -1.
+ MOVES [Run -> 0]
}
- MOVES
- [Run -> 0]
}
MODEL [ d4, a2, a1, b1, b2, e4, c2, c1, f4, d2, d1, f1, f2, g1, g2, h1, h2, e1, e2, i1, i2 | C { (d4); (e4); (f4) }; E { (a2, a1); (a2, b2); (a1, a2); (a1, b1); (b1, a1); (b1, b2); (b1, c1); (b2, a2); (b2, b1); (b2, c2); (c2, b2); (c2, c1); (c2, d2); (c1, b1); (c1, c2); (c1, d1); (d2, c2); (d2, d1); (d2, e1); (d1, c1); (d1, d2); (d1, e2); (f1, f2); (f1, g1); (f1, e1); (f2, f1); (f2, g2); (f2, e2); (g1, f1); (g1, g2); (g1, h1); (g2, f2); (g2, g1); (g2, h2); (h1, g1); (h1, h2); (h1, i1); (h2, g2); (h2, h1); (h2, i2); (e1, d2); (e1, f1); (e1, e2); (e2, d1); (e2, f2); (e2, e1); (i1, h1); (i1, i2); (i2, h2); (i2, i1) }; R { (e1) }; _opt_C:1 { } | vx { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; vy { d4->0., a2->0., a1->0., b1->0., b2->0., e4->0., c2->0., c1->0., f4->0., d2->0., d1->0., f1->0., f2->0., g1->0., g2->0., h1->0., h2->0., e1->0., e2->0., i1->0., i2->0. }; x { d4->100., a2->-50., a1->-50., b1->0., b2->0., e4->150., c2->50., c1->50., f4->200., d2->100., d1->100., f1->200., f2->200., g1->250., g2->250., h1->300., h2->300., e1->150., e2->150., i1->350., i2->350. }; y { d4->-150., a2->-100., a1->-50., b1->-50., b2->-100., e4->0., c2->-100., c1->-50., f4->-150., d2->-100., d1->-50., f1->-100., f2->-50., g1->-100., g2->-50., h1->-100., h2->-50., e1->-100., e2->-50., i1->-100., i2->-50. } ]
Modified: trunk/Toss/examples/Gomoku.toss
===================================================================
--- trunk/Toss/examples/Gomoku.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Gomoku.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -1,5 +1,5 @@
PLAYERS 1, 2
-DATA r1: circle, r2: line, adv_ratio: 5, depth: 2
+DATA rCircle: circle, rCross: line, adv_ratio: 5, depth: 2
REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w)
REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w)
REL DiagA5 (x, y, z, v, w) =
@@ -23,23 +23,20 @@
[a1 | P:1 {}; Q (a1) | - ]
emb Q, P pre not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
}
- MOVES [Cross -> 1]
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
}
- MOVES [Circle -> 0]
}
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+MODEL [ | P:1 {}; Q:1 {} | ] "
... ... ... ...
... ... ... ...
... ... ... ...
Modified: trunk/Toss/examples/Gomoku19x19.toss
===================================================================
--- trunk/Toss/examples/Gomoku19x19.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Gomoku19x19.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -1,158 +1,42 @@
PLAYERS 1, 2
-RULE 1:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] ->
- [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- emb Q, P
- pre
- not
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- ex r, s, t, u
- (R(v, r) and C(r, w) and R(w, s) and C(s, x) and R(x, t) and C(t, y) and
- R(y, u) and
- C(u, z)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y, t) and
- R(y, u) and
- C(z, u))))
-RULE 2:
- [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] ->
- [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}]
- emb Q, P
- pre
- not
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- ex r, s, t, u
- (R(v, r) and C(r, w) and R(w, s) and C(s, x) and R(x, t) and C(t, y) and
- R(y, u) and
- C(u, z)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y, t) and
- R(y, u) and
- C(z, u))))
+DATA rCircle: circle, rCross: line, adv_ratio: 5, depth: 2
+REL Row5 (x, y, z, v, w) = R(x, y) and R(y, z) and R(z, v) and R(v, w)
+REL Col5 (x, y, z, v, w) = C(x, y) and C(y, z) and C(z, v) and C(v, w)
+REL DiagA5 (x, y, z, v, w) =
+ DiagA(x, y) and DiagA(y, z) and DiagA(z, v) and DiagA(v, w)
+REL DiagB5 (x, y, z, v, w) =
+ DiagB(x, y) and DiagB(y, z) and DiagB(z, v) and DiagB(v, w)
+REL Conn5 (x, y, z, v, w) =
+ Row5(x,y,z,v,w) or Col5(x,y,z,v,w) or DiagA5(x,y,z,v,w) or DiagB5(x,y,z,v,w)
+REL WinQ() =
+ ex x,y,z,v,w (Q(x) and Q(y) and Q(z) and Q(v) and Q(w) and Conn5(x,y,z,v,w))
+REL WinP() =
+ ex x,y,z,v,w (P(x) and P(y) and P(z) and P(v) and P(w) and Conn5(x,y,z,v,w))
+RULE Cross:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P (a1); Q:1 {} | - ]
+ emb Q, P pre not WinQ()
+RULE Circle:
+ [a1 | P:1 {}; Q:1 {} | - ]
+ ->
+ [a1 | P:1 {}; Q (a1) | - ]
+ emb Q, P pre not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1:
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- );
- 2:
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- )
- }
- MOVES [1 -> 1]
- }
+ PLAYER 1 {
+ PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1]
+ }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
+}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1:
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- );
- 2:
- :(
- ex v, w, x, y, z
- (Q(v) and Q(w) and Q(x) and Q(y) and Q(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- ) +
- -1. *
- :(
- ex v, w, x, y, z
- (P(v) and P(w) and P(x) and P(y) and P(z) and
- (C(v, w) and C(w, x) and C(x, y) and C(y, z) or
- R(v, w) and R(w, x) and R(x, y) and R(y, z) or
- ex r, s, t, u
- (C(r, w) and C(s, x) and C(t, y) and C(u, z) and R(v, r) and R(w,
- s) and R(x, t) and R(y, u)) or
- ex r, s, t, u
- (R(v, r) and C(w, r) and R(w, s) and C(x, s) and R(x, t) and C(y,
- t) and R(y, u) and C(z, u))))
- )
- }
- MOVES [2 -> 0]
- }
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 {
+ PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0]
+ }
+}
+MODEL [ | P:1 {}; Q:1 {} | ] "
.......................................................
. . . . . . . . . . . . . . . . . . .
Modified: trunk/Toss/examples/Pawn-Whopping.toss
===================================================================
--- trunk/Toss/examples/Pawn-Whopping.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Pawn-Whopping.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -135,22 +135,22 @@
...?
" emb wP, bP pre not WhiteEnds()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WhiteEnds()) - :(BlackEnds());
- 2: :(BlackEnds()) - :(WhiteEnds())
+ PLAYER 1 {
+ PAYOFF :(WhiteEnds()) - :(BlackEnds())
+ MOVES
+ [WhiteBeat -> 1]; [WhiteMove -> 1]; [WhiteMoveTwo -> 1];
+ [WhiteRightPassant -> 1]; [WhiteLeftPassant -> 1]
}
- MOVES [WhiteBeat -> 1]; [WhiteMove -> 1]; [WhiteMoveTwo -> 1];
- [WhiteRightPassant -> 1]; [WhiteLeftPassant -> 1]
+ PLAYER 2 { PAYOFF :(BlackEnds()) - :(WhiteEnds()) }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WhiteEnds()) - :(BlackEnds());
- 2: :(BlackEnds()) - :(WhiteEnds())
+ PLAYER 1 { PAYOFF :(WhiteEnds()) - :(BlackEnds()) }
+ PLAYER 2 {
+ PAYOFF :(BlackEnds()) - :(WhiteEnds())
+ MOVES
+ [BlackBeat -> 0]; [BlackMove -> 0]; [BlackMoveTwo -> 0];
+ [BlackRightPassant -> 0]; [BlackLeftPassant -> 0]
}
- MOVES [BlackBeat -> 0]; [BlackMove -> 0]; [BlackMoveTwo -> 0];
- [BlackRightPassant -> 0]; [BlackLeftPassant -> 0]
}
MODEL [ | | ] "
... ... ... ...
Modified: trunk/Toss/examples/Tic-Tac-Toe.toss
===================================================================
--- trunk/Toss/examples/Tic-Tac-Toe.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/Tic-Tac-Toe.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -15,23 +15,16 @@
RULE Circle:
[a | Q:1 {} | - ] -> [a | Q (a) | - ] emb Q, P pre not WinP()
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
- }
- MOVES [Cross -> 1]
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ())
+ MOVES [Cross -> 1] }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP()) }
}
LOC 1 {
- PLAYER 2
- PAYOFF {
- 1: :(WinP()) - :(WinQ());
- 2: :(WinQ()) - :(WinP())
- }
- MOVES [Circle -> 0]
+ PLAYER 1 { PAYOFF :(WinP()) - :(WinQ()) }
+ PLAYER 2 { PAYOFF :(WinQ()) - :(WinP())
+ MOVES [Circle -> 0] }
}
-MODEL [ | P:1 {}; Q:1 {} |
- ] "
+MODEL [ | P:1 {}; Q:1 {} | ] "
. . .
Modified: trunk/Toss/examples/bounce.toss
===================================================================
--- trunk/Toss/examples/bounce.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/bounce.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -18,13 +18,8 @@
(-1. * 0.)) + (-1. * 0.)) < 0)))
post true
LOC 0 {
- PLAYER 1
- PAYOFF {
- 1: 0.;
- 2: 0.
- }
- MOVES
- [Move, t: 3. -- 3. -> 0]
+ PLAYER 1 { PAYOFF 0. MOVES [Move, t: 3. -- 3. -> 0] }
+ PLAYER 2 { PAYOFF 0. }
}
MODEL [ 1, 2, 3 | G { (2, 3); (3, 2) } |
vx { 1->0., 2->0., 3->0. }; vy { 1->27., 2->0., 3->0. };
Modified: trunk/Toss/examples/rewriting_example.toss
===================================================================
--- trunk/Toss/examples/rewriting_example.toss 2011-04-16 14:56:40 UTC (rev 1413)
+++ trunk/Toss/examples/rewriting_example.toss 2011-04-16 21:05:20 UTC (rev 1414)
@@ -35,7 +35,10 @@
x(3) = 2. * x(2) - x(1);
x(2) = x(2);
x(1) = x(1)
-LOC 0 {PLAYER 1 PAYOFF {1: 0.; 2: 0.} MOVES [Rewrite, t: 1. -- 1. -> 0]}
+LOC 0 {
+ PLAYER 1 { PAYOFF 0. MOVES [Rewrite, t: 1. -- 1. -> 0] }
+ PLAYER 2 { PAYOFF 0. }
+}
MODEL
[1, 2, 3, 4, 5, 6, 7, 9, 10, 11 |
R (1, 2);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-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 00:39:20
|
Revision: 1412
http://toss.svn.sourceforge.net/toss/?rev=1412&view=rev
Author: lukaszkaiser
Date: 2011-04-16 00:39:14 +0000 (Sat, 16 Apr 2011)
Log Message:
-----------
Separating Server functions.
Modified Paths:
--------------
trunk/Toss/Server/Server.ml
Added Paths:
-----------
trunk/Toss/Server/ReqHandler.ml
Added: trunk/Toss/Server/ReqHandler.ml
===================================================================
--- trunk/Toss/Server/ReqHandler.ml (rev 0)
+++ trunk/Toss/Server/ReqHandler.ml 2011-04-16 00:39:14 UTC (rev 1412)
@@ -0,0 +1,118 @@
+(* Server for Toss Functions. *)
+
+let debug_level = ref 0
+
+
+(* 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 possibly_modifies_game = Arena.can_modify_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)) -> (
+ 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
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose effort
+ (fst state) (snd state) (Aux.unsome heur)) in
+ Play.cancel_timeout ();
+ (heur, game_modified, state, Move.move_gs_str state move,
+ gdl_transl, playclock)
+ )
+
+ | Aux.Left(Arena.ApplyRule (r_name, mtch, t, p) as req) ->
+ let (new_state, resp) = Arena.handle_request state req in
+ (g_heur, game_modified, new_state, resp, gdl_transl, playclock)
+
+ | Aux.Left req ->
+ let (new_state, resp) = Arena.handle_request state req in
+ (g_heur, game_modified || possibly_modifies_game req,
+ new_state, resp, gdl_transl, playclock)
+
+ | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) ->
+ Random.self_init ();
+ let old_force_competitive = !Heuristic.force_competitive in
+ Heuristic.force_competitive := true;
+ let new_state, params, new_gdl_transl =
+ GDL.initialize_game player game_descr startcl in
+ let effort, horizon, advr =
+ match params with
+ | Some (e,h,r) -> Some e, Some h, Some r
+ | None -> None, None, None in
+ let new_heur =
+ Heuristic.default_heuristic ~struc:(snd new_state).Arena.struc
+ ?advr (fst new_state) in
+ Heuristic.force_competitive := old_force_competitive;
+ let r = "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 5"
+ ^ "\r\n\r\nREADY" in
+ (Some new_heur, false, new_state, r, new_gdl_transl, playcl)
+
+ | Aux.Right (GDL.Play (_,actions)) | Aux.Right (GDL.Stop (_,actions)) as rq ->
+ let time_started = Unix.gettimeofday () in
+
+ let r_name, mtch =
+ GDL.translate_last_action gdl_transl state actions in
+
+ let new_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
+ let moves =
+ Move.gen_moves Move.cGRID_SIZE rules
+ (snd state).Arena.struc mv_loc in
+ let pos = (
+ try
+ for i = 0 to Array.length moves - 1 do
+ let mov = moves.(i) in
+ if r_name = mov.Move.rule && List.for_all
+ (fun (e, f) -> f = List.assoc e mov.Move.embedding) mtch then
+ raise (Found i)
+ done;
+ failwith "GDL Play request: action mismatched with play state"
+ with Found pos -> pos) in
+ let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
+ let (new_state_noloc, resp) = Arena.handle_request state req in
+ let new_loc = moves.(pos).Move.next_loc in
+ (fst new_state_noloc,
+ {snd new_state_noloc with Arena.cur_loc = new_loc})
+ ) else state in
+
+ let resp =
+ if (match rq with
+ | Aux.Right (GDL.Stop (_, actions)) -> true
+ | _ -> false) then
+ "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 4"
+ ^ "\r\n\r\nDONE"
+ else
+ let mov_msg =
+ let time_used = time_started -. Unix.gettimeofday () in
+ 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
+ | None -> failwith "no heuristic for gametree!" in
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose 5500
+ (fst state) (snd state) heur) in
+ GDL.translate_move gdl_transl state
+ move.Move.rule move.Move.embedding
+ ) else (
+ Gc.compact ();
+ GDL.noop_move gdl_transl (snd state)
+ ) in
+ 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)
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-04-15 18:34:16 UTC (rev 1411)
+++ trunk/Toss/Server/Server.ml 2011-04-16 00:39:14 UTC (rev 1412)
@@ -107,193 +107,20 @@
| Arena.SetLoc i -> i <> !expected_location
| r -> Arena.can_modify_game r
-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
let line = read_in_line in_ch in
let req = req_of_str line in
- let resp =
- match req with
-
- | Aux.Left (Arena.SuggestLocMoves
- (loc, timer, effort, how, horizon, heuristic,
- advr)) -> (
- Random.self_init ();
- ignore (Unix.alarm timer);
- Play.set_timeout (float(timer));
- let heur = match !game_modified, !g_heur with
- | false, Some h -> h
- | true, _ | _, None ->
- g_heur := Some (Heuristic.default_heuristic
- ~struc:(snd !state).Arena.struc
- ?advr (fst !state));
- Aux.unsome !g_heur in
- let (move, _) =
- Aux.random_elem (Play.maximax_unfold_choose effort
- (fst !state) (snd !state) heur) in
- Play.cancel_timeout ();
- Move.move_gs_str !state move
- )
-
- | Aux.Left (Arena.ApplyRule (r_name, mtch, t, p) as req) -> (
- if !game_modified then
- let (new_state, resp) = Arena.handle_request !state req in
- state := new_state; resp
- else
- (* trying to restore [Server.play_state] so as to avoid
- reinitialization *)
- let {Arena.rules=rules; graph=graph} = fst !state in
- let struc = (snd !state).Arena.struc in
- let fn s n = Structure.find_elem s n in
- let r = List.assoc r_name rules in
- let lhs =
- r.ContinuousRule.discrete.DiscreteRule.lhs_struc in
- let m =
- List.map (fun (l, s) -> (fn lhs l, fn struc s)) mtch 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! *)
- let mov = moves.(i) in
- if
- r_name = mov.Move.rule &&
- List.for_all (fun (e, f) ->
- f = List.assoc e mov.Move.embedding) m
- (* TODO: handle location matching *)
- then (
- expected_location := mov.Move.next_loc;
- let _ = if !debug_level > 2 then
- Printf.printf "expected_location = %d\n%!"
- !expected_location in
- raise (Found i))
- done;
- (* TODO: if not due to only time or params mismatch,
- block or warn about invalid rule application *)
- let (new_state, resp) =
- Arena.handle_request !state req in
- if !debug_level > 0 then
- Printf.printf "ApplyRule: mismatched with play state!\n%!";
- state := new_state; resp
- with Found pos ->
- let (new_state, resp) = Arena.handle_request !state req in
- (* Rewriting doesn't handle location update. *)
- let new_loc = moves.(pos).Move.next_loc in
- state := (fst new_state,
- {snd new_state with Arena.cur_loc = new_loc});
- resp
- )
-
- | Aux.Left req ->
- game_modified := !game_modified ||
- possibly_modifies_game req;
- let (new_state, resp) = Arena.handle_request !state req in
- state := new_state; resp
-
- | Aux.Right (GDL.Start (_, player, game_descr, startcl, playcl)) ->
- Random.self_init (); (* Random.init 1234; for repeatablity *)
- let old_force_competitive = !Heuristic.force_competitive in
- Heuristic.force_competitive := true;
- let new_state, params, new_gdl_transl =
- GDL.initialize_game player game_descr startcl in
- state := new_state; gdl_transl := new_gdl_transl;
- let effort, horizon, advr =
- match params with
- | Some (e,h,r) -> Some e, Some h, Some r
- | None -> None, None, None in
- game_modified := false;
- playclock := playcl;
- g_heur := Some (Heuristic.default_heuristic
- ~struc:(snd !state).Arena.struc
- ?advr (fst !state));
- Heuristic.force_competitive := old_force_competitive;
- "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 5"
- ^ "\r\n\r\nREADY"
-
-
- | Aux.Right (GDL.Play (_, actions))
- | Aux.Right (GDL.Stop (_, actions)) ->
- let r_name, mtch =
- GDL.translate_last_action !gdl_transl !state actions in
-
- 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 mv_loc in
- let pos =
- (try
- for i = 0 to Array.length moves - 1 do
- (* FIXME: handle time and params! *)
- let mov = moves.(i) in
- (* {{{ log entry *)
- if !debug_level > 3 then (
- Printf.printf "GDL: for %s considering move %s\n%!"
- r_name (Move.move_gs_str !state mov)
- );
- (* }}} *)
- if
- r_name = mov.Move.rule &&
- List.for_all (fun (e, f) ->
- f = List.assoc e mov.Move.embedding) mtch
- (* TODO: handle location matching *)
- then (
- expected_location := mov.Move.next_loc;
- let _ = if !debug_level > 2 then
- Printf.printf "expected_location = %d\n%!"
- !expected_location in
- raise (Found i))
- done;
- (* TODO: if not due to only time or params mismatch,
- block or warn about invalid rule application *)
-
- failwith
- "Server GDL Play request: action mismatched with play state"
- with Found pos -> pos) in
- let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
- let (new_state, resp) = Arena.handle_request !state req in
- (* Rewriting doesn't handle location update. *)
- let new_loc = moves.(pos).Move.next_loc in
- state := (fst new_state,
- {snd new_state with Arena.cur_loc = new_loc});
- );
-
- if (match req with
- | Aux.Right (GDL.Stop (_, actions)) -> true
- | _ -> false) then
- "HTTP/1.0 200 OK\r\nContent-type: text/acl\r\nContent-length: 4"
- ^ "\r\n\r\nDONE"
- else
- let mov_msg =
- if GDL.our_turn !gdl_transl !state then (
- let time_used = time_started -. Unix.gettimeofday () in
- Play.set_timeout (float(!playclock) -. time_used -. 0.07);
- let heur = match !g_heur with
- | Some h -> h
- | None -> failwith "no heuristic for gametree!" in
- let (move, _) =
- Aux.random_elem (Play.maximax_unfold_choose 5500
- (fst !state) (snd !state) heur) in
- GDL.translate_move !gdl_transl !state
- move.Move.rule move.Move.embedding
- ) else (
- Gc.compact ();
- GDL.noop_move !gdl_transl (snd !state)
- ) in
- 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
+ let (new_gheur, new_modified, new_state, resp, n_gdl_t, n_playclock) =
+ ReqHandler.req_handle !g_heur !game_modified !state !gdl_transl
+ !playclock req in
+ g_heur := new_gheur;
+ game_modified := new_modified;
+ state := new_state;
+ gdl_transl := n_gdl_t;
+ playclock := n_playclock;
if !debug_level > 0 then (
Printf.printf "Resp-time: %F\n%!" (Unix.gettimeofday() -. time_started);
print_endline ("\nRepl: " ^ resp ^ "\n");
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-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-14 01:58:34
|
Revision: 1409
http://toss.svn.sourceforge.net/toss/?rev=1409&view=rev
Author: lukaszkaiser
Date: 2011-04-14 01:58:27 +0000 (Thu, 14 Apr 2011)
Log Message:
-----------
More work on PlayTest and GameTree stability.
Modified Paths:
--------------
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Play/GameTree.ml
trunk/Toss/Play/GameTree.mli
trunk/Toss/Play/Play.ml
trunk/Toss/Play/Play.mli
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
Removed Paths:
-------------
trunk/Toss/Play/Game.mli
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Formula/Aux.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -211,6 +211,11 @@
| hd::tl -> hd::(remove_one e tl)
| [] -> []
+let rec remove_last = function
+ | [] -> raise Not_found
+ | [_] -> []
+ | x :: xs -> x :: (remove_last xs)
+
let rec insert_nth n e = function
| l when n<=0 -> e::l
| [] -> raise Not_found
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Formula/Aux.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -136,6 +136,9 @@
(** Remove an occurrence of a value (uses structural equality). *)
val remove_one : 'a -> 'a list -> 'a list
+(** Remove the last element in a list; raise Not_found for []. *)
+val remove_last : 'a list -> 'a list
+
(** Insert as [n]th element of a list (counting from zero). Raise
[Not_found] if the list has less than [n] elements (e.g. inserting
0th element to empty list is OK). *)
Deleted: trunk/Toss/Play/Game.mli
===================================================================
--- trunk/Toss/Play/Game.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Game.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -1,196 +0,0 @@
-(** Game-related definitions. The UCTS algorithm. *)
-
-(** Default effort used in {!Game.initialize_default} when not
- otherwise specified. *)
-val default_effort : int ref
-
-(** A global "hurry up!" switch triggered by the timer alarm. *)
-val get_timeout : unit -> bool
-val cancel_timeout : unit -> unit
-
-(** History stored for a play, including caching of computations for
- further use. *)
-type memory
-
-(** Effect that heuristics have on the MCTS algorithm. *)
-type mcts_heur_effect =
- | Heuristic_local of float (** TODO: not implemented *)
- (** each tree node only considers the heuristic of its state,
- the parameter is the influence of the heuristic on the tree
- traversal, there is no influence on the actual choice *)
- | Heuristic_mixed of float * float
- (** a node stores a heuristic maximaxed from the leaf states of
- the subtree, [MaximaxMixed (trav, select)] has [trav]
- the influence on the tree traversal, [select] the influence
- on the actual choice *)
- | Heuristic_select of float
- (** a node stores a heuristic maximaxed from the leaf states of
- the subtree, the parameter is the influence on the tree
- traversal, the actual choice is based on the heuristic alone
- and not the Monte-Carlo payoff estimates *)
- | Heuristic_only
- (** a node stores a heuristic maximaxed from the leaf states of
- the subtree, which completely replaces the role of the
- Monte-Carlo payoff estimates from the standard UCT algorithm *)
-
-
-
-(** Parameters of the Upper Confidence Bounds-based Monte Carlo Tree
- Search. Cooperative (competitive) mode means that of actions with
- equal value for a given player, the one with highest (lowest) sum
- of values is chosen. *)
-type uct_params = {
- cUCB : float ; (** coefficient of the confidence bound component *)
- constK : float ; (** smoothening *)
- iters : int ; (** tree updates per move *)
- horizon : int option ; (** limit on the playout length *)
- heur_effect : mcts_heur_effect ; (** maximaxed vs local heuristic *)
- cooperative : bool ; (** cooperative vs competitive *)
- cLCB : float option ; (** cautious action picking; if present, use
- lower confidence bound with given
- coefficient for action selection *)
-}
-
-
-(** An evaluation game is a set of games specific to locations, each
- game is used to assess the value of its location. It contains the
- same data as {!play} plus {!play_state} (for initial state) below,
- only without the [model] and [time] fields, and with some general
- playout parameters. *)
-type evgame_loc = {
- ev_game : Arena.game;
- ev_agents : agent array;
- ev_delta : float;
- ev_location : int;
- ev_memory : memory array;
- ev_horizon : int option;
-}
-and evaluation_game = evgame_loc array
-
-(** How does a player pick moves. *)
-and agent =
- | Random_move
- (** select a random move; avoids rewriting all matches and
- calling evaluation games *)
- | Maximax_evgame of evaluation_game * bool * int * bool
- (** select a move according to evaluation games played in each leaf
- state; in a cooperative/competitive way (see {!uct_params});
- expand the full game subtree to the given depth and propagate
- evaluation game results from leaves by taking
- cooperative/competitive best move for location's player; optional
- alpha-beta-like pruning with move reordering based on
- afterstate heuristic value *)
- | Tree_search of evaluation_game * int option * uct_params * agent array
- (** Monte-Carlo tree search; uses the evaluation game to compute
- heuristic values for use within the tree *)
- | External of (string array -> int)
- (** take an array of string representations of resulting
- structures and return the position of the desired state; for
- interacting with external players only *)
-
-(** The evolving state of a play. *)
-type play_state = {
- game_state : Arena.game_state ;
- memory : memory array ; (** player-specific history *)
-}
-
-(** Data defining a play (without the initial play state). *)
-type play = {
- game : Arena.game ; (** the game played *)
- agents : agent array ; (** location.id-indexed *)
- delta : float ; (** expected width of payoffs *)
-}
-
-(** Initial state of the game given a play definition and initial
- structure, assuming the game starts in location at position 0 of
- {!Arena.game}. *)
-val initial_state : ?loc:int -> play -> Structure.structure -> play_state
-
-val default_params : uct_params
-
-(** An UCT-based agent that uses either random playouts (when
- [random_playout] is set to true) or the same location-dependent
- heuristic as an evaluation game as given for the inside-tree
- (including unevaluated tips) calculation. *)
-val default_treesearch : Structure.structure ->
- iters:int -> ?heuristic:Formula.real_expr array array ->
- ?advr:float ->
- ?random_playout:bool -> ?playout_mm_depth:int ->
- ?heur_effect:mcts_heur_effect -> ?horizon:int ->
- Arena.game -> agent
-
-
-(** Plain limited depth maximax tree search. *)
-val default_maximax : Structure.structure -> depth:int ->
- ?heuristic:Formula.real_expr array array ->
- ?advr:float -> ?pruning:bool ->
- Arena.game -> agent
-
-
-(** Update "memory" assuming that the position given corresponds to a
- move selected, as generated by {!gen_moves}. With tree search,
- selects the corresponding subtree of a tree. *)
-val update_memory : num_players:int -> Arena.game_state -> int ->
- memory array -> memory array
-
-(** Make a move in a play, or compute the payoff table when the game
- ended. Return the move chosen and the moves considered. One can
- use only the {!move} to suggest a move, or only the updated
- {!play_state} to follow a move (or both). Note that some
- computations are cached across play states, but that memory is not
- stored in the suggested move. If [just_payoffs] is given true,
- just compute the payoff table without computing available
- moves. *)
-val toss :
- grid_size:int -> ?just_payoffs:bool ->
- play -> play_state ->
- (int * Move.move array * memory array * play_state,
- float array) Aux.choice
-
-(** Play a play, by applying {!toss}, till the end. Return the final
- structure and its payoff. Discretize continuous move parameters
- using [grid_size] nodes per parameter. Limit the length of a play
- that started [plys] ago to no more than [horizon] steps
- overall.
-
- The [set_timer] should be only provided for standalone plays. For
- suggestions, the timer is set by {!Server}. It limits time per
- move, given in seconds. *)
-val play :
- grid_size:int -> ?set_timer:int -> ?horizon:int -> ?plys:int ->
- play -> play_state -> Structure.structure * float array
-
-(** Initialize a play. Optionally, take heuristics for use as simple
- evaluation games -- if not given, heuristics are derived from
- payoffs by {!Heuristic.of_payoff}. Moves suggested using given
- search method ("maximax", "alpha_beta", "alpha_beta_ord",
- "uct_random_playouts",
- "uct_greedy_playouts", "uct_maximax_playouts", "uct_no_playouts").
-
- Construct a default UCT tree search or plain maximax agent for use
- with the general {!toss} function. *)
-val initialize_default :
- Arena.game * Arena.game_state -> ?loc:int -> ?effort:int ->
- search_method:string -> ?horizon:int -> ?advr:float ->
- ?payoffs_already_tnf:bool ->
- ?heuristic:Formula.real_expr array array ->
- unit -> play * play_state
-
-(** Suggest a (currently, single) move for a state, return the same
- state but with accrued computation (i.e. bigger stored search
- trees). *)
-val suggest : ?effort:int ->
- play -> play_state -> (Move.move * play_state) option
-
-
-(* ------------------------- DEBUGGING ------------------------------------- *)
-
-(** Debugging information. At level 0 nothing is printed out.
- At level 1, we print only the number of iterations which passed.
- If > 1, print the updated gametree at each move using
- treesearch. *)
-val set_debug_level : int -> unit
-
-(** If true, do not randomize the final choice of move. Useful mostly
- for debugging. *)
-val deterministic_suggest : bool ref
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/GameTree.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -220,10 +220,9 @@
~choice:(choice_f heur (choice stop_vals))
(* Choose one of the maximizing moves (at random) given a game tree. *)
-let choose_move game = function
+let choose_moves game = function
| Terminal _ -> raise Not_found
- | Leaf (state, _, _) ->
- Aux.random_elem (Array.to_list (Move.list_moves game state))
+ | Leaf (state, _, _) -> Array.to_list (Move.list_moves game state)
| Node (_, p, info, succ) ->
let cmp (_, c1) (_, c2) =
let nval child = (node_values child).(p) in
@@ -236,19 +235,19 @@
Aux.array_find_all (fun (_,c) -> (node_values c).(p) = mval) succ in
let nonleaf = function Leaf _ -> false | _ -> true in
let move_s (m, n) = Move.move_gs_str_short (state n) m in
- if !debug_level > 0 then print_endline
+ if !debug_level > 2 then print_endline
("\nBest Moves: " ^ (String.concat ", " (List.map move_s maxs)));
if List.exists (fun x -> nonleaf (snd x)) maxs then (
- let (m, t) = Aux.random_elem maxs in (m, state t)
+ List.map (fun (m, t) -> (m, state t)) maxs
) else ( (* Do *not* take a shallow leaf if possible. *)
let nonleaves = Aux.array_find_all (fun (_,c) -> nonleaf c) succ in
if nonleaves = [] then (
- let (m, t) = Aux.random_elem maxs in (m, state t)
+ List.map (fun (m, t) -> (m, state t)) maxs
) else (
let upd_max mv (_, c) = max mv (node_values c).(p) in
let sx = (node_values (snd (List.hd nonleaves))).(p) in
let mx = List.fold_left upd_max sx nonleaves in
let mxs = List.filter (fun (_,c) -> (node_values c).(p)=mx) nonleaves in
- let (m, t) = Aux.random_elem mxs in (m, state t)
+ List.map (fun (m, t) -> (m, state t)) mxs
)
)
Modified: trunk/Toss/Play/GameTree.mli
===================================================================
--- trunk/Toss/Play/GameTree.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/GameTree.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -76,8 +76,9 @@
val node_info : 'a game_tree -> 'a
-(** Choose one of the maximizing moves (at random) given a game tree. *)
-val choose_move : Arena.game -> 'a game_tree -> Move.move * Arena.game_state
+(** Choose all maximizing moves given a game tree. *)
+val choose_moves : Arena.game -> 'a game_tree ->
+ (Move.move * Arena.game_state) list
(** Game tree initialization. *)
Modified: trunk/Toss/Play/Play.ml
===================================================================
--- trunk/Toss/Play/Play.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Play.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -46,31 +46,50 @@
~info_node:(maxdepth_node) ~choice:(maximax_depth_choice ab)
(* Maximax unfolding upto depth. *)
-let rec unfold_maximax_upto ?(ab=false) count game heur t =
- if count = 0 || timed_out () then t else
+let rec unfold_maximax_upto ?(ab=false) count game heur (t, pmvs) =
+ let mvs = (choose_moves game t) :: pmvs in
+ if count = 0 || timed_out () then (t, mvs) else
try
let u = unfold_maximax ~ab:ab game heur t in
if !debug_level > 0 then Printf.printf "%d,%!" (size u);
- unfold_maximax_upto ~ab:ab (count-1) game heur u
+ if !debug_level > 1 then (
+ let move_s (m, n) = Move.move_gs_str_short n m in
+ let mstr = String.concat ", " (List.map move_s (List.hd mvs)) in
+ Printf.printf "(%s),%!" mstr
+ );
+ unfold_maximax_upto ~ab:ab (count-1) game heur (u, mvs)
with
- | Not_found -> t
+ | Not_found -> (t, mvs)
| Aux.Timeout msg ->
if !debug_level > 0 then
- if !debug_level > 0 then Printf.printf "Timeout %f (%s)%!"
+ Printf.printf "Timeout %f (%s)%!"
(Unix.gettimeofday() -. !timeout) msg;
- t
+ (t, mvs)
(* Maximax unfold upto depth and choose move. *)
-let maximax_unfold_choose count game state heur =
+let maximax_unfold_choose ?(check_stable=3) count game state heur =
let ab = Heuristic.is_constant_sum heur in (* TODO: payoffs as well! *)
if !debug_level > 0 then Printf.printf "Using Alpha-Beta: %B\n%!" ab;
if !debug_level > 3 then
Array.iter (fun h -> Array.iter Formula.print_real h) heur;
let t = init game state (fun _ _ _ -> 0) heur in
- let u = unfold_maximax_upto ~ab count game heur t in
- if !debug_level > 1 then
- print_endline (str ~upto:1 ~struc:false string_of_int u);
- choose_move game u
+ try
+ let (u, mvs) = unfold_maximax_upto ~ab count game heur (t, []) in
+ let nbr_to_check = min (2*check_stable + 1) (List.length mvs / 3) in
+ let last_mvs = Aux.take_n (max 1 nbr_to_check) mvs in
+ if !debug_level = 2 then
+ print_endline (str ~upto:1 ~struc:false string_of_int u);
+ if !debug_level > 2 then
+ print_endline (str ~upto:(!debug_level-1) string_of_int u);
+ let rec ord_sub = function
+ | ([], _) -> true
+ | (x :: xs, []) -> false
+ | (x :: xs, y :: ys) when x = y -> ord_sub (xs, ys)
+ | (x :: xs, y :: ys) -> ord_sub (x :: xs, ys) in
+ let nbr mv = List.length (List.filter (fun m -> ord_sub (mv,m)) last_mvs) in
+ let mvs_votes = List.map (fun m -> (m, nbr m)) last_mvs in
+ fst (List.hd (List.stable_sort (fun (_, i) (_, j) -> j - i) mvs_votes))
+ with Not_found -> []
(* -------------------- UCT ------------------ *)
@@ -117,8 +136,8 @@
if parent_sc.score_obs = 0 then failwith
"ucb1_tuned: parent has no observations";
let cHEUR = match params.heur_effect with
- | (c, _) when not lower_bound -> c
- | (_, c) when lower_bound -> c in
+ | (_, c) when lower_bound -> c
+ | (c, _) -> c in
let i2f = float_of_int in
let tot = i2f parent_sc.score_obs in
let vari = score.variation_table.(player) in
Modified: trunk/Toss/Play/Play.mli
===================================================================
--- trunk/Toss/Play/Play.mli 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/Play.mli 2011-04-14 01:58:27 UTC (rev 1409)
@@ -13,11 +13,13 @@
int GameTree.game_tree -> int GameTree.game_tree
-(** Maximax unfolding upto depth. *)
+(** Maximax unfolding upto depth, keep previous moves for stability. *)
val unfold_maximax_upto : ?ab:bool -> int -> Arena.game ->
Formula.real_expr array array ->
- int GameTree.game_tree -> int GameTree.game_tree
+ int GameTree.game_tree * (Move.move * Arena.game_state) list list ->
+ int GameTree.game_tree * (Move.move * Arena.game_state) list list
(** Maximax unfold upto depth and choose move. *)
-val maximax_unfold_choose : int -> Arena.game -> Arena.game_state ->
- Formula.real_expr array array -> Move.move * Arena.game_state
+val maximax_unfold_choose : ?check_stable:int -> int -> Arena.game ->
+ Arena.game_state -> Formula.real_expr array array ->
+ (Move.move * Arena.game_state) list
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Play/PlayTest.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -25,24 +25,27 @@
let test_maximax ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
- ~iters gname ?(msg="") ?(nomove=false) check_fun =
- let (g, s) = state_of_file ("./examples/"^gname^".toss") ~struc ~time ~loc in
+ ~iters ~game ?(msg="") ?(nomove=false) cond =
+ let (g, s) = state_of_file ("./examples/"^game^".toss") ~struc ~time ~loc in
GameTree.set_debug_level debug;
Play.set_debug_level debug;
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr g in
- try
- let (m, ns) = Play.maximax_unfold_choose iters g s h in
- let move_str = Move.move_gs_str_short s m in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str) (check_fun move_str)
- with Not_found ->
- if nomove then assert_bool "No Move: Test Passed" true else
- assert_bool "No Move: Test Failed!" false
+ let res_mvs = Play.maximax_unfold_choose iters g s h in
+ if res_mvs <> [] then
+ List.iter (fun (m, ns) ->
+ let move_str = Move.move_gs_str_short s m in
+ assert_bool
+ (Printf.sprintf "%s: Failed move: %s." msg move_str) (cond move_str)
+ ) res_mvs
+ else if nomove then
+ assert_bool "No Move: Test Passed" true
+ else
+ assert_bool "No Move: Test Failed!" false
-let test_algo algo ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
- ~iters gname ?(msg="") ?(nomove=false) check_fun =
+let test_algo algo ~game ~iters ?(advr=4.) ?(debug=0)
+ ?(struc="") ?(time=0.) ?(loc=0) ?(nomove=false) ?(msg="") cond =
if algo = "Maximax" then
- test_maximax ~debug ~advr ~struc ~time ~loc ~iters gname ~nomove check_fun
+ test_maximax ~debug ~advr ~struc ~time ~loc ~iters ~game ~nomove ~msg cond
else failwith "Unsupported play algorithm"
@@ -68,27 +71,21 @@
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr:4. g in
let t = GameTree.init g s (fun _ _ _ -> 0) h in
- let u = Play.unfold_maximax_upto 50 g h t in
+ let (u, _) = Play.unfold_maximax_upto 50 g h (t, []) in
(* print_endline (GameTree.str string_of_int u); *)
assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u);
- let u1 = Play.unfold_maximax_upto ~ab:true 50 g h t in
+ let (u1, _) = Play.unfold_maximax_upto ~ab:true 50 g h (t, []) in
(* print_endline (GameTree.str string_of_int u1); *)
assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u1);
);
- "checkers suggest first move 5 iters" >::
- (fun () ->
- test_maximax "Checkers" ~debug:0 ~iters:5
- ~msg:"make any first move in checkers after 5 iters" (fun s -> true)
- );
]
let tictactoe_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters
- "Tic-Tac-Toe" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Tic-Tac-Toe" ~iters ~advr:5. in
("Tic-Tac-Toe (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
"basic defense" >::
@@ -192,9 +189,8 @@
]
let breakthrough_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:2. ~struc ~time ~loc ~iters
- "Breakthrough" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Breakthrough" ~iters ~advr:2. in
("Breakthrough (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
"avoid endgame" >::
@@ -325,119 +321,16 @@
let gomoku8x8_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters
- "Gomoku" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Gomoku" ~iters ~advr:5. in
("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
- "avoid endgame 1" >::
+ "simple attack" >::
(fun () ->
let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- Q.. P..P ... ...
- ... ... ... ...
- ...Q ... ... ...
- ... ... ... ...
- Q.. ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block"
- (fun mov_s -> "Cross{1:b5}" = mov_s)
- );
-
- "avoid endgame 2" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... Q..Q Q.. ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... P..P ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block with line"
- (fun mov_s -> "Cross{1:f7}" = mov_s);
- );
-
-
- "block gameover" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... P.. ... ...
- ... ... ... ...
- ... ...P P..Q ...
- ... ... ... ...
- ... P..P ...Q ...
- ... ... ... ...
- ...Q Q..Q Q..P ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block"
- (fun mov_s -> "Cross{1:a3}" = mov_s);
- );
-
-
- "more pieces" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- P ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ...P Q..Q Q.. ...
- ... ... ... ...
- ...Q Q..Q P..P ...
- ... ... ... ...
- Q..Q P..Q P.. ...
- ... ... ... ...
- ...P Q..P ...P ...
- ... ... ... ...
- ...P ... P.. ...
- ... ... ... ...
- ... ... ...Q ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should block the open line"
- (fun mov_s -> "Cross{1:e7}" = mov_s);
- );
-
- "attack" >::
- (fun () ->
- let struc = "MODEL [ | | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
... ...Q ... ...
... ... ... ...
... P..Q P.. ...
@@ -456,13 +349,13 @@
test_do ~struc ~loc:0 ~msg:"P should attack the diagonal"
(fun mov_s -> "Cross{1:d4}" = mov_s);
);
+
]
let connect4_tests algo iters =
- let test_do ?(struc="") ?(time=0.) ?(loc=0) ?(msg="") check_f =
- test_algo algo ~debug:0 ~advr:5. ~struc ~time ~loc ~iters
- "Connect4" ~msg check_f in
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Connect4" ~iters ~advr:5. ~debug:0 in
("Connect4 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
"simple attack" >::
@@ -507,7 +400,7 @@
(fun mov_s -> "Cross{1:f3}" <> mov_s);
);
- "endgame" >::
+ (Printf.sprintf "endgame (%i iters)" (30*iters)) >::
(fun () ->
let struc = "MODEL [ | | ] \"
@@ -524,73 +417,152 @@
P P P Q Q . .
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_do ~struc ~loc:0 ~msg:"P should defend"
+ test_do ~iters:(30*iters) ~struc ~loc:0 ~msg:"P should defend"
(fun mov_s -> "Cross{1:e2}" = mov_s);
);
]
+let checkers_tests algo iters =
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Checkers" ~iters ~advr:2. in
+ ("Checkers (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "any first move" >::
+ (fun () ->
+ test_do ~msg:"make any first move" (fun s -> true)
+ );
+ ]
+
+
+
let tests = "Play" >::: [
basic_tests;
- tictactoe_tests "Maximax" 3;
- breakthrough_tests "Maximax" 5;
+ tictactoe_tests "Maximax" 4;
+ breakthrough_tests "Maximax" 6;
gomoku8x8_tests "Maximax" 4;
- connect4_tests "Maximax" 7;
+ connect4_tests "Maximax" 4;
+ checkers_tests "Maximax" 4;
]
(* ----------------- BIG TESTS ------------- *)
-let chess_tests_big = "ChessBig" >::: [
- "random first move" >::
- (fun () ->
- test_maximax "Chess" ~debug:0 ~iters:0
- ~msg:"make any first move in chess" (fun s -> true)
- );
-
- "first move 1 iter" >::
- (fun () ->
- test_maximax "Chess" ~debug:0 ~iters:1
- ~msg:"make a selected first move in chess" (fun s -> true)
- );
+let gomoku8x8_tests_big algo iters =
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Gomoku" ~advr:5. ~iters in
+ ("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
- "detect draw" >::
- (fun () ->
- let struc =
-"MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+ "avoid endgame 1" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
- ... ... +bN ...
+ ... ... ... ...
... ... ... ...
... ... ... ...
... ... ... ...
- ... bP. ...-bNwK.
+ ... ...P ... ...
... ... ... ...
- ...bP ... ... ...
+ ... ... ... ...
... ... ... ...
- bR. ... ...bQ ...
+ Q.. P..P ... ...
... ... ... ...
- ... ...bK ... ...bP
+ ...Q ... ... ...
... ... ... ...
+ Q.. ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block"
+ (fun mov_s -> "Cross{1:b5}" = mov_s)
+ );
+
+ "avoid endgame 2" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
+ ... ... ... ...
... ... ... ...
+ ... Q..Q Q.. ...
+ ... ... ... ...
+ ... ...P ... ...
... ... ... ...
-\" with
-D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
-D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
- test_maximax "Chess" ~debug:0 ~iters:1 ~struc
- ~msg:"detect draw in chess" ~nomove:true (fun _ -> false)
- );
-]
+ ... ... ... ...
+ ... ... ... ...
+ ... P..P ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block with line"
+ (fun mov_s -> "Cross{1:f7}" = mov_s);
+ );
-let gomoku_tests_big = "GomokuBig" >::: [
- "maximax suggest defense 1" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+
+ "block gameover" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... P.. ... ...
+ ... ... ... ...
+ ... ...P P..Q ...
+ ... ... ... ...
+ ... P..P ...Q ...
+ ... ... ... ...
+ ...Q Q..Q Q..P ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block"
+ (fun mov_s -> "Cross{1:a3}" = mov_s);
+ );
+
+
+ "more pieces" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
+ ... ... ... ...
+ P ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ...P Q..Q Q.. ...
+ ... ... ... ...
+ ...Q Q..Q P..P ...
+ ... ... ... ...
+ Q..Q P..Q P.. ...
+ ... ... ... ...
+ ...P Q..P ...P ...
+ ... ... ... ...
+ ...P ... P.. ...
+ ... ... ... ...
+ ... ... ...Q ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should block the open line"
+ (fun mov_s -> "Cross{1:e7}" = mov_s);
+ );
+
+ "defense 1" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
... ...P ... ...
... ... ... ...
... P.. ... ...
@@ -605,14 +577,14 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:160
- (fun s -> s = "Circle{1:d8}");
- );
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:1 ~msg:"Q should defend"
+ (fun s -> s = "Circle{1:d8}");
+ );
- "maximax suggest defense 2" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ "defense 2" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
... ... ... ...
P.. ... ... ...
... ... ... ...
@@ -630,14 +602,14 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:180
- (fun s -> s = "Circle{1:e1}");
- );
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:1 ~msg:"Q should defend"
+ (fun s -> s = "Circle{1:e1}");
+ );
- "maximax suggest defense 3" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ "stability under iterations (long)" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
@@ -655,16 +627,92 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:210
- (fun s -> s = "Circle{1:b6}");
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:1 ~iters:212 ~debug:0 ~msg:"Q should defend"
+ (fun s -> s = "Circle{1:b6}");
+ );
+
+ ]
+
+
+
+let connect4_tests_big algo (i_from, i_to, i_step) =
+ let test_do = test_algo algo ~game:"Connect4" ~advr:5. ~debug:0 in
+ let rec range f t s = if t < f then [] else f :: (range (f+s) t s) in
+ let create_tests test_create_f =
+ (Printf.sprintf "Connect4 (%s %i-%i by %i)" algo i_from i_to i_step) >:::
+ (List.concat (List.map test_create_f (range i_from i_to i_step))) in
+ let make_test i =
+ [(Printf.sprintf "endgame (%i)" i) >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
+
+ . . . . . . .
+
+ . . . . . . .
+
+ Q . . . . . .
+
+ P . . . . . .
+
+ P . +Q Q . . .
+
+ P P P Q Q . .
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~iters:i ~msg:"P should defend"
+ (fun mov_s -> "Cross{1:e2}" = mov_s);
+ );] in
+ create_tests make_test
+
+
+let chess_tests_big algo iters =
+ let test_do ?(iters=iters) =
+ test_algo algo ~game:"Chess" ~advr:2. ~iters in
+ ("Chess (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "random first move" >::
+ (fun () ->
+ test_do ~iters:0 ~msg:"make a random first move" (fun s -> true)
+ );
+
+ "select any first move" >::
+ (fun () ->
+ test_do ~msg:"make any selected first move" (fun s -> true)
+ );
+
+ "detect draw" >::
+ (fun () ->
+ let struc =
+ "MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+ ... ... ... ...
+ ... ... +bN ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... bP. ...-bNwK.
+ ... ... ... ...
+ ...bP ... ... ...
+ ... ... ... ...
+ bR. ... ...bQ ...
+ ... ... ... ...
+ ... ...bK ... ...bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with
+D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
+D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
+ test_do ~struc ~msg:"detect draw" ~nomove:true (fun _ -> false)
);
]
let bigtests = "PlayBig" >::: [
- chess_tests_big;
- gomoku_tests_big;
+ connect4_tests_big "Maximax" (100, 300, 10);
+ gomoku8x8_tests_big "Maximax" 6;
+ chess_tests_big "Maximax" 1;
]
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-04-13 17:14:22 UTC (rev 1408)
+++ trunk/Toss/Server/Server.ml 2011-04-14 01:58:27 UTC (rev 1409)
@@ -130,8 +130,9 @@
~struc:(snd !state).Arena.struc
?advr (fst !state));
Aux.unsome !g_heur in
- let (move, _) = Play.maximax_unfold_choose effort
- (fst !state) (snd !state) heur in
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose effort
+ (fst !state) (snd !state) heur) in
Play.cancel_timeout ();
Move.move_gs_str !state move
)
@@ -178,17 +179,11 @@
Printf.printf "ApplyRule: mismatched with play state!\n%!";
state := new_state; resp
with Found pos ->
- let old_struc = (snd !state).Arena.struc in
let (new_state, resp) = Arena.handle_request !state req in
(* Rewriting doesn't handle location update. *)
let new_loc = moves.(pos).Move.next_loc in
state := (fst new_state,
{snd new_state with Arena.cur_loc = new_loc});
- let new_game_state = {
- Arena.struc = (snd new_state).Arena.struc;
- cur_loc = moves.(pos).Move.next_loc;
- time = (snd new_state).Arena.time;
- } in
resp
)
@@ -258,7 +253,6 @@
failwith
"Server GDL Play request: action mismatched with play state"
with Found pos -> pos) in
- let old_struc = (snd !state).Arena.struc in
let req = Arena.ApplyRuleInt (r_name, mtch, 0.1, []) in
let (new_state, resp) = Arena.handle_request !state req in
(* Rewriting doesn't handle location update. *)
@@ -280,8 +274,9 @@
let heur = match !g_heur with
| Some h -> h
| None -> failwith "no heuristic for gametree!" in
- let (move, _) = Play.maximax_unfold_choose 5500
- (fst !state) (snd !state) heur in
+ let (move, _) =
+ Aux.random_elem (Play.maximax_unfold_choose 5500
+ (fst !state) (snd !state) heur) in
GDL.translate_move !gdl_transl !state
move.Move.rule move.Move.embedding
) else (
@@ -359,7 +354,10 @@
failwith "only 2-player games supported in experiments for now" in
let timeo = if pl = 0 then !exp_p1_timeout else !exp_p2_timeout in
let heur = if pl = 0 then heur1 else heur2 in
- let (_, s) = Play.maximax_unfold_choose depth game !cur_state heur in
+ Play.set_timeout (float timeo);
+ let (_, s) =
+ Aux.random_elem (Play.maximax_unfold_choose depth game !cur_state heur) in
+ Play.cancel_timeout ();
cur_state := s;
print_endline ("State: " ^ (Structure.str !cur_state.Arena.struc));
print_endline ("Evals: " ^ (string_of_int !Solver.eval_counter));
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-13 17:14:28
|
Revision: 1408
http://toss.svn.sourceforge.net/toss/?rev=1408&view=rev
Author: lukaszkaiser
Date: 2011-04-13 17:14:22 +0000 (Wed, 13 Apr 2011)
Log Message:
-----------
Adding and ordering Play tests.
Modified Paths:
--------------
trunk/Toss/Play/PlayTest.ml
Modified: trunk/Toss/Play/PlayTest.ml
===================================================================
--- trunk/Toss/Play/PlayTest.ml 2011-04-13 14:42:37 UTC (rev 1407)
+++ trunk/Toss/Play/PlayTest.ml 2011-04-13 17:14:22 UTC (rev 1408)
@@ -25,16 +25,34 @@
let test_maximax ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
- ~iters gname move_s =
+ ~iters gname ?(msg="") ?(nomove=false) check_fun =
let (g, s) = state_of_file ("./examples/"^gname^".toss") ~struc ~time ~loc in
GameTree.set_debug_level debug;
Play.set_debug_level debug;
let h = Heuristic.default_heuristic ~struc:s.Arena.struc ~advr g in
- let (m, ns) = Play.maximax_unfold_choose iters g s h in
- assert_equal ~printer:(fun x -> x) move_s (Move.move_gs_str_short s m)
+ 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 test_algo algo ?(debug=0) ?(advr=4.) ?(struc="") ?(time=0.) ?(loc=0)
+ ~iters gname ?(msg="") ?(nomove=false) check_fun =
+ if algo = "Maximax" then
+ test_maximax ~debug ~advr ~struc ~time ~loc ~iters gname ~nomove check_fun
+ else failwith "Unsupported play algorithm"
-let basic_tests = "Play" >::: [
+
+
+
+
+(* ----------------- NORMAL TESTS ------------- *)
+
+let basic_tests = "Basic" >::: [
+
"maximax unfold once, node_info" >::
(fun () ->
let (g, s) = state_of_file "./examples/Tic-Tac-Toe.toss" in
@@ -59,9 +77,23 @@
assert_equal ~printer:(fun x -> string_of_int x) 250 (GameTree.size u1);
);
- "maximax suggest move: Tic-Tac-Toe defense" >::
+ "checkers suggest first move 5 iters" >::
(fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ 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
+ ("Tic-Tac-Toe (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "basic defense" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
. . .
@@ -69,207 +101,105 @@
. P Q
\"" in
- test_maximax "Tic-Tac-Toe" ~struc ~loc:1 ~iters:9 "Circle{1:b3}";
- );
-]
+ test_do ~struc ~loc:1 (fun s -> s = "Circle{1:b3}")
+ );
-
-let gomoku_tests_big = "Gomoku" >::: [
- "maximax suggest defense 1" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... P.. ... ...
- ... ... ... ...
- ... Q..P P..P ...
- ... ... ... ...
- Q ... P..Q ... ...
- ... ... ... ...
- ... Q..Q ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:160 "Circle{1:d8}";
- );
-
- "maximax suggest defense 2" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
- ... ... ... ...
- P.. ... ... ...
- ... ... ... ...
- ...P ...Q ...P ...
- ... ... ... ...
- Q..P Q..Q Q..P Q..
- ... ... ... ...
- P.. P..Q Q..Q Q..P
- ... ... ... ...
- P..Q P..P Q.. ...
- ... ... ... ...
- ...Q P..Q Q.. P..P
- ... ... ... ...
- P ... P..Q ... P..
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:180 "Circle{1:e1}";
- );
-
- "maximax suggest defense 3" >::
- (fun () ->
- let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ...P ... ...
- ... ... ... ...
- ... Q..Q ... ...
- ... ... ... ...
- ... P..P Q..P ...
- ... ... ... ...
- ... P..Q ... ...
- ... ... ... ...
- ... ...Q P.. ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
- ... ... ... ...
-\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
- test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:210 "Circle{1:b6}";
- );
-]
-
-let bigtests = "PlayBig" >::: [
- gomoku_tests_big;
-]
-
-(* ------------------------------------------ *)
-
-
-let search_tests algo comment effort_easy time_easy effort_medium
- time_medium effort_hard time_hard =
- let update_game gname struc loc =
- state_of_file ("./examples/"^gname^".toss") ~struc ~time:0. ~loc in
- let compute_try search_method effort timer_sec (advr, state) msg pred =
- if search_method = "GameTree" then
- let heur = Heuristic.default_heuristic
- ~struc:(snd state).Arena.struc
- ~advr (fst state) in
- Play.set_timeout (float(timer_sec));
- let (move, _) = Play.maximax_unfold_choose effort
- (fst state) (snd state) heur in
- Play.cancel_timeout ();
- let move_str = Move.move_gs_str_short (snd state) move in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str) (pred move_str)
- else failwith "other method unsupported for now" in
- let easy_case = compute_try algo effort_easy time_easy
- and easy_big_case = compute_try algo effort_easy time_medium
- and medium_case = compute_try algo effort_medium time_medium
- and hard_small_case = compute_try algo effort_hard time_medium
- and hard_case = compute_try algo effort_hard time_hard in
- (algo ^ "-" ^ comment) >::: [
-
- "tictactoe suggest tie" >:: (fun () ->
- let state = update_game "Tic-Tac-Toe"
-"MODEL [ | P:1 { }; Q:1 { } | ] \"
+ "basic tie" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 { }; Q:1 { } | ] \"
Q P P
. P .
. Q .
-\"" 1 in
- (* TODO: replace with easy_case after monotonic heur done *)
- easy_case (5.0, state) "Q should block for tie"
- (fun mov_s -> "Circle{1:a1}" = mov_s));
+\"" in
+ test_do ~struc ~loc:1 ~msg:"Q should block for tie"
+ (fun s -> s = "Circle{1:a1}")
+ );
- "tictactoe suggest optimal single" >::
- (fun () ->
- let state = update_game "Tic-Tac-Toe"
-"MODEL [ | P:1 { }; Q:1 { } | ] \"
+ "suggest optimal single" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 { }; Q:1 { } | ] \"
. . .
. . .
. . P
-\"" 1 in
- easy_case (5.0, state) "Q play the middle for tie"
- (fun mov_s -> "Circle{1:b2}" = mov_s));
+\"" in
+ test_do ~struc ~loc:1 ~msg:"Q play the middle for tie"
+ (fun s -> s = "Circle{1:b2}")
+ );
- "tictactoe suggest optimal multi" >::
- (fun () ->
- let state = update_game "Tic-Tac-Toe"
-"MODEL [ | P:1 { }; Q:1 { } | ] \"
+ "suggest optimal multi" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 { }; Q:1 { } | ] \"
. . .
. P .
. . .
-\"" 1 in
- easy_case (5.0, state) ("Q should play the corner for tie"^
- " (heuristic still ignores monotonicity?)")
- (fun mov_s -> List.mem mov_s
- ["Circle{1:a1}"; "Circle{1:a3}"; "Circle{1:c1}"; "Circle{1:c3}"]));
+\"" in
+ test_do ~struc ~loc:1 ~msg:("Q should play the corner for tie " ^
+ " (heuristic not monotone?)")
+ (fun s -> List.mem s
+ ["Circle{1:a1}"; "Circle{1:a3}"; "Circle{1:c1}"; "Circle{1:c3}"])
+ );
- "tictactoe suggest avoid endgame diagonal" >::
- (fun () ->
- let state = update_game "Tic-Tac-Toe"
-"MODEL [ | P:1 { }; Q:1 { } | ] \"
+ "avoid endgame diagonal" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 { }; Q:1 { } | ] \"
Q . P
. P .
. . .
-\"" 1 in
- easy_case (5.0, state) "Q should block diagonal"
- (fun mov_s -> "Circle{1:a1}" = mov_s));
+\"" in
+ test_do ~struc ~loc:1 ~msg:"Q should block diagonal"
+ (fun s -> s = "Circle{1:a1}")
+ );
- "tictactoe suggest avoid endgame straight" >::
- (fun () ->
- let state = update_game "Tic-Tac-Toe"
-"MODEL [ | P:1 { }; Q:1 { } | ] \"
+ "avoid endgame straight" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 { }; Q:1 { } | ] \"
. P Q
. P .
. . .
-\"" 1 in
- easy_case (5.0, state) "Q should block straight"
- (fun mov_s -> "Circle{1:b1}" = mov_s);
- );
+\"" in
+ test_do ~struc ~loc:1 ~msg:"Q should block straight"
+ (fun s -> s = "Circle{1:b1}");
+ );
- "tictactoe suggest win" >::
- (fun () ->
- let state = update_game "Tic-Tac-Toe"
-"MODEL [ | P:1 { }; Q:1 { } | ] \"
+ "basic win" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 { }; Q:1 { } | ] \"
P . .
. P P
Q . Q
-\"" 1 in
- easy_case (5.0, state) "Q should win"
- (fun mov_s -> "Circle{1:b1}" = mov_s));
+\"" in
+ test_do ~struc ~loc:1 ~msg:"Q should win"
+ (fun s -> s = "Circle{1:b1}")
+ );
+ ]
- "breakthrough suggest avoid endgame" >::
- (fun () ->
- let state = update_game "Breakthrough"
-"MODEL [ | | ] \"
+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
+ ("Breakthrough (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "avoid endgame" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
B B..B B..B B..B B..
... ... ... ...
@@ -286,17 +216,17 @@
... W..W ...W W..
... ... ... ...
W..W ...W W..W W..W
-\"" 0 in
- easy_case (2.0, state) "W shouldn't move from b1"
- (fun mov_s ->
- not (List.mem mov_s
- ["WhiteStraight{1:b1, 2:b2}";
- "WhiteDiag{1:b1, 2:a2}"; "WhiteDiag{1:b1, 2:c2}"])));
+\"" in
+ test_do ~struc ~loc:0 ~msg:"W shouldn't move from b1"
+ (fun mov_s ->
+ not (List.mem mov_s
+ ["WhiteStraight{1:b1, 2:b2}";
+ "WhiteDiag{1:b1, 2:a2}"; "WhiteDiag{1:b1, 2:c2}"]))
+ );
- "breakthrough suggest endgame" >::
- (fun () ->
- let state = update_game "Breakthrough"
-"MODEL [ | | ] \"
+ "endgame attack" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
B B..B B..B B..B B..
... ... ... ...
@@ -313,14 +243,13 @@
W.. W..W ...W W..
... ... ... ...
W.. ...W W..W W..W
-\"" 1 in
- easy_case (2.0, state) "B should attack left"
- (fun mov_s -> "BlackDiag{1:b3, 2:a2}" = mov_s));
+\"" in
+ test_do ~struc ~loc:1 ~msg:"B should attack left"
+ (fun mov_s -> "BlackDiag{1:b3, 2:a2}" = mov_s));
- "breakthrough suggest midgame" >::
- (fun () ->
- let state = update_game "Breakthrough"
-"MODEL [ | | ] \"
+ "midgame capture" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
B..B B.. B..B ...
... ... ... ...
@@ -337,14 +266,13 @@
... ... ... ...
... ... ... ...
W..W ...W ...W W..W
-\"" 0 in
- easy_case (2.0, state) "W should beat the lower B" (* or medium *)
- (fun mov_s -> "WhiteDiag{1:e3, 2:f4}" = mov_s));
+\"" in
+ test_do ~struc ~loc:0 ~msg:"W should beat the lower B"
+ (fun mov_s -> "WhiteDiag{1:e3, 2:f4}" = mov_s));
- "breakthrough suggest adv_ratio" >::
- (fun () ->
- let state = update_game "Breakthrough"
-"MODEL [ | | ] \"
+ "too big adv_ratio" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
B B..B B..B B..B B..
... ... ... ...
@@ -361,16 +289,15 @@
W W.. W..W W.. W..
... ... ... ...
W..W W..W W..W W..W
-\"" 0 in
- easy_case (2.0, state) "W should play cool"
- (fun mov_s ->
- mov_s <> "WhiteDiag{1:e4, 2:f5}"
- && mov_s <> "WhiteDiag{1:e4, 2:d5}"));
+\"" in
+ test_do ~struc ~loc:0 ~msg:"W should play cool"
+ (fun mov_s ->
+ mov_s <> "WhiteDiag{1:e4, 2:f5}"
+ && mov_s <> "WhiteDiag{1:e4, 2:d5}"));
- "breakthrough suggest depth" >::
- (fun () ->
- let state = update_game "Breakthrough"
-"MODEL [ | | ] \"
+ "preserve piece" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
B ...B ...B B..B B..
... ... ... ...
@@ -387,18 +314,25 @@
... ... W..W W..
... ... ... ...
W..W W..W W..W W..W
-\"" 0 in
- medium_case (2.0, state) "W should not lose the piece"
- (fun mov_s ->
- mov_s <> "WhiteDiag{1:d5, 2:e6}"
- && mov_s <> "WhiteDiag{1:d5, 2:c6}"
- && mov_s <> "WhiteStraight{1:d5, 2:d6}"));
+\"" in
+ test_do ~struc ~loc:0 ~msg:"W should not lose the piece"
+ (fun mov_s ->
+ mov_s <> "WhiteDiag{1:d5, 2:e6}"
+ && mov_s <> "WhiteDiag{1:d5, 2:c6}"
+ && mov_s <> "WhiteStraight{1:d5, 2:d6}")
+ );
+ ]
- "gomoku8x8 avoid endgame" >::
- (fun () ->
- let state = update_game "Gomoku"
-"MODEL [ | | ] \"
+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
+ ("Gomoku8x8 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "avoid endgame 1" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
@@ -416,12 +350,14 @@
... ... ... ...
... ... ... ...
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in
- easy_big_case (5.0, state) "P should block"
- (fun mov_s -> "Cross{1:b5}" = mov_s);
+ 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)
+ );
- let state = update_game "Gomoku"
-"MODEL [ | | ] \"
+ "avoid endgame 2" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
@@ -439,17 +375,15 @@
... ... ... ...
... ... ... ...
\" 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))" 0 in
- easy_big_case (5.0, state) "P should block with line"
- (fun mov_s -> "Cross{1:f7}" = mov_s);
+ 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);
+ );
-);
-
- "gomoku8x8 block gameover" >::
- (fun () ->
- let state = update_game "Gomoku"
-"MODEL [ | | ] \"
+ "block gameover" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
@@ -467,17 +401,15 @@
... ... ... ...
... ... ... ...
\" 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))" 0 in
- easy_big_case (5.0, state) "P should block"
- (fun mov_s -> "Cross{1:a3}" = mov_s);
+ 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);
+ );
-);
-
- "gomoku8x8 more pieces" >::
- (fun () ->
- let state = update_game "Gomoku"
-"MODEL [ | | ] \"
+ "more pieces" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
P ... ... ... ...
... ... ... ...
@@ -495,15 +427,14 @@
... ... ... ...
... ... ...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))" 0 in
- easy_big_case (5.0, state) "should block the open line"
- (fun mov_s -> "Cross{1:e7}" = mov_s);
-);
+ 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);
+ );
- "gomoku8x8 attack" >::
- (fun () ->
- let state = update_game "Gomoku"
-"MODEL [ | | ] \"
+ "attack" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ... ...
... ... ... ...
... ... ... ...
@@ -521,15 +452,22 @@
... ... ... ...
... ... 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))" 0 in
- easy_big_case (5.0, state) "should attack the diagonal"
- (fun mov_s -> "Cross{1:d4}" = mov_s);
-);
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should attack the diagonal"
+ (fun mov_s -> "Cross{1:d4}" = mov_s);
+ );
+ ]
- "connect4 simple" >::
- (fun () ->
- let state = update_game "Connect4"
-"MODEL [ | | ] \"
+
+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
+ ("Connect4 (" ^ algo ^ " " ^ (string_of_int iters) ^ ")") >::: [
+
+ "simple attack" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
. . . . . . .
@@ -543,15 +481,14 @@
P Q Q +Q . . .
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
- DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in
- easy_case (2.0, state) "should attack"
- (fun mov_s -> "Cross{1:a4}" = mov_s);
-);
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should attack"
+ (fun mov_s -> "Cross{1:a4}" = mov_s);
+ );
- "connect4 avoid losing" >::
- (fun () ->
- let state = update_game "Connect4"
-"MODEL [ | | ] \"
+ "avoid losing" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
... ... ...
... ... ...
... ... ... ...
@@ -565,16 +502,14 @@
... ... ... ...
... Q..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))" 0 in
- hard_small_case (2.0, state) "should not attack"
- (fun mov_s -> "Cross{1:f3}" <> mov_s);
-);
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should not attack"
+ (fun mov_s -> "Cross{1:f3}" <> mov_s);
+ );
-
- "connect4 endgame" >::
- (fun () ->
- let state = update_game "Connect4"
-"MODEL [ | | ] \"
+ "endgame" >::
+ (fun () ->
+ let struc = "MODEL [ | | ] \"
. . . . . . .
@@ -588,20 +523,153 @@
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))" 0 in
- hard_case (2.0, state) "should defend"
- (fun mov_s -> "Cross{1:e2}" = mov_s);
-);
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_do ~struc ~loc:0 ~msg:"P should defend"
+ (fun mov_s -> "Cross{1:e2}" = mov_s);
+ );
+ ]
+let tests = "Play" >::: [
+ basic_tests;
+ tictactoe_tests "Maximax" 3;
+ breakthrough_tests "Maximax" 5;
+ gomoku8x8_tests "Maximax" 4;
+ connect4_tests "Maximax" 7;
]
-let tests = "Play" >::: [
- basic_tests;
- search_tests "GameTree" "iters 75 230 300" 75 120 230 240 300 360;
+
+(* ----------------- 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)
+ );
+
+ "detect draw" >::
+ (fun () ->
+ let struc =
+"MODEL [ | bB:1 {}; wB:1 {}; wN:1 {}; wP:1 {}; wQ:1 {}; wR:1 {} | ] \"
+ ... ... ... ...
+ ... ... +bN ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... bP. ...-bNwK.
+ ... ... ... ...
+ ...bP ... ... ...
+ ... ... ... ...
+ bR. ... ...bQ ...
+ ... ... ... ...
+ ... ...bK ... ...bP
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with
+D1(x, y) = ex z ( (R(x, z) and C(z, y)) or (R(y, z) and C(z, x)) ) ;
+D2(x, y) = ex z ( (R(x, z) and C(y, z)) or (R(y, z) and C(x, z)) )" in
+ test_maximax "Chess" ~debug:0 ~iters:1 ~struc
+ ~msg:"detect draw in chess" ~nomove:true (fun _ -> false)
+ );
]
+let gomoku_tests_big = "GomokuBig" >::: [
+ "maximax suggest defense 1" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ...P ... ...
+ ... ... ... ...
+ ... P.. ... ...
+ ... ... ... ...
+ ... Q..P P..P ...
+ ... ... ... ...
+ Q ... P..Q ... ...
+ ... ... ... ...
+ ... Q..Q ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:160
+ (fun s -> s = "Circle{1:d8}");
+ );
+
+ "maximax suggest defense 2" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ P.. ... ... ...
+ ... ... ... ...
+ ...P ...Q ...P ...
+ ... ... ... ...
+ Q..P Q..Q Q..P Q..
+ ... ... ... ...
+ P.. P..Q Q..Q Q..P
+ ... ... ... ...
+ P..Q P..P Q.. ...
+ ... ... ... ...
+ ...Q P..Q Q.. P..P
+ ... ... ... ...
+ P ... P..Q ... P..
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:180
+ (fun s -> s = "Circle{1:e1}");
+ );
+
+ "maximax suggest defense 3" >::
+ (fun () ->
+ let struc = "MODEL [ | P:1 {}; Q:1 {} | ] \"
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ...P ... ...
+ ... ... ... ...
+ ... Q..Q ... ...
+ ... ... ... ...
+ ... P..P Q..P ...
+ ... ... ... ...
+ ... P..Q ... ...
+ ... ... ... ...
+ ... ...Q P.. ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+ ... ... ... ...
+\" with DiagA (x, y) = ex u (R(x, u) and C(u, y));
+ DiagB (x, y) = ex u (R(x, u) and C(y, u))" in
+ test_maximax "Gomoku" ~debug:0 ~struc ~loc:1 ~iters:210
+ (fun s -> s = "Circle{1:b6}");
+ );
+]
+
+
+let bigtests = "PlayBig" >::: [
+ chess_tests_big;
+ gomoku_tests_big;
+]
+
+
+(* ----------------- RUN THE TESTS ------------- *)
+
let exec = Aux.run_test_if_target "PlayTest" tests
let execbig = Aux.run_test_if_target "PlayTest" bigtests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-04-13 14:42:46
|
Revision: 1407
http://toss.svn.sourceforge.net/toss/?rev=1407&view=rev
Author: lukaszkaiser
Date: 2011-04-13 14:42:37 +0000 (Wed, 13 Apr 2011)
Log Message:
-----------
Removing Game ml.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/Play/Makefile
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/ServerTest.ml
trunk/Toss/TossFullTest.ml
trunk/Toss/TossTest.ml
Removed Paths:
-------------
trunk/Toss/Play/Game.ml
trunk/Toss/Play/GameTest.ml
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-04-05 20:44:16 UTC (rev 1406)
+++ trunk/Toss/Makefile 2011-04-13 14:42:37 UTC (rev 1407)
@@ -129,7 +129,7 @@
Play/HeuristicTest \
Play/MoveTest \
Play/GameTreeTest \
- Play/GameTest
+ Play/PlayTest
# GGP tests
GGP_tests: \
Deleted: trunk/Toss/Play/Game.ml
===================================================================
--- trunk/Toss/Play/Game.ml 2011-04-05 20:44:16 UTC (rev 1406)
+++ trunk/Toss/Play/Game.ml 2011-04-13 14:42:37 UTC (rev 1407)
@@ -1,1245 +0,0 @@
-(* Game-related definitions. The UCTS algorithm. *)
-
-open Printf
-
-(* Default effort overshoots to let timeout handle stopping. *)
-let default_effort = ref 10
-
-let debug_level = ref 0
-let set_debug_level i = (debug_level := i)
-
-let deterministic_suggest = ref false
-
-(* A global "hurry up!" switch triggered by the timer alarm. *)
-let timeout = ref false
-let get_timeout () = !timeout
-let cancel_timeout () =
- let remaining = Unix.alarm 0 in
- (* {{{ log entry *)
- if !debug_level > 0 then (
- if !timeout then
- Printf.printf "Computation finished by timeout.\n%!"
- else
- Printf.printf "Computation finished with %d seconds left.\n%!"
- remaining
- );
- (* }}} *)
- timeout := false
-
-let trigger_timeout _ =
- (* if !debug_level > 0 then printf " TIMEOUT %!"; *)
- (* TODO: no output possible from inside handler *)
- timeout := true
-
-let () =
- Sys.set_signal Sys.sigalrm
- (Sys.Signal_handle (fun _ -> timeout := true))
-
-type f_table = float array
-
-(* Cumulative score of players for computing value estimate. *)
-type score = {
- score_table : f_table; (* sum of payoffs *)
- variation_table : f_table; (* sum of squares of payoffs *)
- (* sum of the squares of payoffs *)
- score_obs : int (* number of observations *)
-}
-
-let add_score {score_table=table1; variation_table=vartab1; score_obs=obs1}
- {score_table=table2; variation_table=vartab2; score_obs=obs2} =
- {score_table = Aux.array_map2 (fun sc1 sc2 ->
- sc1+.sc2) table1 table2;
- variation_table = Aux.array_map2 (fun sc1 sc2 ->
- sc1+.sc2) vartab1 vartab2;
- score_obs = abs obs1 + abs obs2}
-
-let score_payoff payoff = {
- score_table = payoff;
- variation_table = Array.map (fun sc-> sc*.sc) payoff;
- score_obs = 1;
-}
-
-let discount n payoffs =
- Array.map (fun payoff ->
- (0.5 +. 1./.((float_of_int n) +. 2.)) *. payoff) payoffs
-
-
-type uctree_node = {
- node_state : Arena.game_state ;
- node_stats : score ; (* playout statistic *)
- node_heuristic : f_table ; (* heuristic table *)
- node_bestheur : int ; (* the subtree from which
- [node_heuristic] is picked *)
- node_endstate : Structure.structure ; (* final game state of a
- playout that originated
- the node (mostly for debugging) *)
- node_subtrees : uctree array ;
-}
-
-(* The game tree for turn-based multiplayer games UCT search. Assumes
- determinism of move generation (the same state and location should
- result in the same array of moves). *)
-and uctree =
- | Node of uctree_node
- | Leaf of Arena.game_state * score * f_table * Structure.structure
- (* once played leaf: state, time, location, score, heuristic, game-end *)
- | Tip of Arena.game_state * f_table
- (* unplayed leaf, with heuristic value (evaluation game
- result) *)
- | Terminal of Arena.game_state * score * f_table * f_table
- (* the score, the cache of the actual payoff table and the
- heuristic *)
- | TEmpty (* to be expanded in any context *)
-
-(* History stored for a play, including caching of computations for
- further use. *)
-type memory =
- | No_memory
- | State_history of Structure.structure list
- (* states visited in reverse order *)
- | UCTree of uctree
-
-(* Effect that heuristics have on the MCTS algorithm. *)
-type mcts_heur_effect =
- | Heuristic_local of float (* TODO: not implemented *)
- (* each tree node only considers the heuristic of its state,
- the parameter is the influence of the heuristic on the tree
- traversal, there is no influence on the actual choice *)
- | Heuristic_mixed of float * float
- (* a node stores a heuristic maximaxed from the leaf states of
- the subtree, [MaximaxMixed (trav, select)] has [trav]
- the influence on the tree traversal, [select] the influence
- on the actual choice *)
- | Heuristic_select of float
- (* a node stores a heuristic maximaxed from the leaf states of
- the subtree, the parameter is the influence on the tree
- traversal, the actual choice is based on the heuristic alone
- and not the Monte-Carlo payoff estimates *)
- | Heuristic_only
- (* a node stores a heuristic maximaxed from the leaf states of
- the subtree, which completely replaces the role of the
- Monte-Carlo payoff estimates from the standard UCT algorithm *)
-
-
-(* Parameters of the Upper Confidence Bounds-based Monte Carlo Tree
- Search. Cooperative (competitive) mode means that of actions with
- equal value for a given player, the one with highest (lowest) sum
- of values is chosen. *)
-type uct_params = {
- cUCB : float ; (* coefficient of the confidence bound component *)
- constK : float ; (* smoothening *)
- iters : int ; (* tree updates per move *)
- horizon : int option ; (* limit on the playout length *)
- heur_effect : mcts_heur_effect ; (* maximaxed vs local heuristic *)
- cooperative : bool ; (* cooperative vs competitive *)
- cLCB : float option ; (* cautious action picking; if present, use
- lower confidence bound with given
- coefficient for action selection *)
-}
-
-(* An evaluation game is a set of games specific to locations, each
- game is used to assess the value of its location. It contains the
- same data as {!play} plus {!play_state} (for initial state) below,
- only without the [struc] and [time] fields, and with some general
- playout parameters. [ev_agents] array can be empty but only if
- every location of the [ev_game] subgame has empty moves list. *)
-type evgame_loc = {
- ev_game : Arena.game;
- ev_agents : agent array; (* player-indexed or empty *)
- ev_delta : float;
- ev_location : int;
- ev_memory : memory array; (* player-indexed *)
- ev_horizon : int option;
-}
-and evaluation_game = evgame_loc array
-
-
-(* How does a player pick moves. *)
-and agent =
- | Random_move
- (* select a random move; avoids rewriting all matches and calling
- evaluation games *)
- | Maximax_evgame of evaluation_game * bool * int * bool
- (* select a move according to evaluation games played in each
- leaf state; in a cooperative/competitive way (see
- {!uct_params}); expand the full game subtree to the given
- depth and propagate evaluation game results from leaves by
- taking cooperative/competitive best move for location's
- player; optional alpha-beta-like pruning, with move
- reordering based on afterstate heuristic value *)
- | Tree_search of evaluation_game * int option * uct_params * agent array
- (* Monte-Carlo tree search; uses the evaluation game to compute
- heuristic values for use within the tree, and the agents for
- playout plays *)
- | External of (string array -> int)
- (* take an array of string representations of resulting structures
- and return the position of the desired state; for interacting
- with external players only *)
-
-(* The evolving state of a play. *)
-type play_state = {
- game_state : Arena.game_state ;
- memory : memory array ; (* player-specific history *)
-}
-
-(* Data defining a play (without the initial play state). TODO:
- remove dependency on [delta] (move it to Arena.game). *)
-type play = {
- game : Arena.game ; (* the game played *)
- agents : agent array ; (* player-indexed *)
- delta : float ; (* expected width of payoffs *)
-}
-
-
-let default_params = {
- cUCB = 1.0 ;
- cLCB = Some 1.0 ;
- constK = 1.0 ;
- iters = 200 ;
- horizon = None ;
- heur_effect = Heuristic_mixed (0.5, 0.2) ;
- cooperative = false ;
-}
-
-
-let default_heuristic = Heuristic.default_heuristic
-
-(* The UCB1-TUNED estimate, modified to extend to the zero- and
- one-observation cases. *)
-let ucb1_tuned ?(lower_bound=false)
- params delta player parent_sc ~heuristic score =
- if parent_sc.score_obs = 0 then failwith
- "ucb1_tuned: parent has no observations";
- let cHEUR = match params.heur_effect with
- | Heuristic_local c when not lower_bound -> c
- | Heuristic_mixed (c, _) when not lower_bound -> c
- | Heuristic_mixed (_, c) when lower_bound -> c
- | Heuristic_select c -> c
- | Heuristic_only -> 1.0
- | _ -> 0.0 in
- let i2f = float_of_int in
- let tot = i2f parent_sc.score_obs in
- let vari = score.variation_table.(player) in
- let obs = i2f score.score_obs in
- let score = score.score_table.(player) in
- let var_est = if obs < 2. then 0. else
- (vari -. score *. score /. obs) /. (obs -. 1.) in
- let var_ucb = if obs < 2. then 0. else
- var_est +. delta *.
- sqrt (2. *. log (tot +. params.constK) /. (obs +. params.constK)) in
- let var_coef = if obs < 2. then 0.25 else
- min 0.25 (var_ucb /. delta) in
- let cb =
- (if lower_bound then
- match params.cLCB with Some lcb -> ~-. lcb | None -> 0.
- else params.cUCB) *. delta *. sqrt
- ((log (tot +. params.constK) /. (obs +. params.constK)) *. var_coef) in
- let mean = if obs < 1. then 0. else score /. obs in
- if params.heur_effect = Heuristic_only then
- heuristic +. cb
- else
- mean +. cb +. cHEUR *. heuristic *. cb
-
-(* The move valuation used when actually making a move using the MCTS-UCT
- algorithm, computed for all players. *)
-let node_values params delta parent_sc heuristics
- ({score_table=table;score_obs=obs} as score) =
- let i2f = float_of_int in
- if params.cLCB <> None && parent_sc.score_obs > 0 then
- Array.mapi (fun player heuristic ->
- ucb1_tuned ~lower_bound:true
- params delta player parent_sc ~heuristic score)
- heuristics
- else
- match params.heur_effect with
- | Heuristic_mixed (_, cHEUR) ->
- if obs = 0 then
- Array.map (fun h -> cHEUR*.h) heuristics
- else
- Array.mapi (fun player score ->
- score /. i2f (abs obs) +.
- cHEUR *. heuristics.(player)) table
- | Heuristic_local _ ->
- if obs = 0 then Array.map (fun _ -> 0.) table
- else
- Array.map (fun score -> score /. i2f (abs obs)) table
- | Heuristic_select _ | Heuristic_only -> heuristics
-
-let uctree_heuristic = function
- | Node node -> node.node_heuristic
- | Leaf (_,_,h,_) -> h
- | Tip (_,h) -> h
- | Terminal (_,_,h,_) -> h
- | TEmpty -> failwith "uctree_heuristic: empty tree"
-
-let uctree_size = function
- | Node node -> node.node_stats.score_obs
- | Leaf (_,_,h,_) -> 1
- | Tip (_,h) -> 1
- | Terminal (_,_,h,_) -> 1
- | TEmpty -> 0
-
-let uctree_location = function
- | Node node -> node.node_state.Arena.cur_loc
- | Leaf (s,_,_,_) -> s.Arena.cur_loc
- | Tip (s,_) -> s.Arena.cur_loc
- | Terminal (s,_,_,_) -> s.Arena.cur_loc
- | _ -> failwith "uctree_location: empty tree"
-
-let uctree_model = function
- | Node node -> node.node_state.Arena.struc
- | Leaf (m,_,_,_) -> m.Arena.struc
- | Tip (m,_) -> m.Arena.struc
- | Terminal (m,_,_,_) -> m.Arena.struc
- | _ -> failwith "uctree_model: empty tree"
-
-let uctree_state = function
- | Node node -> node.node_state
- | Leaf (m,_,_,_) -> m
- | Tip (m,_) -> m
- | Terminal (m,_,_,_) -> m
- | _ -> failwith "uctree_state: empty tree"
-
-(* An unevaluated tree or subtree. *)
-let uctree_empty = function
- | TEmpty | Tip _ -> true
- | _ -> false
-
-let uctree_score ?num_players = function
- | Node node -> node.node_stats
- | Leaf (_,s,_,_) -> s
- | Terminal (_,s,_,_) -> s
- | _ ->
- match num_players with
- | None -> failwith "uctree_score: no score in tree, no num_players"
- | Some n ->
- {score_table= Array.make n 0.0;
- variation_table=Array.make n 0.0; score_obs=0}
-
-(* The result of the game played when the node was first grown. *)
-let uctree_endgame = function
- | Node node -> node.node_endstate
- | Leaf (_,_,_,r) -> r
- | Tip _ -> failwith "uctree_endgame: Tip"
- | Terminal (r,_,_,_) -> r.Arena.struc
- | TEmpty -> failwith "uctree_endgame: TEmpty"
-
-
-let print_score (!) params delta heuristics score =
- !"Values: ";
- let values = node_values params delta score heuristics score in
- Array.iteri (fun player score_v -> !(string_of_int player);
- !" nobs="; !(string_of_int score.score_obs);
- !" score=";
- !(string_of_float score_v);
- !" value=";
- !(sprintf "%2.2f" values.(player));
- !" UCB=";
- !(sprintf "%2.2f"
- (ucb1_tuned params delta player score
- ~heuristic:(heuristics.(player)) score));
- !"; ") score.score_table
-
-(* Print the whole tree. Debugging. *)
-let print_uctree (!) params delta tree =
- let kind = function
- | TEmpty -> "Empty"
- | Tip _ -> "Tip" | Leaf _ -> "Leaf" | Terminal _ -> "Terminal"
- | Node _ -> "Node" in
- let rec pr prefix pos = function
- | Tip _ when debug_level.contents <= 4 -> ()
- | node ->
- let pref_str s =
- Str.global_replace (Str.regexp "\n") ("\n"^prefix) s in
- !prefix;
- let score = uctree_score ~num_players:0 node in
- let heuristic = uctree_heuristic node in
- !(sprintf "pos %d " pos);
- print_score (!) params delta heuristic score;
- !"heuristics";
- Array.iteri (fun player score->
- !(sprintf " %d:%f" player score)) heuristic;
- !"; scores";
- Array.iteri (fun player score->
- !(sprintf " %d:%.2f" player score)) score.score_table;
- !"; ";
- !(kind node); !":\n";
- !prefix;
- !(pref_str (Structure.str (uctree_model node)));
- match node with
- | TEmpty
- | Terminal _ | Tip _ -> !"/\n"
- | Leaf (_,_,_,result) ->
- !"game ended in:\n";
- !prefix; !(pref_str (Structure.str result));
- !"/\n"
- | Node node ->
- !"game ended in:\n";
- !prefix; !(pref_str (Structure.str node.node_endstate));
- !"+\n";
- Array.iteri (fun pos subt ->
- (* !(prefix^"| "); !(print_action act); !"\n"; *)
- pr (prefix^"|") pos subt) node.node_subtrees in
- if tree = TEmpty then !"Empty\n"
- else pr " " 0 tree
-
-let str_payoff payoff =
- String.concat ", "
- (Array.to_list (Array.mapi (fun p v -> sprintf"%d:%f" p v) payoff))
-
-
-let initial_state ?(loc=0) {game=game; agents=agents} model =
- (* {{{ log entry *)
- if !debug_level > 5 then (
- Printf.printf "initial_state: agents #=%d, loc #=%d\n%!"
- (Array.length agents) (Array.length game.Arena.graph);
- );
- (* }}} *)
- let player_memory = Array.map
- (function Tree_search _ -> UCTree TEmpty | _ -> No_memory) agents in
- {
- game_state = {Arena.cur_loc = loc; time = 0.0; struc = model};
- memory = player_memory;
- }
-
-(* TODO: [num_players] not used (remove if not needed). *)
-let update_memory_single num_players state pos = function
- | No_memory -> No_memory
- | State_history history -> State_history (state.Arena.struc::history)
- | UCTree (Node node) ->
- UCTree node.node_subtrees.(pos)
- | UCTree _ -> UCTree TEmpty
-
-let update_memory ~num_players state pos memory =
- Array.map
- (update_memory_single num_players state pos) memory
-
-
-(* Average tables of numbers. *)
-let average_table tables =
- match tables with
- | [] -> failwith "average_table: empty list"
- | [table] -> table
- | hd::tl ->
- let n = float_of_int (List.length tables) in
- let sum = List.fold_left (fun sum table ->
- Aux.array_map2 (fun v1 v2 ->
- v1+.v2) sum table) hd tl in
- Array.map (fun v -> v /. n) sum
-
-(* Find all maximal elements. *)
-let find_all_max cmp l =
- let rec find best acc = function
- | hd::tl ->
- let rel = cmp hd best in
- if rel < 0 then find best acc tl
- else if rel = 0 then find best (hd::acc) tl
- else find hd [hd] tl
- | [] -> List.rev acc in
- match l with
- | [] -> invalid_arg "find_all_max: empty list"
- | hd::tl -> find hd [hd] tl
-
-(* Maximaxing: find the best among subtrees for a player. Pick a best
- entry in the lexicographic product of: maximal [scores] value for
- [player], minimal/maximal sum of [scores] values (resp. competitive
- [cooperative=false] / [cooperative=true] mode), integer accuracy
- measure [subt_sizes]. Return a best position (randomized if
- multiple are optimal) and a best scores table (averaged if multiple
- are optimal). *)
-let find_best_score ?(use_det_setting=false) cooperative player
- scores subt_sizes =
- (* find a new best score *)
- let my_scores = Array.map (fun s->s.(player)) scores in
- let bestsc = Aux.array_argfind_all_max compare my_scores in
- match bestsc with
- | [] ->
- failwith "find_best_score: empty arg max"
- | [bestsc] -> scores.(bestsc), bestsc
- | _ ->
- (* pick cooperative/competitive ones *)
- let sc_sums = List.map
- (fun bh -> bh,
- Array.fold_left (+.) 0. scores.(bh))
- bestsc in
- let cmp_sums : (int * float) -> (int * float) -> int =
- if cooperative
- then fun (_,x) (_,y) -> compare x y
- else fun (_,x) (_,y) -> compare y x in
- let bestsc =
- find_all_max cmp_sums sc_sums in
- match bestsc with
- | [] -> failwith "impossible"
- | [bestsc,_] -> scores.(bestsc), bestsc
- | (bsc,_)::(bsc2,_)::_
- when use_det_setting && !deterministic_suggest ->
- scores.(bsc), bsc
- | _ ->
- (* pick ones from biggest subtrees *)
- let bestsc =
- find_all_max
- (fun (b1,_) (b2,_) -> subt_sizes.(b1) - subt_sizes.(b2))
- bestsc in
- match bestsc with
- | [] -> failwith "impossible"
- | [bestsc,_] -> scores.(bestsc), bestsc
- | _::_ ->
- (* check the number of players
- TODO: perhaps not worth averaging *)
- let randbest, _ =
- List.nth bestsc (Random.int (List.length bestsc)) in
- let bestsc_table = scores.(randbest) in
- if Array.length bestsc_table > 2 then
- average_table
- (List.map (fun (b,_) -> scores.(b))
- bestsc),
- randbest
- else bestsc_table, randbest
-
-let debug_count = ref 0
-
-(* Generate evaluation game score (the whole payoff table). *)
-let rec play_evgame grid_size model time evgame =
- let subloc = evgame.ev_game.Arena.graph.(evgame.ev_location) in
- if subloc.Arena.moves = [] then (* optimization *)
- Array.map (fun expr ->
- Solver.M.get_real_val expr model) subloc.Arena.payoffs
- else
- let state =
- {game_state={Arena.cur_loc=evgame.ev_location; struc=model; time=time};
- memory=evgame.ev_memory} in
- let subplay =
- {game=evgame.ev_game; agents=evgame.ev_agents; delta=evgame.ev_delta} in
- (* ignoring the endgame model *)
- let _, payoff =
- play ~grid_size ?horizon:evgame.ev_horizon subplay state in
- payoff
-
-(* Generate evgame scores for possible moves. *)
-and gen_scores grid_size subgames moves models loc =
- Array.mapi (fun pos mv ->
- let {Arena.struc=model; time=time} = models.(pos) in
- play_evgame grid_size model time subgames.(mv.Move.next_loc)
- ) moves
-
-
-
-(* Make a move in a play, or compute the payoff table when the game
- ended. Return the move chosen and the moves considered. One can use
- only a {!move} to suggest a move, or only the updated {!play_state}
- to follow the best move (or both). Also return the accrued
- computation as updated "memory" for the current state.
-
- Uses [Random_move] for other agents if their "effort" is set to
- zero. Do not use [Random_move] or [effort=0] when the table of
- moves is used for more than extracting the move selected! *)
-and toss ~grid_size ?(just_payoffs=false)
- ({game={Arena.rules=rules; graph=graph; num_players=num_players;
- defined_rels=defined_rels};
- agents=agents; delta=delta} as play_def)
- {game_state=state; memory=memory} =
- let loc = graph.(state.Arena.cur_loc) in
- let moves =
- if just_payoffs then [| |]
- else Move.gen_moves grid_size rules state.Arena.struc loc in
- (* Don't forget to check after generating models as well --
- postconditions! *)
- if moves = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- else
- let agent = agents.(loc.Arena.player) in
- match agent with
-
- | Random_move
- | Maximax_evgame (_, _, 0, _)
- | Tree_search (_, _, {iters=0}, _) ->
- let mlen = Array.length moves in
- let init_pos = Random.int mlen in
- let pos = ref init_pos in
- let nstate = ref None in
- while !nstate = None && (!pos <> init_pos || !pos < mlen) do
- let mv = moves.(!pos mod mlen) in
- let rule = List.assoc mv.Move.rule rules in
- nstate :=
- Aux.map_option
- (fun (model, time, _) ->
- (* ignoring shifts, i.e. animation steps *)
- {Arena.cur_loc=mv.Move.next_loc; struc=model; time=time})
- (ContinuousRule.rewrite_single state.Arena.struc state.Arena.time
- mv.Move.embedding rule mv.Move.mv_time mv.Move.parameters);
- incr pos
- done;
- (match !nstate with
- | None ->
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- | Some state ->
- (* [pos] refers to unfiltered array! use only to extract
- | the move from the returned array *)
- Aux.Left
- (!pos mod mlen, moves, memory,
- {game_state = state;
- memory = update_memory ~num_players state !pos memory}))
-
- | Maximax_evgame (subgames, cooperative, depth, use_pruning) ->
- (* {{{ log entry *)
-
- let nodes_count = ref 0 in
- let size_count = ref 1 in
- let depth0 = depth in
- let debug_playclock = ref 0. in
- if !debug_level > 1 && depth > 1 || !debug_level > 3
- then (
- printf "toss: %s ev game, timer started...\n%!"
- (if use_pruning then "alpha_beta_ord" else "maximax");
- debug_playclock := Sys.time ());
-
- (* }}} *)
- (* full tree search of limited depth by plain recursive
- calls, with optional alpha-beta pruning *)
- (* [betas] are used imperatively *)
- let rec maximax_tree pre_heur prev_player betas depth
- {Arena.cur_loc = loc; struc=model; time=time} =
- (* {{{ log entry *)
- incr nodes_count;
- size_count := !size_count + Array.length moves;
- if (depth0 > 2 || !debug_level > 4)
- && depth > 1 && !debug_level > 0
- then printf "%d,%!" !nodes_count;
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4)
- && (depth > 1 || !debug_level > 3)
- then printf "%s%!"
- (Str.global_replace (Str.regexp "\n")
- ("\n"^String.make (max 0 (depth0-depth)) '|')
- ("\n" ^ Structure.str model));
- (* }}} *)
- if !timeout then (* will be handled by i.deep. *)
- Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
- else if depth < 1 then ( (* leaf position *)
- let res =
- match pre_heur with
- | Some h -> h
- | None ->
- play_evgame grid_size model time subgames.(loc) in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- let player = graph.(loc).Arena.player in
- printf ", leaf %d heur: %F %!" player res.(player)
- );
- (* }}} *)
- res
- ) else
- let location = graph.(loc) in
- let moves =
- Move.gen_moves grid_size rules model location in
- if moves = [| |] then (* terminal position *)
- let res =
- (* *)
- Array.map (fun expr ->
- 100000. *.
- Solver.M.get_real_val expr model)
- location.Arena.payoffs (* see [let payoff] above *)
- (* *
- play_evgame grid_size model time subgames.(loc)
- * *)
- in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- let player = graph.(loc).Arena.player in
- printf ", terminal %d heur: %F %!" player res.(player)
- );
- (* }}} *)
- res
- else if !timeout then
- Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
- else
- let moves, models = Move.gen_models rules model time moves in
- let n = Array.length models in
- if !timeout then
- Array.map (fun _ -> 0.) graph.(loc).Arena.payoffs
- else if n = 0 then begin (* terminal after postconditions *)
- let res =
- (* play_evgame grid_size model time subgames.(loc) *)
- (* *)
- Array.map (fun expr ->
- 100000. *.
- Solver.M.get_real_val expr model)
- location.Arena.payoffs
- (* *
- play_evgame grid_size model time subgames.(loc)
- * *)
- in
- (* {{{ log entry *)
- if !debug_level > 4 then (
- let player = graph.(loc).Arena.player in
- printf ", terminal %d heur: %F %!" player res.(player)
- );
- (* }}} *)
- res
- end else
- let player = location.Arena.player in
- let now_pruning = use_pruning && prev_player <> player in
- let new_betas = Array.make num_players infinity in
- let index =
- Array.init (Array.length models) (fun i->i) in
- let heuristics =
- if depth > 1 then begin
- let heuristics =
- gen_scores grid_size subgames moves models location in
- Array.sort (fun j i-> compare
- heuristics.(i).(player) heuristics.(j).(player)) index;
- (* {{{ log entry *)
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) &&
- (depth > 1 || !debug_level > 3)
- then
- printf ", best %d pre-heur: %F %!" player
- heuristics.(index.(0)).(player);
- (* }}} *)
- Some heuristics
- end else None in
- let rec aux best i =
- if i < n && not !timeout then (
- let pos = index.(i) in
- let state = models.(pos) in
- let sub_heur =
- maximax_tree
- (Aux.map_option (fun h->h.(pos)) heuristics)
- player new_betas (depth-1) state in
- (* note strong inequality: don't lose ordering info *)
- if now_pruning && sub_heur.(player) > betas.(player)
- then (
- (* {{{ log entry *)
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) &&
- (depth > 1 || !debug_level > 3)
- then (
- printf ", best cut %d maximax: %F. %!" player
- sub_heur.(player));
- (* }}} *)
- sub_heur)
- else if sub_heur.(player) > best.(player)
- then aux sub_heur (i+1)
- else aux best (i+1))
- else if !timeout then best
- else (
- betas.(player) <- best.(player);
- (* {{{ log entry *)
- if !debug_level > 2 && (depth0 > 2 || !debug_level > 4) &&
- (depth > 1 || !debug_level > 3)
- then (
- printf ", best %d maximax: %F. %!" player
- best.(player));
- (* }}} *)
- best) in
- let alphas = Array.make num_players neg_infinity in
- aux alphas 0 in
- let betas = Array.make num_players infinity in
- let player = loc.Arena.player in
- let moves, models =
- Move.gen_models rules state.Arena.struc state.Arena.time moves in
- if models = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- else
- let cur_depth = ref 0 in
- (* {{{ log entry *)
- if !debug_level > 1 && (depth > 2 || !debug_level > 3) then (
- Printf.printf "\n\nIterative-deepening: depth %d\n%!"
- (!cur_depth + 1)
- );
- (* }}} *)
- let scores =
- Array.map (maximax_tree None player betas !cur_depth) models in
- incr cur_depth;
- while not !timeout && !cur_depth < depth do
- (* {{{ log entry *)
- if !debug_level > 1 && (depth > 2 || !debug_level > 3) then (
- Printf.printf "\n\nIterative-deepening: depth %d\n%!"
- (!cur_depth + 1)
- );
- (* }}} *)
- let index =
- Array.init (Array.length models) (fun i->i) in
- Array.sort (fun j i-> compare
- scores.(i).(player) scores.(j).(player)) index;
- let betas = Array.make num_players infinity in
- let new_scores =
- Array.map (fun j ->
- maximax_tree None player betas !cur_depth models.(j))
- index in
- incr cur_depth;
- if not !timeout then
- Array.iteri (fun i j ->
- (* inverting the permutation *)
- scores.(j) <- new_scores.(i)) index;
- (* {{{ log entry *)
- if !debug_level > 1 && (depth > 2 || !debug_level > 3) then (
- Printf.printf "\nIterative-deepening: depth %d scores:\n%!"
- !cur_depth;
- Array.iteri (fun i score ->
- Printf.printf "Structure:%s -- score %F\n"
- (Structure.str models.(i).Arena.struc) score.(player)) scores
- );
- (* }}} *)
- done;
- let _, best =
- find_best_score ~use_det_setting:true cooperative player scores
- (Array.map (fun _ -> 1) scores) in
- let state = models.(best) in
- (* {{{ log entry *)
- if !debug_level > 0 && (depth > 1 || !debug_level > 3)
- then printf " %d nodes, %d size, %f elapsed time\n%!"
- !nodes_count !size_count
- (Sys.time () -. !debug_playclock);
- if !debug_level > 1 && (depth > 1 || !debug_level > 3)
- then
- Printf.printf "moving to state\n%s\n%!"
- (Structure.str state.Arena.struc);
- (* }}} *)
- Aux.Left
- (best, moves, memory,
- {game_state=state;
- memory=update_memory ~num_players state best memory})
-
- | Tree_search (subgames, evgame_horizon, params, agents) ->
- (* {{{ log entry *)
- let debug_playclock = ref 0. in
- if !debug_level > 1 then (
- debug_playclock := Sys.time ();
- printf "\ntoss: tree search, timer started\n%!");
- (* }}} *)
- (* the generated moves are wasted, but it's not much *)
- let uctree =
- match memory.(loc.Arena.player) with
- | UCTree uctree -> uctree
- | No_memory -> TEmpty
- | _ -> failwith
- "toss: tree search agent without game tree memory" in
- (* {{{ log entry *)
- if !debug_level > 2 then (
- print_endline "\ntoss: initial tree:";
- print_uctree (print_string)
- params delta uctree; flush stdout);
- if !debug_level > 3 then printf "toss: %d iters\n"
- params.iters;
- (* }}} *)
- (* [grow_uctree] will check if it is not a terminal
- position *)
- let uctree = ref uctree and iteri = ref 0 in
- (* the score update is already stored in the tree *)
- while !iteri < params.iters && not !timeout do
- incr iteri;
- (* {{{ log entry *)
- if !debug_level > 0 then printf "%d,%!" !iteri;
- (* }}} *)
- uctree :=
- snd (grow_uctree grid_size {play_def with agents=agents}
- params subgames evgame_horizon
- ~default_state:{game_state=state; memory=memory} !uctree)
- done;
- (* {{{ log entry *)
- if !debug_level > 2 then (
- print_endline "\ntoss: updated tree:";
- print_uctree (print_string)
- params delta !uctree; flush stdout);
- if !debug_level > 1 then
- printf "elapsed time: %f\n%!"
- (Sys.time () -. !debug_playclock);
- (* }}} *)
- (match !uctree with
- | Node node ->
- let scores = Array.map (fun subtree ->
- node_values params delta
- (uctree_score ~num_players !uctree)
- (uctree_heuristic subtree)
- (uctree_score ~num_players subtree))
- node.node_subtrees in
- let _, best =
- find_best_score ~use_det_setting:true
- params.cooperative loc.Arena.player
- scores (Array.map uctree_size node.node_subtrees) in
- let state = uctree_state node.node_subtrees.(best) in
- (* {{{ log entry *)
- if !debug_level > 1 then
- Printf.printf "moving to state\n%s\n%!"
- (Structure.str state.Arena.struc);
- (* }}} *)
- memory.(loc.Arena.player) <- (UCTree (Node node));
- Aux.Left
- (best, moves, memory,
- {game_state=state;
- memory=
- update_memory num_players state best memory})
-
- | Terminal (game_state, score, heuristic, payoff) ->
- Aux.Right payoff
-
- | _ -> failwith "toss: tree search -- unexpected end of tree")
- | External callback ->
- (* {{{ log entry *)
- if !debug_level > 3 then printf "toss: external\n";
- (* }}} *)
- let moves, models =
- Move.gen_models rules state.Arena.struc state.Arena.time moves in
- if models = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- loc.Arena.payoffs in
- Aux.Right payoff
- else
- let descriptions =
- Array.map (fun m -> Structure.str m.Arena.struc) models in
- let best = callback descriptions in
- let state = models.(best) in
- Aux.Left
- (best, moves, memory,
- {game_state=state;
- memory=update_memory num_players state best memory})
-
-
-(* Play a play, by applying {!toss}, till the end. Return the final
- structure and its payoff.
-
- The [set_timer] should be only provided for standalone plays. For
- suggestions, the timer is set by {!Server}. Tests use their own
- timers too, see {!GameTest}. *)
-and play ~grid_size ?set_timer ?horizon ?(plys=0) play_def state =
- let () = match set_timer with
- | None -> ()
- | Some timer ->
- (* {{{ log entry *)
- if !debug_level > 2 then printf "SET ALARM %d\n%!" timer;
- (* }}} *)
- ignore (Unix.alarm timer) in
- let res =
- toss ~grid_size
- ~just_payoffs:(horizon <> None && plys >= Aux.unsome horizon)
- play_def state in
- let () = match set_timer with
- | None -> ()
- | Some _ -> cancel_timeout () in
- match res with
- | Aux.Left (_,_,_,state) ->
- (* {{{ log entry *)
- if !debug_level > 5 || (!debug_level > 0 && set_timer <> None) then
- printf "step-state:\n%s\n%!"
- (Structure.str state.game_state.Arena.struc);
- (* }}} *)
- play ~grid_size ?set_timer ?horizon ~plys:(plys+1) play_def state
- | Aux.Right payoff ->
- (* {{{ log entry *)
- if !debug_level > 5 || (!debug_level > 1 && set_timer <> None) then
- printf "payoff-state:\n%a\n%!"
- (Aux.array_fprint (fun f pv->fprintf f "%F" pv)) payoff;
- (* }}} *)
- state.game_state.Arena.struc, discount plys payoff
-
-
-(* Walk up the tree selecting the optimal estimates route, and update
- the estimates and heuristics ("maximax") on the way down.
-
- Currently, timeouts are not handled inside UCT iterations. *)
-and grow_uctree grid_size
- ({game={Arena.rules=rules; graph=graph; num_players=num_players};
- delta=delta} as play_def) params subgames
- evgame_horizon ?default_state =
- (* the state is only used for the empty tree case *)
- function
- | Node {
- node_state=game_state; node_stats=score;
- node_heuristic=heuristic; node_bestheur=old_bestheur;
- node_endstate=endmodel; node_subtrees=subtrees
- } ->
- let player = graph.(game_state.Arena.cur_loc).Arena.player in
- (* compute UCBs and update the best subtree *)
- let ucb_scores = Array.map (fun subtree ->
- let heuristic = uctree_heuristic subtree in
- ucb1_tuned params delta player score
- ~heuristic:(heuristic.(player))
- (uctree_score ~num_players subtree)) subtrees in
- let best = Aux.array_argfind_all_max
- (compare : float -> float -> int) ucb_scores in
- (* no use of prioritizing cooperative/competitive in an
- exploratory context *)
- let best = List.nth best (Random.int (List.length best)) in
- let upscore, subtree =
- grow_uctree grid_size play_def params subgames evgame_horizon
- subtrees.(best) in
- subtrees.(best) <- subtree;
- let score = add_score score upscore in
- (* maximaxing -- update the heuristic if needed *)
- let subtree_heur = uctree_heuristic subtree in
- let heuristic, bestheur =
- if subtree_heur.(player) > heuristic.(player)
- then subtree_heur, best
- else if best <> old_bestheur
- then heuristic, old_bestheur
- else if subtree_heur.(player) = heuristic.(player)
- then subtree_heur, old_bestheur (* update for other players *)
- else
- let heuristics = Array.map uctree_heuristic subtrees in
- let subt_sizes = Array.map (fun subt ->
- (uctree_score ~num_players subt).score_obs) subtrees in
- find_best_score params.cooperative
- player heuristics subt_sizes in
- upscore,
- Node {
- node_state=game_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=endmodel;
- node_subtrees=subtrees; node_bestheur=bestheur;
- }
-
- | Leaf (game_state, score, heuristic, endmodel) ->
- let player = graph.(game_state.Arena.cur_loc).Arena.player in
- expand_uctree grid_size play_def game_state ~score subgames
- evgame_horizon params.heur_effect heuristic params.horizon
- params.cooperative player
-
- | Tip (game_state, heuristic) ->
- let player = graph.(game_state.Arena.cur_loc).Arena.player in
- expand_uctree grid_size play_def game_state subgames evgame_horizon
- params.heur_effect heuristic params.horizon params.cooperative
- player
-
- | Terminal (game_state, score, heuristic, payoff) ->
- let upscore = score_payoff payoff in
- let score = add_score score upscore in
- upscore,
- Terminal (game_state, score, heuristic, payoff)
-
- | TEmpty ->
- let play_state = Aux.unsome default_state in
- let endmodel, payoff =
- play ~grid_size ?horizon:params.horizon play_def play_state in
- let upscore = score_payoff payoff in
- upscore,
- (* the heuristic value of the root can be ignored *)
- Leaf (play_state.game_state, upscore, payoff, endmodel)
-
-(* Expand a leaf of the tree. *)
-and expand_uctree grid_size ({game={Arena.rules=rules; graph=graph;
- num_players=num_players;
- defined_rels=defined_rels};
- delta=delta} as play_def)
- state ?score subgames evgame_horizon heur_effect heuristic
- horizon cooperative player =
- let location = graph.(state.Arena.cur_loc) in
- let moves = Move.gen_moves grid_size rules state.Arena.struc location in
- if moves = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- location.Arena.payoffs in
- let upscore = score_payoff payoff in
- upscore, Terminal (state, upscore, heuristic, payoff)
-
- else
- let moves, models =
- Move.gen_models rules state.Arena.struc state.Arena.time moves in
- if models = [| |] then
- let payoff =
- Array.map (fun expr ->
- Solver.M.get_real_val expr state.Arena.struc)
- location.Arena.payoffs in
- let upscore = score_payoff payoff in
- upscore, Terminal (state, upscore, heuristic, payoff)
- else
- let heuristics =
- gen_scores grid_size subgames moves models location in
- let subt_sizes = Array.map (fun _ -> 0) heuristics in
- let heuristic, bestheur =
- find_best_score cooperative player heuristics subt_sizes in
- let scores =
- Array.map (fun payoffs -> payoffs.(location.Arena.player))
- heuristics in
- let subtrees =
- Array.mapi (fun i state -> Tip (state, heuristics.(i)))
- models in
- let best = Aux.array_argfind_all_max
- (compare : float -> float -> int) scores in
- let best = List.nth best (Random.int (List.length best)) in
- let next_state = models.(best) in
- let empty_mem = Array.make num_players No_memory in
- let state =
- {game_state=next_state; memory=empty_mem} in
- if heur_effect = Heuristic_only then
- let upscore = score_payoff (Array.make num_players 0.) in
- (* we maintain score to: (1) count the number of node visits,
- (2) keep info when the search tree hits terminal nodes *)
- let score = match score with
- | None -> upscore
- | Some score -> add_score score upscore in
- subtrees.(best) <-
- Leaf (next_state, upscore, heuristics.(best), next_state.Arena.struc);
- (upscore,
- Node {
- node_state=next_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=next_state.Arena.struc;
- node_subtrees=subtrees; node_bestheur=bestheur;
- })
- else
- let endmodel, payoff = play ~grid_size ?horizon play_def state in
- let upscore = score_payoff payoff in
- let score = match score with
- | None -> upscore
- | Some score -> add_score score upscore in
- subtrees.(best) <-
- Leaf (next_state, upscore, heuristics.(best), endmodel);
- (upscore,
- Node {
- node_state=next_state; node_stats=score;
- node_heuristic=heuristic; node_endstate=endmodel;
- node_subtrees=subtrees; node_bestheur=bestheur;
- })
-
-let evgame_of_heuristic heuristics game =
- let evgame gloc =
- {ev_game =
- {Arena.rules = [];
- player_names = game.Arena.player_names;
- defined_rels = game.Arena.defined_rels;
- data = game.Arena.data;
- graph = [|
- {Arena.id=0; player=gloc.Arena.player;
- payoffs=heuristics.(gloc.Arena.id);
- moves=[]} |];
- num_players = game.Arena.num_players};
- ev_agents = [| |]; ev_delta = 0.0; ev_location = 0;
- ev_horizon = Some 0; ev_memory = [| |]} in
- Array.map evgame game.Arena.graph
-
-(* An UCT-based agent that uses either random playouts (when
- [random_playout] is set to true) or the same location-dependent
- heuristic for maximax search as given for the inside-tree
- (including unevaluated tips) calculation. *)
-let default_treesearch struc ~iters ?heuristic
- ?advr ?(random_playout=false)
- ?(playout_mm_depth=0) ?(heur_effect=default_params.heur_effect)
- ?horizon game =
- (* heuristics are location-id indexed first, then player-indexed *)
- let heuristics = match heuristic with Some h -> h
- | None ->
- default_heuristic ~struc ?advr game in
- let heur_evgame =
- evgame_of_heuristic heuristics game in
- let playout_agents =
- if not (random_playout || heur_effect = Heuristic_only) then
- Array.map (fun _ ->
- Maximax_evgame
- (heur_evgame, false, playout_mm_depth, true))
- game.Arena.graph
- else Array.map (fun _ -> Random_move) game.Arena.graph in
- Tree_search
- (heur_evgame, Some 0,
- {default_params with iters=iters; horizon=horizon;
- heur_effect=heur_effect},
- playout_agents)
-
-(* Plain limited depth maximax tree search. *)
-let default_maximax struc ~depth ?heuristic
- ?advr ?(pruning=true) game =
- let heuristics = match heuristic with Some h -> h
- | None ->
- default_heuristic ~struc ?advr game in
- let heur_evgame =
- evgame_of_heuristic heuristics game in
- Maximax_evgame (heur_evgame, false, depth, pruning)
-
-let initialize_default state ?loc ?effort
- ~search_method ?horizon
- ?advr ?(payoffs_already_tnf=false) ?heuristic () =
- let effort = match effort with
- | None -> !default_effort | Some e -> e in
- let {Arena.rules=rules; graph=graph; num_players=num_players} = fst state in
- let struc = (snd state).Arena.struc in
- (* {{{ log entry *)
- if !debug_level > 0 then printf "\ninitializing game and play\n%!";
- (* }}} *)
- (* TODO: default_heuristic redoes payoff normalization. *)
- let game = fst state in
- let agent =
- match search_method with
- | "maximax" ->
- default_maximax struc ~depth:effort ?heuristic
- ?advr ~pruning:false game
- | "alpha_beta_ord" ->
- default_maximax struc ~depth:effort ?heuristic
- ?advr ~pruning:true game
- | "uct_random_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~random_playout:true game
- | "uct_greedy_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~random_playout:false game
- | "uct_maximax_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~random_playout:false ~playout_mm_depth:1 game
- | "uct_no_playouts" ->
- default_treesearch struc
- ~iters:effort ?heuristic ?advr ?horizon
- ~heur_effect:Heuristic_only game
- | s -> failwith ("Game.initialize: unknown search method "^s)
- in
- let play =
- {game = game; agents=Array.make num_players agent;
- delta = 2.0} in (* FIXME: give/calc delta *)
- (* {{{ log entry *)
- if !debug_level > 2 then printf "play initialized\n%!";
- (* }}} *)
- let init_state = initial_state ?loc play struc in
- play, init_state
-
-let suggest ?effort play play_state =
- let play = match effort with
- | None -> play
- | Some effort ->
- {play with agents=Array.map
- (function
- | Tree_search (subgames, sth, params, agents) ->
- Tree_search (
- subgames, sth, {params with iters=effort},
- agents)
- | Maximax_evgame (
- subgames, cooperative, depth, use_pruning) ->
- Maximax_evgame
- (subgames, cooperative, effort, use_pruning)
- | (Random_move | External _) as agent -> agent
- ) play.agents} in
- (* {{{ log entry *)
- if !debug_level > 2 then printf "\nsuggest:\n%!";
- (* }}} *)
- (match
- toss ~grid_size:Move.cGRID_SIZE play play_state
- with
- | Aux.Left (bpos, moves, memory, _) ->
- (* [suggest] does not update the state, rule application
- should do it *)
- (* {{{ log entry *)
- if !debug_level > 1 then
- printf "suggest: pos %d out of %d -- %s\n%!" bpos
- (Array.length moves)
- (Move.move_gs_str (play.game, play_state.game_state) moves.(bpos));
- (* }}} *)
- Some (moves.(bpos), {play_state with memory=memory})
- | Aux.Right payoffs ->
- (* {{{ log entry *)
- if !debug_level > 2 then (
- Printf.printf "Suggest: found payoffs = %a\n%!"
- (Aux.array_fprint (fun ppf -> Printf.fprintf ppf "%F")) payoffs
- );
- (* }}} *)
- None)
-
Deleted: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-04-05 20:44:16 UTC (rev 1406)
+++ trunk/Toss/Play/GameTest.ml 2011-04-13 14:42:37 UTC (rev 1407)
@@ -1,1063 +0,0 @@
-open OUnit
-open Aux
-
-let assert_one_of str str_list =
- let elements = String.concat ", " str_list in
- assert_bool ("expected one of "^elements^", but got "^str)
- (List.mem str str_list)
-
-let assert_not_one_of str str_list =
- let elements = String.concat ", " str_list in
- assert_bool ("expected disjoint from "^elements^", yet got "^str)
- (not (List.mem str str_list))
-
-let struc_of_str s =
- StructureParser.parse_structure Lexer.lex (Lexing.from_string s)
-
-let formula_of_str s =
- FormulaParser.parse_formula Lexer.lex (Lexing.from_string s)
-
-let real_expr_of_str s =
- FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s)
-
-let defstruc_of_str s =
- match
- ArenaParser.parse_game_defs Lexer.lex (Lexing.from_string s)
- with Arena.StateStruc struc -> struc
- | _ -> failwith "defstruc_of_str: not a structure"
-
-let state_of_str s =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_string s)
-
-let state_of_file s =
- let f = open_in s in
- let res =
- ArenaParser.parse_game_state Lexer.lex
- (Lexing.from_channel f) in
- res
-
-module StrMap = Structure.StringMap
-module IntMap = Structure.IntMap
-
-let move_str r s m = Move.move_str_short s m
-let move_gs_str = Move.move_gs_str_short
-
-let update_game ?(defs=false)
- (lazy (horizon, adv_ratio, (state_game, state))) new_struc_s new_loc =
- let new_struc =
- if defs then defstruc_of_str new_struc_s else struc_of_str new_struc_s in
- horizon, adv_ratio,
- (state_game, {state with Arena.struc = new_struc; cur_loc = new_loc})
-
-let get_loc_game ?update_struc
- (lazy (horizon, adv_ratio, (state_game, state))) new_loc =
- horizon, adv_ratio,
- match update_struc with
- | None ->
- (state_game, {state with Arena.cur_loc = new_loc})
- | Some upd ->
- (state_game, {state with
- Arena.struc = upd state.Arena.struc;
- cur_loc = new_loc})
-
-
-let rec binary_to_assoc = function
- | [k;v]::tl -> (k,v)::(binary_to_assoc tl)
- | [] -> []
- | _ -> failwith "binary_to_assoc: arity mismatch"
-
-let rec fix_find f x =
- try fix_find f (f x)
- with Not_found -> x
-
-module RelMap = Structure.StringMap
-module Tuples = Structure.Tuples
-
-let winQxyz =
- "ex x, y, z ((((Q(x) and Q(y)) and Q(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
-let winPxyz =
- "ex x, y, z ((((P(x) and P(y)) and P(z)) and ((((R(x, y) and R(y, z)) or (C(x, y) and C(y, z))) or ex u, v ((((R(x, v) and C(v, y)) and R(y, u)) and C(u, z)))) or ex u, v ((((R(x, v) and C(y, v)) and R(y, u)) and C(z, u))))))"
-let winPvwxyz =
- "ex v, w, x, y, z ((((((P(v) and P(w)) and P(x)) and P(y)) and P(z))
- and ((((((R(v, w) and R(w, x)) and R(x, y)) and R(y, z)) or (((C(v,
- w) and C(w, x)) and C(x, y)) and C(y, z))) or ex r, s, t, u
- ((((((((R(v, r) and C(r, w)) and R(w, s)) and C(s, x)) and R(x, t))
- and C(t, y)) and R(y, u)) and C(u, z)))) or ex r, s, t, u
- ((((((((R(v, r) and C(w, r)) and R(w, s)) and C(x, s)) and R(x, t))
- and C(y, t)) and R(y, u)) and C(z, u))))))"
-let winQvwxyz =
- "ex v, w, x, y, z ((((((Q(v) and Q(w)) and Q(x)) and Q(y)) and Q(z))
- and ((((((R(v, w) and R(w, x)) and R(x, y)) and R(y, z)) or (((C(v,
- w) and C(w, x)) and C(x, y)) and C(y, z))) or ex r, s, t, u
- ((((((((R(v, r) and C(r, w)) and R(w, s)) and C(s, x)) and R(x, t))
- and C(t, y)) and R(y, u)) and C(u, z)))) or ex r, s, t, u
- ((((((((R(v, r) and C(w, r)) and R(w, s)) and C(x, s)) and R(x, t))
- and C(y, t)) and R(y, u)) and C(z, u))))))"
-
-let checkers_1x1_to_3x2 s =
- let r = String.make (8*8*6+8*2) ' ' in
- for i = 1 to 8*2 do
- r.[i*8*3+i-1] <- '\n' done;
- for i = 1 to 8 do
- for j = 1 to 8 do
- if (i+j) mod 2 = 0 then (
- String.blit "..." 0 r
- ((8-j)*8*3*2 + (8-j)*2 + (i-1)*3) 3;
- String.blit "..." 0 r
- ((8-j)*8*3*2 + (8-j)*2 + 8*3 + 1 + (i-1)*3) 3);
- if s.[(8-j)*8 + (8-j) + i-1] <> '.' then
- r.[(8-j)*8*3*2 + (8-j)*2 + 8*3 + 1 + (i-1)*3] <-
- s.[(8-j)*8 + (8-j) + i-1];
- done
- done;
- r
-
-let tictactoe_1x1_to_3x2 s =
- let r = String.make (3*3*6+3*2) ' ' in
- for i = 1 to 3*2 do
- r.[i*3*3+i-1] <- '\n' done;
- for i = 1 to 3 do
- for j = 1 to 3 do
- r.[(3-j)*3*3*2 + (3-j)*2 + 3*3 + 1 + (i-1)*3] <-
- s.[(3-j)*3 + (3-j) + i-1]
- done
- done;
- r
-
-let breakthrough_game =
- lazy (None, 2.0, state_of_file "./examples/Breakthrough.toss")
-
-let breakthrough_simpl_game =
- lazy (None, 2.0, state_of_file "./GGP/tests/breakthrough-simpl.toss")
-
-let tictactoe_game =
- lazy (None, 5.0, state_of_file "./examples/Tic-Tac-Toe.toss")
-
-let gomoku8x8_game =
- lazy (None, 5.0, state_of_file "./examples/Gomoku.toss")
-
-let gomoku19x19_game =
- lazy (None, 5.0, state_of_file "./examples/Gomoku19x19.toss")
-
-let connect4_game =
- lazy (None, 2.0, state_of_file "./examples/Connect4.toss")
-
-let chess_game =
- lazy (Some 400, 2.0, state_of_file "./examples/Chess.toss")
-
-let checkers_game =
- lazy (Some 400, 2.0, state_of_file "./examples/Checkers.toss")
-
-let breakthrough_heur_adv adv_ratio =
- let expanded_win1 =
- "ex y1, y2, y3, y4, y5, y6, y7, y8 (C(y1, y2) and C(y2, y3) and C(y3, y4) and C(y4, y5) and C(y5, y6) and C(y6, y7) and C(y7, y8) and W(y8))" in
- let expanded_win2 =
- "ex y1, y2, y3, y4, y5, y6, y7, y8 (B(y1) and C(y1, y2) and C(y2, y3) and C(y3, y4) and C(y4, y5) and C(y5, y6) and C(y6, y7) and C(y7, y8))" in
- let expanded_payoff1 =
- (Heuristic.of_payoff adv_ratio (strings_of_list ["B"; "W"])
- (real_expr_of_str
- (":("^expanded_win1^") - :("^expanded_win2^")"))) in
- let expanded_payoff2 =
- (Heuristic.of_payoff adv_ratio (strings_of_list ["B"; "W"])
- (real_expr_of_str
- (":("^expanded_win2^") - :("^expanded_win1^")"))) in
- let expanded_payoffs =
- [|expanded_payoff1; expanded_payoff2|] in
- [|expanded_payoffs; expanded_payoffs|]
-
-let breakthrough_heur =
- breakthrough_heur_adv 1.5
-
-let chess_piece_value_heur =
- let white_val =
- "Sum (x | wP(x): 1) + Sum (x | wN(x): 3.2) +
- Sum (x | wB(x): 3.33) + Sum (x | wR(x): 5.1) + Sum (x | wQ(x): 8.8) +
- Sum (x | wK(x): 100)" in
- let black_val =
- "Sum (x | bP(x): 1) + Sum (x | bN(x): 3.2) +
- Sum (x | bB(x): 3.33) + Sum (x | bR(x): 5.1) + Sum (x | bQ(x): 8.8) +
- Sum (x | bK(x): 100)" in
- let white_heur =
- real_expr_of_str ("("^white_val^") - ("^black_val^")") in
- let black_heur =
- real_expr_of_str ("("^black_val^") - ("^white_val^")") in
- let heuristic = [|white_heur; black_heur|] in
- Array.make 32 heuristic
-
-let check_loc_random = function
- | Game.Tree_search (_,_,_,evgames) ->
- if
- Aux.array_for_all (function Game.Random_move -> true | _ -> false)
- evgames
- then true
- else if
- Aux.array_for_all (function Game.Random_move -> false | _ -> true)
- evgames
- then false
- else failwith "check_loc_random: inconsistent"
- | _ -> failwith "check_loc_random: not a Tree_search"
-
-let payoff_str pay =
- String.concat ", "
- (List.map (fun (p,v)->p^": "^string_of_float v) pay)
-
-let try_n_times n (state_game, state) compute_move pred comment =
- let hist = ref 0 in
- let failed = ref [] in
- for i = 1 to n do
- let move, _ = compute_move () in
- let move_str = move_gs_str state move in
- if pred move_str
- then incr hist
- else failed := move_str :: !failed
- done;
- assert_bool
- (Printf.sprintf "%s: only %d out of %d\nFailed moves: %s."
- comment !hist n (String.concat "; " !failed))
- (float_of_int !hist >= float_of_int n *. 0.7)
-
-let compute_try search_method randomize effort timer_sec
- (horizon, advr, state) loc msg pred =
- if search_method = "GameTree"
- then
- let heur = Heuristic.default_heuristic
- ~struc:(snd state).Arena.struc
- ~advr (fst state) in
- Play.set_timeout (float(timer_sec));
- let (move, _) = Play.maximax_unfold_choose effort
- (fst state) (snd state) heur in
- Play.cancel_timeout ();
- let move_str = move_gs_str (snd state) move in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str)
- (pred move_str)
-
- else
- let p,ps = Game.initialize_default
- state ~advr ?horizon ~loc ~effort ~search_method () in
- let compute_move () =
- ignore (Unix.alarm timer_sec);
- let res =
- Aux.unsome (Game.suggest p ps) in
- Game.cancel_timeout ();
- res in
- if randomize then
- try_n_times 5 state compute_move pred msg
- else
- let move, _ = compute_move () in
- let move_str = move_gs_str (snd state) move in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str)
- (pred move_str)
-
-
-
-let misc_tests = "misc" >::: [
-
- "play: breakthrough suggest in game" >::
- (fun () ->
- let horizon, advr, state =
- update_game breakthrough_game
-"[ | | ] \"
- ... ... ... ...
- ... ... ... ...
-... ... ... ...
-...B ... B.. ...
- ... ... ... ...
- B..B B..B B..B B..
-... ... ... ...
-...B B..B B..B B..W
- ... ... ... ...
-W W..W W..B W..W ...
-... ... ... ...
-W..W W.. W.. ...
[truncated message content] |
|
From: <luk...@us...> - 2011-04-05 20:44:24
|
Revision: 1406
http://toss.svn.sourceforge.net/toss/?rev=1406&view=rev
Author: lukaszkaiser
Date: 2011-04-05 20:44:16 +0000 (Tue, 05 Apr 2011)
Log Message:
-----------
Small but important bug.
Modified Paths:
--------------
trunk/Toss/Server/Server.ml
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-04-05 15:57:57 UTC (rev 1405)
+++ trunk/Toss/Server/Server.ml 2011-04-05 20:44:16 UTC (rev 1406)
@@ -587,7 +587,7 @@
);
if !experiment then
run_test !e_len !e_d1 !e_d2
- else if !sqltest != "" then
+ else if !sqltest <> "" then
DB.print_rows (DB.get_table "WebClient/tossdb.sqlite" !sqltest)
else try
start_server req_handle !port !server
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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-03-29 17:16:16
|
Revision: 1404
http://toss.svn.sourceforge.net/toss/?rev=1404&view=rev
Author: lukaszkaiser
Date: 2011-03-29 17:16:10 +0000 (Tue, 29 Mar 2011)
Log Message:
-----------
Very small build corrections.
Modified Paths:
--------------
trunk/Toss/Makefile
trunk/Toss/www/reference/.cvsignore
Property Changed:
----------------
trunk/Toss/www/reference/
Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile 2011-03-29 15:52:15 UTC (rev 1403)
+++ trunk/Toss/Makefile 2011-03-29 17:16:10 UTC (rev 1404)
@@ -12,6 +12,7 @@
Language/*~ Server/*~ Client/*~ www/*~ WebClient/~
make -C www/reference
make -C www
+ make -C .
mkdir ../toss_$(RELEASE)
cp -r * ../toss_$(RELEASE)
mv ../toss_$(RELEASE) .
Property changes on: trunk/Toss/www/reference
___________________________________________________________________
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 .
*.html
*.html.de
*.html.en
*.png
*.css
reference.pdf
*.ps
*.dvi
*.aux
*.out
*.log
*.bbl
*.blg
*.idx
*.thm
*.snm
*.nav
*.toc
*.flc
*~
+ # 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 .
*.html
*.html.de
*.html.en
*.html.fr
*.html.pl
*.png
*.css
reference.pdf
*.ps
*.dvi
*.aux
*.out
*.log
*.bbl
*.blg
*.idx
*.thm
*.snm
*.nav
*.toc
*.flc
*~
Modified: trunk/Toss/www/reference/.cvsignore
===================================================================
--- trunk/Toss/www/reference/.cvsignore 2011-03-29 15:52:15 UTC (rev 1403)
+++ trunk/Toss/www/reference/.cvsignore 2011-03-29 17:16:10 UTC (rev 1404)
@@ -5,6 +5,8 @@
*.html
*.html.de
*.html.en
+*.html.fr
+*.html.pl
*.png
*.css
reference.pdf
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-29 15:52:24
|
Revision: 1403
http://toss.svn.sourceforge.net/toss/?rev=1403&view=rev
Author: lukaszkaiser
Date: 2011-03-29 15:52:15 +0000 (Tue, 29 Mar 2011)
Log Message:
-----------
Corrections to the german website version and other very small things.
Modified Paths:
--------------
trunk/Toss/Server/Server.ml
trunk/Toss/www/Makefile
trunk/Toss/www/contact.xml
trunk/Toss/www/create.xml
trunk/Toss/www/develop.xml
trunk/Toss/www/docs.xml
trunk/Toss/www/examples.xml
trunk/Toss/www/index.xml
trunk/Toss/www/play.xml
trunk/Toss/www/upload_sourceforge.sh
Modified: trunk/Toss/Server/Server.ml
===================================================================
--- trunk/Toss/Server/Server.ml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/Server/Server.ml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -403,7 +403,7 @@
play, play_state
| _ -> assert false in
ignore (Unix.alarm (!playclock - (int_of_float time_used) - 1));
- Play.set_timeout (float(!playclock) -. time_used -. 0.02);
+ Play.set_timeout (float(!playclock) -. time_used -. 0.07);
if !no_gtree then
let res = Game.suggest p ps in
Game.cancel_timeout ();
Modified: trunk/Toss/www/Makefile
===================================================================
--- trunk/Toss/www/Makefile 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/Makefile 2011-03-29 15:52:15 UTC (rev 1403)
@@ -4,7 +4,7 @@
code_doc_link:
ln -s ../_build/Toss.docdir code_doc
- rm code_doc/Toss.docdir
+ rm -f code_doc/Toss.docdir
cp code_doc/index.html code_doc/index.html.en
cp code_doc/index.html code_doc/index.html.de
cp code_doc/index.html code_doc/index.html.pl
Modified: trunk/Toss/www/contact.xml
===================================================================
--- trunk/Toss/www/contact.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/contact.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -25,8 +25,8 @@
<section title="Email" lang="de">
<par>Toss ist ein Open-Source Projekt, wird auf
<a href="http://sourceforge.net">SourceForge</a>
- gehosted und unter der BSD Lizenz disribuiert.<br/></par>
- <par>Man kann uns unter folgener Addresse erreichen:
+ gehosted und unter der BSD Lizenz distribuiert.<br/></par>
+ <par>Man kann uns unter folgener Adresse erreichen:
<mailto address="tos...@li..."/>
</par>
</section>
@@ -115,12 +115,12 @@
</item>
<item><a href="http://www.dozingcatsoftware.com/Gridlock/">Gridlock</a>
- ist eine Sammlung von Open-Source Spielen. Es spielt nett, erlaubt
- es aber nicht das Spiel zu editieren.
+ ist eine Sammlung von Open-Source Spielen. Es spielt gut, erlaubt
+ aber nicht das Spiel zu editieren.
</item>
<item><a href="http://www.zillions-of-games.com/">Zillions of Games</a>
- ist eine Sprache für Spieldefinitionen, ein Simulator und eine grosse
+ ist eine Sprache für Spieldefinitionen, ein Simulator und eine große
Bibliothek von Spielen. Leider ist es nicht Open-Source.
</item>
@@ -219,17 +219,17 @@
<section title="Links zu Simulation- und Modellierungprogrammen" lang="de">
<itemize>
<item><a href="http://edu.kde.org/step/">Step</a>
- ist ein Open-Source Physiksimulator, teil der KDE Education Project.
- Man kann damit Systeme mit kontiuerlicher Dynamik simulieren.
+ ist ein Open-Source Physiksimulator, ein Teil des KDE Education Project.
+ Man kann damit Systeme mit kontinuierliches Dynamik simulieren.
</item>
- <item><a href="http://www.iseesystems.com/softwares/Education/StellaSoftware.aspx">STELLA</a> ist ein kommerzieller Simulationsprogramm und erlaubt
- sowohl diskrete als auch kontinuerliche Dynamik.
+ <item><a href="http://www.iseesystems.com/softwares/Education/StellaSoftware.aspx">STELLA</a> ist ein kommerzielles Simulationsprogramm und erlaubt
+ sowohl diskrete als auch kontinuierliche Dynamik.
</item>
<item><a href="http://ptolemy.eecs.berkeley.edu/">Ptolemy</a> Projekt
- erforscht Modelierung, Simulation und das Design von Nebenläufigen im
- Echtzeit laufenden eingebeteten Systeme. Es erlaubt verschiedene
+ erforscht Modellierung, Simulation und das Design von nebenläufigen in
+ Echtzeit laufenden eingebetteten Systemen. Es erlaubt verschiedene
Modelle von Berechnungen gleichzeitig zu verknüpfen und zu nutzen.
</item>
</itemize>
@@ -297,9 +297,9 @@
</itemize>
</section>
<section title="Team" lang="de">
- <par>Toss hat angefangen während der Arbeit im
- <a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a>
- Graduiertenkolleg. Viele haben dazu beigetragen, hier benennen wir
+ <par>Die Arbeit an Toss begann im Graduiertenkolleg
+ <a href="http://www.algosyn.rwth-aachen.de/">AlgoSyn</a>.
+ Viele haben dazu beigetragen, hier benennen wir
nur einige Mitwirkende. Zur Zeit programmieren am meisten:</par>
<itemize>
<item>Łukasz Kaiser (<mailto address="luk...@gm..."/>)</item>
@@ -307,7 +307,7 @@
<item>Łukasz Stafiniak</item>
<item>Michał Wójcik</item>
</itemize>
- <par>Freunde die uns sehr geholfen haben.</par>
+ <par>Freunde, die uns sehr geholfen haben.</par>
<itemize>
<item>Dietmar Berwanger</item>
<item>Matko Botincan</item>
Modified: trunk/Toss/www/create.xml
===================================================================
--- trunk/Toss/www/create.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/create.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -28,7 +28,7 @@
<section title="Zwei Methoden um ein neues Spiel in Toss zu erzeugen"
lang="de">
- <par>Wenn man schon genug online gespielt hat, kann man mit den wirklichen
+ <par>Wenn man genug online gespielt hat, kann man mit dem wirklichen
Spass in Toss anfangen und ein neues Spiel erschaffen. Zwei Wege
kann man dazu nutzen.</par>
<itemize>
@@ -36,7 +36,7 @@
<item>Die .toss Files kann man auch direkt editieren.</item>
</itemize>
<par>Um kleine Änderungen zu machen oder ein einfaches Beispiel zu
- definieren kann man wohl die GUI benutzen. Um kompliziertere Spiele zu
+ definieren kann man die GUI benutzen. Um kompliziertere Spiele zu
erzeugen und ganz neue Ideen zu realisieren ist es bequemer, die .toss
Files direkt in einem Editor zu bearbeiten.</par>
</section>
@@ -86,20 +86,20 @@
several other features.<br/></par>
<par><br/><toss-video/></par>
</section>
- <section title="Spiele im Toss GUI Erzeugen" lang="de">
+ <section title="Spiele in das Toss GUI Erzeugen" lang="de">
<par>Um die Toss GUI zu starten, muss man:</par>
<itemize>
<item>Toss <em>runterladen</em> von der
<a href="http://sourceforge.net/project/showfiles.php?group_id=115606">
SourceForge Seite</a>.</item>
<item><em>Toss ausführen</em>, indem man auf <em>Toss.py</em> clickt.
- Man kann am Anfang einer der Files im <em>examples</em> Verzeichniss
+ Man kann am Anfang einer der Files im <em>examples</em> Verzeichnis
öffnen.</item>
</itemize>
- <par>Wenn die GUI schon läuft, kann man am besten den
+ <par>Wenn die GUI schon läuft, kann man am besten das
<a href="http://vimeo.com/10110495">Toss Tutorial</a> unten angucken,
- wo es gezeigt wird, wie man ein einfaches Spiel in Toss vollständig
- definiert und wo auch andere Features erklärt sind.<br/></par>
+ wo gezeigt wird, wie man ein einfaches Spiel in Toss vollständig
+ definiert und auch andere Features erklärt sind.<br/></par>
<par><br/><toss-video/></par>
</section>
<section title="Tworzenie Gier w Interfejsie Graficznym Tossa" lang="pl">
@@ -155,14 +155,14 @@
</section>
<section title="Spiele in Text Form erschaffen" lang="de">
<par>Wir glauben, dass es für kompliziertere Spiele einfacher ist,
- ein Texteditor zu benutzen als die Toss GUI immer zu starten.
+ einen Texteditor zu benutzen, als die Toss GUI jedesmal zu starten.
Um die verschiedenen Felder im .toss Files zu verstehen ist es aber
- nötig, erstmal die Grundlagen von Toss durchzuarbeiten, z.B. indem
- man das Tutorial oben durchgeht, und auch das
+ nötig erstmal die Grundlagen von Toss durchzuarbeiten, z.B. indem
+ man das Tutorial oben durchgeht, das
<a href="reference/reference.pdf">reference.pdf</a> File wenigstens
- durchzublättert, und auch die <a href="docs.html">Dokumentation</a>.
+ durchblättert und die <a href="docs.html">Dokumentation</a> liest.
Danach kann man einfach die .toss Files im Editor
- bearbeiten, Mit einer von den folgenden kann man gut anfangen.
+ bearbeiten, mit einer des folgenden kann man gut anfangen.
</par>
<itemize>
<item><a href="http://toss.svn.sourceforge.net/viewvc/toss/trunk/Toss/examples/Breakthrough.toss?revision=1349">Breakthrough</a></item>
Modified: trunk/Toss/www/develop.xml
===================================================================
--- trunk/Toss/www/develop.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/develop.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -40,17 +40,17 @@
</section>
<section title="Vorbereitung" lang="de">
<itemize>
- <item>Ausser der Interfaces ist Toss fast vollständig in
+ <item>Mit Ausnahme des Interfaces ist Toss fast vollständig in
<a href="http://caml.inria.fr/">Objective Caml</a> geschrieben.
Um an Toss zu arbeiten braucht man ein gutes Verständnis von
OCaml und eine vollständige OCaml Installation.
</item>
<item>Das <em>Build System</em> von Toss basiert auf <em>ocamlbuild</em>
und nutzt <em>Makefiles</em> um die C Teile zu kompilieren.
- Man muss diese Tools installiert haben um Toss zu bauen.
+ Man muss diese Tools installiert haben, um Toss zu bauen.
</item>
<item>Wenn man Toss unter Ubuntu kompilieren möchte, braucht man
- Pakette, die mit folgender Zeile installiert werden können.<br/>
+ Pakete, die mit folgender Zeile installiert werden können.<br/>
sudo apt-get install g++ python-qt4 python-dev pyqt4-dev-tools
ocaml-findlib menhir libounit-ocaml-dev libapache2-mod-python
sqlite3 python-pysqlite2
@@ -60,7 +60,7 @@
SVN Repository</a> zum <em>Toss</em> Verzeichnis auszuchecken.<br/>
svn co https://toss.svn.sourceforge.net/svnroot/toss/trunk/Toss Toss
</item>
- <item>Im Toss Verzeichnis führe <em>make</em> aus und überprüfe,
+ <item>Führe <em>make</em> aus im Toss Verzeichnis und überprüfe,
dass es erfolgreich funktioniert hat.</item>
</itemize>
</section>
@@ -134,11 +134,11 @@
</section>
<section title="Toss Verstehen" lang="de">
<itemize>
- <item><a href="create.html">Erzeuge</a> wenigstens ein einfaches Spiel
- mit Toss um die Grundlagen zu verstehen.</item>
+ <item><a href="create.html">Erzeuge</a> mindestens ein einfaches Spiel
+ mit Toss, um die Grundlagen zu verstehen.</item>
<item>Lese die <a href="docs.html">Dokumentation</a> von Toss.
</item>
- <item>Vergesse nicht die <a href="reference/reference.pdf">
+ <item>Vergiss nicht die <a href="reference/reference.pdf">
Reference.pdf</a> durchzublättern.</item>
<item>Wenn man Toss programmiert, ist die
<a href="code_doc/">Quellcode Dokumentation</a> oft nützlich.</item>
@@ -194,11 +194,11 @@
</itemize>
</section>
<section title="Mit Toss Team Zusammenarbeiten" lang="de">
- <par>Wenn du eine Idee für Toss hast, ein Vorschlag, eine Anfrage,
+ <par>Wenn du eine Idee für Toss hast, einen Vorschlag, eine Anfrage,
wenn du Toss programmieren möchtest oder einfach mit uns reden,
- schreibe uns! Die angagiertesten Toss Developer beantworten
- täglich Fragen über Toss auch auf privaten Emails (unten), aber es ist
- am besten an <em>toss-devel</em> zu schreiben.</par>
+ schreibe uns! Die engagiertesten Toss Developer beantworten
+ täglich Fragen über Toss auch auf privaten Emails (unten), aber
+ es ist am besten an <em>toss-devel</em> zu schreiben.</par>
<itemize>
<item>Toss Mailingliste:
<mailto address="tos...@li..."/></item>
Modified: trunk/Toss/www/docs.xml
===================================================================
--- trunk/Toss/www/docs.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/docs.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -19,9 +19,9 @@
<par><br/><toss-video/></par>
</section>
<section title="Toss Benutzen" lang="de">
- <par>Um zu lehrnen wie man Toss benutzt um neue Spiele zu erschaffen,
+ <par>Um zu lernen, wie man Toss benutzt um neue Spiele zu erschaffen,
besuche die <a href="create.html">Neue Spiele Erzeugen</a> Seite oder
- fange schnell an mit dem Video Tutorial unten.<br/></par>
+ fange mit dem Video Tutorial unten an.<br/></par>
<par><br/><toss-video/></par>
</section>
<section title="Używanie Tossa" lang="pl">
@@ -48,13 +48,13 @@
for fast fact-checking.</par>
</section>
<section title="Referenz" lang="de">
- <par>"Toss Design and Specification" ist ein oft erneuerter Dokument
- in dem wir versuchen, ein Übersicht über die mathematische Grundlagen
- von Toss und die Hauptideen der Algorithmen die wir implementiert haben
- zu geben. Es ist am besten als
+ <par><em>Toss Design and Specification</em> ist ein ständig aktuliesiertes
+ Dokument, in dem wir versuchen, eine Übersicht über die mathematische
+ Grundlagen von Toss und die Hauptideen der Algorithmen, die wir
+ implementiert haben, zu geben. Es ist am besten als
<a href="reference/reference.pdf">reference.pdf</a> zu lesen, aber
- eine <a href="reference/">html Version</a> mit niedriegerer Qualität
- steht auch zur Verfügung falls man etwas ganz schnell finden muss.</par>
+ eine <a href="reference/">html Version</a> mit niedrigerer Qualität
+ steht auch zur Verfügung, falls man etwas ganz schnell finden muss.</par>
</section>
<section title="Opis" lang="pl">
<par>"Toss Design and Specification" to ciągle zmieniający się dokument,
@@ -84,8 +84,8 @@
Wir erzeugen <a href="code_doc/">Quellcode Dokumentation</a> von
Kommentaren mit Hilfe von
<a href="http://caml.inria.fr/pub/docs/manual-ocaml/manual029.html">
- ocamldoc</a>. Es ist die aktuellste Information über Toss Quellcode,
- die Modulen und deren Zussamenhänge.</section>
+ ocamldoc</a>. Es ist die aktuellste Information über den Toss Quellcode,
+ die Module und deren Zusammenhänge.</section>
<section title="Dokumentacja Kodu" lang="pl">
<a href="code_doc/">Dokumentację z komentarzy w kodzie</a> generujemy
przy pomocy
@@ -130,32 +130,35 @@
</itemize>
</section>
+
<section title="Mathematische Grundlagen von Toss" lang="de">
- <par>Um mehr über Toss zu erfahren, folge diese Links.</par>
+ <par>Um mehr über Toss zu erfahren, folge diesen Links.</par>
<itemize>
- <item><em>Eine kompakte Darstellung</em> der mathematischen Modell hinter
- Toss findet man in <a href="pub/playing_structure_rewriting_games.pdf">
+ <item><em>Eine kompakte Darstellung</em> des mathematischen Modells auf
+ dem Toss basiert findet man in
+ <a href="pub/playing_structure_rewriting_games.pdf">
Playing Structure Rewriting Games</a>.
</item>
- <item><em>Komplexität</em> einer syntaktischen Fragment of Toss wurde
- in dem Paper <a href="pub/graph_games_short.pdf">
+ <item><em>Die Komplexität</em> eines syntaktischen Fragments von Toss
+ wurde in dem Paper <a href="pub/graph_games_short.pdf">
Synthesis for Structure Rewriting Systems</a> analysiert.
</item>
- <item><em>Eine Presentation</em> über die Mathematik von Toss wurde bei
- <em>IIT Kanpur</em> gegeben und man kann sie
+ <item><em>Eine Präsentation</em> über die Mathematik von Toss wurde bei
+ <em>IIT Kanpur</em> gegeben und kann
<a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi">
- online sehen</a>.
+ online angeschaut werden</a>.
</item>
- <item><em>Eine kürzere Presentation</em> über Toss als AI Programm wurde
- bei <em>AGI 2010</em> gegeben und man kann die auch
- <a href="http://www.vimeo.com/15326245">online sehen</a>.
+ <item><em>Eine kürzere Präsentation</em> über Toss als AI Programm wurde
+ bei <em>AGI 2010</em> gegeben und kann ebenfalls
+ <a href="http://www.vimeo.com/15326245">online angeschaut werden</a>.
</item>
</itemize>
</section>
+
<section title="Matematyczne Podstawy Tossa" lang="pl">
<par>Matematyczne podstawy Tossa są bardzo bogate. Poniższe linki
pozwalają zapoznać się z częścią z nich.</par>
Modified: trunk/Toss/www/examples.xml
===================================================================
--- trunk/Toss/www/examples.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/examples.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -29,9 +29,9 @@
</section>
<section title="Drei Gewinnt (Tic-Tac-Toe)" lang="de">
<par>Tic-Tac-Toe ist das einfachste Spiel in Toss.
- Die Spieler müssen nur die P und Q Prädikate an leere Positionen
- plazieren und die Gewinnbedingug ist durch eine einfache Formel gegeben.
- Man kann in Toss auch auf <i>Hint</i> klicken um ein Hinweis zu
+ Die Spieler müssen nur die Prädikate P und Q an leere Positionen
+ plazieren, die Gewinnbedingung ist durch eine einfache Formel gegeben.
+ Man kann in Toss auch auf <i>Hint</i> klicken, um ein Hinweis zu
bekommen.</par>
<itemize>
<item><em>(1) Tic Tac Toe.</em>
@@ -84,7 +84,7 @@
<image src="breakthrough_screen_small.png" /></a>
</section>
<section title="Einfache Brettspiele" lang="de">
- <par>Hier geben wir einige andere Beispiele von Brettspiele,
+ <par>Hier geben wir einige andere Beispiele von Brettspielen an,
die man leicht in Toss GUI erschaffen kann.</par>
<itemize>
<item><em>(2) Gomoku.</em>
Modified: trunk/Toss/www/index.xml
===================================================================
--- trunk/Toss/www/index.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/index.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -22,11 +22,11 @@
<section title="Über Toss" lang="de">
<par><em>Toss</em> erlaubt es, Spiele zu erzeugen, zu analysieren
- und zu spielen. Dank einem allgeminen Algorithmus ist es möglich,
- ein Spiel zu Bauen und direkt gegen dem Computer zu spielen.
- Hast du schon mal gewundert, wie man Schach spielt wenn die Brettmitte
- fehlt? Experimentiere mit deine Spielideen und trete
- gegen deine Freunde online an!
+ und zu spielen. Dank eines allgemeinen Algorithmus ist es möglich,
+ ein Spiel zu bauen und direkt gegen das Computer zu spielen. Hast
+ du Dich schon mal gefragt, wie man Schach spielt wenn die Brettmitte
+ fehlt? Experimentiere mit Deinen Spielideen und trete
+ gegen Deine Freunde online an!
</par>
</section>
@@ -76,9 +76,9 @@
<section title="Neue Spiele Erzeugen" lang="de">
<par>Das <a href="http://vimeo.com/10110495">Toss Tutorial</a> unten
- zeigt, wie man in Toss ein einfaches Spiel definieren kann, und es
+ zeigt, wie man in Toss ein einfaches Spiel definieren kann, und
erklärt auch einige andere Features von Toss. Mit Toss ist es möglich,
- deine Spielideen zu realisieren! Lehrne wie man mit Toss neue
+ Deine Spielideen zu realisieren! Lerne wie man mit Toss neue
<a href="create.html">Spiele erzeugt.</a>
<br/></par>
<par><br/><toss-video/></par>
@@ -131,30 +131,30 @@
<section title="Eigenschaften von Toss" lang="de">
- <par>Die Spiele in Toss sind durch relationale Strukturen definiert,
- und die Züge durch Graphersetzungregeln. Das Ergebniss eines Spiels
- wird durch Formeln der monadischer Logik zweiter Stufe definiert, die
- in Toss mit Zählquantoren erweitert ist, um reele Werte zu liefern.</par>
+ <par>Die Spiele in Toss sind durch relationale Strukturen definiert
+ und die Züge durch Graphersetzungsregeln. Das Ergebnis eines Spiels
+ wird durch Formeln der monadischen Logik zweiter Stufe definiert, die
+ in Toss mit Zählquantoren erweitert ist, um reelle Werte zu liefern.</par>
<itemize>
- <item><em>Strukturen</em> in Toss können beliebiege Relationen beinhalten
- und dazu noch zusätzliche Funktionen mir reelen Werte.</item>
- <item><em>Ersetzungsregeln</em> werden ausgeführt indem die Struktur
+ <item><em>Strukturen</em> in Toss können beliebige Relationen beinhalten
+ und zusätzlich Funktionen mit reellen Werten.</item>
+ <item><em>Ersetzungsregeln</em> werden ausgeführt, indem die Struktur
auf der linken Seite mit der Hauptstruktur gematcht wird und danach
- mit der auf der rechten Seite ersetzt wird.</item>
- <item><em>Kontinuerliche dynamik</em> kann durch ein ODE System
+ durch die Struktur auf der rechten Seite ersetzt wird.</item>
+ <item><em>Kontinuerliche Dynamik</em> kann durch ein ODE-System
eingegeben werden. Das erlaubt die Simulation von Bewegung und
- andere physykalischen Eigenschaften der Objekte.</item>
+ anderen physikalischen Eigenschaften der Objekte.</item>
<item><em>Zusätzliche Bedingungen</em> können die Ersetzungsregeln
- beschränken. Dazu gehören Prekonditionen, Invarianten, und
- Postkonditionen.</item>
+ einschränken. Dazu gehören Vorbedingungen, Invarianten, und
+ Nachbedingungen.</item>
<item><em>Logik</em> wird benutzt, um die Bedingungen und die Ergebnisse
zu definieren. In Toss ist die vollständige monadische Logik zweiter
Stufe implementiert, mit zusätzlichen Zählquantoren.</item>
- <item><em>Der Solver</em> in Toss ist stark optimiert. Es eliminiert
+ <item><em>Der Solver</em> in Toss ist stark optimiert. Er eliminiert
die Quantoren wenn möglich und dekomponiert die Formel
(mit Hilfe von <a href="http://minisat.se/">MiniSat</a>).</item>
<item><em>Hinweise</em> können dadurch allgemein in allen Spielen
- gegeben werden, der Zugauswahl passiert durch UCT oder Maximax.</item>
+ gegeben werden, die Zugauswahl passiert durch UCT oder Maximax.</item>
</itemize>
</section>
@@ -249,31 +249,32 @@
</section>
<section title="Mathematische Grundlagen von Toss" lang="de">
- <par>Um mehr über Toss zu erfahren, folge diese Links.</par>
+ <par>Um mehr über Toss zu erfahren, folge diesen Links.</par>
<itemize>
- <item><em>Eine kompakte Darstellung</em> der mathematischen Modell hinter
- Toss findet man in <a href="pub/playing_structure_rewriting_games.pdf">
+ <item><em>Eine kompakte Darstellung</em> des mathematischen Modells auf
+ dem Toss basiert findet man in
+ <a href="pub/playing_structure_rewriting_games.pdf">
Playing Structure Rewriting Games</a>.
</item>
- <item><em>Design und Specifikation</em> von Toss sind im
+ <item><em>Das Design und die Specifikation</em> von Toss sind in
<a href="reference/reference.pdf">reference.pdf</a> beschrieben.
</item>
- <item><em>Komplexität</em> einer syntaktischen Fragment of Toss wurde
- in dem Paper <a href="pub/graph_games_short.pdf">
+ <item><em>Die Komplexität</em> eines syntaktischen Fragments von Toss
+ wurde in dem Paper <a href="pub/graph_games_short.pdf">
Synthesis for Structure Rewriting Systems</a> analysiert.
</item>
- <item><em>Eine Presentation</em> über die Mathematik von Toss wurde bei
- <em>IIT Kanpur</em> gegeben und man kann sie
+ <item><em>Eine Präsentation</em> über die Mathematik von Toss wurde bei
+ <em>IIT Kanpur</em> gegeben und kann
<a href="http://www2.cse.iitk.ac.in/~fsttcs/2009/videos/star/LukaszKaiser.avi">
- online sehen</a>.
+ online angeschaut werden</a>.
</item>
- <item><em>Eine kürzere Presentation</em> über Toss als AI Programm wurde
- bei <em>AGI 2010</em> gegeben und man kann die auch
- <a href="http://www.vimeo.com/15326245">online sehen</a>.
+ <item><em>Eine kürzere Präsentation</em> über Toss als AI Programm wurde
+ bei <em>AGI 2010</em> gegeben und kann ebenfalls
+ <a href="http://www.vimeo.com/15326245">online angeschaut werden</a>.
</item>
</itemize>
</section>
Modified: trunk/Toss/www/play.xml
===================================================================
--- trunk/Toss/www/play.xml 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/play.xml 2011-03-29 15:52:15 UTC (rev 1403)
@@ -30,20 +30,20 @@
</section>
<section title="Allgemeines Spielen (General Game Playing)" lang="de">
<a href="http://en.wikipedia.org/wiki/General_Game_Playing">General
- Game Playing</a>, kurz GGP, fördert von einem Computer dass er
+ Game Playing</a>, kurz GGP, fordert von einem Computer, dass er
ein vorher unbekanntes Spiel spielt. Es ist ein stark wachsendes KI Feld
- mit Wissenschaftler bei <a href="http://games.stanford.edu/">Stanford</a>
- und in <a href="http://www.general-game-playing.de/">Deutschland</a>.
- Programme, die Spiele in GDL-Format spielen können kann man auf dem
+ mit Wissenschaftlern in <a href="http://games.stanford.edu/">Stanford</a>
+ und <a href="http://www.general-game-playing.de/">Deutschland</a>.
+ Programme, die Spiele in GDL-Format spielen können, kann man auf dem
<a href="http://euklid.inf.tu-dresden.de:8180/ggpserver/">
Dresden GGP Server</a> gegeneinander spielen lassen, und Toss hat
- da letztens auch einiger Erfolgreiche Partien gespielt.
+ da in letzter Zeit auch einige erfolgreiche Partien gespielt.
<br/>
Spiele im GDL-Format lassen sich nicht direkt Online darstellen, aber
das <a href="http://code.google.com/p/ggp-galaxy/">GGP Galaxy Project</a>
- hat letztens angefangen zu versuchen, dieses Problem zu beseitigen.
+ hat vor kurzem angefangen zu versuchen, dieses Problem zu beseitigen.
Die Spiele im Toss-Format kann man dagegen direkt Online ansehen und
- spielen. Darunter zeigen wir einige Spiele von Toss gegen Fluxplayer.
+ spielen. Unten zeigen wir einige Spiele von Toss gegen Fluxplayer.
</section>
<section title="Ogólne Programy do Gier (General Game Playing)" lang="pl">
<a href="http://en.wikipedia.org/wiki/General_Game_Playing">General
Modified: trunk/Toss/www/upload_sourceforge.sh
===================================================================
--- trunk/Toss/www/upload_sourceforge.sh 2011-03-28 09:37:24 UTC (rev 1402)
+++ trunk/Toss/www/upload_sourceforge.sh 2011-03-29 15:52:15 UTC (rev 1403)
@@ -1,6 +1,6 @@
#!/bin/bash
-#scp index.html.en $1,To...@we...:htdocs/index.html
-#scp -C *.html.* $1,To...@we...:htdocs/
+scp index.html.en $1,To...@we...:htdocs/index.html
+scp -C *.html.* $1,To...@we...:htdocs/
scp -C Publications/*.html.* $1,To...@we...:htdocs/Publications/
scp -C styles/* $1,To...@we...:htdocs/styles/
scp -C scripts/* $1,To...@we...:htdocs/scripts/
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-28 09:37:30
|
Revision: 1402
http://toss.svn.sourceforge.net/toss/?rev=1402&view=rev
Author: lukaszkaiser
Date: 2011-03-28 09:37:24 +0000 (Mon, 28 Mar 2011)
Log Message:
-----------
Better timeout, < 0.1s divergence now.
Modified Paths:
--------------
trunk/Toss/Play/GameTree.ml
Modified: trunk/Toss/Play/GameTree.ml
===================================================================
--- trunk/Toss/Play/GameTree.ml 2011-03-27 01:37:34 UTC (rev 1401)
+++ trunk/Toss/Play/GameTree.ml 2011-03-28 09:37:24 UTC (rev 1402)
@@ -87,13 +87,17 @@
Solver.M.clear_timeout ();
Node (state, player,info_node depth game state player children,children)
| Node (state, player, info, children) ->
- if timeout() then raise (Aux.Timeout "GameTree.unfold_abstract.node");
+ if timeout() then raise (Aux.Timeout "GameTree.unfold_abstract.node1");
+ Solver.M.set_timeout timeout;
let n = choice depth game state player info children in
let (move, child) = children.(n) in
+ Solver.M.clear_timeout ();
+ if timeout() then raise (Aux.Timeout "GameTree.unfold_abstract.node2");
let child_unfolded = unfold_abstract ~timeout:timeout ~depth:(depth+1)
game ~info_terminal:info_terminal ~info_leaf:info_leaf
~info_node:info_node ~choice:choice child in
children.(n) <- (move, child_unfolded);
+ if timeout() then raise (Aux.Timeout "GameTree.unfold_abstract.node3");
Node (state, player, info_node depth game state player children, children)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-27 01:37:40
|
Revision: 1401
http://toss.svn.sourceforge.net/toss/?rev=1401&view=rev
Author: lukaszkaiser
Date: 2011-03-27 01:37:34 +0000 (Sun, 27 Mar 2011)
Log Message:
-----------
More timeout points in Server.
Modified Paths:
--------------
trunk/Toss/Solver/Solver.ml
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-03-26 23:49:28 UTC (rev 1400)
+++ trunk/Toss/Solver/Solver.ml 2011-03-27 01:37:34 UTC (rev 1401)
@@ -322,6 +322,7 @@
(* Eval with very basic caching. *)
let eval_m struc phi =
if phi = And [] then Any else (
+ check_timeout "Solver.eval_m.start";
update_cache struc;
try
let (res, _) = Hashtbl.find !cache_results phi in
@@ -332,7 +333,7 @@
with Not_found ->
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";
+ check_timeout "Solver.eval_m.not_found";
let asg = eval struc (ref els) Any phi in
incr eval_counter;
Hashtbl.add !cache_results phi (asg, phi_rels phi);
@@ -390,6 +391,7 @@
print_endline ("phi: " ^ (Formula.str phi));
print_endline ("proc phi: " ^ (Formula.str proc_phi));
);
+ check_timeout "Solver.eval_cache_sentences";
eval_m struc proc_phi
@@ -397,7 +399,8 @@
other than those assigned in [asg] explicitely. *)
let rec get_real_val solver asg expr struc =
let check_fa phi = (* check_f struc asg phi in *)
- if FormulaOps.free_vars phi = [] then
+ check_timeout "Solver.get_real_val.check_fa";
+ if FormulaOps.free_vars phi = [] then
(eval_cache_sentences solver struc phi) <> Empty
else check_f struc asg phi in
match expr with
@@ -414,6 +417,7 @@
print_endline ("sum vars " ^ (Formula.var_list_str vl));
print_endline ("all vars " ^ (Formula.var_list_str all_vs));
);
+ check_timeout "Solver.get_real_val.sum";
let asg_gd = join asg (eval_cache_sentences solver struc guard) in
let tps = tuples struc.elements (List.map var_str all_vs) asg_gd in
let add_val acc tp =
@@ -421,6 +425,7 @@
acc +. (get_real_val solver tp_asg r struc) in
List.fold_left add_val 0. tps
| _ ->
+ check_timeout "Solver.get_real_val.other";
let rec get_rval = function
| FO (_, [(_, a)]) -> get_rval a
| Real
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-26 23:49:34
|
Revision: 1400
http://toss.svn.sourceforge.net/toss/?rev=1400&view=rev
Author: lukstafi
Date: 2011-03-26 23:49:28 +0000 (Sat, 26 Mar 2011)
Log Message:
-----------
Removed forcing non-monotonic (it is detected correctly). GameTree+Play added to test suite (alpha-beta-ord moved to GameBig).
Modified Paths:
--------------
trunk/Toss/Play/GameTest.ml
Modified: trunk/Toss/Play/GameTest.ml
===================================================================
--- trunk/Toss/Play/GameTest.ml 2011-03-26 20:52:16 UTC (rev 1399)
+++ trunk/Toss/Play/GameTest.ml 2011-03-26 23:49:28 UTC (rev 1400)
@@ -219,22 +219,37 @@
let compute_try search_method randomize effort timer_sec
(horizon, advr, state) loc msg pred =
- let p,ps = Game.initialize_default
- state ~advr ?horizon ~loc ~effort ~search_method () in
- let compute_move () =
- ignore (Unix.alarm timer_sec);
- let res =
- Aux.unsome (Game.suggest p ps) in
- Game.cancel_timeout ();
- res in
- if randomize then
- try_n_times 5 state compute_move pred msg
- else
- let move, _ = compute_move () in
- let move_str = move_gs_str (snd state) move in
- assert_bool
- (Printf.sprintf "%s: Failed move: %s." msg move_str)
- (pred move_str)
+ if search_method = "GameTree"
+ then
+ let heur = Heuristic.default_heuristic
+ ~struc:(snd state).Arena.struc
+ ~advr (fst state) in
+ Play.set_timeout (float(timer_sec));
+ let (move, _) = Play.maximax_unfold_choose effort
+ (fst state) (snd state) heur in
+ Play.cancel_timeout ();
+ let move_str = move_gs_str (snd state) move in
+ assert_bool
+ (Printf.sprintf "%s: Failed move: %s." msg move_str)
+ (pred move_str)
+
+ else
+ let p,ps = Game.initialize_default
+ state ~advr ?horizon ~loc ~effort ~search_method () in
+ let compute_move () =
+ ignore (Unix.alarm timer_sec);
+ let res =
+ Aux.unsome (Game.suggest p ps) in
+ Game.cancel_timeout ();
+ res in
+ if randomize then
+ try_n_times 5 state compute_move pred msg
+ else
+ let move, _ = compute_move () in
+ let move_str = move_gs_str (snd state) move in
+ assert_bool
+ (Printf.sprintf "%s: Failed move: %s." msg move_str)
+ (pred move_str)
@@ -920,10 +935,8 @@
P Q Q +Q . . .
\" with DiagA (x, y) = ex u (R(x, u) and C(u, y)) ;
DiagB (x, y) = ex u (R(x, u) and C(y, u))" 0 in
- Heuristic.use_monotonic := false;
easy_case state 0 "should attack"
(fun mov_s -> "Cross{1:a4}" = mov_s);
- Heuristic.use_monotonic := true;
);
"connect4 avoid losing" >::
@@ -944,10 +957,8 @@
... Q..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))" 0 in
- Heuristic.use_monotonic := false;
hard_small_case state 0 "should not attack"
(fun mov_s -> "Cross{1:f3}" <> mov_s);
- Heuristic.use_monotonic := true;
);
@@ -969,10 +980,8 @@
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))" 0 in
- Heuristic.use_monotonic := false;
hard_case state 0 "should defend"
(fun mov_s -> "Cross{1:e2}" = mov_s);
- Heuristic.use_monotonic := true
);
@@ -980,11 +989,12 @@
let tests = "Game" >::: [
misc_tests;
- search_tests "alpha_beta_ord" "effort 2 3 4" false 2 120 3 240 4 360;
+ search_tests "GameTree" "iters 75 230 300" false 75 120 230 240 300 360;
]
let bigtests = "GameBig" >::: [
misc_tests_big;
+ search_tests "alpha_beta_ord" "depth 2 3 4" false 2 120 3 240 4 360;
search_tests "alpha_beta_ord" "time 10 60 120" false 10 10 10 60 10 120;
]
@@ -1032,9 +1042,9 @@
);
]
-let a () = Aux.run_test_if_target "GameTest" tests
+let a = Aux.run_test_if_target "GameTest" tests
-let a () = Aux.run_test_if_target "GameTest" bigtests
+let a = Aux.run_test_if_target "GameTest" bigtests
let a () = run_test_tt ~verbose:true experiments
@@ -1044,9 +1054,7 @@
(* DiscreteRule.debug_level := 5; *)
Game.set_debug_level 10
-let a () = Heuristic.use_monotonic := false
-
-let a =
+let a () =
match test_filter
["GameBig:0:misc_big:3:chess draw"]
bigtests
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <luk...@us...> - 2011-03-26 20:52:23
|
Revision: 1399
http://toss.svn.sourceforge.net/toss/?rev=1399&view=rev
Author: lukstafi
Date: 2011-03-26 20:52:16 +0000 (Sat, 26 Mar 2011)
Log Message:
-----------
ServerTest: shielding against possible change of use_monotonic (GDL translation and play).
Modified Paths:
--------------
trunk/Toss/Server/ServerTest.ml
Modified: trunk/Toss/Server/ServerTest.ml
===================================================================
--- trunk/Toss/Server/ServerTest.ml 2011-03-26 18:52:18 UTC (rev 1398)
+++ trunk/Toss/Server/ServerTest.ml 2011-03-26 20:52:16 UTC (rev 1399)
@@ -52,6 +52,10 @@
let old_det_suggest = !Game.deterministic_suggest in
Game.deterministic_suggest := true;
let old_translation = !GDL.manual_translation in
+ let old_force_competitive = !Heuristic.force_competitive in
+ let old_use_monotonic = !Heuristic.use_monotonic in
+ Heuristic.use_monotonic := true;
+ Heuristic.force_competitive := false;
GDL.manual_translation := false;
let in_ch = open_in "./Server/ServerGDLTest.in2" in
let out_ch = open_out "./Server/ServerGDLTest.temp" in
@@ -71,7 +75,9 @@
assert_equal ~printer:(fun x->x)
(strip_spaces target) (strip_spaces result);
GDL.manual_translation := old_translation;
- Game.default_effort := old_effort
+ Game.default_effort := old_effort;
+ Heuristic.force_competitive := old_force_competitive;
+ Heuristic.use_monotonic := old_use_monotonic
);
]
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
