ata.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3
   4 type jump_kind = [ `TAG of Tag.t | `CONTAINS of string | `NOTHING ]
   5 let cpt_trans = ref 0
   6 let miss_trans = ref 0
   7 let cpt_eval = ref 0
   8 let miss_eval = ref 0
   9
  10 let gen_id =
  11   let id = ref (-1) in
  12     fun () -> incr id;!id
  13
  14 let h_union = Hashtbl.create 4097
  15
  16 let pt_cup s1 s2 =
  17   (* special case, since this is a union we want hash(s1,s2) = hash(s2,s1) *)
  18   let x = Ptset.hash s1
  19   and y = Ptset.hash s2 in
  20   let h = if x < y then HASHINT2(x,y) else HASHINT2(y,x) in
  21     try
  22       Hashtbl.find h_union h
  23     with
  24       | Not_found -> let s = Ptset.union s1 s2
  25         in
  26           Hashtbl.add h_union h s;s
  27
  28 module State = struct
  29
  30   type t = int
  31   let mk = gen_id
  32
  33 end
  34 let mk_state = State.mk
  35
  36 type state = State.t
  37
  38
  39
  40 type formula_expr =
  41   | False | True
  42   | Or of formula * formula
  43   | And of formula * formula
  44   | Atom of ([ `Left | `Right  | `LLeft | `RRight  ]*bool*state)
  45 and formula = { fid: int;
  46                 fkey : int;
  47                 pos : formula_expr;
  48                 neg : formula;
  49                 st : (Ptset.t*Ptset.t*Ptset.t)*(Ptset.t*Ptset.t*Ptset.t);
  50                 size: int;
  51               }
  52
  53 external hash_const_variant : [> ] -> int = "%identity"
  54 external vb : bool -> int = "%identity"
  55
  56 let hash_node_form t = match t with
  57   | False -> 0
  58   | True -> 1
  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)
  62
  63
  64
  65 module FormNode =
  66 struct
  67   type t = formula
  68
  69   let hash t = t.fkey
  70   let equal f1 f2 =
  71     if f1.fid == f2.fid || f1.fkey == f2.fkey || f1.pos == f2.pos then true
  72     else
  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
  76       | Or(g1,g2),Or(h1,h2)
  77       | And(g1,g2),And(h1,h2)  -> g1.fid == h1.fid && g2.fid == h2.fid
  78       | _ -> false
  79
  80 end
  81 module WH = Weak.Make(FormNode)
  82
  83 let f_pool = WH.create 107
  84
  85 let empty_triple = Ptset.empty,Ptset.empty,Ptset.empty
  86 let empty_hex = empty_triple,empty_triple
  87
  88 let true_,false_ =
  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; }
  91   in
  92     WH.add f_pool f;
  93     WH.add f_pool t;
  94     t,f
  95
  96 let is_true f = f.fid == 1
  97 let is_false f = f.fid == 0
  98
  99
 100 let cons pos neg s1 s2 size1 size2 =
 101   let rec pnode =
 102     { fid = gen_id ();
 103       fkey = hash_node_form pos;
 104       pos = pos;
 105       neg = nnode;
 106       st = s1;
 107       size = size1;}
 108   and nnode = {
 109     fid = gen_id ();
 110     pos = neg;
 111     fkey = hash_node_form neg;
 112     neg = pnode;
 113     st = s2;
 114     size = size2;
 115   }
 116   in
 117     (WH.merge f_pool pnode),(WH.merge f_pool nnode)
 118
 119 let atom_  d p s =
 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)
 127
 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)
 131
 132 let merge_states f1 f2 =
 133   let sp =
 134     union_hex f1.st f2.st
 135   and sn =
 136     union_hex f1.neg.st f2.neg.st
 137   in
 138     sp,sn
 139
 140 let full_or_ f1 f2 =
 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 )
 146
 147 let or_ f1 f2 =
 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
 153   else
 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)
 158
 159
 160
 161 let and_ f1 f2 =
 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
 167   else
 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)
 172
 173
 174 let not_ f = f.neg
 175
 176 let k_hash (s,t) = HASHINT2(Ptset.hash s,Tag.hash t)
 177
 178 module HTagSetKey =
 179 struct
 180   type t = Ptset.t*Tag.t
 181   let equal (s1,s2) (t1,t2) =  (s2 == t2) &&  Ptset.equal s1 t1
 182   let hash = k_hash
 183 end
 184
 185 module HTagSet = Hashtbl.Make(HTagSetKey)
 186
 187 type skiplist = Nothing | All
 188                 | Zero of skiplist
 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
 192
 193
 194 type formlist = Nil | Cons of state*formula*int*bool*formlist
 195
 196 type 'a t = {
 197     id : int;
 198     mutable states : Ptset.t;
 199     init : Ptset.t;
 200     mutable final : Ptset.t;
 201     universal : 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;
 206 }
 207
 208   module Pair (X : Set.OrderedType) (Y : Set.OrderedType) =
 209   struct
 210     type t = X.t*Y.t
 211     let compare (x1,y1) (x2,y2) =
 212       let r = X.compare x1 x2 in
 213         if r == 0 then Y.compare y1 y2
 214         else r
 215   end
 216
 217   module PL = Set.Make (Pair (Ptset) (Ptset))
 218
 219
 220   let pr_st ppf l = Format.fprintf ppf "{";
 221     begin
 222       match l with
 223         |       [] -> ()
 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
 227     end;
 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 "⊥"
 232     | And(f1,f2) ->
 233         Format.fprintf ppf "(";
 234         (pr_frm ppf f1);
 235         Format.fprintf ppf ") ∧ (";
 236         (pr_frm ppf f2);
 237         Format.fprintf ppf ")"
 238     | Or(f1,f2) ->
 239         (pr_frm ppf f1);
 240         Format.fprintf ppf " ∨ ";
 241         (pr_frm ppf f2);
 242     | Atom(dir,b,s) -> Format.fprintf ppf "%s%s[%i]"
 243         (if b then "" else "¬")
 244         (match  dir with
 245            | `Left ->  "↓₁"
 246            | `Right -> "↓₂"
 247            | `LLeft ->  "⇓₁"
 248            | `RRight -> "⇓₂") s
 249
 250   let dump ppf a =
 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,_)) ->
 261
 262                     let s =
 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 "*\\{"
 268                           )^ "}"
 269                     in
 270                       Format.fprintf ppf "(%s,%i) %s " s q (if b then "=>" else "->");
 271                       pr_frm ppf f;
 272                       Format.fprintf ppf "\n")l;
 273
 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))
 283                         flist
 284                     in
 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;
 289                                    pr_frm ppf f)           flist;
 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;
 299       ) a.sigma;    *)
 300     Format.fprintf ppf "=======================================\n%!"
 301
 302   module Transitions = struct
 303     type t = state*TagSet.t*bool*formula*bool
 304     let ( ?< ) x = x
 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
 311
 312
 313   end
 314   type transition = Transitions.t
 315
 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) *)
 318
 319
 320   module HFEval = Hashtbl.Make(
 321     struct
 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)
 325       let hash (a,b,c) =
 326         HASHINT3(a,Ptset.hash b,Ptset.hash c)
 327     end)
 328
 329
 330
 331
 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
 338         | _ ->
 339             try
 340               HFEval.find hfeval (f.fid,s1,s2)
 341             with
 342               | Not_found -> let r =
 343                   match f.pos with
 344                     | Atom((`Left|`LLeft),b,q) ->
 345                         if b == (Ptset.mem q s1)
 346                         then (true,true,false)
 347                         else false,false,false
 348                     | Atom(_,b,q) ->
 349                         if b == (Ptset.mem q s2)
 350                         then (true,false,true)
 351                         else false,false,false
 352                     | Or(f1,f2) ->
 353                         let b1,rl1,rr1 = eval f1
 354                         in
 355                           if b1 && rl1 && rr1 then (true,true,true)
 356                           else
 357                             let b2,rl2,rr2 = eval f2
 358                             in
 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)
 362                     | And(f1,f2) ->
 363                         let b1,rl1,rr1 = eval f1 in
 364                           if b1 && rl1 && rr1 then (true,true,true)
 365                           else if b1
 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)
 370                     | _ -> assert false
 371                 in
 372                   HFEval.add hfeval (f.fid,s1,s2) r;
 373                   r
 374       in eval f
 375
 376
 377     let form_list_fold_left f acc fl =
 378       let rec loop acc fl =
 379         match fl with
 380           | Nil -> acc
 381           | Cons(s,frm,h,m,fll) -> loop (f acc s frm h m) fll
 382       in
 383         loop acc fl
 384
 385     let h_formlist = Hashtbl.create 4096
 386     let rec eval_formlist ?(memo=true) s1 s2 fl =
 387       match fl with
 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)
 391           in
 392
 393             try
 394               if memo then Hashtbl.find h_formlist k
 395               else (raise Not_found)
 396             with
 397                 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
 402             in(*
 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)
 411
 412
 413
 414     let tags_of_state a q = Hashtbl.fold
 415       (fun p l acc ->
 416          if p == q then
 417            List.fold_left
 418              (fun acc (ts,(_,_,aux)) ->
 419                 if aux then acc else
 420                   TagSet.cup ts acc) acc l
 421          else acc) a.phi TagSet.empty
 422
 423
 424
 425     let tags a qs =
 426       let ts = Ptset.fold (fun q acc -> TagSet.cup acc (tags_of_state a q)) qs TagSet.empty
 427       in
 428         if TagSet.is_finite ts
 429         then `Positive(TagSet.positive ts)
 430         else `Negative(TagSet.negative ts)
 431
 432     let inter_text a b =
 433       match b with
 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)
 436
 437     let mk_nil_ctx x _ = Tree.mk_nil x
 438     let next_sibling_ctx x _ = Tree.next_sibling x
 439     let r_ignore _ x = x
 440
 441     let set_get_tag r t = r := (fun _ -> t)
 442
 443     module type ResultSet =
 444     sig
 445       type t
 446       val empty : t
 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
 453     end
 454
 455     module Integer : ResultSet =
 456     struct
 457       type t = int
 458       let empty = 0
 459       let cons _ x = x+1
 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"
 464       let length x = x
 465     end
 466
 467     module IdSet : ResultSet =
 468     struct
 469       type node = Nil
 470                   | Cons of Tree.t * node
 471                   | Concat of node*node
 472
 473       and t = { node : node;
 474                 length :  int }
 475
 476       let empty = { node = Nil; length = 0 }
 477
 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 }
 481
 482       let fold f l acc =
 483         let rec loop acc t = match t with
 484           | Nil -> acc
 485           | Cons (e,t) -> loop (f e acc) t
 486           | Concat (t1,t2) -> loop (loop acc t1) t2
 487         in
 488           loop acc l.node
 489
 490       let length l = l.length
 491
 492
 493       let iter f l =
 494         let rec loop = function
 495           | Nil -> ()
 496           | Cons (e,t) -> f e; loop t
 497           | Concat(t1,t2) -> loop t1;loop t2
 498         in loop l.node
 499
 500       let map f l =
 501         let rec loop = function
 502           | Nil -> Nil
 503           | Cons(e,t) -> Cons(f e, loop t)
 504           | Concat(t1,t2) -> Concat(loop t1,loop t2)
 505         in
 506           { l with node = loop l.node }
 507
 508
 509     end
 510
 511     module Run (RS : ResultSet) =
 512     struct
 513       let fmt = Format.err_formatter
 514       let pr x = Format.fprintf fmt x
 515       module Formlist =
 516       struct
 517         type t = formlist
 518         let nil : t = Nil
 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
 521         let pr fmt l =
 522           let rec loop = function
 523             | Nil -> ()
 524             | Cons(q,f,_,m,l) ->
 525                 Format.fprintf fmt "%i %s" q (if m then "=>" else "->");
 526                 pr_frm fmt f;
 527                 Format.fprintf fmt "\n%!";
 528                 loop l
 529           in
 530             loop l
 531       end
 532
 533       type ptset_list = Nil | Cons of Ptset.t*int*ptset_list
 534       let hpl l = match l with
 535         | Nil -> 0
 536         | Cons (_,i,_) -> i
 537
 538       let cons s l = Cons (s,(Ptset.hash s) + 65599 * (hpl l), l)
 539
 540       let rec empty_size n =
 541         if n == 0 then Nil
 542         else cons Ptset.empty (empty_size (n-1))
 543
 544       let fold_pl f l acc =
 545         let rec loop l acc = match l with
 546             Nil -> acc
 547           | Cons(s,h,pl) -> loop pl (f s h acc)
 548         in
 549           loop l acc
 550       let map_pl f l =
 551         let rec loop =
 552           function Nil -> Nil
 553             | Cons(s,h,ll) -> cons (f s) (loop ll)
 554         in loop l
 555       let iter_pl f l =
 556         let rec loop =
 557           function Nil -> ()
 558             | Cons(s,h,ll) ->  (f s);(loop ll)
 559         in loop l
 560
 561       let rev_pl l =
 562         let rec loop acc l = match l with
 563           | Nil -> acc
 564           | Cons(s,_,ll) -> loop (cons s acc) ll
 565         in
 566           loop Nil l
 567
 568       let rev_map_pl f l  =
 569         let rec loop acc l =
 570           match l with
 571             | Nil -> acc
 572             | Cons(s,_,ll) -> loop (cons (f s) acc) ll
 573         in
 574           loop Nil l
 575
 576       let td_trans = Hashtbl.create 4096
 577
 578
 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;
 587
 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;
 593 *)
 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 *)
 602           else f_notext
 603
 604       let choose_jump_down a b c d =
 605         choose_jump a b c d
 606           (Tree.mk_nil)
 607           (Tree.text_below)
 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);
 612              res*)
 613           (fun _ -> Tree.node_child ) (* !! no tagged_child in Tree.ml *)
 614           (fun _ -> Tree.node_child ) (* !! no select_child in Tree.ml *)
 615           (Tree.tagged_desc)
 616           (fun _ -> Tree.node_child ) (* !! no select_desc *)
 617           (Tree.node_child)
 618
 619       let choose_jump_next a b c d =
 620         choose_jump a b c d
 621           (fun t _ -> Tree.mk_nil t)
 622           (Tree.text_next)
 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);
 627              res*)
 628
 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)
 634
 635
 636       let get_trans slist tag a t =
 637         try
 638           Hashtbl.find td_trans (tag,hpl slist)
 639         with
 640           | Not_found ->
 641               let fl_list,llist,rlist,ca,da,sa,fa =
 642                 fold_pl
 643                   (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
 644                      let fl,ll,rr,ca,da,sa,fa =
 645                        Ptset.fold
 646                          (fun q acc ->
 647                             fst (
 648                               List.fold_left
 649                                 (fun (((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc),h_acc) as acc)
 650                                    (ts,(m,f,_))  ->
 651                                      if (TagSet.mem tag ts)
 652                                      then
 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),
 662                                           h_acc)
 663                                    else acc ) (acc,0) (
 664                                   try Hashtbl.find a.phi q
 665                                   with
 666                                       Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
 667                                         q;[]
 668                                 ))
 669
 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)
 673               in
 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
 680
 681       let merge rb rb1 rb2 mark t res1 res2 =
 682         if rb
 683         then
 684           let res1 = if rb1 then res1 else RS.empty
 685           and res2 = if rb2 then res2 else RS.empty
 686           in
 687             if mark then RS.cons t (RS.concat res1 res2)
 688             else RS.concat res1 res2
 689         else RS.empty
 690
 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);
 701                   Formlist.pr fmt fl;
 702                   pr "Results : "; pr_st fmt (Ptset.elements r');
 703                   pr ", %b %b %b %b\n%!" rb rb1 rb2 mark
 704                 in *)
 705                 let _ = res.(i) <- merge rb rb1 rb2 mark t res1.(i) res2.(i)
 706                 in
 707                   fold ll1 ll2 fll (i+1) (cons r' aq)
 708             | Nil, Nil,[] -> aq,res
 709             | _ -> assert false
 710           in
 711             fold sl1 sl2 fll 0 Nil
 712         in
 713         let null_result() = (pempty,Array.make slot_size RS.empty) in
 714         let rec loop t slist ctx =
 715           let (a,b) =
 716           if Tree.is_nil t then null_result()
 717           else
 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
 723             in*)
 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
 727           in
 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)
 733
 734         in
 735         let loop_no_right t slist ctx =
 736           if Tree.is_nil t then null_result()
 737           else
 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
 743         in
 744           (if noright then loop_no_right else loop) t slist ctx
 745
 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
 749           in res.(0)
 750         ;;
 751
 752         module Configuration =
 753         struct
 754           module Ptss = Set.Make(Ptset)
 755           module IMap = Map.Make(Ptset)
 756           type t = { hash : int;
 757                         sets : Ptss.t;
 758                         results : RS.t IMap.t }
 759           let empty = { hash = 0;
 760                         sets = Ptss.empty;
 761                         results = IMap.empty;
 762                       }
 763           let is_empty c = Ptss.is_empty c.sets
 764           let add c s r =
 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}
 767             else
 768               { hash = HASHINT2(c.hash,Ptset.hash s);
 769                 sets = Ptss.add s c.sets;
 770                 results = IMap.add s r c.results
 771               }
 772
 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%!"
 781
 782           let merge c1 c2  =
 783             let acc1 = IMap.fold (fun s r acc ->
 784                                     IMap.add s
 785                                       (try
 786                                          RS.concat r (IMap.find s acc)
 787                                        with
 788                                          | Not_found -> r) acc) c1.results IMap.empty
 789             in
 790             let imap =
 791               IMap.fold (fun s r acc ->
 792                            IMap.add s
 793                              (try
 794                                 RS.concat r (IMap.find s acc)
 795                               with
 796                                 | Not_found -> r) acc)  c2.results acc1
 797             in
 798             let h,s =
 799               Ptss.fold
 800                 (fun s (ah,ass) -> (HASHINT2(ah,Ptset.hash s),
 801                                     Ptss.add s ass))
 802                 (Ptss.union c1.sets c2.sets) (0,Ptss.empty)
 803             in
 804               { hash = h;
 805                 sets =s;
 806                 results = imap }
 807
 808         end
 809
 810         let h_fold = Hashtbl.create 511
 811
 812         let fold_f_conf  t slist fl_list conf dir=
 813           let rec loop sl fl acc =
 814             match sl,fl with
 815               |Nil,[] -> acc
 816               | Cons(s,hs,sll), formlist::fll ->
 817                   let r',rb,rb1,rb2,mark =
 818                     try
 819                       Hashtbl.find h_fold (hs,Formlist.hash formlist,dir)
 820                     with
 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)
 825                   in(*
 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))
 829                     (Tree.dump_node t) ;
 830                     pr_st fmt (Ptset.elements s);
 831                     pr ", formualae (with hash %i): \n" (Formlist.hash formlist);
 832                     Formlist.pr fmt formlist;
 833                     pr "result is ";
 834                     pr_st fmt (Ptset.elements r');
 835                     pr " %b %b %b %b \n%!" rb rb1 rb2 mark ;
 836                   in *)
 837                     if rb && ((dir&&rb1)|| ((not dir) && rb2))
 838                     then
 839                       let acc =
 840                         let old_r =
 841                           try Configuration.IMap.find s conf.Configuration.results
 842                           with Not_found -> RS.empty
 843                         in
 844                           Configuration.add acc r' (if mark then RS.cons t old_r else old_r)
 845                       in
 846                         loop sll fll acc
 847                     else loop sll fll acc
 848               | _ -> assert false
 849           in
 850             loop slist fl_list Configuration.empty
 851
 852         let h_trans = Hashtbl.create 4096
 853
 854         let get_up_trans slist ptag a tree =
 855           let key = (HASHINT2(hpl slist,Tag.hash ptag)) in
 856             try
 857           Hashtbl.find h_trans key
 858           with
 859           | Not_found ->
 860           let f_list,_ =
 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
 864                                               then
 865                                                 let h_acc = HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)) in
 866                                                   (Formlist.cons q f h_acc m fl_acc,
 867                                                    h_acc)
 868                                               else (fl_acc,h_acc))
 869                               acc l)
 870               a.phi (Formlist.nil,0)
 871           in
 872           let res = fold_pl (fun _ _ acc -> f_list::acc) slist []
 873           in
 874             (Hashtbl.add h_trans key res;res)
 875
 876
 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)
 882                     in *)
 883             accu,conf,next
 884           else
 885 (*          let _ =
 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
 889             in *)
 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
 893                           in *)
 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
 899           in
 900 (*        let _ = if below_right then pr "Returning from jump to next = %s\n" (Tree.dump_node next)in   *)
 901           let sub =
 902             if dotd then
 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
 906               else
 907 (*              let _ = pr "Topdown on whole tree\n%!" in *)
 908                 prepare_topdown a tree false
 909             else conf
 910           in
 911           let conf,next =
 912             (Configuration.merge rightconf sub, next_of_next)
 913           in
 914             if Tree.equal tree root then
 915 (*              let _ = pr "Stopping at root, configuration after topdown is:" ;
 916                 Configuration.pr fmt conf;
 917                 pr "\n%!"
 918               in *)  accu,conf,next
 919             else
 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;
 928             pr "\n"
 929           in *)
 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);
 934           in        *)
 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)
 940           in
 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);
 944           in        *)
 945             bottom_up a parent newconf next jump_fun root false init accu
 946
 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); *)
 951           let r =
 952             try
 953               Hashtbl.find h_tdconf tag
 954             with
 955               | Not_found ->
 956                   let res = Hashtbl.fold (fun q l acc ->
 957                                             if List.exists (fun (ts,_) -> TagSet.mem tag ts) l
 958                                             then Ptset.add q acc
 959                                             else acc) a.phi Ptset.empty
 960                   in Hashtbl.add h_tdconf tag res;res
 961           in
 962 (*        let _ = pr ", among ";
 963             pr_st fmt (Ptset.elements r);
 964             pr "\n%!";
 965           in *)
 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
 969             | Cons(x,_,Nil) ->x
 970             | _ -> assert false
 971           in
 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)
 976
 977
 978
 979         let run_bottom_up a t k =
 980           let trlist = Hashtbl.find a.phi (Ptset.choose a.init)
 981           in
 982           let init = List.fold_left
 983             (fun acc (_,(_,f,_)) ->
 984                Ptset.union acc (let (_,_,l) = fst (f.st) in l))
 985             Ptset.empty trlist
 986           in
 987           let tree1,jump_fun =
 988             match k with
 989               | `TAG (tag) ->
 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)
 993               | _ -> assert false
 994           in
 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
1001             in
1002               (*            let _ = pr "End of first iteration, conf is:\n%!";
1003                             Configuration.pr fmt conf
1004                             in *)
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
1008             in
1009               if Tree.is_nil next_of_next  (*|| Tree.equal next next_of_next *)then
1010                 acc
1011               else loop next_of_next (jump_fun next_of_next) acc
1012           in
1013           loop tree1 tree2 RS.empty
1014
1015
1016     end
1017
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)
1021
1022