tree.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7 INCLUDE "utils.ml"
   8
   9 type tree
  10 type 'a node = int
  11 type node_kind = [`Text | `Tree ]
  12
  13 let compare_node : 'a node -> 'a node -> int = (-)
  14 let equal_node : 'a node -> 'a node -> bool = (==)
  15
  16 (* abstract type, values are pointers to a XMLTree C++ object *)
  17
  18 external int_of_node : 'a node -> int = "%identity"
  19
  20 external parse_xml_uri : string -> int -> bool -> bool -> tree = "caml_call_shredder_uri"
  21 external parse_xml_string :  string -> int -> bool -> bool -> tree = "caml_call_shredder_string"
  22
  23 external save_tree : tree -> string -> unit = "caml_xml_tree_save"
  24 external load_tree : string ->  int -> tree = "caml_xml_tree_load"
  25
  26 external nullt : unit -> 'a node = "caml_xml_tree_nullt"
  27
  28 let nil : 'a node = Obj.magic (-1)
  29
  30 external text_get_tc_text : tree -> [`Text] node -> string = "caml_text_collection_get_text"
  31
  32 external text_is_empty : tree -> [`Text ] node -> bool = "caml_text_collection_empty_text"
  33
  34 let text_is_empty t n =
  35   (equal_node nil n) || text_is_empty t n
  36
  37
  38
  39 external text_is_contains : tree -> string -> bool = "caml_text_collection_is_contains"
  40 external text_count_contains : tree -> string -> int = "caml_text_collection_count_contains"
  41 external text_count : tree -> string -> int = "caml_text_collection_count"
  42 external text_contains : tree -> string -> [`Text ] node array = "caml_text_collection_contains"
  43 external text_unsorted_contains : tree -> string -> unit = "caml_text_collection_unsorted_contains"
  44 external get_cached_text : tree -> [`Text] node -> string = "caml_text_collection_get_cached_text"
  45 let get_cached_text t x =
  46   if x == -1 then ""
  47   else get_cached_text t x
  48
  49 external tree_serialize : tree -> string -> unit = "caml_xml_tree_serialize"
  50
  51 external tree_unserialize : string -> tree = "caml_xml_tree_unserialize"
  52
  53 external tree_root : tree -> [`Tree] node = "caml_xml_tree_root"
  54
  55 let tree_is_nil x = equal_node x nil
  56
  57 external tree_parent : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent"
  58 external tree_parent_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
  59 external tree_prev_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_prev_doc"
  60 external tree_first_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
  61 external tree_next_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
  62 external tree_prev_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling"
  63 external tree_is_leaf : tree -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
  64 external tree_last_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_last_child"
  65 external tree_is_first_child : tree -> [`Tree] node -> bool = "caml_xml_tree_is_first_child"
  66
  67 (*    external tag : tree -> [`Tree ] node -> T = "caml_xml_tree_tag"*)
  68 external tree_tag_id : tree -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"
  69
  70
  71 let tree_is_last t n = equal_node nil (tree_next_sibling t n)
  72
  73 external tree_prev_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
  74
  75 external tree_my_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
  76 external tree_next_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
  77 external tree_doc_ids : tree -> [`Tree ] node -> [`Text ] node * [`Text ] node = "caml_xml_tree_doc_ids"
  78
  79 let text_size tree = int_of_node (snd ( tree_doc_ids tree (Obj.magic 0) ))
  80
  81 external tree_text_xml_id : tree -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
  82 external tree_node_xml_id : tree -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
  83 external tree_is_ancestor : tree -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor"
  84 external tree_tagged_desc : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc"
  85 external tree_tagged_foll_below : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_below"
  86 external tree_subtree_tags : tree -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags"
  87 external tree_select_below : tree -> [`Tree ] node -> Ptset.int_vector -> Ptset.int_vector -> [`Tree ] node = "caml_xml_tree_select_below"
  88 external tree_select_desc_only : tree -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node = "caml_xml_tree_select_desc_only"
  89 external tree_select_next : tree -> [`Tree ] node -> Ptset.int_vector -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_select_next"
  90 external tree_select_foll_only : tree -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_select_foll_only"
  91 external tree_select_desc_or_foll_only : tree -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_select_foll_only"
  92
  93 type descr =
  94   | Nil
  95   | Node of [`Tree] node
  96   | Text of [`Text] node * [`Tree] node
  97
  98 type t = { doc : tree;
  99            node : descr;
 100            ttable : (Tag.t,(Ptset.t*Ptset.t)) Hashtbl.t;
 101          }
 102
 103
 104
 105
 106
 107
 108 let text_size t = text_size t.doc
 109
 110 let collect_tags tree =
 111   let h_union = Hashtbl.create 511 in
 112   let pt_cup s1 s2 =
 113     (* special case, since this is a union we want hash(s1,s2) = hash(s2,s1) *)
 114     let x = Ptset.hash s1
 115     and y = Ptset.hash s2 in
 116     let h = if x < y then HASHINT2(x,y) else HASHINT2(y,x) in
 117       try
 118         Hashtbl.find h_union h
 119       with
 120         | Not_found -> let s = Ptset.union s1 s2
 121           in
 122             Hashtbl.add h_union h s;s
 123   in
 124   let h_add = Hashtbl.create 511 in
 125   let pt_add t s =
 126     let k = HASHINT2(Tag.hash t,Ptset.hash s) in
 127       try
 128         Hashtbl.find h_add k
 129       with
 130       | Not_found -> let r = Ptset.add t s in
 131           Hashtbl.add h_add k r;r
 132   in
 133   let h = Hashtbl.create 511 in
 134   let sing = Ptset.singleton Tag.pcdata in
 135   let update t sb sa =
 136     let sbelow,safter =
 137       try
 138         Hashtbl.find h t
 139       with
 140         | Not_found ->
 141             (sing,sing)
 142     in
 143       Hashtbl.replace h t (pt_cup sbelow sb, pt_cup safter sa)
 144   in
 145   let rec loop id acc =
 146     if equal_node id nil
 147     then (Ptset.empty,acc)
 148     else
 149       let below2,after2 = loop (tree_next_sibling tree id) acc in
 150       let below1,after1 = loop (tree_first_child tree id) after2 in
 151       let tag = tree_tag_id tree id in
 152         update tag below1 after2;
 153         pt_add tag (pt_cup below1 below2), (pt_add tag after1)
 154   in
 155   let b,a = loop (tree_root tree) Ptset.empty in
 156     update Tag.pcdata b a;
 157     h
 158
 159
 160
 161
 162
 163 let contains_array = ref [| |]
 164 let contains_index = Hashtbl.create 4096
 165 let in_array _ i =
 166   try
 167     Hashtbl.find contains_index i
 168   with
 169       Not_found -> false
 170
 171 let init_contains t s =
 172   let a = text_contains t.doc s
 173   in
 174     Array.fast_sort (compare) a;
 175     contains_array := a;
 176     Array.iter (fun x -> Hashtbl.add contains_index x true) !contains_array
 177
 178 let count_contains t s = text_count_contains t.doc s
 179 let unsorted_contains t s = text_unsorted_contains t.doc s
 180
 181 let init_naive_contains t s =
 182   let i,j = tree_doc_ids t.doc (tree_root t.doc)
 183   in
 184   let regexp = Str.regexp_string s in
 185   let matching arg =
 186     try
 187       let _ = Str.search_forward regexp arg 0;
 188       in true
 189     with _ -> false
 190   in
 191   let rec loop n acc l =
 192     if n >= j then acc,l
 193     else
 194       let s = get_cached_text t.doc n
 195       in
 196         if matching s
 197         then loop (n+1) (n::acc) (l+1)
 198         else loop (n+1) acc l
 199   in
 200   let acc,l = loop i [] 0 in
 201   let a = Array.create l nil in
 202   let _ = List.fold_left (fun cpt e -> a.(cpt) <- e; (cpt-1)) (l-1) acc
 203   in
 204     contains_array := a
 205
 206
 207
 208 module DocIdSet = struct
 209   include Set.Make (struct type t = [`Text] node
 210                            let compare = compare_node end)
 211
 212 end
 213 let is_nil t = t.node == Nil
 214
 215 let is_node t = t.node != Nil
 216
 217 let node_of_t t  =
 218   let _ = Tag.init (Obj.magic t) in
 219   let table = collect_tags t
 220   in
 221 (*
 222   let _ = Hashtbl.iter (fun t (sb,sa) ->
 223                           Printf.eprintf "'%s' -> { " (Tag.to_string t);
 224                           Ptset.iter (fun i ->  Printf.eprintf "'%s' " (Tag.to_string i)) sb;
 225                           Printf.eprintf "}\n { ";
 226                           Ptset.iter (fun i ->  Printf.eprintf "'%s' " (Tag.to_string i)) sa;
 227                           Printf.eprintf "} \n----------------------------------\n";
 228                        ) table in
 229   let i,j = tree_doc_ids t (tree_root t) in
 230     Printf.eprintf "%i docs, range from %i to %i\n%!" (Array.length s) i j;
 231     Array.iter (fun i -> print_endline (">>>" ^ i ^ "<<<")) s; *)
 232     { doc= t;
 233       node = Node(tree_root t);
 234       ttable = table;
 235     }
 236 let finalize _ = Printf.eprintf "Release the string list !\n%!"
 237 ;;
 238
 239 let parse f str =
 240   node_of_t
 241     (f str
 242        !Options.sample_factor
 243        !Options.index_empty_texts
 244        !Options.disable_text_collection)
 245
 246 let parse_xml_uri str = parse parse_xml_uri str
 247 let parse_xml_string str =  parse parse_xml_string str
 248
 249
 250 external pool : tree -> Tag.pool = "%identity"
 251
 252 let save t str = (save_tree t.doc str)
 253 ;;
 254
 255 let load ?(sample=64) str =
 256   node_of_t (load_tree str sample)
 257
 258
 259
 260
 261 let tag_pool t = pool t.doc
 262
 263 let compare a b = match a.node,b.node  with
 264   | Nil, Nil -> 0
 265   | Nil,_ -> 1
 266   | _ , Nil -> -1
 267   | Node(i),Node(j) -> compare_node i j
 268   | Text(i,_), Text(j,_) -> compare_node i j
 269   | Node(i), Text(_,j) -> compare_node i j
 270   | Text(_,i), Node(j) -> compare_node i j
 271
 272 let equal a b = (compare a b) == 0
 273
 274
 275 let norm (n : [`Tree ] node ) =  if n == -1 then Nil else Node (n)
 276
 277 let nts = function
 278     Nil -> "Nil"
 279   | Text (i,j) -> Printf.sprintf "Text (%i, %i)" i j
 280   | Node (i) -> Printf.sprintf "Node (%i)"  i
 281
 282 let dump_node t = nts t.node
 283
 284 let mk_nil t = { t with node = Nil }
 285 let root n = { n with node = norm (tree_root n.doc) }
 286
 287 let is_root n = match n.node with
 288   | Node(t) -> (int_of_node t) == 0
 289   | _ -> false
 290
 291 let is_left n = match n.node with
 292   | Node(t) -> (tree_is_first_child n.doc t) && (equal_node nil (tree_prev_text n.doc t))
 293   | Text(_,t) -> tree_is_nil t || tree_is_first_child n.doc t
 294   | _ -> false
 295
 296 let is_below_right t1 t2 =
 297   match (t1.node,t2.node) with
 298     | Nil,_ | _,Nil -> false
 299     | Node(i1), Node(i2)   ->
 300         tree_is_ancestor t1.doc (tree_parent t1.doc i1) i2
 301         && not (tree_is_ancestor t1.doc i1 i2)
 302     | Text(_,i1),Node(i2) -> i1 == i2 ||
 303         (tree_is_ancestor t1.doc (tree_parent t1.doc i1) i2 && i1 < i2)
 304     | Text(_,i1),Text(i,_) ->
 305         let x,y = tree_doc_ids t1.doc i1 in
 306           i >= x && i <= y
 307     | Node(i1), Text(i,_) ->
 308         let i2 = tree_next_sibling t1.doc i1 in
 309         let x,y = tree_doc_ids t1.doc i2 in
 310           i >= x && i <= y
 311
 312 let parent n =
 313   let node' =
 314     match n.node with (* inlined parent *)
 315       | Node(t) when (int_of_node t)== 0 -> Nil
 316       | Node(t) ->
 317           let txt = tree_prev_text n.doc t in
 318             if text_is_empty n.doc txt then
 319               let ps = tree_prev_sibling n.doc t in
 320                 if tree_is_nil ps
 321                 then
 322                   Node(tree_parent n.doc t)
 323                 else Node(ps)
 324             else
 325               Text(txt,t)
 326       | Text(i,t) ->
 327           let ps = tree_prev_doc n.doc i in
 328             if tree_is_nil ps
 329             then Node (tree_parent_doc n.doc i)
 330             else Node(ps)
 331       | _ -> failwith "parent"
 332   in
 333     { n with node = node' }
 334
 335 let node_child n =
 336   match n.node with
 337     | Node i ->  { n with node= norm(tree_first_child n.doc i) }
 338     | _ -> { n with node = Nil }
 339
 340 let node_sibling n =
 341   match n.node with
 342     | Node i ->  { n with node= norm(tree_next_sibling n.doc i) }
 343     | _ -> { n with node = Nil }
 344
 345 let node_sibling_ctx  n _ =
 346   match n.node with
 347     | Node i ->  { n with node= norm(tree_next_sibling n.doc i) }
 348     | _ -> { n with node = Nil }
 349
 350
 351 let first_child n =
 352   let node' =
 353     match n.node with
 354       | Node (t) ->
 355           let fs = tree_first_child n.doc t in
 356             if equal_node nil fs
 357             then
 358               let txt = tree_my_text n.doc t in
 359                 if equal_node nil txt
 360                 then Nil
 361                 else Text(txt,nil)
 362             else
 363               let txt = tree_prev_text n.doc fs in
 364                 if equal_node nil txt
 365                 then Node(fs)
 366                 else Text(txt, fs)
 367       | Text(_,_) -> Nil
 368       | Nil -> failwith "first_child"
 369   in
 370     { n with node = node'}
 371
 372 let next_sibling n =
 373   let node' =
 374     match n.node with
 375       | Text (_,ns) -> norm ns
 376       | Node(t) ->
 377           let ns = tree_next_sibling n.doc t in
 378           let txt = tree_next_text n.doc t in
 379             if equal_node nil txt
 380             then norm ns
 381             else Text(txt, ns)
 382       | Nil -> failwith "next_sibling"
 383   in
 384     { n with node = node'}
 385
 386 let next_sibling_ctx n _ = next_sibling n
 387
 388 let left = first_child
 389 let right = next_sibling
 390
 391 let id t =
 392   match t.node with
 393     | Node(n)  -> tree_node_xml_id t.doc n
 394     | Text(i,_)  -> tree_text_xml_id t.doc i
 395     | _ ->  -1
 396
 397 let tag t =
 398   match t.node with
 399   | Text(_) -> Tag.pcdata
 400   | Node(n) -> tree_tag_id t.doc n
 401   | _ -> failwith "tag"
 402
 403 (*
 404     let string_below t id =
 405       let strid = parent_doc t.doc id in
 406         match t.node with
 407           | Node(NC(i)) ->
 408               (Tree.equal i strid) || (is_ancestor t.doc i strid)
 409           | Node(SC(i,_)) -> Text.equal i id
 410           | _ -> false
 411
 412
 413     let tagged_foll t tag =
 414       if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_foll"
 415       else match t with
 416         | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_foll d n tag) }
 417         | { doc=d; node=Node(SC (_,n)) } when is_nil n -> { t with node= Nil }
 418         | { doc=d; node=Node(SC (_,n)) } ->
 419             let nnode =
 420               if tag_id d n == tag then n
 421               else
 422                 let n' = tagged_desc d n tag in
 423                   if is_nil n' then tagged_foll d n tag
 424                   else n'
 425             in {t with node= norm nnode}
 426         | _ -> { t with node=Nil }
 427
 428
 429     let tagged_desc t tag =
 430       if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_desc"
 431       else match t with
 432         | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_desc d n tag) }
 433         | _ -> { t with node=Nil }
 434
 435 *)
 436 let select_next tb tf t s =
 437   match s.node  with
 438     | Node (below) -> begin
 439         match t.node with
 440           | Node( n)  ->
 441               { t with node = norm (tree_select_next t.doc n (Ptset.to_int_vector tb) (Ptset.to_int_vector tf) below) }
 442           | Text (i,n)  when equal_node nil n ->
 443               let p = tree_parent_doc t.doc i in
 444                 { t with node = norm (tree_select_next t.doc p (Ptset.to_int_vector tb) (Ptset.to_int_vector tf) below) }
 445           | Text(_,n)  ->
 446               if Ptset.mem (tree_tag_id t.doc n) (Ptset.union tb tf)
 447               then { t with node=Node(n) }
 448               else
 449                 let vb = Ptset.to_int_vector tb in
 450                 let vf = Ptset.to_int_vector tf in
 451                 let node =
 452                   let dsc = tree_select_below t.doc n vb vf in
 453                     if equal_node nil dsc
 454                     then tree_select_next t.doc n vb vf below
 455                     else dsc
 456                 in
 457                   { t with node = norm node }
 458           | _ -> {t with node = Nil }
 459       end
 460
 461     | _ -> { t with node = Nil }
 462
 463
 464
 465
 466   let select_foll_only  tf t s =
 467     match s.node  with
 468       | Node (below)  ->
 469           begin
 470             match t.node with
 471             | Node(n) ->
 472                 { t with node= norm (tree_select_foll_only t.doc n (Ptset.to_int_vector tf) below) }
 473             | Text(i,n)  when equal_node nil n ->
 474                 let p = tree_parent_doc t.doc i in
 475                   { t with node= norm (tree_select_foll_only t.doc p (Ptset.to_int_vector tf) below) }
 476             |  Text(_,n) ->
 477                  if Ptset.mem (tree_tag_id t.doc n) tf
 478                  then { t with node=Node(n) }
 479                  else
 480                    let vf = Ptset.to_int_vector tf in
 481                    let node =
 482                      let dsc = tree_select_desc_only t.doc n vf in
 483                        if tree_is_nil dsc
 484                        then tree_select_foll_only t.doc n vf below
 485                        else dsc
 486                    in
 487                      { t with node = norm node }
 488             | _ -> { t with node = Nil }
 489         end
 490       | _ -> {t with node=Nil }
 491
 492 let select_below  tc td t=
 493   match t.node with
 494     | Node( n) ->
 495         let vc = Ptset.to_int_vector tc
 496         in
 497         let vd = Ptset.to_int_vector td
 498         in
 499           { t with node= norm(tree_select_below t.doc n vc vd) }
 500     | _ -> { t with node=Nil }
 501
 502
 503 let select_desc_only  td t =
 504   match t.node with
 505     | Node(n) ->
 506         let vd = Ptset.to_int_vector td
 507         in
 508           { t with node = norm(tree_select_desc_only t.doc n vd) }
 509     | _ -> { t with node = Nil }
 510
 511
 512 let tagged_desc tag t =
 513   match t.node with
 514     | Node(n) ->
 515           { t with node = norm(tree_tagged_desc t.doc n tag) }
 516     | _ -> { t with node = Nil }
 517
 518
 519 let tagged_foll_below tag t s =
 520     match s.node  with
 521       | Node (below)  ->
 522           begin
 523             match t.node with
 524             | Node(n) ->
 525                 { t with node= norm (tree_tagged_foll_below t.doc n tag below) }
 526             | Text(i,n)  when equal_node nil n ->
 527                 let p = tree_prev_doc t.doc i in
 528                   { t with node= norm (tree_tagged_foll_below t.doc p tag below) }
 529             |  Text(_,n) ->
 530                  if (tree_tag_id t.doc n) == tag
 531                  then { t with node=Node(n) }
 532                  else
 533                    let node =
 534                      let dsc = tree_tagged_desc t.doc n tag in
 535                        if tree_is_nil dsc
 536                        then tree_tagged_foll_below t.doc n tag below
 537                        else dsc
 538                    in
 539                      { t with node = norm node }
 540             | _ -> { t with node = Nil }
 541           end
 542       | _ -> {t with node=Nil }
 543
 544
 545 let last_idx = ref 0
 546 let array_find a i j =
 547   let l = Array.length a in
 548   let rec loop idx x y =
 549     if x > y || idx >= l then nil
 550         else
 551           if a.(idx) >= x then if a.(idx) > y then nil else (last_idx := idx;a.(idx))
 552           else loop (idx+1) x y
 553   in
 554     if a.(0) > j || a.(l-1) < i then nil
 555     else loop !last_idx i j
 556
 557
 558
 559 let text_below t =
 560   let l = Array.length !contains_array in
 561       match t.node with
 562         | Node(n)  ->
 563             let i,j = tree_doc_ids t.doc n in
 564             let id = if l == 0 then i else (array_find !contains_array i j)
 565             in
 566 (*            Printf.printf "Looking for text below node %i with tag %s in range %i %i, in array : [|\n%!"
 567                 n (Tag.to_string (tree_tag_id t.doc n)) i j;
 568               Array.iter (fun i -> Printf.printf "%i " (int_of_node i )) !contains_array;
 569               Printf.printf "|]\nResult is %i\n%!" id;        *)
 570               if id == nil then
 571                 { t with  node=Nil }
 572               else
 573                 { t with  node = Text(id, tree_next_sibling t.doc (tree_prev_doc t.doc id)) }
 574         | _ -> (*Printf.printf "Here\n%!"; *)
 575             { t with node = Nil }
 576
 577 let text_next t root =
 578   let l = Array.length !contains_array in
 579       let inf = match t.node with
 580         | Node(n)  -> snd(tree_doc_ids t.doc n)+1
 581         | Text(i,_)  -> i+1
 582         | _ -> assert false
 583       in
 584         match root.node with
 585           | Node (n)  ->
 586               let _,j = tree_doc_ids t.doc n in
 587               let id = if l == 0 then if inf > j then nil else inf
 588               else array_find !contains_array inf j
 589               in
 590                 if id == nil then  { t with node= Nil }
 591                 else
 592                   { t with node = Text(id,tree_next_sibling t.doc (tree_prev_doc t.doc id)) }
 593           | _ -> { t with node = Nil}
 594
 595
 596 (*
 597     let subtree_tags t tag =
 598       match t with
 599           { doc = d; node = Node(NC n) } ->
 600             subtree_tags d n tag
 601         | _ -> 0
 602
 603     let select_desc_array = ref [| |]
 604     let idx = ref 0
 605
 606     let init_tagged_next t tagid =
 607       let l = subtree_tags (root t) tagid
 608       in
 609         tagged_desc_array := Array.create l { t with node= Nil };
 610         let i = ref 0 in
 611           let rec collect t =
 612             if is_node t then begin
 613               if tag t == tagid then
 614                 begin
 615                   !tagged_desc_array.(!i) <- t;
 616                   incr i;
 617                 end;
 618               collect (first_child t);
 619               collect (next_sibling t)
 620             end;
 621           in
 622             collect t;
 623             idx := 0
 624
 625     let print_id ppf v =
 626       let pr x= Format.fprintf ppf x in
 627         match v with
 628             { node=Nil } -> pr "NULLT: -1"
 629           | { node=String(i) } | { node=Node(SC(i,_)) } -> pr "DocID: %i" (int_of_node i)
 630           | { node=Node(NC(i)) } -> pr "Node: %i" (int_of_node i)
 631
 632
 633
 634 (*    let tagged_next t tag =
 635       if !idx >= Array.length !tagged_desc_array
 636       then {t with node=Nil}
 637       else
 638         let r = !tagged_desc_array.(!idx)
 639         in
 640           incr idx; r
 641 *)
 642
 643
 644     let has_tagged_foll t tag = is_node (tagged_foll t tag)
 645     let has_tagged_desc t tag = is_node (tagged_desc t tag)
 646
 647     let contains t s =
 648       Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s)
 649
 650
 651     let contains_old t s =
 652       let regexp = Str.regexp_string s in
 653       let matching arg =
 654         try
 655           let _ = Str.search_forward regexp arg 0;
 656           in true
 657         with _ -> false
 658       in
 659       let rec find t acc = match t.node with
 660         | Nil -> acc
 661         | String i ->
 662             if  matching (string t) then DocIdSet.add i acc else acc
 663         | Node(_) ->  (find (left t )) ((find (right t))  acc)
 664       in
 665         find t DocIdSet.empty
 666
 667
 668     let contains_iter t s =
 669       let regexp = Str.regexp_string s in
 670       let matching arg =
 671         try
 672           let _ = Str.search_forward regexp arg 0;
 673           in true
 674         with _ -> false
 675       in
 676       let size = Text.size t.doc in
 677       let rec find acc n =
 678         if n == size then acc
 679         else
 680           find
 681             (if matching (Text.get_cached_text t.doc (Obj.magic n)) then
 682              DocIdSet.add (Obj.magic n) acc
 683            else acc) (n+1)
 684       in
 685         find DocIdSet.empty 0
 686
 687
 688
 689
 690     let count_contains t s =   Text.count_contains t.doc s
 691 *)
 692
 693   let count t s = text_count t.doc s
 694 (*
 695     let is_left t =
 696       if is_root t then false
 697       else
 698       if tag (parent t) == Tag.pcdata then false
 699       else
 700         let u = left (parent t) in
 701           (id t) == (id u)
 702 *)
 703   let print_xml_fast outc t =
 704     let rec loop ?(print_right=true) t =
 705       match t.node with
 706       | Nil -> ()
 707       | Text(i,n) -> output_string outc (get_cached_text t.doc i);
 708           if print_right
 709           then loop (right t)
 710       | Node (n) ->
 711           let tg = Tag.to_string (tag t) in
 712           let l = left t
 713           and r = right t
 714           in
 715             output_char outc  '<';
 716             output_string outc  tg;
 717             ( match l.node with
 718                   Nil -> output_string outc  "/>"
 719                 | Node(_) when Tag.equal (tag l) Tag.attribute ->
 720                     (loop_attributes (left l);
 721                      match (right l).node with
 722                        | Nil -> output_string outc  "/>"
 723                        | _ ->
 724                            output_char outc  '>';
 725                            loop (right l);
 726                            output_string outc  "</";
 727                            output_string outc  tg;
 728                            output_char outc '>' )
 729                 | _ ->
 730                     output_char outc  '>';
 731                     loop l;
 732                     output_string outc "</";
 733                     output_string outc tg;
 734                     output_char outc '>'
 735             );if print_right then loop r
 736     and loop_attributes a =
 737         match a.node with
 738           | Node(_) ->
 739               let value =
 740                 match (left a).node with
 741                   | Text(i,_) -> (get_cached_text a.doc i)
 742                   | _ -> assert false
 743               in
 744                 output_char outc ' ';
 745                 output_string outc (Tag.to_string (tag a));
 746                 output_string outc "=\"";
 747                 output_string outc value;
 748                 output_char outc '"';
 749                 loop_attributes (right a)
 750           | _ -> ()
 751     in
 752         loop ~print_right:false t
 753
 754
 755     let print_xml_fast outc t =
 756       if Tag.to_string (tag t) = "" then
 757         print_xml_fast outc (first_child t)
 758       else print_xml_fast outc t
 759
 760
 761 let tags_below t tag =
 762   fst(Hashtbl.find t.ttable tag)
 763
 764 let tags_after t tag =
 765   snd(Hashtbl.find t.ttable tag)
 766
 767 let tags t tag = Hashtbl.find t.ttable tag
 768
 769 let  tagged_lowest t tag =
 770   let rec loop_lowest i =
 771     let j = tree_tagged_desc t.doc i tag in
 772     if tree_is_nil j then i else loop_lowest j
 773   in
 774     match t.node with
 775       | Node i ->
 776           let j = loop_lowest i in
 777             { t with
 778                 node = norm(
 779                   if tree_is_nil j then
 780                     if (tree_tag_id t.doc i) == tag
 781                     then i
 782                     else j
 783                   else j) }
 784       | Nil -> t
 785       | _ -> assert false
 786
 787
 788 let tagged_next t tag =
 789   match t.node with
 790     | Node(i) ->
 791         let n = tree_tagged_foll_below t.doc i tag (Obj.magic 0)
 792         in
 793           if tree_is_nil  n then mk_nil t
 794           else
 795             tagged_lowest { t with node = Node n } tag
 796     | Nil -> t
 797     | _ -> assert false
 798
 799 let rec binary_parent t =
 800   let res =
 801   match t.node with
 802   | Node(0) -> { t with node = Nil }
 803   | Node(i) ->
 804       let j = tree_prev_sibling t.doc i in
 805         if tree_is_nil j then
 806           let idoc = tree_prev_text t.doc i in
 807             if equal_node nil idoc then
 808               { t with node = Node (tree_parent t.doc i) }
 809             else
 810               { t with node = Text(idoc,i) }
 811         else
 812           let idoc = tree_prev_text t.doc i in
 813             if equal_node nil idoc then
 814               { t with node = Node (j) }
 815             else { t with node = Text(idoc,i) }
 816   | Text(d,i) ->
 817       if tree_is_nil i then
 818         let n = tree_parent_doc t.doc d in
 819         let lc = tree_last_child t.doc n in
 820           if tree_is_nil lc then {t with node = Node n }
 821           else { t with node = Node lc }
 822       else
 823         let j = tree_prev_sibling t.doc i in
 824           if tree_is_nil j then
 825             { t with node = Node (tree_parent t.doc i) }
 826           else { t with node = Node j }
 827   | Nil -> t
 828   in match res.node with
 829     | Text(idoc,t) ->
 830         if (Array.length !contains_array) != 0
 831         then if in_array !contains_array idoc then res
 832         else binary_parent res
 833         else res
 834     | _ -> res
 835
 836 let benchmark_text t =
 837   let doc = t.doc in
 838     match (root t).node with
 839       | Node i -> let _,size = tree_doc_ids doc i in
 840           Printf.eprintf "%i will take ~ %i seconds\n%!"
 841             size (size/10000) ;
 842         let a = Array.create size "" in
 843           for i = 0 to size
 844           do
 845             a.(i) <- text_get_tc_text t.doc (i+1)
 846           done; a
 847       | _ -> assert false
 848
 849 let doc_ids (t:t) : (int*int) =
 850   (Obj.magic (
 851     match t.node with
 852       | Node i -> tree_doc_ids t.doc i
 853       | Text (i,_) -> (i,i)
 854       | Nil -> (nil,nil)
 855    ))
 856
 857 let subtree_tags t tag = match t.node with
 858   | Nil -> 0
 859   | Node(i) -> tree_subtree_tags t.doc i tag
 860   | Text(_,i) -> tree_subtree_tags t.doc i tag