4 type jump_kind = [ `TAG of Tag.t | `CONTAINS of string | `NOTHING ]
14 let h_union = Hashtbl.create 4097
17 (* special case, since this is a union we want hash(s1,s2) = hash(s2,s1) *)
19 and y = Ptset.hash s2 in
20 let h = if x < y then HASHINT2(x,y) else HASHINT2(y,x) in
22 Hashtbl.find h_union h
24 | Not_found -> let s = Ptset.union s1 s2
26 Hashtbl.add h_union h s;s
34 let mk_state = State.mk
42 | Or of formula * formula
43 | And of formula * formula
44 | Atom of ([ `Left | `Right | `LLeft | `RRight ]*bool*state)
45 and formula = { fid: int;
49 st : (Ptset.t*Ptset.t*Ptset.t)*(Ptset.t*Ptset.t*Ptset.t);
53 external hash_const_variant : [> ] -> int = "%identity"
54 external vb : bool -> int = "%identity"
56 let hash_node_form t = match t with
59 | And(f1,f2) -> (2+17*f1.fkey + 37*f2.fkey) (*land max_int *)
60 | Or(f1,f2) -> (3+101*f1.fkey + 253*f2.fkey) (*land max_int *)
61 | Atom(v,b,s) -> HASHINT3(hash_const_variant v,(3846*(vb b) +257),s)
71 if f1.fid == f2.fid || f1.fkey == f2.fkey || f1.pos == f2.pos then true
73 match f1.pos,f2.pos with
74 | False,False | True,True -> true
75 | Atom(d1,b1,s1), Atom(d2,b2,s2) when (b1==b2) && (s1==s2) && (d1 = d2) -> true
77 | And(g1,g2),And(h1,h2) -> g1.fid == h1.fid && g2.fid == h2.fid
81 module WH = Weak.Make(FormNode)
83 let f_pool = WH.create 107
85 let empty_triple = Ptset.empty,Ptset.empty,Ptset.empty
86 let empty_hex = empty_triple,empty_triple
89 let rec t = { fid = 1; pos = True; fkey=1; neg = f ; st = empty_hex; size =1; }
90 and f = { fid = 0; pos = False; fkey=0; neg = t; st = empty_hex; size = 1; }
96 let is_true f = f.fid == 1
97 let is_false f = f.fid == 0
100 let cons pos neg s1 s2 size1 size2 =
103 fkey = hash_node_form pos;
111 fkey = hash_node_form neg;
117 (WH.merge f_pool pnode),(WH.merge f_pool nnode)
120 let si = Ptset.singleton s in
121 let ss = match d with
122 | `Left -> (si,Ptset.empty,si),empty_triple
123 | `Right -> empty_triple,(si,Ptset.empty,si)
124 | `LLeft -> (Ptset.empty,si,si),empty_triple
125 | `RRight -> empty_triple,(Ptset.empty,si,si)
126 in fst (cons (Atom(d,p,s)) (Atom(d,not p,s)) ss ss 1 1)
128 let union_hex ((l1,ll1,lll1),(r1,rr1,rrr1)) ((l2,ll2,lll2),(r2,rr2,rrr2)) =
129 (pt_cup l1 l2 ,pt_cup ll1 ll2,pt_cup lll1 lll2),
130 (pt_cup r1 r2 ,pt_cup rr1 rr2,pt_cup rrr1 rrr2)
132 let merge_states f1 f2 =
134 union_hex f1.st f2.st
136 union_hex f1.neg.st f2.neg.st
141 let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in
142 let sp,sn = merge_states f1 f2 in
143 let psize = f1.size + f2.size in
144 let nsize = f1.neg.size + f2.neg.size in
145 fst (cons (Or(f1,f2)) (And(f1.neg,f2.neg)) sp sn psize nsize )
148 let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in
149 if is_true f1 || is_true f2 then true_
150 else if is_false f1 && is_false f2 then false_
151 else if is_false f1 then f2
152 else if is_false f2 then f1
154 let psize = f1.size + f2.size in
155 let nsize = f1.neg.size + f2.neg.size in
156 let sp,sn = merge_states f1 f2 in
157 fst (cons (Or(f1,f2)) (And(f1.neg,f2.neg)) sp sn psize nsize)
162 let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in
163 if is_true f1 && is_true f2 then true_
164 else if is_false f1 || is_false f2 then false_
165 else if is_true f1 then f2
166 else if is_true f2 then f1
168 let psize = f1.size + f2.size in
169 let nsize = f1.neg.size + f2.neg.size in
170 let sp,sn = merge_states f1 f2 in
171 fst (cons (And(f1,f2)) (Or(f1.neg,f2.neg)) sp sn psize nsize)
176 let k_hash (s,t) = HASHINT2(Ptset.hash s,Tag.hash t)
180 type t = Ptset.t*Tag.t
181 let equal (s1,s2) (t1,t2) = (s2 == t2) && Ptset.equal s1 t1
185 module HTagSet = Hashtbl.Make(HTagSetKey)
187 type skiplist = Nothing | All
189 | One of skiplist | Two of skiplist | Three of skiplist
190 | Four of skiplist | Five of skiplist | Six of skiplist
191 | Seven of skiplist | Eight of skiplist | Nine of skiplist
194 type formlist = Nil | Cons of state*formula*int*bool*formlist
198 mutable states : Ptset.t;
200 mutable final : Ptset.t;
202 starstate : Ptset.t option;
203 (* Transitions of the Alternating automaton *)
204 phi : (state,(TagSet.t*(bool*formula*bool)) list) Hashtbl.t;
205 sigma : (int,('a t -> Tree.t -> Tree.t -> Ptset.t*'a)) Hashtbl.t;
208 module Pair (X : Set.OrderedType) (Y : Set.OrderedType) =
211 let compare (x1,y1) (x2,y2) =
212 let r = X.compare x1 x2 in
213 if r == 0 then Y.compare y1 y2
217 module PL = Set.Make (Pair (Ptset) (Ptset))
220 let pr_st ppf l = Format.fprintf ppf "{";
224 | [s] -> Format.fprintf ppf " %i" s
225 | p::r -> Format.fprintf ppf " %i" p;
226 List.iter (fun i -> Format.fprintf ppf "; %i" i) r
228 Format.fprintf ppf " }"
229 let rec pr_frm ppf f = match f.pos with
230 | True -> Format.fprintf ppf "⊤"
231 | False -> Format.fprintf ppf "⊥"
233 Format.fprintf ppf "(";
235 Format.fprintf ppf ") ∧ (";
237 Format.fprintf ppf ")"
240 Format.fprintf ppf " ∨ ";
242 | Atom(dir,b,s) -> Format.fprintf ppf "%s%s[%i]"
243 (if b then "" else "¬")
251 Format.fprintf ppf "Automaton (%i) :\n" a.id;
252 Format.fprintf ppf "States : "; pr_st ppf (Ptset.elements a.states);
253 Format.fprintf ppf "\nInitial states : "; pr_st ppf (Ptset.elements a.init);
254 Format.fprintf ppf "\nFinal states : "; pr_st ppf (Ptset.elements a.final);
255 Format.fprintf ppf "\nUniversal states : "; pr_st ppf (Ptset.elements a.universal);
256 Format.fprintf ppf "\nAlternating transitions :\n------------------------------\n";
257 let l = Hashtbl.fold (fun k t acc ->
258 (List.map (fun (t,(m,f,p)) -> (t,k),(m,f,p)) t)@ acc) a.phi [] in
259 let l = List.sort (fun ((tsx,x),_) ((tsy,y),_) -> if x-y == 0 then TagSet.compare tsx tsy else x-y) l in
260 List.iter (fun ((ts,q),(b,f,_)) ->
263 if TagSet.is_finite ts
264 then "{" ^ (TagSet.fold (fun t a -> a ^ " '" ^ (Tag.to_string t)^"'") ts "") ^" }"
265 else let cts = TagSet.neg ts in
266 if TagSet.is_empty cts then "*" else
267 (TagSet.fold (fun t a -> a ^ " " ^ (Tag.to_string t)) cts "*\\{"
270 Format.fprintf ppf "(%s,%i) %s " s q (if b then "=>" else "->");
272 Format.fprintf ppf "\n")l;
274 Format.fprintf ppf "NFA transitions :\n------------------------------\n";
275 (* HTagSet.iter (fun (qs,t) (disp,b,_,flist,_,_) ->
276 let (ls,lls,_),(rs,rrs,_) =
277 List.fold_left (fun ((a1,b1,c1),(a2,b2,c2)) (_,f) ->
278 let (x1,y1,z1),(x2,y2,z2) = f.st in
279 ((Ptset.union x1 a1),(Ptset.union y1 b1),(Ptset.union c1 z1)),
280 ((Ptset.union x2 a2),(Ptset.union y2 b2),(Ptset.union c2 z2)))
281 ((Ptset.empty,Ptset.empty,Ptset.empty),
282 (Ptset.empty,Ptset.empty,Ptset.empty))
285 pr_st ppf (Ptset.elements qs);
286 Format.fprintf ppf ",%s %s " (Tag.to_string t) (if b then "=>" else "->");
287 List.iter (fun (q,f) ->
288 Format.fprintf ppf "\n%i," q;
290 Format.fprintf ppf "\nleft=";
291 pr_st ppf (Ptset.elements ls);
292 Format.fprintf ppf " , ";
293 pr_st ppf (Ptset.elements lls);
294 Format.fprintf ppf ", right=";
295 pr_st ppf (Ptset.elements rs);
296 Format.fprintf ppf ", ";
297 pr_st ppf (Ptset.elements rrs);
298 Format.fprintf ppf ", first=%s, next=%s\n\n" disp.flabel disp.nlabel;
300 Format.fprintf ppf "=======================================\n%!"
302 module Transitions = struct
303 type t = state*TagSet.t*bool*formula*bool
305 let ( >< ) state (l,b) = state,(l,b,false)
306 let ( ><@ ) state (l,b) = state,(l,b,true)
307 let ( >=> ) (state,(label,mark,pred)) form = (state,label,mark,form,pred)
308 let ( +| ) f1 f2 = or_ f1 f2
309 let ( *& ) f1 f2 = and_ f1 f2
310 let ( ** ) d s = atom_ d true s
314 type transition = Transitions.t
316 let equal_trans (q1,t1,m1,f1,_) (q2,t2,m2,f2,_) =
317 (q1 == q2) && (TagSet.equal t1 t2) && (m1 == m2) (*&& (equal_form f1 f2) *)
320 module HFEval = Hashtbl.Make(
322 type t = int*Ptset.t*Ptset.t
323 let equal (a,b,c) (d,e,f) =
324 a==d && (Ptset.equal b e) && (Ptset.equal c f)
326 HASHINT3(a,Ptset.hash b,Ptset.hash c)
332 let hfeval = HFEval.create 4097
333 let eval_form_bool f s1 s2 =
334 let rec eval f = match f.pos with
335 (* test some inlining *)
336 | True -> true,true,true
337 | False -> false,false,false
340 HFEval.find hfeval (f.fid,s1,s2)
342 | Not_found -> let r =
344 | Atom((`Left|`LLeft),b,q) ->
345 if b == (Ptset.mem q s1)
346 then (true,true,false)
347 else false,false,false
349 if b == (Ptset.mem q s2)
350 then (true,false,true)
351 else false,false,false
353 let b1,rl1,rr1 = eval f1
355 if b1 && rl1 && rr1 then (true,true,true)
357 let b2,rl2,rr2 = eval f2
359 let rl1,rr1 = if b1 then rl1,rr1 else false,false
360 and rl2,rr2 = if b2 then rl2,rr2 else false,false
361 in (b1 || b2, rl1||rl2,rr1||rr2)
363 let b1,rl1,rr1 = eval f1 in
364 if b1 && rl1 && rr1 then (true,true,true)
366 then let b2,rl2,rr2 = eval f2 in
367 if b2 then (true,rl1||rl2,rr1||rr2)
368 else (false,false,false)
369 else (false,false,false)
372 HFEval.add hfeval (f.fid,s1,s2) r;
377 let form_list_fold_left f acc fl =
378 let rec loop acc fl =
381 | Cons(s,frm,h,m,fll) -> loop (f acc s frm h m) fll
385 let h_formlist = Hashtbl.create 4096
386 let rec eval_formlist ?(memo=true) s1 s2 fl =
388 | Nil -> Ptset.empty,false,false,false,false
389 | Cons(q,f,h,mark,fll) ->
390 let k = (h,Ptset.hash s1,Ptset.hash s2,mark)
394 if memo then Hashtbl.find h_formlist k
395 else (raise Not_found)
398 let s,b',b1',b2',amark = eval_formlist (~memo:memo) s1 s2 fll in
399 let b,b1,b2 = eval_form_bool f s1 s2 in
400 let r = if b then (Ptset.add q s, b, b1'||b1,b2'||b2,mark||amark)
401 else s,b',b1',b2',amark
403 Format.fprintf Format.err_formatter "\nEvaluating formula (%i) %i %s" h q (if mark then "=>" else "->");
404 pr_frm (Format.err_formatter) f;
405 Format.fprintf Format.err_formatter " in context ";
406 pr_st Format.err_formatter (Ptset.elements s1);
407 Format.fprintf Format.err_formatter ", ";
408 pr_st Format.err_formatter (Ptset.elements s2);
409 Format.fprintf Format.err_formatter " result is %b\n%!" b; *)
410 (Hashtbl.add h_formlist k r;r)
414 let tags_of_state a q = Hashtbl.fold
418 (fun acc (ts,(_,_,aux)) ->
420 TagSet.cup ts acc) acc l
421 else acc) a.phi TagSet.empty
426 let ts = Ptset.fold (fun q acc -> TagSet.cup acc (tags_of_state a q)) qs TagSet.empty
428 if TagSet.is_finite ts
429 then `Positive(TagSet.positive ts)
430 else `Negative(TagSet.negative ts)
434 | `Positive s -> let r = Ptset.inter a s in (r,Ptset.mem Tag.pcdata r, true)
435 | `Negative s -> let r = Ptset.diff a s in (r, Ptset.mem Tag.pcdata r, false)
437 let mk_nil_ctx x _ = Tree.mk_nil x
438 let next_sibling_ctx x _ = Tree.next_sibling x
441 let set_get_tag r t = r := (fun _ -> t)
443 module type ResultSet =
447 val cons : Tree.t -> t -> t
448 val concat : t -> t -> t
449 val iter : (Tree.t -> unit) -> t -> unit
450 val fold : (Tree.t -> 'a -> 'a) -> t -> 'a -> 'a
451 val map : (Tree.t -> Tree.t) -> t -> t
452 val length : t -> int
455 module Integer : ResultSet =
460 let concat x y = x + y
461 let iter _ _ = failwith "iter not implemented"
462 let fold _ _ _ = failwith "fold not implemented"
463 let map _ _ = failwith "map not implemented"
467 module IdSet : ResultSet =
470 | Cons of Tree.t * node
471 | Concat of node*node
473 and t = { node : node;
476 let empty = { node = Nil; length = 0 }
478 let cons e t = { node = Cons(e,t.node); length = t.length+1 }
479 let concat t1 t2 = { node = Concat(t1.node,t2.node); length = t1.length+t2.length }
480 let append e t = { node = Concat(t.node,Cons(e,Nil)); length = t.length+1 }
483 let rec loop acc t = match t with
485 | Cons (e,t) -> loop (f e acc) t
486 | Concat (t1,t2) -> loop (loop acc t1) t2
490 let length l = l.length
494 let rec loop = function
496 | Cons (e,t) -> f e; loop t
497 | Concat(t1,t2) -> loop t1;loop t2
501 let rec loop = function
503 | Cons(e,t) -> Cons(f e, loop t)
504 | Concat(t1,t2) -> Concat(loop t1,loop t2)
506 { l with node = loop l.node }
511 module Run (RS : ResultSet) =
513 let fmt = Format.err_formatter
514 let pr x = Format.fprintf fmt x
519 let cons q f i m l = Cons(q,f,i,m,l)
520 let hash = function Nil -> 0 | Cons(_,_,i,_,_) -> max_int land i
522 let rec loop = function
525 Format.fprintf fmt "%i %s" q (if m then "=>" else "->");
527 Format.fprintf fmt "\n%!";
533 type ptset_list = Nil | Cons of Ptset.t*int*ptset_list
534 let hpl l = match l with
538 let cons s l = Cons (s,(Ptset.hash s) + 65599 * (hpl l), l)
540 let rec empty_size n =
542 else cons Ptset.empty (empty_size (n-1))
544 let fold_pl f l acc =
545 let rec loop l acc = match l with
547 | Cons(s,h,pl) -> loop pl (f s h acc)
553 | Cons(s,h,ll) -> cons (f s) (loop ll)
558 | Cons(s,h,ll) -> (f s);(loop ll)
562 let rec loop acc l = match l with
564 | Cons(s,_,ll) -> loop (cons s acc) ll
572 | Cons(s,_,ll) -> loop (cons (f s) acc) ll
576 let td_trans = Hashtbl.create 4096
579 let choose_jump tagset qtags1 qtagsn a f_nil f_text f_t1 f_s1 f_tn f_sn f_notext =
580 let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
581 let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
582 (* Format.fprintf Format.err_formatter "Tags below states ";
583 pr_st Format.err_formatter (Ptset.elements qtags1);
584 Format.fprintf Format.err_formatter " are { ";
585 Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tags1;
586 Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastext1 fin1;
588 Format.fprintf Format.err_formatter "Tags below states ";
589 pr_st Format.err_formatter (Ptset.elements qtagsn);
590 Format.fprintf Format.err_formatter " are { ";
591 Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tagsn;
592 Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastextn finn;
594 if (hastext1||hastextn) then f_text (* jumping to text nodes doesn't work really well *)
595 else if (Ptset.is_empty tags1) && (Ptset.is_empty tagsn) then f_nil
596 else if (Ptset.is_empty tagsn) then
597 if (Ptset.is_singleton tags1) then f_t1 (Ptset.choose tags1) (* TaggedChild/Sibling *)
598 else f_s1 tags1 (* SelectChild/Sibling *)
599 else if (Ptset.is_empty tags1) then
600 if (Ptset.is_singleton tagsn) then f_tn (Ptset.choose tagsn) (* TaggedDesc/Following *)
601 else f_sn tagsn (* SelectDesc/Following *)
604 let choose_jump_down a b c d =
608 (*fun x -> let i,j = Tree.doc_ids x in
609 let res = Tree.text_below x in
610 Printf.printf "Calling text_below %s (tag=%s), docids= (%i,%i), res=%s\n"
611 (Tree.dump_node x) (Tag.to_string (Tree.tag x)) i j (Tree.dump_node res);
613 (fun _ -> Tree.node_child ) (* !! no tagged_child in Tree.ml *)
614 (fun _ -> Tree.node_child ) (* !! no select_child in Tree.ml *)
616 (fun _ -> Tree.node_child ) (* !! no select_desc *)
619 let choose_jump_next a b c d =
621 (fun t _ -> Tree.mk_nil t)
623 (*fun x y -> let i,j = Tree.doc_ids x in
624 let res = Tree.text_next x y in
625 Printf.printf "Calling text_next %s (tag=%s) ctx=%s, docids= (%i,%i), res=%s\n"
626 (Tree.dump_node x) (Tag.to_string (Tree.tag x)) (Tree.dump_node y) i j (Tree.dump_node res);
629 (fun _ -> Tree.node_sibling_ctx) (* !! no tagged_sibling in Tree.ml *)
630 (fun _ -> Tree.node_sibling_ctx) (* !! no select_child in Tree.ml *)
631 (Tree.tagged_foll_below)
632 (fun _ -> Tree.node_sibling_ctx) (* !! no select_foll *)
633 (Tree.node_sibling_ctx)
636 let get_trans slist tag a t =
638 Hashtbl.find td_trans (tag,hpl slist)
641 let fl_list,llist,rlist,ca,da,sa,fa =
643 (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
644 let fl,ll,rr,ca,da,sa,fa =
649 (fun (((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc),h_acc) as acc)
651 if (TagSet.mem tag ts)
653 let (child,desc,below),(sibl,foll,after) = f.st in
654 let h_acc = HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)) in
655 ((Formlist.cons q f h_acc m fl_acc,
656 Ptset.union ll_acc below,
657 Ptset.union rl_acc after,
658 Ptset.union child c_acc,
659 Ptset.union desc d_acc,
660 Ptset.union sibl s_acc,
661 Ptset.union foll f_acc),
664 try Hashtbl.find a.phi q
666 Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
670 ) set (Formlist.nil,Ptset.empty,Ptset.empty,ca,da,sa,fa)
671 in fl::fll_acc, cons ll lllacc, cons rr rllacc,ca,da,sa,fa)
672 slist ([],Nil,Nil,Ptset.empty,Ptset.empty,Ptset.empty,Ptset.empty)
674 (* Logic to chose the first and next function *)
675 let tags_below,tags_after = Tree.tags t tag in
676 let first = choose_jump_down tags_below ca da a
677 and next = choose_jump_next tags_after sa fa a in
678 let v = (fl_list,llist,rlist,first,next) in
679 Hashtbl.add td_trans (tag, hpl slist) v; v
681 let merge rb rb1 rb2 mark t res1 res2 =
684 let res1 = if rb1 then res1 else RS.empty
685 and res2 = if rb2 then res2 else RS.empty
687 if mark then RS.cons t (RS.concat res1 res2)
688 else RS.concat res1 res2
691 let top_down ?(noright=false) a t slist ctx slot_size =
692 let pempty = empty_size slot_size in
693 let eval_fold2_slist fll sl1 sl2 res1 res2 t =
694 let res = Array.copy res1 in
695 let rec fold l1 l2 fll i aq = match l1,l2,fll with
696 | Cons(s1,_,ll1), Cons(s2, _ ,ll2),fl::fll ->
697 let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in
698 (* let _ = pr "Evaluation context : "; pr_st fmt (Ptset.elements s1);
699 pr_st fmt (Ptset.elements s2);
700 pr "Formlist (%i) : " (Formlist.hash fl);
702 pr "Results : "; pr_st fmt (Ptset.elements r');
703 pr ", %b %b %b %b\n%!" rb rb1 rb2 mark
705 let _ = res.(i) <- merge rb rb1 rb2 mark t res1.(i) res2.(i)
707 fold ll1 ll2 fll (i+1) (cons r' aq)
708 | Nil, Nil,[] -> aq,res
711 fold sl1 sl2 fll 0 Nil
713 let null_result() = (pempty,Array.make slot_size RS.empty) in
714 let rec loop t slist ctx =
716 if Tree.is_nil t then null_result()
718 let tag = Tree.tag t in
719 let fl_list,llist,rlist,first,next = get_trans slist tag a t in
720 (* let _ = pr "For tag %s,node %s, returning formulae list: \n%!"
721 (Tag.to_string tag) (Tree.dump_node t);
722 List.iter (fun f -> Formlist.pr fmt f;pr "\n%!") fl_list
724 let sl1,res1 = loop (first t) llist t in
725 let sl2,res2 = loop (next t ctx) rlist ctx in
726 eval_fold2_slist fl_list sl1 sl2 res1 res2 t
728 (* let _ = pr "Inside topdown call: tree was %s, tag = %s" (Tree.dump_node t) (if Tree.is_nil t then "###"
729 else Tag.to_string (Tree.tag t));
730 iter_pl (fun s -> (pr_st fmt (Ptset.elements s))) a;
731 Array.iter (fun i -> pr "%i" (RS.length i)) b;
732 pr "\n%!"; in*) (a,b)
735 let loop_no_right t slist ctx =
736 if Tree.is_nil t then null_result()
738 let tag = Tree.tag t in
739 let fl_list,llist,rlist,first,next = get_trans slist tag a t in
740 let sl1,res1 = loop (first t) llist t in
741 let sl2,res2 = null_result() in
742 eval_fold2_slist fl_list sl1 sl2 res1 res2 t
744 (if noright then loop_no_right else loop) t slist ctx
746 let run_top_down a t =
747 let init = cons a.init Nil in
748 let _,res = top_down a t init t 1
752 module Configuration =
754 module Ptss = Set.Make(Ptset)
755 module IMap = Map.Make(Ptset)
756 type t = { hash : int;
758 results : RS.t IMap.t }
759 let empty = { hash = 0;
761 results = IMap.empty;
763 let is_empty c = Ptss.is_empty c.sets
765 if Ptss.mem s c.sets then
766 { c with results = IMap.add s (RS.concat r (IMap.find s c.results)) c.results}
768 { hash = HASHINT2(c.hash,Ptset.hash s);
769 sets = Ptss.add s c.sets;
770 results = IMap.add s r c.results
773 let pr fmt c = Format.fprintf fmt "{";
774 Ptss.iter (fun s -> pr_st fmt (Ptset.elements s);
775 Format.fprintf fmt " ") c.sets;
776 Format.fprintf fmt "}\n%!";
777 IMap.iter (fun k d ->
778 pr_st fmt (Ptset.elements k);
779 Format.fprintf fmt "-> %i\n" (RS.length d)) c.results;
780 Format.fprintf fmt "\n%!"
783 let acc1 = IMap.fold (fun s r acc ->
786 RS.concat r (IMap.find s acc)
788 | Not_found -> r) acc) c1.results IMap.empty
791 IMap.fold (fun s r acc ->
794 RS.concat r (IMap.find s acc)
796 | Not_found -> r) acc) c2.results acc1
800 (fun s (ah,ass) -> (HASHINT2(ah,Ptset.hash s),
802 (Ptss.union c1.sets c2.sets) (0,Ptss.empty)
810 let h_fold = Hashtbl.create 511
812 let fold_f_conf t slist fl_list conf dir=
813 let rec loop sl fl acc =
816 | Cons(s,hs,sll), formlist::fll ->
817 let r',rb,rb1,rb2,mark =
819 Hashtbl.find h_fold (hs,Formlist.hash formlist,dir)
821 Not_found -> let res =
822 if dir then eval_formlist ~memo:false s Ptset.empty formlist
823 else eval_formlist ~memo:false Ptset.empty s formlist
824 in (Hashtbl.add h_fold (hs,Formlist.hash formlist,dir) res;res)
826 let _ = pr "Evaluating on set (%s) with tree %s=%s"
827 (if dir then "left" else "right")
828 (Tag.to_string (Tree.tag t))
830 pr_st fmt (Ptset.elements s);
831 pr ", formualae (with hash %i): \n" (Formlist.hash formlist);
832 Formlist.pr fmt formlist;
834 pr_st fmt (Ptset.elements r');
835 pr " %b %b %b %b \n%!" rb rb1 rb2 mark ;
837 if rb && ((dir&&rb1)|| ((not dir) && rb2))
841 try Configuration.IMap.find s conf.Configuration.results
842 with Not_found -> RS.empty
844 Configuration.add acc r' (if mark then RS.cons t old_r else old_r)
847 else loop sll fll acc
850 loop slist fl_list Configuration.empty
852 let h_trans = Hashtbl.create 4096
854 let get_up_trans slist ptag a tree =
855 let key = (HASHINT2(hpl slist,Tag.hash ptag)) in
857 Hashtbl.find h_trans key
861 Hashtbl.fold (fun q l acc ->
862 List.fold_left (fun (fl_acc,h_acc) (ts,(m,f,_)) ->
863 if TagSet.mem ptag ts
865 let h_acc = HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)) in
866 (Formlist.cons q f h_acc m fl_acc,
870 a.phi (Formlist.nil,0)
872 let res = fold_pl (fun _ _ acc -> f_list::acc) slist []
874 (Hashtbl.add h_trans key res;res)
877 let h_tdconf = Hashtbl.create 511
878 let rec bottom_up a tree conf next jump_fun root dotd init accu =
879 if (not dotd) && (Configuration.is_empty conf ) then
880 (* let _ = pr "Returning early from %s, with accu %i, next is %s\n%!"
881 (Tree.dump_node tree) (Obj.magic accu) (Tree.dump_node next)
886 pr "Going bottom up for tree with tag %s configuration is"
887 (if Tree.is_nil tree then "###" else Tag.to_string (Tree.tag tree));
888 Configuration.pr fmt conf
890 let below_right = Tree.is_below_right tree next in
891 (* let _ = Format.fprintf Format.err_formatter "below_right %s %s = %b\n%!"
892 (Tree.dump_node tree) (Tree.dump_node next) below_right
894 let accu,rightconf,next_of_next =
895 if below_right then (* jump to the next *)
896 (* let _ = pr "Jumping to %s tag %s\n%!" (Tree.dump_node next) (Tag.to_string (Tree.tag next)) in *)
897 bottom_up a next conf (jump_fun next) jump_fun (Tree.next_sibling tree) true init accu
898 else accu,Configuration.empty,next
900 (* let _ = if below_right then pr "Returning from jump to next = %s\n" (Tree.dump_node next)in *)
903 if below_right then (* only recurse on the left subtree *)
904 (* let _ = pr "Topdown on left subtree\n%!" in *)
905 prepare_topdown a tree true
907 (* let _ = pr "Topdown on whole tree\n%!" in *)
908 prepare_topdown a tree false
912 (Configuration.merge rightconf sub, next_of_next)
914 if Tree.equal tree root then
915 (* let _ = pr "Stopping at root, configuration after topdown is:" ;
916 Configuration.pr fmt conf;
920 let parent = Tree.binary_parent tree in
921 let ptag = Tree.tag parent in
922 let dir = Tree.is_left tree in
923 let slist = Configuration.Ptss.fold (fun e a -> cons e a) conf.Configuration.sets Nil in
924 let fl_list = get_up_trans slist ptag a parent in
925 let slist = rev_pl (slist) in
926 (* let _ = pr "Current conf is : %s " (Tree.dump_node tree);
927 Configuration.pr fmt conf;
930 let newconf = fold_f_conf parent slist fl_list conf dir in
931 (* let _ = pr "New conf before pruning is (dir=%b):" dir;
932 Configuration.pr fmt newconf ;
933 pr "accu is %i\n" (RS.length accu);
935 let accu,newconf = Configuration.IMap.fold (fun s res (ar,nc) ->
936 if Ptset.intersect s init then
937 ( RS.concat res ar ,nc)
938 else (ar,Configuration.add nc s res))
939 (newconf.Configuration.results) (accu,Configuration.empty)
941 (* let _ = pr "New conf after pruning is (dir=%b):" dir;
942 Configuration.pr fmt newconf ;
943 pr "accu is %i\n" (RS.length accu);
945 bottom_up a parent newconf next jump_fun root false init accu
947 and prepare_topdown a t noright =
948 let tag = Tree.tag t in
949 (* pr "Going top down on tree with tag %s = %s "
950 (if Tree.is_nil t then "###" else (Tag.to_string(Tree.tag t))) (Tree.dump_node t); *)
953 Hashtbl.find h_tdconf tag
956 let res = Hashtbl.fold (fun q l acc ->
957 if List.exists (fun (ts,_) -> TagSet.mem tag ts) l
959 else acc) a.phi Ptset.empty
960 in Hashtbl.add h_tdconf tag res;res
962 (* let _ = pr ", among ";
963 pr_st fmt (Ptset.elements r);
966 let r = cons r Nil in
967 let set,res = top_down (~noright:noright) a t r t 1 in
968 let set = match set with
972 (* pr "Result of topdown run is %!";
973 pr_st fmt (Ptset.elements set);
974 pr ", number is %i\n%!" (RS.length res.(0)); *)
975 Configuration.add Configuration.empty set res.(0)
979 let run_bottom_up a t k =
980 let trlist = Hashtbl.find a.phi (Ptset.choose a.init)
982 let init = List.fold_left
983 (fun acc (_,(_,f,_)) ->
984 Ptset.union acc (let (_,_,l) = fst (f.st) in l))
990 (*Tree.tagged_lowest t tag, fun tree -> Tree.tagged_next tree tag*)
991 (Tree.tagged_desc tag t, fun tree -> Tree.tagged_foll_below tag tree t)
992 | `CONTAINS(_) -> (Tree.text_below t,fun tree -> Tree.text_next tree t)
995 let tree2 = jump_fun tree1 in
996 let rec loop tree next acc =
997 (* let _ = pr "\n_________________________\nNew iteration\n" in
998 let _ = pr "Jumping to %s\n%!" (Tree.dump_node tree) in *)
999 let acc,conf,next_of_next = bottom_up a tree
1000 Configuration.empty next jump_fun (Tree.root tree) true init acc
1002 (* let _ = pr "End of first iteration, conf is:\n%!";
1003 Configuration.pr fmt conf
1005 let acc = Configuration.IMap.fold
1006 ( fun s res acc -> if Ptset.intersect init s
1007 then RS.concat res acc else acc) conf.Configuration.results acc
1009 if Tree.is_nil next_of_next (*|| Tree.equal next next_of_next *)then
1011 else loop next_of_next (jump_fun next_of_next) acc
1013 loop tree1 tree2 RS.empty
1018 let top_down_count a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down a t)
1019 let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t)
1020 let bottom_up_count a t k = let module RI = Run(Integer) in Integer.length (RI.run_bottom_up a t k)