Thread: [Toss-devel-svn] SF.net SVN: toss:[1187] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
From: <luk...@us...> - 2010-11-21 20:45:53
|
Revision: 1187 http://toss.svn.sourceforge.net/toss/?rev=1187&view=rev Author: lukstafi Date: 2010-11-21 20:45:43 +0000 (Sun, 21 Nov 2010) Log Message: ----------- Cleanup of Aux: removed unused functions, some functions used once moved to their use site. AuxTest test suite. Modified Paths: -------------- trunk/Toss/Arena/DiscreteRule.ml trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/Formula/BoolFormula.ml trunk/Toss/Formula/FFTNF.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/Heuristic.ml trunk/Toss/Solver/AssignmentSet.ml trunk/Toss/Solver/Assignments.ml trunk/Toss/Solver/FFSolver.ml trunk/Toss/Solver/Structure.ml trunk/Toss/TossTest.ml Modified: trunk/Toss/Arena/DiscreteRule.ml =================================================================== --- trunk/Toss/Arena/DiscreteRule.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Arena/DiscreteRule.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -209,10 +209,7 @@ let enumerate_matchings model rule matches = let all_elems = Structure.Elems.elements model.Structure.elements in let assgns = - (* Aux.drop_repeating ( - List.sort Pervasives.compare ( *) - enumerate_assgns all_elems rule.lhs_elem_vars matches - (* )) *) in + enumerate_assgns all_elems rule.lhs_elem_vars matches in List.map (assignment_to_embedding rule) assgns (* Helpers for special relations. *) @@ -228,6 +225,12 @@ Some (String.sub rel 1 (String.index_from rel 1 '_' - 1)) with Not_found -> None +(* Return the result of the first index [i] that passes the + given test, and [i+1]. *) +let rec first_i n gen test = + let res = gen n in + if test res then n+1, res else first_i (n+1) gen test + (* Rewrite the model [given_model], allowing the elements to be cloned and deleted. Also change the "trace" of rewritten elements. @@ -251,7 +254,7 @@ let _, alloc_elems, rmmap = List.fold_left (fun (next, alloc_elems, rmmap) evar -> let next, nelem = - Aux.first_i next (fun i->i) (fun i-> not (Els.mem i elems)) in + first_i next (fun i->i) (fun i-> not (Els.mem i elems)) in next, nelem::alloc_elems, (evar, nelem)::rmmap) (1, [], []) rule_obj.rhs_elem_vars in (* Select a nice name in case elements in the model are named. In @@ -470,6 +473,44 @@ module STups = Structure.Tuples +(** Return the nth dimensional "triangle matrix", as the set of [n] + element subsets of [l]. *) +let triang_product n l = + let rec mult1 = function + | [],[] -> [] + | [_],[_] -> [] + | e::es,(_::rs) -> List.map (fun r->e::r) rs::mult1 (es, rs) + | _ -> failwith "triang_product: impossible" in + let rec mult2 = function + (*| [],[] -> []*) + | [_],[] -> [] + | [_;_],[_] -> [] + | e::es,(_::rs) -> List.map (List.map (fun r->e::r)) rs::mult2 (es, rs) + | _ -> failwith "triang_product: impossible" in + let rec multn = function + | _,[] -> [] + | _,[_] -> [] + | _,[_;[[]]] -> [] + | e::es,(_::rs) -> + List.map (concat_map (List.map (fun r->e::r))) rs::multn (es, rs) + | _ -> failwith "triang_product: impossible" in + let ls = List.map (fun e->[e]) l in + match n with + | 0 -> [] + | 1 -> ls + | 2 -> List.flatten (mult1 (l,ls)) + | 3 -> + let lls = mult1 (l,ls) in + List.flatten (List.flatten (mult2 (l,lls))) + | n -> + let rec aux n acc = + if n=0 then acc + else aux (n-1) (multn (l,acc)) in + let lls = mult1 (l,ls) in + let llls = mult2 (l,lls) in + List.flatten (List.flatten (aux (n-3) llls)) + + (** Translate a rule specification into a processed form. Note that when a relation is in $\tau_h$, and is present in the LHS but not in the RHS, it is still not removed by a rewrite. @@ -598,8 +639,8 @@ (* check if the map is a total 1-1 onto, if so, [rlmap=None], optimize *) let rlmap = let rimg, ldom = List.split rule_src.rule_s in - let rimg = Aux.drop_repeating (List.sort Pervasives.compare rimg) - and ldom = Aux.drop_repeating (List.sort Pervasives.compare ldom) in + let rimg = Aux.unique (=) rimg + and ldom = Aux.unique (=) ldom in let nimg = List.length rimg and ndom = List.length ldom in if nimg = Els.cardinal rule_src.rhs_struc.Structure.elements && ndom = Els.cardinal rule_src.lhs_struc.Structure.elements && Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Formula/Aux.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -30,15 +30,6 @@ in List.rev (maps_f [] l) -let rec map_some2 f l1 l2 = - match (l1, l2) with - ([], []) -> [] - | (a1::l1, a2::l2) -> - (match f a1 a2 with - | None -> map_some2 f l1 l2 - | Some r -> r :: map_some2 f l1 l2) - | (_, _) -> invalid_arg "map_some2" - let map_reduce mapf redf red0 l = match List.sort (fun x y -> compare (fst x) (fst y)) (List.map mapf l) with @@ -50,38 +41,19 @@ List.rev (List.map (fun (k,vs) -> k, List.fold_left redf red0 vs) ((k0,vs)::l)) -let rec drop_repeating = function - | hd::(nk::tl as rest) when hd = nk -> drop_repeating rest - | hd::tl -> hd::drop_repeating tl - | tl -> tl - -let rec has_repeating = function - | [] -> false - | hd::tl when List.mem hd tl -> true - | hd::tl -> has_repeating tl - let list_remove v l = List.filter (fun w->v<>w) l -let list_existsi p l = - let rec aux i = function - | [] -> false - | a::l -> p i a || aux (i+1) l in - aux 0 l - let rec rev_assoc l x = match l with [] -> raise Not_found - | (a,b)::l -> if compare b x = 0 then a else rev_assoc l x + | (a,b)::l -> if b = x then a else rev_assoc l x let rev_assoc_all l x = let rec aux acc = function | [] -> acc | (a,b)::l -> - if compare b x = 0 then aux (a::acc) l else aux acc l in + if b = x then aux (a::acc) l else aux acc l in aux [] l -let replace_assoc k v l = - (k, v)::(List.remove_assoc k l) - let rec replace_assoc k v = function | [] -> [k, v] | (a, b as pair) :: l -> @@ -95,53 +67,10 @@ else aux (pair :: acc) l in aux [] l - -let find_max cmp l = - let rec find acc = function - | hd::tl -> - if cmp hd acc <= 0 then find acc tl - else find hd tl - | [] -> acc in - match l with - | [] -> invalid_arg "find_max: empty list" - | hd::tl -> find hd tl - -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 - | [] -> acc in - match l with - | [] -> invalid_arg "find_all_max: empty list" - | hd::tl -> find hd [hd] tl - -let insert_ordered cmp e l = - let rec aux = function - | [] -> [e] - | hd::_ as l when cmp e hd <= 0 -> e::l - | hd::tl -> hd::aux tl in - aux l - let unsome = function | Some v -> v | None -> raise (Invalid_argument "unsome") -let rev_map_choose f l = - let rec rmap_f accu = function - | [] -> None, accu, [] - | a::tl -> - match f a with - | Left r -> rmap_f (r :: accu) tl - | Right r -> Some r, accu, tl in - rmap_f [] l - -let rec try_find f = function - | [] -> raise Not_found - | hd::tl -> try f hd with Not_found -> try_find f tl - let rec map_try f = function | [] -> [] | hd::tl -> @@ -155,75 +84,21 @@ concat_map (fun el -> List.map (fun tup -> el::tup) prod) set) l [[]] -let gproduct f r0 l = - List.fold_right (fun set prod -> - concat_map (fun el -> List.map (fun tup -> f el tup) prod) set) - l [r0] +let all_tuples_for args elems = + List.fold_left (fun tups _ -> + concat_map (fun e -> (List.map (fun tup -> e::tup) tups)) + elems) [[]] args -let triang_product n l = - let rec mult1 = function - | [],[] -> [] - | [_],[_] -> [] - | e::es,(_::rs) -> List.map (fun r->e::r) rs::mult1 (es, rs) - | _ -> failwith "triang_product: impossible" in - let rec mult2 = function - (*| [],[] -> []*) - | [_],[] -> [] - | [_;_],[_] -> [] - | e::es,(_::rs) -> List.map (List.map (fun r->e::r)) rs::mult2 (es, rs) - | _ -> failwith "triang_product: impossible" in - let rec multn = function - | _,[] -> [] - | _,[_] -> [] - | _,[_;[[]]] -> [] - | e::es,(_::rs) -> - List.map (concat_map (List.map (fun r->e::r))) rs::multn (es, rs) - | _ -> failwith "triang_product: impossible" in - let ls = List.map (fun e->[e]) l in - match n with - | 0 -> [] - | 1 -> ls - | 2 -> List.flatten (mult1 (l,ls)) - | 3 -> - let lls = mult1 (l,ls) in - List.flatten (List.flatten (mult2 (l,lls))) - | n -> - let rec aux n acc = - if n=0 then acc - else aux (n-1) (multn (l,acc)) in - let lls = mult1 (l,ls) in - let llls = mult2 (l,lls) in - List.flatten (List.flatten (aux (n-3) llls)) - let rec remove_one e = function | hd::tl when hd = e -> tl | hd::tl -> hd::(remove_one e tl) | [] -> [] -let rec remove_nth n = function - | [] -> invalid_arg "remove_nth" - | hd::tl when n<=0 -> tl - | hd::tl -> hd::(remove_nth (n-1) tl) +let rec insert_nth n e = function + | l when n<=0 -> e::l + | [] -> raise Not_found + | hd::tl -> hd::(insert_nth (n-1) e tl) - -let rec extract_nth n = function - | [] -> invalid_arg "extract_nth" - | hd::tl when n<=0 -> hd, tl - | hd::tl -> - let e, tl = extract_nth (n-1) tl in - e, hd::tl - -let rec replace_nth n e = function - | [] -> invalid_arg "replace_nth" - | hd::tl when n<=0 -> e::tl - | hd::tl -> hd::(replace_nth (n-1) e tl) - - -let rec add_nth n e = function - | [] -> [e] - | hd::tl when n<=0 -> e::hd::tl - | hd::tl -> hd::(add_nth (n-1) e tl) - let find_index v l = let rec aux n = function | [] -> raise Not_found @@ -231,20 +106,6 @@ | _::tl -> aux (n+1) tl in aux 0 l -let sample n l = - let s = List.length l in - let rec samp n = - if n=0 then [] - else (List.nth l (Random.int s))::samp (n-1) in - samp n - -let rec first_i n gen test = - let res = gen n in - if test res then n+1, res else first_i (n+1) gen test - -let rec map_for b n f = - if b < n then (f b)::(map_for (b+1) n f) else [] - let maximal cmp l = let rec aux acc = function | hd::tl when @@ -257,13 +118,10 @@ (* TODO: that's quadratic, perhaps (sort |> drop_repeating) would be faster in practice *) -let unique cmp l = - let rec aux acc = function - | hd::tl when not (List.exists (fun x->cmp hd x) acc) -> - aux (hd::acc) tl - | hd::tl -> aux acc tl - | [] -> acc in - List.rev (aux [] l) +let rec unique eq = function + | [] -> [] + | x :: xs -> + x :: unique eq (List.filter (fun y -> not (eq y x)) xs) let take_n n l = let rec aux n acc = function @@ -272,36 +130,6 @@ | _ -> acc in List.rev (aux n [] l) -let take_n_unique n l = - let rec aux n acc = function - | hd::tl when n > 0 && not (List.mem hd acc) -> - aux (n-1) (hd::acc) tl - | hd::tl when n > 0 -> aux n acc tl - | _ -> acc in - List.rev (aux n [] l) - -let concat_unique ls = - let rec conc acc = function - | [] -> acc - | []::rest -> conc acc rest - | (hd::tl)::rest when List.mem hd acc -> conc acc (tl::rest) - | (hd::tl)::rest -> conc (hd::acc) (tl::rest) in - List.rev (conc [] ls) - -let prefix_free ls = - let rec prefix = function - | [],[] -> false - | [],_ -> true - | hd1::tl1, hd2::tl2 when hd1=hd2 -> prefix (tl1,tl2) - | _ -> false in - let rec aux acc = function - | hd::tl when not (List.exists (fun x->hd=x) acc) && - not (List.exists (fun l2->prefix (l2,hd)) ls) -> - aux (hd::acc) tl - | hd::tl -> aux acc tl - | [] -> acc in - List.rev (aux [] ls) - let array_map2 f a b = let l = Array.length a in if l <> Array.length b then @@ -317,58 +145,9 @@ r end -let array_mapi2 f a b = - let l = Array.length a in - if l <> Array.length b then - raise (Invalid_argument "Aux.array_mapi2") - else - if l = 0 then [||] else begin - let r = Array.create l - (f 0 (Array.unsafe_get a 0) (Array.unsafe_get b 0)) in - for i = 1 to l - 1 do - Array.unsafe_set r i - (f i (Array.unsafe_get a i) (Array.unsafe_get b i)) - done; - r - end - -let array_fold_map f acc a = - let l = Array.length a in - if l = 0 then acc, [||] else begin - let acc, e = f acc (Array.unsafe_get a 0) in - let prev = ref acc in - let r = Array.create l e in - for i = 1 to l - 1 do - let acc, e = f !prev (Array.unsafe_get a i) in - prev := acc; - Array.unsafe_set r i e - done; - !prev, r - end - let array_combine a b = - let l = Array.length a in - if l <> Array.length b then - raise (Invalid_argument "Aux.array_combine") - else - if l = 0 then [||] else begin - let r = Array.create l - (Array.unsafe_get a 0, Array.unsafe_get b 0) in - for i = 1 to l - 1 do - Array.unsafe_set r i - (Array.unsafe_get a i, Array.unsafe_get b i) - done; - r - end + array_map2 (fun x y->x,y) a b -let array_exists p a = - let res = ref false in - let i = ref 0 in - while !i < Array.length a && not !res do - res := p (Array.unsafe_get a !i); - incr i - done; !res - let array_existsi p a = let res = ref false in let i = ref 0 in @@ -378,7 +157,7 @@ done; !res let array_mem e a = - array_exists (fun x -> e=x) a + array_existsi (fun _ x -> e=x) a let array_from_assoc l = match l with @@ -401,54 +180,6 @@ | hd::tl -> Array.unsafe_set a i (f hd); fill (i+1) tl in fill 1 tl -(* Same as [Array.of_list (List.concat (List.map (fun x-> List.map (g - x) (f x)) l))] *) -let array_concat_map_of_list f g = function - [] -> [||] - | hd::tl as l -> - let ls = List.map f l in - let len = - List.fold_left (fun acc l->acc + List.length l) 0 ls in - if len = 0 then [||] else - let org = ref l in - let rec seek = function - | [] -> assert false - | []::tl -> org := List.tl !org; seek tl - | (hd::_)::_ -> hd in - let e = seek ls in - let a = Array.make len (g (List.hd !org) e) in - let hd = ref (List.hd ls) and tl = ref (List.tl ls) in - while !hd=[] do - hd := List.hd !tl; tl := List.tl !tl - done; - let e = ref (List.hd !org) in - hd := List.tl !hd; - for i=1 to len-1 do - while !hd=[] do - hd := List.hd !tl; tl := List.tl !tl; - org := List.tl !org; e := List.hd !org - done; - Array.unsafe_set a i (g !e (List.hd !hd)); - hd := List.tl !hd - done; - a - -let array_fold_while p f x a = - let r = ref x and i = ref 0 in - let n = Array.length a in - while !i < n && p (Array.unsafe_get a !i) do - r := f !r (Array.unsafe_get a !i); incr i - done; - !r - -let array_find f a = - let i = ref 0 in - let n = Array.length a in - while !i < n && not (f (Array.unsafe_get a !i)) do - incr i done; - if !i >= n then raise Not_found - else Array.unsafe_get a !i - let array_argfind f a = let i = ref 0 in let n = Array.length a in @@ -473,37 +204,6 @@ done; !r -let array_for_all f a = - try - for i = 0 to Array.length a - 1 do - if not (f (Array.unsafe_get a i)) then - raise Not_found - done; - true - with Not_found -> false - -let array_for_all2 f a b = - let len = min (Array.length a) (Array.length b) in - try - for i = 0 to len - 1 do - if not (f (Array.unsafe_get a i) (Array.unsafe_get b i)) then - raise Not_found - done; - true - with Not_found -> false - -let array_argfind_max cmp a = - let n = Array.length a in - if n=0 then failwith "array_argfind_max: empty array" - else - let best = ref (Array.unsafe_get a 0) - and besti = ref 0 in - for i = 1 to n-1 do - let e = Array.unsafe_get a i in - if cmp e !best > 0 then (best := e; besti := i) - done; - !besti - let array_argfind_all_max cmp a = let n = Array.length a in if n=0 then [] @@ -517,12 +217,34 @@ else if res = 0 then besti := i:: !besti done; !besti + +let array_for_all f a = + try + for i = 0 to Array.length a - 1 do + if not (f (Array.unsafe_get a i)) then + raise Not_found + done; + true + with Not_found -> false +let array_for_all2 f a b = + let len = Array.length a in + if len <> Array.length b then + raise (Invalid_argument "Aux.array_for_all2") + else + try + for i = 0 to len - 1 do + if not (f (Array.unsafe_get a i) (Array.unsafe_get b i)) then + raise Not_found + done; + true + with Not_found -> false + let neg f x = not (f x) let partition_choice l = let rec split laux raux = function - | [] -> laux, raux + | [] -> List.rev laux, List.rev raux | Left e::tl -> split (e::laux) raux tl | Right e::tl -> split laux (e::raux) tl in split [] [] l @@ -536,11 +258,6 @@ | Right e -> split laux (e::raux) tl in split [] [] l -let rec split_triples = function - [] -> ([], [], []) - | (x,y,z)::l -> - let (rx, ry, rz) = split_triples l in (x::rx, y::ry, z::rz) - let transpose_lists lls = let rec aux acc = function | [] -> List.map List.rev acc @@ -551,28 +268,17 @@ | hd::tl -> aux (List.map (fun e->[e]) hd) tl -let all_tuples_for args elems = - List.fold_left (fun tups _ -> - concat_map (fun e -> (List.map (fun tup -> e::tup) tups)) - elems) [[]] args - let rec fold_n f accu n = if n <= 0 then accu else fold_n f (f accu) (n-1) -let rec foldi_n f accu n = - let accu = ref accu in - for i=1 to n do - accu := f i !accu - done; !accu +(* Return the result of the first index [i] that passes the + given test, and [i+1]. *) +let rec first_i n gen test = + let res = gen n in + if test res then n+1, res else first_i (n+1) gen test -let all_tuples_n arity elems = - fold_n (fun tups -> - concat_map (fun e -> (List.map (fun tup -> e::tup) tups)) - elems) [[]] arity - - let new_filename basename suffix = if not (Sys.file_exists (basename^suffix)) then basename^suffix else @@ -585,34 +291,13 @@ snd (first_i 0 (fun i -> s^(string_of_int i)) (fun v -> not (Strings.mem v names))) -let not_conflicting_name_cands names cands = - let _ = if cands = [] then - failwith "not_conflicting_name: no candidates" in - if List.exists (fun s->not (Strings.mem s names)) cands - then List.find (fun s->not (Strings.mem s names)) cands - else - let ncands = List.map (fun s-> - first_i 0 (fun i -> s^(string_of_int i)) - (fun v -> not (Strings.mem v names))) cands in - snd (List.hd (List.stable_sort (fun (a,_) (b,_) -> a-b) ncands)) - let not_conflicting_names s names n = - snd (List.fold_left (fun (i,res) _ -> + List.rev (snd (List.fold_left (fun (i,res) _ -> let i', v = first_i i (fun i -> s^(string_of_int i)) (fun v -> not (Strings.mem v names)) in - i', v::res) (0,[]) n) + i', v::res) (0,[]) n)) -let rec split_table columns rows = - let rec collect = function - | [], rest -> [], rest - | hd::tl, e::more -> - let cols, rest = collect (tl, more) in - (e::hd)::cols, rest - | cols, [] -> cols, [] in - let columns, rest = collect (columns, rows) in - if rest = [] then columns else split_table columns rest - (* Character classes. *) let is_uppercase c = c >= 'A' && c <= 'Z' let is_lowercase c = c >= 'a' && c <= 'z' Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Formula/Aux.mli 2010-11-21 20:45:43 UTC (rev 1187) @@ -15,109 +15,59 @@ (** Map a list filtering out some elements. *) val map_some : ('a -> 'b option) -> 'a list -> 'b list -val map_some2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list - (** Map elements into key-value pairs, and fold values with the same - key. *) + key. Uses {!List.fold_left}, therefore reverses the order. The + resulting keys are sorted in the {!Pervasives.compare} order. *) val map_reduce : ('a -> 'b * 'c) -> ('d -> 'c -> 'd) -> 'd -> 'a list -> ('b * 'd) list -(** Return a list of unique elements (using structural equality) for a - *sorted* input list. *) -val drop_repeating : 'a list -> 'a list - -(** Check if an element of a list repeats, using structural - equality. *) -val has_repeating : 'a list -> bool - (** Remove all elements equal to the argument, using structural inequality. *) val list_remove : 'a -> 'a list -> 'a list -(** Check if at least one element and its position satisfies the predicate. *) -val list_existsi : (int -> 'a -> bool) -> 'a list -> bool - -(** Return first key with the given value from the key-value pairs. *) +(** Return first key with the given value from the key-value pairs, + using structural equality. *) val rev_assoc : ('a * 'b) list -> 'b -> 'a -(** Inverse image of an association: return all keys with a given value. *) +(** Inverse image of an association: return all keys with a given + value (using structural equality). Returns elements in reverse order. *) val rev_assoc_all : ('a * 'b) list -> 'b -> 'a list -(** Replace the value of a first occurrence of a key. *) +(** Replace the value of a first occurrence of a key, or place it at + the end of the assoc list. *) val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list (** Find the value associated with the first occurrence of the key and remove them from the list. *) val pop_assoc : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list -(** Find the first maximal element. Comparison is by [cmp a b <= 0] - iff [a <= b]. *) -val find_max : ('a -> 'a -> int) -> 'a list -> 'a - -(** Find all maximal elements. *) -val find_all_max : ('a -> 'a -> int) -> 'a list -> 'a list - -(** Insert an element (without repeating it) into an - increasing-ordered list. *) -val insert_ordered : ('a -> 'a -> int) -> 'a -> 'a list -> 'a list - (** unConstructors. *) val unsome : 'a option -> 'a -(** Map a prefix of [Left] elements (returned in reverse order) till - the first [Right] element (if any), also return the unmapped tail - of the list. *) -val rev_map_choose : - ('a -> ('b, 'c) choice) -> 'a list -> 'c option * 'b list * 'a list - -(** Find the first result of [f] on [l] that does not raise [Not_found]. *) -val try_find : ('a -> 'b) -> 'a list -> 'b - (** Map [f] on the list collecting results whose computation does not raise [Not_found]. Therefore [map_try] call cannot raise [Not_found]. *) val map_try : ('a -> 'b) -> 'a list -> 'b list -(** Cartesian product of lists. *) +(** Cartesian product of lists. Not tail recursive. *) val product : 'a list list -> 'a list list -(** Generalized product. [product l = gproduct (fun x y->x::y) [] l]. *) -val gproduct : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list +(** An [n]th cartesian power of the second list, where [n] is the + length of the first list. Tail recursive. *) +val all_tuples_for : 'a list -> 'b list -> 'b list list -(** Return the nth dimensional "triangle matrix", as the set of [n] - element subsets of [l]. *) -val triang_product : int -> 'a list -> 'a list list - (** Remove an occurrence of a value (uses structural equality). *) val remove_one : 'a -> 'a list -> 'a list -(** Remove [n+1]th element of a list ([n]th counting from zero). *) -val remove_nth : int -> '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). *) +val insert_nth : int -> 'a -> 'a list -> 'a list -(** At once access an element as by {!List.nth}, and delete as by - {!remove_nth}. *) -val extract_nth : int -> 'a list -> 'a * 'a list - -(** Replace [n+1]th element of a list ([n]th counting from zero). *) -val replace_nth : int -> 'a -> 'a list -> 'a list - -(** Add as [n]th element of a list (counting from zero). *) -val add_nth : int -> 'a -> 'a list -> 'a list - (** Find the index of the first occurrence of a value in a list, counting from zero. *) val find_index : 'a -> 'a list -> int -(** Sample from a list with repetitions. *) -val sample : int -> 'a list -> 'a list - -(** Return the result of the first index [i] that passes the - given test, and [i+1]. *) -val first_i : int -> (int -> 'a) -> ('a -> bool) -> int * 'a - -(** Map the numbers [b..n]. *) -val map_for : int -> int -> (int -> 'a) -> 'a list - (** Return the list of maximal elements, under the given less-or-equal comparison (the input does not need to be sorted). (Currently, of equal elements only the last one is preserved.) *) @@ -126,41 +76,26 @@ (** Return the list of unique elements, under the given comparison (the input does not need to be sorted). (Currently uses a straightforward [n^2] algorithm, a sorting-based would reduce it to - [n log n].) *) + [n log n]. Currently not tail-recursive.) *) val unique : ('a -> 'a -> bool) -> 'a list -> 'a list (** Take [n] elements of the given list, or less it the list does not contain enough values. *) val take_n : int -> 'a list -> 'a list -(** Take [n] nonrepeating elements of the given list, or less it the - list does not contain enough values. *) -val take_n_unique : int -> 'a list -> 'a list - -(** Concatenate lists without repeating the elements. *) -val concat_unique : 'a list list -> 'a list - -(** All lists from [l] that are not initial parts of other lists from [l]. *) -val prefix_free : 'a list list -> 'a list list - (** Make an array from an association from indices to values. The indices must cover the [0..length-1] range; raises - [Invalid_argument] otherwise. *) + [Invalid_argument "Aux.array_from_assoc"] otherwise. *) val array_from_assoc : (int * 'a) list -> 'a array (** Map a function over two arrays index-wise. Raises [Invalid_argument] if the arrays are of different lengths. *) val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array -val array_mapi2 : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array -(** Map a function over an array threading an accumulator. *) -val array_fold_map : - ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array - -(** Zip two arrays into an array of pairs. *) +(** Zip two arrays into an array of pairs. Raises [Invalid_argument + "Aux.array_map2"] if the arrays are of different lengths. *) val array_combine : 'a array -> 'b array -> ('a * 'b) array -val array_exists : ('a -> bool) -> 'a array -> bool val array_existsi : (int -> 'a -> bool) -> 'a array -> bool val array_mem : 'a -> 'a array -> bool @@ -168,20 +103,6 @@ (** Same as [Array.of_list (List.map f l)] *) val array_map_of_list : ('a -> 'b) -> 'a list -> 'b array -(** Same as [Array.of_list (List.concat (List.map (fun x-> List.map (g - x) (f x)) l))]. The first function generates the results and the - second postprocesses them. *) -val array_concat_map_of_list - : ('a -> 'b list) -> ('a -> 'b -> 'c) -> 'a list -> 'c array - -(** Like {!Array.fold_left}, but only for the initial elements for - which the predicate holds. *) -val array_fold_while : - ('a -> bool) -> ('b -> 'a -> 'b) -> 'b -> 'a array -> 'b - -(** Find the first element that satisfies a predicate. Raises [Not_found]. *) -val array_find : ('a -> bool) -> 'a array -> 'a - val array_argfind : ('a -> bool) -> 'a array -> int (** Find all elements for which [f] holds. *) @@ -192,12 +113,11 @@ (** Find if a predicate holds for all elements. *) val array_for_all : ('a -> bool) -> 'a array -> bool -(** Find if a predicate holds for all elements of two arrays pointwise. *) +(** Find if a predicate holds for all elements of two arrays + pointwise. Raises [Invalid_argument "Aux.array_for_all2"] if + arrays are of different lengths. *) val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool -(** Find the index of the first maximal element in an array. *) -val array_argfind_max : ('a -> 'a -> int) -> 'a array -> int - (** Find indices of all maximal elements in an array. *) val array_argfind_all_max : ('a -> 'a -> int) -> 'a array -> int list @@ -212,42 +132,23 @@ also {!partition_choice}). *) val partition_map : ('a -> ('b, 'c) choice) -> 'a list -> 'b list * 'c list -(** Transpose a list of triples into a triple of lists. *) -val split_triples : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list - -(** Transpose a rectangular matrix represented by lists. *) +(** Transpose a rectangular matrix represented by lists. Raises + [Invalid_argument "List.map2"] when matrix is not rectangular. *) val transpose_lists : 'a list list -> 'a list list -(** An [n]th cartesian power of the second list, where [n] is the - length of the first list. *) -val all_tuples_for : 'a list -> 'b list -> 'b list list - (** Iterate a function [n] times: [f^n(x)]. *) val fold_n : ('a -> 'a) -> 'a -> int -> 'a -(** Fold a function over the [1..n] sequence: [f(n,f(...f(1,x)...))]. *) -val foldi_n : (int -> 'a -> 'a) -> 'a -> int -> 'a - -(** An [n]th cartesian power of a list. *) -val all_tuples_n : int -> 'a list -> 'a list list - (** Generate a fresh filename of the form [base ^ n ^ suffix]. *) val new_filename : string -> string -> string (** Returns a string proloning [s] and not appearing in [names]. *) val not_conflicting_name : Strings.t -> string -> string -(** Returns a string proloning one of [cands] and not appearing in - [names]. *) -val not_conflicting_name_cands : Strings.t -> string list -> string - (** Returns [n] strings proloning [s] and not appearing in [names]. *) val not_conflicting_names : string -> Strings.t -> 'a list -> string list -(** Collect columns of a table given by concatenation of rows. *) -val split_table : 'a list list -> 'a list -> 'a list list - (** Character classes. *) val is_uppercase : char -> bool val is_lowercase : char -> bool Modified: trunk/Toss/Formula/BoolFormula.ml =================================================================== --- trunk/Toss/Formula/BoolFormula.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Formula/BoolFormula.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -261,9 +261,6 @@ 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 unique = function (* remove duplicate subformulas *) - [] -> [] - | x :: xs -> [x] @ (unique (List.filter (fun y -> y<>x) xs)) in 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! *) @@ -272,10 +269,10 @@ match phi with BVar _ -> phi | BNot psi -> BNot (singularise psi) - | BOr psis -> let unique_psis = 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 = unique psis in + | 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 = Modified: trunk/Toss/Formula/FFTNF.ml =================================================================== --- trunk/Toss/Formula/FFTNF.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Formula/FFTNF.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -1073,6 +1073,18 @@ (* build will flatten the formula *) evs, build false phi +(* Map a prefix of [Left] elements (returned in reverse order) till + the first [Right] element (if any), also return the unmapped tail + of the list. *) +let rev_map_choose f l = + let rec rmap_f accu = function + | [] -> None, accu, [] + | a::tl -> + match f a with + | Left r -> rmap_f (r :: accu) tl + | Right r -> Some r, accu, tl in + rmap_f [] l + (* Step 4. Search depth-first since it's simpler, perhaps results in less duplication, and there are no clear advantages of breadth-first. *) let find_active frels evs t = Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Play/Game.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -477,6 +477,19 @@ 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 + | [] -> 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 @@ -503,14 +516,14 @@ then fun (_,x) (_,y) -> compare x y else fun (_,x) (_,y) -> compare y x in let bestsc = - Aux.find_all_max cmp_sums sc_sums in + find_all_max cmp_sums sc_sums in match bestsc with | [] -> failwith "impossible" | [bestsc,_] -> scores.(bestsc), bestsc | _ -> (* pick ones from biggest subtrees *) let bestsc = - Aux.find_all_max + find_all_max (fun (b1,_) (b2,_) -> subt_sizes.(b1) - subt_sizes.(b2)) bestsc in match bestsc with Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Play/Heuristic.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -307,6 +307,10 @@ List.map (fun v -> List.map (List.assoc v) substs) vars in (* TODO: optimizable *) + let rec has_repeating = function + | [] -> false + | hd::tl when List.mem hd tl -> true + | hd::tl -> has_repeating tl in if has_repeating vs_insts then [], true, [] @@ -317,6 +321,16 @@ exception Outside_subst of (fo_var * int) list +let find_max cmp l = + let rec find acc = function + | hd::tl -> + if cmp hd acc <= 0 then find acc tl + else find hd tl + | [] -> acc in + match l with + | [] -> invalid_arg "find_max: empty list" + | hd::tl -> find hd tl + let expanded_descr max_alt_descr elems rels struc all_vars xvars xsubsts = let alt_descr = ref 0 in @@ -633,6 +647,12 @@ (* ********** Heuristic of Payoff Expression ********** *) +(* Generalized product. [product l = gproduct (fun x y->x::y) [] l]. *) +let gproduct f r0 l = + List.fold_right (fun set prod -> + concat_map (fun el -> List.map (fun tup -> f el tup) prod) set) + l [r0] + let rec limited_dnf neg = function | (Rel _ | Eq _ @@ -640,7 +660,7 @@ | RealExpr _) as psi -> [[if neg then Not psi else psi]] | Not psi -> limited_dnf (not neg) psi | And conjs -> - Aux.gproduct List.append [] (List.map (limited_dnf neg) conjs) + gproduct List.append [] (List.map (limited_dnf neg) conjs) | Or disjs -> Aux.concat_map (limited_dnf neg) disjs | Ex (vs, psi) as phi -> [[if neg then All (vs, Not psi) else phi]] Modified: trunk/Toss/Solver/AssignmentSet.ml =================================================================== --- trunk/Toss/Solver/AssignmentSet.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Solver/AssignmentSet.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -93,7 +93,8 @@ (Aux.product (List.rev_map (fun _ -> Structure.Elems.elements elems) vars)) | FO (`FO v, asg_list) -> let (idx, vs) = (Aux.find_index v vars, Aux.remove_one v vars) in - let prolong e asg = Array.of_list (Aux.add_nth idx e (Array.to_list asg)) in + let prolong e asg = + Array.of_list (Aux.insert_nth idx e (Array.to_list asg)) in List.concat (List.rev_map (fun (e, asg) -> List.rev_map (prolong e) (tuples elems vs asg)) asg_list) | _ -> failwith "listing tuples in non first-order assignment set" Modified: trunk/Toss/Solver/Assignments.ml =================================================================== --- trunk/Toss/Solver/Assignments.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Solver/Assignments.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -292,24 +292,10 @@ (* ---------------------- UNIVERSAL PROJECTION ------------------------------ *) -let concat_map f l = - let rec cmap_f accu = function - | [] -> accu - | a::l -> cmap_f (List.rev_append (f a) accu) l - in - List.rev (cmap_f [] l) - -let product l = - if List.mem [] l then [] - else - List.fold_right (fun set prod -> - concat_map (fun el -> List.map (fun tup -> el::tup) prod) set) - l [[]] - let negate_real_disj poly_disj = let neg_sign (p, s) = (p, SignTable.neg_sign_op s) in let ndisj = List.rev_map (fun l -> List.rev_map neg_sign l) poly_disj in - List.filter RealQuantElim.sat (product ndisj) + List.filter RealQuantElim.sat (Aux.product ndisj) (* Project assignments on a given universal variable. We assume that [elems] are all elements and are sorted. Corresponds to the for-all v quantifier. *) Modified: trunk/Toss/Solver/FFSolver.ml =================================================================== --- trunk/Toss/Solver/FFSolver.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Solver/FFSolver.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -156,6 +156,12 @@ let debug_count = ref 0 +let list_existsi p l = + let rec aux i = function + | [] -> false + | a::l -> p i a || aux (i+1) l in + aux 0 l + (* We assume that for every "not ex psi" subformula, "ex psi" is ground, and that every other occurrence of negation is in a literal (it is guaranteed by @@ -289,7 +295,7 @@ if List.mem_assoc x sb then 1, y else 0, x in let oldvars = List.filter (fun v->List.mem_assoc v sb) vtup in - let multi_unkn = Aux.list_existsi + let multi_unkn = list_existsi (fun i v->i>nvi && not (List.mem v oldvars)) vtup in if multi_unkn && (conj_cont <> [] || delayed1 <> []) then (* delay *) @@ -401,7 +407,7 @@ if List.mem_assoc x sb then 1, y else 0, x in let oldvars = List.filter (fun v->List.mem_assoc v sb) vtup in - let multi_unkn = Aux.list_existsi + let multi_unkn = list_existsi (fun i v->i>nvi && not (List.mem v oldvars)) vtup in if multi_unkn && (conj_cont <> [] || delayed1 <> []) then (* delay *) Modified: trunk/Toss/Solver/Structure.ml =================================================================== --- trunk/Toss/Solver/Structure.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/Solver/Structure.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -254,6 +254,21 @@ (* ------------ GLOBAL FUNCTIONS TO CREATE STRUCTURES FROM LISTS ------------ *) +(** Map a function over an array threading an accumulator. *) +let array_fold_map f acc a = + let l = Array.length a in + if l = 0 then acc, [||] else begin + let acc, e = f acc (Array.unsafe_get a 0) in + let prev = ref acc in + let r = Array.create l e in + for i = 1 to l - 1 do + let acc, e = f !prev (Array.unsafe_get a i) in + prev := acc; + Array.unsafe_set r i e + done; + !prev, r + end + (* Add to a named structure elements, relations and functions from the lists. *) let add_from_lists struc els rels funs = List.fold_left (fun s (fn, assgns) -> @@ -271,7 +286,7 @@ | Some ar -> ar in let s = add_rel_name rn arity s in List.fold_left (fun s tp -> - let s, tp = Aux.array_fold_map find_or_new_elem s tp in + let s, tp = array_fold_map find_or_new_elem s tp in add_rel s rn tp) s tps) (List.fold_left (fun s ne -> fst (find_or_new_elem s ne)) struc els) rels) funs @@ -335,31 +350,12 @@ { del_rels_struc with elements = Elems.remove e del_rels_struc.elements ; functions = StringMap.map del_fun del_rels_struc.functions ; } -(* Copied from Server/Aux.ml *) -let map_reduce mapf redf red0 l = - match List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) - (List.map mapf l) with - | [] -> [] - | (k0, v0)::tl -> - let k0, vs, l = List.fold_left (fun (k0, vs, l) (kn, vn) -> - if k0 = kn then k0, vn::vs, l else kn, [vn], (k0,vs)::l) - (k0, [v0], []) tl in - List.rev (List.map (fun (k,vs) -> k, List.fold_left redf red0 vs) - ((k0,vs)::l)) - -let concat_map f l = - let rec cmap_f accu = function - | [] -> accu - | a::l -> cmap_f (List.rev_append (f a) accu) l - in - List.rev (cmap_f [] l) - (* Remove the elements [es] and all incident relation tuples from [struc]; return the deleted relation tuples. *) let del_elems struc es = let rel_tuples = - map_reduce (fun x->x) List.rev_append [] - (concat_map (incident struc) es) in + Aux.map_reduce (fun x->x) List.rev_append [] + (Aux.concat_map (incident struc) es) in let del_rels_struc = List.fold_left (fun s (rn, tps) -> del_rels s rn tps) struc rel_tuples in let del_fun fmap = Modified: trunk/Toss/TossTest.ml =================================================================== --- trunk/Toss/TossTest.ml 2010-11-21 17:16:38 UTC (rev 1186) +++ trunk/Toss/TossTest.ml 2010-11-21 20:45:43 UTC (rev 1187) @@ -1,6 +1,7 @@ open OUnit let formula_tests = "Formula" >::: [ + AuxTest.tests; FormulaTest.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...> - 2010-11-21 21:34:09
|
Revision: 1188 http://toss.svn.sourceforge.net/toss/?rev=1188&view=rev Author: lukaszkaiser Date: 2010-11-21 21:34:02 +0000 (Sun, 21 Nov 2010) Log Message: ----------- Solver corrections and tests moved to OUnit. Modified Paths: -------------- trunk/Toss/Client/SystemDisplay.py trunk/Toss/Solver/AssignmentSet.ml trunk/Toss/Solver/AssignmentSet.mli trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/Solver.mli trunk/Toss/Solver/SolverTest.ml trunk/Toss/TossTest.ml Modified: trunk/Toss/Client/SystemDisplay.py =================================================================== --- trunk/Toss/Client/SystemDisplay.py 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/Client/SystemDisplay.py 2010-11-21 21:34:02 UTC (rev 1188) @@ -43,7 +43,7 @@ suggest_bt = self.toolbar.addAction (QIcon(":/pics/move.svg"),"Hint") QObject.connect(suggest_bt, SIGNAL("triggered ()"), self.suggest) - self.__sg_iters = 4 + self.__sg_iters = 2 self.sg_iters_bt = self.toolbar.addAction ("Depth: " + str(self.__sg_iters)) QObject.connect(self.sg_iters_bt, SIGNAL("triggered ()"), Modified: trunk/Toss/Solver/AssignmentSet.ml =================================================================== --- trunk/Toss/Solver/AssignmentSet.ml 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/Solver/AssignmentSet.ml 2010-11-21 21:34:02 UTC (rev 1188) @@ -85,14 +85,17 @@ (* List all tuples the first-order assignment [asg] assigns to [vars] - in order in which [vars] are given. Raise Not_found if the assignment - is empty. Use [elems] as the set of all elements of the structure. *) + in order in which [vars] are given. [elems] are are all elements. *) let rec tuples elems vars = function - | Empty -> raise Not_found + | Empty -> [] | Any -> List.rev_map Array.of_list (Aux.product (List.rev_map (fun _ -> Structure.Elems.elements elems) vars)) | FO (`FO v, asg_list) -> - let (idx, vs) = (Aux.find_index v vars, Aux.remove_one v vars) in + let (idx, vs) = + try + (Aux.find_index v vars, Aux.remove_one v vars) + with Not_found -> + failwith ("assigned var "^ v ^ " not in "^ (String.concat "," vars)) in let prolong e asg = Array.of_list (Aux.insert_nth idx e (Array.to_list asg)) in List.concat (List.rev_map (fun (e, asg) -> Modified: trunk/Toss/Solver/AssignmentSet.mli =================================================================== --- trunk/Toss/Solver/AssignmentSet.mli 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/Solver/AssignmentSet.mli 2010-11-21 21:34:02 UTC (rev 1188) @@ -33,6 +33,5 @@ (string * int) list -> assignment_set -> (string * int) list (* List all tuples the first-order assignment [asg] assigns to [vars] - in order in which [vars] are given. Raise Not_found if the assignment - is empty. Use [elems] as the set of all elements of the structure. *) + in order in which [vars] are given. [elems] are are all elements. *) val tuples : Structure.Elems.t -> string list -> assignment_set -> int array list Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/Solver/Solver.ml 2010-11-21 21:34:02 UTC (rev 1188) @@ -207,15 +207,10 @@ eval_m struc (RealExpr (Plus (expr, Times (Const (-1.), RVar rvar)), Formula.EQZero)) -let rec remove_dup acc = function - | [] -> acc - | [x] -> x :: acc - | x :: y :: xs when x = y -> remove_dup acc (y :: xs) - | x :: y :: xs -> remove_dup (x :: acc) (y :: xs) (* Fast function to get a value of a real expression without free variables other than those assigned in [asg] explicitely. *) -let rec get_real_val_a solver asg expr struc = +let rec get_real_val solver asg expr struc = let rec check_f = function Ex (vs, phi) -> check_f phi | Or (fl) -> List.exists check_f fl @@ -224,10 +219,10 @@ Char phi -> if check_f phi then 1. else 0. | Const v -> v | Times (e1, e2) -> - (get_real_val_a solver asg e1 struc) *. (get_real_val_a solver asg e2 struc) + (get_real_val solver asg e1 struc) *. (get_real_val solver asg e2 struc) | Plus (e1, e2) -> - (get_real_val_a solver asg e1 struc) +. (get_real_val_a solver asg e2 struc) - | Sum (vl, guard, r) -> (* TODO; FIXME; is asg ok down here? *) + (get_real_val solver asg e1 struc) +. (get_real_val solver asg e2 struc) + | Sum (vl, guard, r) -> let gd = ( try let gd_id = List.assoc guard !(solver.reg_formulas) in @@ -235,13 +230,19 @@ with Not_found -> Hashtbl.find solver.formulas_eval (register_formula solver guard) ) in - if !debug_level > 0 then print_endline ("guard " ^ (Formula.str guard)); - let asg = eval_m struc gd in - let tps = tuples struc.elements (List.map var_str vl) asg in - let stps = remove_dup [] (List.sort Pervasives.compare tps) in - let add_val acc tp = - acc+.(get_real_val_a solver (join asg (asg_of_tuple struc vl tp)) r struc) in - List.fold_left add_val 0. stps + let all_vs = (List.map to_fo (AssignmentSet.assigned_vars [] asg)) @ vl in + if !debug_level > 0 then ( + print_endline ("guard " ^ (Formula.str guard)); + print_endline ("asg " ^ (AssignmentSet.str asg)); + print_endline ("sum vars " ^ (Formula.var_list_str vl)); + print_endline ("all vars " ^ (Formula.var_list_str all_vs)); + ); + let asg_gd = join asg (eval_m struc gd) in + let tps = tuples struc.elements (List.map var_str all_vs) asg_gd in + let add_val acc tp = + let tp_asg = asg_of_tuple struc all_vs tp in + acc +. (get_real_val solver tp_asg r struc) in + List.fold_left add_val 0. tps | _ -> let rec get_rval = function | FO (_, [(_, a)]) -> get_rval a @@ -258,8 +259,6 @@ AssignmentSet.str ev_assgn) in get_rval (join asg (evaluate_real "#" expr struc)) -let get_real_val expr struc = - get_real_val_a (new_solver ()) Any expr struc (* Evaluate i-th formula on j-th structure. *) let evaluate solver ~formula struc = @@ -288,7 +287,7 @@ let evaluate struc formula = evaluate solver ~formula struc let check_formula struc formula = check solver ~formula struc - let get_real_val = get_real_val_a solver Any + let get_real_val = get_real_val solver Any let formula_str phi = let phi = Hashtbl.find solver.formulas_check phi in Formula.str phi Modified: trunk/Toss/Solver/Solver.mli =================================================================== --- trunk/Toss/Solver/Solver.mli 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/Solver/Solver.mli 2010-11-21 21:34:02 UTC (rev 1188) @@ -23,7 +23,8 @@ Assignments.assignment_set (* Fast function to get a value of a real expression without free variables. *) -val get_real_val : Formula.real_expr -> Structure.structure -> float +val get_real_val : solver -> Assignments.assignment_set -> + Formula.real_expr -> Structure.structure -> float (* ------------------------- DEBUGGING ------------------------------------- *) Modified: trunk/Toss/Solver/SolverTest.ml =================================================================== --- trunk/Toss/Solver/SolverTest.ml 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/Solver/SolverTest.ml 2010-11-21 21:34:02 UTC (rev 1188) @@ -1,4 +1,5 @@ open Solver ;; +open OUnit ;; Solver.set_debug_level 0 ;; Sat.set_debug_level 0;; @@ -13,129 +14,144 @@ FormulaParser.parse_real_expr Lexer.lex (Lexing.from_string s) ;; -let nstruc_of_string s = +let struc_of_string s = StructureParser.parse_structure Lexer.lex (Lexing.from_string s) ;; -let struc_of_string s = let struc = nstruc_of_string s in struc ;; -let test_eval struc_s phi_s = +let eval_eq struc_s phi_s aset_s = let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in let solver = new_solver () in let f = register_formula solver phi in - print_string "Evaluating\n "; - print_endline (Formula.str phi); - print_string "on\n "; - print_endline (Structure.str struc); - print_string "returns:\n "; - print_endline (AssignmentSet.str (evaluate solver f struc)); - print_endline "" + assert_equal ~printer:(fun x -> x) + (AssignmentSet.str (evaluate solver f struc)) aset_s ;; -let test_eval_real struc_s expr_s = +let eval_real_eq var_s struc_s expr_s aset_s = let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in - print_string "Evaluating real expr as r_var\n "; - print_endline (Formula.real_str expr); - print_string "on\n "; - print_endline (Structure.str struc); - print_string "returns:\n "; - print_endline (AssignmentSet.str (evaluate_real "r_var" expr struc)); - print_endline "" + assert_equal ~printer:(fun x -> x) + (AssignmentSet.str (evaluate_real var_s expr struc)) aset_s ;; -let test_real_val struc_s expr_s = +let real_val_eq struc_s expr_s x = let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in - print_string ("Real value of " ^ (Formula.real_str expr) ^ " on\n "); - print_string ((Structure.str struc) ^ "\nis: "); - print_endline ((string_of_float (get_real_val expr struc)) ^ "\n"); + assert_equal ~printer:(fun x -> string_of_float x) + (get_real_val (new_solver ()) AssignmentSet.Any expr struc) x ;; -test_eval "[ | R { (a, b); (a, c) } | ]" "ex x R (x, y)" ;; -test_eval "[ | R { (a, b); (a, c) } | ]" "x = y" ;; +let tests = "Solver" >::: [ + "eval: first-order quantifier free" >:: + (fun () -> + eval_eq "[ | R { (a, b); (a, c) } | ]" "x = y" + "{ y->1{ x->1 } , y->2{ x->2 } , y->3{ x->3 } }"; + eval_eq "[ | R { (a, b); (b, c) }; P { b } | ]" "P(x) and x = y" + "{ y->2{ x->2 } }"; + eval_eq "[ | R { (a, b); (a, c) } | ]" "R(x, y) and x = y" + "{}"; + eval_eq "[ | R { (a, a); (a, b) } | ]" "R(x, y) and x = y" + "{ y->1{ x->1 } }"; + eval_eq "[ | R { (a, b); (a, c) } | ]" "not x = y" + "{ y->1{ x->2, x->3 } , y->2{ x->1, x->3 } , y->3{ x->1, x->2 } }"; + eval_eq "[ | R { (a, a); (a, c) } | ]" "R (x, y) and not x = y" + "{ y->2{ x->1 } }"; + ); -test_eval "[ | R { (a, b); (b, c) }; P { b } | ]" "P(x) and x = y" ;; + "eval: first-order with quantifiers" >:: + (fun () -> + eval_eq "[ | R { (a, b); (a, c) } | ]" "ex x R (x, y)" + "{ y->2, y->3 }"; + eval_eq "[ | R { (a, b); (b, c) }; P { b } | ]" + "ex x ( P(x) and not (ex y R(x, y)) )" + "{}"; + ); -test_eval "[ | R { (a, b); (a, c) } | ]" "R(x, y) and x = y" ;; + "eval: mso quantifier free basic" >:: + (fun () -> + eval_eq "[ | P { a } | ]" "x in X" + "{ x->1{ X->(inc {1} excl {}) } }"; + eval_eq "[ | P { a } | ]" "not (x in X)" + "{ x->1{ X->(inc {} excl {1}) } }"; + eval_eq "[ | P { a } | ]" "x in X and x in Y" + "{ x->1{ Y->(inc {1} excl {}){ X->(inc {1} excl {}) } } }"; + eval_eq "[ | P { a } | ]" "x in X and not (x in Y)" + "{ x->1{ Y->(inc {} excl {1}){ X->(inc {1} excl {}) } } }"; + eval_eq "[ | P { a } | ]" "x in X and x = y and not (x in X)" + "{}"; + eval_eq "[ | P { a } | ]" "x in X and x in Y and (x = y and not (x in Y))" + "{}"; + eval_eq "[ | P { a } | ]" "x in X and (x in X or x in Y)" + "{ x->1{ X->(inc {1} excl {}) } }"; + ); -test_eval "[ | R { (a, a); (a, b) } | ]" "R(x, y) and x = y" ;; + "eval: mso quantifier free" >:: + (fun () -> + eval_eq "[ | P { a } | ]" "(t in X2) and ((t in X) or ((t in C)))" + ("{ t->1{ X2->(inc {1} excl {}){ X->(inc {} excl {}){ C->(inc {1}" ^ + " excl {}) }, X->(inc {1} excl {}) } } }"); + eval_eq "[ | P { a } | ]" "(t in X2) and ((t in X) or ((t in C) or (t in X)))" + ("{ t->1{ X2->(inc {1} excl {}){ X->(inc {} excl {}){ C->(inc {1}" ^ + " excl {}) }, X->(inc {1} excl {}) } } }"); + eval_eq "[ | P { a } | ]" + "(((t in X2) and ((t in X) or (((t in C) or (t in X)) and ((not t in C) + or (not (t in X))))) and ((not (t in X)) or ((t in C) and (t in X)) or + ((not (t in C)) and (not (t in X))))))" + "{ t->1{ X2->(inc {1} excl {}){ C->(inc {1} excl {}) } } }"; + ); -test_eval "[ | R { (a, b); (b, c) }; P { b } | ]" - "ex x ( P(x) and not (ex y R(x, y)) )" ;; + "eval: mso with only first-order quantifiers" >:: + (fun () -> + eval_eq "[ | P { a } | ]" + "(not t in X2) or ((t in X2) and (t in X3)) and + all s (s in X3 or not P(s))" + ("{ t->1{ X3->(inc {} excl {}){ X2->(inc {} excl {1}) }," ^ + " X3->(inc {1} excl {}) } }"); + ); -test_eval "[ | R { (a, b); (a, c) } | ]" "not x = y" ;; + "eval: mso with quantifiers" >:: + (fun () -> + let reach_f = + "all X (x in X and (all z,v (z in X and R(z,v)-> v in X))-> y in X)" in + eval_eq "[ | R { (a, b); (a, c) } | ]" reach_f + "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3{ x->1, x->3 } }"; + eval_eq "[ | R { (a, b); (b, c) } | ]" reach_f + "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }"; + eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]" + ("x != y and not R(x, y) and " ^ reach_f) + ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^ + " y->6{ x->1, x->2, x->3, x->4 } , y->7{ x->1, x->2, x->3, x->4," ^ + " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }"); + ); -test_eval "[ | R { (a, a); (a, c) } | ]" "R (x, y) and not x = y" ;; + "eval: with real values" >:: + (fun () -> + eval_eq "[ | P { x } | ] " "ex :x ((:x^2 + 3*:x + 2 < 0) and (:x < 0))" + "T"; + eval_eq "[ | P { x } | f { x -> 1, y -> 2, z -> 3 } ]" ":f(x) > 2" + "{ x->3 }"; + eval_eq "[ | P { x } | f { x -> 1, y -> 2, z -> 3 } ]" + "ex :x (:x^2 + :x * :f(x) + 2 < 0)" + "{ x->3 }"; + eval_eq "[ | R { (a, a); (a, b) } | ] " ":(all y (R (x, y))) > 0" + "{ x->1 }"; + ); -test_eval "[ | P { a } | ]" "x in X" ;; - -test_eval "[ | P { a } | ]" "not (x in X)" ;; - -test_eval "[ | P { a } | ]" "x in X and x in Y" ;; - -test_eval "[ | P { a } | ]" "x in X and not (x in Y)" ;; - -test_eval "[ | P { a } | ]" "x in X and x = y and not (x in X)" ;; - -test_eval "[ | P { a } | ]" "x in X and x in Y and (x = y and not (x in Y))" ;; - -test_eval "[ | P { a } | ]" "x in X and (x in X or x in Y)" ;; - -test_eval "[ | P { a } | ]" "(t in X2) and ((t in X) or ((t in C)))" ;; - -test_eval "[ | P { a } | ]" "(t in X2) and ((t in X) or ((t in C) or (t in X)))" ;; - -test_eval "[ | P { a } | ]" - ("(((t in X2) and ((t in X) or (((t in C) or (t in X)) and ((not (t in C)) or" ^ - " (not (t in X))))) and ((not (t in X)) or ((t in C) and (t in X)) or ((not (t in C)) and (not (t in X))))))") ;; - -test_eval "[ | P { a } | ]" "(not t in X2) or ((t in X2) and (t in X3)) and all s (s in X3 or not P(s))" ;; - -let reach_f = - "all X (x in X and ( all z,v (z in X and R (z, v) -> v in X )) -> y in X)" ;; - -test_eval "[ | R { (a, b); (a, c) } | ]" reach_f ;; - -test_eval "[ | R { (a, b); (b, c) } | ]" reach_f ;; - -test_eval "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]" - ("x != y and not R(x, y) and " ^ reach_f) ;; - -test_eval "[ | P { x } | ] " "ex :x ((:x^2 + 3*:x + 2 < 0) and (:x < 0))" ;; - -test_eval "[ | P { x } | f { x -> 1, y -> 2, z -> 3 } ]" ":f(x) > 2" ;; - -test_eval "[ | P { x } | f { x -> 1, y -> 2, z -> 3 } ]" - "ex :x (:x^2 + :x * :f(x) + 2 < 0)" ;; - -test_eval "[ | R { (a, a); (a, b) } | ] " ":(all y (R (x, y))) > 0" ;; - -test_eval_real "[ | R { (a, a); (a, b) } | ] " ":(all y (R (x, y)))" ;; - -test_real_val "[ | R { (a, a); (a, b) } | ] " ":(ex x (R (x, x))) + 1" ;; - -test_real_val "[ | P { x } | f { x->1, y->2, z->3 } ]" "Sum (x | true : :f(x)^2)" ;; - -test_real_val "[ | R { (a, a); (a, b) } | ] " "Sum (x | true : :(all y (R (x, y))))";; - -test_real_val "[ | R { (a, a); (a, b) } | ] " "Sum (x | all y (R (x, y)) : 1)";; - -test_real_val "[ | P { x } | f { x->1, y->2, z->3 } ]" - "Sum (x, y | P(x) : :f(x) * :f(y))" ;; - -test_real_val "[ | P { x } | f { x->1, y->2, z->3 } ]" - "Sum (x, y | true : :f(x) * :f(y))" ;; - -test_real_val "[ | R { (a, a); (a, b) } | ] " "Sum (x, y | R (x, y) : 1)";; - - -(* Heuristic guard evaluation test. *) - -let heur_phi = "(((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 ((C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r))) or ex r, s, t, u ((R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w)))) and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(v)) and (not P(w)) and (not P(x)) and (not P(y)) and (not P(z))" ^ - "and (not ex v, w, x, y, z ((((C(y, z) and C(x, y) and C(w, x) and C(v, w)) or (R(y, z) and R(x, y) and R(w, x) and R(v, w)) or ex r, s, t, u ((R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w))) or ex r, s, t, u ((C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)))) and P(z) and P(y) and P(x) and P(w) and P(v)))))" ;; - -(* Formula.print (FormulaOps.tnf_fv (formula_of_string heur_phi)) ;; *) - -test_eval "[ | | ] \" + "eval: game heuristic tests" >:: + (fun () -> + let heur_phi = "(((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 + ((C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) + and C(w, r) and R(v, r))) or ex r, s, t, u ((R(y, u) and R(x, t) and + R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w)))) + and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(v)) and (not P(w)) + and (not P(x)) and (not P(y)) and (not P(z))" ^ + "and (not ex v, w, x, y, z ((((C(y, z) and C(x, y) and C(w, x) and + C(v, w)) or (R(y, z) and R(x, y) and R(w, x) and R(v, w)) or + ex r, s, t, u ((R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) + and C(t, y) and C(s, x) and C(r, w))) or ex r, s, t, u ((C(z, u) and + R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and + R(v, r)))) and P(z) and P(y) and P(x) and P(w) and P(v)))))" in + let _ () = Formula.print (FormulaOps.tnf_fv (formula_of_string heur_phi)) in + eval_eq "[ | | ] \" ... ... ... ... P ... ... ... ... ... ... ... ... @@ -152,10 +168,64 @@ ...P ... P.. ... ... ... ... ... ... ... ...Q ... -\"" heur_phi ;; +\"" heur_phi + ("{ z->5{ y->12{ x->19{ w->26{ v->33 } } } } ," ^ + " z->6{ y->5{ x->4{ w->3{ v->2 } } } } ," ^ + " z->7{ y->6{ x->5{ w->4{ v->3 } } } } ," ^ + " z->8{ y->7{ x->6{ w->5{ v->4 } } } } ," ^ + " z->32{ y->39{ x->46{ w->53{ v->60 } } } } ," ^ + " z->48{ y->47{ x->46{ w->45{ v->44 } } } } ," ^ + " z->53{ y->44{ x->35{ w->26{ v->17 } } } } ," ^ + " z->58{ y->50{ x->42{ w->34{ v->26 } } } } ," ^ + " z->62{ y->53{ x->44{ w->35{ v->26 } } } } ," ^ + " z->63{ y->54{ x->45{ w->36{ v->27 } } } } }"); + ); + "eval real: basic" >:: + (fun () -> + eval_real_eq "r" "[ | R { (a, a); (a, b) } | ] " ":(all y (R (x, y)))" + "{ x->1{ ((1.) + ((-1.)*r) = 0) } , x->2{ ((0.) + ((-1.)*r) = 0) } }"; + ); + "get real val" >:: + (fun () -> + real_val_eq "[ | R { (a, a); (a, b) } | ] " + ":(ex x (R (x, x))) + 1" 2.; + real_val_eq "[ | P { x } | f { x->1, y->2, z->3 } ]" + "Sum (x | true : :f(x)^2)" 14.; + real_val_eq "[ | R { (a, a); (a, b) } | ] " + "Sum (x | true : :(all y (R (x, y))))" 1.; + real_val_eq "[ | R { (a, a); (a, b) } | ] " + "Sum (x | all y (R (x, y)) : 1)" 1.; + real_val_eq "[ | P { x } | f { x->1, y->2, z->3 } ]" + "Sum (x, y | P(x) : :f(x) * :f(y))" 6.; + real_val_eq "[ | P { x } | f { x->1, y->2, z->3 } ]" + "Sum (x, y | true : :f(x) * :f(y))" 36.; + real_val_eq "[ | R { (a, a); (a, b) } | ] " + "Sum (x, y | R (x, y) : 1)" 2.; + ); +] ;; + +let a = + let file_from_path p = + String.sub p (String.rindex p '/'+1) + (String.length p - String.rindex p '/' - 1) in + let test_fname name = + let fname = file_from_path Sys.executable_name in + String.length fname >= String.length name && + String.sub fname 0 (String.length name) = name in + (* So that the tests are not run twice while building TossTest. *) + if test_fname "SolverTest" then + match test_filter [""] tests with + | Some tests -> ignore (run_test_tt ~verbose:true tests) + | None -> () +;; + + + + + (* ----------------------- FOUR POINTS PROBLEM --------------------------- *) (* Modified: trunk/Toss/TossTest.ml =================================================================== --- trunk/Toss/TossTest.ml 2010-11-21 20:45:43 UTC (rev 1187) +++ trunk/Toss/TossTest.ml 2010-11-21 21:34:02 UTC (rev 1188) @@ -1,7 +1,7 @@ open OUnit let formula_tests = "Formula" >::: [ - AuxTest.tests; + (* AuxTest.tests; *) FormulaTest.tests; FormulaOpsTest.tests; FFTNFTest.tests; @@ -10,6 +10,7 @@ let solver_tests = "Solver" >::: [ StructureTest.tests; FFSolverTest.tests; + SolverTest.tests; ] let arena_tests = "Arena" >::: [ This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-22 02:05:32
|
Revision: 1190 http://toss.svn.sourceforge.net/toss/?rev=1190&view=rev Author: lukaszkaiser Date: 2010-11-22 02:05:26 +0000 (Mon, 22 Nov 2010) Log Message: ----------- Solver optimization and small corrections. Modified Paths: -------------- trunk/Toss/Formula/Makefile trunk/Toss/Makefile trunk/Toss/Solver/Solver.ml trunk/Toss/TossTest.ml Modified: trunk/Toss/Formula/Makefile =================================================================== --- trunk/Toss/Formula/Makefile 2010-11-21 21:44:23 UTC (rev 1189) +++ trunk/Toss/Formula/Makefile 2010-11-22 02:05:26 UTC (rev 1190) @@ -3,6 +3,7 @@ %Test: make -C .. Formula/$@ +AuxTest: FormulaTest: BoolFormulaTest: FormulaOpsTest: Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2010-11-21 21:44:23 UTC (rev 1189) +++ trunk/Toss/Makefile 2010-11-22 02:05:26 UTC (rev 1190) @@ -32,9 +32,9 @@ OCB_CFLAG=-cflags -I,+oUnit,-g OCB_LIB=-libs str,nums,unix,oUnit OCB_PP=-pp "camlp4o ../caml_extensions/pa_let_try.cmo ../caml_extensions/pa_backtrace.cmo" -OCAMLBUILD=ocamlbuild -j 4 -menhir ../menhir_conf $(OCB_PP) \ +OCAMLBUILD=ocamlbuild -j 8 -menhir ../menhir_conf $(OCB_PP) \ $(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAG) -OCAMLBUILDBT=ocamlbuild -j 4 menhir ../menhir_conf $(OCB_PP) \ +OCAMLBUILDBT=ocamlbuild -j 8 menhir ../menhir_conf $(OCB_PP) \ $(OCB_LIB) $(OCB_CFLAG) $(OCB_LFLAGBT) FormulaINC=Formula/Sat @@ -68,6 +68,7 @@ # Formula tests Formula_tests: \ + Formula/AuxTest \ Formula/FormulaTest \ Formula/BoolFormulaTest \ Formula/FormulaOpsTest \ Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-21 21:44:23 UTC (rev 1189) +++ trunk/Toss/Solver/Solver.ml 2010-11-22 02:05:26 UTC (rev 1190) @@ -177,23 +177,39 @@ process_vars [] (List.sort Formula.compare_vars (fo_vars_real p)) +(* Helper: find assoc and remove. *) +let rec assoc_del (x : Formula.formula) = function + | [] -> raise Not_found + | (a, b as pair) :: l -> + if x = a then (b, l) else + let (b, nl) = assoc_del x l in + (b, pair :: nl) + (* Eval with very basic caching. *) let eval_m struc phi = + if phi = And [] then Any else if !cache_struc != struc then ( let els = Set (Elems.cardinal struc.elements, struc.elements) in let asg = eval struc (ref els) Any phi in cache_struc := struc; cache_results := [(phi, asg)]; asg - ) else try - List.assoc phi !cache_results - with Not_found -> - if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi)); - if List.length !cache_results > !cCACHESIZE then cache_results := []; - let els = Set (Elems.cardinal struc.elements, struc.elements) in - let asg = eval struc (ref els) Any phi in - cache_results := (phi, asg) :: !cache_results; - asg + ) else + try + let (res, new_cache) = assoc_del phi !cache_results in + cache_results := (phi, res) :: new_cache; + if !debug_level > 1 then ( + print_endline ("found in cache: " ^ (Formula.str phi)); + print_endline ("size: "^ (string_of_int (List.length !cache_results))); + ); + res + with Not_found -> + if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi)); + if List.length !cache_results > !cCACHESIZE then cache_results := []; + let els = Set (Elems.cardinal struc.elements, struc.elements) in + let asg = eval struc (ref els) Any phi in + cache_results := (phi, asg) :: !cache_results; + asg (* Helper function, assignment of tuple. *) let asg_of_tuple struc vars tuple = @@ -207,37 +223,66 @@ eval_m struc (RealExpr (Plus (expr, Times (Const (-1.), RVar rvar)), Formula.EQZero)) +(* Helper checking function. *) +let rec check_f struc asg = function + | Ex (vs, phi) -> check_f struc asg phi + | Or (fl) -> List.exists (check_f struc asg) fl + | phi -> join asg (eval_m struc phi) <> Empty +(* Almost as eval_m but cache sub-formulas in boolean form without free vars. *) +let eval_cache_sentences solver struc in_phi = + let reg_tnf phi = + try + let phi_id = List.assoc phi !(solver.reg_formulas) in + Hashtbl.find solver.formulas_eval phi_id + with Not_found -> + Hashtbl.find solver.formulas_eval (register_formula solver phi) in + let eval_no_fv phi = + if FormulaOps.free_vars phi = [] then ( + if !debug_level > 1 then + print_endline ("sentence check: " ^ (Formula.str phi)); + if check_f struc Any (reg_tnf phi) then And [] else Or [] + ) + else phi in + let not_true f = f <> And [] in + let not_false f = f <> Or [] in + let rec subst_no_fv = function + | And fl -> + let nfl = List.filter not_true (List.map subst_no_fv fl) in + if List.exists (fun f -> f = Or []) nfl then Or [] else And nfl + | Or fl -> + let nfl = List.filter not_false (List.map subst_no_fv fl) in + if List.exists (fun f -> f = And []) nfl then And [] else Or nfl + | f -> eval_no_fv f in + let phi = subst_no_fv in_phi in + let proc_phi = reg_tnf phi in + if !debug_level > 0 then ( + print_endline ("in phi: " ^ (Formula.str in_phi)); + print_endline ("phi: " ^ (Formula.str phi)); + print_endline ("proc phi: " ^ (Formula.str proc_phi)); + ); + eval_m struc proc_phi + + (* Fast function to get a value of a real expression without free variables other than those assigned in [asg] explicitely. *) let rec get_real_val solver asg expr struc = - let rec check_f = function - Ex (vs, phi) -> check_f phi - | Or (fl) -> List.exists check_f fl - | phi -> join asg (eval_m struc phi) <> Empty in + let check_fa = check_f struc asg in match expr with - Char phi -> if check_f phi then 1. else 0. + Char phi -> if check_fa phi then 1. else 0. | Const v -> v | Times (e1, e2) -> (get_real_val solver asg e1 struc) *. (get_real_val solver asg e2 struc) | Plus (e1, e2) -> (get_real_val solver asg e1 struc) +. (get_real_val solver asg e2 struc) | Sum (vl, guard, r) -> - let gd = ( - try - let gd_id = List.assoc guard !(solver.reg_formulas) in - Hashtbl.find solver.formulas_eval gd_id - with Not_found -> - Hashtbl.find solver.formulas_eval (register_formula solver guard) - ) in let all_vs = (List.map to_fo (AssignmentSet.assigned_vars [] asg)) @ vl in if !debug_level > 0 then ( - print_endline ("guard " ^ (Formula.str guard)); print_endline ("asg " ^ (AssignmentSet.str asg)); print_endline ("sum vars " ^ (Formula.var_list_str vl)); print_endline ("all vars " ^ (Formula.var_list_str all_vs)); ); - let asg_gd = join asg (eval_m struc gd) in + 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 = let tp_asg = asg_of_tuple struc all_vs tp in Modified: trunk/Toss/TossTest.ml =================================================================== --- trunk/Toss/TossTest.ml 2010-11-21 21:44:23 UTC (rev 1189) +++ trunk/Toss/TossTest.ml 2010-11-22 02:05:26 UTC (rev 1190) @@ -1,7 +1,7 @@ open OUnit let formula_tests = "Formula" >::: [ - (* AuxTest.tests; *) + AuxTest.tests; FormulaTest.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...> - 2010-11-22 21:18:53
|
Revision: 1191 http://toss.svn.sourceforge.net/toss/?rev=1191&view=rev Author: lukstafi Date: 2010-11-22 21:18:46 +0000 (Mon, 22 Nov 2010) Log Message: ----------- Test adjustments. Bug fixes in FFSolver. Display of _new_ on boards fix. Modified Paths: -------------- trunk/Toss/Arena/DiscreteRuleTest.ml trunk/Toss/Play/GameTest.ml trunk/Toss/Play/HeuristicTest.ml trunk/Toss/Solver/FFSolver.ml trunk/Toss/Solver/FFSolverTest.ml trunk/Toss/Solver/Structure.ml Modified: trunk/Toss/Arena/DiscreteRuleTest.ml =================================================================== --- trunk/Toss/Arena/DiscreteRuleTest.ml 2010-11-22 02:05:26 UTC (rev 1190) +++ trunk/Toss/Arena/DiscreteRuleTest.ml 2010-11-22 21:18:46 UTC (rev 1191) @@ -18,6 +18,12 @@ let rev_names = Structure.rev_string_to_int_map +let assert_one_of ?msg str_list str = + let msg = match msg with None -> "" | Some msg -> msg^": " in + let elements = String.concat ", " str_list in + assert_bool (msg^"expected one of "^elements^", but got "^str) + (List.mem str str_list) + let tests = "DiscreteRule" >::: [ "parsing: simple tests" >:: (fun () -> @@ -522,7 +528,7 @@ pre = Formula.And []; rule_s = [1,1]} in assert_equal ~printer:(fun x->x) ~msg:"one not opt" - "(true and (not O(b)) and true and true)-> true" + "(not O(b))-> true" (rule_obj_str rule_obj); let lhs_struc = struc_of_str "[ e | _opt_D (e); O(e) | ]" in @@ -538,7 +544,7 @@ pre = Formula.And []; rule_s = [1,1]} in assert_equal ~printer:(fun x->x) ~msg:"del one not opt" - "(O(b) and true and true and true)-> (not O(b))" + "O(b)-> (not O(b))" (rule_obj_str rule_obj); let lhs_struc = struc_of_str "[ e | D (e); _opt_O(e) | ]" in @@ -553,8 +559,8 @@ emb_rels = ["O"; "D"]; pre = Formula.And []; rule_s = [1,1]} in - assert_equal ~printer:(fun x->x) ~msg:"match defined" - "((P(b) or Q(b)) and true and true and true)-> O(b)" + assert_one_of ~msg:"match defined" + ["(P(b) or Q(b))-> O(b)"; "(Q(b) or P(b))-> O(b)"] (rule_obj_str rule_obj); let lhs_struc = struc_of_str "[ e | D (e); _opt_O(e) | ]" in @@ -569,8 +575,8 @@ emb_rels = ["O"; "D"]; pre = Formula.And []; rule_s = [1,1]} in - assert_equal ~printer:(fun x->x) ~msg:"match defined" - "((P(b) or Q(b)) and true and true and true)-> (O(b) and (not P(b)) and (not Q(b)))" + assert_one_of ~msg:"match defined 2" + ["(P(b) or Q(b))-> (O(b) and (not P(b)) and (not Q(b)))";"(Q(b) or P(b))-> (O(b) and (not P(b)) and (not Q(b)))"] (rule_obj_str rule_obj); ); @@ -591,7 +597,7 @@ pre = Formula.And []; rule_s = [1,1]} in assert_equal ~printer:(fun x->x) ~msg:"defrel: diffthan P Q" - "(true and ((not P(b)) and (not Q(b))) and true and true)-> true" + "((not P(b)) and (not Q(b)))-> true" (rule_obj_str rule_obj); let lhs_struc = struc_of_str "[ e | _del_D (e); O(e) | ]" in @@ -606,8 +612,8 @@ emb_rels = ["O"; "D"]; pre = Formula.And []; rule_s = [1,1]} in - assert_equal ~printer:(fun x->x) ~msg:"del defrel" - "(((_del_P(b) or _del_Q(b)) and O(b)) and ((not P(b)) and (not Q(b))) and true and true)-> (P(b) and (not O(b)))" + assert_one_of ~msg:"del defrel" + ["(O(b) and (not P(b)) and (not Q(b)) and (_del_P(b) or _del_Q(b)))-> (P(b) and (not O(b)))";"((_del_Q(b) or _del_P(b)) and O(b) and (not P(b)) and (not Q(b)))-> (P(b) and (not O(b)))"] (rule_obj_str rule_obj); let lhs_struc = struc_of_str "[ e | _opt_D (e); _diffthan_P(e) | ]" in @@ -623,7 +629,7 @@ pre = Formula.And []; rule_s = [1,1]} in assert_equal ~printer:(fun x->x) ~msg:"diffthan override" - "(true and ((not O(b)) and (not P(b))) and true and true)-> (O(b) and (not Q(b)))" + "((not O(b)) and (not P(b)))-> (O(b) and (not Q(b)))" (rule_obj_str rule_obj); ); Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2010-11-22 02:05:26 UTC (rev 1190) +++ trunk/Toss/Play/GameTest.ml 2010-11-22 21:18:46 UTC (rev 1191) @@ -39,7 +39,8 @@ let p_name (r, e) = (* Structure.elem_str rhs_struc r *) string_of_int r ^ ":" ^ Structure.elem_str struc e in - let emb = String.concat ", " (List.map p_name move.Game.embedding) in + let emb = String.concat ", " + (List.sort compare (List.map p_name move.Game.embedding)) in move.Game.rule ^ "{" ^ emb ^ "}" let move_gs_str state move = @@ -724,7 +725,7 @@ (fun mov_s -> List.mem mov_s ["2{1:a1}"; "2{1:a3}"; "2{1:c1}"; "2{1:c3}"])); - "tictactoe suggest avoid endgame" >:: + "tictactoe suggest avoid endgame diagonal" >:: (fun () -> let state = update_game tictactoe_game "[ | P:1 { }; Q:1 { } | ] \" @@ -736,9 +737,25 @@ . . . \"" 1 in (* TODO: replace with easy_case after monotonic heur done *) - easy_case state 1 "Q should block" + easy_case state 1 "Q should block diagonal" (fun mov_s -> "2{1:a1}" = mov_s)); + "tictactoe suggest avoid endgame straight" >:: + (fun () -> + let state = update_game tictactoe_game +"[ | P:1 { }; Q:1 { } | ] \" + + . P Q + + . P . + + . . . +\"" 1 in + (* TODO: replace with easy_case after monotonic heur done *) + easy_case state 1 "Q should block straight" + (fun mov_s -> "2{1:a1}" = mov_s); + ); + "tictactoe suggest win" >:: (fun () -> let state = update_game tictactoe_game @@ -800,8 +817,8 @@ ... ... ... ... W.. ...W W..W W..W \"" 1 in - easy_case state 1 "B should attack left" (* or medium *) - (fun mov_s -> "6{4:b3, 3:a3, 2:b2, 1:a2}" = mov_s)); + easy_case state 1 "B should attack left" + (fun mov_s -> "6{1:a2, 2:b2, 3:a3, 4:b3}" = mov_s)); "breakthrough suggest midgame" >:: (fun () -> @@ -826,12 +843,13 @@ \"" 0 in (* white move should beat the lower black *) easy_case state 0 "W should beat the lower B" (* or medium *) - (fun mov_s -> "3{1:e3, 3:e4, 2:f3, 4:f4}" = mov_s)); + (fun mov_s -> "3{1:e3, 2:f3, 3:e4, 4:f4}" = mov_s)); "gomoku8x8 avoid endgame" >:: (fun () -> + skip_if true "takes too long -- uncheck later"; let state = update_game gomoku8x8_game "[ | | ] \" ... ... ... ... @@ -881,6 +899,7 @@ "gomoku8x8 block gameover" >:: (fun () -> + skip_if true "takes too long -- uncheck later"; let state = update_game gomoku8x8_game "[ | | ] \" ... ... ... ... @@ -908,6 +927,7 @@ "gomoku8x8 more pieces" >:: (fun () -> + skip_if true "takes too long -- uncheck later"; let state = update_game gomoku8x8_game "[ | | ] \" ... ... ... ... @@ -989,7 +1009,7 @@ ); ] -let a = +let a = let file_from_path p = String.sub p (String.rindex p '/'+1) (String.length p - String.rindex p '/' - 1) in @@ -1012,7 +1032,7 @@ let a () = match test_filter - ["Game:0:misc:1:breakthrough payoff"] + ["Game:1:alpha_beta_ord:4:tictactoe suggest avoid endgame straight"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) Modified: trunk/Toss/Play/HeuristicTest.ml =================================================================== --- trunk/Toss/Play/HeuristicTest.ml 2010-11-22 02:05:26 UTC (rev 1190) +++ trunk/Toss/Play/HeuristicTest.ml 2010-11-22 21:18:46 UTC (rev 1191) @@ -127,7 +127,7 @@ F F F F F F F F \"" in assert_equal ~printer:(fun x->x) - "ex y7, y6, y5, y4, y3, y2, y1, y0, y ((C(x, y7) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, y) and C(y, x)))" + "ex y7, y6, y5, y4, y3, y2, y1, y0, y ((C(y7, y6) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, x) and C(x, y)))" (Formula.str (Heuristic.expanded_description 5 (Aux.strings_of_list ["B"; "W"]) state (formula_of_str "ex y (C(x, y) and F(y))"))); @@ -267,7 +267,7 @@ F F F F F F F F \"" in assert_equal ~printer:(fun x->x) - "ex y7, y6, y5, y4, y3, y2, y1, y0, y ((C(x, y7) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, y) and C(y, x)))" + "ex y7, y6, y5, y4, y3, y2, y1, y0, y ((C(y7, y6) and C(y6, y5) and C(y5, y4) and C(y4, y3) and C(y3, y2) and C(y2, y1) and C(y1, y0) and C(y0, x) and C(x, y)))" (Formula.str (Heuristic.expanded_form 5 (Aux.strings_of_list ["B"; "W"]) state (formula_of_str "ex y (C(x, y) and F(y))"))); Modified: trunk/Toss/Solver/FFSolver.ml =================================================================== --- trunk/Toss/Solver/FFSolver.ml 2010-11-22 02:05:26 UTC (rev 1190) +++ trunk/Toss/Solver/FFSolver.ml 2010-11-22 21:18:46 UTC (rev 1191) @@ -26,7 +26,23 @@ let vars_of_array nvs = Array.fold_left (fun vs nv -> Vars.add nv vs) Vars.empty nvs +let sb_str struc sb = + String.concat ", " (List.map (fun (v,e) -> + var_str v^"->"^Structure.elem_str struc e) sb) +let rec is_unique_assoc = function + | [] -> true + | (e,_)::tl -> if List.mem_assoc e tl then false + else is_unique_assoc tl + +(* +let aFO lnum (v,assgns) = + Printf.printf "(%d:%s) %!" lnum (var_str v); + if is_unique_assoc assgns then A.FO (v, assgns) + else failwith + ("not unique "^string_of_int lnum^": "^A.str (A.FO (v,assgns))) +*) + let rec invert_aset acc = function | A.Empty -> [] | A.Any -> acc @@ -266,9 +282,13 @@ Tuples.fold (fun tup dom -> if Aux.array_for_all2 (fun known asked-> known = -1 || known = asked) known_tup tup + && not (List.mem tup.(nvi) dom) then tup.(nvi)::dom else dom) tuples [] in - if not multi_unkn && conj_cont = [] && delayed1 = [] && + if init_domain = [] + then raise + (Unsatisfiable_FO (vars_of_array (var_tup vtup))) + else if not multi_unkn && conj_cont = [] && delayed1 = [] && delayed2 = [] then (* no more vars and conjuncts *) A.FO (nvar, List.map (fun e->e,A.Any) init_domain) @@ -383,7 +403,9 @@ then Elems.add tup.(nvi) dom else dom) tuples Elems.empty in Elems.elements (Elems.diff model.elements init_domain_co) in - if conj_cont = [] && delayed1 = [] && delayed2 = [] + if init_domain = [] + then raise Unsatisfiable + else if conj_cont = [] && delayed1 = [] && delayed2 = [] then (* no more vars and conjuncts *) A.FO (nvar, List.map (fun e->e,A.Any) init_domain) else @@ -669,7 +691,9 @@ let register_real_expr expr = ref (expr, false) let evaluate struc reg_phi = if not (snd !reg_phi) then - reg_phi := normalize_for_model struc (fst !reg_phi), true; + reg_phi := + normalize_for_model struc + (FormulaOps.simplify (fst !reg_phi)), true; evaluate struc (fst !reg_phi) let check_formula struc reg_phi = if not (snd !reg_phi) then @@ -680,5 +704,9 @@ reg_expr := normalize_expr_for_model struc (fst !reg_expr), true; get_real_val (fst !reg_expr) struc - let formula_str reg_phi = Formula.str (fst !reg_phi) + let formula_str reg_phi = + if not (snd !reg_phi) then + (* to increase consistency of display *) + reg_phi := FormulaOps.simplify (fst !reg_phi), false; + Formula.str (fst !reg_phi) end Modified: trunk/Toss/Solver/FFSolverTest.ml =================================================================== --- trunk/Toss/Solver/FFSolverTest.ml 2010-11-22 02:05:26 UTC (rev 1190) +++ trunk/Toss/Solver/FFSolverTest.ml 2010-11-22 21:18:46 UTC (rev 1191) @@ -30,15 +30,31 @@ (* alfa-conversion of the above *) let winQvwxyz_idempotent = "ex z ((Q(z) and (ex u0 ((C(u0, z) and ex y2 ((R(y2, u0) and Q(y2) and ex t0 ((C(t0, y2) and ex x2 ((R(x2, t0) and Q(x2) and ex s0 ((C(s0, x2) and ex w2 ((R(w2, s0) and Q(w2) and ex r0 ((C(r0, w2) and ex v2 ((R(v2, r0) and Q(v2))))))))))))))))) or ex u ((C(z, u) and ex y1 ((R(y1, u) and Q(y1) and ex t ((C(y1, t) and ex x1 ((R(x1, t) and Q(x1) and ex s ((C(x1, s) and ex w1 ((R(w1, s) and Q(w1) and ex r ((C(w1, r) and ex v1 ((R(v1, r) and Q(v1))))))))))))))))) or ex y0 ((C(y0, z) and Q(y0) and ex x0 ((C(x0, y0) and Q(x0) and ex w0 ((C(w0, x0) and Q(w0) and ex v0 ((C(v0, w0) and Q(v0))))))))) or ex y ((R(y, z) and Q(y) and ex x ((R(x, y) and Q(x) and ex w ((R(w, x) and Q(w) and ex v ((R(v, w) and Q(v))))))))))))" +let real_val_eq struc_s expr_s x = + let struc = struc_of_str struc_s in + let expr = + FFSolver.normalize_expr_for_model struc (real_of_str expr_s) in + assert_equal ~printer:(fun x -> string_of_float x) ~msg:expr_s + x (FFSolver.get_real_val expr struc) let tests = "FFSolver" >::: [ - "get_real_val: simple sum" >:: + "get_real_val: tests from Solver.ml" >:: (fun () -> - let r = real_of_str "Sum (x, y | R (x, y) : 1)" in - let model = struc_of_str "[ | R { (a, a); (a, b) } | ] " in - assert_equal ~printer:(fun x -> string_of_float x) (2.) - (FFSolver.get_real_val r model) - ); + real_val_eq "[ | R { (a, a); (a, b) } | ] " + ":(ex x (R (x, x))) + 1" 2.; + real_val_eq "[ | P { x } | f { x->1, y->2, z->3 } ]" + "Sum (x | true : :f(x)^2)" 14.; + real_val_eq "[ | R { (a, a); (a, b) } | ] " + "Sum (x | true : :(all y (R (x, y))))" 1.; + real_val_eq "[ | R { (a, a); (a, b) } | ] " + "Sum (x | all y (R (x, y)) : 1)" 1.; + real_val_eq "[ | P { x } | f { x->1, y->2, z->3 } ]" + "Sum (x, y | P(x) : :f(x) * :f(y))" 6.; + real_val_eq "[ | P { x } | f { x->1, y->2, z->3 } ]" + "Sum (x, y | true : :f(x) * :f(y))" 36.; + real_val_eq "[ | R { (a, a); (a, b) } | ] " + "Sum (x, y | R (x, y) : 1)" 2.; + ); "evaluate: negation" >:: (fun () -> @@ -195,3 +211,4 @@ with | Some tests -> ignore (run_test_tt ~verbose:true tests) | None -> () + Modified: trunk/Toss/Solver/Structure.ml =================================================================== --- trunk/Toss/Solver/Structure.ml 2010-11-22 02:05:26 UTC (rev 1190) +++ trunk/Toss/Solver/Structure.ml 2010-11-22 21:18:46 UTC (rev 1191) @@ -640,7 +640,8 @@ predicates in let long_preds = List.filter (fun r -> - List.mem_assoc r uniq_long && not (List.mem r short_preds)) + List.mem_assoc r uniq_long && not (List.mem r news) + && not (List.mem r short_preds)) predicates in let used1, rep1, short_preds, diffthans, opts, news, dels, long_preds = if use_any then This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-23 01:44:52
|
Revision: 1192 http://toss.svn.sourceforge.net/toss/?rev=1192&view=rev Author: lukaszkaiser Date: 2010-11-23 01:44:43 +0000 (Tue, 23 Nov 2010) Log Message: ----------- Optimizing evaluation order in solver. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Solver/Assignments.ml trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/SolverTest.ml Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-22 21:18:46 UTC (rev 1191) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-23 01:44:43 UTC (rev 1192) @@ -685,6 +685,16 @@ | Or fl -> Or (List.rev_map unprotect fl) | phi -> phi +(* Choose a variable from [vs] to put topmost for [phi]. *) +let pick_var phi (vs : var list) = + let rec has_pos_pred v = function (* Simple positive-predicate heuristic. *) + | Rel (_, [|w|]) when v = (w :> var) -> true + | And fl | Or fl -> List.exists (has_pos_pred v) fl + | _ -> false in + let (posp, other) = List.partition (fun v -> has_pos_pred v phi) vs in + if posp = [] then (List.hd other, List.tl other) else + (List.hd posp, (List.tl posp) @ other) + (* A formula is in TNF if, and only if, it is a boolean combination of formulas tau of the form: a literal or Ex (xs, boolean combination of tau's) or All (xs, boolean combination of tau's). One invariant must additionally hold: @@ -709,7 +719,9 @@ let dnf_phi = List.rev_map unand conv_phi in if !debug_level_tnf > 0 then print_endline ("TNF done: "^ (var_str x)); Or (List.rev_map (append_quant [x] ~universal:false) dnf_phi) - | Ex (x :: xs, phi) -> tnf_fun (Ex ([x], Ex (xs, phi))) + | Ex (vs, phi) -> + let (x, xs) = pick_var phi vs in + tnf_fun (Ex ([x], Ex (xs, phi))) | All ([], phi) -> failwith "empty universal when computing TNF" | All (xs, And fl) -> And (List.rev_map (fun f -> tnf_fun (All (xs, f))) fl) | All ([x], phi) -> @@ -723,7 +735,9 @@ let cnf_phi = List.rev_map unor conv_phi in if !debug_level_tnf > 0 then print_endline ("TNF done: " ^ (var_str x)); And (List.rev_map (append_quant [x] ~universal:true) cnf_phi) - | All (x :: xs, phi) -> tnf_fun (All ([x], All (xs, phi))) + | All (vs, phi) -> + let (x, xs) = pick_var phi vs in + tnf_fun (All ([x], All (xs, phi))) and tnf_re_fun = function RVar _ | Const _ | Fun _ as x -> x @@ -757,7 +771,30 @@ let tnf_fv phi = let fv = free_vars phi in let psi = rename_quant_avoiding [] (Ex (fv, phi)) in - del_vars_quant fv (tnf psi) + let rec order_by_fv acc_fv = function + | [] -> [] + | [f] -> [f] + | l -> + let cross x = List.exists (fun v -> List.mem v acc_fv) (free_vars x) in + let (cf, o) = List.partition cross l in + if cf = [] then + let new_fv = free_vars (List.hd l) in + order_by_fv new_fv (List.map (order_by_fv_phi new_fv) l) + else + let new_fv = acc_fv @ (free_vars (And cf)) in + cf @ (order_by_fv new_fv (List.map (order_by_fv_phi new_fv) o)) + and order_by_fv_phi acc_fv = function + | And fl -> + let is_pred = function Rel (_, [|_|]) -> true | _ -> false in + let (p, np) = List.partition is_pred fl in + let res = And (order_by_fv acc_fv (p @ np)) in + if !debug_level > 1 then print_endline ("fvordered: " ^ (str res)); + res + | Ex (vs, phi) -> Ex (vs, order_by_fv_phi acc_fv phi) + | f -> f in + match flatten (del_vars_quant fv (tnf psi)) with + | Or fl -> Or (List.map (order_by_fv_phi []) fl) + | f -> f (* Assign emptyset to the MSO-variable v by replacing "x in X" with "false". *) let assign_emptyset v phi = Modified: trunk/Toss/Solver/Assignments.ml =================================================================== --- trunk/Toss/Solver/Assignments.ml 2010-11-22 21:18:46 UTC (rev 1191) +++ trunk/Toss/Solver/Assignments.ml 2010-11-23 01:44:43 UTC (rev 1192) @@ -470,7 +470,8 @@ let aset_tuples = List.fold_left (fun s (e,_)-> Tuples.union s (tps e)) Tuples.empty map in - full_join_rel aset vars aset_tuples all_elems + if aset_tuples = Tuples.empty then Empty else + full_join_rel aset vars aset_tuples all_elems | _ -> full_join_rel aset vars tuples_set all_elems and full_join_rel aset vars tuples_set all_elems = Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-22 21:18:46 UTC (rev 1191) +++ trunk/Toss/Solver/Solver.ml 2010-11-23 01:44:43 UTC (rev 1192) @@ -91,6 +91,7 @@ | Not phi -> (*A intersect (complement B)=A intersect (complement(B intersect A))*) report (complement_join elems aset (eval model elems aset phi)) + | And [] -> aset | And [phi] -> report (eval model elems aset phi) | And fl -> report (List.fold_left (eval model elems) aset fl) | Or [phi] -> report (eval model elems aset phi) @@ -101,13 +102,13 @@ | Ex ([], phi) | All ([], phi) -> failwith "evaluating empty quantifier" | Ex (vl, phi) -> let aset_vars = AssignmentSet.assigned_vars [] aset in - let in_aset = (* FIXME; TODO; care for same-name quantified vars! *) + let in_aset = (* FIXME; TODO; same-name quantified vars?! (tnf_fv!) *) if List.exists (fun v -> List.mem v aset_vars) vl then Any else aset in let phi_asgn = eval model elems in_aset phi in report (join aset (project_list elems phi_asgn vl)) | All (vl, phi) -> let aset_vars = AssignmentSet.assigned_vars [] aset in - let in_aset = (* FIXME; TODO; care for same-name quantified vars! *) + let in_aset = (* FIXME; TODO; same-name quantified vars?! (tnf_fv!) *) if List.exists (fun v -> List.mem v aset_vars) vl then Any else aset in let phi_asgn = eval model elems in_aset phi in report (join aset (universal_list elems phi_asgn vl)) Modified: trunk/Toss/Solver/SolverTest.ml =================================================================== --- trunk/Toss/Solver/SolverTest.ml 2010-11-22 21:18:46 UTC (rev 1191) +++ trunk/Toss/Solver/SolverTest.ml 2010-11-23 01:44:43 UTC (rev 1192) @@ -19,11 +19,14 @@ ;; let eval_eq struc_s phi_s aset_s = - let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in - let solver = new_solver () in - let f = register_formula solver phi in - assert_equal ~printer:(fun x -> x) - (AssignmentSet.str (evaluate solver f struc)) aset_s + let res = ref "" in + backtrace ( + let (struc, phi) = (struc_of_string struc_s, formula_of_string phi_s) in + let solver = new_solver () in + let f = register_formula solver phi in + res := AssignmentSet.str (evaluate solver f struc); + ); + assert_equal ~printer:(fun x -> x) !res aset_s ;; let eval_real_eq var_s struc_s expr_s aset_s = @@ -179,7 +182,7 @@ " z->58{ y->50{ x->42{ w->34{ v->26 } } } } ," ^ " z->62{ y->53{ x->44{ w->35{ v->26 } } } } ," ^ " z->63{ y->54{ x->45{ w->36{ v->27 } } } } }"); - ); + ); "eval real: basic" >:: (fun () -> This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-23 09:56:39
|
Revision: 1193 http://toss.svn.sourceforge.net/toss/?rev=1193&view=rev Author: lukstafi Date: 2010-11-23 09:56:32 +0000 (Tue, 23 Nov 2010) Log Message: ----------- Alpha-beta bug fix. adv_ratio lowered to 2. Modified Paths: -------------- trunk/Toss/Client/Wrapper.py trunk/Toss/Play/Game.ml trunk/Toss/Play/GameTest.ml Modified: trunk/Toss/Client/Wrapper.py =================================================================== --- trunk/Toss/Client/Wrapper.py 2010-11-23 01:44:43 UTC (rev 1192) +++ trunk/Toss/Client/Wrapper.py 2010-11-23 09:56:32 UTC (rev 1193) @@ -396,7 +396,7 @@ # "EVAL LOC MOVES advancement_ratio location TIMEOUT time_in_sec iters_or_depth_limit method optional_playout_horizon" # syntax variant 2: # "EVAL LOC MOVES [{0: heuristic_player_0_loc_0; 1: heuristic_player_1_loc_0}; {0: heuristic_player_0_loc_1; 1: heuristic_player_1_loc_1}] advancement_ratio location TIMEOUT time_in_sec iters_or_depth_limit method optional_playout_horizon" - m = self.msg ("EVAL LOC MOVES 5.0 " + str(loc) +" TIMEOUT 1200 "+ str(no_iters) + " alpha_beta_ord") + m = self.msg ("EVAL LOC MOVES 2.0 " + str(loc) +" TIMEOUT 1200 "+ str(no_iters) + " alpha_beta_ord") self.set_time (ts, t) msg = [s.strip() for s in m.split(';')] emb = dict() Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2010-11-23 01:44:43 UTC (rev 1192) +++ trunk/Toss/Play/Game.ml 2010-11-23 09:56:32 UTC (rev 1193) @@ -225,8 +225,7 @@ cooperative = false ; } -(* At least 5th degree monotonic heuristic needed for Gomoku. *) -let default_adv_ratio = 5.0 +let default_adv_ratio = 2.0 let default_heuristic ?struc advance_ratio @@ -736,7 +735,8 @@ let state = models.(pos) in let sub_heur = maximax_tree player new_betas (depth-1) state in - if now_pruning && sub_heur.(player) >= betas.(player) + (* 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 > 6) && Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2010-11-23 01:44:43 UTC (rev 1192) +++ trunk/Toss/Play/GameTest.ml 2010-11-23 09:56:32 UTC (rev 1193) @@ -753,7 +753,7 @@ \"" 1 in (* TODO: replace with easy_case after monotonic heur done *) easy_case state 1 "Q should block straight" - (fun mov_s -> "2{1:a1}" = mov_s); + (fun mov_s -> "2{1:b1}" = mov_s); ); "tictactoe suggest win" >:: @@ -845,6 +845,31 @@ easy_case state 0 "W should beat the lower B" (* or medium *) (fun mov_s -> "3{1:e3, 2:f3, 3:e4, 4:f4}" = mov_s)); + "breakthrough suggest adv_ratio" >:: + (fun () -> + let state = update_game breakthrough_game +"[ | | ] \" + ... ... ... ... + B B..B B..B B..B B.. + ... ... ... ... + B.. ... -B.B B..B + ... ... ... ... + ... ...+B ... ... + ... ... ... ... + ...B ... B.. ... + ... ... ... ... + ... ...W ... ... + ... ... ... ... + ... ... ... ... + ... ... ... ... + W W.. W..W W.. W.. + ... ... ... ... + W..W W..W W..W W..W +\"" 0 in + (* white move should beat the lower black *) + easy_case state 0 "W should play cool" + (fun mov_s -> mov_s <> "3{1:e4, 2:f4, 3:e5, 4:f5}" + && mov_s <> "2{1:d4, 2:e4, 3:d5, 4:e5}")); "gomoku8x8 avoid endgame" >:: @@ -1009,7 +1034,7 @@ ); ] -let a = +let a = let file_from_path p = String.sub p (String.rindex p '/'+1) (String.length p - String.rindex p '/' - 1) in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-23 11:20:28
|
Revision: 1194 http://toss.svn.sourceforge.net/toss/?rev=1194&view=rev Author: lukaszkaiser Date: 2010-11-23 11:20:21 +0000 (Tue, 23 Nov 2010) Log Message: ----------- Back to FFSolver eval for profiling. Modified Paths: -------------- trunk/Toss/Makefile trunk/Toss/Solver/Solver.ml Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2010-11-23 09:56:32 UTC (rev 1193) +++ trunk/Toss/Makefile 2010-11-23 11:20:21 UTC (rev 1194) @@ -48,6 +48,11 @@ caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo $(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@ +%.p.native: %.ml \ + Formula/Sat/minisat/SatSolver.o Formula/Sat/minisat/MiniSATWrap.o \ + caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo + $(OCAMLBUILD) -Is $($(subst /,INC,$(dir $@))) $@ + %.d.byte: %.ml \ Formula/Sat/minisat/SatSolver.o Formula/Sat/minisat/MiniSATWrap.o \ caml_extensions/pa_let_try.cmo caml_extensions/pa_backtrace.cmo Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-23 09:56:32 UTC (rev 1193) +++ trunk/Toss/Solver/Solver.ml 2010-11-23 11:20:21 UTC (rev 1194) @@ -283,7 +283,9 @@ print_endline ("sum vars " ^ (Formula.var_list_str vl)); print_endline ("all vars " ^ (Formula.var_list_str all_vs)); ); - let asg_gd = join asg (eval_cache_sentences solver struc guard) in + let gd = FFTNF.ff_tnf (FFSolver.promote_for struc) guard in + let asg_gd = join asg (FFSolver.evaluate struc gd) in + (* 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 = let tp_asg = asg_of_tuple struc all_vs tp in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-24 00:34:16
|
Revision: 1195 http://toss.svn.sourceforge.net/toss/?rev=1195&view=rev Author: lukaszkaiser Date: 2010-11-24 00:34:10 +0000 (Wed, 24 Nov 2010) Log Message: ----------- Correcting solver cache gives significant speed improvement. Added profiling targets. Modified Paths: -------------- trunk/Toss/.cvsignore trunk/Toss/Arena/.cvsignore trunk/Toss/Formula/.cvsignore trunk/Toss/Makefile trunk/Toss/Play/.cvsignore trunk/Toss/Solver/.cvsignore trunk/Toss/Solver/Solver.ml Property Changed: ---------------- trunk/Toss/ trunk/Toss/Arena/ trunk/Toss/Formula/ trunk/Toss/Play/ trunk/Toss/Solver/ Property changes on: trunk/Toss ___________________________________________________________________ Modified: svn:ignore - # We are still using .cvsignore files as we find them easier to manage # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . Toss.docdir _build Server *.native *~ *.annot *.cmx *.cmi *.o *.cmo *.a *.cmxa log.* + # We are still using .cvsignore files as we find them easier to manage # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . Toss.docdir _build Server *.native *Profile.log gmon.out *~ *.annot *.cmx *.cmi *.o *.cmo *.a *.cmxa log.* Modified: trunk/Toss/.cvsignore =================================================================== --- trunk/Toss/.cvsignore 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/.cvsignore 2010-11-24 00:34:10 UTC (rev 1195) @@ -6,6 +6,8 @@ _build Server *.native +*Profile.log +gmon.out *~ *.annot *.cmx Property changes on: trunk/Toss/Arena ___________________________________________________________________ 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 . *~ + # 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 . *Profile.log *~ Modified: trunk/Toss/Arena/.cvsignore =================================================================== --- trunk/Toss/Arena/.cvsignore 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/Arena/.cvsignore 2010-11-24 00:34:10 UTC (rev 1195) @@ -2,4 +2,5 @@ # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . +*Profile.log *~ Property changes on: trunk/Toss/Formula ___________________________________________________________________ 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 . *~ + # 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 . *Profile.log *~ Modified: trunk/Toss/Formula/.cvsignore =================================================================== --- trunk/Toss/Formula/.cvsignore 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/Formula/.cvsignore 2010-11-24 00:34:10 UTC (rev 1195) @@ -2,4 +2,5 @@ # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . +*Profile.log *~ Modified: trunk/Toss/Makefile =================================================================== --- trunk/Toss/Makefile 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/Makefile 2010-11-24 00:34:10 UTC (rev 1195) @@ -71,6 +71,11 @@ %TestDebug: %Test.d.byte OCAMLRUNPARAM=b; export OCAMLRUNPARAM; _build/$< +%TestProfile: %Test.p.native + _build/$< + gprof _build/$< > $@.log + + # Formula tests Formula_tests: \ Formula/AuxTest \ Property changes on: trunk/Toss/Play ___________________________________________________________________ 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 . *~ + # 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 . *~ *Profile.log Modified: trunk/Toss/Play/.cvsignore =================================================================== --- trunk/Toss/Play/.cvsignore 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/Play/.cvsignore 2010-11-24 00:34:10 UTC (rev 1195) @@ -2,4 +2,5 @@ # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . +*Profile.log *~ Property changes on: trunk/Toss/Solver ___________________________________________________________________ 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 . *~ + # 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 . *Profile.log *~ Modified: trunk/Toss/Solver/.cvsignore =================================================================== --- trunk/Toss/Solver/.cvsignore 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/Solver/.cvsignore 2010-11-24 00:34:10 UTC (rev 1195) @@ -2,4 +2,5 @@ # than svn properties. Therefore if you change .cvsignore do the following. # svn propset svn:ignore -F .cvsignore . +*Profile.log *~ Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-23 11:20:21 UTC (rev 1194) +++ trunk/Toss/Solver/Solver.ml 2010-11-24 00:34:10 UTC (rev 1195) @@ -11,14 +11,13 @@ (* CACHE *) let cache_struc = ref (empty_structure ()) -let cache_results = ref [] -let cCACHESIZE = ref 50 +let cache_results = Hashtbl.create 15; (* ----------------------- BASIC TYPE DEFINITION -------------------------- *) type solver = { - reg_formulas : (Formula.formula * int) list ref ; + reg_formulas : (Formula.formula, int) Hashtbl.t ; formulas_eval : (int, Formula.formula) Hashtbl.t ; formulas_check : (int, Formula.formula) Hashtbl.t ; } @@ -27,7 +26,7 @@ (* ----------------------- CONSTRUCTOR FUNCTIONS -------------------------- *) let new_solver () = { - reg_formulas = ref [] ; + reg_formulas = Hashtbl.create 3 ; formulas_eval = Hashtbl.create 3 ; formulas_check = Hashtbl.create 3 ; } @@ -36,16 +35,16 @@ let rec check_form = function Ex (vs, phi) -> check_form phi | phi -> phi in - let psi = FormulaOps.tnf_fv phi in try - let res = List.assoc psi !(solver.reg_formulas) in + let res = Hashtbl.find solver.reg_formulas phi in if !debug_level > 0 then print_endline ("Found " ^ (str phi)); res with Not_found -> + let psi = FormulaOps.tnf_fv phi in if !debug_level > 0 then print_endline ("Entered " ^ (str phi)); if !debug_level > 0 then print_endline ("Registering " ^ (str psi)); let id = Hashtbl.length solver.formulas_eval + 1 in - solver.reg_formulas := (psi, id) :: !(solver.reg_formulas); + Hashtbl.add solver.reg_formulas phi id; Hashtbl.add solver.formulas_eval id psi; Hashtbl.add solver.formulas_check id (check_form psi); id @@ -193,23 +192,21 @@ let els = Set (Elems.cardinal struc.elements, struc.elements) in let asg = eval struc (ref els) Any phi in cache_struc := struc; - cache_results := [(phi, asg)]; + Hashtbl.clear cache_results; + Hashtbl.add cache_results phi asg; asg ) else try - let (res, new_cache) = assoc_del phi !cache_results in - cache_results := (phi, res) :: new_cache; + let res = Hashtbl.find cache_results phi in if !debug_level > 1 then ( print_endline ("found in cache: " ^ (Formula.str phi)); - print_endline ("size: "^ (string_of_int (List.length !cache_results))); ); res with Not_found -> if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi)); - if List.length !cache_results > !cCACHESIZE then cache_results := []; let els = Set (Elems.cardinal struc.elements, struc.elements) in let asg = eval struc (ref els) Any phi in - cache_results := (phi, asg) :: !cache_results; + Hashtbl.add cache_results phi asg; asg (* Helper function, assignment of tuple. *) @@ -234,7 +231,7 @@ let eval_cache_sentences solver struc in_phi = let reg_tnf phi = try - let phi_id = List.assoc phi !(solver.reg_formulas) in + let phi_id = Hashtbl.find solver.reg_formulas phi in Hashtbl.find solver.formulas_eval phi_id with Not_found -> Hashtbl.find solver.formulas_eval (register_formula solver phi) in @@ -257,7 +254,7 @@ | f -> eval_no_fv f in let phi = subst_no_fv in_phi in let proc_phi = reg_tnf phi in - if !debug_level > 0 then ( + if !debug_level > 1 then ( print_endline ("in phi: " ^ (Formula.str in_phi)); print_endline ("phi: " ^ (Formula.str phi)); print_endline ("proc phi: " ^ (Formula.str proc_phi)); @@ -283,9 +280,9 @@ print_endline ("sum vars " ^ (Formula.var_list_str vl)); print_endline ("all vars " ^ (Formula.var_list_str all_vs)); ); - let gd = FFTNF.ff_tnf (FFSolver.promote_for struc) guard in - let asg_gd = join asg (FFSolver.evaluate struc gd) in - (* let asg_gd = join asg (eval_cache_sentences solver struc guard) in *) + (* let gd = FFTNF.ff_tnf (FFSolver.promote_for struc) guard in + let asg_gd = join asg (FFSolver.evaluate struc gd) in *) + 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 = let tp_asg = asg_of_tuple struc all_vs tp in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-27 14:29:25
|
Revision: 1196 http://toss.svn.sourceforge.net/toss/?rev=1196&view=rev Author: lukaszkaiser Date: 2010-11-27 14:29:19 +0000 (Sat, 27 Nov 2010) Log Message: ----------- Transitive closure syntax. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Formula/FormulaOps.mli trunk/Toss/Formula/FormulaOpsTest.ml trunk/Toss/Formula/FormulaParser.mly trunk/Toss/Formula/Lexer.mll trunk/Toss/Formula/Tokens.mly trunk/Toss/Solver/SolverTest.ml trunk/Toss/examples/Tic-Tac-Toe.tossstyle Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-27 14:29:19 UTC (rev 1196) @@ -234,7 +234,25 @@ All (nvs, rename_quant_avoiding (avs @ nvs) (subst_vars subst phi)) +(* --------------------------- TRANSITIVE CLOSURE --------------------------- *) +(* We construct transitive closure of phi(x, y, z) over x, y as + "all X (x in X and (all x',y' + (x' in X and phi(x',y',z)-> y' in X)) -> y in X)" *) +let make_tc x y phi = + let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in + let (_, nx) = subst_name_avoiding fv xv in + let (_, ny) = subst_name_avoiding fv yv in + let (nxv, nyv) = (fo_var_of_string nx, fo_var_of_string ny) in + let frX = mso_var_of_string(snd(subst_name_avoiding fv(var_of_string "X"))) in + let nphi = subst_vars [(x, nx); (y, ny)] phi in + let impphi = Or [Not (And [In (nxv, frX); nphi]); In (nyv, frX)] in + let inphi = And [In (xv, frX); All (([nxv; nyv] :> var list), impphi)] in + All ([(frX :> var)], Or [Not inphi; In (yv, frX)]) + + + + (* --------- SUBSTITUTE DEFINED RELATIONS ------------ *) (* Substitute in relations defined in [defs] by their definitions. *) Modified: trunk/Toss/Formula/FormulaOps.mli =================================================================== --- trunk/Toss/Formula/FormulaOps.mli 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Formula/FormulaOps.mli 2010-11-27 14:29:19 UTC (rev 1196) @@ -53,6 +53,10 @@ val assign_emptyset : string -> formula -> formula +(* ------------------------ Transitive Closure ---------------------------- *) + +val make_tc : string -> string -> formula -> formula + (* -------------------------- Simplification ------------------------------ *) (* Recursively simplify a formula *) Modified: trunk/Toss/Formula/FormulaOpsTest.ml =================================================================== --- trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-27 14:29:19 UTC (rev 1196) @@ -258,6 +258,16 @@ [("R", (["x"; "y"], formula_of_string "S (x, y) and ex x S(y, x)"))] "R (y, x)" "S(y, x) and ex x0 (S(x, x0))"; ); + + "transitive closure creation" >:: + (fun () -> + let tc_eq x y phi1 phi2 = + formula_eq id phi2 (FormulaOps.make_tc x y) phi1 in + tc_eq "x" "y" "R(x, y)" "all X (x in X and (all x0,y0 + (x0 in X and R(x0,y0) -> y0 in X)) -> y in X)"; + tc_eq "x" "y" "R(x, y) and x in X" "all X0 (x in X0 and (all x0,y0 + (x0 in X0 and (R(x0,y0) and x0 in X) -> y0 in X0)) -> y in X0)"; + ); ] ;; let a = Modified: trunk/Toss/Formula/FormulaParser.mly =================================================================== --- trunk/Toss/Formula/FormulaParser.mly 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Formula/FormulaParser.mly 2010-11-27 14:29:19 UTC (rev 1196) @@ -76,6 +76,7 @@ | NOT formula_expr { Not ($2) } | EX var_list formula_expr { Ex ($2, $3) } | ALL var_list formula_expr { All ($2, $3) } + | TC ID COMMA ID formula_expr { FormulaOps.make_tc $2 $4 $5 } | OPEN formula_expr CLOSE { $2 } | formula_expr AND formula_expr { And [$1; $3] } | formula_expr OR formula_expr { Or [$1; $3] } Modified: trunk/Toss/Formula/Lexer.mll =================================================================== --- trunk/Toss/Formula/Lexer.mll 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Formula/Lexer.mll 2010-11-27 14:29:19 UTC (rev 1196) @@ -1,21 +1,4 @@ { -(* Tokens for parsers: must be in the same order as the type def. below. -%token <string> ID -%token <int> INT -%token <float> FLOAT -%token <string> BOARD_STRING -%token APOSTROPHE -%token COLON SEMICOLON COMMA 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 -%token IN AND OR XOR NOT EX ALL -%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 -*) - type token = | ID of (string) | INT of (int) @@ -59,6 +42,7 @@ | NOT | EX | ALL + | TC | WITH | EMB | PRE @@ -174,6 +158,8 @@ | "not" { NOT } | "ex" { EX } | "all" { ALL } + | "tc" { TC } + | "TC" { TC } | "with" { WITH } | "emb" { EMB } | "pre" { PRE } Modified: trunk/Toss/Formula/Tokens.mly =================================================================== --- trunk/Toss/Formula/Tokens.mly 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Formula/Tokens.mly 2010-11-27 14:29:19 UTC (rev 1196) @@ -7,7 +7,7 @@ %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 -%token IN AND OR XOR NOT EX ALL +%token IN AND OR XOR NOT EX ALL TC %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 Modified: trunk/Toss/Solver/SolverTest.ml =================================================================== --- trunk/Toss/Solver/SolverTest.ml 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/Solver/SolverTest.ml 2010-11-27 14:29:19 UTC (rev 1196) @@ -112,8 +112,7 @@ "eval: mso with quantifiers" >:: (fun () -> - let reach_f = - "all X (x in X and (all z,v (z in X and R(z,v)-> v in X))-> y in X)" in + let reach_f = "tc x, y R(x, y)" in eval_eq "[ | R { (a, b); (a, c) } | ]" reach_f "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3{ x->1, x->3 } }"; eval_eq "[ | R { (a, b); (b, c) } | ]" reach_f Modified: trunk/Toss/examples/Tic-Tac-Toe.tossstyle =================================================================== --- trunk/Toss/examples/Tic-Tac-Toe.tossstyle 2010-11-24 00:34:10 UTC (rev 1195) +++ trunk/Toss/examples/Tic-Tac-Toe.tossstyle 2010-11-27 14:29:19 UTC (rev 1196) @@ -1,6 +1,6 @@ nocolor ; elOPACITY: 30 ; relOPACITY: 150 ; -arrLENscale: 0.1 ; +arrLENscale: 0 ; P: ~/greencircle.svg; Q: ~/cross.svg; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-27 20:55:30
|
Revision: 1197 http://toss.svn.sourceforge.net/toss/?rev=1197&view=rev Author: lukaszkaiser Date: 2010-11-27 20:55:24 +0000 (Sat, 27 Nov 2010) Log Message: ----------- First-order transitive closure and subst_vars debugging. Modified Paths: -------------- trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/Formula/Formula.ml trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Formula/FormulaOps.mli trunk/Toss/Formula/FormulaOpsTest.ml trunk/Toss/Formula/FormulaParser.mly trunk/Toss/Solver/SolverTest.ml Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/Aux.ml 2010-11-27 20:55:24 UTC (rev 1197) @@ -11,8 +11,10 @@ let strings_of_list nvs = add_strings nvs Strings.empty +let is_digit c = + (c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') || + (c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9') - (* {2 Helper functions on lists and other functions lacking from the standard library.} *) let concat_map f l = Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/Aux.mli 2010-11-27 20:55:24 UTC (rev 1197) @@ -7,6 +7,8 @@ val add_strings : string list -> Strings.t -> Strings.t val strings_of_list : string list -> Strings.t +val is_digit : char -> bool + (** {2 Helper functions on lists and other functions lacking from the standard library.} *) Modified: trunk/Toss/Formula/Formula.ml =================================================================== --- trunk/Toss/Formula/Formula.ml 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/Formula.ml 2010-11-27 20:55:24 UTC (rev 1197) @@ -12,15 +12,14 @@ type mso_var = [ `MSO of string ];; type real_var = [ `Real of string ];; -let is_digit c = - (c = '0') || (c = '1') || (c = '2') || (c = '3') || (c = '4') || - (c = '5') || (c = '6') || (c = '7') || (c = '8') || (c = '9') - (* We recognize if the variable is FO (x, y) or MSO (X, Y) or Real (r1, r2). *) let var_of_string s : var = - if String.length s = 0 then failwith "empty strings not allowed as vars" - else if s.[0] = ':' then `Real s - else if ((Char.uppercase s.[0]) = s.[0]) && (not (is_digit s.[0])) then `MSO s + if String.length s = 0 then + failwith "empty strings not allowed as vars" + else if s.[0] = ':' then + `Real s + else if ((Char.uppercase s.[0]) = s.[0]) && (not (Aux.is_digit s.[0])) then + `MSO s else `FO s let fo_var_of_string s : fo_var = Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-27 20:55:24 UTC (rev 1197) @@ -205,13 +205,21 @@ let new_vs = List.filter (fun x -> not (in_vs x)) subst in if new_vs = [] then Sum(vs, phi, r) else Sum(vs, subst_vars new_vs phi, r) +(* Helper function: strip digits from string end except if it starts with one. *) +let rec strip_digits s = + if Aux.is_digit s.[0] then s else + let len = String.length s in + if Aux.is_digit s.[len-1] then + strip_digits (String.sub s 0 (len-1)) + else s + (* Find a substitution for [v] which avoids [avs]. *) let subst_name_avoiding avoidv var = - let (avs, v) = (List.rev_map var_str avoidv, var_str var) in + let (avs, v) = (List.rev_map var_str avoidv, strip_digits (var_str var)) in let rec asubst i = let vi = v ^ (string_of_int i) in - if not (List.mem vi avs) then (v, vi) else asubst (i+1) in - if List.mem v avs then asubst 0 else (v, v) + if not (List.mem vi avs) then (var_str var, vi) else asubst (i+1) in + if List.mem v avs then asubst 0 else (var_str var, v) (** Rename quantified variables avoiding the ones from [avs], and the above-quantified ones. Does not go into real_expr. *) @@ -225,7 +233,7 @@ if avoidv = [] then Ex (vs, rename_quant_avoiding (avs @ vs) phi) else let subst = List.map (subst_name_avoiding avs) avoidv in let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in - Ex (nvs, rename_quant_avoiding (avs @ nvs) (subst_vars subst phi)) + Ex (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi)) | All (vs, phi) -> let (avoidv, okv) = List.partition (fun v -> List.mem v avs) vs in if avoidv = [] then All (vs, rename_quant_avoiding (avs @ vs) phi) else @@ -233,7 +241,16 @@ let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in All (nvs, rename_quant_avoiding (avs @ nvs) (subst_vars subst phi)) +(* Apply substitution [subst] to all free variables in the given formula + checking for and preventing name clashes with quantified variables. *) +let subst_vars_check subst phi = + let nvars = List.map (fun (_, nv) -> var_of_string nv) subst in + let avoidvars = List.rev_append (free_vars phi) nvars in + subst_vars subst (rename_quant_avoiding avoidvars phi) +let subst_vars_nocheck subst phi = subst_vars subst phi + + (* --------------------------- TRANSITIVE CLOSURE --------------------------- *) (* We construct transitive closure of phi(x, y, z) over x, y as @@ -245,14 +262,23 @@ let (_, ny) = subst_name_avoiding fv yv in let (nxv, nyv) = (fo_var_of_string nx, fo_var_of_string ny) in let frX = mso_var_of_string(snd(subst_name_avoiding fv(var_of_string "X"))) in - let nphi = subst_vars [(x, nx); (y, ny)] phi in + let nphi = subst_vars_check [(x, nx); (y, ny)] phi in let impphi = Or [Not (And [In (nxv, frX); nphi]); In (nyv, frX)] in let inphi = And [In (xv, frX); All (([nxv; nyv] :> var list), impphi)] in All ([(frX :> var)], Or [Not inphi; In (yv, frX)]) +(* First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *) +let rec make_fo_tc k x y phi = + let (xv, yv) = (fo_var_of_string x, fo_var_of_string y) in + if k = 0 then Eq (xv, yv) else if k = 1 then Or [Eq (xv, yv); phi] else + let (fv, k1, k2) = (free_vars phi, k / 2, k - (k / 2)) in + let (_, t) = subst_name_avoiding fv (var_of_string "t") in + let (phi1, phi2) = (make_fo_tc k1 x y phi, make_fo_tc k2 x y phi) in + let (phi1s, phi2s) = + (subst_vars_check [(y,t)] phi1, subst_vars_check [(x,t)] phi2) in + Ex ([var_of_string t], And [phi1s; phi2s]) - (* --------- SUBSTITUTE DEFINED RELATIONS ------------ *) (* Substitute in relations defined in [defs] by their definitions. *) Modified: trunk/Toss/Formula/FormulaOps.mli =================================================================== --- trunk/Toss/Formula/FormulaOps.mli 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/FormulaOps.mli 2010-11-27 20:55:24 UTC (rev 1197) @@ -35,7 +35,12 @@ (* Apply substitution [subst] to all free variables in the given formula. Preserves order of subformulas. *) val subst_vars : (string * string) list -> formula -> formula +val subst_vars_nocheck : (string * string) list -> formula -> formula +(* Apply substitution [subst] to all free variables in the given formula + checking for and preventing name clashes with quantified variables. *) +val subst_vars_check : (string * string) list -> formula -> formula + (** Rename quantified variables avoiding the ones from [avs] list, and the above-quantified ones. Does not go into real_expr. *) val rename_quant_avoiding : var list -> formula -> formula @@ -55,8 +60,12 @@ (* ------------------------ Transitive Closure ---------------------------- *) +(* Transitive closure of phi(x, y, z) over x and y, an MSO formula. *) val make_tc : string -> string -> formula -> formula +(* First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *) +val make_fo_tc : int -> string -> string -> formula -> formula + (* -------------------------- Simplification ------------------------------ *) (* Recursively simplify a formula *) Modified: trunk/Toss/Formula/FormulaOpsTest.ml =================================================================== --- trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-27 20:55:24 UTC (rev 1197) @@ -15,7 +15,7 @@ let id x = x ;; -let tests = "Formula" >::: [ +let tests = "FormulaOps" >::: [ "nnf and parsing" >:: (fun () -> let nnf_eq phi1 phi2 = formula_eq id phi2 FormulaOps.nnf phi1 in @@ -259,6 +259,17 @@ "R (y, x)" "S(y, x) and ex x0 (S(x, x0))"; ); + "rename quantified variables" >:: + (fun () -> + let rq_eq vs phi1 phi2 = + let avs = List.map Formula.var_of_string vs in + formula_eq id phi2 (FormulaOps.rename_quant_avoiding avs) phi1 in + rq_eq ["x"] "ex x R(x, y)" "ex x0 R(x0, y)"; + rq_eq ["x"] "ex y R(x, y)" "ex y R(x, y)"; + rq_eq ["t"] "ex t ( (x = t or R(x, t)) and ex t0 ( t=t0 or R(t, t0) ))" + "ex t0 ( (x = t0 or R(x, t0)) and ex t1 ((t0 = t1 or R(t0, t1)) ))"; + ); + "transitive closure creation" >:: (fun () -> let tc_eq x y phi1 phi2 = @@ -268,6 +279,18 @@ tc_eq "x" "y" "R(x, y) and x in X" "all X0 (x in X0 and (all x0,y0 (x0 in X0 and (R(x0,y0) and x0 in X) -> y0 in X0)) -> y in X0)"; ); + + "first-order transitive closure creation" >:: + (fun () -> + let tc_eq k x y phi1 phi2 = + formula_eq id phi2 (FormulaOps.make_fo_tc k x y) phi1 in + tc_eq 2 "x" "y" "R(x, y)" "ex t((x=t or R(x,t)) and (t=y or R(t,y)))"; + tc_eq 3 "x" "y" "R(x, y, t)" "ex t0 ( (x = t0 or R(x, t0, t)) and + ex t1 ( (t0 = t1 or R(t0, t1, t)) and (t1 = y or R(t1, y, t)) ) )"; + tc_eq 5 "x" "y" "R(x, y)" "ex t ( ex t0 ( ((x = t0) or R(x, t0)) and + ((t0 = t) or R(t0, t)) ) and ex t0( ((t = t0) or R(t, t0)) and ex t1 ( + (t0 = t1 or R(t0, t1)) and (t1 = y or R(t1, y)) )))"; + ); ] ;; let a = Modified: trunk/Toss/Formula/FormulaParser.mly =================================================================== --- trunk/Toss/Formula/FormulaParser.mly 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Formula/FormulaParser.mly 2010-11-27 20:55:24 UTC (rev 1197) @@ -77,6 +77,7 @@ | EX var_list formula_expr { Ex ($2, $3) } | ALL var_list formula_expr { All ($2, $3) } | TC ID COMMA ID formula_expr { FormulaOps.make_tc $2 $4 $5 } + | TC INT ID COMMA ID formula_expr { FormulaOps.make_fo_tc $2 $3 $5 $6 } | OPEN formula_expr CLOSE { $2 } | formula_expr AND formula_expr { And [$1; $3] } | formula_expr OR formula_expr { Or [$1; $3] } Modified: trunk/Toss/Solver/SolverTest.ml =================================================================== --- trunk/Toss/Solver/SolverTest.ml 2010-11-27 14:29:19 UTC (rev 1196) +++ trunk/Toss/Solver/SolverTest.ml 2010-11-27 20:55:24 UTC (rev 1197) @@ -26,19 +26,19 @@ let f = register_formula solver phi in res := AssignmentSet.str (evaluate solver f struc); ); - assert_equal ~printer:(fun x -> x) !res aset_s + assert_equal ~printer:(fun x -> x) aset_s !res ;; let eval_real_eq var_s struc_s expr_s aset_s = let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in assert_equal ~printer:(fun x -> x) - (AssignmentSet.str (evaluate_real var_s expr struc)) aset_s + aset_s (AssignmentSet.str (evaluate_real var_s expr struc)) ;; let real_val_eq struc_s expr_s x = let (struc, expr) = (struc_of_string struc_s, real_expr_of_string expr_s) in assert_equal ~printer:(fun x -> string_of_float x) - (get_real_val (new_solver ()) AssignmentSet.Any expr struc) x + x (get_real_val (new_solver ()) AssignmentSet.Any expr struc) ;; @@ -112,16 +112,25 @@ "eval: mso with quantifiers" >:: (fun () -> - let reach_f = "tc x, y R(x, y)" in - eval_eq "[ | R { (a, b); (a, c) } | ]" reach_f + eval_eq "[ | R { (a, b); (a, c) } | ]" "tc x, y R(x, y)" "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3{ x->1, x->3 } }"; - eval_eq "[ | R { (a, b); (b, c) } | ]" reach_f - "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }"; + eval_eq "[ | R { (a, b); (b, c) } | ]" "tc x, y R(x, y)" + "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }"; eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]" - ("x != y and not R(x, y) and " ^ reach_f) + "x != y and not R(x, y) and tc x, y R(x, y)" ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^ " y->6{ x->1, x->2, x->3, x->4 } , y->7{ x->1, x->2, x->3, x->4," ^ " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }"); + eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]" + "x != y and not R(x, y) and tc 4 x, y R(x, y)" + ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^ + " y->6{ x->2, x->3, x->4 } , y->7{ x->3, x->4," ^ + " x->5 } , y->8{ x->4, x->5, x->6 } }"); + eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]" + "x != y and not R(x, y) and tc 7 x, y R(x, y)" + ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^ + " y->6{ x->1, x->2, x->3, x->4 } , y->7{ x->1, x->2, x->3, x->4," ^ + " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }"); ); "eval: with real values" >:: This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-28 01:37:06
|
Revision: 1201 http://toss.svn.sourceforge.net/toss/?rev=1201&view=rev Author: lukaszkaiser Date: 2010-11-28 01:37:00 +0000 (Sun, 28 Nov 2010) Log Message: ----------- More solver tests, fixing one assignments bug. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Solver/Assignments.ml trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/SolverTest.ml Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-28 00:49:57 UTC (rev 1200) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-28 01:37:00 UTC (rev 1201) @@ -239,7 +239,7 @@ if avoidv = [] then All (vs, rename_quant_avoiding (avs @ vs) phi) else let subst = List.map (subst_name_avoiding avs) avoidv in let nvs = okv @ (List.map var_of_string (snd (List.split subst))) in - All (nvs, rename_quant_avoiding (avs @ nvs) (subst_vars subst phi)) + All (nvs, subst_vars subst (rename_quant_avoiding (avs @ nvs) phi)) (* Apply substitution [subst] to all free variables in the given formula checking for and preventing name clashes with quantified variables. *) Modified: trunk/Toss/Solver/Assignments.ml =================================================================== --- trunk/Toss/Solver/Assignments.ml 2010-11-28 00:49:57 UTC (rev 1200) +++ trunk/Toss/Solver/Assignments.ml 2010-11-28 01:37:00 UTC (rev 1201) @@ -144,7 +144,7 @@ | x when x < 0 -> let rmap = List.rev_map (fun (i, a) -> (i, set_equal v e a)) map in let nmap = List.rev (List.filter (fun (_, a) -> a <> Empty) rmap) in - if nmap = [] then Empty else FO (v, nmap) + if nmap = [] then Empty else FO (u, nmap) | _ -> FO (v, [(e, aset)]) ) | aset -> FO (v, [(e, aset)]) Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-28 00:49:57 UTC (rev 1200) +++ trunk/Toss/Solver/Solver.ml 2010-11-28 01:37:00 UTC (rev 1201) @@ -102,13 +102,23 @@ | Ex (vl, phi) -> let aset_vars = AssignmentSet.assigned_vars [] aset in let in_aset = (* FIXME; TODO; same-name quantified vars?! (tnf_fv!) *) - if List.exists (fun v -> List.mem v aset_vars) vl then Any else aset in + if List.exists (fun v -> List.mem v aset_vars) vl then + let asg_s = AssignmentSet.str aset in + let form_s = Formula.str (Ex (vl, phi)) in + let msg_s = "solver: multiple vars?\n "^ asg_s ^ "\n "^ form_s in + failwith msg_s (* Any *) + else aset in let phi_asgn = eval model elems in_aset phi in report (join aset (project_list elems phi_asgn vl)) | All (vl, phi) -> let aset_vars = AssignmentSet.assigned_vars [] aset in let in_aset = (* FIXME; TODO; same-name quantified vars?! (tnf_fv!) *) - if List.exists (fun v -> List.mem v aset_vars) vl then Any else aset in + if List.exists (fun v -> List.mem v aset_vars) vl then + let asg_s = AssignmentSet.str aset in + let form_s = Formula.str (Ex (vl, phi)) in + let msg_s = "solver: multiple vars?\n "^ asg_s ^ "\n "^ form_s in + failwith msg_s (* Any *) + else aset in let phi_asgn = eval model elems in_aset phi in report (join aset (universal_list elems phi_asgn vl)) Modified: trunk/Toss/Solver/SolverTest.ml =================================================================== --- trunk/Toss/Solver/SolverTest.ml 2010-11-28 00:49:57 UTC (rev 1200) +++ trunk/Toss/Solver/SolverTest.ml 2010-11-28 01:37:00 UTC (rev 1201) @@ -112,7 +112,7 @@ "eval: mso with quantifiers" >:: (fun () -> - eval_eq "[ | R { (a, b); (a, c) } | ]" "tc x, y R(x, y)" +(* eval_eq "[ | R { (a, b); (a, c) } | ]" "tc x, y R(x, y)" "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3{ x->1, x->3 } }"; eval_eq "[ | R { (a, b); (b, c) } | ]" "tc x, y R(x, y)" "{ y->1{ x->1 } , y->2{ x->1, x->2 } , y->3 }"; @@ -120,7 +120,7 @@ "x != y and not R(x, y) and tc x, y R(x, y)" ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^ " y->6{ x->1, x->2, x->3, x->4 } , y->7{ x->1, x->2, x->3, x->4," ^ - " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }"); + " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }"); *) eval_eq "[ | R { (a,b); (b,c); (c,d); (d,e); (e,f); (f,g); (g,h) } | ]" "x != y and not R(x, y) and tc 4 x, y R(x, y)" ("{ y->3{ x->1 } , y->4{ x->1, x->2 } , y->5{ x->1, x->2, x->3 } ," ^ @@ -133,6 +133,29 @@ " x->5 } , y->8{ x->1, x->2, x->3, x->4, x->5, x->6 } }"); ); + "eval: bigger tc tests" >:: + (fun () -> + eval_eq "[ | | ] \" + ... ... + ... ... + ... ... + ... ... + ... ... + ... ... + ... ... + ... wB. +\"" "set d1(x, y) = ex z ((R(x, z) and C(z, y)) or (R(y, z) and C(z, x))) in + set d2(x, y) = ex z ((R(x, z) and C(y, z)) or (R(y, z) and C(x, z))) in + set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in + set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in + set fd1(x, y) = tc x,y (d1(x, y) and not w(y) and not b(y)) in + set fd2(x, y) = tc x,y (d2(x, y) and not w(y) and not b(y)) in + set Diag1 (x, y) = ex z (fd1 (x, z) and (z = y or d1 (z, y))) in + set Diag2 (x, y) = ex z (fd2 (x, z) and (z = y or d2 (z, y))) in + wB(x) and (Diag1 (x, y) or Diag2 (x, y))" + "{ y->3{ x->3 } , y->6{ x->3 } , y->8{ x->3 } , y->9{ x->3 } }"; + ); + "eval: with real values" >:: (fun () -> eval_eq "[ | P { x } | ] " "ex :x ((:x^2 + 3*:x + 2 < 0) and (:x < 0))" This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-28 13:28:06
|
Revision: 1203 http://toss.svn.sourceforge.net/toss/?rev=1203&view=rev Author: lukaszkaiser Date: 2010-11-28 13:27:59 +0000 (Sun, 28 Nov 2010) Log Message: ----------- First small step in mso solver optimizations. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Solver/Solver.ml Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-28 01:40:56 UTC (rev 1202) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-28 13:27:59 UTC (rev 1203) @@ -813,6 +813,33 @@ if !debug_level_tnf > 0 then print_endline ("TNF re of " ^ (real_str re)); tnf_re_fun re + +let rec has_mso = function + | In _ -> true + | Rel _ | Eq _ | RealExpr _ -> false + | Not phi | Ex (_, phi) | All (_, phi) -> has_mso phi + | And flist | Or flist -> List.exists has_mso flist + +let rec has_fo = function + | In _ -> false + | Rel _ | Eq _ | RealExpr _ -> true + | Not phi | Ex (_, phi) | All (_, phi) -> has_fo phi + | And flist | Or flist -> List.exists has_fo flist + +let rec mso_last = function + | Rel _ | Eq _ | In _ | RealExpr _ as phi -> phi + | Not phi -> Not (mso_last phi) + | Ex (vs, phi) -> Ex (vs, mso_last phi) + | All (vs, phi) -> All (vs, mso_last phi) + | And flist -> + let (msos, fos) = List.partition has_mso (List.map mso_last flist) in + let (somefo, nofo) = List.partition has_fo msos in + And (fos @ somefo @ nofo) + | Or flist -> + let (msos, fos) = List.partition has_mso (List.map mso_last flist) in + let (somefo, nofo) = List.partition has_fo msos in + Or (fos @ somefo @ nofo) + let tnf_fv phi = let fv = free_vars phi in let psi = rename_quant_avoiding [] (Ex (fv, phi)) in @@ -833,11 +860,18 @@ let is_pred = function Rel (_, [|_|]) -> true | _ -> false in let (p, np) = List.partition is_pred fl in let res = And (order_by_fv acc_fv (p @ np)) in - if !debug_level > 1 then print_endline ("fvordered: " ^ (str res)); + if !debug_level > 1 then print_endline ("fvordered and: " ^ (str res)); res + | Or fl -> + let is_pred = function Rel (_, [|_|]) -> true | _ -> false in + let (p, np) = List.partition is_pred fl in + let res = Or (order_by_fv acc_fv (p @ np)) in + if !debug_level > 1 then print_endline ("fvordered or: " ^ (str res)); + res | Ex (vs, phi) -> Ex (vs, order_by_fv_phi acc_fv phi) + | All (vs, phi) -> All (vs, order_by_fv_phi acc_fv phi) | f -> f in - match flatten (del_vars_quant fv (tnf psi)) with + match mso_last (flatten (del_vars_quant fv (tnf psi))) with | Or fl -> Or (List.map (order_by_fv_phi []) fl) | f -> f Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-11-28 01:40:56 UTC (rev 1202) +++ trunk/Toss/Solver/Solver.ml 2010-11-28 13:27:59 UTC (rev 1203) @@ -85,6 +85,11 @@ MSO (y, [((Elems.add e Elems.empty, Elems.empty), Any)]) in report (join aset (FO (x, List.map (fun e -> (e, sing_mso e)) (slist elems)))) + | Not (In (x, y)) -> + let sing_non_mso e = + MSO (y, [((Elems.empty, Elems.add e Elems.empty), Any)]) in + report (join aset (FO (x, List.map (fun e -> (e, sing_non_mso e)) + (slist elems)))) | RealExpr (p, s) -> (* TODO: use aset directly as context for speed *) report (join aset (assignment_of_real_expr model elems (p, s))) | Not phi -> @@ -95,9 +100,16 @@ | And fl -> report (List.fold_left (eval model elems) aset fl) | Or [phi] -> report (eval model elems aset phi) | Or fl -> - let asets = List.rev_map (fun f -> eval model elems aset f) fl in - report - (List.fold_left (sum elems) Empty asets) + let step_or (ast, asets) = function + (* | Not psi -> + let nast = eval model elems ast psi in + (nast, report (complement_join elems ast nast) :: asets) + | (In (x, y)) as psi -> + let nast = eval model elems ast (Not psi) in + (nast, report (eval model elems ast psi) :: asets) *) + | psi -> (ast, report (eval model elems ast psi) :: asets) in + let (_, asets) = List.fold_left step_or (aset, []) fl in + report (List.fold_left (sum elems) Empty asets) | Ex ([], phi) | All ([], phi) -> failwith "evaluating empty quantifier" | Ex (vl, phi) -> let aset_vars = AssignmentSet.assigned_vars [] aset in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-28 16:10:48
|
Revision: 1205 http://toss.svn.sourceforge.net/toss/?rev=1205&view=rev Author: lukstafi Date: 2010-11-28 16:10:41 +0000 (Sun, 28 Nov 2010) Log Message: ----------- Printing adjustments. Modified Paths: -------------- trunk/Toss/Arena/ContinuousRule.ml trunk/Toss/Formula/Formula.ml trunk/Toss/Formula/Formula.mli trunk/Toss/Solver/FFSolverTest.ml Modified: trunk/Toss/Arena/ContinuousRule.ml =================================================================== --- trunk/Toss/Arena/ContinuousRule.ml 2010-11-28 15:34:57 UTC (rev 1204) +++ trunk/Toss/Arena/ContinuousRule.ml 2010-11-28 16:10:41 UTC (rev 1205) @@ -202,12 +202,12 @@ Format.fprintf f "@ @[<hv>update@ %a@]" (Term.fprint_eqs ~diff:false) r.update; if r.discrete.DiscreteRule.pre <> Formula.And [] then - Format.fprintf f "@ @[<1>pre@ %a@]" (Formula.fprint_nobra 0) + Format.fprintf f "@ @[<1>pre@ %a@]" Formula.fprint r.discrete.DiscreteRule.pre; if r.inv <> Formula.And [] then - Format.fprintf f "@ @[<1>inv@ %a@]" (Formula.fprint_nobra 0) r.inv; + Format.fprintf f "@ @[<1>inv@ %a@]" Formula.fprint r.inv; if r.post <> Formula.And [] then - Format.fprintf f "@ @[<1>post@ %a@]" (Formula.fprint_nobra 0) r.post; + Format.fprintf f "@ @[<1>post@ %a@]" Formula.fprint r.post; Format.fprintf f "@]" let print r = fprint Format.std_formatter r Modified: trunk/Toss/Formula/Formula.ml =================================================================== --- trunk/Toss/Formula/Formula.ml 2010-11-28 15:34:57 UTC (rev 1204) +++ trunk/Toss/Formula/Formula.ml 2010-11-28 16:10:41 UTC (rev 1205) @@ -163,104 +163,65 @@ -let rec fprint_formula f = function - Rel (s, vars) -> Format.fprintf f "%s(%a)" s fprint_var_tup vars - | Eq (x, y) -> Format.fprintf f "(%s = %s)" (var_str x) (var_str y) - | In (x, y) -> Format.fprintf f "(%s in %s)" (var_str x) (var_str y) - | RealExpr (p, s) -> - Format.fprintf f "@[(%a %s)@]" fprint_real p (sign_op_str s) - | Not phi -> Format.fprintf f "@[(not %a)@]" fprint_formula phi - | And [] -> Format.fprintf f "true" - | Or [] -> Format.fprintf f "false" - | And (flist) -> fprint_f_list " and " f flist - | Or (flist) -> fprint_f_list " or " f flist - | Ex (x, phi) -> - Format.fprintf f "ex %a@ @[<1>(%a)@]" fprint_var_list x fprint_formula phi - | All (x, phi) -> - Format.fprintf f "all %a@ @[<1>(%a)@]" fprint_var_list x fprint_formula phi - -and fprint_f_list sep f = function - [] -> Format.fprintf f "[]" - | [phi] -> fprint_formula f phi - | lst -> - let rec fprlst fm = function - [] -> () - | [x] -> Format.fprintf fm "%a" fprint_formula x - | x :: xs -> - Format.fprintf fm "%a@ %s@ %a" fprint_formula x sep fprlst xs in - Format.fprintf f "@[<1>(%a)@]" fprlst lst - -and fprint_real f = function - RVar s -> Format.fprintf f "%s" s - | Const fl -> Format.fprintf f "%F" fl - | Times (r1, r2) -> - Format.fprintf f "@[(%a@ *@ %a)@]" fprint_real r1 fprint_real r2 - | Plus (r1, r2) -> - Format.fprintf f "@[(%a@ +@ %a)@]" fprint_real r1 fprint_real r2 - | Fun (s, v) -> Format.fprintf f ":%s(%s)" s (var_str v) - | Char phi -> Format.fprintf f "@[<1>:(%a)@]" fprint_formula phi - | Sum (vl, phi, r) -> - Format.fprintf f "@[<1>Sum (%s | %a : %a)@]" - (var_list_str vl) fprint_formula phi fprint_real r - let fprint_var f v = Format.pp_print_string f (var_str v) -(* Bracket-savvy precedences: 0 or, 1 and, 2 not ex all *) -let rec fprint_nobra prec f = function +(* Bracket-savvy encodings: 0 or, 1 and, 2 not ex all *) +let rec fprint_prec prec f = function Rel (s, vars) -> Format.fprintf f "%s(%a)" s (Aux.fprint_sep_list "," fprint_var) (Array.to_list vars) | Eq (x, y) -> Format.fprintf f "%s = %s" (var_str x) (var_str y) | In (x, y) -> Format.fprintf f "%s in %s" (var_str x) (var_str y) | RealExpr (p, s) -> - Format.fprintf f "@[(%a %s)@]" (fprint_real_nobra 0) p (sign_op_str s) + Format.fprintf f "@[(%a %s)@]" (fprint_real_prec 0) p (sign_op_str s) | Not phi -> let lb, rb = if prec > 2 then "(", ")" else "", "" in - Format.fprintf f "@[<1>%snot@ %a%s@]" lb (fprint_nobra 2) phi rb + Format.fprintf f "@[<1>%snot@ %a%s@]" lb (fprint_prec 2) phi rb | And [] -> Format.fprintf f "true" | Or [] -> Format.fprintf f "false" - | And [phi] -> fprint_nobra prec f phi - | Or [phi] -> fprint_nobra prec f phi + | And [phi] -> fprint_prec prec f phi + | Or [phi] -> fprint_prec prec f phi | And flist -> - let lb, rb = if prec > 1 then "(", ")" else "", "" in + let lb, rb = if prec = 0 || prec > 1 then "(", ")" else "", "" in Format.fprintf f "@[<1>%s%a%s@]" lb - (Aux.fprint_sep_list " and" (fprint_nobra 1)) flist rb + (Aux.fprint_sep_list " and" (fprint_prec 1)) flist rb | Or flist -> let lb, rb = if prec > 0 then "(", ")" else "", "" in Format.fprintf f "@[<1>%s%a%s@]" lb - (Aux.fprint_sep_list " or" (fprint_nobra 0)) flist rb + (Aux.fprint_sep_list " or" (fprint_prec 0)) flist rb | Ex (x, phi) -> let lb, rb = if prec > 2 then "(", ")" else "", "" in Format.fprintf f "@[<1>%sex@ %a@ %a%s@]" lb - (Aux.fprint_sep_list "," fprint_var) x (fprint_nobra 2) phi rb + (Aux.fprint_sep_list "," fprint_var) x (fprint_prec 2) phi rb | All (x, phi) -> let lb, rb = if prec > 2 then "(", ")" else "", "" in Format.fprintf f "@[<1>%sall@ %a@ %a%s@]" lb - (Aux.fprint_sep_list "," fprint_var) x (fprint_nobra 2) phi rb + (Aux.fprint_sep_list "," fprint_var) x (fprint_prec 2) phi rb (* Bracket-savvy precedences: 0 +, 2 * *) -and fprint_real_nobra prec f = function +and fprint_real_prec prec f = function RVar s -> Format.fprintf f "%s" s | Const fl -> Format.fprintf f "%F" fl | Times (r1, r2) -> let lb, rb = if prec > 2 then "(", ")" else "", "" in Format.fprintf f "@[<1>%s%a@ *@ %a%s@]" lb - (fprint_real_nobra 2) r1 (fprint_real_nobra 2) r2 rb + (fprint_real_prec 2) r1 (fprint_real_prec 2) r2 rb | Plus (r1, r2) -> let lb, rb = if prec > 0 then "(", ")" else "", "" in Format.fprintf f "@[<1>%s%a@ +@ %a%s@]" lb - (fprint_real_nobra 0) r1 (fprint_real_nobra 0) r2 rb + (fprint_real_prec 0) r1 (fprint_real_prec 0) r2 rb | Fun (s, v) -> Format.fprintf f ":%s(%s)" s (var_str v) - | Char phi -> Format.fprintf f "@[<1>:(@,%a@,)@]" (fprint_nobra 0) phi + | Char phi -> Format.fprintf f "@[<1>:(@,%a@,)@]" (fprint_prec 0) phi | Sum (vl, phi, r) -> Format.fprintf f "@[<1>Sum@ (@,%a@ |@ %a@ :@ %a@,)@]" - (Aux.fprint_sep_list "," fprint_var) vl (fprint_nobra 0) phi - (fprint_real_nobra 0) r + (Aux.fprint_sep_list "," fprint_var) vl (fprint_prec 0) phi + (fprint_real_prec 0) r -let fprint f phi = Format.fprintf f "@[%a@]" fprint_formula phi +let fprint f phi = fprint_prec 0 f phi +let fprint_real f phi = fprint_real_prec 0 f phi let print phi = fprint Format.std_formatter phi let sprint phi = ignore (Format.flush_str_formatter ()); Modified: trunk/Toss/Formula/Formula.mli =================================================================== --- trunk/Toss/Formula/Formula.mli 2010-11-28 15:34:57 UTC (rev 1204) +++ trunk/Toss/Formula/Formula.mli 2010-11-28 16:10:41 UTC (rev 1205) @@ -90,8 +90,8 @@ val sprint_real : real_expr -> string val fprint_real : Format.formatter -> real_expr -> unit -val fprint_nobra : int -> Format.formatter -> formula -> unit -val fprint_real_nobra : int -> Format.formatter -> real_expr -> unit +val fprint_prec : int -> Format.formatter -> formula -> unit +val fprint_real_prec : int -> Format.formatter -> real_expr -> unit (* --------------- BASIC HELPER FUNCTIONS USED IN PARSER ------------------- *) Modified: trunk/Toss/Solver/FFSolverTest.ml =================================================================== --- trunk/Toss/Solver/FFSolverTest.ml 2010-11-28 15:34:57 UTC (rev 1204) +++ trunk/Toss/Solver/FFSolverTest.ml 2010-11-28 16:10:41 UTC (rev 1205) @@ -284,7 +284,7 @@ let heur_phi = formula_of_str "(((R(x, y) and R(y, z)) or (C(x, y) and C(y, z)) or ex u, v ((C(z, u) and C(y, v) and R(y, u) and R(x, v))) or ex u, v ((R(y, u) and R(x, v) and C(v, y) and C(u, z)))) and (P(z) or P(y) or P(x)) and (not Q(x)) and (not Q(y)) and (not Q(z))) and (not 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)))))))" in - Printf.printf "heur_phi=%s\n%!"(Formula.str heur_phi); + (* Printf.printf "heur_phi=%s\n%!"(Formula.str heur_phi); *) let ttt = struc_of_str "[ | P:1 { }; Q:1 { } | ] \" @@ -294,7 +294,7 @@ . . . \"" in - FFTNF.debug_level := 3; + (* FFTNF.debug_level := 3; *) assert_equal ~printer:(fun x->x) "" (Formula.str (FFSolver.normalize_for_model @@ -339,7 +339,7 @@ ... ... ... ... ... ... ... ... \"" in - FFTNF.debug_level := 3; + (* FFTNF.debug_level := 3; *) assert_equal ~printer:(fun x->x) "" (Formula.str (FFSolver.normalize_for_model This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-28 17:05:50
|
Revision: 1206 http://toss.svn.sourceforge.net/toss/?rev=1206&view=rev Author: lukaszkaiser Date: 2010-11-28 17:05:43 +0000 (Sun, 28 Nov 2010) Log Message: ----------- Corrections to mso solving and variable ordering. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Solver/Assignments.ml trunk/Toss/Solver/SolverTest.ml Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-28 16:10:41 UTC (rev 1205) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-28 17:05:43 UTC (rev 1206) @@ -840,40 +840,46 @@ let (somefo, nofo) = List.partition has_fo msos in Or (fos @ somefo @ nofo) +let free_vars_fo f = + let is_fo = function `FO _ -> true | _ -> false in + List.filter is_fo (free_vars f) + +let rec order_by_fv acc_fv = function + | [] -> [] + | [f] -> [order_by_fv_phi acc_fv f] + | l -> + let cross x = List.exists (fun v -> List.mem v acc_fv) (free_vars x) in + let (cf, o) = List.partition cross l in + if cf = [] then + let new_fv = free_vars (List.hd l) in + order_by_fv new_fv l + else + let new_fv = acc_fv @ (free_vars_fo (And cf)) in + (List.map (order_by_fv_phi acc_fv) cf) @ (order_by_fv new_fv o) + +and order_by_fv_phi acc_fv = function + | And fl -> + let is_pred = function Rel (_, [|_|]) -> true | _ -> false in + let (p, np) = List.partition is_pred fl in + let res = And (order_by_fv acc_fv (p @ np)) in + if !debug_level > 0 then print_endline ("fvordered and: " ^ (str res)); + res + | Or fl -> + let is_pred = function Rel (_, [|_|]) -> true | _ -> false in + let (p, np) = List.partition is_pred fl in + let res = Or (order_by_fv acc_fv (p @ np)) in + if !debug_level > 0 then print_endline ("fvordered or: " ^ (str res)); + res + | Ex (vs, phi) -> Ex (vs, order_by_fv_phi acc_fv phi) + | All (vs, phi) -> All (vs, order_by_fv_phi acc_fv phi) + | f -> f + let tnf_fv phi = let fv = free_vars phi in let psi = rename_quant_avoiding [] (Ex (fv, phi)) in - let rec order_by_fv acc_fv = function - | [] -> [] - | [f] -> [f] - | l -> - let cross x = List.exists (fun v -> List.mem v acc_fv) (free_vars x) in - let (cf, o) = List.partition cross l in - if cf = [] then - let new_fv = free_vars (List.hd l) in - order_by_fv new_fv (List.map (order_by_fv_phi new_fv) l) - else - let new_fv = acc_fv @ (free_vars (And cf)) in - cf @ (order_by_fv new_fv (List.map (order_by_fv_phi new_fv) o)) - and order_by_fv_phi acc_fv = function - | And fl -> - let is_pred = function Rel (_, [|_|]) -> true | _ -> false in - let (p, np) = List.partition is_pred fl in - let res = And (order_by_fv acc_fv (p @ np)) in - if !debug_level > 1 then print_endline ("fvordered and: " ^ (str res)); - res - | Or fl -> - let is_pred = function Rel (_, [|_|]) -> true | _ -> false in - let (p, np) = List.partition is_pred fl in - let res = Or (order_by_fv acc_fv (p @ np)) in - if !debug_level > 1 then print_endline ("fvordered or: " ^ (str res)); - res - | Ex (vs, phi) -> Ex (vs, order_by_fv_phi acc_fv phi) - | All (vs, phi) -> All (vs, order_by_fv_phi acc_fv phi) - | f -> f in match mso_last (flatten (del_vars_quant fv (tnf psi))) with | Or fl -> Or (List.map (order_by_fv_phi []) fl) - | f -> f + | f -> order_by_fv_phi [] f (* Assign emptyset to the MSO-variable v by replacing "x in X" with "false". *) let assign_emptyset v phi = Modified: trunk/Toss/Solver/Assignments.ml =================================================================== --- trunk/Toss/Solver/Assignments.ml 2010-11-28 16:10:41 UTC (rev 1205) +++ trunk/Toss/Solver/Assignments.ml 2010-11-28 17:05:43 UTC (rev 1206) @@ -297,6 +297,13 @@ let ndisj = List.rev_map (fun l -> List.rev_map neg_sign l) poly_disj in List.filter RealQuantElim.sat (Aux.product ndisj) +let convert dnf = (* Sat.convert cnf *) + let bv v = BoolFormula.BVar v in + let bool_dnf = BoolFormula.BOr + (List.map (fun lits -> BoolFormula.BAnd (List.map bv lits)) dnf) in + let conv = BoolFormula.convert bool_dnf in + conv + (* Project assignments on a given universal variable. We assume that [elems] are all elements and are sorted. Corresponds to the for-all v quantifier. *) let rec universal elems v = function @@ -324,7 +331,7 @@ let (assgs, _) = List.partition (fun x-> x > max_elem) conj in List.fold_left (fun s i -> sum elems s disj_arr.(i - max_elem - 1)) Empty assgs in - let dnf = Sat.convert cnf in + let dnf = convert cnf in List.fold_left (fun s c -> join s (assgn_of_conj c)) Any dnf | Real poly_disj -> let neg_disj = negate_real_disj poly_disj in @@ -395,7 +402,7 @@ let assgn = List.fold_left appd Any con_assgs in if assgn = Empty then cur_list else ((pos, neg), assgn) :: cur_list in - let dnf = Sat.convert cnf in + let dnf = convert cnf in List.fold_left add_assgn_of_conj [] dnf Modified: trunk/Toss/Solver/SolverTest.ml =================================================================== --- trunk/Toss/Solver/SolverTest.ml 2010-11-28 16:10:41 UTC (rev 1205) +++ trunk/Toss/Solver/SolverTest.ml 2010-11-28 17:05:43 UTC (rev 1206) @@ -135,6 +135,16 @@ "eval: bigger tc tests" >:: (fun () -> + let diag_phi = + "set d1(x, y) = ex z ((R(x, z) and C(z, y)) or (R(y, z) and C(z, x))) in + set d2(x, y) = ex z ((R(x, z) and C(y, z)) or (R(y, z) and C(x, z))) in + set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in + set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in + set fd1(x, y) = tc x,y (d1(x, y) and not w(y) and not b(y)) in + set fd2(x, y) = tc x,y (d2(x, y) and not w(y) and not b(y)) in + set Diag1 (x, y) = ex z (fd1 (x, z) and (z = y or d1 (z, y))) in + set Diag2 (x, y) = ex z (fd2 (x, z) and (z = y or d2 (z, y))) in + wB(x) and (Diag1 (x, y) or Diag2 (x, y))" in eval_eq "[ | | ] \" ... ... ... ... @@ -144,16 +154,24 @@ ... ... ... ... ... wB. -\"" "set d1(x, y) = ex z ((R(x, z) and C(z, y)) or (R(y, z) and C(z, x))) in - set d2(x, y) = ex z ((R(x, z) and C(y, z)) or (R(y, z) and C(x, z))) in - set w(x) = wP(x) or wR(x) or wN(x) or wB(x) or wQ(x) or wK(x) in - set b(x) = bP(x) or bR(x) or bN(x) or bB(x) or bQ(x) or bK(x) in - set fd1(x, y) = tc x,y (d1(x, y) and not w(y) and not b(y)) in - set fd2(x, y) = tc x,y (d2(x, y) and not w(y) and not b(y)) in - set Diag1 (x, y) = ex z (fd1 (x, z) and (z = y or d1 (z, y))) in - set Diag2 (x, y) = ex z (fd2 (x, z) and (z = y or d2 (z, y))) in - wB(x) and (Diag1 (x, y) or Diag2 (x, y))" +\"" diag_phi "{ y->3{ x->3 } , y->6{ x->3 } , y->8{ x->3 } , y->9{ x->3 } }"; + eval_eq "[ | | ] \" + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... ... ... + ... wB. ... +\"" diag_phi + ("{ y->3{ x->3 } , y->8{ x->3 } , y->10{ x->3 } ," ^ + " y->13{ x->3 } , y->17{ x->3 } , y->24{ x->3 } }"); ); "eval: with real values" >:: This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-28 15:35:05
|
Revision: 1204 http://toss.svn.sourceforge.net/toss/?rev=1204&view=rev Author: lukstafi Date: 2010-11-28 15:34:57 +0000 (Sun, 28 Nov 2010) Log Message: ----------- FFSolver rewrite: disjunctions. FFSolver-FFTNF interface: free variables fixes. FFTNF: Proper subtask handling (a subtask is a ground universally quantified subformula). Tests: executable checking moved to Aux. Solver: exposing more capabilities. Heuristic: abstracting over solver when possible. Modified Paths: -------------- trunk/Toss/Arena/ArenaTest.ml trunk/Toss/Arena/ContinuousRuleTest.ml trunk/Toss/Arena/DiscreteRuleTest.ml trunk/Toss/Arena/TermTest.ml trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/Formula/AuxTest.ml trunk/Toss/Formula/FFTNF.ml trunk/Toss/Formula/FFTNFTest.ml trunk/Toss/Formula/Formula.ml trunk/Toss/Formula/FormulaOpsTest.ml trunk/Toss/Formula/FormulaTest.ml trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Heuristic.ml trunk/Toss/Play/HeuristicTest.ml trunk/Toss/Play/Makefile trunk/Toss/Solver/AssignmentSet.ml trunk/Toss/Solver/AssignmentSet.mli trunk/Toss/Solver/FFSolver.ml trunk/Toss/Solver/FFSolver.mli trunk/Toss/Solver/FFSolverTest.ml trunk/Toss/Solver/Solver.ml trunk/Toss/Solver/Solver.mli trunk/Toss/Solver/SolverIntf.ml trunk/Toss/Solver/SolverIntf.mli trunk/Toss/Solver/SolverTest.ml trunk/Toss/Solver/StructureTest.ml trunk/Toss/TossTest.ml Modified: trunk/Toss/Arena/ArenaTest.ml =================================================================== --- trunk/Toss/Arena/ArenaTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Arena/ArenaTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -159,28 +159,4 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "ArenaTest" then - ignore (run_test_tt ~verbose:true tests) - -let a () = - - - let fname = "../examples/Gomoku19x19.toss" in - let file = open_in fname in - let contents = String.make 10000 '$' in - let _ = input_file file contents 0 10000 in - let contents = - String.sub contents 0 (String.index contents '$') in - let s = "SET STATE #" ^ fname ^ "#" ^ contents in - let (gs,_) = Arena.handle_request Arena.empty_state (req_of_str s) in - let (_, msg) = - Arena.handle_request gs (req_of_str "GET STATE") in - assert_equal ~msg:"Set Gomoku19x19.toss" ~printer:(fun x->x) - contents msg; + Aux.run_test_if_target "ArenaTest" tests Modified: trunk/Toss/Arena/ContinuousRuleTest.ml =================================================================== --- trunk/Toss/Arena/ContinuousRuleTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Arena/ContinuousRuleTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -131,12 +131,4 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "ContinuousRuleTest" then - ignore (run_test_tt ~verbose:true tests) + Aux.run_test_if_target "ContinuousRuleTest" tests Modified: trunk/Toss/Arena/DiscreteRuleTest.ml =================================================================== --- trunk/Toss/Arena/DiscreteRuleTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Arena/DiscreteRuleTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -636,15 +636,7 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "DiscreteRuleTest" then - ignore (run_test_tt ~verbose:true tests) + Aux.run_test_if_target "DiscreteRuleTest" tests let a () = match (test_filter ["DiscreteRule:11:rewrite: compile_rule adding and deleting elements"] tests) with Modified: trunk/Toss/Arena/TermTest.ml =================================================================== --- trunk/Toss/Arena/TermTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Arena/TermTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -68,12 +68,4 @@ ];; let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "TermTest" then - ignore (run_test_tt ~verbose:true tests) + Aux.run_test_if_target "TermTest" tests Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/Aux.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -69,6 +69,14 @@ else aux (pair :: acc) l in aux [] l +let pop_assq x l = + let rec aux acc = function + | [] -> raise Not_found + | (a, b as pair) :: l -> + if a == x then b, List.rev_append acc l + else aux (pair :: acc) l in + aux [] l + let unsome = function | Some v -> v | None -> raise (Invalid_argument "unsome") @@ -260,6 +268,10 @@ | Right e -> split laux (e::raux) tl in split [] [] l +let map_choice f g = function + | Left e -> Left (f e) + | Right e -> Right (g e) + let transpose_lists lls = let rec aux acc = function | [] -> List.map List.rev acc @@ -346,3 +358,14 @@ 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 file_from_path p = + String.sub p (String.rindex p '/'+1) + (String.length p - String.rindex p '/' - 1) in + let test_fname = + 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 + (* So that the tests are not run twice while building TossTest. *) + if test_fname then + ignore (OUnit.run_test_tt ~verbose:true tests) Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/Aux.mli 2010-11-28 15:34:57 UTC (rev 1204) @@ -41,9 +41,12 @@ val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list (** Find the value associated with the first occurrence of the key and - remove them from the list. *) + remove them from the list. Uses structural equality. *) val pop_assoc : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list +(** As {!Aux.pop_assoc}, but uses physical equality. *) +val pop_assq : 'a -> ('a * 'b) list -> 'b * ('a * 'b) list + (** unConstructors. *) val unsome : 'a option -> 'a @@ -134,6 +137,9 @@ also {!partition_choice}). *) val partition_map : ('a -> ('b, 'c) choice) -> 'a list -> 'b list * 'c list +val map_choice : + ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) choice -> ('b, 'd) choice + (** Transpose a rectangular matrix represented by lists. Raises [Invalid_argument "List.map2"] when matrix is not rectangular. *) val transpose_lists : 'a list list -> 'a list list @@ -169,3 +175,5 @@ string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> 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/AuxTest.ml =================================================================== --- trunk/Toss/Formula/AuxTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/AuxTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -63,7 +63,7 @@ ); - "replace_assoc, pop_assoc" >:: + "replace_assoc, pop_assoc, pop_assq" >:: (fun () -> assert_equal ~printer:(print_alist (fun x -> x)) ["B","f";"C","B"; "G","replaced"; "G", "T"] @@ -85,6 +85,18 @@ Not_found (fun () -> Aux.pop_assoc "G" ["B","f";"C","B"; "F","Ts"]); + + let g = "G" in + assert_equal + ~printer:(fun (x,y) -> x^" -- "^print_alist (fun e->e) y) + ("T", ["B","f";"G", "T0";"C","B"; g, "T2"]) + (Aux.pop_assq g + ["B","f";"G", "T0"; "C","B"; g,"T"; g, "T2"]); + + assert_raises ~msg:"should not find" + Not_found + (fun () -> Aux.pop_assq g + ["B","f";"G", "T0"; "C","B"; "F","Ts"]); ); "unsome, map_try" >:: @@ -390,12 +402,4 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "AuxTest" then - ignore (run_test_tt ~verbose:true tests) + Aux.run_test_if_target "AuxTest" tests Modified: trunk/Toss/Formula/FFTNF.ml =================================================================== --- trunk/Toss/Formula/FFTNF.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/FFTNF.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -6,9 +6,13 @@ {3 Algorithm for calculating FFTNF(_<_):} - 1: Reduce to negation-normal prenex-normal form with - existential-first minimized alternation; collapse nonalternating - quantifiers into quantifying over sets of variables. + 1: Reduce to partially negation-normal prenex-normal form with + existential-first minimized alternation -- do not push negation + inside an existentially quantified ground subformula; collapse + nonalternating quantifiers into quantifying over sets of + variables. We call a negated existentially quantified ground + subformula -- or equivalently a universally quantified ground + subformula -- a subtask. 2: Collapse conjunctions and disjunctions using associativity. @@ -16,8 +20,9 @@ built during the breadth-first search for unprocessed literal and is then zipped by pulling-out the selected literal. - The whole term is searched breadth-first for best literal to - pull-out. The first best literal is selected. + The whole term is searched breadth-first for a subtask or the best + literal to pull-out. A subtask is preferred, otherwise the first + best literal is selected. A literal that has all variables quantified in the scope of some variable of another literal is worse than the other literal. If @@ -26,18 +31,18 @@ than b -- should be pulled out earlier. "a _<_ b" returns false if it is indifferent whether a or b should be first. - The literal to be pulled out is replaced by T = And[], forming the - initial location (context[],[T]). + The subtask or literal to be pulled out is replaced by T = And[], + forming the initial location (context[],[T]). Note: the literal is treated as "conjoined", as opposed to "disjoined", to the surroundings, because disjunctions of literals are much rarer than conjunctions. - 4: When a literal is placed in its final location it is marked as - processed. Denote by Qn, Qn', etc., a quantifier over a set of - variables, and by -Qn a quantifier that is complementary to Qn - (i.e. -ex vs.Phi = all vs.Phi). The result of pulling out a literal - L of a location (context[],[fill-loc]) (denoted also as + 4: When a subtask/literal is placed in its final location it is + marked as processed. Denote by Qn, Qn', etc., a quantifier over a + set of variables, and by -Qn a quantifier that is complementary to + Qn (i.e. -ex vs.Phi = all vs.Phi). The result of pulling out a + literal L of a location (context[],[fill-loc]) (denoted also as context[][fill-loc]) by cases on context[]: (a) context'[Qn.[]] where Qn = Qn' union Qn'' for Qn' @@ -95,6 +100,10 @@ (f3) context'[(([] \/ D) /\ C) \/ E] (when the nearest q. is universal): pull-out(context'[([] \/ D \/ E) /\ (C \/ E)], [fill-loc]) + The same rules are applied for subtasks, where we take + Var(subtask)=empty, and a subtask is protected only when not in + scope of any quantifier. + 5: since the literals in conjunctions have been scrambled by the zipping process, they are sorted into the order in which they have been processed. @@ -177,47 +186,49 @@ | Ex (x, phi) when neg -> All (x, nnf ~neg:true phi) | Ex (x, phi) -> Ex (x, nnf ~neg:false phi) | All (x, phi) when neg -> Ex (x, nnf ~neg:true phi) + | All (x, phi) as sbt when not neg && FormulaOps.free_vars sbt = [] + -> Not (pn_nnf (Ex (x, nnf ~neg:true phi))) | All (x, phi) -> All (x, nnf ~neg:false phi) and pn_nnf phi = let rec pnf ex vars sb = function - | (Rel _ - | Eq _ - | In _ - | RealExpr _) as psi -> - [], vars, FormulaOps.subst_vars sb psi - | Not (Ex _) as phi -> [], vars, phi + | (Rel _ + | Eq _ + | In _ + | RealExpr _) as psi -> + [], vars, FormulaOps.subst_vars sb psi + | Not (Ex _) as phi -> [], vars, phi (* already processed recursively *) - | Not psi as phi -> (* already reduced to NNF *) - [], vars, FormulaOps.subst_vars sb phi - | And conjs -> - let (prefs, vars, conjs) = - List.fold_right (fun conj (prefs, vars, conjs) -> - let (pref, vars, conj) = pnf ex vars sb conj in - (pref::prefs, vars, conj::conjs)) - conjs ([], vars, []) in - let pref = merge ex [] prefs in - pref, vars, And conjs - | Or disjs -> - let (prefs, vars, disjs) = - List.fold_right (fun disj (prefs, vars, disjs) -> - let (pref, vars, disj) = pnf ex vars sb disj in - (pref::prefs, vars, disj::disjs)) - disjs ([], vars, []) in - let pref = merge ex [] prefs in - pref, vars, Or disjs - | Ex (xs, psi) -> - let vs = List.map Formula.var_str xs in - let vs, sb = update_sb vs vars sb in - let pref, vars, psi = - pnf true (add_strings vs vars) sb psi in - (Left (pack_vs xs vs))::pref, vars, psi - | All (xs, psi) -> - let vs = List.map Formula.var_str xs in - let vs, sb = update_sb vs vars sb in - let pref, vars, psi = - pnf false (add_strings vs vars) sb psi in - (Right (pack_vs xs vs))::pref, vars, psi in + | Not psi as phi -> (* already reduced to NNF *) + [], vars, FormulaOps.subst_vars sb phi + | And conjs -> + let (prefs, vars, conjs) = + List.fold_right (fun conj (prefs, vars, conjs) -> + let (pref, vars, conj) = pnf ex vars sb conj in + (pref::prefs, vars, conj::conjs)) + conjs ([], vars, []) in + let pref = merge ex [] prefs in + pref, vars, And conjs + | Or disjs -> + let (prefs, vars, disjs) = + List.fold_right (fun disj (prefs, vars, disjs) -> + let (pref, vars, disj) = pnf ex vars sb disj in + (pref::prefs, vars, disj::disjs)) + disjs ([], vars, []) in + let pref = merge ex [] prefs in + pref, vars, Or disjs + | Ex (xs, psi) -> + let vs = List.map Formula.var_str xs in + let vs, sb = update_sb vs vars sb in + let pref, vars, psi = + pnf true (add_strings vs vars) sb psi in + (Left (pack_vs xs vs))::pref, vars, psi + | All (xs, psi) -> + let vs = List.map Formula.var_str xs in + let vs, sb = update_sb vs vars sb in + let pref, vars, psi = + pnf false (add_strings vs vars) sb psi in + (Right (pack_vs xs vs))::pref, vars, psi in let pref, _, phi = pnf true Strings.empty [] (nnf phi) in List.fold_right (fun q phi -> match q with @@ -435,7 +446,7 @@ fvs=Vars.empty; t=TProc (-1,Rel("[HOLE]",[||]))}})))) (Formula.str (unpack_flat (formula_of_tree loc.n))) -(* Pull out "subtasks", flatten and convert to a formula. *) +(* Flatten and convert to a formula. *) (* While translating, also simplify constant truth values. *) exception Simpl_true exception Simpl_false @@ -470,7 +481,7 @@ let subts_proc, subts = Aux.partition_map (function | {t=TProc (i,_)} as lit -> Left (i,lit) - | {t=TLit _} -> failwith "unprocessed[1]" + | {t=TLit _} -> assert false | subt->Right subt) subts in let subts_proc = List.map snd @@ -607,9 +618,9 @@ (* Safer than using the generic [Not_found] exception. *) exception Lit_not_found -(* Return the minimal-depth best literal and its location but with the - literal removed. Best literal: there is no literal with older - oldest variable, and is smallest wrt. [cmp_lits] among +(* Return the minimal-depth subtask or best literal and its location + but with the subtask/literal removed. Best literal: there is no literal + with older oldest variable, and is smallest wrt. [cmp_lits] among such. Remember to mark protected literals before. *) let rec find_unprot cmp_lits best_loc bfstack loc = @@ -637,12 +648,14 @@ match bfstack with | [] -> (match best_loc with - | Some best_loc -> best_loc + | Some (best,loc) -> Right best, loc | None -> raise Lit_not_found) | next::tl_stack -> find_unprot cmp_lits best_loc tl_stack next in (* check location *) match loc.n with + | {t=TNot_subtask subt} -> + Left subt, {loc with n={fvs=Vars.empty; t=TAnd[]}} | {fvs=lit_vs; t=TLit lit} -> let _ = if !debug_level > 3 then printf "find_unprot: processing literal, loc %s\n" @@ -684,12 +697,20 @@ | AllNode (_, vs) | ExNode (_, vs) -> vs | AndNode (ctx', _) | OrNode (ctx', _) -> scope_vars ctx' -let rec pull_out (lit_id, lit, lit_vs as litv) loc = +(* The rewriting steps. Uses a callback to process subtasks + recursively before putting them in their final locations. *) +let rec pull_out subproc (task_id, task_lit as task) loc = let _ = if !debug_level > 2 then printf "\npull-out_step_location: %s\n" (location_str loc) in - let tlit = {fvs=lit_vs; t=TProc (lit_id, lit)} in + let lit_vs, put_result = + match task_lit with + | Left subt -> + Vars.empty, + lazy {fvs=Vars.empty; t=TProc (task_id, subproc subt)} + | Right (lit, lit_vs) -> + lit_vs, lazy {fvs=lit_vs; t=TProc (task_id, lit)} in match loc.x with - | Top -> conj_flat (tlit, loc.n) + | Top -> conj_flat (Lazy.force put_result, loc.n) (* a *) | AllNode (ctx', vs) @@ -699,18 +720,18 @@ (* a1 *) if Vars.is_empty vs' then let _ = if !debug_level > 2 then printf "a1\n" in - pull_out litv {x=ctx'; n=qT loc.x (vs,loc.n)} + pull_out subproc task {x=ctx'; n=qT loc.x (vs,loc.n)} (* a2 *) else let _ = if !debug_level > 2 then printf "a2\n" in zip {x=ctx'; n=qT loc.x (vs', conj_flat ( - tlit, qT loc.x (vs'', loc.n)))} + Lazy.force put_result, qT loc.x (vs'', loc.n)))} (* b *) | AndNode (ctx', subts) -> let _ = if !debug_level > 2 then printf "b\n" in - pull_out litv + pull_out subproc task {x=ctx'; n=zip {loc with x=AndNode (Top, subts)}} (* c *) @@ -731,7 +752,7 @@ (* c1 *) if Vars.is_empty vs3 then let _ = if !debug_level > 2 then printf "c1\n" in - pull_out litv + pull_out subproc task {loc with x= qNode qN ( orNode_flat (ctx', [qT qN (vs4, disj)]), vs2)} @@ -743,21 +764,22 @@ let _ = if !debug_level > 2 then printf "c2\n" in let subt = disj_flat ( - qT qN (vs1_3, conj_flat (tlit, qT qN (vs5, loc.n))), + qT qN (vs1_3, conj_flat + (Lazy.force put_result, qT qN (vs5, loc.n))), qT qN (vs4, disj)) in zip {x=ctx'; n=qT qN (vs3, subt)} (* c3 *) else if match qN with ExNode _ -> true | _ -> false then let _ = if !debug_level > 2 then printf "c3\n" in - pull_out litv + pull_out subproc task {x=orNode_flat (ctx', [qT qN (vsD, disj)]); n= qT qN (vs0, loc.n)} (* c4 *) else let _ = if !debug_level > 2 then printf "c4\n" in - pull_out litv + pull_out subproc task {x= orNode_flat ( (* no need for andNode_flat here *) @@ -790,7 +812,7 @@ (* d1 *) if Vars.is_empty vs3 then let _ = if !debug_level > 2 then printf "d1\n" in - pull_out litv + pull_out subproc task {loc with x= orNode_flat ( qNode qN (andNode_flat ( ctx', qT qN (vs4, conj)), vs2), @@ -799,7 +821,7 @@ (* d2 *) else if match qN with AllNode _ -> true | _ -> false then let _ = if !debug_level > 2 then printf "d2\n" in - pull_out litv + pull_out subproc task {loc with x= orNode_flat ( qNode qN (andNode_flat (ctx', qT qN (vsC, conj)), vsFLD) , or_subts)} @@ -809,7 +831,7 @@ let vs5 = Vars.union vsD vsC in let vs6 = Vars.union vsFL vsC in let _ = if !debug_level > 2 then printf "d3\n" in - pull_out litv + pull_out subproc task {loc with x= andNode_flat ( qNode qN ( orNode_flat( @@ -822,21 +844,21 @@ (* e *) | OrNode (Top, _) -> let _ = if !debug_level > 2 then printf "e\n" in - zip {loc with n=conj_flat (tlit, loc.n)} + zip {loc with n=conj_flat (Lazy.force put_result, loc.n)} | OrNode (ctx',_) when not (quant_in_scope ctx') -> let _ = if !debug_level > 2 then printf "e\n" in - zip {loc with n=conj_flat (tlit, loc.n)} + zip {loc with n=conj_flat (Lazy.force put_result, loc.n)} (* f1 *) | OrNode (AndNode (Top, _), _) -> let _ = if !debug_level > 2 then printf "f1\n" in zip {loc with n= - conj_flat ({fvs=lit_vs; t=TProc (lit_id,lit)}, loc.n)} + conj_flat (Lazy.force put_result, loc.n)} | OrNode (AndNode (ctx', _), _) when Vars.subset (scope_vars ctx') lit_vs -> let _ = if !debug_level > 2 then printf "f1\n" in zip {loc with n= - conj_flat ({fvs=lit_vs; t=TProc (lit_id,lit)}, loc.n)} + conj_flat (Lazy.force put_result, loc.n)} (* f2 *) (* same as (d) of FFSEP *) | OrNode (AndNode (ctx', conjs), disjs) @@ -846,7 +868,7 @@ {fvs=Vars.empty; t=TOr []} in let c = List.fold_right (fun a b->conj_flat (a,b)) conjs {fvs=Vars.empty; t=TAnd []} in - pull_out litv + pull_out subproc task {loc with x= andNode_flat ( orNode_flat (ctx', [conj_flat (d,c)]), c)} @@ -857,7 +879,7 @@ {fvs=Vars.empty; t=TOr []} in let c = List.fold_right (fun a b->conj_flat (a,b)) conjs {fvs=Vars.empty; t=TAnd []} in - pull_out litv + pull_out subproc task {loc with x= orNode_flat ( AndNode (ctx', [disj_flat (c,e)]), disjs @ esjs)} @@ -872,11 +894,15 @@ (* a bit redundant -- only the first call is a nontrivial location *) let rec loop i loc = try - let (lit, lit_vs), loc = find_unprotected cmp_lits loc in + let subt_lit, loc = find_unprotected cmp_lits loc in let _ = if !debug_level > 2 then begin - printf "\nfound_literal: %s\n" (Formula.str lit); + printf "\nfound_subtask-literal: %s\n" + (match subt_lit with + | Left subt -> + Formula.str (formula_of_tree {fvs=Vars.empty;t=subt}) + | Right (lit,_) -> Formula.str lit); printf "location: %s\n" (location_str loc) end in - let phi = pull_out (i, lit, lit_vs) loc in + let phi = pull_out subproc (i, subt_lit) loc in if !debug_level > 2 then printf "\npull-out_result: %s\n" (Formula.str (formula_of_tree phi)); @@ -886,21 +912,13 @@ let _ = if !debug_level > 2 then begin printf "\nff_tnf-result: %s\n" (Formula.str (formula_of_tree result)) end in - result in - let rec subproc = function - | ({t=TProc _} | {t=TLit _}) as lit -> lit - | {t=TNot_subtask subt} -> - let loc = {x=Top; n={fvs=Vars.empty; t=subt}} in - {fvs=Vars.empty; t=TNot_subtask (subproc (loop 0 loc)).t} - | {fvs=fvs; t=TAnd subts} -> - {fvs=fvs; t=TAnd (List.map subproc subts)} - | {fvs=fvs; t=TOr subts} -> - {fvs=fvs; t=TOr (List.map subproc subts)} - | {fvs=fvs; t=TAll (vs, subt)} -> - {fvs=fvs; t=TAll (vs, subproc subt)} - | {fvs=fvs; t=TEx (vs, subt)} -> - {fvs=fvs; t=TEx (vs, subproc subt)} in - let res = subproc (loop 0 loc) in + result + + and subproc subt = + let loc = {x=Top; n={fvs=Vars.empty; t=subt}} in + flatten_tree_to_formula (loop 0 loc) in + + let res = loop 0 loc in if !debug_level > 1 then printf "ff_tnf: res=%s\n%!" (Formula.str (formula_of_tree res)); let flat = flatten_tree_to_formula res in @@ -939,7 +957,7 @@ * {F1, ..., FMN_M} are all fluent atoms that occur positively in Phi and whose free variables are contained in the existential prefix of PNF(Phi) (where PNF is "prenex normal, existential-first with - minimized alternation, form") + minimized alternation, form") plus the free variables of Phi * (ex V1 (F11/\.../\F1N_1/\Guard1) \/ ... \/ ex VM (FM1/\.../\FMN_M/\GuardM)) @@ -948,8 +966,9 @@ {3 Algorithm for computing the FFSEP(F)(Phi):} - 1: Find the existential prefix variables EV. Let "active atoms" be - the positive atoms R(tup) with [R \in F] and [tup \in EV]. + 1: Find the free variables FV and existential prefix variables + EV. Let "active atoms" be the positive atoms R(tup) with [R \in F] + and [tup \in EV+FV]. 2: Flatten the formula Phi (using associativity), and push negation inside (partial NN) only when there is an active atom in the subformula. @@ -1003,10 +1022,11 @@ *) -(* Steps 1 and 2: Find existential prefix vars EV, flatten formula, - build the tree while pushing negation inside (flatten if possible) - if the subformula contains active atoms. *) +(* Steps 1 and 2: Find free vars FV and existential prefix vars EV, + flatten formula, build the tree while pushing negation inside + (flatten if possible) if the subformula contains active atoms. *) let ffsep_init frels phi = + let fvs = FormulaOps.free_vars phi in let rec aux neg evs = function | Ex (vs, phi) when not neg -> aux neg (add_vars vs evs) phi @@ -1018,9 +1038,10 @@ aux neg (aux neg evs phi) (And js) | Rel _ | RealExpr _ | Eq _ | In _ -> evs in let evs = aux false Vars.empty phi in + let fevs = add_vars fvs evs in let is_active rel vs = Strings.mem rel frels && - array_for_all (fun v->Vars.mem v evs) vs in + array_for_all (fun v->Vars.mem v fevs) vs in let rec has_active neg = function | Rel (rel, vs) when neg -> false | Rel (rel, vs) -> is_active rel (Formula.var_tup vs) @@ -1033,35 +1054,35 @@ {fvs=vars_of_list (FormulaOps.free_vars phi); t=TProc (0, if neg then Not phi else phi)} else - match phi with - | Rel _ as atom -> assert (not neg); - {fvs=vars_of_list (FormulaOps.free_vars atom); t=TLit atom} - | Not phi -> build (not neg) phi - | Ex (vs, phi) -> - let ({fvs=fvs} as subt) = build neg phi in - let qvs = vars_of_list vs in - let t = - if neg then TAll (qvs, subt) - else TEx (qvs, subt) in - {fvs=Vars.diff fvs qvs; t=t} - | All (vs, phi) -> - let ({fvs=fvs} as subt) = build neg phi in - let qvs = vars_of_list vs in - let t = - if neg then TEx (qvs, subt) - else TAll (qvs, subt) in - {fvs=Vars.diff fvs qvs; t=t} - | And js -> - let js = concat_map (build_and neg) js in - let t = if neg then TOr js else TAnd js in - {fvs=List.fold_left (fun fvs jt -> Vars.union fvs jt.fvs) - Vars.empty js; t=t} - | Or js -> - let js = concat_map (build_or neg) js in - let t = if neg then TAnd js else TOr js in - {fvs=List.fold_left (fun fvs jt -> Vars.union fvs jt.fvs) - Vars.empty js; t=t} - | RealExpr _ | In _ | Eq _ -> assert false + match phi with + | Rel _ as atom -> assert (not neg); + {fvs=vars_of_list (FormulaOps.free_vars atom); t=TLit atom} + | Not phi -> build (not neg) phi + | Ex (vs, phi) -> + let ({fvs=fvs} as subt) = build neg phi in + let qvs = vars_of_list vs in + let t = + if neg then TAll (qvs, subt) + else TEx (qvs, subt) in + {fvs=Vars.diff fvs qvs; t=t} + | All (vs, phi) -> + let ({fvs=fvs} as subt) = build neg phi in + let qvs = vars_of_list vs in + let t = + if neg then TEx (qvs, subt) + else TAll (qvs, subt) in + {fvs=Vars.diff fvs qvs; t=t} + | And js -> + let js = concat_map (build_and neg) js in + let t = if neg then TOr js else TAnd js in + {fvs=List.fold_left (fun fvs jt -> Vars.union fvs jt.fvs) + Vars.empty js; t=t} + | Or js -> + let js = concat_map (build_or neg) js in + let t = if neg then TAnd js else TOr js in + {fvs=List.fold_left (fun fvs jt -> Vars.union fvs jt.fvs) + Vars.empty js; t=t} + | RealExpr _ | In _ | Eq _ -> assert false and build_and neg phi = match build neg phi with | {t=TAnd js} when not neg -> js @@ -1071,7 +1092,7 @@ | {t=TOr js} when not neg -> js | {t=TAnd js} when neg -> js | t -> [t] in (* build will flatten the formula *) - evs, build false phi + fvs, evs, build false phi (* Map a prefix of [Left] elements (returned in reverse order) till the first [Right] element (if any), also return the unmapped tail @@ -1189,7 +1210,7 @@ (* Step 3, point (g) of step 5, step 6. *) let ffsep frels phi = - let evs, tree = ffsep_init frels phi in + let fvs, evs, tree = ffsep_init frels phi in (* step 3 *) let rec loop solved climbed = match climbed with [] -> solved @@ -1211,18 +1232,18 @@ | _ -> assert false in let forest = loop [] [[], tree] in (* step 6 *) - let fvs = FormulaOps.free_vars phi in - let avs = FormulaOps.free_vars (And (concat_map fst forest)) in - let avs = List.filter (fun v->not (List.mem v fvs)) avs in + let all_avs = FormulaOps.free_vars (And (concat_map fst forest)) in + let all_avs = List.filter (fun v->not (List.mem v fvs)) all_avs in + (* does not descend alternations, only erases "real" [evs] *) let rec erase_qs neg = function | Ex (vs, phi) when not neg -> - let vs = List.filter (fun v->not (List.mem v avs)) vs in - if vs = [] then erase_qs neg phi - else Ex (vs, erase_qs neg phi) + let nvs = List.filter (fun v->not (List.mem v all_avs)) vs in + if nvs = [] then erase_qs neg phi + else Ex (nvs, erase_qs neg phi) | All (vs, phi) when neg -> - let vs = List.filter (fun v->not (List.mem v avs)) vs in - if vs = [] then erase_qs neg phi - else All (vs, erase_qs neg phi) + let nvs = List.filter (fun v->not (List.mem v all_avs)) vs in + if nvs = [] then erase_qs neg phi + else All (nvs, erase_qs neg phi) | Not phi -> Not (erase_qs (not neg) phi) | Or disjs -> Or (List.map (erase_qs neg) disjs) | And conjs -> And (List.map (erase_qs neg) conjs) Modified: trunk/Toss/Formula/FFTNFTest.ml =================================================================== --- trunk/Toss/Formula/FFTNFTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/FFTNFTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -1,3 +1,6 @@ +(* Some tests of the FFTNF module are in the FFSolverTest test suite + (when it is easier to do them using {!FFSolver.normalize_for_model}). *) + open OUnit open Aux open Printf @@ -37,10 +40,10 @@ let tests = "FFTNF" >::: [ - "pn_nnf: renaming" >:: + "pn_nnf: subtasks and renaming" >:: (fun () -> - assert_equal ~printer:(fun x->x) - "ex x0 (all x ((P(x0) and Q(x))))" + assert_equal ~printer:(fun x->x) ~msg:"subtask, no renaming" + "ex x ((P(x) and (not ex x ((not Q(x))))))" (Formula.str (FFTNF.p_pn_nnf (formula_of_str "ex x P(x) and all x Q(x)"))); assert_equal ~printer:(fun x->x) @@ -58,20 +61,24 @@ (formula_of_str "ex x (P(x) and (not (all x Q(x))))"))); ); - "pn_nnf: merging" >:: + "pn_nnf: subtasks and merging" >:: (fun () -> assert_equal ~printer:(fun x->x) - "ex z (all x (ex y ((R(x, y) and Q(z)))))" + "ex z (((not ex x (all y ((not R(x, y))))) and Q(z)))" (Formula.str (FFTNF.p_pn_nnf (formula_of_str "(all x ex y R(x,y)) and (ex z Q(z))"))); - assert_equal ~printer:(fun x->x) - "ex y (ex v (all w (all z (all x (((P(x) and R(y, z)) and C(v, w)))))))" + assert_equal ~printer:(fun x->x) ~msg:"one subtask, merge rest" + "ex y (ex v (all w (all z ((((not ex x ((not P(x)))) and R(y, z)) and C(v, w))))))" (Formula.str (FFTNF.p_pn_nnf (formula_of_str "all x P(x) and ex y (all z R(y,z)) and ex v (all w C(v,w))"))); - assert_equal ~printer:(fun x->x) - "ex y (all z (all x (ex y0 (ex v (all v0 (((Q(v0) and R(x, y0)) and (P(v) and R(y, z)))))))))" + assert_equal ~printer:(fun x->x) ~msg:"subtask breaks PNF" + "ex y (all z (ex v (((not ex x (all y (ex v (((not Q(v)) or (not R(x, y))))))) and (P(v) and R(y, z))))))" (Formula.str (FFTNF.p_pn_nnf (formula_of_str "all x (ex y (all v (Q(v) and R(x,y)))) and ex y (all z (ex v (P(v) and R(y,z))))"))); + assert_equal ~printer:(fun x->x) ~msg:"no subtask: free dependent" + "ex y (all z (all x (ex y0 (ex v (all v0 ((((P(f) and Q(v0)) and R(x, y0)) and (P(v) and R(y, z)))))))))" + (Formula.str (FFTNF.p_pn_nnf + (formula_of_str "all x (ex y (all v (P(f) and Q(v) and R(x,y)))) and ex y (all z (ex v (P(v) and R(y,z))))"))); ); "ff_tnf: simple formulas" >:: @@ -160,20 +167,4 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "FFTNFTest" then - ignore (run_test_tt ~verbose:true tests) - - -let a () = - match test_filter [""] - tests - with - | Some tests -> ignore (run_test_tt ~verbose:true tests) - | None -> () + Aux.run_test_if_target "FFTNFTest" tests Modified: trunk/Toss/Formula/Formula.ml =================================================================== --- trunk/Toss/Formula/Formula.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/Formula.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -260,7 +260,7 @@ (fprint_real_nobra 0) r -let fprint f phi = Format.printf "@[%a@]" fprint_formula phi +let fprint f phi = Format.fprintf f "@[%a@]" fprint_formula phi let print phi = fprint Format.std_formatter phi let sprint phi = ignore (Format.flush_str_formatter ()); Modified: trunk/Toss/Formula/FormulaOpsTest.ml =================================================================== --- trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -297,18 +297,7 @@ ] ;; let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - (* So that the tests are not run twice while building TossTest. *) - if test_fname "FormulaOpsTest" then - match test_filter [""] tests with - | Some tests -> ignore (run_test_tt ~verbose:true tests) - | None -> () + Aux.run_test_if_target "FormulaOpsTest" tests ;; (* --------------------------- Reals separation test ----------------------- *) Modified: trunk/Toss/Formula/FormulaTest.ml =================================================================== --- trunk/Toss/Formula/FormulaTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Formula/FormulaTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -19,16 +19,5 @@ ] ;; let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - (* So that the tests are not run twice while building TossTest. *) - if test_fname "FormulaTest" then - match test_filter [""] tests with - | Some tests -> ignore (run_test_tt ~verbose:true tests) - | None -> () + Aux.run_test_if_target "FormulaTest" tests ;; Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Play/GameTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -874,7 +874,6 @@ "gomoku8x8 avoid endgame" >:: (fun () -> - skip_if true "takes too long -- uncheck later"; let state = update_game gomoku8x8_game "[ | | ] \" ... ... ... ... @@ -924,7 +923,6 @@ "gomoku8x8 block gameover" >:: (fun () -> - skip_if true "takes too long -- uncheck later"; let state = update_game gomoku8x8_game "[ | | ] \" ... ... ... ... @@ -1035,15 +1033,7 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "GameTest" then - ignore (run_test_tt ~verbose:true tests) + Aux.run_test_if_target "GameTest" tests let a () = run_test_tt ~verbose:true experiments Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Play/Heuristic.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -88,10 +88,6 @@ ********** - SuggestExpansion(Phi, S) is true iff Phi has a universal quantifier - or if the number of existential quantifiers in Phi is smaller than - the square root of the number of elements in S. - Tentative compact specification of ExpandedDescription: ExpandedDescription(S, T) of a set of substitutions T(x1,...,xn) @@ -333,6 +329,7 @@ let expanded_descr max_alt_descr elems rels struc all_vars xvars xsubsts = + let solver = Solver.new_solver () in let alt_descr = ref 0 in let max_arity = find_max (-) (List.map (fun (_,tups) -> @@ -469,10 +466,13 @@ flush stdout) in let new_substs = map_some (fun atom -> (* g *) - let assgns = FFSolver.evaluate struc ~aset:path_assgns atom in + let assgns = + Solver.evaluate_partial_aset solver + ~formula:(Solver.register_formula solver atom) + struc path_assgns in let _ = if !debug_level > 3 then (printf "yxvars=%s\n" (String.concat ", "(List.map var_str yxvars)); flush stdout) in - let substs = FFSolver.assgn_to_list struc yxvars assgns in + let substs = AssignmentSet.fo_assgn_to_list elems yxvars assgns in (* sort substitutions while checking for (i) *) let substs, repeating_inst, vs_insts = (* check_sort_substs_k1 new_yvars used_vars substs *) @@ -581,10 +581,10 @@ List.map Formula.to_fo (FormulaOps.free_vars phi) in if vars = [] then Or [] else - let phi = FFSolver.normalize_for_model struc phi in - let aset = FFSolver.evaluate struc phi in + let aset = SolverIntf.M.evaluate struc + (SolverIntf.M.register_formula phi) in let substs = - FFSolver.assgn_to_list struc vars aset in + AssignmentSet.fo_assgn_to_list elems vars aset in (* sort substitutions; TODO: optimizable *) let substs = trunc_to_vars vars substs in if !debug_level > 2 then ( @@ -621,10 +621,10 @@ List.map Formula.to_fo (FormulaOps.free_vars phi) in if vars = [] then phi else - let ev_phi = FFSolver.normalize_for_model struc phi in let substs = - FFSolver.assgn_to_list struc vars - (FFSolver.evaluate struc ev_phi) in + AssignmentSet.fo_assgn_to_list elems vars + (SolverIntf.M.evaluate struc + (SolverIntf.M.register_formula phi)) in (* sort substitutions; TODO: optimizable *) let substs = trunc_to_vars vars substs in let all_vars = add_strings (List.map var_str vars) all_vars in Modified: trunk/Toss/Play/HeuristicTest.ml =================================================================== --- trunk/Toss/Play/HeuristicTest.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Play/HeuristicTest.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -355,6 +355,7 @@ "of_payoff: monotonic tic-tac-toe" >:: (fun () -> backtrace ( + (* TODO: add preconditions in rules! *) let rules = [ rule_of_str sigPQ "[a | P:1 {}; Q:1 {} | ] -> [ | Q:1 {}; P(a) | ] emb P, Q"; rule_of_str sigPQ "[a | P:1 {}; Q:1 {} | ] -> [ | P:1 {}; Q(a) | ] emb P, Q"] in @@ -395,15 +396,7 @@ ] let a = - let file_from_path p = - String.sub p (String.rindex p '/'+1) - (String.length p - String.rindex p '/' - 1) in - let test_fname name = - let fname = file_from_path Sys.executable_name in - String.length fname >= String.length name && - String.sub fname 0 (String.length name) = name in - if test_fname "HeuristicTest" then - ignore (run_test_tt ~verbose:true tests) + Aux.run_test_if_target "HeuristicTest" tests let a () = Modified: trunk/Toss/Play/Makefile =================================================================== --- trunk/Toss/Play/Makefile 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Play/Makefile 2010-11-28 15:34:57 UTC (rev 1204) @@ -3,12 +3,18 @@ %Test: make -C .. Play/$@ +%TestProfile: + make -C .. Play/$@ + %TestDebug: make -C .. Play/$@ HeuristicTest: GameTest: +HeuristicTestProfile: +GameTestProfile: + HeuristicTestDebug: GameTestDebug: Modified: trunk/Toss/Solver/AssignmentSet.ml =================================================================== --- trunk/Toss/Solver/AssignmentSet.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Solver/AssignmentSet.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -70,6 +70,32 @@ | Real poly_dnf -> "{ " ^ (cases_str "" poly_dnf) ^ " }" +let rec named_str struc = function + Empty -> "{}" + | Any -> "T" + | FO (v, map) -> + let vn = Formula.var_str v in + let estr (e, a) = + if a = Any then vn ^ "->" ^ (Structure.elem_str struc e) else + vn ^ "->" ^ + (Structure.elem_str struc e) ^ (named_str struc a) ^ " " in + "{ " ^ (String.concat ", " (List.map estr map)) ^ " }" + | MSO (v, map) -> + let vn = Formula.var_str v in + let estr ((pos, neg), a) = + let (posl, negl) = (Elems.elements pos, Elems.elements neg) in + let pos_str = + String.concat ", " (List.map (Structure.elem_str struc) posl) in + let neg_str = + String.concat ", " (List.map (Structure.elem_str struc) negl) in + let a_s = if a = Any then "" else named_str struc a in + if a = Empty then "{}" else + vn ^ "->(inc {" ^ pos_str ^ "} excl {" ^ neg_str ^ "})" ^ a_s + in + "{ " ^ (String.concat ", " (List.map estr map)) ^ " }" + | Real poly_dnf -> + "{ " ^ (cases_str "" poly_dnf) ^ " }" + (* Select an arbitrary assignment for first-order variables with the given names and default values. Raise [Not_found] if the assignment set is empty. *) @@ -101,3 +127,33 @@ List.concat (List.rev_map (fun (e, asg) -> List.rev_map (prolong e) (tuples elems vs asg)) asg_list) | _ -> failwith "listing tuples in non first-order assignment set" + +(* Check if a variable is actually present in the assignments + tree. TODO: handle the real case. *) +let rec mem_assoc v = function + | Empty | Any -> false + | FO (v1, _) when (v1 :> Formula.var) = (v :> Formula.var) -> true + | MSO (v1, _) when (v1 :> Formula.var) = (v :> Formula.var) -> true + | Real _ -> false + | FO (_, assgns) -> + List.exists (fun (_,aset) -> mem_assoc v aset) assgns + | MSO (_, assgns) -> + List.exists (fun (_,aset) -> mem_assoc v aset) assgns + +(* Convert the FO part of an assignment set to a set of assignments. *) +let rec fo_assgn_to_list all_elems vars = function + | Any -> + let elems = List.map (fun _ -> all_elems) vars in + let tuples = Aux.product elems in + List.map (List.combine vars) tuples + | Empty -> [] + | FO (v, els) -> + let vars = Aux.list_remove v vars in + Aux.concat_map (fun (e,sub)-> + List.map (fun tl->(v,e)::tl) + (fo_assgn_to_list all_elems vars sub)) els + | MSO (_, els) -> + Aux.concat_map (fun (e,sub)-> + fo_assgn_to_list all_elems vars sub) els + | Real _ -> + failwith "AssignmentSet.assgn_to_list: Reals not implemented yet." Modified: trunk/Toss/Solver/AssignmentSet.mli =================================================================== --- trunk/Toss/Solver/AssignmentSet.mli 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Solver/AssignmentSet.mli 2010-11-28 15:34:57 UTC (rev 1204) @@ -26,6 +26,9 @@ (* Print the given assignment as string. *) val str : assignment_set -> string +(* Print the given assignment as string, using element names. *) +val named_str : Structure.structure -> assignment_set -> string + (* Select an arbitrary assignment for first-order variables with the given names and default values. Raise [Not_found] if the assignment set is empty. *) @@ -35,3 +38,12 @@ (* List all tuples the first-order assignment [asg] assigns to [vars] in order in which [vars] are given. [elems] are are all elements. *) val tuples : Structure.Elems.t -> string list -> assignment_set -> int array list + +(* Check if a variable is actually present in the assignments tree. *) +val mem_assoc : [< Formula.var ] -> assignment_set -> bool + + +(* Convert the FO part of an assingment set into a list of substitutions. *) +val fo_assgn_to_list : + int list -> Formula.fo_var list -> assignment_set -> + (Formula.fo_var * Structure.Elems.elt) list list Modified: trunk/Toss/Solver/FFSolver.ml =================================================================== --- trunk/Toss/Solver/FFSolver.ml 2010-11-28 13:27:59 UTC (rev 1203) +++ trunk/Toss/Solver/FFSolver.ml 2010-11-28 15:34:57 UTC (rev 1204) @@ -1,10 +1,9 @@ -(* A solver based on the FF Type Normal Form and - {!Assignments}. Continuous aspects (polynomials, real variables, - formulas characterizing reals) are not developed. Also fixes some - [Sum] computation bug in {!Solver}. +(* A solver based on the FF Type Normal Form and {!AssignmentSet}s + without predetermined order of variables. Continuous aspects + (polynomials, real variables, formulas characterizing reals) are + not developed yet (but real expressions with [Sum]s, [Char]acteristic + and real functions are available). *) -*) - open Formula open Printf @@ -36,11 +35,11 @@ else is_unique_assoc tl (* -let aFO lnum (v,assgns) = + let aFO lnum (v,assgns) = Printf.printf "(%d:%s) %!" lnum (var_str v); if is_unique_assoc assgns then A.FO (v, assgns) else failwith - ("not unique "^string_of_int lnum^": "^A.str (A.FO (v,assgns))) + ("not unique "^string_of_int lnum^": "^A.str (A.FO (v,assgns))) *) let rec invert_aset acc = function @@ -52,7 +51,8 @@ | A.Real _ | A.MSO _ -> failwith "Real/MSO assignments not supported yet" -(* Use a bigger assignment set as the first argument. *) +(* Use a bigger assignment set as the first argument. TODO: obsolete + this function by optimizations of disjunction and existential q. *) let sum_assignment_sets all_elems aset1 aset2 = let sbs2 = invert_aset [[]] aset2 in let rec aux sb = function @@ -75,7 +75,8 @@ failwith "Real/MSO assignments not supported yet" in List.fold_right aux sbs2 aset1 -(* Remove existentially quantified variables from the solution. *) +(* Remove existentially quantified variables from the solution. TODO: + obsolete this function by optimizing treatment of ex. q. variables. *) let rec project all_elems aset v = match aset with | A.Empty -> A.Empty @@ -147,6 +148,19 @@ | Unsatisfiable -> map_try ?catch f tl +let rec fold_try ?catch f accu = function + | [] -> [] + | hd::tl -> + try + fold_try ?catch f (f accu hd) tl + with + | Unsatisfiable_FO witnesses as exc -> + if catch = None || Vars.mem (Aux.unsome catch) witnesses + then fold_try ?catch f accu tl + else raise exc + | Unsatisfiable -> + fold_try ?catch f accu tl + (* Remove universally quantified variables from the solution. *) let universal num_elems all_elems aset v = let rec aux = function @@ -164,7 +178,8 @@ | A.FO (v1, assgns) -> let assgns = map_try (fun (e, aset) -> e, aux aset) assgns in - A.FO (v1, assgns) + if assgns = [] then raise Unsatisfiable + else A.FO (v1, assgns) | A.Real _ | A.MSO _ -> failwith "FFSolver: Real/MSO assignments not supported yet" in aux aset @@ -178,6 +193,25 @@ | a::l -> p i a || aux (i+1) l in aux 0 l +(* Remove a variable from an assignment by projecting on the given + element; if the variable does not admit the element, raise + [Unsatisfiable]. *) +let project_v_on_elem v e aset = + let rec aux = function + | A.Empty -> raise Unsatisfiable + | A.Any -> A.Any + | A.FO (v1, assgns) when v1 = v -> + (try List.assoc e assgns + with Not_found -> raise Unsatisfiable) + | A.FO (v1, assgns) -> + let assgns = + map_try (fun (e, aset) -> e, aux aset) assgns in + if assgns = [] then raise Unsatisfiable + else A.FO (v1, assgns) + | A.Real _ | A.MSO _ -> + failwith "FFSolver: Real/MSO assignments not supported yet" in + aux aset + (* We assume that for every "not ex psi" subformula, "ex psi" is ground, and that every other occurrence of negation is in a literal (it is guaranteed by @@ -185,381 +219,455 @@ We use the structure of the formula to organize search and build the result on the recursive stack. Accumulated substitution stores - the most recent variable first. Our approach lies somewhere between - database-like: we accumulate the answer set and process - disjunctions by summing the resulting answer sets, and very - simplified finite-domain-constraint-satisfaction (e.g. Gecode) - like: we split the "search space" by assigning values to a variable - once we encounter the first "good" constraint on that variable (so - we process conjunctions by a simple form of "propagation"). We - organize conjunctive constraints into three queues: currently - handled, delayed1: positive has more than one undefined position or - negative with exactly one undefined position, delayed2: - would have to split on all elements. *) -let evaluate model ?(sb=[]) ?(aset=A.Any) phi = + the most recent variable first, it represents the path from root to + the current position in the aset being built. Our approach + resembles constraint propagation: we split the "search space" by + assigning values to a variable once we encounter the first "good" + constraint on that variable. We organize conjunctive constraints + into three queues: currently handled, delayed1: positive has more + than one undefined position or negative with exactly one undefined + position, delayed2: would have to split on all elements. We fold + over disjunctive constraints by keeping the aset subtree to which + we merge from the current context to produce the final answer. (It + is initialized with Empty aset.) + + The rules to merge (disjoin) the current aset (cur-aset) and the + current position (cur-pos): + + (a) cur-aset=Any: return Any (subsumption) + + (b) no more conjuncts in subformula: return Any (subsumption the + other way round) -- descending the recursion stack will rebuild the + final aset + + (c) introducing a variable v that is also the root of cur-aset: + + (c1) map-try over the cur-pos values of v, passing as aset to disjoin + the corresponding cur-aset subtree, or Empty if cur-aset does not + admit given value + + (c2) if map-try returned non-empty, add to it cur-aset subtrees of v + values outside of map-try results (if empty, raise Unsatisfiable) + + (d) introducing a variable v that does not occur in cur-aset: + (includes case cur-aset=Empty) + + (d1) map-try over the cur-pos values of v, passing as aset to disjoin + the whole cur-aset + + (d2) if map-try returned non-empty, add to it the whole cur-aset + for v set to all elements outside of map-try results (unless + cur-aset is Empty); if map-try returned empty, raise Unsatisfiable + [TODO: this can benefit from extending the definition of asets with + "other-than" subtree] + + (e) introducing a variable v that occurs in cur-aset: + + (e1) cut the cur-aset into a forest: the aset without v (for each + occurrence of v in cur-aset removing the corresponding assignment + of its parent variable, perhaps recursively if it was a single + assignment), and the asets composed of a single path to each + occurrence of v and its subtree ("flower-trees") + + (e2) pull-out v by copying the trunk in front of each child-subtree + of v, for each "flower-tree" + + (e3) merge the resulting trees starting with "cur-aset with holes", + observing that they have the same order of variables as + "accumulator" on relevant paths, with v at root + + (e1-e3) observe that during merger, the "cur-aset with holes" will + be cloned over, and the v-occurrence-child-subtrees will either be + reintroduced to their original places or the holes kept, depending + on what v-assignment the clone belongs to; this observation is used + for the actual implementation + + (e4) apply the case (c) +*) +let rec merge all_elems v init_domain sb cur_aset eval_cont = + match cur_aset with + | A.MSO _ | A.Real _ -> failwith + "FFSolver.evaluate: MSO and Real not supported yet" + (* a *) + | A.Any -> A.Any + (* c *) + | A.FO (v1, dis_assgns) when v1 = v -> + let choose e = + e, eval_cont ((v, e)::sb) + (try List.assoc e dis_assgns with Not_found -> A.Empty) in + (* c1 *) + let pos_assgns = + map_try ~catch:(v :> var) choose init_domain in + if pos_assgns = [] then raise Unsatisfiable + else + (* c2 *) + let more_assgns = Aux.map_some (fun e_aset -> + if List.mem_assoc (fst e_aset) pos_assgns then None else Some e_aset) + dis_assgns in + A.FO (v, pos_assgns @ more_assgns) + + (* d *) + | _ when not (A.mem_assoc v cur_aset) -> + let choose e = + e, eval_cont ((v, e)::sb) cur_aset in + (* d1 *) + let pos_assgns = + map_try ~catch:(v :> var) choose init_domain in + if pos_assgns = [] then raise Unsatisfiable + else if cur_aset = A.Empty + then A.FO (v, pos_assgns) + else + (* d2 *) + let more_assgns = Aux.map_some (fun e -> + if List.mem_assoc e pos_assgns then None else Some (e, cur_aset)) + all_elems in + A.FO (v, pos_assgns @ more_assgns) + + (* e *) + | _ -> (* when A.mem_assoc v cur_aset *) + let pull_v e = + e, project_v_on_elem v e cur_aset in + let cur_aset = + A.FO (v, map_try pull_v all_elems) in + merge all_elems v init_domain sb cur_aset eval_cont + + +(* "Negate" the second assignment set wrt. [all_elems] and add it to the + first aset. *) +let rec add_complement all_elems disj_aset = function + | A.Empty -> A.Any + | A.Any -> + if disj_aset = A.Empty then raise Unsatisfiable; + disj_aset + | A.FO (_, []) -> assert false + | A.FO (v, assgns) -> + let add_cont sb dset = + let e = snd (List.hd sb) in + let cset = + (* Empty will turn into Any on recursive callback *) + try List.assoc e assgns with Not_found -> A.Empty in + add_complement all_elems dset cset in + merge all_elems v all_elems [] disj_aset add_cont + + | A.Real _ | A.MSO _ -> + failwith "FFSolver: Real/MSO assignments not supported yet" + + +let evaluate model ?(sb=[]) ?(disj_aset=A.Empty) phi = let all_elems = Elems.elements model.elements in let num_elems = Elems.cardinal model.elements in - (* Build a context on the recursive stack for - the resulting assignment set. Collect the results and pack them - back into the assignment set. *) - let rec context sb aset delayed2 delayed1 conj_cont = - let rec aux sb = function - | A.Empty -> raise Unsatisfiable - | A.Any -> solve sb delayed2 delayed1 conj_cont - | A.FO (v, assgns) -> - let assgns = - map_try (fun (e, aset) -> - e, aux ((v,e)::sb) aset) assgns in - if assgns = [] then raise Unsatisfiable - else A.FO (v, assgns) - | A.Real _ | A.MSO _ -> - failwith "Real/MSO assignments not supported yet" in - aux sb aset - (* Process conjunctions by passing the remaining conjuncts a la CPS. - Disjunctions are processed by summing the returned assignment - sets. Branch on a variable when it is first encountered in a - literal. Eliminate a variable (and sum its branches) from the - assignment set when exiting an existential quantifier. - Check universally quantified variables for coverage. + (* Process conjunctions by passing the remaining conjuncts a la CPS, + filtering according to subsumption with the current alternative + (cur-aset), accumulating assignments in a substitution and + rebuilding the resulting aset on return. Disjunctions are + processed by fold-try of the solution process with cur-aset as + accumulator. Branch on a variable when it is first encountered in + a literal. Eliminate a variable (and sum its branches) from the + assignment set when exiting an existential quantifier [TODO: + optimize]. Check universally quantified variables for coverage. Do not return [A.Empty], raise [Unsatisfiable] instead. *) - and solve sb delayed2 delayed1 = function - | [] -> - if delayed1 <> [] - then solve sb delayed2 [] (List.rev delayed1) - else if delayed2 <> [] - then solve sb [] [] (List.rev delayed2) - else A.Any + let rec solve delayed2 delayed1 conj_cont sb cur_aset = + (* a *) + if cur_aset = A.Any then A.Any + else match conj_cont with + | [] -> + if delayed1 <> [] + then solve delayed2 [] (List.rev delayed1) sb cur_aset + else if delayed2 <> [] + then solve [] [] (List.rev delayed2) sb cur_aset + (... [truncated message content] |
From: <luk...@us...> - 2010-11-29 09:49:08
|
Revision: 1207 http://toss.svn.sourceforge.net/toss/?rev=1207&view=rev Author: lukstafi Date: 2010-11-29 09:49:01 +0000 (Mon, 29 Nov 2010) Log Message: ----------- FFTNF bug fixes (recent missing negation, older implementation of c3 of FFTNF spec). Modified Paths: -------------- trunk/Toss/Formula/FFTNF.ml trunk/Toss/Formula/FFTNFTest.ml trunk/Toss/Solver/FFSolverTest.ml Modified: trunk/Toss/Formula/FFTNF.ml =================================================================== --- trunk/Toss/Formula/FFTNF.ml 2010-11-28 17:05:43 UTC (rev 1206) +++ trunk/Toss/Formula/FFTNF.ml 2010-11-29 09:49:01 UTC (rev 1207) @@ -50,7 +50,7 @@ (a1) empty Qn': pull-out(context'[],[Qn.[fill-loc]]) - (a2) nonempty Qn': context'[Qn'.L /\ Qn''.[fill-loc]] + (a2) nonempty Qn': context'[Qn'.(L /\ Qn''.[fill-loc])] (b) context'[[] /\ C]: pull-out(context'[],[[fill-loc] /\ C]) @@ -93,6 +93,7 @@ (f1) If the pulled-out literal is protected in current scope, leave it here. + context[L /\ [fill-loc]] (f2) when the nearest quantifier is existential: pull-out(context'[([] /\ C) \/ (D /\ C)], [fill-loc]) @@ -658,8 +659,8 @@ Left subt, {loc with n={fvs=Vars.empty; t=TAnd[]}} | {fvs=lit_vs; t=TLit lit} -> let _ = if !debug_level > 3 then - printf "find_unprot: processing literal, loc %s\n" - (location_str loc) in + printf "find_unprot: processing literal %s, loc %s\n" + (Formula.str lit) (location_str loc) in let best_loc = (* store if first *) match best_loc with | Some ((lit2,lit_vs2), _) @@ -706,7 +707,7 @@ match task_lit with | Left subt -> Vars.empty, - lazy {fvs=Vars.empty; t=TProc (task_id, subproc subt)} + lazy {fvs=Vars.empty; t=TProc (task_id, Not (subproc subt))} | Right (lit, lit_vs) -> lit_vs, lazy {fvs=lit_vs; t=TProc (task_id, lit)} in match loc.x with @@ -717,18 +718,21 @@ | ExNode (ctx', vs) -> let vs' = Vars.inter vs lit_vs in let vs'' = Vars.diff vs vs' in - (* a1 *) + (* a1 + pull-out(context'[],[Qn.[fill-loc]]) *) if Vars.is_empty vs' then let _ = if !debug_level > 2 then printf "a1\n" in pull_out subproc task {x=ctx'; n=qT loc.x (vs,loc.n)} - (* a2 *) + (* a2 + context'[Qn'.(L /\ Qn''.[fill-loc])] *) else let _ = if !debug_level > 2 then printf "a2\n" in zip {x=ctx'; n=qT loc.x (vs', conj_flat ( Lazy.force put_result, qT loc.x (vs'', loc.n)))} - (* b *) + (* b + pull-out(context'[],[[fill-loc] /\ C]) *) | AndNode (ctx', subts) -> let _ = if !debug_level > 2 then printf "b\n" in pull_out subproc task @@ -749,14 +753,16 @@ let disj = {fvs=vsSibl; t=TOr subts} in let vs1_3 = Vars.diff vs1 vs3 in - (* c1 *) + (* c1 + pull-out(context'[Qn2.[] \/ Qn4.D],[fill-loc]) *) if Vars.is_empty vs3 then let _ = if !debug_level > 2 then printf "c1\n" in pull_out subproc task {loc with x= qNode qN ( orNode_flat (ctx', [qT qN (vs4, disj)]), vs2)} - (* c2 *) + (* c2 + context'[Qn3.(Qn1\Qn3.(L /\ Qn5.[fill-loc]) \/ Qn4.D)] *) else if not (Vars.is_empty vs1) && (not (Vars.is_empty vs1_3) || Vars.is_empty (Vars.diff vs3 vs1)) @@ -769,14 +775,17 @@ qT qN (vs4, disj)) in zip {x=ctx'; n=qT qN (vs3, subt)} - (* c3 *) + (* c3 + pull-out(context'[Qn2+3.[] \/ Qn3+4.D],[fill-loc]) *) else if match qN with ExNode _ -> true | _ -> false then let _ = if !debug_level > 2 then printf "c3\n" in pull_out subproc task - {x=orNode_flat (ctx', [qT qN (vsD, disj)]); - n= qT qN (vs0, loc.n)} + {loc with x=qNode qN + (orNode_flat (ctx', [qT qN (vsD, disj)]), vs0)} - (* c4 *) + (* c4 + pull-out(context'[Qn.(([] \/ D) /\ ([fill-loc] \/ + D))],[T]) *) else let _ = if !debug_level > 2 then printf "c4\n" in pull_out subproc task @@ -809,7 +818,8 @@ let conj = {fvs=vsSiblAnd; t=TAnd and_subts} in - (* d1 *) + (* d1 + pull-out(context'[Qn2.([] \/ D) /\ Qn4.C],[fill-loc]) *) if Vars.is_empty vs3 then let _ = if !debug_level > 2 then printf "d1\n" in pull_out subproc task @@ -818,7 +828,8 @@ ctx', qT qN (vs4, conj)), vs2), or_subts)} - (* d2 *) + (* d2 + pull-out(context'[Qn2+3.([] \/ D) /\ Qn3+4.C]) *) else if match qN with AllNode _ -> true | _ -> false then let _ = if !debug_level > 2 then printf "d2\n" in pull_out subproc task @@ -826,7 +837,9 @@ qNode qN (andNode_flat (ctx', qT qN (vsC, conj)), vsFLD) , or_subts)} - (* d3 *) + (* d3 + pull-out(context'[Qn6.([] /\ C) \/ Qn5.(D /\ + C)],[fill-loc]) *) else let vs5 = Vars.union vsD vsC in let vs6 = Vars.union vsFL vsC in @@ -841,7 +854,8 @@ | OrNode (OrNode _,_) -> failwith "pull_out: malformed context (nonflat disjunction)" - (* e *) + (* e + context[fill-loc] *) | OrNode (Top, _) -> let _ = if !debug_level > 2 then printf "e\n" in zip {loc with n=conj_flat (Lazy.force put_result, loc.n)} @@ -849,7 +863,8 @@ let _ = if !debug_level > 2 then printf "e\n" in zip {loc with n=conj_flat (Lazy.force put_result, loc.n)} - (* f1 *) + (* f1 + context[L /\ [fill-loc]] *) | OrNode (AndNode (Top, _), _) -> let _ = if !debug_level > 2 then printf "f1\n" in zip {loc with n= @@ -860,7 +875,9 @@ zip {loc with n= conj_flat (Lazy.force put_result, loc.n)} - (* f2 *) (* same as (d) of FFSEP *) + (* f2 + pull-out(context'[([] /\ C) \/ (D /\ C)], [fill-loc]) *) + (* same as (d) of FFSEP *) | OrNode (AndNode (ctx', conjs), disjs) when not (univ_next_in_scope ctx') -> let _ = if !debug_level > 2 then printf "f2\n" in @@ -872,7 +889,9 @@ {loc with x= andNode_flat ( orNode_flat (ctx', [conj_flat (d,c)]), c)} - (* f3 *) (* same as (f) of FFSEP *) + (* f3 + pull-out(context'[([] \/ D \/ E) /\ (C \/ E)], [fill-loc]) *) + (* same as (f) of FFSEP *) | OrNode (AndNode (OrNode (ctx', esjs), conjs), disjs) -> let _ = if !debug_level > 2 then printf "f3\n" in let e = List.fold_right (fun a b->disj_flat (a,b)) esjs Modified: trunk/Toss/Formula/FFTNFTest.ml =================================================================== --- trunk/Toss/Formula/FFTNFTest.ml 2010-11-28 17:05:43 UTC (rev 1206) +++ trunk/Toss/Formula/FFTNFTest.ml 2010-11-29 09:49:01 UTC (rev 1207) @@ -151,7 +151,20 @@ "ff_tnf: deep" >:: (fun () -> + (* FFTNF.debug_level := 7; *) assert_equal ~printer:(fun x->x) + "ex z (((not Q(z)) and (ex x, y ((not R(x, y))) or ex y ((C(y, z) and ex x (P(x)))))))" + (Formula.str (FFTNF.ff_tnf + (FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"])) + (formula_of_str "ex x, y, z ((not R(x,y) or (P(x) and C(y,z))) and not Q(z))"))); + + assert_equal ~printer:(fun x->x) + "ex z (((not Q(z)) and (ex x, y ((not R(x, y))) or ex y (((not C(y, z)) and ex x ((not P(x))))))))" + (Formula.str (FFTNF.ff_tnf + (FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"])) + (formula_of_str "ex x, y, z not ((R(x,y) and (P(x) or C(y,z))) or Q(z))"))); + + assert_equal ~printer:(fun x->x) "ex z ((Q(z) or ex x ((P(x) and ex y (R(x, y)))) or ex y ((C(y, z) and ex x (R(x, y))))))" (Formula.str (FFTNF.ff_tnf (FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"])) @@ -164,6 +177,21 @@ (formula_of_str "ex x, y, z (C(x, z) and ((R(x,y) and (P(x) or C(y,z))) or Q(z)))"))); ); + "ff_tnf: subtasks" >:: + (fun () -> + assert_equal ~printer:(fun x->x) + "(not ex z (((not Q(z)) and (ex x, y ((not R(x, y))) or ex y (((not C(y, z)) and ex x ((not P(x)))))))))" + (Formula.str (FFTNF.ff_tnf + (FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"])) + (formula_of_str "all x, y, z ((R(x,y) and (P(x) or C(y,z))) or Q(z))"))); + + assert_equal ~printer:(fun x->x) + "(((not ex z ((not Q(z)))) and ex y (P(y))) or ex x, y (C(x, y)))" + (Formula.str (FFTNF.ff_tnf + (FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"])) + (formula_of_str "ex x, y (C(x, y) or (P(y) and all z Q(z)))"))); + ); + ] let a = Modified: trunk/Toss/Solver/FFSolverTest.ml =================================================================== --- trunk/Toss/Solver/FFSolverTest.ml 2010-11-28 17:05:43 UTC (rev 1206) +++ trunk/Toss/Solver/FFSolverTest.ml 2010-11-29 09:49:01 UTC (rev 1207) @@ -273,7 +273,7 @@ \"" in (* FFTNF.debug_level := 3; *) assert_equal ~printer:(fun x->x) - "((not ex x ((Q(x) and (ex y ((C(x, y) and Q(y) and ex z ((C(y, z) and Q(z))))) or ex y ((R(x, y) and Q(y) and ex z ((R(y, z) and Q(z))))) or ex y ((Q(y) and ex z ((Q(z) and (ex v0 ((R(x, v0) and C(y, v0) and ex u0 ((R(y, u0) and C(z, u0))))) or ex v ((R(x, v) and C(v, y) and ex u ((R(y, u) and C(u, z)))))))))))))) and ((not Q(a1)) and (not P(a1))))" + "((not ex x ((Q(x) and (ex y ((C(x, y) and Q(y) and ex z ((C(y, z) and Q(z))))) or ex y ((R(x, y) and Q(y) and ex z ((R(y, z) and Q(z))))) or ex y ((Q(y) and ex z ((Q(z) and (ex v0 ((R(x, v0) and C(y, v0) and ex u0 ((R(y, u0) and C(z, u0))))) or ex v ((R(x, v) and C(v, y) and ex u ((R(y, u) and C(u, z)))))))))))))) and ((not P(a1)) and (not Q(a1))))" (Formula.str (FFSolver.normalize_for_model tictactoe_init tictactoe_LHS)); ); @@ -296,56 +296,11 @@ \"" in (* FFTNF.debug_level := 3; *) assert_equal ~printer:(fun x->x) - "" + "((not ex z0 ((P(z0) and (ex y0 ((R(y0, z0) and P(y0) and ex x0 ((R(x0, y0) and P(x0))))) or ex y0 ((C(y0, z0) and P(y0) and ex x0 ((C(x0, y0) and P(x0))))) or ex y0 ((P(y0) and ex x0 ((P(x0) and (ex u ((C(z0, u) and R(y0, u) and ex v ((C(y0, v) and R(x0, v))))) or ex u0 ((C(u0, z0) and R(y0, u0) and ex v0 ((C(v0, y0) and R(x0, v0)))))))))))))) and ((P(z) and (not Q(z)) and (C(y, z) and (not Q(y)) and (C(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (C(y, z) and (not Q(z)) and (C(x, y) and (not Q(x))))) or (P(z) and (not Q(z)) and (R(y, z) and (not Q(y)) and (R(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (R(y, z) and (not Q(z)) and (R(x, y) and (not Q(x))))) or (P(x) and (not Q(x)) and (R(x, y) and (not Q(y)) and (R(y, z) and (not Q(z))))) or (P(x) and (not Q(x)) and (C(x, y) and (not Q(y)) and (C(y, z) and (not Q(z))))) or ((not Q(z)) and ex u ((C(u, z) and (R(y, u) and P(y) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v0 ((R(x, v0) and (C(y, v0) and (not Q(y)) and ex u0 ((R(y, u0) and (C(z, u0) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u0 ((C(z, u0) and (R(y, u0) and (not Q(y)) and ex v0 ((C(y, v0) and (R(x, v0) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v ((R(x, v) and (C(v, y) and (not Q(y)) and ex u ((R(y, u) and (C(u, z) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u ((C(u, z) and (R(y, u) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(y) and (not Q(y)) and ex u0 ((R(y, u0) and ex v0 ((C(y, v0) and (C(z, u0) and (not Q(z)) and (R(x, v0) and (not Q(x)))))))))))" (Formula.str (FFSolver.normalize_for_model ttt heur_phi)); ); - "ff_tnf: gomoku heuristic with negative subtask" >:: - (fun () -> - skip_if true "ttt enough"; - let heur_phi = formula_of_str - "(((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 - ((C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) - and C(w, r) and R(v, r))) or ex r, s, t, u ((R(y, u) and R(x, t) and - R(w, s) and R(v, r) and C(u, z) and C(t, y) and C(s, x) and C(r, w)))) - and (Q(z) or Q(y) or Q(x) or Q(w) or Q(v)) and (not P(v)) and (not P(w)) - and (not P(x)) and (not P(y)) and (not P(z)) - and (not ex v, w, x, y, z ((((C(y, z) and C(x, y) and C(w, x) and - C(v, w)) or (R(y, z) and R(x, y) and R(w, x) and R(v, w)) or - ex r, s, t, u ((R(y, u) and R(x, t) and R(w, s) and R(v, r) and C(u, z) - and C(t, y) and C(s, x) and C(r, w))) or ex r, s, t, u ((C(z, u) and - R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and - R(v, r)))) and P(z) and P(y) and P(x) and P(w) and P(v)))))" - in - Printf.printf "heur_phi=%s\n%!"(Formula.str heur_phi); - let gomoku8x8 = struc_of_str -"[ | P:1 { }; Q:1 { } | ] \" - ... ... ... ... - ... ... ... ... -... ... ... ... -... ... ... ... - ... ... ... ... - ... ... ... ... -... ... ... ... -... ... ... ... - ... ... ... ... - ... ... ... ... -... ... ... ... -... ... ... ... - ... ... ... ... - ... ... ... ... -... ... ... ... -... ... ... ... -\"" in - (* FFTNF.debug_level := 3; *) - assert_equal ~printer:(fun x->x) - "" - (Formula.str (FFSolver.normalize_for_model - gomoku8x8 heur_phi)); - ); - ] let a = This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-29 17:40:13
|
Revision: 1208 http://toss.svn.sourceforge.net/toss/?rev=1208&view=rev Author: lukaszkaiser Date: 2010-11-29 17:40:07 +0000 (Mon, 29 Nov 2010) Log Message: ----------- Two versions of fo tc construction, chess work. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Formula/FormulaOps.mli trunk/Toss/Formula/FormulaOpsTest.ml trunk/Toss/Formula/FormulaParser.mly trunk/Toss/examples/Chess.toss Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-11-29 09:49:01 UTC (rev 1207) +++ trunk/Toss/Formula/FormulaOps.ml 2010-11-29 17:40:07 UTC (rev 1208) @@ -269,16 +269,30 @@ All ([(frX :> var)], Or [Not inphi; In (yv, frX)]) (* First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *) -let rec make_fo_tc k x y phi = +let rec make_fo_tc_conj k x y phi = let (xv, yv) = (fo_var_of_string x, fo_var_of_string y) in if k = 0 then Eq (xv, yv) else if k = 1 then Or [Eq (xv, yv); phi] else let (fv, k1, k2) = (free_vars phi, k / 2, k - (k / 2)) in let (_, t) = subst_name_avoiding fv (var_of_string "t") in - let (phi1, phi2) = (make_fo_tc k1 x y phi, make_fo_tc k2 x y phi) in + let (phi1, phi2) = + (make_fo_tc_conj k1 x y phi, make_fo_tc_conj k2 x y phi) in let (phi1s, phi2s) = (subst_vars_check [(y,t)] phi1, subst_vars_check [(x,t)] phi2) in Ex ([var_of_string t], And [phi1s; phi2s]) +(* First-order [k]-step refl. transitive closure of [phi], disjunctive form. *) +let make_fo_tc_disj k x y phi = + let (fv, xv, yv) = (free_vars phi, fo_var_of_string x, fo_var_of_string y) in + let (_, t) = subst_name_avoiding fv (var_of_string "t") in + let phi_t = subst_vars_check [(y,t)] phi in + let rec k_step i = + if i = 0 then [Eq (xv, yv)] else if i = 1 then phi::[Eq (xv, yv)] else + let lst = k_step (i-1) in + let psi = subst_vars_check [(x,t)] (List.hd lst) in + Ex ([var_of_string t], And [phi_t; psi]) :: lst in + Or (List.rev (k_step k)) + + (* --------- SUBSTITUTE DEFINED RELATIONS ------------ *) Modified: trunk/Toss/Formula/FormulaOps.mli =================================================================== --- trunk/Toss/Formula/FormulaOps.mli 2010-11-29 09:49:01 UTC (rev 1207) +++ trunk/Toss/Formula/FormulaOps.mli 2010-11-29 17:40:07 UTC (rev 1208) @@ -60,8 +60,10 @@ val make_tc : string -> string -> formula -> formula (* First-order [k]-step refl. transitive closure of [phi] over [x] and [y]. *) -val make_fo_tc : int -> string -> string -> formula -> formula +val make_fo_tc_conj : int -> string -> string -> formula -> formula +val make_fo_tc_disj : int -> string -> string -> formula -> formula + (* -------------------------- Simplification ------------------------------ *) (* Recursively simplify a formula *) Modified: trunk/Toss/Formula/FormulaOpsTest.ml =================================================================== --- trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-29 09:49:01 UTC (rev 1207) +++ trunk/Toss/Formula/FormulaOpsTest.ml 2010-11-29 17:40:07 UTC (rev 1208) @@ -286,13 +286,16 @@ "first-order transitive closure creation" >:: (fun () -> let tc_eq k x y phi1 phi2 = - formula_eq id phi2 (FormulaOps.make_fo_tc k x y) phi1 in + formula_eq id phi2 (FormulaOps.make_fo_tc_conj k x y) phi1 in tc_eq 2 "x" "y" "R(x, y)" "ex t((x=t or R(x,t)) and (t=y or R(t,y)))"; tc_eq 3 "x" "y" "R(x, y, t)" "ex t0 ( (x = t0 or R(x, t0, t)) and ex t1 ( (t0 = t1 or R(t0, t1, t)) and (t1 = y or R(t1, y, t)) ) )"; tc_eq 5 "x" "y" "R(x, y)" "ex t ( ex t0 ( ((x = t0) or R(x, t0)) and ((t0 = t) or R(t0, t)) ) and ex t0( ((t = t0) or R(t, t0)) and ex t1 ( (t0 = t1 or R(t0, t1)) and (t1 = y or R(t1, y)) )))"; + let tc_eq k x y phi1 phi2 = + formula_eq id phi2 (FormulaOps.make_fo_tc_disj k x y) phi1 in + tc_eq 2 "x" "y" "R(x, y)" "x = y or R(x, y) or ex t(R(x,t) and R(t,y))"; ); ] ;; Modified: trunk/Toss/Formula/FormulaParser.mly =================================================================== --- trunk/Toss/Formula/FormulaParser.mly 2010-11-29 09:49:01 UTC (rev 1207) +++ trunk/Toss/Formula/FormulaParser.mly 2010-11-29 17:40:07 UTC (rev 1208) @@ -77,7 +77,7 @@ | EX var_list formula_expr { Ex ($2, $3) } | ALL var_list formula_expr { All ($2, $3) } | TC ID COMMA ID formula_expr { FormulaOps.make_tc $2 $4 $5 } - | TC INT ID COMMA ID formula_expr { FormulaOps.make_fo_tc $2 $3 $5 $6 } + | 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 OR formula_expr { Or [$1; $3] } Modified: trunk/Toss/examples/Chess.toss =================================================================== --- trunk/Toss/examples/Chess.toss 2010-11-29 09:49:01 UTC (rev 1207) +++ trunk/Toss/examples/Chess.toss 2010-11-29 17:40:07 UTC (rev 1208) @@ -1,6 +1,4 @@ PLAYERS 1, 2 -REL WinW() = false -REL WinB() = false REL IsFirst(x) = not ex z C(z, x) REL IsSecond(x) = ex y (C(y, x) and IsFirst(y)) REL IsEight(x) = not ex z C(y, z) @@ -19,6 +17,23 @@ REL Diag1 (x, y) = ex z (FreeD1 (x, z) and (z = y or D1 (z, y))) REL Diag2 (x, y) = ex z (FreeD2 (x, z) and (z = y or D2 (z, y))) REL Diag (x, y) = Diag1 (x, y) or Diag2 (x, y) +REL FreeC (x, y) = tc 6 x, y ((C(x, y) or C(y, x)) and not w(y) and not b(y)) +REL FreeR (x, y) = tc 6 x, y ((R(x, y) or R(y, x)) and not w(y) and not b(y)) +REL Col (x, y) = ex z (FreeC (x, z) and (z = y or (C(z, y) or C(y, z)))) +REL Row (x, y) = ex z (FreeR (x, z) and (z = y or (R(z, y) or R(y, z)))) +REL Line (x, y) = Col (x, y) or Row (x, y) +REL wPBeats (x) = ex y (wP(y) and ex z ((R(y, z) or R(z, y)) and C(z, x))) +REL bPBeats (x) = ex y (bP(y) and ex z ((R(y, z) or R(z, y)) and C(x, z))) +REL wDiagBeats (x) = ex y ((wQ(y) or wB(y)) and Diag(y, x)) +REL bDiagBeats (x) = ex y ((bQ(y) or bB(y)) and Diag(y, x)) +REL wLineBeats (x) = ex y ((wQ(y) or wR(y)) and Line(y, x)) +REL bLineBeats (x) = ex y ((bQ(y) or bR(y)) and Line(y, x)) +REL wFigBeats(x) = wDiagBeats(x) or wLineBeats(x) or ex y(wN(y) and Knight(y,x)) +REL bFigBeats(x) = bDiagBeats(x) or bLineBeats(x) or ex y(bN(y) and Knight(y,x)) +REL wBeats(x) = wFigBeats(x) or wPBeats(x) +REL bBeats(x) = bFigBeats(x) or bPBeats(x) +REL CheckW() = ex x (wK(x) and bBeats(x)) +REL CheckB() = ex x (bK(x) and wBeats(x)) RULE WhitePawnMove: [ | | ] " ... @@ -30,7 +45,7 @@ wP . -" emb w, b pre not WinB() +" emb w, b post not CheckW() RULE BlackPawnMove: [ | | ] " ... @@ -42,7 +57,7 @@ ... bP -" emb w, b pre not WinW() +" emb w, b post not CheckB() RULE WhitePawnMoveDbl: [ | | ] " @@ -58,7 +73,7 @@ . ... ... -" emb w, b pre IsSecond(a1) and not WinB() +" emb w, b pre IsSecond(a1) post not CheckW() RULE BlackPawnMoveDbl: [ | | ] " ... @@ -74,7 +89,7 @@ ... bP -" emb w, b pre IsSeventh(a3) and not WinW() +" emb w, b pre IsSeventh(a3) post not CheckB() RULE WhitePawnRight: [ | | ] " ... @@ -86,7 +101,7 @@ ?..wP ... . ?.. -" emb w, b pre not WinB() +" emb w, b post not CheckW() RULE WhitePawnLeft: [ | | ] " ... @@ -98,7 +113,7 @@ wP.? ... ? ... -" emb w, b pre not WinB() +" emb w, b post not CheckW() RULE WhitePawnRightDbl: [ | | ] " ... @@ -114,7 +129,7 @@ ? wP. ... .... -" emb w, b pre not WinB() +" emb w, b post not CheckW() RULE WhitePawnLeftDbl: [ | | ] " ... @@ -130,7 +145,7 @@ wP ?.. ... .... -" emb w, b pre not WinB() +" emb w, b post not CheckW() RULE BlackPawnRight: [ | | ] " ... @@ -142,7 +157,7 @@ ...? ... ? bP. -" emb w, b pre not WinW() +" emb w, b post not CheckB() RULE BlackPawnLeft: [ | | ] " ... @@ -154,7 +169,7 @@ ?... ... bP ?.. -" emb w, b pre not WinW() +" emb w, b post not CheckB() RULE BlackPawnRightDbl: [ | | ] " ... @@ -170,7 +185,7 @@ ? bP. ... ?... -" emb w, b pre not WinW() +" emb w, b post not CheckB() RULE BlackPawnLeftDbl: [ | | ] " ... @@ -186,40 +201,68 @@ bP ?.. ... ...? -" emb w, b pre not WinW() +" emb w, b post not CheckB() RULE WhiteKnight: [ a, b | wN { a }; _opt_b { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] -> [ a, b | wN { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Knight(a, b) and not WinB() + emb w, b pre Knight(a, b) post not CheckW() RULE BlackKnight: [ a, b | bN { a }; _opt_w { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] -> [ a, b | bN { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Knight(a, b) and not WinW() + emb w, b pre Knight(a, b) post not CheckB() RULE WhiteBishop: [ a, b | wB { a }; _opt_b { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] -> [ a, b | wB { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Diag(a, b) and not WinB() + emb w, b pre Diag(a, b) post not CheckW() RULE BlackBishop: [ a, b | bB { a }; _opt_w { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] -> [ a, b | bB { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] - emb w, b pre Diag(a, b) and not WinW() + emb w, b pre Diag(a, b) post not CheckB() +RULE WhiteRook: + [ a, b | wR { a }; _opt_b { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + -> + [ a, b | wR { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + emb w, b pre Line(a, b) post not CheckW() +RULE BlackRook: + [ a, b | bR { a }; _opt_w { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + -> + [ a, b | bR { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + emb w, b pre Line(a, b) post not CheckB() +RULE WhiteQueen: + [ a, b | wQ { a }; _opt_b { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + -> + [ a, b | wQ { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckW() +RULE BlackQueen: + [ a, b | bQ { a }; _opt_w { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + -> + [ a, b | bQ { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB() LOC 0 { PLAYER 1 PAYOFF { - 1: :(WinW()) - :(WinB()); - 2: :(WinB()) - :(WinW()) + 1: :(CheckB()) - :(CheckW()); + 2: :(CheckW()) - :(CheckB()) } MOVES [WhitePawnMove -> 1]; @@ -229,7 +272,9 @@ [WhitePawnRight -> 1]; [WhitePawnRightDbl -> 1]; [WhiteKnight -> 1]; - [WhiteBishop -> 1] + [WhiteBishop -> 1]; + [WhiteRook -> 1]; + [WhiteQueen -> 1] } LOC 1 { PLAYER 2 @@ -245,7 +290,9 @@ [BlackPawnRight -> 0]; [BlackPawnRightDbl -> 0]; [BlackKnight -> 0]; - [BlackBishop -> 0] + [BlackBishop -> 0]; + [BlackRook -> 0]; + [BlackQueen -> 0] } MODEL [ | | ] " This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-29 20:19:46
|
Revision: 1209 http://toss.svn.sourceforge.net/toss/?rev=1209&view=rev Author: lukaszkaiser Date: 2010-11-29 20:19:39 +0000 (Mon, 29 Nov 2010) Log Message: ----------- Preconditions checking and a step towards full chess definition. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/ContinuousRule.ml trunk/Toss/Arena/ContinuousRule.mli trunk/Toss/examples/Chess.toss Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2010-11-29 17:40:07 UTC (rev 1208) +++ trunk/Toss/Arena/Arena.ml 2010-11-29 20:19:39 UTC (rev 1209) @@ -783,7 +783,7 @@ | GetRuleMatches (r_name) -> ( try let r = List.assoc r_name state.game.rules in - let matches = ContinuousRule.matches struc r in + let matches = ContinuousRule.matches_post struc r state.time in (* matches are from LHS to model *) let name (lhs,rhs) = Structure.elem_str (ContinuousRule.lhs r) lhs ^ " -> " ^ Modified: trunk/Toss/Arena/ContinuousRule.ml =================================================================== --- trunk/Toss/Arena/ContinuousRule.ml 2010-11-29 17:40:07 UTC (rev 1208) +++ trunk/Toss/Arena/ContinuousRule.ml 2010-11-29 20:19:39 UTC (rev 1209) @@ -79,17 +79,6 @@ (List.hd ids, List.map List.hd llst) :: (select_pos (List.tl ids) (List.map List.tl llst)) -(* Helper function to add a defined relation to structure. *) -(* let add_def_rel struc (r_name, (vars, _, reg_def)) = - let def_asg = SolverIntf.M.evaluate struc reg_def in - match def_asg with - | AssignmentSet.Empty -> - Structure.add_rel_name r_name (List.length vars) struc - | _ -> - let tuples = AssignmentSet.tuples struc.Structure.elements vars def_asg in - Structure.add_rels struc r_name tuples -*) - (* For now, we rewrite only single rules. *) let rewrite_single struc cur_time m r t params = let time = ref cur_time in @@ -187,6 +176,17 @@ (DiscreteRule.rule_str r.discrete) ^ " " ^ dyn_str ^ upd_str ^ pre_str ^ inv_str ^ post_str + +(* Matches which satisfy postcondition with time 1 and empty params *) +let matches_post struc r cur_time = + let is_ok m = + let (res_struc, _, _) = rewrite_single struc cur_time m r 1. [] in + SolverIntf.M.check_formula res_struc r.post_pp in + if r.post = Formula.And [] then matches struc r else + List.filter is_ok (matches struc r) + + + let has_dynamics r = r.dynamics <> [] (* List.exists (fun (_, t) -> t <> Term.Const 0.) r.dynamics *) Modified: trunk/Toss/Arena/ContinuousRule.mli =================================================================== --- trunk/Toss/Arena/ContinuousRule.mli 2010-11-29 17:40:07 UTC (rev 1208) +++ trunk/Toss/Arena/ContinuousRule.mli 2010-11-29 20:19:39 UTC (rev 1209) @@ -60,7 +60,10 @@ (* Find all matches of [r] in [struc] which satisfy [r]'s precondition. *) val matches : Structure.structure -> rule -> (int * int) list list +(* Matches which satisfy postcondition with time 1 and empty params *) +val matches_post : Structure.structure -> rule -> float -> (int * int) list list + (* --------------------------- REWRITING ------------------------------------ *) (* For now, we rewrite only single rules. Modified: trunk/Toss/examples/Chess.toss =================================================================== --- trunk/Toss/examples/Chess.toss 2010-11-29 17:40:07 UTC (rev 1208) +++ trunk/Toss/examples/Chess.toss 2010-11-29 20:19:39 UTC (rev 1209) @@ -22,6 +22,7 @@ REL Col (x, y) = ex z (FreeC (x, z) and (z = y or (C(z, y) or C(y, z)))) REL Row (x, y) = ex z (FreeR (x, z) and (z = y or (R(z, y) or R(y, z)))) REL Line (x, y) = Col (x, y) or Row (x, y) +REL Near (x, y) = C(x,y) or C(y,x) or R(x,y) or R(y,x) or D1(x, y) or D2(x, y) REL wPBeats (x) = ex y (wP(y) and ex z ((R(y, z) or R(z, y)) and C(z, x))) REL bPBeats (x) = ex y (bP(y) and ex z ((R(y, z) or R(z, y)) and C(x, z))) REL wDiagBeats (x) = ex y ((wQ(y) or wB(y)) and Diag(y, x)) @@ -30,8 +31,8 @@ REL bLineBeats (x) = ex y ((bQ(y) or bR(y)) and Line(y, x)) REL wFigBeats(x) = wDiagBeats(x) or wLineBeats(x) or ex y(wN(y) and Knight(y,x)) REL bFigBeats(x) = bDiagBeats(x) or bLineBeats(x) or ex y(bN(y) and Knight(y,x)) -REL wBeats(x) = wFigBeats(x) or wPBeats(x) -REL bBeats(x) = bFigBeats(x) or bPBeats(x) +REL wBeats(x) = wFigBeats(x) or wPBeats(x) or ex y (wK(y) and Near(y, x)) +REL bBeats(x) = bFigBeats(x) or bPBeats(x) or ex y (bK(y) and Near(y, x)) REL CheckW() = ex x (wK(x) and bBeats(x)) REL CheckB() = ex x (bK(x) and wBeats(x)) RULE WhitePawnMove: @@ -202,6 +203,30 @@ ... ...? " emb w, b post not CheckB() +RULE WhitePawnPromote: + [ | | ] " + ... + ... + + wP +" -> [ | | ] " + ... + wQ. + + . +" emb w, b pre IsEight(a2) post not CheckW() +RULE BlackPawnPromote: + [ | | ] " + ... + bP. + + . +" -> [ | | ] " + ... + ... + + bQ +" emb w, b pre IsFirst(a1) post not CheckB() RULE WhiteKnight: [ a, b | wN { a }; _opt_b { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] @@ -258,6 +283,20 @@ [ a, b | bQ { b } | vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] emb w, b pre (Line(a, b) or Diag(a, b)) post not CheckB() +RULE WhiteKing: + [ a, b | wK { a }; _opt_b { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + -> + [ a, b | wK { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + emb w, b pre Near(a, b) post not CheckW() +RULE BlackKing: + [ a, b | bK { a }; _opt_w { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + -> + [ a, b | bK { b } | + vx {a->0.,b->10.}; vy {a->0.,b->0.}; x {a->0.,b->10.}; y {a->0.,b->10.} ] + emb w, b pre Near(a, b) post not CheckB() LOC 0 { PLAYER 1 PAYOFF { @@ -271,10 +310,12 @@ [WhitePawnLeftDbl -> 1]; [WhitePawnRight -> 1]; [WhitePawnRightDbl -> 1]; + [WhitePawnPromote -> 1]; [WhiteKnight -> 1]; [WhiteBishop -> 1]; [WhiteRook -> 1]; - [WhiteQueen -> 1] + [WhiteQueen -> 1]; + [WhiteKing -> 1] } LOC 1 { PLAYER 2 @@ -289,10 +330,12 @@ [BlackPawnLeftDbl -> 0]; [BlackPawnRight -> 0]; [BlackPawnRightDbl -> 0]; + [BlackPawnPromote -> 0]; [BlackKnight -> 0]; [BlackBishop -> 0]; [BlackRook -> 0]; - [BlackQueen -> 0] + [BlackQueen -> 0]; + [BlackKing -> 0] } MODEL [ | | ] " This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-30 00:13:33
|
Revision: 1210 http://toss.svn.sourceforge.net/toss/?rev=1210&view=rev Author: lukstafi Date: 2010-11-30 00:13:26 +0000 (Tue, 30 Nov 2010) Log Message: ----------- Heuristic: clarified handling of quantifiers. FFTNF: subtasks bugfixes and cleanup. FFSolver: extensive diagnostic logging, disjunction rewrite bugfixes. Modified Paths: -------------- trunk/Toss/Formula/FFTNF.ml trunk/Toss/Formula/FFTNFTest.ml trunk/Toss/Play/Heuristic.ml trunk/Toss/Play/HeuristicTest.ml trunk/Toss/Solver/FFSolver.ml trunk/Toss/Solver/FFSolverTest.ml Modified: trunk/Toss/Formula/FFTNF.ml =================================================================== --- trunk/Toss/Formula/FFTNF.ml 2010-11-29 20:19:39 UTC (rev 1209) +++ trunk/Toss/Formula/FFTNF.ml 2010-11-30 00:13:26 UTC (rev 1210) @@ -259,7 +259,7 @@ and tree_node = | TProc of int * formula (* processed literal *) | TLit of formula (* unprocessed literal *) - | TNot_subtask of tree_node + | TNot_subtask of formula (* process recursively separately from the rest, doesn't have free variables *) | TAnd of tree list @@ -344,7 +344,7 @@ let rec aux = function | {t=TProc (_,lit)} -> lit | {t=TLit lit} -> lit - | {t=TNot_subtask subt} -> Not (aux {fvs=Vars.empty; t=subt}) + | {t=TNot_subtask subt} -> Not subt | {t=TAnd subts} -> And (List.map aux subts) | {t=TOr subts} -> Or (List.map aux subts) | {t=TAll (vs, subt)} -> All (Vars.elements vs, aux subt) @@ -504,52 +504,12 @@ {fvs=Vars.empty; t=TAnd (subts_proc @ subts)} | {t=TAll (vs, phi)} -> - let phi = loop phi in - begin match phi with - | {t=TAnd conjs} -> - let task_conjs, conjs = - Aux.partition_map (function - | {t=TNot_subtask _} as subt -> Left subt - | subt -> Right subt) conjs in - if task_conjs <> [] then - {fvs=Vars.empty; t=TAnd (task_conjs @ [ - {fvs=Vars.empty; t=TAll (vs, {fvs=Vars.empty; t=TAnd conjs})} - ])} - else - {fvs=Vars.empty; t=TAll (vs, {fvs=Vars.empty; t=TAnd conjs})} - | _ -> - {fvs=Vars.empty; t=TAll (vs, phi)} - end + {fvs=Vars.empty; t=TAll (vs, loop phi)} | {t=TEx (vs, phi)} -> - let phi = loop phi in - begin match phi with - | {t=TAnd conjs} -> - let task_conjs, conjs = - Aux.partition_map (function - | {t=TNot_subtask _} as subt -> Left subt - | subt -> Right subt) conjs in - if task_conjs <> [] then - {fvs=Vars.empty; t=TAnd (task_conjs @ [ - {fvs=Vars.empty; t=TEx (vs, {fvs=Vars.empty; t=TAnd conjs})} - ])} - else - {fvs=Vars.empty; t=TEx (vs, {fvs=Vars.empty; t=TAnd conjs})} - | _ -> - {fvs=Vars.empty; t=TEx (vs, phi)} - end + {fvs=Vars.empty; t=TEx (vs, loop phi)} - | {t=TNot_subtask phi} -> - begin - try - let phi = loop {fvs=Vars.empty; t=phi} in - {fvs=Vars.empty; t=TNot_subtask phi.t} - with - | Simpl_true -> raise Simpl_false - | Simpl_false -> raise Simpl_true - end - - | ({t=TLit _} | {t=TProc _}) as lit -> lit in + | {t=TNot_subtask _} | ({t=TLit _} | {t=TProc _}) as proc -> proc in try formula_of_tree (loop tree) with | Simpl_true -> And [] @@ -575,8 +535,8 @@ prefix Top (p_pn_nnf phi) in let phi = FormulaOps.flatten_formula phi in let rec to_tree = function - | Not (Ex _ as phi) -> - {fvs=Vars.empty; t=TNot_subtask (to_tree phi).t} + | Not (Ex _ as phi) -> (* assumes [phi] is ground! *) + {fvs=Vars.empty; t=TNot_subtask phi} | (Rel _ | Eq _ | In _ | RealExpr _ | Not _) as lit -> {fvs=vars_of_list (FormulaOps.all_vars lit); t=TLit lit} | And conjs -> @@ -707,7 +667,8 @@ match task_lit with | Left subt -> Vars.empty, - lazy {fvs=Vars.empty; t=TProc (task_id, Not (subproc subt))} + (* it's a TNot_subtask, the negation is added by [subproc] *) + lazy {fvs=Vars.empty; t=TProc (task_id, subproc subt)} | Right (lit, lit_vs) -> lit_vs, lazy {fvs=lit_vs; t=TProc (task_id, lit)} in match loc.x with @@ -917,8 +878,7 @@ let _ = if !debug_level > 2 then begin printf "\nfound_subtask-literal: %s\n" (match subt_lit with - | Left subt -> - Formula.str (formula_of_tree {fvs=Vars.empty;t=subt}) + | Left subt -> Formula.str (Not subt) | Right (lit,_) -> Formula.str lit); printf "location: %s\n" (location_str loc) end in let phi = pull_out subproc (i, subt_lit) loc in @@ -934,8 +894,12 @@ result and subproc subt = - let loc = {x=Top; n={fvs=Vars.empty; t=subt}} in - flatten_tree_to_formula (loop 0 loc) in + let loc = init subt in + let _ = if !debug_level > 2 then + printf "\ninit_subtask_location: %s\n" (location_str loc) in + (* Whatever the recursive call result, it will not spoil the TNF + property because we must land outside of quantifiers anyway. *) + Not (flatten_tree_to_formula (loop 0 loc)) in let res = loop 0 loc in if !debug_level > 1 then Modified: trunk/Toss/Formula/FFTNFTest.ml =================================================================== --- trunk/Toss/Formula/FFTNFTest.ml 2010-11-29 20:19:39 UTC (rev 1209) +++ trunk/Toss/Formula/FFTNFTest.ml 2010-11-30 00:13:26 UTC (rev 1210) @@ -177,7 +177,7 @@ (formula_of_str "ex x, y, z (C(x, z) and ((R(x,y) and (P(x) or C(y,z))) or Q(z)))"))); ); - "ff_tnf: subtasks" >:: + "ff_tnf: simple subtasks" >:: (fun () -> assert_equal ~printer:(fun x->x) "(not ex z (((not Q(z)) and (ex x, y ((not R(x, y))) or ex y (((not C(y, z)) and ex x ((not P(x)))))))))" @@ -192,6 +192,24 @@ (formula_of_str "ex x, y (C(x, y) or (P(y) and all z Q(z)))"))); ); + "ff_tnf: tic-tac-toe subtask" >:: + (fun () -> + let heur_phi = "(((R(x, y) and R(y, z)) or + (C(x, y) and C(y, z)) or ex t, u + ((C(z, u) and R(y, u) and C(y, t) and R(x, t))) or ex t, u ((R(y, u) and R(x, t) and C(u, z) and C(t, y)))) + and (Q(z) or Q(y) or Q(x)) + and (not P(x)) and (not P(y)) and (not P(z))" ^ + "and (not ex x, y, z ((((C(y, z) and C(x, y)) or (R(y, z) and R(x, y)) or + ex t, u ((R(y, u) and R(x, t) and C(u, z) + and C(t, y))) or ex t, u ((C(z, u) and + R(y, u) and C(y, t) and R(x, t)))) and P(z) and P(y) and P(x)))))" in + assert_equal ~printer:(fun x->x) + "((not ex x ((P(x) and (ex y ((C(x, y) and P(y) and ex z ((C(y, z) and P(z))))) or ex y ((R(x, y) and P(y) and ex z ((R(y, z) and P(z))))) or ex t ((R(x, t) and ex y ((C(y, t) and P(y) and ex u ((R(y, u) and ex z ((C(z, u) and P(z))))))))) or ex t0 ((R(x, t0) and ex y ((C(t0, y) and P(y) and ex u0 ((R(y, u0) and ex z ((C(u0, z) and P(z))))))))))))) and (not P(x)) and (not P(z)) and (not P(y)) and ((R(y, z) and R(x, y)) or (C(y, z) and C(x, y)) or ex t ((C(t, y) and R(x, t) and ex u ((R(y, u) and C(u, z))))) or ex t0 ((R(x, t0) and C(y, t0) and ex u0 ((C(z, u0) and R(y, u0)))))) and (Q(x) or Q(z) or Q(y)))" + (Formula.str (FFTNF.ff_tnf + (FFTNF.promote_rels (Aux.strings_of_list ["P"; "Q"])) + (formula_of_str heur_phi))); + ); + ] let a = Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2010-11-29 20:19:39 UTC (rev 1209) +++ trunk/Toss/Play/Heuristic.ml 2010-11-30 00:13:26 UTC (rev 1210) @@ -50,15 +50,18 @@ Algorithm Alg(Ex(V,Phi), Guard0): - 1: Segregate Phi into Guard/\Subgoals where Guard is a conjunction - of formulas without existential quantifiers and each conjunct in - Subgoals contains an existential quantifier. + 1: Segregate Phi into Guard/\Subgoals where Guard is a boolean + combination of atoms and quantified subformulas + universal-in-positive / existential-in-negative positions, and each + conjunct in Subgoals contains a positive occurrence of existential + quantifier (not in scope of any other quantifier). 2: Reduce Subgoals to DNF treating quantified subformulas opaquely. - 3: Each disjunct Dj is a conjunction of literals and quantified - formulas. Split the conjuncts into existential quantifications - {Ex(Vj1,Ej1), ..., Ex(Vjn,Ejn)} and others (Gj). Let + 3: Each disjunct Dj is a conjunction of literals and existentially + quantified formulas. Split the conjuncts into existential + quantifications {Ex(Vj1,Ej1), ..., Ex(Vjn,Ejn)} and others + (Gj). Let Rji=Alg(Ex(Vji,Eji),Gj) @@ -662,15 +665,15 @@ | And conjs -> gproduct List.append [] (List.map (limited_dnf neg) conjs) | Or disjs -> Aux.concat_map (limited_dnf neg) disjs - | Ex (vs, psi) as phi -> - [[if neg then All (vs, Not psi) else phi]] + | Ex _ as phi -> + [[if neg then Not phi else phi]] | All (vs, psi) as phi -> [[if neg then Ex (vs, Not psi) else phi]] -let rec has_existential = function - | Not phi -> has_existential phi - | And phs | Or phs -> List.exists has_existential phs - | Ex _ -> true | _ -> false +let rec has_pos_existential ?(neg=false) = function + | Not phi -> has_pos_existential ~neg:(not neg) phi + | And phs | Or phs -> List.exists (has_pos_existential ~neg) phs + | Ex _ -> not neg | All _ -> neg | _ -> false let rec map_constants f = function @@ -714,7 +717,7 @@ let conjs = match phi with | And conjs | Or [And conjs] -> conjs | _ -> [phi] in - let subgoals, guard = List.partition has_existential conjs in + let subgoals, guard = List.partition has_pos_existential conjs in if subgoals = [] then (* bottoming-out of recursion; [Const 1.] is the weight *) if vs = [] then @@ -789,15 +792,6 @@ ) guards in sum_exprs parts -let has_universal phi= - let rec aux neg = function - | Not phi -> aux (not neg) phi - | And phs | Or phs -> List.exists (aux neg) phs - | All (_, phi) -> not neg || aux neg phi - | Ex (_, phi) -> neg || aux neg phi - | _ -> false in - aux false phi - let of_payoff ?(max_alt_descr=5) ?struc ?fluent_preconds adv_ratio frels expr = (* FIXME: what [gds] should be doing? it's not doing anything *) let rec aux gds = function Modified: trunk/Toss/Play/HeuristicTest.ml =================================================================== --- trunk/Toss/Play/HeuristicTest.ml 2010-11-29 20:19:39 UTC (rev 1209) +++ trunk/Toss/Play/HeuristicTest.ml 2010-11-30 00:13:26 UTC (rev 1210) @@ -276,7 +276,7 @@ "of_payoff: non-existential" >:: (fun () -> assert_equal ~printer:(fun x->x) - "((0.66 + (1. * :(all x (P(x))))) + Sum (y | (Q(y) and all z (R(y, z))) : 1.))" + "((0.66 + (1. * :((not ex x ((not P(x))))))) + Sum (y | (Q(y) and all z (R(y, z))) : 1.))" (Formula.real_str (Heuristic.map_constants (fun c->(floor (c*.100.))/.100.) (Heuristic.of_payoff 1.5 Modified: trunk/Toss/Solver/FFSolver.ml =================================================================== --- trunk/Toss/Solver/FFSolver.ml 2010-11-29 20:19:39 UTC (rev 1209) +++ trunk/Toss/Solver/FFSolver.ml 2010-11-30 00:13:26 UTC (rev 1210) @@ -149,7 +149,7 @@ map_try ?catch f tl let rec fold_try ?catch f accu = function - | [] -> [] + | [] -> accu | hd::tl -> try fold_try ?catch f (f accu hd) tl @@ -212,6 +212,35 @@ failwith "FFSolver: Real/MSO assignments not supported yet" in aux aset +let rec aset_fo_vars = function + | A.Empty | A.Any -> [] + | A.FO (v, assgns) -> + v :: Aux.concat_map aset_fo_vars (List.map snd assgns) + | A.Real _ | A.MSO _ -> + failwith "FFSolver: Real/MSO assignments not supported yet" + +(* For debugging. Brute force check. *) +let aset_subsumed all_elems a b = + let vars = aset_fo_vars a in + let asbs = A.fo_assgn_to_list all_elems vars a in + let asbs = + Aux.unique (=) (List.map (List.sort Pervasives.compare) asbs) in + let bsbs = A.fo_assgn_to_list all_elems vars b in + let asbs = + Aux.unique (=) (List.map (List.sort Pervasives.compare) bsbs) in + (* {{{ log entry *) + if !debug_level > 3 then ( + printf "subsumption: test %d <= %d\n%!" + (List.length asbs) (List.length bsbs); + ); + (* }}} *) + List.for_all (fun asb -> + List.exists (fun bsb -> + try + List.for_all (fun (v,ae) -> + List.assoc v bsb = ae) asb + with Not_found -> false) bsbs) asbs + (* We assume that for every "not ex psi" subformula, "ex psi" is ground, and that every other occurrence of negation is in a literal (it is guaranteed by @@ -284,7 +313,8 @@ (e4) apply the case (c) *) -let rec merge all_elems v init_domain sb cur_aset eval_cont = +(* Model used only for debugging. *) +let rec merge model all_elems v init_domain sb cur_aset eval_cont = match cur_aset with | A.MSO _ | A.Real _ -> failwith "FFSolver.evaluate: MSO and Real not supported yet" @@ -329,12 +359,13 @@ e, project_v_on_elem v e cur_aset in let cur_aset = A.FO (v, map_try pull_v all_elems) in - merge all_elems v init_domain sb cur_aset eval_cont + merge model all_elems v init_domain sb cur_aset eval_cont (* "Negate" the second assignment set wrt. [all_elems] and add it to the first aset. *) -let rec add_complement all_elems disj_aset = function +(* Model used only for debugging. *) +let rec add_complement model all_elems disj_aset = function | A.Empty -> A.Any | A.Any -> if disj_aset = A.Empty then raise Unsatisfiable; @@ -346,14 +377,21 @@ let cset = (* Empty will turn into Any on recursive callback *) try List.assoc e assgns with Not_found -> A.Empty in - add_complement all_elems dset cset in - merge all_elems v all_elems [] disj_aset add_cont + add_complement model all_elems dset cset in + merge model all_elems v all_elems [] disj_aset add_cont | A.Real _ | A.MSO _ -> failwith "FFSolver: Real/MSO assignments not supported yet" let evaluate model ?(sb=[]) ?(disj_aset=A.Empty) phi = + (* {{{ log entry *) + let guard_number = ref 0 in + if !debug_level > 1 then ( + printf "evaluate: phi=%s; sb=%s; disj_aset=%s\n%!" + (Formula.str phi) (sb_str model sb) (AssignmentSet.named_str model disj_aset); + ); + (* }}} *) let all_elems = Elems.elements model.elements in let num_elems = Elems.cardinal model.elements in @@ -369,17 +407,37 @@ Do not return [A.Empty], raise [Unsatisfiable] instead. *) let rec solve delayed2 delayed1 conj_cont sb cur_aset = + (* {{{ log entry *) + if !debug_level > 3 then ( + printf "solve: remaining=%s\nsolve: sb=%s\nsolve: disj_aset=%s\n%!" + (Formula.str (And (conj_cont @ delayed1 @ delayed2))) (sb_str model sb) (AssignmentSet.named_str model cur_aset); + ); + (* }}} *) (* a *) - if cur_aset = A.Any then A.Any - else match conj_cont with + if cur_aset = A.Any then ( + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "a: cur_aset=Any subsuming phi=%s\n%!" + (Formula.str (And (conj_cont @ delayed1 @ delayed2))) + ); + (* }}} *) + A.Any + ) else match conj_cont with | [] -> if delayed1 <> [] then solve delayed2 [] (List.rev delayed1) sb cur_aset else if delayed2 <> [] then solve [] [] (List.rev delayed2) sb cur_aset (* b *) - else A.Any (* subsuming [cur_aset] *) - + else ( + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "b: phi=[] subsuming cur_aset=%s\n%!" + (AssignmentSet.named_str model cur_aset); + ); + (* }}} *) + A.Any (* subsuming [cur_aset] *) + ) | Rel (relname, vtup) as atom :: conj_cont -> let tuples_s = try StringMap.find relname model.relations @@ -393,7 +451,7 @@ then solve delayed2 [] (List.rev delayed1) sb cur_aset else solve [] [] (List.rev delayed2) sb cur_aset with Not_found -> - (* we will add new variables one at a time *) + (* we will add new variables one at a time *) let nvi = Aux.array_argfind (fun v->not (List.mem_assoc v sb)) vtup in let nvar = vtup.(nvi) in @@ -404,9 +462,9 @@ if multi_unkn && conj_cont <> [] then (* delay *) solve delayed2 (atom::delayed1) conj_cont sb cur_aset else - (* to narrow the domain, lookup incidence of known vars, - filter for partial match and project on the nvar - position *) + (* to narrow the domain, lookup incidence of known vars, + filter for partial match and project on the nvar + position *) let tuples_i = try StringMap.find relname model.incidence with Not_found -> IntMap.empty in @@ -433,20 +491,28 @@ && not (List.mem tup.(nvi) dom) then tup.(nvi)::dom else dom) tuples [] in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "init_domain: sb=%s; phi=%s; dom=%s\n%!" + (sb_str model sb) (Formula.str atom) + (String.concat ", " (List.map (Structure.elem_str model) + init_domain)); + ); + (* }}} *) if init_domain = [] then raise (Unsatisfiable_FO (vars_of_array (var_tup vtup))) else if not multi_unkn && conj_cont = [] && delayed1 = [] && delayed2 = [] then (* no more vars and conjuncts *) - merge all_elems nvar init_domain sb cur_aset + merge model all_elems nvar init_domain sb cur_aset (fun _ _ -> A.Any) (* subsume *) else let conj_cont = if multi_unkn then atom::conj_cont else conj_cont in (* If not [multi_unkn] then for elements in [init_domain] rel holds *) - merge all_elems nvar init_domain sb cur_aset + merge model all_elems nvar init_domain sb cur_aset (solve delayed2 delayed1 conj_cont) ) @@ -458,7 +524,7 @@ then raise (Unsatisfiable_FO (vars_of_list (vtup :> var list))) else solve delayed2 delayed1 conj_cont sb cur_aset with Not_found -> - (* we will add new variables one at a time *) + (* we will add new variables one at a time *) let nvi, nvar = if List.mem_assoc x sb then 1, y else 0, x in let oldvars = @@ -470,16 +536,29 @@ solve (atom::delayed2) delayed1 conj_cont sb cur_aset else if multi_unkn then let conj_cont = atom::conj_cont in - merge all_elems nvar all_elems sb cur_aset + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "init_domain: sb=%s; phi=%s; dom=ALL ELEMS\n%!" + (sb_str model sb) (Formula.str atom); + ); + (* }}} *) + merge model all_elems nvar all_elems sb cur_aset (solve delayed2 delayed1 conj_cont) else let ovar = if nvi = 1 then x else y in let e = List.assoc ovar sb in - merge all_elems nvar [e] sb cur_aset + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "init_domain: sb=%s; phi=%s; dom=%s\n%!" + (sb_str model sb) (Formula.str atom) + (Structure.elem_str model e); + ); + (* }}} *) + merge model all_elems nvar [e] sb cur_aset (solve delayed2 delayed1 conj_cont) ) - (* by analogy to the [Rel (relname, vtup)] case *) + (* by analogy to the [Rel (relname, vtup)] case *) | Not (Rel (relname, vtup)) as literal :: conj_cont -> let tuples_s = try StringMap.find relname model.relations @@ -494,7 +573,7 @@ then solve delayed2 [] (List.rev delayed1) sb cur_aset else solve [] [] (List.rev delayed2) sb cur_aset with Not_found -> - (* we will add new variables one at a time *) + (* we will add new variables one at a time *) let nvi = Aux.array_argfind (fun v->not (List.mem_assoc v sb)) vtup in let nvar = vtup.(nvi) in @@ -509,9 +588,9 @@ then solve delayed2 (literal::delayed1) conj_cont sb cur_aset else if multi_unkn then - (* we cannot easily optimize *) + (* we cannot easily optimize *) let conj_cont = [literal] in - merge all_elems nvar all_elems sb cur_aset + merge model all_elems nvar all_elems sb cur_aset (solve delayed2 delayed1 conj_cont) else let tuples_i = @@ -540,12 +619,20 @@ then Elems.add tup.(nvi) dom else dom) tuples Elems.empty in Elems.elements (Elems.diff model.elements init_domain_co) in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "init_domain: sb=%s; phi=%s; dom=%s\n%!" + (sb_str model sb) (Formula.str literal) + (String.concat ", " (List.map (Structure.elem_str model) + init_domain)); + ); + (* }}} *) if init_domain = [] then raise Unsatisfiable else (* If not [multi_unkn] then for elements in [init_domain] rel does not hold *) - merge all_elems nvar init_domain sb cur_aset + merge model all_elems nvar init_domain sb cur_aset (solve delayed2 delayed1 conj_cont) ) @@ -557,7 +644,7 @@ then raise (Unsatisfiable_FO (vars_of_list ([x; y] :> var list))) else solve delayed2 delayed1 conj_cont sb cur_aset with Not_found -> - (* we will add new variables one at a time *) + (* we will add new variables one at a time *) let nvi, nvar = if List.mem_assoc x sb then 1, y else 0, x in let oldvars = @@ -569,15 +656,28 @@ solve (literal::delayed2) delayed1 conj_cont sb cur_aset else if not multi_unkn && conj_cont <> [] then solve delayed2 (literal::delayed1) conj_cont sb cur_aset - else if multi_unkn then - merge all_elems nvar all_elems sb cur_aset + else if multi_unkn then begin + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "init_domain: sb=%s; phi=%s; dom=ALL ELEMS\n%!" + (sb_str model sb) (Formula.str literal); + ); + (* }}} *) + merge model all_elems nvar all_elems sb cur_aset (solve delayed2 delayed1 (literal :: conj_cont)) - else (* optimize *) + end else (* optimize *) let ovar = if nvi = 1 then x else y in let e = List.assoc ovar sb in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "init_domain: sb=%s; phi=%s; dom=ALL ELEMS - %s\n%!" + (sb_str model sb) (Formula.str literal) + (Structure.elem_str model e); + ); + (* }}} *) let init_domain = Elems.elements (Elems.remove e model.elements) in - merge all_elems nvar init_domain sb cur_aset + merge model all_elems nvar init_domain sb cur_aset (solve delayed2 delayed1 conj_cont) ) @@ -593,13 +693,25 @@ (* Propagate implication constraints. *) | Or fl :: conj_cont when List.exists (function Not _ -> true | _ -> false) fl -> + (* {{{ log entry *) + let cur_guard = !guard_number in + if !debug_level > 2 then ( + printf "Computing guard no %d..." cur_guard; incr guard_number; + ); + (* }}} *) let guard, body = Aux.partition_map (function Not phi -> Aux.Left phi | phi -> Aux.Right phi) fl in - (* assignments of the guard alone *) + (* assignments of the guard alone *) let guard_set = try solve [] [] guard sb A.Empty with Unsatisfiable_FO _ | Unsatisfiable -> A.Empty in - let cur_aset = add_complement all_elems cur_aset guard_set in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Guard: no %d guard_set=%s\nBody: %s\n%!" cur_guard + (AssignmentSet.named_str model guard_set) (Formula.str (Or body)); + ); + (* }}} *) + let cur_aset = add_complement model all_elems cur_aset guard_set in if body = [] || guard_set = A.Empty then (* the positive part is in effect false -- discard it *) solve delayed2 delayed1 conj_cont sb cur_aset @@ -612,34 +724,100 @@ solve delayed2 delayed1 (guard @ [concl] @ conj_cont) sb cur_aset (* Continue in each branch folding disjuncts; "Or []" is OK. *) - | Or fl :: conj_cont -> - List.fold_left (fun dset phi -> - solve delayed2 delayed1 (phi::conj_cont) sb dset) A.Empty fl + | Or fl :: conj_cont -> + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Folding-disjunctively-over: %s\ndisjunct-continuation: %s\n%!" + (Formula.str (Or fl)) (Formula.str (And conj_cont)); + ); + (* }}} *) + fold_try (fun dset phi -> + (* {{{ log entry *) + if !debug_level > 3 then ( + printf "disjunct: %s; prior dset=%s\n%!" + (Formula.str phi) (AssignmentSet.named_str model dset); + ); + (* }}} *) + solve delayed2 delayed1 (phi::conj_cont) sb dset) + cur_aset fl | Ex ([], phi) :: _ | All ([], phi) :: _ -> assert false - (* Only project, as the mechanics of existential variables is - handled at the site of their first occurrence. *) + (* Only project, as the mechanics of existential variables is + handled at the site of their first occurrence. *) | Ex (vl, phi) :: conj_cont -> + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solving-for-existential-variables: %s...\n%!" + (String.concat ", " (List.map Formula.var_str vl)); + ); + (* }}} *) let aset = solve delayed2 delayed1 (phi::conj_cont) sb cur_aset in - (* TODO: handle other kinds *) + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solved-variables: %s; aset=%s\n%!" + (String.concat ", " (List.map Formula.var_str vl)) + (AssignmentSet.named_str model aset); + ); + (* }}} *) + (* TODO: handle other kinds *) let vl = List.map to_fo vl in - List.fold_left (project all_elems) aset vl + let aset = List.fold_left (project all_elems) aset vl in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Eliminated-variables: %s; aset=%s\n%!" + (String.concat ", " (List.map Formula.var_str vl)) + (AssignmentSet.named_str model aset); + ); + (* }}} *) + aset - (* Check whether assignment set covers all elements for variables - [vl]. *) + (* Check whether assignment set covers all elements for variables + [vl]. *) | All (vl, phi) :: conj_cont -> + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solving-for-universal-variables: %s...\n%!" + (String.concat ", " (List.map Formula.var_str vl)); + ); + (* }}} *) let aset = solve delayed2 delayed1 (phi::conj_cont) sb cur_aset in - (* TODO: handle other kinds *) + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solved-variables: %s; aset=%s\n%!" + (String.concat ", " (List.map Formula.var_str vl)) + (AssignmentSet.named_str model aset); + ); + (* }}} *) + (* TODO: handle other kinds *) let vl = List.map to_fo vl in - List.fold_left (universal num_elems all_elems) aset vl + let aset = + List.fold_left (universal num_elems all_elems) aset vl in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Eliminated-variables: %s; aset=%s\n%!" + (String.concat ", " (List.map Formula.var_str vl)) + (AssignmentSet.named_str model aset); + ); + (* }}} *) + aset - (* By assumption that [Ex (vl, phi)] is ground, check it - separately and proceed or fail. *) - | Not (Ex (vl, phi)) :: conj_cont -> + (* By assumption that [phi] is ground, check it + separately and proceed or fail. *) + | Not phi as subtask :: conj_cont -> + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solving-a-subtask: %s...\n" (Formula.str subtask); + ); + (* }}} *) let aset = - try solve [] [] [phi] sb cur_aset + (* solving in empty context! *) + try solve [] [] [phi] [] A.Empty with Unsatisfiable_FO _ | Unsatisfiable -> A.Empty in + if !debug_level > 2 then ( + printf "Solved-subtask: %s\nsubtask: aset=%s\n%!" + (Formula.str subtask) (AssignmentSet.named_str model aset); + ); if aset = A.Empty then solve delayed2 delayed1 conj_cont sb cur_aset else raise Unsatisfiable @@ -647,11 +825,7 @@ | RealExpr _ :: _ | In _ :: _ -> failwith "FFSolver: MSO and Reals not implemented yet." - | Not phi :: _ -> - failwith ( - "FFSolver: formula not in partially-negation-normal form: " - ^ "negation over " ^ Formula.str phi) - + (* and solve_db sb delayed2 delayed1 conj_cont = let count = !debug_count in Modified: trunk/Toss/Solver/FFSolverTest.ml =================================================================== --- trunk/Toss/Solver/FFSolverTest.ml 2010-11-29 20:19:39 UTC (rev 1209) +++ trunk/Toss/Solver/FFSolverTest.ml 2010-11-30 00:13:26 UTC (rev 1210) @@ -151,8 +151,32 @@ (AssignmentSet.str (FFSolver.evaluate model phi)) ); - "eval: game heuristic tests from SolverTest.ml" >:: + + "eval: tic-tac-toe heuristic" >:: (fun () -> + let heur_phi = "(((R(x, y) and R(y, z)) or + (C(x, y) and C(y, z)) or ex t, u + ((C(z, u) and R(y, u) and C(y, t) and R(x, t))) or ex t, u ((R(y, u) and R(x, t) and C(u, z) and C(t, y)))) + and (Q(z) or Q(y) or Q(x)) + and (not P(x)) and (not P(y)) and (not P(z))" ^ + "and (not ex x, y, z ((((C(y, z) and C(x, y)) or (R(y, z) and R(x, y)) or + ex t, u ((R(y, u) and R(x, t) and C(u, z) + and C(t, y))) or ex t, u ((C(z, u) and + R(y, u) and C(y, t) and R(x, t)))) and P(z) and P(y) and P(x)))))" in + (* FFSolver.debug_level := 7; *) + eval_eq "[ | | ] \" + +Q P P + +. P . + +. Q . +\"" heur_phi + "{ z->a3{ y->a2{ x->a1 } } , z->c1{ y->b1{ x->a1 } } }"; + ); + + "eval: gomoku heuristic from SolverTest.ml" >:: + (fun () -> let heur_phi = "(((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 ((C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) @@ -166,6 +190,7 @@ and C(t, y) and C(s, x) and C(r, w))) or ex r, s, t, u ((C(z, u) and R(y, u) and C(y, t) and R(x, t) and C(x, s) and R(w, s) and C(w, r) and R(v, r)))) and P(z) and P(y) and P(x) and P(w) and P(v)))))" in + (* FFSolver.debug_level := 7; *) eval_eq "[ | | ] \" ... ... ... ... P ... ... ... ... @@ -183,18 +208,8 @@ ...P ... P.. ... ... ... ... ... ... ... ...Q ... -\"" heur_phi - ("{ z->5{ y->12{ x->19{ w->26{ v->33 } } } } ," ^ - " z->6{ y->5{ x->4{ w->3{ v->2 } } } } ," ^ - " z->7{ y->6{ x->5{ w->4{ v->3 } } } } ," ^ - " z->8{ y->7{ x->6{ w->5{ v->4 } } } } ," ^ - " z->32{ y->39{ x->46{ w->53{ v->60 } } } } ," ^ - " z->48{ y->47{ x->46{ w->45{ v->44 } } } } ," ^ - " z->53{ y->44{ x->35{ w->26{ v->17 } } } } ," ^ - " z->58{ y->50{ x->42{ w->34{ v->26 } } } } ," ^ - " z->62{ y->53{ x->44{ w->35{ v->26 } } } } ," ^ - " z->63{ y->54{ x->45{ w->36{ v->27 } } } } }"); - ); +\"" heur_phi + "{ y->d6{ z->e7{ x->c5{ v->a3{ w->b4 } } } } , y->e1{ x->d1{ v->b1{ z->f1{ w->c1 } } } } , y->f1{ x->e1{ v->c1{ z->g1{ w->d1 } } } } , y->g1{ x->f1{ v->d1{ w->e1{ z->h1 } } } } , y->d2{ x->c3{ v->a5{ z->e1{ w->b4 } } } } , y->g5{ x->f6{ v->d8{ w->e7{ z->h4 } } } } , y->g6{ x->f6{ v->d6{ w->e6{ z->h6 } } } } , y->b7{ x->b6{ v->b4{ w->b5{ z->b8 } } } } , y->e7{ x->d6{ z->f8{ v->b4{ w->c5 } } } } , y->f7{ x->e6{ z->g8{ v->c4{ w->d5 } } } } }"); "get_real_val: tic-tac-toe winning" >:: (fun () -> @@ -273,7 +288,7 @@ \"" in (* FFTNF.debug_level := 3; *) assert_equal ~printer:(fun x->x) - "((not ex x ((Q(x) and (ex y ((C(x, y) and Q(y) and ex z ((C(y, z) and Q(z))))) or ex y ((R(x, y) and Q(y) and ex z ((R(y, z) and Q(z))))) or ex y ((Q(y) and ex z ((Q(z) and (ex v0 ((R(x, v0) and C(y, v0) and ex u0 ((R(y, u0) and C(z, u0))))) or ex v ((R(x, v) and C(v, y) and ex u ((R(y, u) and C(u, z)))))))))))))) and ((not P(a1)) and (not Q(a1))))" + "((not ex x ((Q(x) and (ex y ((C(x, y) and Q(y) and ex z ((C(y, z) and Q(z))))) or ex y ((R(x, y) and Q(y) and ex z ((R(y, z) and Q(z))))) or ex v0 ((R(x, v0) and ex y ((C(y, v0) and Q(y) and ex u0 ((R(y, u0) and ex z ((C(z, u0) and Q(z))))))))) or ex v ((R(x, v) and ex y ((C(v, y) and Q(y) and ex u ((R(y, u) and ex z ((C(u, z) and Q(z))))))))))))) and ((not P(a1)) and (not Q(a1))))" (Formula.str (FFSolver.normalize_for_model tictactoe_init tictactoe_LHS)); ); @@ -296,7 +311,9 @@ \"" in (* FFTNF.debug_level := 3; *) assert_equal ~printer:(fun x->x) - "((not ex z0 ((P(z0) and (ex y0 ((R(y0, z0) and P(y0) and ex x0 ((R(x0, y0) and P(x0))))) or ex y0 ((C(y0, z0) and P(y0) and ex x0 ((C(x0, y0) and P(x0))))) or ex y0 ((P(y0) and ex x0 ((P(x0) and (ex u ((C(z0, u) and R(y0, u) and ex v ((C(y0, v) and R(x0, v))))) or ex u0 ((C(u0, z0) and R(y0, u0) and ex v0 ((C(v0, y0) and R(x0, v0)))))))))))))) and ((P(z) and (not Q(z)) and (C(y, z) and (not Q(y)) and (C(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (C(y, z) and (not Q(z)) and (C(x, y) and (not Q(x))))) or (P(z) and (not Q(z)) and (R(y, z) and (not Q(y)) and (R(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (R(y, z) and (not Q(z)) and (R(x, y) and (not Q(x))))) or (P(x) and (not Q(x)) and (R(x, y) and (not Q(y)) and (R(y, z) and (not Q(z))))) or (P(x) and (not Q(x)) and (C(x, y) and (not Q(y)) and (C(y, z) and (not Q(z))))) or ((not Q(z)) and ex u ((C(u, z) and (R(y, u) and P(y) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v0 ((R(x, v0) and (C(y, v0) and (not Q(y)) and ex u0 ((R(y, u0) and (C(z, u0) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u0 ((C(z, u0) and (R(y, u0) and (not Q(y)) and ex v0 ((C(y, v0) and (R(x, v0) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v ((R(x, v) and (C(v, y) and (not Q(y)) and ex u ((R(y, u) and (C(u, z) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u ((C(u, z) and (R(y, u) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(y) and (not Q(y)) and ex u0 ((R(y, u0) and ex v0 ((C(y, v0) and (C(z, u0) and (not Q(z)) and (R(x, v0) and (not Q(x)))))))))))" +"((not ex z0 ((P(z0) and (ex y0 ((R(y0, z0) and P(y0) and ex x0 ((R(x0, y0) and P(x0))))) or ex y0 ((C(y0, z0) and P(y0) and ex x0 ((C(x0, y0) and P(x0))))) or ex u ((C(z0, u) and ex y0 ((R(y0, u) and P(y0) and ex v ((C(y0, v) and ex x0 ((R(x0, v) and P(x0))))))))) or ex u0 ((C(u0, z0) and ex y0 ((R(y0, u0) and P(y0) and ex v0 ((C(v0, y0) and ex x0 ((R(x0, v0) and P(x0))))))))))))) and ((P(z) and (not Q(z)) and (C(y, z) and (not Q(y)) and (C(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (C(y, z) and (not Q(z)) and (C(x, y) and (not Q(x))))) or (P(z) and (not Q(z)) and (R(y, z) and (not Q(y)) and (R(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (R(y, z) and (not Q(z)) and (R(x, y) and (not Q(x))))) or (P(x) and (not Q(x)) and (R(x, y) and (not Q(y)) and (R(y, z) and (not Q(z))))) or (P(x) and (not Q(x)) and (C(x, y) and (not Q(y)) and (C(y, z) and (not Q(z))))) or ((not Q(z)) and ex u ((C(u, z) and (R(y, u) and P(y) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v0 ((R(x, v0) and (C(y, v0) and (not Q(y)) and ex u0 ((R(y, u0) and (C(z, u0) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u0 ((C(z, u0) and (R(y, u0) and (not Q(y)) and ex v0 ((C(y, v0) and (R(x, v0) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v ((R(x, v) and (C(v, y) and (not Q(y)) and ex u ((R(y, u) and (C(u, z) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u ((C(u, z) and (R(y, u) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(y) and (not Q(y)) and ex u0 ((R(y, u0) and ex v0 ((C(y, v0) and (C(z, u0) and (not Q(z)) and (R(x, v0) and (not Q(x)))))))))))" +(* old variant: + "((not ex z0 ((P(z0) and (ex y0 ((R(y0, z0) and P(y0) and ex x0 ((R(x0, y0) and P(x0))))) or ex y0 ((C(y0, z0) and P(y0) and ex x0 ((C(x0, y0) and P(x0))))) or ex y0 ((P(y0) and ex x0 ((P(x0) and (ex u ((C(z0, u) and R(y0, u) and ex v ((C(y0, v) and R(x0, v))))) or ex u0 ((C(u0, z0) and R(y0, u0) and ex v0 ((C(v0, y0) and R(x0, v0)))))))))))))) and ((P(z) and (not Q(z)) and (C(y, z) and (not Q(y)) and (C(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (C(y, z) and (not Q(z)) and (C(x, y) and (not Q(x))))) or (P(z) and (not Q(z)) and (R(y, z) and (not Q(y)) and (R(x, y) and (not Q(x))))) or (P(y) and (not Q(y)) and (R(y, z) and (not Q(z)) and (R(x, y) and (not Q(x))))) or (P(x) and (not Q(x)) and (R(x, y) and (not Q(y)) and (R(y, z) and (not Q(z))))) or (P(x) and (not Q(x)) and (C(x, y) and (not Q(y)) and (C(y, z) and (not Q(z))))) or ((not Q(z)) and ex u ((C(u, z) and (R(y, u) and P(y) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v0 ((R(x, v0) and (C(y, v0) and (not Q(y)) and ex u0 ((R(y, u0) and (C(z, u0) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u0 ((C(z, u0) and (R(y, u0) and (not Q(y)) and ex v0 ((C(y, v0) and (R(x, v0) and (not Q(x))))))))) or (P(x) and (not Q(x)) and ex v ((R(x, v) and (C(v, y) and (not Q(y)) and ex u ((R(y, u) and (C(u, z) and (not Q(z))))))))) or (P(z) and (not Q(z)) and ex u ((C(u, z) and (R(y, u) and (not Q(y)) and ex v ((C(v, y) and (R(x, v) and (not Q(x))))))))) or (P(y) and (not Q(y)) and ex u0 ((R(y, u0) and ex v0 ((C(y, v0) and (C(z, u0) and (not Q(z)) and (R(x, v0) and (not Q(x)))))))))))"*) (Formula.str (FFSolver.normalize_for_model ttt heur_phi)); ); @@ -307,7 +324,7 @@ Aux.run_test_if_target "FFSolverTest" tests let a () = - match test_filter ["FFSolver:1:evaluate: universal"] + match test_filter ["FFSolver:8:eval: gomoku heuristic from SolverTest.ml"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-11-30 15:31:52
|
Revision: 1211 http://toss.svn.sourceforge.net/toss/?rev=1211&view=rev Author: lukstafi Date: 2010-11-30 15:31:45 +0000 (Tue, 30 Nov 2010) Log Message: ----------- FFSolver: rewrite of existential quantification. Modified Paths: -------------- trunk/Toss/Play/GameTest.ml trunk/Toss/Solver/FFSolver.ml trunk/Toss/Solver/FFSolverTest.ml Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2010-11-30 00:13:26 UTC (rev 1210) +++ trunk/Toss/Play/GameTest.ml 2010-11-30 15:31:45 UTC (rev 1211) @@ -675,9 +675,9 @@ ] let search_tests algo randomize effort_easy effort_medium effort_hard = - let easy_case = compute_try algo randomize effort_easy 120 - and medium_case = compute_try algo randomize effort_medium 240 - and hard_case = compute_try algo randomize effort_hard 600 in + let easy_case = compute_try algo randomize effort_easy 240 + and medium_case = compute_try algo randomize effort_medium 600 + and hard_case = compute_try algo randomize effort_hard 1200 in algo >::: [ "tictactoe suggest tie" >:: (fun () -> @@ -950,7 +950,6 @@ "gomoku8x8 more pieces" >:: (fun () -> - skip_if true "takes too long -- uncheck later"; let state = update_game gomoku8x8_game "[ | | ] \" ... ... ... ... Modified: trunk/Toss/Solver/FFSolver.ml =================================================================== --- trunk/Toss/Solver/FFSolver.ml 2010-11-30 00:13:26 UTC (rev 1210) +++ trunk/Toss/Solver/FFSolver.ml 2010-11-30 15:31:45 UTC (rev 1211) @@ -51,8 +51,7 @@ | A.Real _ | A.MSO _ -> failwith "Real/MSO assignments not supported yet" -(* Use a bigger assignment set as the first argument. TODO: obsolete - this function by optimizations of disjunction and existential q. *) +(* Use a bigger assignment set as the first argument. *) let sum_assignment_sets all_elems aset1 aset2 = let sbs2 = invert_aset [[]] aset2 in let rec aux sb = function @@ -75,8 +74,7 @@ failwith "Real/MSO assignments not supported yet" in List.fold_right aux sbs2 aset1 -(* Remove existentially quantified variables from the solution. TODO: - obsolete this function by optimizing treatment of ex. q. variables. *) +(* Remove existentially quantified variables from the solution. *) let rec project all_elems aset v = match aset with | A.Empty -> A.Empty @@ -226,7 +224,7 @@ let asbs = Aux.unique (=) (List.map (List.sort Pervasives.compare) asbs) in let bsbs = A.fo_assgn_to_list all_elems vars b in - let asbs = + let bsbs = Aux.unique (=) (List.map (List.sort Pervasives.compare) bsbs) in (* {{{ log entry *) if !debug_level > 3 then ( @@ -241,10 +239,12 @@ List.assoc v bsb = ae) asb with Not_found -> false) bsbs) asbs -(* We assume that for every "not ex - psi" subformula, "ex psi" is ground, and that every other - occurrence of negation is in a literal (it is guaranteed by - {!ff_tnf}). +(* We assume that for every "not ex psi" subformula, "ex psi" is + ground, and that every other occurrence of negation is in a literal + (it is guaranteed by {!FFTNF.ff_tnf}). We assume that every + existentially quantified single disjunct [Ex (vs, Or [phi])] marks + the fact that the body [phi] does not have universal quantifiers + (guaranteed by {!FFSolver.add_locvar_info}). We use the structure of the formula to organize search and build the result on the recursive stack. Accumulated substitution stores @@ -258,7 +258,9 @@ position, delayed2: would have to split on all elements. We fold over disjunctive constraints by keeping the aset subtree to which we merge from the current context to produce the final answer. (It - is initialized with Empty aset.) + is initialized with Empty aset.) In the same way we fold over + assignments for local variables: existentially quantified variables + that do not have a universal quantifier in their scope. The rules to merge (disjoin) the current aset (cur-aset) and the current position (cur-pos): @@ -314,8 +316,9 @@ (e4) apply the case (c) *) (* Model used only for debugging. *) -let rec merge model all_elems v init_domain sb cur_aset eval_cont = - match cur_aset with +let merge model all_elems is_local v init_domain sb cur_aset + eval_cont = + let rec aux = function (* v not in local_vars *) | A.MSO _ | A.Real _ -> failwith "FFSolver.evaluate: MSO and Real not supported yet" (* a *) @@ -357,11 +360,20 @@ | _ -> (* when A.mem_assoc v cur_aset *) let pull_v e = e, project_v_on_elem v e cur_aset in - let cur_aset = - A.FO (v, map_try pull_v all_elems) in - merge model all_elems v init_domain sb cur_aset eval_cont + aux (A.FO (v, map_try pull_v all_elems)) in + if is_local then + (* similar to case (d), but fold instead of mapping *) + let choose cur_aset e = + eval_cont ((v, e)::sb) cur_aset in + let pos_assgns = + fold_try ~catch:(v :> var) choose cur_aset init_domain in + if pos_assgns = A.Empty then raise Unsatisfiable + else pos_assgns + else aux cur_aset + + (* "Negate" the second assignment set wrt. [all_elems] and add it to the first aset. *) (* Model used only for debugging. *) @@ -378,7 +390,7 @@ (* Empty will turn into Any on recursive callback *) try List.assoc e assgns with Not_found -> A.Empty in add_complement model all_elems dset cset in - merge model all_elems v all_elems [] disj_aset add_cont + merge model all_elems false v all_elems [] disj_aset add_cont | A.Real _ | A.MSO _ -> failwith "FFSolver: Real/MSO assignments not supported yet" @@ -406,7 +418,7 @@ optimize]. Check universally quantified variables for coverage. Do not return [A.Empty], raise [Unsatisfiable] instead. *) - let rec solve delayed2 delayed1 conj_cont sb cur_aset = + let rec solve local_vars delayed2 delayed1 conj_cont sb cur_aset = (* {{{ log entry *) if !debug_level > 3 then ( printf "solve: remaining=%s\nsolve: sb=%s\nsolve: disj_aset=%s\n%!" @@ -425,9 +437,9 @@ ) else match conj_cont with | [] -> if delayed1 <> [] - then solve delayed2 [] (List.rev delayed1) sb cur_aset + then solve local_vars delayed2 [] (List.rev delayed1) sb cur_aset else if delayed2 <> [] - then solve [] [] (List.rev delayed2) sb cur_aset + then solve local_vars [] [] (List.rev delayed2) sb cur_aset (* b *) else ( (* {{{ log entry *) @@ -446,10 +458,10 @@ if not (Tuples.mem tup tuples_s) then raise (Unsatisfiable_FO (vars_of_array (var_tup vtup))) else if conj_cont <> [] - then solve delayed2 delayed1 conj_cont sb cur_aset + then solve local_vars delayed2 delayed1 conj_cont sb cur_aset else if delayed1 <> [] - then solve delayed2 [] (List.rev delayed1) sb cur_aset - else solve [] [] (List.rev delayed2) sb cur_aset + then solve local_vars delayed2 [] (List.rev delayed1) sb cur_aset + else solve local_vars [] [] (List.rev delayed2) sb cur_aset with Not_found -> (* we will add new variables one at a time *) let nvi = @@ -460,7 +472,7 @@ let multi_unkn = Aux.array_existsi (fun i v->i>nvi && not (List.mem v oldvars)) vtup in if multi_unkn && conj_cont <> [] then (* delay *) - solve delayed2 (atom::delayed1) conj_cont sb cur_aset + solve local_vars delayed2 (atom::delayed1) conj_cont sb cur_aset else (* to narrow the domain, lookup incidence of known vars, filter for partial match and project on the nvar @@ -505,15 +517,15 @@ else if not multi_unkn && conj_cont = [] && delayed1 = [] && delayed2 = [] then (* no more vars and conjuncts *) - merge model all_elems nvar init_domain sb cur_aset + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar init_domain sb cur_aset (fun _ _ -> A.Any) (* subsume *) else let conj_cont = if multi_unkn then atom::conj_cont else conj_cont in (* If not [multi_unkn] then for elements in [init_domain] rel holds *) - merge model all_elems nvar init_domain sb cur_aset - (solve delayed2 delayed1 conj_cont) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar init_domain sb cur_aset + (solve local_vars delayed2 delayed1 conj_cont) ) (* by analogy to the [Rel (relname, vtup)] case *) @@ -522,7 +534,7 @@ (try if not (List.assoc x sb = List.assoc y sb) then raise (Unsatisfiable_FO (vars_of_list (vtup :> var list))) - else solve delayed2 delayed1 conj_cont sb cur_aset + else solve local_vars delayed2 delayed1 conj_cont sb cur_aset with Not_found -> (* we will add new variables one at a time *) let nvi, nvar = @@ -533,7 +545,7 @@ (fun i v->i>nvi && not (List.mem v oldvars)) vtup in if multi_unkn && (conj_cont <> [] || delayed1 <> []) then (* delay *) - solve (atom::delayed2) delayed1 conj_cont sb cur_aset + solve local_vars (atom::delayed2) delayed1 conj_cont sb cur_aset else if multi_unkn then let conj_cont = atom::conj_cont in (* {{{ log entry *) @@ -542,8 +554,8 @@ (sb_str model sb) (Formula.str atom); ); (* }}} *) - merge model all_elems nvar all_elems sb cur_aset - (solve delayed2 delayed1 conj_cont) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar all_elems sb cur_aset + (solve local_vars delayed2 delayed1 conj_cont) else let ovar = if nvi = 1 then x else y in let e = List.assoc ovar sb in @@ -554,8 +566,8 @@ (Structure.elem_str model e); ); (* }}} *) - merge model all_elems nvar [e] sb cur_aset - (solve delayed2 delayed1 conj_cont) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar [e] sb cur_aset + (solve local_vars delayed2 delayed1 conj_cont) ) (* by analogy to the [Rel (relname, vtup)] case *) @@ -568,10 +580,10 @@ then raise (Unsatisfiable_FO (vars_of_array (var_tup vtup))) else if conj_cont <> [] - then solve delayed2 delayed1 conj_cont sb cur_aset + then solve local_vars delayed2 delayed1 conj_cont sb cur_aset else if delayed1 <> [] - then solve delayed2 [] (List.rev delayed1) sb cur_aset - else solve [] [] (List.rev delayed2) sb cur_aset + then solve local_vars delayed2 [] (List.rev delayed1) sb cur_aset + else solve local_vars [] [] (List.rev delayed2) sb cur_aset with Not_found -> (* we will add new variables one at a time *) let nvi = @@ -583,15 +595,15 @@ (fun i v->i>nvi && not (List.mem v oldvars)) vtup in if multi_unkn && (conj_cont <> [] || delayed1 <> []) then (* delay *) - solve (literal::delayed2) delayed1 conj_cont sb cur_aset + solve local_vars (literal::delayed2) delayed1 conj_cont sb cur_aset else if not multi_unkn && conj_cont <> [] then - solve delayed2 (literal::delayed1) conj_cont sb cur_aset + solve local_vars delayed2 (literal::delayed1) conj_cont sb cur_aset else if multi_unkn then (* we cannot easily optimize *) let conj_cont = [literal] in - merge model all_elems nvar all_elems sb cur_aset - (solve delayed2 delayed1 conj_cont) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar all_elems sb cur_aset + (solve local_vars delayed2 delayed1 conj_cont) else let tuples_i = try StringMap.find relname model.incidence @@ -632,8 +644,8 @@ else (* If not [multi_unkn] then for elements in [init_domain] rel does not hold *) - merge model all_elems nvar init_domain sb cur_aset - (solve delayed2 delayed1 conj_cont) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar init_domain sb cur_aset + (solve local_vars delayed2 delayed1 conj_cont) ) (* by analogy to both [Eq] and [not Rel] cases *) @@ -642,7 +654,7 @@ (try if List.assoc x sb = List.assoc y sb then raise (Unsatisfiable_FO (vars_of_list ([x; y] :> var list))) - else solve delayed2 delayed1 conj_cont sb cur_aset + else solve local_vars delayed2 delayed1 conj_cont sb cur_aset with Not_found -> (* we will add new variables one at a time *) let nvi, nvar = @@ -653,9 +665,9 @@ (fun i v->i>nvi && not (List.mem v oldvars)) vtup in if multi_unkn && (conj_cont <> [] || delayed1 <> []) then (* delay *) - solve (literal::delayed2) delayed1 conj_cont sb cur_aset + solve local_vars (literal::delayed2) delayed1 conj_cont sb cur_aset else if not multi_unkn && conj_cont <> [] then - solve delayed2 (literal::delayed1) conj_cont sb cur_aset + solve local_vars delayed2 (literal::delayed1) conj_cont sb cur_aset else if multi_unkn then begin (* {{{ log entry *) if !debug_level > 2 then ( @@ -663,8 +675,8 @@ (sb_str model sb) (Formula.str literal); ); (* }}} *) - merge model all_elems nvar all_elems sb cur_aset - (solve delayed2 delayed1 (literal :: conj_cont)) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar all_elems sb cur_aset + (solve local_vars delayed2 delayed1 (literal :: conj_cont)) end else (* optimize *) let ovar = if nvi = 1 then x else y in let e = List.assoc ovar sb in @@ -677,19 +689,18 @@ (* }}} *) let init_domain = Elems.elements (Elems.remove e model.elements) in - merge model all_elems nvar init_domain sb cur_aset - (solve delayed2 delayed1 conj_cont) + merge model all_elems (Vars.mem (nvar :> var) local_vars) nvar init_domain sb cur_aset + (solve local_vars delayed2 delayed1 conj_cont) ) + | Or [_] :: _ | And [_] :: _ -> assert false + (* use associativity, but don't invert the order *) | And conj :: conj_cont -> let conj_cont = if conj_cont = [] then conj else conj @ conj_cont in - solve delayed2 delayed1 conj_cont sb cur_aset + solve local_vars delayed2 delayed1 conj_cont sb cur_aset - | Or [phi] :: conj_cont -> - solve delayed2 delayed1 (phi::conj_cont) sb cur_aset - (* Propagate implication constraints. *) | Or fl :: conj_cont when List.exists (function Not _ -> true | _ -> false) fl -> @@ -703,7 +714,7 @@ (function Not phi -> Aux.Left phi | phi -> Aux.Right phi) fl in (* assignments of the guard alone *) let guard_set = - try solve [] [] guard sb A.Empty + try solve local_vars [] [] guard sb A.Empty with Unsatisfiable_FO _ | Unsatisfiable -> A.Empty in (* {{{ log entry *) if !debug_level > 2 then ( @@ -714,14 +725,14 @@ let cur_aset = add_complement model all_elems cur_aset guard_set in if body = [] || guard_set = A.Empty then (* the positive part is in effect false -- discard it *) - solve delayed2 delayed1 conj_cont sb cur_aset + solve local_vars delayed2 delayed1 conj_cont sb cur_aset else (* hopefully more constrained (TODO: don't redo the guard?) *) let concl = match body with | [concl] -> concl | _ -> Or body in - solve delayed2 delayed1 (guard @ [concl] @ conj_cont) sb cur_aset + solve local_vars delayed2 delayed1 (guard @ [concl] @ conj_cont) sb cur_aset (* Continue in each branch folding disjuncts; "Or []" is OK. *) | Or fl :: conj_cont -> @@ -738,11 +749,34 @@ (Formula.str phi) (AssignmentSet.named_str model dset); ); (* }}} *) - solve delayed2 delayed1 (phi::conj_cont) sb dset) + solve local_vars delayed2 delayed1 (phi::conj_cont) sb dset) cur_aset fl | Ex ([], phi) :: _ | All ([], phi) :: _ -> assert false + (* Local variables -- handled by merging online. *) + | Ex (vl, Or [phi]) :: conj_cont -> + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solving-for-local-variables: %s...\n%!" + (String.concat ", " (List.map Formula.var_str vl)); + ); + (* }}} *) + let local_vars = add_vars vl local_vars in + (* FIXME: after debugging return to tail call *) + let aset = + solve local_vars delayed2 delayed1 (phi::conj_cont) sb + cur_aset in + (* {{{ log entry *) + if !debug_level > 2 then ( + printf "Solved-local-variables: %s; aset=%s\n%!" + (String.concat ", " (List.map Formula.var_str vl)) + (AssignmentSet.named_str model aset); + ); + (* }}} *) + (* TODO: handle other kinds *) + aset + (* Only project, as the mechanics of existential variables is handled at the site of their first occurrence. *) | Ex (vl, phi) :: conj_cont -> @@ -752,7 +786,7 @@ (String.concat ", " (List.map Formula.var_str vl)); ); (* }}} *) - let aset = solve delayed2 delayed1 (phi::conj_cont) sb cur_aset in + let aset = solve local_vars delayed2 delayed1 (phi::conj_cont) sb cur_aset in (* {{{ log entry *) if !debug_level > 2 then ( printf "Solved-variables: %s; aset=%s\n%!" @@ -781,7 +815,7 @@ (String.concat ", " (List.map Formula.var_str vl)); ); (* }}} *) - let aset = solve delayed2 delayed1 (phi::conj_cont) sb cur_aset in + let aset = solve local_vars delayed2 delayed1 (phi::conj_cont) sb cur_aset in (* {{{ log entry *) if !debug_level > 2 then ( printf "Solved-variables: %s; aset=%s\n%!" @@ -812,14 +846,14 @@ (* }}} *) let aset = (* solving in empty context! *) - try solve [] [] [phi] [] A.Empty + try solve local_vars [] [] [phi] [] A.Empty with Unsatisfiable_FO _ | Unsatisfiable -> A.Empty in if !debug_level > 2 then ( printf "Solved-subtask: %s\nsubtask: aset=%s\n%!" (Formula.str subtask) (AssignmentSet.named_str model aset); ); if aset = A.Empty then - solve delayed2 delayed1 conj_cont sb cur_aset + solve local_vars delayed2 delayed1 conj_cont sb cur_aset else raise Unsatisfiable | RealExpr _ :: _ | In _ :: _ -> @@ -839,7 +873,7 @@ aset *) in - try solve [] [] [phi] sb disj_aset + try solve Vars.empty [] [] [phi] sb disj_aset with Unsatisfiable_FO _ | Unsatisfiable -> A.Empty (* Assignments of a single variable that are supported by all @@ -965,7 +999,34 @@ | Sum (vl, gd, e) -> Sum (vl, norm gd, aux e) in aux expr +let add_locvar_info phi = + let rec has_univ = function + | All _ -> true + | Or js | And js -> List.exists has_univ js + | Ex (_, phi) -> has_univ phi + | _ -> false in (* assumes (partial) NNF *) + let rec aux = function + | Ex (vs, phi) when not (has_univ phi) -> + Ex (vs, Or [aux phi]) + | Ex (vs, phi) -> Ex (vs, aux phi) + | All (vs, phi) -> All (vs, aux phi) + | Not phi -> Not (aux phi) (* subtasks also apply *) + | Or [phi] -> aux phi + | And [phi] -> aux phi + | Or djs -> Or (List.map aux djs) + | And cjs -> And (List.map aux cjs) + | atom -> atom in + aux phi +let rec add_locvar_info_expr = function + | Times (a,b) -> + Times (add_locvar_info_expr a, add_locvar_info_expr b) + | Plus (a,b) -> + Plus (add_locvar_info_expr a, add_locvar_info_expr b) + | Char (phi) -> Char (add_locvar_info phi) + | Sum (vs, guard, expr) -> + Sum (vs, add_locvar_info guard, add_locvar_info_expr expr) + | simple -> simple (* Interface to {!SolverIntf}. *) module M = struct @@ -978,26 +1039,32 @@ let evaluate_partial struc sb reg_phi = if not (snd !reg_phi) then reg_phi := - normalize_for_model struc - ((* FormulaOps.simplify *) (fst !reg_phi)), true; + add_locvar_info + (normalize_for_model struc + ((* FormulaOps.simplify *) (fst !reg_phi))), true; evaluate struc ~sb (fst !reg_phi) let evaluate struc reg_phi = if not (snd !reg_phi) then reg_phi := - normalize_for_model struc - ((* FormulaOps.simplify *) (fst !reg_phi)), true; + add_locvar_info + (normalize_for_model struc + ((* FormulaOps.simplify *) (fst !reg_phi))), true; evaluate struc (fst !reg_phi) let check_formula struc reg_phi = if not (snd !reg_phi) then - reg_phi := normalize_for_model struc (fst !reg_phi), true; + reg_phi := + add_locvar_info + (normalize_for_model struc (fst !reg_phi)), true; check_formula struc (fst !reg_phi) let get_real_val reg_expr struc = if not (snd !reg_expr) then reg_expr := - normalize_expr_for_model struc (fst !reg_expr), true; + add_locvar_info_expr + (normalize_expr_for_model struc (fst !reg_expr)), true; get_real_val (fst !reg_expr) struc let formula_str reg_phi = if not (snd !reg_phi) then + (* TODO: inconsistent with other defs *) (* to increase consistency of display *) reg_phi := FormulaOps.simplify (fst !reg_phi), false; Formula.str (fst !reg_phi) Modified: trunk/Toss/Solver/FFSolverTest.ml =================================================================== --- trunk/Toss/Solver/FFSolverTest.ml 2010-11-30 00:13:26 UTC (rev 1210) +++ trunk/Toss/Solver/FFSolverTest.ml 2010-11-30 15:31:45 UTC (rev 1211) @@ -32,18 +32,17 @@ let eval_eq struc_s phi_s aset_s = let struc = struc_of_str struc_s in - let f = - FFSolver.normalize_for_model struc (formula_of_str phi_s) in + let f = FFSolver.M.register_formula (formula_of_str phi_s) in assert_equal ~printer:(fun x -> x) aset_s - (AssignmentSet.named_str struc (FFSolver.evaluate struc f)) + (AssignmentSet.named_str struc (FFSolver.M.evaluate struc f)) ;; let real_val_eq struc_s expr_s x = let struc = struc_of_str struc_s in let expr = - FFSolver.normalize_expr_for_model struc (real_of_str expr_s) in + FFSolver.M.register_real_expr (real_of_str expr_s) in assert_equal ~printer:(fun x -> string_of_float x) ~msg:expr_s - x (FFSolver.get_real_val expr struc) + x (FFSolver.M.get_real_val expr struc) let tests = "FFSolver" >::: [ "eval: first-order quantifier free from SolverTest.ml" >:: @@ -96,7 +95,16 @@ ); "eval: first-order with quantifiers more" >:: - (fun () -> () + (fun () -> + eval_eq "[ | R {(a,a); (a,b); (a,c); (a,d)}; S {(a,b); (b,c); (c,d); (d,d)}; P(d) | ]" + "ex x all y ex z (R(x,y) and S(y,z) and v=x)" + "{ v->a }"; + eval_eq "[ | R {(a,a); (a,b); (a,c); (a,d)}; S {(a,b); (b,c); (c,d); (d,d)}; P(d) | ]" + "ex z all y ex x (R(x,y) and S(y,z) and v=z)" + "{}"; + eval_eq "[ | R {(a,a); (a,b); (a,c); (a,d)}; S {(a,b); (b,c); (c,d); (d,d)}; P(d) | ]" + "ex x all y ex z (R(x,y) and S(y,z))" + "T"; ); "evaluate: negation" >:: @@ -172,7 +180,7 @@ . Q . \"" heur_phi - "{ z->a3{ y->a2{ x->a1 } } , z->c1{ y->b1{ x->a1 } } }"; + "{ y->b1{ z->c1{ x->a1 } } , y->a2{ z->a3{ x->a1 } } }"; ); "eval: gomoku heuristic from SolverTest.ml" >:: @@ -209,7 +217,7 @@ ... ... ... ... ... ... ...Q ... \"" heur_phi - "{ y->d6{ z->e7{ x->c5{ v->a3{ w->b4 } } } } , y->e1{ x->d1{ v->b1{ z->f1{ w->c1 } } } } , y->f1{ x->e1{ v->c1{ z->g1{ w->d1 } } } } , y->g1{ x->f1{ v->d1{ w->e1{ z->h1 } } } } , y->d2{ x->c3{ v->a5{ z->e1{ w->b4 } } } } , y->g5{ x->f6{ v->d8{ w->e7{ z->h4 } } } } , y->g6{ x->f6{ v->d6{ w->e6{ z->h6 } } } } , y->b7{ x->b6{ v->b4{ w->b5{ z->b8 } } } } , y->e7{ x->d6{ z->f8{ v->b4{ w->c5 } } } } , y->f7{ x->e6{ z->g8{ v->c4{ w->d5 } } } } }"); + "{ y->d6{ z->e7{ x->c5{ w->b4{ v->a3 } } } } , y->e1{ x->d1{ v->b1{ z->f1{ w->c1 } } } } , y->f1{ x->e1{ v->c1{ z->g1{ w->d1 } } } } , y->g1{ x->f1{ v->d1{ w->e1{ z->h1 } } } } , y->d2{ x->c3{ v->a5{ z->e1{ w->b4 } } } } , y->g5{ x->f6{ v->d8{ w->e7{ z->h4 } } } } , y->g6{ x->f6{ v->d6{ w->e6{ z->h6 } } } } , y->b7{ x->b6{ v->b4{ w->b5{ z->b8 } } } } , y->e7{ x->d6{ z->f8{ w->c5{ v->b4 } } } } , y->f7{ x->e6{ z->g8{ w->d5{ v->c4 } } } } }"); "get_real_val: tic-tac-toe winning" >:: (fun () -> @@ -324,7 +332,7 @@ Aux.run_test_if_target "FFSolverTest" tests let a () = - match test_filter ["FFSolver:8:eval: gomoku heuristic from SolverTest.ml"] + match test_filter ["FFSolver:4:eval: first-order with quantifiers more"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-12-01 22:13:38
|
Revision: 1212 http://toss.svn.sourceforge.net/toss/?rev=1212&view=rev Author: lukaszkaiser Date: 2010-12-01 22:13:31 +0000 (Wed, 01 Dec 2010) Log Message: ----------- GUI for adv_ratio setting, read adv_ratio and depth from data. Modified Paths: -------------- trunk/Toss/Client/SystemDisplay.py trunk/Toss/Client/Wrapper.py trunk/Toss/examples/Breakthrough.toss trunk/Toss/examples/Gomoku.toss Modified: trunk/Toss/Client/SystemDisplay.py =================================================================== --- trunk/Toss/Client/SystemDisplay.py 2010-11-30 15:31:45 UTC (rev 1211) +++ trunk/Toss/Client/SystemDisplay.py 2010-12-01 22:13:31 UTC (rev 1212) @@ -44,11 +44,21 @@ QObject.connect(suggest_bt, SIGNAL("triggered ()"), self.suggest) self.__sg_iters = 2 + dp = self.system.get_data("depth") + if dp != "none": self.__sg_iters = int(dp) self.sg_iters_bt = self.toolbar.addAction ("Depth: " + str(self.__sg_iters)) QObject.connect(self.sg_iters_bt, SIGNAL("triggered ()"), self.set_sg_iters) + self.__adv_ratio = 2 + ar = self.system.get_data("adv_ratio") + if ar != "none": self.__adv_ratio = int(ar) + self.adv_ratio_bt = self.toolbar.addAction ("Adv.: " + + str(self.__adv_ratio)) + QObject.connect(self.adv_ratio_bt, SIGNAL("triggered ()"), + self.set_adv_ratio) + self.toolbar.addSeparator () toss_bt = self.toolbar.addAction (QIcon(":/pics/toss.svg"), "Toss") @@ -149,6 +159,13 @@ self.__sg_iters = si self.sg_iters_bt.setText ("Depth: " + str(si)) + def set_adv_ratio (self): + (ar, ok) = QInputDialog.getInt (self, "Advancement Agresiveness Ratio", + "Set advancement agressiveness: ", + self.__adv_ratio, 1, 10, 1) + self.__adv_ratio = ar + self.adv_ratio_bt.setText ("Adv.: " + str(ar)) + def snap_to_grid (self): (gC, ok) = QInputDialog.getInt (self, "Grid Size", "Snap to Grid of Size: ", @@ -350,7 +367,7 @@ return self.__can_redraw = False (r, m, p, e) = self.system.suggest (self.__sg_iters, - cur_loc) + cur_loc, self.__adv_ratio) found_match = False for i in range(len(self.moves)): (matches, rule, itvls, endp) = self.moves[i] @@ -413,7 +430,7 @@ return shape_moves = [] for i in range(len(self.moves)): # moves[i] = (matches, r, itvls, endp) - if self.system.get_rdata (self.moves[i][1]) == pattern_name: + if self.system.get_rdata_named (self.moves[i][1]) == pattern_name: shape_moves.append (i) if len(shape_moves) != 1: return (all_matches, r, itvls, endp) = self.moves[shape_moves[0]] Modified: trunk/Toss/Client/Wrapper.py =================================================================== --- trunk/Toss/Client/Wrapper.py 2010-11-30 15:31:45 UTC (rev 1211) +++ trunk/Toss/Client/Wrapper.py 2010-12-01 22:13:31 UTC (rev 1212) @@ -284,11 +284,18 @@ m = self.msg ("SET LOC MOVES " + (str (i)) + " " + moves_str) return (m) - def get_rdata (self, i): - m = self.msg ("GET DATA r" + (self.rule_names[i])) + def get_data (self, did): + m = self.msg ("GET DATA " + did) + if len(m) < 3: return (m) if m[0:3] == "ERR": return ("none") return (m) + def get_rdata (self, i): + return (self.get_data ("r" + (self.rule_names[i]))) + + def get_rdata_named (self, rn): + return (self.get_data ("r" + rn)) + def set_rdata (self, i, data_s): self.changes += 1 return (self.msg ("SET DATA r" + self.rule_names[i] + " " + data_s)) @@ -389,14 +396,14 @@ t = [s.strip() for s in m.split('/')] return ((float(t[0]), float(t[1]))) - def suggest (self, no_iters, loc): + def suggest (self, no_iters, loc, adv_ratio): (ts, t) = self.get_time () # Note that we set max. horizon to 500 here # syntax variant 1: # "EVAL LOC MOVES advancement_ratio location TIMEOUT time_in_sec iters_or_depth_limit method optional_playout_horizon" # syntax variant 2: # "EVAL LOC MOVES [{0: heuristic_player_0_loc_0; 1: heuristic_player_1_loc_0}; {0: heuristic_player_0_loc_1; 1: heuristic_player_1_loc_1}] advancement_ratio location TIMEOUT time_in_sec iters_or_depth_limit method optional_playout_horizon" - m = self.msg ("EVAL LOC MOVES 2.0 " + str(loc) +" TIMEOUT 1200 "+ str(no_iters) + " alpha_beta_ord") + m = self.msg ("EVAL LOC MOVES " + str(adv_ratio) + ".0 " + str(loc) +" TIMEOUT 1200 "+ str(no_iters) + " alpha_beta_ord") self.set_time (ts, t) msg = [s.strip() for s in m.split(';')] emb = dict() Modified: trunk/Toss/examples/Breakthrough.toss =================================================================== --- trunk/Toss/examples/Breakthrough.toss 2010-11-30 15:31:45 UTC (rev 1211) +++ trunk/Toss/examples/Breakthrough.toss 2010-12-01 22:13:31 UTC (rev 1212) @@ -1,4 +1,5 @@ PLAYERS 1, 2 +DATA depth: 3 RULE 1: [ | B:1 {} | ] " Modified: trunk/Toss/examples/Gomoku.toss =================================================================== --- trunk/Toss/examples/Gomoku.toss 2010-11-30 15:31:45 UTC (rev 1211) +++ trunk/Toss/examples/Gomoku.toss 2010-12-01 22:13:31 UTC (rev 1212) @@ -1,4 +1,5 @@ PLAYERS 1, 2 +DATA r1: circle, r2: line, adv_ratio: 4 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.}] @@ -169,4 +170,4 @@ ... ... ... ... ... ... ... ... ... ... ... ... -" \ No newline at end of file +" This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-12-04 01:59:13
|
Revision: 1215 http://toss.svn.sourceforge.net/toss/?rev=1215&view=rev Author: lukaszkaiser Date: 2010-12-04 01:59:06 +0000 (Sat, 04 Dec 2010) Log Message: ----------- Entanglement rewrite and WebClient corrections. Modified Paths: -------------- trunk/Toss/Solver/Structure.ml trunk/Toss/WebClient/TossConnect.js trunk/Toss/WebClient/Wrapper.py trunk/Toss/examples/Entanglement.toss Modified: trunk/Toss/Solver/Structure.ml =================================================================== --- trunk/Toss/Solver/Structure.ml 2010-12-02 22:51:40 UTC (rev 1214) +++ trunk/Toss/Solver/Structure.ml 2010-12-04 01:59:06 UTC (rev 1215) @@ -286,7 +286,8 @@ | None -> if tps = [] then raise ( Structure_mismatch - "Structure.add_from_lists: relation of undetermined arity") + ("Structure.add_from_lists: relation of undetermined arity: " ^ + rn)) else Array.length (List.hd tps) | Some ar -> ar in let s = add_rel_name rn arity s in Modified: trunk/Toss/WebClient/TossConnect.js =================================================================== --- trunk/Toss/WebClient/TossConnect.js 2010-12-02 22:51:40 UTC (rev 1214) +++ trunk/Toss/WebClient/TossConnect.js 2010-12-04 01:59:06 UTC (rev 1215) @@ -93,8 +93,10 @@ var rels = []; for (var i = 0; i < r.length; i++) { var rel_name = strip(' ', '\'', r[i].substring(1,r[i].indexOf(','))); - var args_s = r[i].substring(r[i].indexOf('['), r[i].indexOf(']')); - rels.push ([rel_name, convert_python_list (',', args_s)]); + var args_s = r[i].substring(r[i].indexOf('[')+1, r[i].indexOf(']')); + if (rel_name[0] != "_" && args_s != "''") { + rels.push ([rel_name, convert_python_list (',', args_s)]); + } } return (rels) } Modified: trunk/Toss/WebClient/Wrapper.py =================================================================== --- trunk/Toss/WebClient/Wrapper.py 2010-12-02 22:51:40 UTC (rev 1214) +++ trunk/Toss/WebClient/Wrapper.py 2010-12-04 01:59:06 UTC (rev 1215) @@ -21,7 +21,7 @@ return ("SOME MODEL", "SFX") def _pos (self): - if self.i == 0: + if self.i == ";MODEL": return (" MODEL ") if self.p == 0: return (" RULE " + (str (self.i)) + " LEFT ") @@ -123,9 +123,9 @@ def get_rel (self, rel_name): m = self.s.msg ("GET ALLOF REL" + (self._pos ()) + rel_name) cur = m.find('{') - if cur < 0: return ([]) - if m.find('(') < 0: return ([]) - tps = [ts.strip('() ') for ts in m[cur+1:-1].split(";")] + par = m.find('(') + if cur < 0 and par < 0: return ([]) + tps = [ts.strip('{}() ') for ts in m[max(cur,par):].split(";")] return ([[t.strip() for t in ts.split(",")] for ts in tps]) def get_rels (self, nodes = []): @@ -152,13 +152,10 @@ return (self.s.set_arity (rel, i)) def get_rel_names_arities (self): - msig = "; ".join (self.s.msg ("GET SIGNATURE").split(',')) mrel = self.s.msg ("GET SIGNATURE REL" + (self._pos ())) - m = mrel + (", ".join (msig.split (':'))) - if len(m) < 1: return ([]) - if len(mrel) < 1: m = m[2:] - pair_strs = [s.strip() for s in m.split (';')] - rels_ar_lst = [p.split(',') for p in pair_strs] + if len(mrel) < 1: return ([]) + pair_strs = [s.strip() for s in mrel.split (',')] + rels_ar_lst = [p.split(':') for p in pair_strs] rels = [(rl[0].strip(), int (rl[1].strip())) for rl in rels_ar_lst] return ([r for r in set(rels)]) @@ -181,11 +178,11 @@ self.changes = 0 # increment on each change of model or rules # Initialize the model and the rules. - self.model = ModelClient (self, 0, 0) - self.rules = [(ModelClient (self, i+1, 0), ModelClient (self, i+1, 1)) - for i in range(self.__no_of_rules ())] + self.model = ModelClient (self, ";MODEL", 0) + self.rule_names = self.__names_of_rules () + self.rules = [(ModelClient (self, i, 0), ModelClient (self, i, 1)) + for i in self.rule_names] - def __str__ (self): return ("System") @@ -203,9 +200,17 @@ def __no_of_rules (self): """Get number of rewrite rules from server.""" - i = self.msg ("GET RULE") - return (int (i)); + names_msg = self.msg ("GET RULE") + if len(names_msg.strip()) < 1: return(0) + names = [s.strip() for s in names_msg.split (';')] + return (int (len(names))); + def __names_of_rules (self): + """Get names of rewrite rules from server.""" + names_msg = self.msg ("GET RULE") + if len(names_msg.strip()) < 1: return([]) + return ([s.strip() for s in names_msg.split (';')]) + def no_of_locs (self): """Get number of game locations from server.""" m = self.msg ("GET LOC").split("/") @@ -307,65 +312,67 @@ return (m) def add_rule (self): - rule_no = len(self.rules) + 1 + rule_name = str(len(self.rules) + 1) + self.rule_names.append(rule_name) emptyr_str = " [||]->[||] with [] pre true inv true post true" self.changes += 1 - self.msg ("SET RULE " + (str (rule_no)) + emptyr_str) - rl = ModelClient (self, rule_no, 0) - rr = ModelClient (self, rule_no, 1) + self.msg ("SET RULE " + rule_name + emptyr_str) + rl = ModelClient (self, rule_name, 0) + rr = ModelClient (self, rule_name, 1) self.rules.append ((rl, rr)) - return (rule_no) + return (len(self.rules)) + def get_conditions (self, i): - m = self.msg ("GET RULE cond " + str(i)) + m = self.msg ("GET RULE cond " + self.rule_names[i]) return ([c.strip() for c in m.split(";")]) def set_conditions (self, i, pre_s, inv_s, post_s): self.changes += 1 - m = self.msg ("SET RULE cond " + str(i) + " " + pre_s + + m = self.msg ("SET RULE cond " + self.rule_names[i] + " " + pre_s + " " + inv_s + " " + post_s) return (m) def get_emb_rels (self, i): - m = self.msg ("GET RULE emb " + str(i)) + m = self.msg ("GET RULE emb " + self.rule_names[i]) return (m) def set_emb_rels (self, i, lst_s): self.changes += 1 - m = self.msg ("SET RULE emb " + str(i) + " " + lst_s) + m = self.msg ("SET RULE emb " + self.rule_names[i] + " " + lst_s) return (m) def get_embeddings (self, i, elem): - m = self.msg ("GET RULE assoc " + str(i) + " " + str(elem)) + m = self.msg ("GET RULE assoc " + self.rule_names[i] + " " + str(elem)) return (m) def set_embeddings (self, i, elem, lst_s): self.changes += 1 - m = self.msg ("SET RULE assoc " + str(i) + " "+ str(elem) + " " + lst_s) + m = self.msg ("SET RULE assoc " + self.rule_names[i] + " "+ str(elem) + " " + lst_s) return (m) def get_update (self, i, elem, fun): - m = self.msg ("GET RULE update " + str(i) + " "+ fun + " " + str(elem)) + m = self.msg ("GET RULE update " + self.rule_names[i] + " "+ fun + " " + str(elem)) return (m) def set_update (self, i, elem, fun, t): self.changes += 1 - m = self.msg ("SET RULE update " + str(i) + " " + + m = self.msg ("SET RULE update " + self.rule_names[i] + " " + fun + " " + str(elem) + " " + t) return (m) def get_dynamic (self, i, elem, fun): - m = self.msg ("GET RULE dynamics "+ str(i) +" "+ fun + " " + str(elem)) + m = self.msg ("GET RULE dynamics "+ self.rule_names[i] +" "+ fun + " " + str(elem)) return (m) def set_dynamic (self, i, elem, fun, t): self.changes += 1 - m = self.msg ("SET RULE dynamics "+ str(i) + " " + + m = self.msg ("SET RULE dynamics "+ self.rule_names[i] + " " + fun + " " + str(elem) + " " + t) return (m) - def query (self, rule_id): - msg = self.msg ("GET RULE " + (str (rule_id)) + " MODEL") + def query (self, rule_nm): + msg = self.msg ("GET RULE " + rule_nm + " MODEL") if msg.find('->') < 0: return ([]) def make_match (m_str): m = dict () @@ -375,16 +382,17 @@ return (m) return ([make_match (m.strip()) for m in msg.split(';')]) - def apply_rule (self, rule_id, match, time, params): + def apply_rule (self, rule_nm, match, time, params): match_s = ", ".join([str(l) + ": " + str(r) for (l,r) in match.items()]) param_s = ", ".join([str(p) + ": " + repr(v) for (p,v) in params]) - m = self.msg ("SET RULE "+ str(rule_id) + " MODEL " + match_s + + m = self.msg ("SET RULE "+ rule_nm + " MODEL " + match_s + " " + repr(time) + " " + param_s) shifts = dict () for s in [s.strip() for s in m.split(";")]: seq = [e.strip() for e in s.split(",")] - if not (seq[0] in shifts.keys()): shifts[seq[0]] = dict () - shifts[seq[0]][seq[1]] = [float(f) for f in seq[2:]] + if len(seq) > 2: + if not (seq[0] in shifts.keys()): shifts[seq[0]] = dict () + shifts[seq[0]][seq[1]] = [float(f) for f in seq[2:]] return (shifts) def set_time (self, tstep, t): @@ -422,7 +430,7 @@ file = open (file_name, 'r') state = file.read () file.close () - state_str = " ".join (state.split ()) + state_str = ("#"+file_name+"#") + "$".join (state.split ("\n")) self.set_state (state_str) def cur_move_touching (self, elem): Modified: trunk/Toss/examples/Entanglement.toss =================================================================== --- trunk/Toss/examples/Entanglement.toss 2010-12-02 22:51:40 UTC (rev 1214) +++ trunk/Toss/examples/Entanglement.toss 2010-12-04 01:59:06 UTC (rev 1215) @@ -1,50 +1,46 @@ -3: [ 1 | R { (1) } | vx { 1->0. }; vy { 1->0. }; x { 1->-13.2 }; y { 1->-8.8 } ] -> [ 1 | R { (1) } | vx { 1->0. }; vy { 1->0. }; x { 1->-8.8 }; y { 1->-1.1 } ] emb R, C with 1 <- 1 -dynamics - vy(1)' = 0.; - vx(1)' = 0.; - y(1)' = 0.; - x(1)' = 0. -update - vy(1) = 0.; - vx(1) = 0.; - y(1) = y(1); - x(1) = x(1) - pre true inv true post true; 2: [ 1, 2 | C { }; E { (1, 2) }; R { (1) }; _opt_C { (1) } | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-47.3, 2->9.9 }; y { 1->-19.8, 2->-20.9 } ] -> [ 1, 2 | C { }; E { (1, 2) }; R { (2) }; opt_C { (1) } | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-41.8, 2->14.3 }; y { 1->-15.4, 2->-13.2 } ] emb R, C with 2 <- 2, 1 <- 1 -dynamics - vy(2)' = 0.; - vy(1)' = 0.; - vx(2)' = 0.; - vx(1)' = 0.; - y(2)' = 0.; - y(1)' = 0.; - x(2)' = 0.; - x(1)' = 0. -update - vy(2) = 0.; - vy(1) = 0.; - vx(2) = 0.; - vx(1) = 0.; - y(2) = y(2); - y(1) = y(1); - x(2) = x(2); - x(1) = x(1) - pre true inv true post true; 1: [ 1, 2 | C { (2) }; R { (1) } | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-19.8, 2->-21.7229777685 }; y { 1->-18.7, 2->10.1373896253 } ] -> [ 1, 2 | C { (1) }; R { (1) } | vx { 1->0., 2->0. }; vy { 1->0., 2->0. }; x { 1->-5.5, 2->-6.92397351637 }; y { 1->-18.7, 2->5.9348344426 } ] emb C, R with 2 <- 2, 1 <- 1 -dynamics - vy(2)' = 0.; - vy(1)' = 0.; - vx(2)' = 0.; - vx(1)' = 0.; - y(2)' = 0.; - y(1)' = 0.; - x(2)' = 0.; - x(1)' = 0. -update - vy(2) = 0.; - vy(1) = 0.; - vx(2) = 0.; - vx(1) = 0.; - y(2) = y(2); - y(1) = y(1); - x(2) = x(2); - x(1) = x(1) - pre true inv true post true; < 0 : 0 PAYOFF 1: 0.; 0: 0. MOVES [3, t: 1. -- 1. -> 1]; [1, t: 1. -- 1. -> 1] >, < 1 : 1 PAYOFF 1: -1.; 0: 1. MOVES [2, t: 1. -- 1. -> 0] >; [ 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 { } | 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. } ]; 0.; 0; r3: none, r2: none, r1: none; E: 2, C: 1, opt_C: 1, R: 1 +PLAYERS 1, 2 +RULE 1: + [ a1, a2 | C { (a2) }; R { (a1) } | + vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; + x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ] + -> + [ a1, a2 | C { (a1) }; R { (a1) } | + vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; + x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ] +emb R, C +RULE 2: + [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a1) }; _opt_C { (a1) } | + vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; + x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ] + -> + [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a2) }; _opt_C { (a1) } | + vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; + x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ] +emb R, C +RULE 3: + [ a1 | R { (a1) } | + vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ] + -> + [ a1 | R { (a1) } | + vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ] +emb R, C +LOC 0 { + PLAYER 1 + PAYOFF { + 1: 0.; + 2: 0. + } + MOVES + [1 -> 1]; + [3 -> 1] + } +LOC 1 { + PLAYER 2 + PAYOFF { + 1: 1.; + 2: -1. + } + MOVES + [2 -> 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. } ] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-12-04 13:02:41
|
Revision: 1216 http://toss.svn.sourceforge.net/toss/?rev=1216&view=rev Author: lukstafi Date: 2010-12-04 13:02:34 +0000 (Sat, 04 Dec 2010) Log Message: ----------- Handling of postconditions (not optimized yet for alpha-beta). Loading Chess in GameTest. More diagnostic logging in Heuristic and FFTNF. Modified Paths: -------------- trunk/Toss/Arena/Arena.ml trunk/Toss/Arena/ArenaTest.ml trunk/Toss/Arena/ContinuousRule.ml trunk/Toss/Arena/ContinuousRule.mli trunk/Toss/Arena/ContinuousRuleTest.ml trunk/Toss/Formula/Aux.ml trunk/Toss/Formula/Aux.mli trunk/Toss/Formula/AuxTest.ml trunk/Toss/Play/Game.ml trunk/Toss/Play/GameTest.ml trunk/Toss/Play/Heuristic.ml Modified: trunk/Toss/Arena/Arena.ml =================================================================== --- trunk/Toss/Arena/Arena.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Arena/Arena.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -508,8 +508,8 @@ AddElem loc -> apply_to_loc add_new_elem loc state "add elem" | AddRel (loc, rel, tp) -> - (* FIXME: remove this note if AddRel needs to add new - elements, otherwise simplify *) + (* FIXME: remove this note if AddRel needs to add new + elements, otherwise simplify *) let add_rel struc = let struc, tp = List.fold_right (fun n (struc, tp) -> @@ -799,14 +799,15 @@ let m = List.map (fun (l, s) -> Structure.find_elem lhs_struc l, Structure.find_elem state.struc s) mtch in - let (new_struc, new_time, shifts) = - ContinuousRule.rewrite_single struc state.time m r t p in - let val_str ((f, e), tl) = - let ts t = string_of_float (Term.term_val t) in + match ContinuousRule.rewrite_single struc state.time m r t p with + | Some (new_struc, new_time, shifts) -> + let val_str ((f, e), tl) = + let ts t = string_of_float (Term.term_val t) in (* we've moved to using element names in Term *) - f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in - let shifts_s = String.concat "; " (List.map val_str shifts) in - ({state with struc = new_struc; time = new_time}, shifts_s) + f ^ ", " ^ e ^ ", " ^ (String.concat ", " (List.map ts tl)) in + let shifts_s = String.concat "; " (List.map val_str shifts) in + ({state with struc = new_struc; time = new_time}, shifts_s) + | None -> (state, "ERR applying "^r_name^", postcondition fails") with Not_found -> (state, "ERR applying "^r_name^", rule not found") ) | GetRuleNames -> (state, String.concat "; " (fst (List.split state.game.rules))) Modified: trunk/Toss/Arena/ArenaTest.ml =================================================================== --- trunk/Toss/Arena/ArenaTest.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Arena/ArenaTest.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -113,6 +113,7 @@ "setting states from examples dir" >:: (fun () -> backtrace ( + skip_if true "Change to simpler and stable example."; let fname = "./examples/Breakthrough.toss" in let file = open_in fname in let contents = String.make 4000 '$' in Modified: trunk/Toss/Arena/ContinuousRule.ml =================================================================== --- trunk/Toss/Arena/ContinuousRule.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Arena/ContinuousRule.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -79,8 +79,8 @@ (List.hd ids, List.map List.hd llst) :: (select_pos (List.tl ids) (List.map List.tl llst)) -(* For now, we rewrite only single rules. *) -let rewrite_single struc cur_time m r t params = +(* For now, we rewrite only single rules. Does not check postcondition. *) +let rewrite_single_nocheck struc cur_time m r t params = let time = ref cur_time in let left_elname le = Structure.elem_str r.discrete.DiscreteRule.lhs_struc le in @@ -159,6 +159,26 @@ (res_struc, !time, all_vals_assoc) +(* Matches which satisfy postcondition with time 1 and empty params *) +let matches_post struc r cur_time = + let is_ok m = + let (res_struc, _, _) = + rewrite_single_nocheck struc cur_time m r 1. [] in + SolverIntf.M.check_formula res_struc r.post_pp in + if r.post = Formula.And [] then matches struc r else + List.filter is_ok (matches struc r) + +(* For now, we rewrite only single rules. Returns [None] if rewriting + fails. *) +let rewrite_single struc cur_time m r t params = + let (res_struc, _, _ as res_struc_n_shifts) = + rewrite_single_nocheck struc cur_time m r t params in + if r.post = Formula.And [] || + SolverIntf.M.check_formula res_struc r.post_pp + then Some res_struc_n_shifts + else None + + (* -------------------------- PRINTING FUNCTION ----------------------------- *) (* Print a rule to string. *) @@ -177,16 +197,6 @@ dyn_str ^ upd_str ^ pre_str ^ inv_str ^ post_str -(* Matches which satisfy postcondition with time 1 and empty params *) -let matches_post struc r cur_time = - let is_ok m = - let (res_struc, _, _) = rewrite_single struc cur_time m r 1. [] in - SolverIntf.M.check_formula res_struc r.post_pp in - if r.post = Formula.And [] then matches struc r else - List.filter is_ok (matches struc r) - - - let has_dynamics r = r.dynamics <> [] (* List.exists (fun (_, t) -> t <> Term.Const 0.) r.dynamics *) Modified: trunk/Toss/Arena/ContinuousRule.mli =================================================================== --- trunk/Toss/Arena/ContinuousRule.mli 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Arena/ContinuousRule.mli 2010-12-04 13:02:34 UTC (rev 1216) @@ -73,7 +73,17 @@ starting in [cur_time], at matching [m], and returns the rewritten structure, the time after the rewrite, and shifts (i.e. values for functions supplied with dynamics equations, at each time step). *) +val rewrite_single_nocheck : + Structure.structure -> float -> + (int * int) list -> rule -> float -> (string * float) list -> + Structure.structure * float * ((string * string) * Term.term list) list + +(* For now, we rewrite only single rules. + + Same as {!ContinuousRule.rewrite_single_nocheck}, but check if the + postcondition holds. Returns [None] if rewriting fails. *) val rewrite_single : Structure.structure -> float -> (int * int) list -> rule -> float -> (string * float) list -> - Structure.structure * float * ((string * string) * Term.term list) list + (Structure.structure * + float * ((string * string) * Term.term list) list) option Modified: trunk/Toss/Arena/ContinuousRuleTest.ml =================================================================== --- trunk/Toss/Arena/ContinuousRuleTest.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Arena/ContinuousRuleTest.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -96,7 +96,7 @@ let r = rule_of_str s signat [] in let m = List.hd (matches struc r) in let res, _, _ = - rewrite_single struc 0.0 m r 1. [] in + Aux.unsome (rewrite_single struc 0.0 m r 1. []) in assert_equal ~printer:(fun x->x) "[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]" (remove_insignificant_digits (Structure.str res)); @@ -116,12 +116,12 @@ let r = rule_of_str s signat [] in let m = List.hd (matches struc r) in let res, _, _ = - rewrite_single struc 0.0 m r 1. [] in + Aux.unsome (rewrite_single struc 0.0 m r 1. []) in assert_equal ~printer:(fun x->x) ~msg:"first rewrite" "[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]" (remove_insignificant_digits (Structure.str res)); let res, _, _ = - rewrite_single struc 0.0 m r 1. [] in + Aux.unsome (rewrite_single struc 0.0 m r 1. []) in assert_equal ~printer:(fun x->x) ~msg:"second rewrite" "[a | P:1 {}; Q (a); _del_P (a); _new_Q (a) | x {a->0.71}]" (remove_insignificant_digits (Structure.str res)) Modified: trunk/Toss/Formula/Aux.ml =================================================================== --- trunk/Toss/Formula/Aux.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Formula/Aux.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -140,6 +140,24 @@ | _ -> acc in List.rev (aux n [] l) +let array_map_some f a = + let r = Array.map 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 @@ -272,6 +290,9 @@ | Left e -> Left (f e) | Right e -> Right (g e) +let map_option f = function None -> None + | Some e -> Some (f e) + let transpose_lists lls = let rec aux acc = function | [] -> List.map List.rev acc Modified: trunk/Toss/Formula/Aux.mli =================================================================== --- trunk/Toss/Formula/Aux.mli 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Formula/Aux.mli 2010-12-04 13:02:34 UTC (rev 1216) @@ -93,6 +93,9 @@ [Invalid_argument "Aux.array_from_assoc"] otherwise. *) val array_from_assoc : (int * 'a) list -> 'a array +(** Map an array filtering out some elements. *) +val array_map_some : ('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. *) val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array @@ -140,6 +143,8 @@ val map_choice : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) choice -> ('b, 'd) choice +val map_option : ('a -> 'b) -> 'a option -> 'b option + (** Transpose a rectangular matrix represented by lists. Raises [Invalid_argument "List.map2"] when matrix is not rectangular. *) val transpose_lists : 'a list list -> 'a list list Modified: trunk/Toss/Formula/AuxTest.ml =================================================================== --- trunk/Toss/Formula/AuxTest.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Formula/AuxTest.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -5,7 +5,7 @@ String.concat ", " (List.map (fun (k,v) -> k^": "^f v) l) let tests = "Aux" >::: [ - "concat_map, map_some" >:: + "concat_map, map_some, array_map_some" >:: (fun () -> let f = function `A -> ["a";"b"] | `B -> ["c"] | `C -> [] | `D -> ["d";"e"] in @@ -18,6 +18,12 @@ assert_equal ~printer:(String.concat "; ") ["a";"b";"d"] (Aux.map_some f [`A;`B;`C;`D]); + + let f = function `A -> Some "a" | `B -> Some "b" | `C -> None + | `D -> Some "d" in + assert_equal ~printer:(fun x->String.concat "; "(Array.to_list x)) + [|"a";"b";"d"|] + (Aux.array_map_some f [|`A;`B;`C;`D|]); ); "map_reduce" >:: Modified: trunk/Toss/Play/Game.ml =================================================================== --- trunk/Toss/Play/Game.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Play/Game.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -248,6 +248,12 @@ else None in Array.map (fun node -> Array.map (fun payoff -> + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf "default_hauristic: Computing of payoff %s...\n%!" + (Formula.real_str payoff); + ); + (* }}} *) Heuristic.of_payoff ?struc ?fluent_preconds advance_ratio (Aux.strings_of_list fluents) payoff) node.Arena.payoffs) graph @@ -588,13 +594,14 @@ ) matchings)) let gen_models rules defined_rels model time moves = - Array.map (fun mv -> + Aux.array_map_some (fun mv -> let rule = List.assoc mv.rule rules in - (* ignoring shifts, i.e. animation steps *) - let model, time, _ = - ContinuousRule.rewrite_single model time mv.embedding - rule mv.mv_time mv.parameters in - {loc=mv.next_loc; struc=model; time=time}) moves + Aux.map_option + (fun (model, time, _) -> + (* ignoring shifts, i.e. animation steps *) + {loc=mv.next_loc; struc=model; time=time}) + (ContinuousRule.rewrite_single model time mv.embedding + rule mv.mv_time mv.parameters)) moves let debug_count = ref 0 @@ -648,17 +655,26 @@ let agent = agents.(state.loc) in match agent with | Random_move -> - let pos = Random.int (Array.length moves) in - let mv = moves.(pos) in - let rule = List.assoc mv.rule rules in - let model, time, _ = (* ignoring shifts *) - ContinuousRule.rewrite_single state.struc state.time - mv.embedding rule mv.mv_time mv.parameters in - let state = {loc=mv.next_loc; struc=model; time=time} in + let pos = ref (Random.int (Array.length moves)) in + let nstate = ref None in + while !nstate = None do + pos := (!pos + 1) mod Array.length moves; + let mv = moves.(!pos) in + let rule = List.assoc mv.rule rules in + nstate := + Aux.map_option + (fun (model, time, _) -> + (* ignoring shifts, i.e. animation steps *) + {loc=mv.next_loc; struc=model; time=time}) + (ContinuousRule.rewrite_single state.struc state.time + mv.embedding rule mv.mv_time mv.parameters); + done; + let state = Aux.unsome !nstate in + (* FIXME: [pos] refers to unfiltered array! *) Aux.Left - (pos, moves, memory, + (!pos, moves, memory, {game_state = state; - memory = update_memory ~num_players state pos memory}) + memory = update_memory ~num_players state !pos memory}) | Maximax_evgame (subgames, cooperative, depth, use_pruning, reorder) -> (* {{{ log entry *) @@ -1171,9 +1187,6 @@ (* {{{ log entry *) if !debug_level > 0 then printf "\ninitializing game and play\n%!"; (* }}} *) - (* {{{ log entry *) - if !debug_level > 2 then printf "game initialized\n%!"; - (* }}} *) (* TODO: default_heuristic redoes payoff normalization. *) let game = state.Arena.game in let play = Modified: trunk/Toss/Play/GameTest.ml =================================================================== --- trunk/Toss/Play/GameTest.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Play/GameTest.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -25,9 +25,13 @@ (Lexing.from_string s) let state_of_file s = + Printf.printf "Loading file %s...\n%!" s; let f = open_in s in - ArenaParser.parse_game_state Lexer.lex - (Lexing.from_channel f) + let res = + ArenaParser.parse_game_state Lexer.lex + (Lexing.from_channel f) in + Printf.printf "File %s loaded.\n%!" s; + res module StrMap = Structure.StringMap module IntMap = Structure.IntMap @@ -463,6 +467,9 @@ let breakthrough_heur = breakthrough_heur_adv 1.5 +let chess_game = + 2.0, state_of_file "./examples/Chess.toss" + let check_loc_random = function | Game.Tree_search (_,_,_,evgames) -> if @@ -555,6 +562,22 @@ assert_bool "Game is not over yet -- some move expected." (move_opt <> None) ); + + "play: chess suggest first move" >:: + (fun () -> + todo "Payoff too difficult for heuristic generation."; + let state = chess_game in + Game.set_debug_level 7; + Heuristic.debug_level := 7; + FFTNF.debug_level := 7; + let move_opt = (let p,ps = Game.initialize_default (snd state) + ~heur_adv_ratio:(fst state) + ~loc:0 ~effort:2 + ~search_method:"alpha_beta_ord" () in + Game.suggest p ps) in + assert_bool "Game is not over yet -- some move expected." + (move_opt <> None) + ); "breakthrough payoff" >:: (fun () -> @@ -1085,7 +1108,7 @@ let a () = match test_filter - ["Game:1:alpha_beta_ord:10:breakthrough suggest depth"] + ["Game:0:misc:0:play: chess suggest first move"] tests with | Some tests -> ignore (run_test_tt ~verbose:true tests) Modified: trunk/Toss/Play/Heuristic.ml =================================================================== --- trunk/Toss/Play/Heuristic.ml 2010-12-04 01:59:06 UTC (rev 1215) +++ trunk/Toss/Play/Heuristic.ml 2010-12-04 13:02:34 UTC (rev 1216) @@ -613,37 +613,45 @@ let rec aux all_vars = function | Or phis -> Or (List.map (aux all_vars) phis) | And phis as phi when has_rels frels phi -> - And (List.map (aux all_vars) phis) + And (List.map (aux all_vars) phis) | Ex (vs, phi) when has_rels frels phi -> - Ex (vs, aux (add_strings (List.map var_str vs) all_vars) phi) + Ex (vs, aux (add_strings (List.map var_str vs) all_vars) phi) | phi -> - if has_rels frels phi then phi - else - let vars = - (* TODO: assumes all variables are FO! *) - List.map Formula.to_fo (FormulaOps.free_vars phi) in - if vars = [] then phi - else - let substs = - AssignmentSet.fo_assgn_to_list elems vars - (SolverIntf.M.evaluate struc - (SolverIntf.M.register_formula phi)) in - (* sort substitutions; TODO: optimizable *) - let substs = trunc_to_vars vars substs in - let all_vars = add_strings (List.map var_str vars) all_vars in - match - expanded_descr max_alt_descr elems rels struc - all_vars vars substs - with - | Or [] -> - (match phi with - | And phis -> And (List.map (aux all_vars) phis) - | Ex (vs, phi) -> - Ex (vs, aux - (add_strings (List.map var_str vs) all_vars) phi) - | _ -> phi) - | Or [psi] -> psi - | psi -> psi in + if has_rels frels phi then phi + else + let vars = + (* TODO: assumes all variables are FO! *) + List.map Formula.to_fo (FormulaOps.free_vars phi) in + if vars = [] then phi + else begin + (* {{{ log entry *) + if !debug_level > 3 then ( + Printf.printf + "Heuristic: computing expanded description for %s...\n%!" + (Formula.str phi) + ); + (* }}} *) + let substs = + AssignmentSet.fo_assgn_to_list elems vars + (SolverIntf.M.evaluate struc + (SolverIntf.M.register_formula phi)) in + (* sort substitutions; TODO: optimizable *) + let substs = trunc_to_vars vars substs in + let all_vars = add_strings (List.map var_str vars) all_vars in + match + expanded_descr max_alt_descr elems rels struc + all_vars vars substs + with + | Or [] -> + (match phi with + | And phis -> And (List.map (aux all_vars) phis) + | Ex (vs, phi) -> + Ex (vs, aux + (add_strings (List.map var_str vs) all_vars) phi) + | _ -> phi) + | Or [psi] -> psi + | psi -> psi + end in aux Strings.empty phi @@ -805,14 +813,44 @@ | None -> (* not monotonic *) let phi' = match struc with | Some struc -> - (* guards are currently ignored *) - expanded_form max_alt_descr frels struc - (FFTNF.ff_tnf (FFTNF.promote_rels frels) phi) + (* guards are currently ignored *) + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf + "Heuristic: for expanding, get ff-tnf of %s...\n%!" + (Formula.str phi); + ); + (* }}} *) + let phi'' = + FFTNF.ff_tnf (FFTNF.promote_rels frels) phi in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf + "Heuristic: computing expanded form of %s...\n%!" + (Formula.str phi''); + ); + (* }}} *) + expanded_form max_alt_descr frels struc phi'' | None -> phi in + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf + "Heuristic: computing for (expanded) formula %s...\n%!" + (Formula.str phi') + ); + (* }}} *) of_formula adv_ratio (FFTNF.ff_tnf (FFTNF.promote_rels frels) phi') | Some fluent_preconds -> (* monotonic case *) + (* {{{ log entry *) + if !debug_level > 2 then ( + Printf.printf + "Heuristic: computing monotonic for %s...\n%!" + (Formula.str phi); + ); + (* }}} *) + (* FIXME: shouldn't be expanding? *) of_preconds fluent_preconds adv_ratio frels phi ) | Sum (vl, gd, e) -> Sum (vl, gd, aux (gd::gds) e) in This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-12-04 23:46:22
|
Revision: 1218 http://toss.svn.sourceforge.net/toss/?rev=1218&view=rev Author: lukaszkaiser Date: 2010-12-04 23:46:15 +0000 (Sat, 04 Dec 2010) Log Message: ----------- Chess in WebClient, using names for rules. Modified Paths: -------------- trunk/Toss/WebClient/TossConnect.js trunk/Toss/WebClient/TossDefaultStyle.js trunk/Toss/WebClient/TossMain.js trunk/Toss/WebClient/TossStyle.css trunk/Toss/WebClient/Wrapper.py trunk/Toss/WebClient/index.html trunk/Toss/examples/Breakthrough.toss trunk/Toss/examples/Chess.toss trunk/Toss/examples/Entanglement.toss trunk/Toss/examples/Gomoku.toss trunk/Toss/examples/Tic-Tac-Toe.toss Modified: trunk/Toss/WebClient/TossConnect.js =================================================================== --- trunk/Toss/WebClient/TossConnect.js 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/WebClient/TossConnect.js 2010-12-04 23:46:15 UTC (rev 1218) @@ -29,6 +29,8 @@ var SUGGESTED_ELEM_SIZEX = 25; // suggested size of elements var SUGGESTED_ELEM_SIZEY = 25; // suggested size of elements +var CACHED_MOVES = "" + // Helper function: sign of a number. function sign (x) { if (x > 0.01) { return (1); } @@ -36,6 +38,11 @@ else { return (0); } } +// Clears cached moves. +function clear_move_cache () { + CACHED_MOVES = ""; +} + // Send [msg] to server and return response text. function sync_server_msg (msg) { var xml_request = new XMLHttpRequest (); @@ -83,8 +90,17 @@ // Get moves applicable to [elem] in Toss Model active on [port]. function get_moves (port, elem) { - var moves_s = srv (port, 'c.cur_move_touching("' + elem + '")'); - return (convert_python_list (';', moves_s)) + if (CACHED_MOVES == "") { + CACHED_MOVES = srv (port, 'c.cur_moves()'); + } + var all_moves = convert_python_list (';', CACHED_MOVES); + var elem_moves = [] + for (i = 0; i < all_moves.length; i++) { + if (all_moves[i].indexOf(elem) >= 0) { + elem_moves.push(all_moves[i]) + } + } + return (elem_moves) } // Get relation tuples of Toss Model active on [port]. Modified: trunk/Toss/WebClient/TossDefaultStyle.js =================================================================== --- trunk/Toss/WebClient/TossDefaultStyle.js 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/WebClient/TossDefaultStyle.js 2010-12-04 23:46:15 UTC (rev 1218) @@ -9,6 +9,133 @@ // - draw_rel (rel_name, args) +var DEFpawn = '<g transform="translate(-22.5,-22.5)"> \ + <path \ + d="M 22,9 C 19.792,9 18,10.792 18,13 C 18,13.885 18.294,14.712 18.781,15.375 C 16.829,16.497 15.5,18.588 15.5,21 C 15.5,23.034 16.442,24.839 17.906,26.031 C 14.907,27.089 10.5,31.578 10.5,39.5 L 33.5,39.5 C 33.5,31.578 29.093,27.089 26.094,26.031 C 27.558,24.839 28.5,23.034 28.5,21 C 28.5,18.588 27.171,16.497 25.219,15.375 C 25.706,14.712 26,13.885 26,13 C 26,10.792 24.208,9 22,9 z " \ + class="chess-path-A" /> \ + </g>'; + +var DEFknight = '<g transform="translate(-22.5,-22.5)"> \ + <path \ + d="M 22,10 C 32.5,11 38.5,18 38,39 L 15,39 C 15,30 25,32.5 23,18" \ + class="chess-path-B" /> \ + <path \ + d="M 24,18 C 24.384,20.911 18.447,25.369 16,27 C 13,29 13.181,31.343 11,31 C 9.9583,30.056 12.413,27.962 11,28 C 10,28 11.187,29.232 10,30 C 9,30 5.9968,31 6,26 C 6,24 12,14 12,14 C 12,14 13.886,12.098 14,10.5 C 13.274,9.5056 13.5,8.5 13.5,7.5 C 14.5,6.5 16.5,10 16.5,10 L 18.5,10 C 18.5,10 19.282,8.0081 21,7 C 22,7 22,10 22,10" \ + class="chess-path-B" /> \ + <path \ + d="M 9 23.5 A 0.5 0.5 0 1 1 8,23.5 A 0.5 0.5 0 1 1 9 23.5 z" \ + transform="translate(0.5,2)" \ + class="chess-path-C" /> \ + <path \ + d="M 15 15.5 A 0.5 1.5 0 1 1 14,15.5 A 0.5 1.5 0 1 1 15 15.5 z" \ + transform="matrix(0.866,0.5,-0.5,0.866,9.6926,-5.1734)" \ + class="chess-path-C" /> \ + <path \ + d="M 37,39 C 38,19 31.5,11.5 25,10.5" \ + class="chess-path-D" /> \ + </g>'; + +var DEFbishop = '<g transform="translate(-22.5,-22.5)"> \ + <path \ + d="M 9,36 C 12.385,35.028 19.115,36.431 22.5,34 C 25.885,36.431 32.615,35.028 36,36 C 36,36 37.646,36.542 39,38 C 38.323,38.972 37.354,38.986 36,38.5 C 32.615,37.528 25.885,38.958 22.5,37.5 C 19.115,38.958 12.385,37.528 9,38.5 C 7.6459,38.986 6.6771,38.972 6,38 C 7.3541,36.055 9,36 9,36 z " \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 15,32 C 17.5,34.5 27.5,34.5 30,32 C 30.5,30.5 30,30 30,30 C 30,27.5 27.5,26 27.5,26 C 33,24.5 33.5,14.5 22.5,10.5 C 11.5,14.5 12,24.5 17.5,26 C 17.5,26 15,27.5 15,30 C 15,30 14.5,30.5 15,32 z " \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 25 10 A 2.5 2.5 0 1 1 20,10 A 2.5 2.5 0 1 1 25 10 z" \ + transform="translate(0,-2)" \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 17.5,26 L 27.5,26" \ + style="stroke-linecap:butt;" class="chess-path-D" /> \ + <path \ + d="M 15,30 L 30,30" \ + style="stroke-linecap:butt;" class="chess-path-D" /> \ + <path \ + d="M 22.5,15.5 L 22.5,20.5" \ + style="stroke-linecap:butt;" class="chess-path-D" /> \ + <path \ + d="M 20,18 L 25,18" \ + style="stroke-linecap:butt;" class="chess-path-D" /> \ + </g>'; + +var DEFrook = '<g transform="translate(-22.5,-22.5)"> \ + <path \ + d="M 9,39 L 36,39 L 36,36 L 9,36 L 9,39 z " \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 12,36 L 12,32 L 33,32 L 33,36 L 12,36 z " \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 11,14 L 11,9 L 15,9 L 15,11 L 20,11 L 20,9 L 25,9 L 25,11 L 30,11 L 30,9 L 34,9 L 34,14" \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 34,14 L 31,17 L 14,17 L 11,14" \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 31,17 L 31,29.5 L 14,29.5 L 14,17" \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 31,29.5 L 32.5,32 L 12.5,32 L 14,29.5" \ + class="chess-path-B" /> \ + <path \ + d="M 11,14 L 34,14" \ + class="chess-path-D" /> \ + </g>'; + +var DEFqueen = '<g transform="translate(-22.5,-22.5)"> \ + <path \ + d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" \ + transform="translate(-1,-1)" \ + style="fill-rule: none;" class="chess-path-B" /> \ + <path \ + d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" \ + transform="translate(15.5,-5.5)" \ + style="fill-rule: none;" class="chess-path-B" /> \ + <path \ + d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" \ + transform="translate(32,-1)" \ + style="fill-rule: none;" class="chess-path-B" /> \ + <path \ + d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" \ + transform="translate(7,-4.5)" \ + style="fill-rule: none;" class="chess-path-B" /> \ + <path \ + d="M 9 13 A 2 2 0 1 1 5,13 A 2 2 0 1 1 9 13 z" \ + transform="translate(24,-4)" \ + style="fill-rule: none;" class="chess-path-B" /> \ + <path \ + d="M 9,26 C 17.5,24.5 30,24.5 36,26 L 38,14 L 31,25 L 31,11 L 25.5,24.5 L 22.5,9.5 L 19.5,24.5 L 14,10.5 L 14,25 L 7,14 L 9,26 z " \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 9,26 C 9,28 10.5,28 11.5,30 C 12.5,31.5 12.5,31 12,33.5 C 10.5,34.5 10.5,36 10.5,36 C 9,37.5 11,38.5 11,38.5 C 17.5,39.5 27.5,39.5 34,38.5 C 34,38.5 35.5,37.5 34,36 C 34,36 34.5,34.5 33,33.5 C 32.5,31 32.5,31.5 33.5,30 C 34.5,28 36,28 36,26 C 27.5,24.5 17.5,24.5 9,26 z " \ + style="stroke-linecap:butt;" class="chess-path-B" /> \ + <path \ + d="M 11.5,30 C 15,29 30,29 33.5,30" \ + class="chess-path-D" /> \ + <path \ + d="M 12,33.5 C 18,32.5 27,32.5 33,33.5" \ + class="chess-path-D" /> \ + <path \ + d="M 10.5,36 C 15.5,35 29,35 34,36" \ + class="chess-path-D" /> \ + </g>'; + +var DEFking = '<g transform="translate(-22.5,-22.5)"> \ + <path d="M 22.5,11.625 L 22.5,6" class="chess-path-D" /> \ + <path d="M 22.5,25 C 22.5,25 27,17.5 25.5,14.5 C 25.5,14.5 24.5,12 22.5,12 C 20.5,12 19.5,14.5 19.5,14.5 C 18,17.5 22.5,25 22.5,25" \ + style="fill:stroke-linecap:butt;" class="chess-path-B" /> \ + <path d="M 11.5,37 C 17,40.5 27,40.5 32.5,37 L 32.5,30 C 32.5,30 41.5,25.5 38.5,19.5 C 34.5,13 25,16 22.5,23.5 L 22.5,27 L 22.5,23.5 C 19,16 9.5,13 6.5,19.5 C 3.5,25.5 11.5,29.5 11.5,29.5 L 11.5,37 z " \ + class="chess-path-D" /> \ + <path d="M 20,8 L 25,8" class="chess-path-D" /> \ + <path d="M 11.5,29.5 C 17,27 27,27 32.5,30" class="chess-path-D" /> \ + <path d="M 11.5,37 C 17,34.5 27,34.5 32.5,37" \ + class="chess-path-D" /> \ + <path d="M 11.5,33.5 C 17,31.5 27,31.5 32.5,33.5" \ + class="chess-path-D" /> \ + </g>'; + // Draw a box around the board. function draw_outline () { var w = SVG_WIDTH + 2*SVG_MARGINX; @@ -45,11 +172,11 @@ // Draw relation [rel_name] between elements [args]. function draw_rel (rel_name, args) { if (args.length == 1) { + var is = 'id="' + "pred_" + args[0] + "_" + rel_name + '" '; + var hs = 'onclick="' + "handle_elem_click('" + args[0] + "')" + '" '; var pos = ELEM_POS[args[0]]; if (rel_name == "P") { // Tic-tac-toe cross - var is = 'id="' + "pred_" + args[0] + "_" + rel_name + '" '; var cs = 'class="' + "model-pred-" + rel_name + '" '; - var hs = 'onclick="' + "handle_elem_click('" + args[0] + "')" + '" '; var ls1 = '<line x1="-10" y1="-10" x2="10" y2="10" />'; var ls2 = '<line x1="10" y1="-10" x2="-10" y2="10" />'; var cr = svg_from_string (pos[0], pos[1], 12, 12, @@ -61,6 +188,54 @@ ["id", "pred_" + args[0] + "_" + rel_name], ["class", "model-pred-" + rel_name], ["onclick", ("handle_elem_click('" + args[0] + "')")]]); + } else if (rel_name == "wP") { // Chess Figure: white pawn + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessW" ' + is + hs + '>' + DEFpawn + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "bP") { // Chess Figure: black pawn + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessB" ' + is + hs + '>' + DEFpawn + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "wN") { // Chess Figure: white knight + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessW" ' + is + hs + '>' + DEFknight + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "bN") { // Chess Figure: black knight + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessB" ' + is + hs + '>' + DEFknight + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "wB") { // Chess Figure: white bishop + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessW" ' + is + hs + '>' + DEFbishop + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "bB") { // Chess Figure: black bishop + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessB" ' + is + hs + '>' + DEFbishop + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "wR") { // Chess Figure: white rook + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessW" ' + is + hs + '>' + DEFrook + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "bR") { // Chess Figure: black rook + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessB" ' + is + hs + '>' + DEFrook + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "wQ") { // Chess Figure: white queen + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessW" ' + is + hs + '>' + DEFqueen + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "bQ") { // Chess Figure: black queen + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessB" ' + is + hs + '>' + DEFqueen + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "wK") { // Chess Figure: white king + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessW" ' + is + hs + '>' + DEFking + '</g>'); + document.getElementById("svg").appendChild(f); + } else if (rel_name == "bK") { // Chess Figure: black king + var f = svg_from_string (pos[0], pos[1], 20, 20, + '<g class="chessB" ' + is + hs + '>' + DEFking + '</g>'); + document.getElementById("svg").appendChild(f); } else { add_svg ("circle", [["cx", pos[0]], ["cy", pos[1]], ["r", SUGGESTED_ELEM_SIZEX - 5], Modified: trunk/Toss/WebClient/TossMain.js =================================================================== --- trunk/Toss/WebClient/TossMain.js 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/WebClient/TossMain.js 2010-12-04 23:46:15 UTC (rev 1218) @@ -49,9 +49,11 @@ // Clear whole svg box. function clear_svg () { + clear_move_cache (); ELEM_COUNTERS = {}; CUR_MOVE = ""; CUR_ELEMS = []; + document.getElementById('cur-move').innerHTML = "none"; var svg_e = document.getElementById("svg"); svg_e.parentNode.removeChild (svg_e); } @@ -82,6 +84,7 @@ // Helper function: highlight move, unhighlight old, save current. function show_move (m) { var m_act = get_move_elems (m); + var m_rule = m.substring (m.indexOf("},")+4, m.lastIndexOf(',')-1); for (var i = 0; i < CUR_ELEMS.length; i++) { unhighlight_elem (CUR_ELEMS[i]); } @@ -92,7 +95,8 @@ if (m_str == "") { document.getElementById('cur-move').innerHTML = "none"; } else { - document.getElementById('cur-move').innerHTML = m_str; + document.getElementById('cur-move').innerHTML = + m_rule + ': <br/>' + m_str; } CUR_ELEMS = m_act; CUR_MOVE = m.toString(); @@ -225,6 +229,7 @@ return; } srv (TOSS_PORT, 'c.make_move' + CUR_MOVE); + clear_move_cache (); CUR_MOVE = ""; CUR_ELEMS = []; ELEM_COUNTERS = {}; Modified: trunk/Toss/WebClient/TossStyle.css =================================================================== --- trunk/Toss/WebClient/TossStyle.css 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/WebClient/TossStyle.css 2010-12-04 23:46:15 UTC (rev 1218) @@ -390,3 +390,113 @@ stroke: #260314; stroke-width: 3px; } + +.chessW .chess-path-A { + opacity:1; + fill:#ffffff; + fill-opacity:1; + fill-rule:nonzero; + stroke:#000000; + stroke-width:1.5; + stroke-linecap:round; + stroke-linejoin:miter; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-dashoffset:10; + stroke-opacity:1; +} + +.chessB .chess-path-A { + opacity:1; + fill:#000000; + fill-opacity:1; + fill-rule:nonzero; + stroke:#000000; + stroke-width:1.5; + stroke-linecap:round; + stroke-linejoin:miter; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-dashoffset:10; + stroke-opacity:1; +} + +.chessW .chess-path-B { + opacity:1; + fill:#ffffff; + fill-opacity:1; + fill-rule:evenodd; + stroke:#000000; + stroke-width:1.5; + stroke-linecap:round; + stroke-linejoin:round; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-opacity:1; +} + +.chessB .chess-path-B { + opacity:1; + fill:#000000; + fill-opacity:1; + fill-rule:evenodd; + stroke:#000000; + stroke-width:1.5; + stroke-linecap:round; + stroke-linejoin:round; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-opacity:1; +} + +.chessW .chess-path-C { + opacity:1; + fill:#000000; + fill-opacity:1; + stroke:#000000; + stroke-width:1.5; + stroke-linecap:round; + stroke-linejoin:round; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-opacity:1; +} + +.chessB .chess-path-C { + opacity:1; + fill:#ffffff; + fill-opacity:1; + stroke:#ffffff; + stroke-width:1.5; + stroke-linecap:round; + stroke-linejoin:round; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-opacity:1; +} + +.chessW .chess-path-D { + fill: #ffffff; + fill-opacity: 0.75; + fill-rule:evenodd; + stroke: #000000; + stroke-width:1; + stroke-linecap:round; + stroke-linejoin:mitter; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-opacity:1; +} + +.chessB .chess-path-D { + fill: #000000; + fill-opacity: 0.75; + fill-rule:evenodd; + stroke: #000000; + stroke-width:1; + stroke-linecap:round; + stroke-linejoin:mitter; + stroke-miterlimit:4; + stroke-dasharray:none; + stroke-opacity:1; +} Modified: trunk/Toss/WebClient/Wrapper.py =================================================================== --- trunk/Toss/WebClient/Wrapper.py 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/WebClient/Wrapper.py 2010-12-04 23:46:15 UTC (rev 1218) @@ -433,6 +433,15 @@ state_str = ("#"+file_name+"#") + "$".join (state.split ("\n")) self.set_state (state_str) + def cur_moves (self): + cur_loc = self.get_cur_loc () + moves = [] + for (r, itvls, endp) in self.get_loc_moves (cur_loc): + for m in self.query (r): + # FIXME! currently we ignore params in html (skip itvls here) + moves.append ((m, r, endp)) + return ("; ".join([str(m) for m in moves])) + def cur_move_touching (self, elem): cur_loc = self.get_cur_loc () moves = [] Modified: trunk/Toss/WebClient/index.html =================================================================== --- trunk/Toss/WebClient/index.html 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/WebClient/index.html 2010-12-04 23:46:15 UTC (rev 1218) @@ -37,6 +37,9 @@ <a id="Breakthrough" href="#" onclick="game_click('Breakthrough')">Breakthrough</a> </li> <li class="menu-list-item"> + <a id="Chess" href="#" onclick="game_click('Chess')">Chess</a> + </li> + <li class="menu-list-item"> <a id="Entanglement" href="#" onclick="game_click('Entanglement')">Entanglement</a> </li> <li class="menu-list-item"> @@ -102,6 +105,10 @@ strategy requires to balance attacking pivotal pieces of the opponent and organizing your own defensive patterns. Play yourself to see how challenging this can be.</p> </div> + <div id="Chess-desc" style="display: none;"> + <p><a href="http://en.wikipedia.org/wiki/Chess">Chess</a>, + the great classical game.</p> + </div> <div id="Entanglement-desc" style="display: none;"> <p><a href="http://en.wikipedia.org/wiki/Entanglement_(graph_measure)">Entanglement</a> is a game in which a number of cops attempt to capture a robber. In each step, the cops are informed Modified: trunk/Toss/examples/Breakthrough.toss =================================================================== --- trunk/Toss/examples/Breakthrough.toss 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/examples/Breakthrough.toss 2010-12-04 23:46:15 UTC (rev 1218) @@ -1,6 +1,6 @@ PLAYERS 1, 2 DATA depth: 3 -RULE 1: +RULE WhiteBeatLeft: [ | B:1 {} | ] " ?B ? @@ -14,7 +14,7 @@ ? . " emb W, B pre not ex x (B(x) and not ex y C(y, x)) -RULE 2: +RULE WhiteMove: [ | B:1 {}; R:2 {} | ] " . @@ -27,7 +27,7 @@ . " emb W, B pre not ex x (B(x) and not ex y C(y, x)) -RULE 3: +RULE WhiteBeatRight: [ | B:1 {} | ] " ? ?B @@ -41,7 +41,7 @@ . ? " emb W, B pre not ex x (B(x) and not ex y C(y, x)) -RULE 4: +RULE BlackBeatLeft: [ | W:1 {} | ] " B ? @@ -55,7 +55,7 @@ ? B " emb W, B pre not ex x (W(x) and not ex y C(x, y)) -RULE 5: +RULE BlackMove: [ | R:2 {}; W:1 {} | ] " B @@ -68,7 +68,7 @@ B " emb W, B pre not ex x (W(x) and not ex y C(x, y)) -RULE 6: +RULE BlackBeatRight: [ | W:1 {} | ] " ? B @@ -92,7 +92,7 @@ :(ex x (B(x) and not ex y C(y, x))) + -1. * :(ex x (W(x) and not ex y C(x, y))) } - MOVES [1 -> 1]; [2 -> 1]; [3 -> 1] + MOVES [WhiteBeatLeft -> 1]; [WhiteMove -> 1]; [WhiteBeatRight -> 1] } LOC 1 { PLAYER 2 @@ -104,7 +104,7 @@ :(ex x (B(x) and not ex y C(y, x))) + -1. * :(ex x (W(x) and not ex y C(x, y))) } - MOVES [4 -> 0]; [5 -> 0]; [6 -> 0] + MOVES [BlackBeatLeft -> 0]; [BlackMove -> 0]; [BlackBeatRight -> 0] } MODEL [ | | ] " Modified: trunk/Toss/examples/Chess.toss =================================================================== --- trunk/Toss/examples/Chess.toss 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/examples/Chess.toss 2010-12-04 23:46:15 UTC (rev 1218) @@ -320,8 +320,8 @@ LOC 1 { PLAYER 2 PAYOFF { - 1: :(WinW()) - :(WinB()); - 2: :(WinB()) - :(WinW()) + 1: :(CheckB()) - :(CheckW()); + 2: :(CheckW()) - :(CheckB()) } MOVES [BlackPawnMove -> 0]; Modified: trunk/Toss/examples/Entanglement.toss =================================================================== --- trunk/Toss/examples/Entanglement.toss 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/examples/Entanglement.toss 2010-12-04 23:46:15 UTC (rev 1218) @@ -1,5 +1,5 @@ PLAYERS 1, 2 -RULE 1: +RULE Follow: [ a1, a2 | C { (a2) }; R { (a1) } | vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ] @@ -8,7 +8,14 @@ vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; x { a1->-10., a2->-10. }; y { a1->-10., a2->10. } ] emb R, C -RULE 2: +RULE Wait: + [ a1 | R { (a1) } | + vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ] + -> + [ a1 | R { (a1) } | + vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ] +emb R, C +RULE Run: [ a1, a2 | C:1 { }; E { (a1, a2) }; R { (a1) }; _opt_C { (a1) } | vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ] @@ -17,13 +24,6 @@ vx { a1->0., a2->0. }; vy { a1->0., a2->0. }; x { a1->-10., a2->10. }; y { a1->-10., a2->-10. } ] emb R, C -RULE 3: - [ a1 | R { (a1) } | - vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ] - -> - [ a1 | R { (a1) } | - vx { a1->0. }; vy { a1->0. }; x { a1->-10. }; y { a1->-10. } ] -emb R, C LOC 0 { PLAYER 1 PAYOFF { @@ -31,8 +31,8 @@ 2: 0. } MOVES - [1 -> 1]; - [3 -> 1] + [Follow -> 1]; + [Wait -> 1] } LOC 1 { PLAYER 2 @@ -40,7 +40,7 @@ 1: 1.; 2: -1. } - MOVES - [2 -> 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 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/examples/Gomoku.toss 2010-12-04 23:46:15 UTC (rev 1218) @@ -1,6 +1,6 @@ PLAYERS 1, 2 DATA r1: circle, r2: line, adv_ratio: 4 -RULE 1: +RULE Circle: [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 @@ -18,7 +18,7 @@ (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: +RULE Cross: [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 @@ -92,7 +92,7 @@ t) and R(y, u) and C(z, u)))) ) } - MOVES [1 -> 1] + MOVES [Circle -> 1] } LOC 1 { PLAYER 2 @@ -150,7 +150,7 @@ t) and R(y, u) and C(z, u)))) ) } - MOVES [2 -> 0] + MOVES [Cross -> 0] } MODEL [ | P:1 {}; Q:1 {} | ] " Modified: trunk/Toss/examples/Tic-Tac-Toe.toss =================================================================== --- trunk/Toss/examples/Tic-Tac-Toe.toss 2010-12-04 15:39:08 UTC (rev 1217) +++ trunk/Toss/examples/Tic-Tac-Toe.toss 2010-12-04 23:46:15 UTC (rev 1218) @@ -13,11 +13,11 @@ (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))) )) -RULE 1: +RULE Circle: [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] -> [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] emb Q, P pre not WinQ() -RULE 2: +RULE Cross: [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] -> [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] emb Q, P pre not WinP() @@ -27,7 +27,7 @@ 1: :(WinP()) - :(WinQ()); 2: :(WinQ()) - :(WinP()) } - MOVES [1 -> 1] + MOVES [Circle -> 1] } LOC 1 { PLAYER 2 @@ -35,7 +35,7 @@ 1: :(WinP()) - :(WinQ()); 2: :(WinQ()) - :(WinP()) } - MOVES [2 -> 0] + MOVES [Cross -> 0] } MODEL [ | P:1 {}; Q:1 {} | ] " This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <luk...@us...> - 2010-12-05 02:06:49
|
Revision: 1219 http://toss.svn.sourceforge.net/toss/?rev=1219&view=rev Author: lukaszkaiser Date: 2010-12-05 02:06:43 +0000 (Sun, 05 Dec 2010) Log Message: ----------- More TNF memoization in Solver, small interface corrections. Modified Paths: -------------- trunk/Toss/Formula/FormulaOps.ml trunk/Toss/Solver/Solver.ml trunk/Toss/WebClient/TossDefaultStyle.js trunk/Toss/WebClient/TossStyle.css trunk/Toss/examples/Breakthrough.toss trunk/Toss/examples/Gomoku.toss trunk/Toss/examples/Tic-Tac-Toe.toss Modified: trunk/Toss/Formula/FormulaOps.ml =================================================================== --- trunk/Toss/Formula/FormulaOps.ml 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/Formula/FormulaOps.ml 2010-12-05 02:06:43 UTC (rev 1219) @@ -302,8 +302,9 @@ try let (dvs, dphi) = List.assoc rn defs in let ovs = List.map var_str (Array.to_list vs) in - let newdphi = rename_quant_avoiding ((Array.to_list vs) :> var list) dphi in - subst_vars (List.combine dvs ovs) newdphi + (* not needed any more: let newdphi = + rename_quant_avoiding ((Array.to_list vs) :> var list) dphi in *) + subst_vars (List.combine dvs ovs) dphi with Not_found -> Rel (rn, vs) ) | x -> x Modified: trunk/Toss/Solver/Solver.ml =================================================================== --- trunk/Toss/Solver/Solver.ml 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/Solver/Solver.ml 2010-12-05 02:06:43 UTC (rev 1219) @@ -31,24 +31,41 @@ formulas_check = Hashtbl.create 3 ; } -let register_formula solver phi = +let register_formula_do solver phi = let rec check_form = function Ex (vs, phi) -> check_form phi | phi -> phi in try let res = Hashtbl.find solver.reg_formulas phi in if !debug_level > 0 then print_endline ("Found " ^ (str phi)); - res + (Hashtbl.find solver.formulas_eval res, res) with Not_found -> let psi = FormulaOps.tnf_fv phi in - if !debug_level > 0 then print_endline ("Entered " ^ (str phi)); + if !debug_level > -1 then print_endline ("Entered " ^ (str phi)); if !debug_level > 0 then print_endline ("Registering " ^ (str psi)); let id = Hashtbl.length solver.formulas_eval + 1 in Hashtbl.add solver.reg_formulas phi id; Hashtbl.add solver.formulas_eval id psi; Hashtbl.add solver.formulas_check id (check_form psi); - id + (psi, id) +let register_formula solver phi = + try + let res = Hashtbl.find solver.reg_formulas phi in + if !debug_level > 0 then print_endline ("DirectFound " ^ (str phi)); + res + with Not_found -> + match Formula.flatten phi with + | And fl -> + let rfl = List.map (fun f -> fst (register_formula_do solver f)) fl in + let id = Hashtbl.length solver.formulas_eval + 1 in + Hashtbl.add solver.reg_formulas phi id; + Hashtbl.add solver.formulas_eval id (And rfl); + Hashtbl.add solver.formulas_check id (And rfl); + id + | _ -> let (_, id) = register_formula_do solver phi in id + + let get_formula solver i = Hashtbl.find solver.formulas_eval i Modified: trunk/Toss/WebClient/TossDefaultStyle.js =================================================================== --- trunk/Toss/WebClient/TossDefaultStyle.js 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/WebClient/TossDefaultStyle.js 2010-12-05 02:06:43 UTC (rev 1219) @@ -184,7 +184,7 @@ document.getElementById("svg").appendChild(cr); } else if (rel_name == "R") { // Robber in Entanglement add_svg ("circle", - [["cx", pos[0]], ["cy", pos[1]], ["r", SUGGESTED_ELEM_SIZEX - 15], + [["cx", pos[0]], ["cy", pos[1]], ["r", SUGGESTED_ELEM_SIZEX - 5], ["id", "pred_" + args[0] + "_" + rel_name], ["class", "model-pred-" + rel_name], ["onclick", ("handle_elem_click('" + args[0] + "')")]]); @@ -238,7 +238,7 @@ document.getElementById("svg").appendChild(f); } else { add_svg ("circle", - [["cx", pos[0]], ["cy", pos[1]], ["r", SUGGESTED_ELEM_SIZEX - 5], + [["cx", pos[0]], ["cy", pos[1]], ["r", SUGGESTED_ELEM_SIZEX - 10], ["id", "pred_" + args[0] + "_" + rel_name], ["class", "model-pred-" + rel_name], ["onclick", ("handle_elem_click('" + args[0] + "')")]]); Modified: trunk/Toss/WebClient/TossStyle.css =================================================================== --- trunk/Toss/WebClient/TossStyle.css 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/WebClient/TossStyle.css 2010-12-05 02:06:43 UTC (rev 1219) @@ -370,7 +370,6 @@ fill: #400827; stroke: #260314; stroke-width: 3px; - z-index: 7; } .model-pred-W { Modified: trunk/Toss/examples/Breakthrough.toss =================================================================== --- trunk/Toss/examples/Breakthrough.toss 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/examples/Breakthrough.toss 2010-12-05 02:06:43 UTC (rev 1219) @@ -1,6 +1,6 @@ PLAYERS 1, 2 DATA depth: 3 -RULE WhiteBeatLeft: +RULE WhiteLeft: [ | B:1 {} | ] " ?B ? @@ -14,7 +14,7 @@ ? . " emb W, B pre not ex x (B(x) and not ex y C(y, x)) -RULE WhiteMove: +RULE WhiteStraight: [ | B:1 {}; R:2 {} | ] " . @@ -27,7 +27,7 @@ . " emb W, B pre not ex x (B(x) and not ex y C(y, x)) -RULE WhiteBeatRight: +RULE WhiteRight: [ | B:1 {} | ] " ? ?B @@ -41,7 +41,7 @@ . ? " emb W, B pre not ex x (B(x) and not ex y C(y, x)) -RULE BlackBeatLeft: +RULE BlackLeft: [ | W:1 {} | ] " B ? @@ -55,7 +55,7 @@ ? B " emb W, B pre not ex x (W(x) and not ex y C(x, y)) -RULE BlackMove: +RULE BlackStraight: [ | R:2 {}; W:1 {} | ] " B @@ -68,7 +68,7 @@ B " emb W, B pre not ex x (W(x) and not ex y C(x, y)) -RULE BlackBeatRight: +RULE BlackRight: [ | W:1 {} | ] " ? B @@ -92,7 +92,7 @@ :(ex x (B(x) and not ex y C(y, x))) + -1. * :(ex x (W(x) and not ex y C(x, y))) } - MOVES [WhiteBeatLeft -> 1]; [WhiteMove -> 1]; [WhiteBeatRight -> 1] + MOVES [WhiteLeft -> 1]; [WhiteStraight -> 1]; [WhiteRight -> 1] } LOC 1 { PLAYER 2 @@ -104,7 +104,7 @@ :(ex x (B(x) and not ex y C(y, x))) + -1. * :(ex x (W(x) and not ex y C(x, y))) } - MOVES [BlackBeatLeft -> 0]; [BlackMove -> 0]; [BlackBeatRight -> 0] + MOVES [BlackLeft -> 0]; [BlackStraight -> 0]; [BlackRight -> 0] } MODEL [ | | ] " Modified: trunk/Toss/examples/Gomoku.toss =================================================================== --- trunk/Toss/examples/Gomoku.toss 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/examples/Gomoku.toss 2010-12-05 02:06:43 UTC (rev 1219) @@ -1,6 +1,6 @@ PLAYERS 1, 2 DATA r1: circle, r2: line, adv_ratio: 4 -RULE Circle: +RULE Cross: [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] -> [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] emb Q, P @@ -18,7 +18,7 @@ (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 Cross: +RULE Circle: [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] -> [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] emb Q, P @@ -92,7 +92,7 @@ t) and R(y, u) and C(z, u)))) ) } - MOVES [Circle -> 1] + MOVES [Cross -> 1] } LOC 1 { PLAYER 2 @@ -150,7 +150,7 @@ t) and R(y, u) and C(z, u)))) ) } - MOVES [Cross -> 0] + MOVES [Circle -> 0] } MODEL [ | P:1 {}; Q:1 {} | ] " Modified: trunk/Toss/examples/Tic-Tac-Toe.toss =================================================================== --- trunk/Toss/examples/Tic-Tac-Toe.toss 2010-12-04 23:46:15 UTC (rev 1218) +++ trunk/Toss/examples/Tic-Tac-Toe.toss 2010-12-05 02:06:43 UTC (rev 1219) @@ -13,11 +13,11 @@ (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))) )) -RULE Circle: +RULE Cross: [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] -> [a1 | P (a1); Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] emb Q, P pre not WinQ() -RULE Cross: +RULE Circle: [a1 | P:1 {}; Q:1 {} | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] -> [a1 | P:1 {}; Q (a1) | vx {a1->0.}; vy {a1->0.}; x {a1->0.}; y {a1->0.}] emb Q, P pre not WinP() @@ -27,7 +27,7 @@ 1: :(WinP()) - :(WinQ()); 2: :(WinQ()) - :(WinP()) } - MOVES [Circle -> 1] + MOVES [Cross -> 1] } LOC 1 { PLAYER 2 @@ -35,7 +35,7 @@ 1: :(WinP()) - :(WinQ()); 2: :(WinQ()) - :(WinP()) } - MOVES [Cross -> 0] + MOVES [Circle -> 0] } MODEL [ | P:1 {}; Q:1 {} | ] " This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |