module CachedTransTable = Hashtbl.Make(SetTagKey)
module Formlist = struct
- include Ptset.Make(Transition)
+ include Hlist.Make(Transition)
let print ppf fl =
iter (fun t -> Transition.print ppf t; Format.pp_print_newline ppf ()) fl
end
let hash (f,(s,t)) =
HASHINT3(Formula.uid f ,StateSet.uid s,StateSet.uid t)
end))
-
+
module F = Formula
- let eval_form_bool f s1 s2 =
- let sets = (s1,s2) in
- let eval = MemoForm.make_rec(
- fun eval (f,_) ->
- match F.expr f with
- | F.True -> true,true,true
- | F.False -> false,false,false
- | F.Atom((`Left|`LLeft),b,q) ->
- if b == (StateSet.mem q s1)
- then (true,true,false)
- else false,false,false
- | F.Atom(_,b,q) ->
- if b == (StateSet.mem q s2)
- then (true,false,true)
- else false,false,false
- | F.Or(f1,f2) ->
- let b1,rl1,rr1 = eval (f1,sets)
- in
- if b1 && rl1 && rr1 then (true,true,true) else
- let b2,rl2,rr2 = eval (f2,sets) in
- let rl1,rr1 = if b1 then rl1,rr1 else false,false
- and rl2,rr2 = if b2 then rl2,rr2 else false,false
- in (b1 || b2, rl1||rl2,rr1||rr2)
-
+let eval_form_bool =
+ MemoForm.make_rec(
+ fun eval (f, ((s1,s2) as sets)) ->
+ match F.expr f with
+ | F.True -> true,true,true
+ | F.False -> false,false,false
+ | F.Atom((`Left|`LLeft),b,q) ->
+ if b == (StateSet.mem q s1)
+ then (true,true,false)
+ else false,false,false
+ | F.Atom(_,b,q) ->
+ if b == (StateSet.mem q s2)
+ then (true,false,true)
+ else false,false,false
+ | F.Or(f1,f2) ->
+ let b1,rl1,rr1 = eval (f1,sets)
+ in
+ if b1 && rl1 && rr1 then (true,true,true) else
+ let b2,rl2,rr2 = eval (f2,sets) in
+ let rl1,rr1 = if b1 then rl1,rr1 else false,false
+ and rl2,rr2 = if b2 then rl2,rr2 else false,false
+ in (b1 || b2, rl1||rl2,rr1||rr2)
+
| F.And(f1,f2) ->
let b1,rl1,rr1 = eval (f1,sets) in
if b1 && rl1 && rr1 then (true,true,true) else
- if b1 then
- let b2,rl2,rr2 = eval (f2,sets) in
- if b2 then (true,rl1||rl2,rr1||rr2) else (false,false,false)
- else (false,false,false)
- )
- in
- eval (f,sets)
-
-
- module MemoFormlist = Memoizer.Make(
- Hashtbl.Make(struct
- type t = Formlist.t*(StateSet.t*StateSet.t)
- let equal (f1,(s1,t1)) (f2,(s2,t2)) =
- Formlist.equal f1 f2 && StateSet.equal s1 s2 && StateSet.equal t1 t2
- let hash (f,(s,t)) =
- HASHINT3(Formlist.uid f ,StateSet.uid s,StateSet.uid t)
- end))
-
- let eval_formlist ?(memo=true) s1 s2 fl =
- let sets = (s1,s2) in
- let eval = MemoFormlist.make_rec (
- fun eval (fl,_) ->
- if Formlist.is_empty fl
- then StateSet.empty,false,false,false,false
- else
- let f,fll = Formlist.uncons fl in
- let q,mark,f,_ = Transition.node f in
- let b,b1,b2 = eval_form_bool f s1 s2 in
- let s,b',b1',b2',amark = eval (fll,sets) in
- if b then (StateSet.add q s, b, b1'||b1,b2'||b2,mark||amark)
- else s,b',b1',b2',amark )
- in eval (fl,sets)
-
+ if b1 then
+ let b2,rl2,rr2 = eval (f2,sets) in
+ if b2 then (true,rl1||rl2,rr1||rr2) else (false,false,false)
+ else (false,false,false)
+ )
+
+let eval_form_bool f s1 s2 = eval_form_bool (f,(s1,s2))
+
+
+module MemoFormlist = Memoizer.Make(
+ Hashtbl.Make(struct
+ type t = Formlist.t*(StateSet.t*StateSet.t)
+ let equal (f1,(s1,t1)) (f2,(s2,t2)) =
+ Formlist.equal f1 f2 && StateSet.equal s1 s2 && StateSet.equal t1 t2
+ let hash (f,(s,t)) =
+ HASHINT3(Formlist.uid f ,StateSet.uid s,StateSet.uid t)
+ end))
+
+
+
+ let eval_formlist = MemoFormlist.make_rec (
+ fun eval (fl,((s1,s2)as sets)) ->
+ match Formlist.node fl with
+ | Formlist.Nil -> StateSet.empty,false,false,false,false
+ | Formlist.Cons(f,fll) ->
+ let q,mark,f,_ = Transition.node f in
+ let b,b1,b2 = eval_form_bool f s1 s2 in
+ let s,b',b1',b2',amark = eval (fll,sets) in
+ if b then (StateSet.add q s, b, b1'||b1,b2'||b2,mark||amark)
+ else s,b',b1',b2',amark )
+
+ let eval_formlist ?(memo=true) s1 s2 fl =
+ eval_formlist (fl,(s1,s2))
+
let tags_of_state a q =
Hashtbl.fold
module Run (RS : ResultSet) =
struct
+ module SList = Hlist.Make (StateSet)
- let fmt = Format.err_formatter
- let pr x = Format.fprintf fmt x
-
- type ptset_list = Nil | Cons of Ptset.Int.t*int*ptset_list
- let hpl l = match l with
- | Nil -> 0
- | Cons (_,i,_) -> i
-
- let cons s l = Cons (s,(Ptset.Int.hash s) + 65599 * (hpl l), l)
-
- let rec empty_size n =
- if n == 0 then Nil
- else cons Ptset.Int.empty (empty_size (n-1))
-
- let fold_pl f l acc =
- let rec loop l acc = match l with
- Nil -> acc
- | Cons(s,h,pl) -> loop pl (f s h acc)
- in
- loop l acc
- let map_pl f l =
- let rec loop =
- function Nil -> Nil
- | Cons(s,h,ll) -> cons (f s) (loop ll)
- in loop l
- let iter_pl f l =
- let rec loop =
- function Nil -> ()
- | Cons(s,h,ll) -> (f s);(loop ll)
- in loop l
-
- let rev_pl l =
- let rec loop acc l = match l with
- | Nil -> acc
- | Cons(s,_,ll) -> loop (cons s acc) ll
- in
- loop Nil l
-
- let rev_map_pl f l =
- let rec loop acc l =
- match l with
- | Nil -> acc
- | Cons(s,_,ll) -> loop (cons (f s) acc) ll
- in
- loop Nil l
-
- module IntSet = Set.Make(struct type t = int let compare = (-) end)
IFDEF DEBUG
THEN
+ module IntSet = Set.Make(struct type t = int let compare = (-) end)
INCLUDE "html_trace.ml"
END
let get_trans slist tag a t =
try
- Hashtbl.find td_trans (tag,hpl slist)
+ Hashtbl.find td_trans (tag,SList.hash slist)
with
| Not_found ->
let fl_list,llist,rlist,ca,da,sa,fa =
- fold_pl
- (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
+ SList.fold
+ (fun set (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
let fl,ll,rr,ca,da,sa,fa =
StateSet.fold
(fun q acc ->
then
let _,_,f,_ = Transition.node t in
let (child,desc,below),(sibl,foll,after) = Formula.st f in
- (Formlist.add t fl_acc,
+ (Formlist.cons t fl_acc,
StateSet.union ll_acc below,
StateSet.union rl_acc after,
StateSet.union child c_acc,
q;[]
)
- ) set (Formlist.empty,StateSet.empty,StateSet.empty,ca,da,sa,fa)
- in fl::fll_acc, cons ll lllacc, cons rr rllacc,ca,da,sa,fa)
- slist ([],Nil,Nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty)
+ ) set (Formlist.nil,StateSet.empty,StateSet.empty,ca,da,sa,fa)
+ in fl::fll_acc, (SList.cons ll lllacc), (SList.cons rr rllacc),ca,da,sa,fa)
+ slist ([],SList.nil,SList.nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty)
in
(* Logic to chose the first and next function *)
let tags_below,tags_after = Tree.tags t tag in
let first = choose_jump_down tags_below ca da a
and next = choose_jump_next tags_after sa fa a in
let v = (fl_list,llist,rlist,first,next) in
- Hashtbl.add td_trans (tag, hpl slist) v; v
+ Hashtbl.add td_trans (tag, SList.hash slist) v; v
let merge rb rb1 rb2 mark t res1 res2 =
if rb
if mark then RS.cons t (RS.concat res1 res2)
else RS.concat res1 res2
else RS.empty
-
+
+ let empty_size n =
+ let rec loop acc = function 0 -> acc
+ | n -> loop (SList.cons StateSet.empty acc) (n-1)
+ in loop SList.nil n
+
let top_down ?(noright=false) a t slist ctx slot_size =
let pempty = empty_size slot_size in
let eval_fold2_slist fll sl1 sl2 res1 res2 t =
let res = Array.copy res1 in
- let rec fold l1 l2 fll i aq = match l1,l2,fll with
- | Cons(s1,_,ll1), Cons(s2, _ ,ll2),fl::fll ->
+ let rec fold l1 l2 fll i aq =
+ match SList.node l1,SList.node l2, fll with
+ | SList.Cons(s1,ll1),
+ SList.Cons(s2,ll2),
+ fl::fll ->
let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in
let _ = res.(i) <- merge rb rb1 rb2 mark t res1.(i) res2.(i)
in
- fold ll1 ll2 fll (i+1) (cons r' aq)
- | Nil, Nil,[] -> aq,res
+ fold ll1 ll2 fll (i+1) (SList.cons r' aq)
+ | SList.Nil, SList.Nil,[] -> aq,res
| _ -> assert false
in
- fold sl1 sl2 fll 0 Nil
+ fold sl1 sl2 fll 0 SList.nil
in
let null_result() = (pempty,Array.make slot_size RS.empty) in
let rec loop t slist ctx =
if Tree.is_nil t then null_result()
else
- let tag = Tree.tag t in
+ let tag = Tree.tag t in
let fl_list,llist,rlist,first,next = get_trans slist tag a t in
let sl1,res1 = loop (first t) llist t in
let sl2,res2 = loop (next t ctx) rlist ctx in
let run_top_down a t =
- let init = cons a.init Nil in
+ let init = SList.cons a.init SList.nil in
let _,res = top_down a t init t 1
in
D_IGNORE_(
let fold_f_conf t slist fl_list conf dir=
let rec loop sl fl acc =
- match sl,fl with
- |Nil,[] -> acc
- | Cons(s,hs,sll), formlist::fll ->
- let r',rb,rb1,rb2,mark =
- try
- Hashtbl.find h_fold (hs,Formlist.hash formlist,dir)
- with
- Not_found -> let res =
- if dir then eval_formlist ~memo:false s Ptset.Int.empty formlist
- else eval_formlist ~memo:false Ptset.Int.empty s formlist
- in (Hashtbl.add h_fold (hs,Formlist.hash formlist,dir) res;res)
- in(*
- let _ = pr "Evaluating on set (%s) with tree %s=%s"
- (if dir then "left" else "right")
- (Tag.to_string (Tree.tag t))
- (Tree.dump_node t) ;
- StateSet.print fmt (Ptset.Int.elements s);
- pr ", formualae (with hash %i): \n" (Formlist.hash formlist);
- Formlist.pr fmt formlist;
- pr "result is ";
- StateSet.print fmt (Ptset.Int.elements r');
- pr " %b %b %b %b \n%!" rb rb1 rb2 mark ;
- in *)
+ match SList.node sl,fl with
+ |SList.Nil,[] -> acc
+ |SList.Cons(s,sll), formlist::fll ->
+ let r',rb,rb1,rb2,mark =
+ let key = SList.hash sl,Formlist.hash formlist,dir in
+ try
+ Hashtbl.find h_fold key
+ with
+ Not_found -> let res =
+ if dir then eval_formlist s Ptset.Int.empty formlist
+ else eval_formlist Ptset.Int.empty s formlist
+ in (Hashtbl.add h_fold key res;res)
+ in
if rb && ((dir&&rb1)|| ((not dir) && rb2))
then
let acc =
let h_trans = Hashtbl.create 4096
let get_up_trans slist ptag a tree =
- let key = (HASHINT2(hpl slist,Tag.hash ptag)) in
+ let key = (HASHINT2(SList.hash slist,Tag.hash ptag)) in
try
Hashtbl.find h_trans key
with
let f_list =
Hashtbl.fold (fun q l acc ->
List.fold_left (fun fl_acc (ts,t) ->
- if TagSet.mem ptag ts then Formlist.add t fl_acc
+ if TagSet.mem ptag ts then Formlist.cons t fl_acc
else fl_acc)
acc l)
- a.trans Formlist.empty
+ a.trans Formlist.nil
in
- let res = fold_pl (fun _ _ acc -> f_list::acc) slist []
+ let res = SList.fold (fun _ acc -> f_list::acc) slist []
in
(Hashtbl.add h_trans key res;res)
let h_tdconf = Hashtbl.create 511
let rec bottom_up a tree conf next jump_fun root dotd init accu =
if (not dotd) && (Configuration.is_empty conf ) then
-(* let _ = pr "Returning early from %s, with accu %i, next is %s\n%!"
- (Tree.dump_node tree) (Obj.magic accu) (Tree.dump_node next)
- in *)
+
accu,conf,next
else
-(* let _ =
- pr "Going bottom up for tree with tag %s configuration is"
- (if Tree.is_nil tree then "###" else Tag.to_string (Tree.tag tree));
- Configuration.pr fmt conf
- in *)
+
let below_right = Tree.is_below_right tree next in
- (* let _ = Format.fprintf Format.err_formatter "below_right %s %s = %b\n%!"
- (Tree.dump_node tree) (Tree.dump_node next) below_right
- in *)
+
let accu,rightconf,next_of_next =
- if below_right then (* jump to the next *)
-(* let _ = pr "Jumping to %s tag %s\n%!" (Tree.dump_node next) (Tag.to_string (Tree.tag next)) in *)
- bottom_up a next conf (jump_fun next) jump_fun (Tree.next_sibling tree) true init accu
- else accu,Configuration.empty,next
- in
-(* let _ = if below_right then pr "Returning from jump to next = %s\n" (Tree.dump_node next)in *)
+ if below_right then (* jump to the next *)
+ bottom_up a next conf (jump_fun next) jump_fun (Tree.next_sibling tree) true init accu
+ else accu,Configuration.empty,next
+ in
let sub =
if dotd then
- if below_right then (* only recurse on the left subtree *)
-(* let _ = pr "Topdown on left subtree\n%!" in *)
- prepare_topdown a tree true
- else
-(* let _ = pr "Topdown on whole tree\n%!" in *)
- prepare_topdown a tree false
+ if below_right then prepare_topdown a tree true
+ else prepare_topdown a tree false
else conf
in
let conf,next =
(Configuration.merge rightconf sub, next_of_next)
in
- if Tree.equal tree root then
-(* let _ = pr "Stopping at root, configuration after topdown is:" ;
- Configuration.pr fmt conf;
- pr "\n%!"
- in *) accu,conf,next
+ if Tree.equal tree root then accu,conf,next
else
let parent = Tree.binary_parent tree in
let ptag = Tree.tag parent in
let dir = Tree.is_left tree in
- let slist = Configuration.Ptss.fold (fun e a -> cons e a) conf.Configuration.sets Nil in
+ let slist = Configuration.Ptss.fold (fun e a -> SList.cons e a) conf.Configuration.sets SList.nil in
let fl_list = get_up_trans slist ptag a parent in
- let slist = rev_pl (slist) in
-(* let _ = pr "Current conf is : %s " (Tree.dump_node tree);
- Configuration.pr fmt conf;
- pr "\n"
- in *)
+ let slist = SList.rev (slist) in
let newconf = fold_f_conf parent slist fl_list conf dir in
-(* let _ = pr "New conf before pruning is (dir=%b):" dir;
- Configuration.pr fmt newconf ;
- pr "accu is %i\n" (RS.length accu);
- in *)
let accu,newconf = Configuration.IMap.fold (fun s res (ar,nc) ->
if Ptset.Int.intersect s init then
( RS.concat res ar ,nc)
else (ar,Configuration.add nc s res))
(newconf.Configuration.results) (accu,Configuration.empty)
in
-(* let _ = pr "New conf after pruning is (dir=%b):" dir;
- Configuration.pr fmt newconf ;
- pr "accu is %i\n" (RS.length accu);
- in *)
+
bottom_up a parent newconf next jump_fun root false init accu
and prepare_topdown a t noright =
StateSet.print fmt (Ptset.Int.elements r);
pr "\n%!";
in *)
- let r = cons r Nil in
+ let r = SList.cons r SList.nil in
let set,res = top_down (~noright:noright) a t r t 1 in
- let set = match set with
- | Cons(x,_,Nil) ->x
+ let set = match SList.node set with
+ | SList.Cons(x,_) ->x
| _ -> assert false
in
(* pr "Result of topdown run is %!";
+++ /dev/null
-(***************************************************************************)
-(* Implementation for sets of positive integers implemented as deeply hash-*)
-(* consed Patricia trees. Provide fast set operations, fast membership as *)
-(* well as fast min and max elements. Hash consing provides O(1) equality *)
-(* checking *)
-(* *)
-(***************************************************************************)
-IFDEF USE_PTSET_INCLUDE
-THEN
-INCLUDE "utils.ml"
-(*
- Cannot be used like this:
- Need to be included after the following declrations:
- type elt = ...
- let equal_elt : elt -> elt -> bool = ...
- let hash_elt : elt -> int = ...
- let uid_elt : elt -> int = ...
-*)
-type 'a node =
- | Empty
- | Leaf of elt
- | Branch of int * int * 'a * 'a
-
-module rec HNode : Hcons.S with type data = Node.t = Hcons.Make (Node)
-and Node : Hashtbl.HashedType with type t = HNode.t node =
-struct
- type t = HNode.t node
- let equal x y =
- match x,y with
- | Empty,Empty -> true
- | Leaf k1, Leaf k2 -> equal_elt k1 k2
- | Branch(b1,i1,l1,r1),Branch(b2,i2,l2,r2) ->
- b1 == b2 && i1 == i2 &&
- (HNode.equal l1 l2) &&
- (HNode.equal r1 r2)
- | _ -> false
- let hash = function
- | Empty -> 0
- | Leaf i -> HASHINT2(HALF_MAX_INT,hash_elt i)
- | Branch (b,i,l,r) -> HASHINT4(b,i,HNode.hash l, HNode.hash r)
-end
-
-type t = HNode.t
-let hash = HNode.hash
-let uid = HNode.uid
-
-let empty = HNode.make Empty
-
-let is_empty s = (HNode.node s) == Empty
-
-(* WH.merge pool *)
-
-let branch p m l r = HNode.make (Branch(p,m,l,r))
-let leaf k = HNode.make (Leaf k)
-
-(* To enforce the invariant that a branch contains two non empty sub-trees *)
-let branch_ne p m t0 t1 =
- if (is_empty t0) then t1
- else if is_empty t1 then t0 else branch p m t0 t1
-
-(********** from here on, only use the smart constructors *************)
-
-let zero_bit k m = (k land m) == 0
-
-let singleton k = leaf k
-
-let is_singleton n =
- match HNode.node n with Leaf _ -> true
- | _ -> false
-
-let mem (k:elt) n =
- let kid = uid_elt k in
- let rec loop n = match HNode.node n with
- | Empty -> false
- | Leaf j -> equal_elt k j
- | Branch (p, _, l, r) -> if kid <= p then loop l else loop r
- in loop n
-
-let rec min_elt n = match HNode.node n with
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_,_,s,_) -> min_elt s
-
-let rec max_elt n = match HNode.node n with
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_,_,_,t) -> max_elt t
-
- let elements s =
- let rec elements_aux acc n = match HNode.node n with
- | Empty -> acc
- | Leaf k -> k :: acc
- | Branch (_,_,l,r) -> elements_aux (elements_aux acc r) l
- in
- elements_aux [] s
-
- let mask k m = (k lor (m-1)) land (lnot m)
-
- let naive_highest_bit x =
- assert (x < 256);
- let rec loop i =
- if i = 0 then 1 else if x lsr i = 1 then 1 lsl i else loop (i-1)
- in
- loop 7
-
- let hbit = Array.init 256 naive_highest_bit
-
- let highest_bit_32 x =
- let n = x lsr 24 in if n != 0 then Array.unsafe_get hbit n lsl 24
- else let n = x lsr 16 in if n != 0 then Array.unsafe_get hbit n lsl 16
- else let n = x lsr 8 in if n != 0 then Array.unsafe_get hbit n lsl 8
- else Array.unsafe_get hbit x
-
- let highest_bit_64 x =
- let n = x lsr 32 in if n != 0 then (highest_bit_32 n) lsl 32
- else highest_bit_32 x
-
- let highest_bit = match Sys.word_size with
- | 32 -> highest_bit_32
- | 64 -> highest_bit_64
- | _ -> assert false
-
- let branching_bit p0 p1 = highest_bit (p0 lxor p1)
-
- let join p0 t0 p1 t1 =
- let m = branching_bit p0 p1 in
- if zero_bit p0 m then
- branch (mask p0 m) m t0 t1
- else
- branch (mask p0 m) m t1 t0
-
- let match_prefix k p m = (mask k m) == p
-
- let add k t =
- let kid = uid_elt k in
- let rec ins n = match HNode.node n with
- | Empty -> leaf k
- | Leaf j -> if equal_elt j k then n else join kid (leaf k) (uid_elt j) n
- | Branch (p,m,t0,t1) ->
- if match_prefix kid p m then
- if zero_bit kid m then
- branch p m (ins t0) t1
- else
- branch p m t0 (ins t1)
- else
- join kid (leaf k) p n
- in
- ins t
-
- let remove k t =
- let kid = uid_elt k in
- let rec rmv n = match HNode.node n with
- | Empty -> empty
- | Leaf j -> if equal_elt k j then empty else n
- | Branch (p,m,t0,t1) ->
- if match_prefix kid p m then
- if zero_bit kid m then
- branch_ne p m (rmv t0) t1
- else
- branch_ne p m t0 (rmv t1)
- else
- n
- in
- rmv t
-
- (* should run in O(1) thanks to Hash consing *)
-
- let equal a b = HNode.equal a b
-
- let compare a b = (HNode.uid a) - (HNode.uid b)
-
- let rec merge s t =
- if (equal s t) (* This is cheap thanks to hash-consing *)
- then s
- else
- match HNode.node s, HNode.node t with
- | Empty, _ -> t
- | _, Empty -> s
- | Leaf k, _ -> add k t
- | _, Leaf k -> add k s
- | Branch (p,m,s0,s1), Branch (q,n,t0,t1) ->
- if m == n && match_prefix q p m then
- branch p m (merge s0 t0) (merge s1 t1)
- else if m > n && match_prefix q p m then
- if zero_bit q m then
- branch p m (merge s0 t) s1
- else
- branch p m s0 (merge s1 t)
- else if m < n && match_prefix p q n then
- if zero_bit p n then
- branch q n (merge s t0) t1
- else
- branch q n t0 (merge s t1)
- else
- (* The prefixes disagree. *)
- join p s q t
-
-
-
-
- let rec subset s1 s2 = (equal s1 s2) ||
- match (HNode.node s1,HNode.node s2) with
- | Empty, _ -> true
- | _, Empty -> false
- | Leaf k1, _ -> mem k1 s2
- | Branch _, Leaf _ -> false
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- subset l1 l2 && subset r1 r2
- else if m1 < m2 && match_prefix p1 p2 m2 then
- if zero_bit p1 m2 then
- subset l1 l2 && subset r1 l2
- else
- subset l1 r2 && subset r1 r2
- else
- false
-
-
- let union s1 s2 = merge s1 s2
- (* Todo replace with e Memo Module *)
- module MemUnion = Hashtbl.Make(
- struct
- type set = t
- type t = set*set
- let equal (x,y) (z,t) = (equal x z)&&(equal y t)
- let equal a b = equal a b || equal b a
- let hash (x,y) = (* commutative hash *)
- let x = HNode.hash x
- and y = HNode.hash y
- in
- if x < y then HASHINT2(x,y) else HASHINT2(y,x)
- end)
- let h_mem = MemUnion.create MED_H_SIZE
-
- let mem_union s1 s2 =
- try MemUnion.find h_mem (s1,s2)
- with Not_found ->
- let r = merge s1 s2 in MemUnion.add h_mem (s1,s2) r;r
-
-
- let rec inter s1 s2 =
- if equal s1 s2
- then s1
- else
- match (HNode.node s1,HNode.node s2) with
- | Empty, _ -> empty
- | _, Empty -> empty
- | Leaf k1, _ -> if mem k1 s2 then s1 else empty
- | _, Leaf k2 -> if mem k2 s1 then s2 else empty
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- merge (inter l1 l2) (inter r1 r2)
- else if m1 > m2 && match_prefix p2 p1 m1 then
- inter (if zero_bit p2 m1 then l1 else r1) s2
- else if m1 < m2 && match_prefix p1 p2 m2 then
- inter s1 (if zero_bit p1 m2 then l2 else r2)
- else
- empty
-
- let rec diff s1 s2 =
- if equal s1 s2
- then empty
- else
- match (HNode.node s1,HNode.node s2) with
- | Empty, _ -> empty
- | _, Empty -> s1
- | Leaf k1, _ -> if mem k1 s2 then empty else s1
- | _, Leaf k2 -> remove k2 s1
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- merge (diff l1 l2) (diff r1 r2)
- else if m1 > m2 && match_prefix p2 p1 m1 then
- if zero_bit p2 m1 then
- merge (diff l1 s2) r1
- else
- merge l1 (diff r1 s2)
- else if m1 < m2 && match_prefix p1 p2 m2 then
- if zero_bit p1 m2 then diff s1 l2 else diff s1 r2
- else
- s1
-
-
-(*s All the following operations ([cardinal], [iter], [fold], [for_all],
- [exists], [filter], [partition], [choose], [elements]) are
- implemented as for any other kind of binary trees. *)
-
-let rec cardinal n = match HNode.node n with
- | Empty -> 0
- | Leaf _ -> 1
- | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1
-
-let rec iter f n = match HNode.node n with
- | Empty -> ()
- | Leaf k -> f k
- | Branch (_,_,t0,t1) -> iter f t0; iter f t1
-
-let rec fold f s accu = match HNode.node s with
- | Empty -> accu
- | Leaf k -> f k accu
- | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu)
-
-
-let rec for_all p n = match HNode.node n with
- | Empty -> true
- | Leaf k -> p k
- | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1
-
-let rec exists p n = match HNode.node n with
- | Empty -> false
- | Leaf k -> p k
- | Branch (_,_,t0,t1) -> exists p t0 || exists p t1
-
-let rec filter pr n = match HNode.node n with
- | Empty -> empty
- | Leaf k -> if pr k then n else empty
- | Branch (p,m,t0,t1) -> branch_ne p m (filter pr t0) (filter pr t1)
-
-let partition p s =
- let rec part (t,f as acc) n = match HNode.node n with
- | Empty -> acc
- | Leaf k -> if p k then (add k t, f) else (t, add k f)
- | Branch (_,_,t0,t1) -> part (part acc t0) t1
- in
- part (empty, empty) s
-
-let rec choose n = match HNode.node n with
- | Empty -> raise Not_found
- | Leaf k -> k
- | Branch (_, _,t0,_) -> choose t0 (* we know that [t0] is non-empty *)
-
-
-let split x s =
- let coll k (l, b, r) =
- if k < x then add k l, b, r
- else if k > x then l, b, add k r
- else l, true, r
- in
- fold coll s (empty, false, empty)
-
-
-let make l = List.fold_left (fun acc e -> add e acc ) empty l
-(*i*)
-
-(*s Additional functions w.r.t to [Set.S]. *)
-
-let rec intersect s1 s2 = (equal s1 s2) ||
- match (HNode.node s1,HNode.node s2) with
- | Empty, _ -> false
- | _, Empty -> false
- | Leaf k1, _ -> mem k1 s2
- | _, Leaf k2 -> mem k2 s1
- | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
- if m1 == m2 && p1 == p2 then
- intersect l1 l2 || intersect r1 r2
- else if m1 < m2 && match_prefix p2 p1 m1 then
- intersect (if zero_bit p2 m1 then l1 else r1) s2
- else if m1 > m2 && match_prefix p1 p2 m2 then
- intersect s1 (if zero_bit p1 m2 then l2 else r2)
- else
- false
-
-
-
-let rec uncons n = match HNode.node n with
- | Empty -> raise Not_found
- | Leaf k -> (k,empty)
- | Branch (p,m,s,t) -> let h,ns = uncons s in h,branch_ne p m ns t
-
-let from_list l = List.fold_left (fun acc e -> add e acc) empty l
-
-END
projects / SXSI / xpathcomp.git / commitdiff