3 type jump_kind = [ `TAG of Tag.t | `CONTAINS of string | `NOTHING ]
13 let h_union = Hashtbl.create 4097
16 (* special case, since this is a union we want hash(s1,s2) = hash(s2,s1) *)
18 and y = Ptset.hash s2 in
19 let h = if x < y then HASHINT2(x,y) else HASHINT2(y,x) in
21 Hashtbl.find h_union h
23 | Not_found -> let s = Ptset.union s1 s2
25 Hashtbl.add h_union h s;s
33 let mk_state = State.mk
41 | Or of formula * formula
42 | And of formula * formula
43 | Atom of ([ `Left | `Right | `LLeft | `RRight ]*bool*state)
44 and formula = { fid: int;
48 st : (Ptset.t*Ptset.t*Ptset.t)*(Ptset.t*Ptset.t*Ptset.t);
52 external hash_const_variant : [> ] -> int = "%identity"
53 external vb : bool -> int = "%identity"
55 let hash_node_form t = match t with
58 | And(f1,f2) -> (2+17*f1.fkey + 37*f2.fkey) (*land max_int *)
59 | Or(f1,f2) -> (3+101*f1.fkey + 253*f2.fkey) (*land max_int *)
60 | Atom(v,b,s) -> HASHINT3(hash_const_variant v,(3846*(vb b) +257),s)
70 if f1.fid == f2.fid || f1.fkey == f2.fkey || f1.pos == f2.pos then true
72 match f1.pos,f2.pos with
73 | False,False | True,True -> true
74 | Atom(d1,b1,s1), Atom(d2,b2,s2) when (b1==b2) && (s1==s2) && (d1 = d2) -> true
76 | And(g1,g2),And(h1,h2) -> g1.fid == h1.fid && g2.fid == h2.fid
80 module WH = Weak.Make(FormNode)
82 let f_pool = WH.create 107
84 let empty_triple = Ptset.empty,Ptset.empty,Ptset.empty
85 let empty_hex = empty_triple,empty_triple
88 let rec t = { fid = 1; pos = True; fkey=1; neg = f ; st = empty_hex; size =1; }
89 and f = { fid = 0; pos = False; fkey=0; neg = t; st = empty_hex; size = 1; }
95 let is_true f = f.fid == 1
96 let is_false f = f.fid == 0
99 let cons pos neg s1 s2 size1 size2 =
102 fkey = hash_node_form pos;
110 fkey = hash_node_form neg;
116 (WH.merge f_pool pnode),(WH.merge f_pool nnode)
119 let si = Ptset.singleton s in
120 let ss = match d with
121 | `Left -> (si,Ptset.empty,si),empty_triple
122 | `Right -> empty_triple,(si,Ptset.empty,si)
123 | `LLeft -> (Ptset.empty,si,si),empty_triple
124 | `RRight -> empty_triple,(Ptset.empty,si,si)
125 in fst (cons (Atom(d,p,s)) (Atom(d,not p,s)) ss ss 1 1)
127 let union_hex ((l1,ll1,lll1),(r1,rr1,rrr1)) ((l2,ll2,lll2),(r2,rr2,rrr2)) =
128 (pt_cup l1 l2 ,pt_cup ll1 ll2,pt_cup lll1 lll2),
129 (pt_cup r1 r2 ,pt_cup rr1 rr2,pt_cup rrr1 rrr2)
131 let merge_states f1 f2 =
133 union_hex f1.st f2.st
135 union_hex f1.neg.st f2.neg.st
140 let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in
141 let sp,sn = merge_states f1 f2 in
142 let psize = f1.size + f2.size in
143 let nsize = f1.neg.size + f2.neg.size in
144 fst (cons (Or(f1,f2)) (And(f1.neg,f2.neg)) sp sn psize nsize )
147 let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in
148 if is_true f1 || is_true f2 then true_
149 else if is_false f1 && is_false f2 then false_
150 else if is_false f1 then f2
151 else if is_false f2 then f1
153 let psize = f1.size + f2.size in
154 let nsize = f1.neg.size + f2.neg.size in
155 let sp,sn = merge_states f1 f2 in
156 fst (cons (Or(f1,f2)) (And(f1.neg,f2.neg)) sp sn psize nsize)
161 let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in
162 if is_true f1 && is_true f2 then true_
163 else if is_false f1 || is_false f2 then false_
164 else if is_true f1 then f2
165 else if is_true f2 then f1
167 let psize = f1.size + f2.size in
168 let nsize = f1.neg.size + f2.neg.size in
169 let sp,sn = merge_states f1 f2 in
170 fst (cons (And(f1,f2)) (Or(f1.neg,f2.neg)) sp sn psize nsize)
175 let k_hash (s,t) = HASHINT2(Ptset.hash s,Tag.hash t)
179 type t = Ptset.t*Tag.t
180 let equal (s1,s2) (t1,t2) = (s2 == t2) && Ptset.equal s1 t1
184 module HTagSet = Hashtbl.Make(HTagSetKey)
186 type skiplist = Nothing | All
188 | One of skiplist | Two of skiplist | Three of skiplist
189 | Four of skiplist | Five of skiplist | Six of skiplist
190 | Seven of skiplist | Eight of skiplist | Nine of skiplist
193 type formlist = Nil | Cons of state*formula*int*bool*formlist
197 mutable states : Ptset.t;
199 mutable final : Ptset.t;
201 starstate : Ptset.t option;
202 (* Transitions of the Alternating automaton *)
203 phi : (state,(TagSet.t*(bool*formula*bool)) list) Hashtbl.t;
204 sigma : (int,('a t -> Tree.t -> Tree.t -> Ptset.t*'a)) Hashtbl.t;
207 module Pair (X : Set.OrderedType) (Y : Set.OrderedType) =
210 let compare (x1,y1) (x2,y2) =
211 let r = X.compare x1 x2 in
212 if r == 0 then Y.compare y1 y2
216 module PL = Set.Make (Pair (Ptset) (Ptset))
219 let pr_st ppf l = Format.fprintf ppf "{";
223 | [s] -> Format.fprintf ppf " %i" s
224 | p::r -> Format.fprintf ppf " %i" p;
225 List.iter (fun i -> Format.fprintf ppf "; %i" i) r
227 Format.fprintf ppf " }"
228 let rec pr_frm ppf f = match f.pos with
229 | True -> Format.fprintf ppf "⊤"
230 | False -> Format.fprintf ppf "⊥"
232 Format.fprintf ppf "(";
234 Format.fprintf ppf ") ∧ (";
236 Format.fprintf ppf ")"
239 Format.fprintf ppf " ∨ ";
241 | Atom(dir,b,s) -> Format.fprintf ppf "%s%s[%i]"
242 (if b then "" else "¬")
250 Format.fprintf ppf "Automaton (%i) :\n" a.id;
251 Format.fprintf ppf "States : "; pr_st ppf (Ptset.elements a.states);
252 Format.fprintf ppf "\nInitial states : "; pr_st ppf (Ptset.elements a.init);
253 Format.fprintf ppf "\nFinal states : "; pr_st ppf (Ptset.elements a.final);
254 Format.fprintf ppf "\nUniversal states : "; pr_st ppf (Ptset.elements a.universal);
255 Format.fprintf ppf "\nAlternating transitions :\n------------------------------\n";
256 let l = Hashtbl.fold (fun k t acc ->
257 (List.map (fun (t,(m,f,p)) -> (t,k),(m,f,p)) t)@ acc) a.phi [] in
258 let l = List.sort (fun ((tsx,x),_) ((tsy,y),_) -> if x-y == 0 then TagSet.compare tsx tsy else x-y) l in
259 List.iter (fun ((ts,q),(b,f,_)) ->
262 if TagSet.is_finite ts
263 then "{" ^ (TagSet.fold (fun t a -> a ^ " '" ^ (Tag.to_string t)^"'") ts "") ^" }"
264 else let cts = TagSet.neg ts in
265 if TagSet.is_empty cts then "*" else
266 (TagSet.fold (fun t a -> a ^ " " ^ (Tag.to_string t)) cts "*\\{"
269 Format.fprintf ppf "(%s,%i) %s " s q (if b then "=>" else "->");
271 Format.fprintf ppf "\n")l;
273 Format.fprintf ppf "NFA transitions :\n------------------------------\n";
274 (* HTagSet.iter (fun (qs,t) (disp,b,_,flist,_,_) ->
275 let (ls,lls,_),(rs,rrs,_) =
276 List.fold_left (fun ((a1,b1,c1),(a2,b2,c2)) (_,f) ->
277 let (x1,y1,z1),(x2,y2,z2) = f.st in
278 ((Ptset.union x1 a1),(Ptset.union y1 b1),(Ptset.union c1 z1)),
279 ((Ptset.union x2 a2),(Ptset.union y2 b2),(Ptset.union c2 z2)))
280 ((Ptset.empty,Ptset.empty,Ptset.empty),
281 (Ptset.empty,Ptset.empty,Ptset.empty))
284 pr_st ppf (Ptset.elements qs);
285 Format.fprintf ppf ",%s %s " (Tag.to_string t) (if b then "=>" else "->");
286 List.iter (fun (q,f) ->
287 Format.fprintf ppf "\n%i," q;
289 Format.fprintf ppf "\nleft=";
290 pr_st ppf (Ptset.elements ls);
291 Format.fprintf ppf " , ";
292 pr_st ppf (Ptset.elements lls);
293 Format.fprintf ppf ", right=";
294 pr_st ppf (Ptset.elements rs);
295 Format.fprintf ppf ", ";
296 pr_st ppf (Ptset.elements rrs);
297 Format.fprintf ppf ", first=%s, next=%s\n\n" disp.flabel disp.nlabel;
299 Format.fprintf ppf "=======================================\n%!"
301 module Transitions = struct
302 type t = state*TagSet.t*bool*formula*bool
304 let ( >< ) state (l,b) = state,(l,b,false)
305 let ( ><@ ) state (l,b) = state,(l,b,true)
306 let ( >=> ) (state,(label,mark,pred)) form = (state,label,mark,form,pred)
307 let ( +| ) f1 f2 = or_ f1 f2
308 let ( *& ) f1 f2 = and_ f1 f2
309 let ( ** ) d s = atom_ d true s
313 type transition = Transitions.t
315 let equal_trans (q1,t1,m1,f1,_) (q2,t2,m2,f2,_) =
316 (q1 == q2) && (TagSet.equal t1 t2) && (m1 == m2) (*&& (equal_form f1 f2) *)
319 module HFEval = Hashtbl.Make(
321 type t = int*Ptset.t*Ptset.t
322 let equal (a,b,c) (d,e,f) =
323 a==d && (Ptset.equal b e) && (Ptset.equal c f)
325 HASHINT3(a,Ptset.hash b,Ptset.hash c)
331 let hfeval = HFEval.create 4097
332 let eval_form_bool f s1 s2 =
333 let rec eval f = match f.pos with
334 (* test some inlining *)
335 | True -> true,true,true
336 | False -> false,false,false
339 HFEval.find hfeval (f.fid,s1,s2)
341 | Not_found -> let r =
343 | Atom((`Left|`LLeft),b,q) ->
344 if b == (Ptset.mem q s1)
345 then (true,true,false)
346 else false,false,false
348 if b == (Ptset.mem q s2)
349 then (true,false,true)
350 else false,false,false
352 let b1,rl1,rr1 = eval f1
354 if b1 && rl1 && rr1 then (true,true,true)
356 let b2,rl2,rr2 = eval f2
358 let rl1,rr1 = if b1 then rl1,rr1 else false,false
359 and rl2,rr2 = if b2 then rl2,rr2 else false,false
360 in (b1 || b2, rl1||rl2,rr1||rr2)
362 let b1,rl1,rr1 = eval f1 in
363 if b1 && rl1 && rr1 then (true,true,true)
365 then let b2,rl2,rr2 = eval f2 in
366 if b2 then (true,rl1||rl2,rr1||rr2)
367 else (false,false,false)
368 else (false,false,false)
371 HFEval.add hfeval (f.fid,s1,s2) r;
376 let form_list_fold_left f acc fl =
377 let rec loop acc fl =
380 | Cons(s,frm,h,m,fll) -> loop (f acc s frm h m) fll
384 let h_formlist = Hashtbl.create 4096
385 let rec eval_formlist ?(memo=true) s1 s2 fl =
387 | Nil -> Ptset.empty,false,false,false,false
388 | Cons(q,f,h,mark,fll) ->
389 let k = (h,Ptset.hash s1,Ptset.hash s2,mark)
393 if memo then Hashtbl.find h_formlist k
394 else (raise Not_found)
397 let s,b',b1',b2',amark = eval_formlist (~memo:memo) s1 s2 fll in
398 let b,b1,b2 = eval_form_bool f s1 s2 in
399 let r = if b then (Ptset.add q s, b, b1'||b1,b2'||b2,mark||amark)
400 else s,b',b1',b2',amark
402 Format.fprintf Format.err_formatter "\nEvaluating formula (%i) %i %s" h q (if mark then "=>" else "->");
403 pr_frm (Format.err_formatter) f;
404 Format.fprintf Format.err_formatter " in context ";
405 pr_st Format.err_formatter (Ptset.elements s1);
406 Format.fprintf Format.err_formatter ", ";
407 pr_st Format.err_formatter (Ptset.elements s2);
408 Format.fprintf Format.err_formatter " result is %b\n%!" b; *)
409 (Hashtbl.add h_formlist k r;r)
413 let tags_of_state a q = Hashtbl.fold
417 (fun acc (ts,(_,_,aux)) ->
419 TagSet.cup ts acc) acc l
420 else acc) a.phi TagSet.empty
425 let ts = Ptset.fold (fun q acc -> TagSet.cup acc (tags_of_state a q)) qs TagSet.empty
427 if TagSet.is_finite ts
428 then `Positive(TagSet.positive ts)
429 else `Negative(TagSet.negative ts)
433 | `Positive s -> let r = Ptset.inter a s in (r,Ptset.mem Tag.pcdata r, true)
434 | `Negative s -> let r = Ptset.diff a s in (r, Ptset.mem Tag.pcdata r, false)
436 let mk_nil_ctx x _ = Tree.mk_nil x
437 let next_sibling_ctx x _ = Tree.next_sibling x
440 let set_get_tag r t = r := (fun _ -> t)
443 let merge_trans t a tag q acc =
444 List.fold_left (fun (accf,acchash,idx) (ts,(m,f,pred)) ->
447 let acchash = HASHINT3(acchash,f.fid,q) in
448 (Cons(q,f,acchash,idx,m,accf),acchash,idx+1)
449 else (accf,acchash,idx)
450 ) acc (try Hashtbl.find a.phi q with Not_found -> [])
454 let cast_cont :'b -> ('a t -> Tree.t -> Tree.t -> Ptset.t*'a) =
457 let get_trans conti t a tag r =
459 Hashtbl.find a.sigma (HASHINT2(Ptset.hash r,Tag.hash tag))
463 Ptset.fold (fun q (accf,acchash,accq,aidx) ->
464 let naccf,acchash,naidx =
465 merge_trans t a tag q (accf,acchash,aidx )
467 (naccf,acchash,Ptset.add q accq,naidx)
469 r (Nil,17,Ptset.empty,0)
471 let (ls,lls,llls),(rs,rrs,rrrs) =
472 form_list_fold_left (fun ((a1,b1,c1),(a2,b2,c2)) _ f _ _ _ ->
473 let (x1,y1,z1),(x2,y2,z2) = f.st in
474 ((Ptset.union x1 a1),(Ptset.union y1 b1),(Ptset.union c1 z1)),
475 ((Ptset.union x2 a2),(Ptset.union y2 b2),(Ptset.union c2 z2)))
476 ((Ptset.empty,Ptset.empty,Ptset.empty),
477 (Ptset.empty,Ptset.empty,Ptset.empty))
483 let tl,htlt,lfin = inter_text tb (tags a ls)
484 and tll,htllt,llfin = inter_text tb (tags a lls)
485 and tr,htrt,rfin = inter_text ta (tags a rs)
486 and trr,htrrt,rrfin = inter_text ta (tags a rrs)
488 let get_tag = ref Tree.tag in
490 if (llfin && lfin) then (* no stars *)
491 (if htlt || htllt then (Tree.text_below, "#text_below")
493 let etl = Ptset.is_empty tl
494 and etll = Ptset.is_empty tll
497 then (Tree.mk_nil, "#mk_nil")
500 if Ptset.is_singleton tll
502 set_get_tag get_tag (Ptset.choose tll);
503 (Tree.tagged_desc (Ptset.choose tll), "#tagged_desc")
505 else (Tree.select_desc_only tll, "#select_desc_only")
506 else if etll then (Tree.node_child,"#node_child")
507 else (Tree.select_below tl tll,"#select_below"))
508 else (* stars or node() *)
509 if htlt||htllt then (Tree.first_child,"#first_child")
510 else (Tree.node_child,"#node_child")
512 if (rrfin && rfin) then (* no stars *)
514 then (Tree.text_next, "#text_next")
516 let etr = Ptset.is_empty tr
517 and etrr = Ptset.is_empty trr
520 then (mk_nil_ctx, "#mk_nil_ctx")
523 if Ptset.is_singleton trr
525 set_get_tag get_tag (Ptset.choose trr);
526 (Tree.tagged_foll_below (Ptset.choose trr),"#tagged_foll_below")
528 else (Tree.select_foll_only trr,"#select_foll_only")
529 else if etrr then (Tree.node_sibling_ctx,"#node_sibling_ctx")
531 (Tree.select_next tr trr,"#select_next") )
533 else if htrt || htrrt then (Tree.next_sibling_ctx,"#next_sibling_ctx")
534 else (Tree.node_sibling_ctx,"#node_sibling_ctx")
536 let cont = let flist = fl in
538 let s1,res1 = conti a (first t) llls res t
539 and s2,res2 = conti a (next t ctx) rrrs res ctx in
540 let r',rb,rb1,rb2,mark,idxl = eval_formlist s1 s2 flist
542 r',(vb rb)*((vb mark) + (vb rb1)*res1 + (vb rb2)*res2)
544 Hashtbl.add a.sigma (HASHINT2(Ptset.hash r,Tag.hash tag)) (cast_cont cont);
549 let rec accepting_among a t r ctx =
550 if Tree.is_nil t || Ptset.is_empty r then Ptset.empty,0,TS.Nil else
551 let dispatch,mark,flist,llls,rrrs =
552 get_trans (fun _ _ _ _ -> failwith "toto") t a (Tree.tag t) r
554 let s1,n1,res1 = accepting_among a (dispatch.first t) llls t in
555 let s2,n2,res2 = accepting_among a (dispatch.next t ctx) rrrs ctx in
556 let r',rb,rb1,rb2 = eval_formlist s1 s2 flist in
557 r',(vb rb)*((vb mark) + (vb rb1)* n1 + (vb rb2)*n2),if rb then
558 dispatch.consres t res1 res2 rb1 rb2
561 let run a t = assert false (*
562 let st,n,res = accepting_among a t a.init t in
563 if Ptset.is_empty (st) then TS.empty,0 else res,n *)
565 let rec accepting_among_count_no_star a t r ctx =
566 if Tree.is_nil t then Ptset.empty,0 else
567 (get_trans (accepting_among_count_no_star) t a (Tree.tag t) r)
571 let rec accepting_among_count_star a t n =
572 if Tree.is_nil t then n else
573 if (Tree.tag t == Tag.attribute)
574 then accepting_among_count_star a (Tree.node_sibling t) n
575 else accepting_among_count_star a (Tree.node_sibling t)
576 (accepting_among_count_star a (Tree.node_child t) (1+n))
578 let rec accepting_among_count_may_star starstate a t r ctx =
579 if r == starstate then starstate,(accepting_among_count_star a t 0)
581 if Tree.is_nil t||Ptset.is_empty r then Ptset.empty,0 else
582 let dispatch,mark,flist,llls,rrrs =
583 get_trans (fun _ _ _ _ -> failwith "toto") t a (Tree.tag t) r
585 let s1,res1 = accepting_among_count_may_star starstate a (dispatch.first t) llls t
586 and s2,res2 = accepting_among_count_may_star starstate a (dispatch.next t ctx) rrrs ctx
588 let r',rb,rb1,rb2 = eval_formlist s1 s2 flist
590 r',(vb rb)*((vb mark) + (vb rb1)*res1 + (vb rb2)*res2)
595 let st,res = match a.starstate with
596 | None -> accepting_among_count_no_star a t a.init t
597 | Some s -> assert false (*accepting_among_count_may_star s a t a.init t *)
599 if Ptset.is_empty (st) then 0 else res
602 let run_time _ _ = failwith "blah"
605 module RealBottomUp = struct
607 (* decrease number of arguments *)
608 let ton t = if Tree.is_nil t then "##"
609 else Tag.to_string (Tree.tag t)
611 let ion t = Tree.dump_node t
612 let memo = Hashtbl.create 4097
616 let rec run a t res r root rinit next targettag r0 first tomark =
618 let res = (vb tomark) + res in
619 let newr,newres = if first then
620 accepting_among_count_no_star a t r t
623 let r,res = if Ptset.is_empty newr then r,0 else newr,newres in
624 if Tree.equal t root then
625 if Ptset.intersect r rinit then (r,res,next)
626 else (Ptset.empty,0,next)
628 let tag = Tree.tag t in
629 let parent = Tree.binary_parent t in
630 let parent_tag = Tree.tag parent in
631 let left = Tree.is_left t in
633 try Hashtbl.find memo (r,parent_tag,left) with
639 (fun (aq,am) (ts,(mark,form,_)) ->
640 if TagSet.mem parent_tag ts then
641 let (value,_,_) = if left then
642 eval_form_bool form r Ptset.empty
644 eval_form_bool form Ptset.empty r
646 (* let _ = if value then begin
647 Format.fprintf Format.err_formatter "Can take transition (%i,%s)%s%!"
648 q (Tag.to_string parent_tag)
649 (if mark then "=>" else "->");
650 pr_frm Format.err_formatter form;
651 Format.fprintf Format.err_formatter "%! %s(" (if left then "left" else "right");
652 pr_st Format.err_formatter (Ptset.elements r);
653 Format.fprintf Format.err_formatter ")\n%!" end;
655 if value then (Ptset.add q aq, mark||am)
659 ) a.phi (Ptset.empty,false)
660 in Hashtbl.add memo (r,parent_tag,left) pair;pair
662 if Ptset.is_empty r' then Ptset.empty,0,next
664 if Tree.is_below_right t next then
665 let rn,resn,nextofnext = run a next 0 r0 t r (Tree.tagged_next next targettag) targettag r0 true false
667 let rn,resn = if Ptset.is_empty rn then Ptset.empty,0 else rn,resn in
668 run a (parent) (resn+res) r' root rinit nextofnext targettag r0 false false
670 run a (parent) (res) r' root rinit next targettag r0 false (mark&&left)
674 let accept_count a t tag initset =
675 let tree1 = Tree.tagged_lowest t tag in
676 let tree2 = Tree.tagged_next tree1 tag in
677 let c,b,_ =run a tree1 0 initset t a.init tree2 tag initset true false
678 in Printf.eprintf "%i\n%!" !cpt;
679 if Ptset.is_empty c then 0 else b
683 module RealBottomUp2 = struct
688 let cons q f i m l = Cons(q,f,i,m,l)
689 let hash = function Nil -> 0 | Cons(_,_,i,_,_) -> max_int land i
691 let rec loop = function
694 Format.fprintf fmt "%i %s" q (if m then "=>" else "->");
696 Format.fprintf fmt "\n%!";
702 type ptset_list = Nil | Cons of Ptset.t*int*ptset_list
703 let hpl l = match l with
707 let cons s l = Cons (s,(Ptset.hash s) + 65599 * (hpl l), l)
709 let rec empty_size n =
711 else cons Ptset.empty (empty_size (n-1))
713 let fold_pl f l acc =
714 let rec loop l acc = match l with
716 | Cons(s,h,pl) -> loop pl (f s h acc)
722 | Cons(s,h,ll) -> cons (f s) (loop ll)
726 let rec loop acc l = match l with
728 | Cons(s,_,ll) -> loop (cons s acc) ll
736 | Cons(s,_,ll) -> loop (cons (f s) acc) ll
740 let merge_int _ rb rb1 rb2 mark _ res1 res2 =
741 if rb then (vb mark) + ((vb rb1)*res1) + ((vb rb2)*res2)
744 let td_trans = Hashtbl.create 4096
746 let choose_jump tagset qtags1 qtagsn a f_nil f_text f_t1 f_s1 f_tn f_sn f_notext =
747 let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
748 let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
749 (* Format.fprintf Format.err_formatter "Tags below states ";
750 pr_st Format.err_formatter (Ptset.elements qtags1);
751 Format.fprintf Format.err_formatter " are { ";
752 Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tags1;
753 Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastext1 fin1;
755 Format.fprintf Format.err_formatter "Tags below states ";
756 pr_st Format.err_formatter (Ptset.elements qtagsn);
757 Format.fprintf Format.err_formatter " are { ";
758 Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tagsn;
759 Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastextn finn;
761 if (hastext1||hastextn) then f_text (* jumping to text nodes doesn't work really well *)
762 else if (Ptset.is_empty tags1) && (Ptset.is_empty tagsn) then f_nil
763 else if (Ptset.is_empty tagsn) then
764 if (Ptset.is_singleton tags1) then f_t1 (Ptset.choose tags1) (* TaggedChild/Sibling *)
765 else f_s1 tags1 (* SelectChild/Sibling *)
766 else if (Ptset.is_empty tags1) then
767 if (Ptset.is_singleton tagsn) then f_tn (Ptset.choose tagsn) (* TaggedDesc/Following *)
768 else f_sn tagsn (* SelectDesc/Following *)
771 let choose_jump_down a b c d =
775 (fun _ -> Tree.node_child ) (* !! no tagged_child in Tree.ml *)
776 (fun _ -> Tree.node_child ) (* !! no select_child in Tree.ml *)
778 (fun _ -> Tree.node_child ) (* !! no select_desc *)
781 let choose_jump_next a b c d =
783 (fun t _ -> Tree.mk_nil t)
785 (fun _ -> Tree.node_sibling_ctx) (* !! no tagged_sibling in Tree.ml *)
786 (fun _ -> Tree.node_sibling_ctx) (* !! no select_child in Tree.ml *)
787 (Tree.tagged_foll_below)
788 (fun _ -> Tree.node_sibling_ctx) (* !! no select_foll *)
789 (Tree.node_sibling_ctx)
795 val cons : elt -> t -> t
796 val concat : t -> t -> t
800 let get_trans slist tag a t =
802 Hashtbl.find td_trans (tag,hpl slist)
805 let fl_list,llist,rlist,ca,da,sa,fa =
807 (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
808 let fl,ll,rr,ca,da,sa,fa =
813 (fun (((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc),h_acc) as acc)
815 if (TagSet.mem tag ts)
817 let (child,desc,below),(sibl,foll,after) = f.st in
818 ((Formlist.cons q f h_acc m fl_acc,
819 Ptset.union ll_acc below,
820 Ptset.union rl_acc after,
821 Ptset.union child c_acc,
822 Ptset.union desc d_acc,
823 Ptset.union sibl s_acc,
824 Ptset.union foll f_acc),
825 HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)))
827 try Hashtbl.find a.phi q
829 Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
833 ) set (Formlist.nil,Ptset.empty,Ptset.empty,ca,da,sa,fa)
834 in fl::fll_acc, cons ll lllacc, cons rr rllacc,ca,da,sa,fa)
835 slist ([],Nil,Nil,Ptset.empty,Ptset.empty,Ptset.empty,Ptset.empty)
837 (* Logic to chose the first and next function *)
838 let tags_below,tags_after = Tree.tags t tag in
839 let first = choose_jump_down tags_below ca da a
840 and next = choose_jump_next tags_after sa fa a in
841 let v = (fl_list,llist,rlist,first,next) in
842 Hashtbl.add td_trans (tag, hpl slist) v; v
845 let top_down ?(noright=false) a merge null t slist ctx slot_size =
846 let pempty = empty_size slot_size in
848 let eval_fold2_slist fll sl1 sl2 res1 res2 t =
849 let res = Array.copy res1 in
850 let rec fold l1 l2 fll i aq = match l1,l2,fll with
851 | Cons(s1,_,ll1), Cons(s2, _ ,ll2),fl::fll ->
852 let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in
853 let _ = res.(i) <- merge null rb rb1 rb2 mark t res1.(i) res2.(i)
855 (* let _ = Format.fprintf Format.err_formatter "(%b,%b,%b,%b) Result was %i %i, now %i\n%!"
856 rb rb1 rb2 mark (Obj.magic res1.(i)) (Obj.magic res2.(i)) (Obj.magic res.(i));
859 fold ll1 ll2 fll (i+1) (cons r' aq)
860 | Nil, Nil,[] -> aq,res
863 fold sl1 sl2 fll 0 Nil
865 let rec loop t slist ctx =
866 if Tree.is_nil t then (pempty,Array.make slot_size null)
868 let tag = Tree.tag t in
869 let fl_list,llist,rlist,first,next = get_trans slist tag a t in
870 let sl1,res1 = loop (first t) llist t in
871 let sl2,res2 = if noright then (pempty,Array.make slot_size null)
872 else loop (next t ctx) rlist ctx in
873 eval_fold2_slist fl_list sl1 sl2 res1 res2 t
877 let run_top_down_count a t =
878 let init = cons a.init Nil in
879 let _,res = top_down a (fun _ rb rb1 rb2 mark t res1 res2 ->
880 (vb rb)*( (vb mark) + (vb rb1)*res1 + (vb rb2)*res2))
885 let run_top_down a t =
886 let init = cons a.init Nil in
888 top_down a (fun null rb rb1 rb2 mark t res1 res2 ->
891 (TS.concat (if mark then TS.Sing(t) else null)
892 (if rb1 then res1 else null))
893 (if rb2 then res2 else null)
902 module type ResultSet =
906 val cons : Tree.t -> t -> t
907 val concat : t -> t -> t
908 val iter : (Tree.t -> unit) -> t -> unit
909 val fold : (Tree.t -> 'a -> 'a) -> t -> 'a -> 'a
910 val map : (Tree.t -> Tree.t) -> t -> t
911 val length : t -> int
914 module Integer : ResultSet =
919 let concat x y = x + y
920 let iter _ _ = failwith "iter not implemented"
921 let fold _ _ _ = failwith "fold not implemented"
922 let map _ _ = failwith "map not implemented"
926 module IdSet : ResultSet =
929 | Cons of Tree.t * node
930 | Concat of node*node
932 and t = { node : node;
935 let empty = { node = Nil; length = 0 }
937 let cons e t = { node = Cons(e,t.node); length = t.length+1 }
938 let concat t1 t2 = { node = Concat(t1.node,t2.node); length = t1.length+t2.length }
939 let append e t = { node = Concat(t.node,Cons(e,Nil)); length = t.length+1 }
943 let rec loop acc t = match t with
945 | Cons (e,t) -> loop (f e acc) t
946 | Concat (t1,t2) -> loop (loop acc t1) t2
950 let length l = l.length
954 let rec loop = function
956 | Cons (e,t) -> f e; loop t
957 | Concat(t1,t2) -> loop t1;loop t2
961 let rec loop = function
963 | Cons(e,t) -> Cons(f e, loop t)
964 | Concat(t1,t2) -> Concat(loop t1,loop t2)
966 { l with node = loop l.node }
971 module Run (RS : ResultSet) =
973 let fmt = Format.err_formatter
974 let pr x = Format.fprintf fmt x
979 let cons q f i m l = Cons(q,f,i,m,l)
980 let hash = function Nil -> 0 | Cons(_,_,i,_,_) -> max_int land i
982 let rec loop = function
985 Format.fprintf fmt "%i %s" q (if m then "=>" else "->");
987 Format.fprintf fmt "\n%!";
993 type ptset_list = Nil | Cons of Ptset.t*int*ptset_list
994 let hpl l = match l with
998 let cons s l = Cons (s,(Ptset.hash s) + 65599 * (hpl l), l)
1000 let rec empty_size n =
1002 else cons Ptset.empty (empty_size (n-1))
1004 let fold_pl f l acc =
1005 let rec loop l acc = match l with
1007 | Cons(s,h,pl) -> loop pl (f s h acc)
1013 | Cons(s,h,ll) -> cons (f s) (loop ll)
1018 | Cons(s,h,ll) -> (f s);(loop ll)
1022 let rec loop acc l = match l with
1024 | Cons(s,_,ll) -> loop (cons s acc) ll
1028 let rev_map_pl f l =
1029 let rec loop acc l =
1032 | Cons(s,_,ll) -> loop (cons (f s) acc) ll
1036 let td_trans = Hashtbl.create 4096
1039 let choose_jump tagset qtags1 qtagsn a f_nil f_text f_t1 f_s1 f_tn f_sn f_notext =
1040 let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
1041 let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
1042 (* Format.fprintf Format.err_formatter "Tags below states ";
1043 pr_st Format.err_formatter (Ptset.elements qtags1);
1044 Format.fprintf Format.err_formatter " are { ";
1045 Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tags1;
1046 Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastext1 fin1;
1048 Format.fprintf Format.err_formatter "Tags below states ";
1049 pr_st Format.err_formatter (Ptset.elements qtagsn);
1050 Format.fprintf Format.err_formatter " are { ";
1051 Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tagsn;
1052 Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastextn finn;
1054 if (hastext1||hastextn) then f_text (* jumping to text nodes doesn't work really well *)
1055 else if (Ptset.is_empty tags1) && (Ptset.is_empty tagsn) then f_nil
1056 else if (Ptset.is_empty tagsn) then
1057 if (Ptset.is_singleton tags1) then f_t1 (Ptset.choose tags1) (* TaggedChild/Sibling *)
1058 else f_s1 tags1 (* SelectChild/Sibling *)
1059 else if (Ptset.is_empty tags1) then
1060 if (Ptset.is_singleton tagsn) then f_tn (Ptset.choose tagsn) (* TaggedDesc/Following *)
1061 else f_sn tagsn (* SelectDesc/Following *)
1064 let choose_jump_down a b c d =
1068 (*fun x -> let i,j = Tree.doc_ids x in
1069 let res = Tree.text_below x in
1070 Printf.printf "Calling text_below %s (tag=%s), docids= (%i,%i), res=%s\n"
1071 (Tree.dump_node x) (Tag.to_string (Tree.tag x)) i j (Tree.dump_node res);
1073 (fun _ -> Tree.node_child ) (* !! no tagged_child in Tree.ml *)
1074 (fun _ -> Tree.node_child ) (* !! no select_child in Tree.ml *)
1076 (fun _ -> Tree.node_child ) (* !! no select_desc *)
1079 let choose_jump_next a b c d =
1081 (fun t _ -> Tree.mk_nil t)
1083 (*fun x y -> let i,j = Tree.doc_ids x in
1084 let res = Tree.text_next x y in
1085 Printf.printf "Calling text_next %s (tag=%s) ctx=%s, docids= (%i,%i), res=%s\n"
1086 (Tree.dump_node x) (Tag.to_string (Tree.tag x)) (Tree.dump_node y) i j (Tree.dump_node res);
1089 (fun _ -> Tree.node_sibling_ctx) (* !! no tagged_sibling in Tree.ml *)
1090 (fun _ -> Tree.node_sibling_ctx) (* !! no select_child in Tree.ml *)
1091 (Tree.tagged_foll_below)
1092 (fun _ -> Tree.node_sibling_ctx) (* !! no select_foll *)
1093 (Tree.node_sibling_ctx)
1096 let get_trans slist tag a t =
1098 Hashtbl.find td_trans (tag,hpl slist)
1101 let fl_list,llist,rlist,ca,da,sa,fa =
1103 (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
1104 let fl,ll,rr,ca,da,sa,fa =
1109 (fun (((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc),h_acc) as acc)
1111 if (TagSet.mem tag ts)
1113 let (child,desc,below),(sibl,foll,after) = f.st in
1114 let h_acc = HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)) in
1115 ((Formlist.cons q f h_acc m fl_acc,
1116 Ptset.union ll_acc below,
1117 Ptset.union rl_acc after,
1118 Ptset.union child c_acc,
1119 Ptset.union desc d_acc,
1120 Ptset.union sibl s_acc,
1121 Ptset.union foll f_acc),
1123 else acc ) (acc,0) (
1124 try Hashtbl.find a.phi q
1126 Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
1130 ) set (Formlist.nil,Ptset.empty,Ptset.empty,ca,da,sa,fa)
1131 in fl::fll_acc, cons ll lllacc, cons rr rllacc,ca,da,sa,fa)
1132 slist ([],Nil,Nil,Ptset.empty,Ptset.empty,Ptset.empty,Ptset.empty)
1134 (* Logic to chose the first and next function *)
1135 let tags_below,tags_after = Tree.tags t tag in
1136 let first = choose_jump_down tags_below ca da a
1137 and next = choose_jump_next tags_after sa fa a in
1138 let v = (fl_list,llist,rlist,first,next) in
1139 Hashtbl.add td_trans (tag, hpl slist) v; v
1141 let merge rb rb1 rb2 mark t res1 res2 =
1144 let res1 = if rb1 then res1 else RS.empty
1145 and res2 = if rb2 then res2 else RS.empty
1147 if mark then RS.cons t (RS.concat res1 res2)
1148 else RS.concat res1 res2
1151 let top_down ?(noright=false) a t slist ctx slot_size =
1152 let pempty = empty_size slot_size in
1153 let eval_fold2_slist fll sl1 sl2 res1 res2 t =
1154 let res = Array.copy res1 in
1155 let rec fold l1 l2 fll i aq = match l1,l2,fll with
1156 | Cons(s1,_,ll1), Cons(s2, _ ,ll2),fl::fll ->
1157 let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in
1158 (* let _ = pr "Evaluation context : "; pr_st fmt (Ptset.elements s1);
1159 pr_st fmt (Ptset.elements s2);
1160 pr "Formlist (%i) : " (Formlist.hash fl);
1162 pr "Results : "; pr_st fmt (Ptset.elements r');
1163 pr ", %b %b %b %b\n%!" rb rb1 rb2 mark
1165 let _ = res.(i) <- merge rb rb1 rb2 mark t res1.(i) res2.(i)
1167 fold ll1 ll2 fll (i+1) (cons r' aq)
1168 | Nil, Nil,[] -> aq,res
1171 fold sl1 sl2 fll 0 Nil
1173 let null_result() = (pempty,Array.make slot_size RS.empty) in
1174 let rec loop t slist ctx =
1176 if Tree.is_nil t then null_result()
1178 let tag = Tree.tag t in
1179 let fl_list,llist,rlist,first,next = get_trans slist tag a t in
1180 (* let _ = pr "For tag %s,node %s, returning formulae list: \n%!"
1181 (Tag.to_string tag) (Tree.dump_node t);
1182 List.iter (fun f -> Formlist.pr fmt f;pr "\n%!") fl_list
1184 let sl1,res1 = loop (first t) llist t in
1185 let sl2,res2 = loop (next t ctx) rlist ctx in
1186 eval_fold2_slist fl_list sl1 sl2 res1 res2 t
1188 (* let _ = pr "Inside topdown call: tree was %s, tag = %s" (Tree.dump_node t) (if Tree.is_nil t then "###"
1189 else Tag.to_string (Tree.tag t));
1190 iter_pl (fun s -> (pr_st fmt (Ptset.elements s))) a;
1191 Array.iter (fun i -> pr "%i" (RS.length i)) b;
1192 pr "\n%!"; in*) (a,b)
1195 let loop_no_right t slist ctx =
1196 if Tree.is_nil t then null_result()
1198 let tag = Tree.tag t in
1199 let fl_list,llist,rlist,first,next = get_trans slist tag a t in
1200 let sl1,res1 = loop (first t) llist t in
1201 let sl2,res2 = null_result() in
1202 eval_fold2_slist fl_list sl1 sl2 res1 res2 t
1204 (if noright then loop_no_right else loop) t slist ctx
1206 let run_top_down a t =
1207 let init = cons a.init Nil in
1208 let _,res = top_down a t init t 1
1212 module Configuration =
1214 module Ptss = Set.Make(Ptset)
1215 module IMap = Map.Make(Ptset)
1216 type t = { hash : int;
1218 results : RS.t IMap.t }
1219 let empty = { hash = 0;
1221 results = IMap.empty;
1223 let is_empty c = Ptss.is_empty c.sets
1225 if Ptss.mem s c.sets then
1226 { c with results = IMap.add s (RS.concat r (IMap.find s c.results)) c.results}
1228 { hash = HASHINT2(c.hash,Ptset.hash s);
1229 sets = Ptss.add s c.sets;
1230 results = IMap.add s r c.results
1233 let pr fmt c = Format.fprintf fmt "{";
1234 Ptss.iter (fun s -> pr_st fmt (Ptset.elements s);
1235 Format.fprintf fmt " ") c.sets;
1236 Format.fprintf fmt "}\n%!";
1237 IMap.iter (fun k d ->
1238 pr_st fmt (Ptset.elements k);
1239 Format.fprintf fmt "-> %i\n" (RS.length d)) c.results;
1240 Format.fprintf fmt "\n%!"
1243 let acc1 = IMap.fold (fun s r acc ->
1246 RS.concat r (IMap.find s acc)
1248 | Not_found -> r) acc) c1.results IMap.empty
1251 IMap.fold (fun s r acc ->
1254 RS.concat r (IMap.find s acc)
1256 | Not_found -> r) acc) c2.results acc1
1260 (fun s (ah,ass) -> (HASHINT2(ah,Ptset.hash s),
1262 (Ptss.union c1.sets c2.sets) (0,Ptss.empty)
1270 let h_fold = Hashtbl.create 511
1272 let fold_f_conf t slist fl_list conf dir=
1273 let rec loop sl fl acc =
1276 | Cons(s,hs,sll), formlist::fll ->
1277 let r',rb,rb1,rb2,mark =
1279 Hashtbl.find h_fold (hs,Formlist.hash formlist,dir)
1281 Not_found -> let res =
1282 if dir then eval_formlist ~memo:false s Ptset.empty formlist
1283 else eval_formlist ~memo:false Ptset.empty s formlist
1284 in (Hashtbl.add h_fold (hs,Formlist.hash formlist,dir) res;res)
1286 let _ = pr "Evaluating on set (%s) with tree %s=%s"
1287 (if dir then "left" else "right")
1288 (Tag.to_string (Tree.tag t))
1289 (Tree.dump_node t) ;
1290 pr_st fmt (Ptset.elements s);
1291 pr ", formualae (with hash %i): \n" (Formlist.hash formlist);
1292 Formlist.pr fmt formlist;
1294 pr_st fmt (Ptset.elements r');
1295 pr " %b %b %b %b \n%!" rb rb1 rb2 mark ;
1297 if rb && ((dir&&rb1)|| ((not dir) && rb2))
1301 try Configuration.IMap.find s conf.Configuration.results
1302 with Not_found -> RS.empty
1304 Configuration.add acc r' (if mark then RS.cons t old_r else old_r)
1307 else loop sll fll acc
1310 loop slist fl_list Configuration.empty
1312 let h_trans = Hashtbl.create 4096
1314 let get_up_trans slist ptag a tree =
1315 let key = (HASHINT2(hpl slist,Tag.hash ptag)) in
1317 Hashtbl.find h_trans key
1321 Hashtbl.fold (fun q l acc ->
1322 List.fold_left (fun (fl_acc,h_acc) (ts,(m,f,_)) ->
1323 if TagSet.mem ptag ts
1325 let h_acc = HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)) in
1326 (Formlist.cons q f h_acc m fl_acc,
1328 else (fl_acc,h_acc))
1330 a.phi (Formlist.nil,0)
1332 let res = fold_pl (fun _ _ acc -> f_list::acc) slist []
1334 (Hashtbl.add h_trans key res;res)
1337 let h_tdconf = Hashtbl.create 511
1338 let rec bottom_up a tree conf next jump_fun root dotd init accu =
1339 if (not dotd) && (Configuration.is_empty conf ) then
1340 (* let _ = pr "Returning early from %s, with accu %i, next is %s\n%!"
1341 (Tree.dump_node tree) (Obj.magic accu) (Tree.dump_node next)
1346 pr "Going bottom up for tree with tag %s configuration is"
1347 (if Tree.is_nil tree then "###" else Tag.to_string (Tree.tag tree));
1348 Configuration.pr fmt conf
1350 let below_right = Tree.is_below_right tree next in
1351 (* let _ = Format.fprintf Format.err_formatter "below_right %s %s = %b\n%!"
1352 (Tree.dump_node tree) (Tree.dump_node next) below_right
1354 let accu,rightconf,next_of_next =
1355 if below_right then (* jump to the next *)
1356 (* let _ = pr "Jumping to %s tag %s\n%!" (Tree.dump_node next) (Tag.to_string (Tree.tag next)) in *)
1357 bottom_up a next conf (jump_fun next) jump_fun (Tree.next_sibling tree) true init accu
1358 else accu,Configuration.empty,next
1360 (* let _ = if below_right then pr "Returning from jump to next = %s\n" (Tree.dump_node next)in *)
1363 if below_right then (* only recurse on the left subtree *)
1364 (* let _ = pr "Topdown on left subtree\n%!" in *)
1365 prepare_topdown a tree true
1367 (* let _ = pr "Topdown on whole tree\n%!" in *)
1368 prepare_topdown a tree false
1372 (Configuration.merge rightconf sub, next_of_next)
1374 if Tree.equal tree root then
1375 (* let _ = pr "Stopping at root, configuration after topdown is:" ;
1376 Configuration.pr fmt conf;
1378 in *) accu,conf,next
1380 let parent = Tree.binary_parent tree in
1381 let ptag = Tree.tag parent in
1382 let dir = Tree.is_left tree in
1383 let slist = Configuration.Ptss.fold (fun e a -> cons e a) conf.Configuration.sets Nil in
1384 let fl_list = get_up_trans slist ptag a parent in
1385 let slist = rev_pl (slist) in
1386 (* let _ = pr "Current conf is : %s " (Tree.dump_node tree);
1387 Configuration.pr fmt conf;
1390 let newconf = fold_f_conf parent slist fl_list conf dir in
1391 (* let _ = pr "New conf before pruning is (dir=%b):" dir;
1392 Configuration.pr fmt newconf ;
1393 pr "accu is %i\n" (RS.length accu);
1395 let accu,newconf = Configuration.IMap.fold (fun s res (ar,nc) ->
1396 if Ptset.intersect s init then
1397 ( RS.concat res ar ,nc)
1398 else (ar,Configuration.add nc s res))
1399 (newconf.Configuration.results) (accu,Configuration.empty)
1401 (* let _ = pr "New conf after pruning is (dir=%b):" dir;
1402 Configuration.pr fmt newconf ;
1403 pr "accu is %i\n" (RS.length accu);
1405 bottom_up a parent newconf next jump_fun root false init accu
1407 and prepare_topdown a t noright =
1408 let tag = Tree.tag t in
1409 (* pr "Going top down on tree with tag %s = %s "
1410 (if Tree.is_nil t then "###" else (Tag.to_string(Tree.tag t))) (Tree.dump_node t); *)
1413 Hashtbl.find h_tdconf tag
1416 let res = Hashtbl.fold (fun q l acc ->
1417 if List.exists (fun (ts,_) -> TagSet.mem tag ts) l
1418 then Ptset.add q acc
1419 else acc) a.phi Ptset.empty
1420 in Hashtbl.add h_tdconf tag res;res
1422 (* let _ = pr ", among ";
1423 pr_st fmt (Ptset.elements r);
1426 let r = cons r Nil in
1427 let set,res = top_down (~noright:noright) a t r t 1 in
1428 let set = match set with
1432 (* pr "Result of topdown run is %!";
1433 pr_st fmt (Ptset.elements set);
1434 pr ", number is %i\n%!" (RS.length res.(0)); *)
1435 Configuration.add Configuration.empty set res.(0)
1439 let run_bottom_up a t k =
1440 let trlist = Hashtbl.find a.phi (Ptset.choose a.init)
1442 let init = List.fold_left
1443 (fun acc (_,(_,f,_)) ->
1444 Ptset.union acc (let (_,_,l) = fst (f.st) in l))
1447 let tree1,jump_fun =
1450 (*Tree.tagged_lowest t tag, fun tree -> Tree.tagged_next tree tag*)
1451 (Tree.tagged_desc tag t, fun tree -> Tree.tagged_foll_below tag tree t)
1452 | `CONTAINS(_) -> (Tree.text_below t,fun tree -> Tree.text_next tree t)
1455 let tree2 = jump_fun tree1 in
1456 let rec loop tree next acc =
1457 (* let _ = pr "\n_________________________\nNew iteration\n" in
1458 let _ = pr "Jumping to %s\n%!" (Tree.dump_node tree) in *)
1459 let acc,conf,next_of_next = bottom_up a tree
1460 Configuration.empty next jump_fun (Tree.root tree) true init acc
1462 (* let _ = pr "End of first iteration, conf is:\n%!";
1463 Configuration.pr fmt conf
1465 let acc = Configuration.IMap.fold
1466 ( fun s res acc -> if Ptset.intersect init s
1467 then RS.concat res acc else acc) conf.Configuration.results acc
1469 if Tree.is_nil next_of_next (*|| Tree.equal next next_of_next *)then
1471 else loop next_of_next (jump_fun next_of_next) acc
1473 loop tree1 tree2 RS.empty
1478 let top_down_count a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down a t)
1479 let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t)
1480 let bottom_up_count a t k = let module RI = Run(Integer) in Integer.length (RI.run_bottom_up a t k)