[Toss-devel-svn] SF.net SVN: toss:[1469] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1469] trunk/Toss
|
From: <luk...@us...> - 2011-06-03 20:24:32
|
Revision: 1469
http://toss.svn.sourceforge.net/toss/?rev=1469&view=rev
Author: lukaszkaiser
Date: 2011-06-03 20:24:22 +0000 (Fri, 03 Jun 2011)
Log Message:
-----------
Hiding structure type in Structure ml (first, mostly formal step).
Modified Paths:
--------------
trunk/Toss/Arena/Arena.ml
trunk/Toss/Arena/ContinuousRule.ml
trunk/Toss/Arena/DiscreteRule.ml
trunk/Toss/GGP/GameSimpl.ml
trunk/Toss/Play/Heuristic.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Solver/Solver.ml
trunk/Toss/Solver/Structure.ml
trunk/Toss/Solver/Structure.mli
trunk/Toss/Solver/StructureTest.ml
Modified: trunk/Toss/Arena/Arena.ml
===================================================================
--- trunk/Toss/Arena/Arena.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Arena/Arena.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -90,7 +90,7 @@
| AssignmentSet.Empty ->
Structure.add_rel_name r_name (List.length vars) struc
| _ ->
- let tuples = AssignmentSet.tuples struc.Structure.elements vars def_asg in
+ let tuples = AssignmentSet.tuples (Structure.elems struc) vars def_asg in
Structure.add_rels struc r_name tuples
let add_def_rels struc rels = List.fold_left add_def_rel_single struc rels
@@ -704,13 +704,13 @@
get_from_loc fun_signature loc (state_game, state) "get signature")
| GetAllTuples (loc, rel) ->
let tuples struc =
- let tps = Structure.StringMap.find rel struc.Structure.relations in
+ let tps = Structure.rel_find rel struc in
Structure.rel_str struc rel tps in
((state_game, state),
get_from_loc tuples loc (state_game, state) "get all tuples")
| GetAllElems loc ->
let elems struc =
- let els = Structure.Elems.elements struc.Structure.elements in
+ let els = Structure.elements struc in
let el_name e = Structure.elem_str struc e in
String.concat "; " (List.map el_name els) in
((state_game, state),
@@ -734,8 +734,8 @@
with Not_found -> ((state_game, state), "ERR no data")
)
| SetArity (rel, ar) ->
- if (try Structure.StringMap.find rel
- struc.Structure.rel_signature = ar with Not_found -> false)
+ if (try List.assoc rel (Structure.rel_signature struc) = ar
+ with Not_found -> false)
then (state_game, state), "SET ARITY"
else
let s = Structure.force_add_rel_name rel ar struc in
@@ -743,8 +743,7 @@
| GetArity (rel) -> (
if rel = "" then ((state_game, state), sig_str state) else
try ((state_game, state), string_of_int
- (Structure.StringMap.find rel
- state.struc.Structure.rel_signature))
+ (List.assoc rel (Structure.rel_signature state.struc)))
with Not_found ->
((state_game, state), "ERR relation "^rel^" arity not found")
)
Modified: trunk/Toss/Arena/ContinuousRule.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRule.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Arena/ContinuousRule.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -170,9 +170,9 @@
not updated later *)
let ns = DiscreteRule.rewrite_single !last_struc m r.compiled in
let set_val struc ((f, e), v) =
- let e_rel =
+ let e_rel =
(* DiscreteRule adds RHS element names to rewritten result *)
- Structure.StringMap.find ("_right_" ^ e) struc.Structure.relations in
+ Structure.rel_find ("_right_" ^ e) struc in
let elem = (Structure.Tuples.choose e_rel).(0) in
Structure.add_fun struc f (elem, v) in
let upd_struc = List.fold_left set_val ns upd_vals in
Modified: trunk/Toss/Arena/DiscreteRule.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRule.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Arena/DiscreteRule.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -305,7 +305,7 @@
by {!find_matchings} for the same structure and rewrite rule. Does
not guarantee that rewriting will succeed. *)
let choose_match model rule_obj matches =
- let elem = Structure.Elems.choose model.Structure.elements in
+ let elem = Structure.Elems.choose (Structure.elems model) in
let default = List.map (fun v->v,elem) rule_obj.lhs_elem_vars in
let asgn = AssignmentSet.choose_fo default matches in
assignment_to_embedding rule_obj asgn
@@ -331,7 +331,7 @@
(* Enumerate matchings returned by {!find_matchings} for the same
structure and rewrite rule. *)
let enumerate_matchings model rule matches =
- let all_elems = Structure.Elems.elements model.Structure.elements in
+ let all_elems = Structure.elements model in
let asgns =
enumerate_asgns all_elems rule.lhs_elem_vars matches in
List.map (assignment_to_embedding rule) asgns
@@ -373,7 +373,7 @@
(* remove the matched elements *)
let (model, drel_tuples) = Structure.del_elems model del_elems in
let del_elems = elems_of_list del_elems in
- let elems = Els.diff model.Structure.elements del_elems in
+ let elems = Els.diff (Structure.elems model) del_elems in
(* Allocate new elements garbage-collecting the numbers. *)
let _, alloc_elems, rmmap =
List.fold_left (fun (next, alloc_elems, rmmap) evar ->
@@ -389,7 +389,7 @@
let all_names = SSMap.fold (fun name el all_names ->
if Els.mem el del_elems then all_names
else Aux.Strings.add name all_names)
- model.Structure.names Aux.Strings.empty in
+ (Structure.names model) Aux.Strings.empty in
let rec select (all_names, elem_names, inv_names as acc) = function
| [] -> acc
| ne::nels ->
@@ -406,7 +406,7 @@
| Some le when rev_assoc_all rlmap le = [re] ->
let name =
SIMap.find (List.assoc le ldmap)
- given_model.Structure.inv_names in
+ (Structure.inv_names given_model) in
if Aux.Strings.mem name all_names then
let olde = SSMap.find name elem_names in
select
@@ -417,7 +417,7 @@
| Some le ->
let lname =
SIMap.find (List.assoc le ldmap)
- given_model.Structure.inv_names in
+ (Structure.inv_names given_model) in
select
(accu (not_conflicting_name all_names (lname^"_"^re)))
nels
@@ -430,9 +430,8 @@
with Not_found ->
all_names, elem_names, inv_names in
let (all_names, elem_names, inv_names) =
- select
- (all_names, model.Structure.names,
- model.Structure.inv_names) alloc_elems in
+ select (all_names, Structure.names model, Structure.inv_names model)
+ alloc_elems in
(* For a tuple removed from the structure, if its preimage does not
appear negatively on the RHS, add all tuples from the
corresponding product of replacement elements (which can be
@@ -493,7 +492,7 @@
SSMap.fold (fun f graph model ->
if SIMap.mem oe graph
then Structure.add_fun model f (ne, SIMap.find oe graph)
- else model) given_model.Structure.functions model
+ else model) (Structure.functions given_model) model
) model rlmap in
(* Add the new trace. *)
let model =
@@ -528,7 +527,7 @@
Structure.add_rel arg_model crel ntup
else arg_model) up_model ctups)
model rule_obj.rhs_neg_tuples in
- {model with Structure.names = elem_names; inv_names = inv_names}
+ Structure.replace_names model elem_names inv_names
(* Rewrite the model keeping the number and identity of elements. *)
let rewrite_nonstruct model rmmap pos_tuples neg_tuples rhs_elem_names =
@@ -776,30 +775,28 @@
opt_rels, pos_rels, pos_expanded in
let lhs_name_of e =
- elemvar_of_elem rule_src.lhs_struc.Structure.inv_names e in
+ elemvar_of_elem (Structure.inv_names rule_src.lhs_struc) e in
let rhs_name_of e =
- elemvar_of_elem rule_src.rhs_struc.Structure.inv_names e in
+ elemvar_of_elem (Structure.inv_names rule_src.rhs_struc) e in
(* 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.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 &&
+ if nimg = Structure.nbr_elems rule_src.rhs_struc &&
+ ndom = Structure.nbr_elems rule_src.lhs_struc &&
nimg = ndom
then None
else
Some (List.map (fun (re,le) -> rhs_name_of re, lhs_name_of le)
rule_src.rule_s) in
- let rhs_elems =
- Els.elements rule_src.rhs_struc.Structure.elements in
+ let rhs_elems = Structure.elements rule_src.rhs_struc in
let rhs_elem_vars = List.map rhs_name_of rhs_elems in
(* [rlmap=None] optimization permutes LHS so that [rule_s] becomes
identity and LHS variables are replaced by RHS ones *)
let lhs_elems =
- if rlmap = None then rhs_elems
- else Els.elements rule_src.lhs_struc.Structure.elements in
+ if rlmap = None then rhs_elems else Structure.elements rule_src.lhs_struc in
let lhs_elem_vars =
if rlmap = None then rhs_elem_vars
else List.map lhs_name_of lhs_elems in
@@ -810,7 +807,7 @@
let lhs_rels =
SSMap.fold (fun rel tups rels ->
(rel, List.map opt_map (STups.elements tups)) :: rels)
- rule_src.lhs_struc.Structure.relations [] in
+ (Structure.relations rule_src.lhs_struc) [] in
(* rename the corresponding variables in the precondition *)
let precond =
if rlmap = None then
@@ -827,14 +824,14 @@
if rlmap = None then
SSMap.fold (fun name re acc ->
SSMap.add name (List.assoc re rule_src.rule_s) acc)
- rule_src.rhs_struc.Structure.names SSMap.empty
- else rule_src.lhs_struc.Structure.names in
+ (Structure.names rule_src.rhs_struc) SSMap.empty
+ else (Structure.names rule_src.lhs_struc) in
let lhs_elem_inv_names =
if rlmap = None then
SIMap.fold (fun re name acc ->
SIMap.add (List.assoc re rule_src.rule_s) name acc)
- rule_src.rhs_struc.Structure.inv_names SIMap.empty
- else rule_src.lhs_struc.Structure.inv_names in
+ (Structure.inv_names rule_src.rhs_struc) SIMap.empty
+ else Structure.inv_names rule_src.lhs_struc in
(* lhs_pos_tups keep their defined rels to be substituted in the
embedding formula, but we need to avoid negating their support *)
let lhs_opt_rels, lhs_pos_tups, lhs_pos_expanded =
@@ -908,7 +905,7 @@
SSMap.fold (fun rel tups rels ->
if STups.is_empty tups then rels
else (rel, STups.elements tups) :: rels)
- rule_src.rhs_struc.Structure.relations [] in
+ (Structure.relations rule_src.rhs_struc) [] in
let rhs_opt_rels, rhs_rels, _ =
compile_opt_rels rhs_rels in
if List.exists (fun (drel, _) -> List.mem_assoc drel rhs_rels)
@@ -980,7 +977,7 @@
lhs_elem_vars = lhs_elem_vars;
lhs_neg_tups = lhs_neg_tups;
lhs_form = emb;
- rhs_elem_names = rule_src.rhs_struc.Structure.names;
+ rhs_elem_names = Structure.names rule_src.rhs_struc;
rhs_elem_vars = rhs_elem_vars;
rhs_pos_tuples = rhs_pos_tuples;
rhs_neg_tuples = rhs_neg_tuples;
@@ -1131,8 +1128,8 @@
let is_alpha_identity r =
not (r.rule_s = []) &&
let len = List.length r.rule_s in
- len = Structure.Elems.cardinal r.lhs_struc.Structure.elements &&
- len = Structure.Elems.cardinal r.rhs_struc.Structure.elements &&
+ len = Structure.nbr_elems r.lhs_struc &&
+ len = Structure.nbr_elems r.rhs_struc &&
let l_str le = Structure.elem_str r.lhs_struc le in
let r_str re = Structure.elem_str r.rhs_struc re in
List.for_all (fun (rhs,lhs) -> r_str rhs = l_str lhs)
@@ -1226,15 +1223,15 @@
let r_str re = Structure.elem_str rhs re in
match rule_s with
| None ->
- let lnum = Structure.Elems.cardinal lhs.Structure.elements in
- let rnum = Structure.Elems.cardinal rhs.Structure.elements in
+ let lnum = Structure.nbr_elems lhs in
+ let rnum = Structure.nbr_elems rhs in
if lnum <> rnum
then failwith
(Printf.sprintf "\"with\" clause not given but LHS and RHS \
structures have different sizes %d and %d" lnum rnum)
else
Structure.Elems.fold (fun re acc -> (re, l_elem (r_str re))::acc)
- rhs.Structure.elements []
+ (Structure.elems rhs) []
| Some rs ->
List.map (fun (re,le) -> r_elem re, l_elem le) rs
Modified: trunk/Toss/GGP/GameSimpl.ml
===================================================================
--- trunk/Toss/GGP/GameSimpl.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/GGP/GameSimpl.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -145,7 +145,7 @@
let simplify ?(keep_nonempty_predicates=true) (game, state) =
let struc = state.Arena.struc in
let signat = Structure.rel_signature struc in
- let nelems = Structure.Elems.cardinal struc.Structure.elements in
+ let nelems = Structure.nbr_elems struc in
let tcard tups = Tups.cardinal tups in
let posi_f, nega_f, indef_f = Arena.all_fluents game in
let fluents =
@@ -168,14 +168,13 @@
let complemented = ref [] in
let predicate_tups =
Structure.Elems.fold (fun e tups -> Tups.add [|e|] tups)
- struc.Structure.elements Tups.empty in
+ (Structure.elems struc) Tups.empty in
let struc = ref struc in
let signat = ref signat in
let used_rels = ref used_rels in
let complements =
List.fold_left (fun table (rel,arity) ->
- let rel_tups =
- Structure.StringMap.find rel !struc.Structure.relations in
+ let rel_tups = Structure.rel_find rel !struc in
let ntups = tcard rel_tups in
let crel =
Structure.StringMap.fold (fun rel2 rel2_tups crel ->
@@ -195,7 +194,7 @@
(* }}} *)
Some rel2
) else None
- ) !struc.Structure.relations None in
+ ) (Structure.relations !struc) None in
let crel =
if not !introduce_complement || arity <> 1 ||
crel <> None || ntups <= nelems / 2
@@ -225,13 +224,11 @@
(* prepare for (1bc) and (2) *)
let subset_table =
List.fold_left (fun table (rel,arity) ->
- let rel_tups =
- Structure.StringMap.find rel struc.Structure.relations in
+ let rel_tups = Structure.rel_find rel struc in
let row =
List.fold_left (fun row (rel2,arity2) ->
if arity2 = arity &&
- Tups.subset rel_tups
- (Structure.StringMap.find rel2 struc.Structure.relations)
+ Tups.subset rel_tups (Structure.rel_find rel2 struc)
then Aux.Strings.add rel2 row
else row
) Aux.Strings.empty signat in
@@ -320,8 +317,7 @@
Aux.unique_sorted (
List.fold_left (fun emb_rels rel ->
let tups =
- try Structure.StringMap.find rel
- lhs_struc.Structure.relations
+ try Structure.rel_find rel lhs_struc
with Not_found -> Tups.empty in
if removable rel &&
not (Tups.is_empty tups) &&
@@ -370,12 +366,11 @@
Structure.add_rels lhs_struc orig
(List.assoc rel lhs_neg_tups)
else lhs_struc
- ) lhs_struc.Structure.relations lhs_struc in
+ ) (Structure.relations lhs_struc) lhs_struc in
let lhs_all_tups n =
List.map Array.of_list (Aux.product (
Aux.fold_n (fun acc ->
- Structure.Elems.elements
- lhs_struc.Structure.elements::acc) [] n)) in
+ Structure.elements lhs_struc ::acc) [] n)) in
let lhs_struc =
List.fold_left (fun lhs_struc emb_rel ->
(* {{{ log entry *)
@@ -387,15 +382,13 @@
try List.assoc emb_rel lhs_neg_tups
with Not_found -> [] in
let all_tups = lhs_all_tups
- (Structure.StringMap.find emb_rel
- struc.Structure.rel_signature) in
+ (List.assoc emb_rel (Structure.rel_signature struc)) in
let avoid_tups = Aux.concat_map
(fun (rel1,(rel2,neg)) ->
if not (removable rel1) ||
not neg || rel2 <> emb_rel then []
else (* neg *)
- (try ltups (Structure.StringMap.find rel1
- lhs_struc.Structure.relations)
+ (try ltups (Structure.rel_find rel1 lhs_struc)
with Not_found -> [])
) equivalent in
(* {{{ log entry *)
@@ -436,8 +429,7 @@
(* 3 *)
let intersect_rels struc grel rels =
let rel_graphs =
- List.map (fun rel ->
- Structure.StringMap.find rel struc.Structure.relations) rels in
+ List.map (fun rel -> Structure.rel_find rel struc) rels in
let graph =
match rel_graphs with
| [] -> assert false
@@ -447,11 +439,9 @@
let tuples = Tups.elements graph in
Structure.add_rels struc grel tuples in
let intersect_with_inv struc grel rel1 rel2 =
- let graph1 =
- Structure.StringMap.find rel1 struc.Structure.relations in
+ let graph1 = Structure.rel_find rel1 struc in
let tuples2 =
- Tups.elements
- (Structure.StringMap.find rel2 struc.Structure.relations) in
+ Tups.elements (Structure.rel_find rel2 struc) in
let inv_graph =
Structure.tuples_of_list (List.map (function
| [|e1; e2|] -> [|e2; e1|]
@@ -785,7 +775,7 @@
then
List.map (fun tup->rel, tup) (Tups.elements tups)
@ cands
- else cands) lhs.Structure.relations [] in
+ else cands) (Structure.relations lhs) [] in
let result = glue_lhs cands in
let lhs, cands = List.fold_left
(fun (lhs, cands) (grel, rels, args) ->
Modified: trunk/Toss/Play/Heuristic.ml
===================================================================
--- trunk/Toss/Play/Heuristic.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Play/Heuristic.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -651,10 +651,10 @@
let expanded_description max_alt_descr frels struc phi =
- let elems = Elems.elements struc.elements in
+ let elems = Structure.elements struc in
let rels =
Structure.StringMap.fold (fun rel tups rels->
- (rel, tups)::rels) struc.Structure.relations [] in
+ (rel, tups)::rels) (Structure.relations struc) [] in
let rels =
List.filter (fun (rel, _) -> not (Strings.mem rel frels)) rels in
let vars =
@@ -694,7 +694,7 @@
} in
FormulaOps.fold_formula gfold in
let i2f = float_of_int in
- let nelems = Structure.Elems.cardinal struc.Structure.elements in
+ let nelems = Structure.nbr_elems struc in
(* {{{ log entry *)
if !debug_level > 2 then (
Printf.printf
@@ -710,10 +710,10 @@
let expanded_form max_alt_descr frels struc phi =
- let elems = Elems.elements struc.elements in
+ let elems = Structure.elements struc in
let rels =
Structure.StringMap.fold (fun rel tups rels->
- (rel, tups)::rels) struc.Structure.relations [] in
+ (rel, tups)::rels) (Structure.relations struc) [] in
let rels =
List.filter (fun (rel,_) -> not (Strings.mem rel frels)) rels in
let rec aux all_vars = function
@@ -1114,7 +1114,7 @@
(snd (List.hd rules)
).ContinuousRule.discrete.DiscreteRule.rhs_struc in
let signat rel =
- Structure.StringMap.find rel signat_struc.Structure.rel_signature in
+ List.assoc rel (Structure.rel_signature signat_struc) in
let fluent_preconds =
if monotonic then
Some (DiscreteRule.fluent_preconds drules signat
Modified: trunk/Toss/Play/HeuristicTest.ml
===================================================================
--- trunk/Toss/Play/HeuristicTest.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Play/HeuristicTest.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -62,11 +62,8 @@
let signat_struc =
match struc with Some struc -> struc
| None -> (List.hd rules).DiscreteRule.rhs_struc in
- let signat rel =
- Structure.StringMap.find rel signat_struc.Structure.rel_signature in
- let signature = Structure.StringMap.fold
- (fun r ar si -> (r,ar)::si)
- signat_struc.Structure.rel_signature [] in
+ let signature = Structure.rel_signature signat_struc in
+ let signat rel = List.assoc rel signature in
let drules = List.map (DiscreteRule.compile_rule signature []) rules in
let posi_frels, nega_frels, indef_frels =
DiscreteRule.fluents drules in
Modified: trunk/Toss/Solver/Solver.ml
===================================================================
--- trunk/Toss/Solver/Solver.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Solver/Solver.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -130,12 +130,12 @@
if aset = Empty then Empty else
match phi with
| Rel (relname, vl) ->
- let tuples_s =
- try StringMap.find relname model.relations
- with Not_found -> Tuples.empty in
- let inc_map =
- try StringMap.find relname model.incidence
- with Not_found -> IntMap.empty in
+ let tuples_s =
+ try Structure.rel_find relname model
+ with Not_found -> Tuples.empty in
+ let inc_map =
+ try Structure.rel_incidence relname model
+ with Not_found -> IntMap.empty in
report (join_rel aset vl tuples_s inc_map elems)
| Eq (x, y) -> report (equal_vars elems x y aset)
| SO (v, vl) ->
@@ -276,7 +276,8 @@
(* Evaluate with assignment, no cache. *)
let evaluate_partial_aset solver ~formula struc fo_aset =
let elems =
- ref (Set (Elems.cardinal struc.elements, struc.elements)) in
+ ref (Set (Elems.cardinal (Structure.elems struc),
+ (Structure.elems struc))) in
let phi = Hashtbl.find solver.formulas_eval formula in
incr eval_counter;
eval [] struc elems fo_aset phi
@@ -289,23 +290,6 @@
let (b, nl) = assoc_del x l in
(b, pair :: nl)
-let diffrels_struc s1 s2 =
- if Structure.equal { s1 with relations = StringMap.empty; }
- { s2 with relations = StringMap.empty; } then
- let is_eq_in map rel tp =
- try
- Structure.Tuples.equal (Structure.StringMap.find rel map) tp
- with Not_found -> false in
- let is_eq_in1, is_eq_in2 = is_eq_in s1.relations, is_eq_in s2.relations in
- let diffrels = ref [] in
- let appdiff1 r tp = if not (is_eq_in1 r tp) then diffrels := r::!diffrels in
- let appdiff2 r tp = if not (is_eq_in2 r tp) then diffrels := r::!diffrels in
- Structure.StringMap.iter appdiff1 s2.relations;
- Structure.StringMap.iter appdiff2 s1.relations;
- if !debug_level > 1 then
- print_endline ("SOME DIFF: " ^ (String.concat ", " !diffrels));
- Some (Aux.unique_sorted !diffrels)
- else None
let phi_rels phi =
let rels = ref [] in
@@ -372,7 +356,8 @@
res
with Not_found ->
if !debug_level > 0 then print_endline ("Eval_m " ^ (str phi));
- let els = Set (Elems.cardinal struc.elements, struc.elements) in
+ let els = Set (Elems.cardinal (Structure.elems struc),
+ (Structure.elems struc)) in
check_timeout "Solver.eval_m.not_found";
let asg = eval [] struc (ref els) Any phi in
incr eval_counter;
@@ -382,7 +367,8 @@
(* Helper function, assignment of tuple. *)
let asg_of_tuple struc vars tuple =
- let els = Set (Elems.cardinal struc.elements, struc.elements) in
+ let els = Set (Elems.cardinal (Structure.elems struc),
+ (Structure.elems struc)) in
assignments_of_list (ref els) (Array.of_list vars) [tuple]
(* Evaluate real expressions. Result is represented as assignments with
@@ -459,7 +445,8 @@
);
check_timeout "Solver.get_real_val.sum";
let asg_gd = join asg (eval_cache_sentences solver struc guard) in
- let tps = tuples struc.elements (List.map var_str all_vs) asg_gd in
+ let tps = tuples (Structure.elems struc)
+ (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
Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Solver/Structure.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -55,10 +55,16 @@
let equal s1 s2 = (compare s1 s2 = 0)
let elements s = Elems.elements s.elements
+let elems s = s.elements
let elem_nbr s el = StringMap.find el s.names
let elem_name s e = IntMap.find e s.inv_names
+let nbr_elems s = Elems.cardinal s.elements
+let names s = s.names
+let inv_names s = s.inv_names
+let replace_names s nms inms = { s with names = nms; inv_names = inms }
+let functions s = s.functions
+let relations s = s.relations
-
(* ----------------------- BASIC HELPER FUNCTIONS --------------------------- *)
(* Number of tuples in a relation. *)
@@ -122,8 +128,14 @@
StringMap.fold (fun f _ acc -> f :: acc) struc.functions []
+(* Find a relation in a model, throw Not_found if not found. *)
+let rel_find relname model = StringMap.find relname model.relations
+(* Incidences of a relation in a model, throw Not_found if not found. *)
+let rel_incidence relname model = StringMap.find relname model.incidence
+
+
(* ---------- ADDING ELEMENTS POSSIBLY WITH HASHED STRING NAMES ---------- *)
(* Nonexisting elements or relations, signature mismatch, etc. *)
@@ -1150,6 +1162,25 @@
List.filter (fun (_, rs) -> rs <> []) (List.rev_map diff_rels elems)
+let diffrels_struc s1 s2 =
+ if equal { s1 with relations = StringMap.empty; }
+ { s2 with relations = StringMap.empty; } then
+ let is_eq_in map rel tp =
+ try
+ Tuples.equal (StringMap.find rel map) tp
+ with Not_found -> false in
+ let is_eq_in1, is_eq_in2 = is_eq_in s1.relations, is_eq_in s2.relations in
+ let diffrels = ref [] in
+ let appdiff1 r tp = if not (is_eq_in1 r tp) then diffrels := r::!diffrels in
+ let appdiff2 r tp = if not (is_eq_in2 r tp) then diffrels := r::!diffrels in
+ StringMap.iter appdiff1 s2.relations;
+ StringMap.iter appdiff2 s1.relations;
+ if !debug_level > 1 then
+ print_endline ("SOME DIFF: " ^ (String.concat ", " !diffrels));
+ Some (Aux.unique_sorted !diffrels)
+ else None
+
+
(* -------------------- PARSER HELPERS -------------------- *)
let is_uppercase c = c >= 'A' && c <= 'Z'
Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Solver/Structure.mli 2011-06-03 20:24:22 UTC (rev 1469)
@@ -17,25 +17,24 @@
(** No element is named by a decimal numeral other than its
number. Elements not appearing in [names] are assumed to be named
by their decimal numeral. *)
-type structure = {
- rel_signature : int StringMap.t ;
- elements : Elems.t ; (** Elements should be *positive* integers. *)
- relations : Tuples.t StringMap.t ;
- functions : (float IntMap.t) StringMap.t ;
- incidence : (Tuples.t IntMap.t) StringMap.t ;
- names : int StringMap.t ;
- inv_names : string IntMap.t ;
-}
+type structure
val compare_elems : int -> int -> int
val compare : structure -> structure -> int
val equal : structure -> structure -> bool
val elements : structure -> int list
+val elems : structure -> Elems.t
+val nbr_elems : structure -> int
+
val elem_nbr : structure -> string -> int
val elem_name : structure -> int -> string
+val names : structure -> int StringMap.t
+val inv_names : structure -> string IntMap.t
+val replace_names : structure -> int StringMap.t -> string IntMap.t -> structure
+val functions : structure -> (float IntMap.t) StringMap.t
+val relations : structure -> Tuples.t StringMap.t
-
(** {2 Basic helper functions} *)
(** Size of a relation, i.e. number of tuples in it. *)
@@ -59,12 +58,19 @@
(** Check if a relation holds for a tuple. *)
val check_rel : structure -> string -> int array -> bool
+(** Find a relation in a model, throw Not_found if not found. *)
+val rel_find : string -> structure -> Tuples.t
+
+(** Incidences of a relation in a model, throw Not_found if not found. *)
+val rel_incidence : string -> structure -> Tuples.t IntMap.t
+
(** Return the value of function [f] on [e] in [struc]. *)
val fun_val : structure -> string -> int -> float
(** Return the list of functions. *)
val f_signature : structure -> string list
+(** Return the list of relations with their arities. *)
val rel_signature : structure -> (string * int) list
(** Cardinality of graphs of all relations in the structure. *)
@@ -227,7 +233,10 @@
no defined properties, unless [ignore_funs] is given). *)
val gc_elems : ?ignore_funs:bool -> structure -> structure
+(** Differing relations (used in solver cache) *)
+val diffrels_struc: structure -> structure -> string list option
+
(** {2 Parser Helpers} *)
exception Board_parse_error of string
Modified: trunk/Toss/Solver/StructureTest.ml
===================================================================
--- trunk/Toss/Solver/StructureTest.ml 2011-05-31 20:33:02 UTC (rev 1468)
+++ trunk/Toss/Solver/StructureTest.ml 2011-06-03 20:24:22 UTC (rev 1469)
@@ -25,7 +25,7 @@
let struc = struc_of_string s in
assert_equal ~printer:(String.concat " | ") result
(List.map (test_incident_in_struc struc)
- (Elems.elements struc.elements))
+ (Structure.elements struc))
let test_del s en result =
let struc = struc_of_string s in
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
