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
  46
  47 external tree_serialize : tree -> string -> unit = "caml_xml_tree_serialize"
  48
  49 external tree_unserialize : string -> tree = "caml_xml_tree_unserialize"
  50
  51 external tree_root : tree -> [`Tree] node = "caml_xml_tree_root"
  52
  53 let tree_is_nil x = equal_node x nil
  54
  55 external tree_parent : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent"
  56 external tree_parent_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
  57 external tree_prev_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_prev_doc"
  58 external tree_first_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
  59 external tree_next_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
  60 external tree_prev_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling"
  61 external tree_is_leaf : tree -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
  62 external tree_last_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_last_child"
  63 external tree_is_first_child : tree -> [`Tree] node -> bool = "caml_xml_tree_is_first_child"
  64
  65 (*    external tag : tree -> [`Tree ] node -> T = "caml_xml_tree_tag"*)
  66 external tree_tag_id : tree -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"
  67
  68
  69 let tree_is_last t n = equal_node nil (tree_next_sibling t n)
  70
  71 external tree_prev_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
  72
  73 external tree_my_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
  74 external tree_next_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
  75 external tree_doc_ids : tree -> [`Tree ] node -> [`Text ] node * [`Text ] node = "caml_xml_tree_doc_ids"
  76
  77 let text_size tree = int_of_node (snd ( tree_doc_ids tree (Obj.magic 0) ))
  78
  79 let get_cached_text t x =
  80   if x == -1 then ""
  81   else
  82      get_cached_text t x
  83
  84
  85 external tree_text_xml_id : tree -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
  86 external tree_node_xml_id : tree -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
  87 external tree_is_ancestor : tree -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor"
  88 external tree_tagged_desc : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc"
  89 external tree_tagged_foll_below : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_below"
  90 external tree_subtree_tags : tree -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags"
  91 (*
  92 external tree_select_below : tree -> [`Tree ] node -> Ptset.int_vector -> Ptset.int_vector -> [`Tree ] node = "caml_xml_tree_select_below"
  93 external tree_select_desc_only : tree -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node = "caml_xml_tree_select_desc_only"
  94 external tree_select_next : tree -> [`Tree ] node -> Ptset.int_vector -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_select_next"
  95 external tree_select_foll_only : tree -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_select_foll_only"
  96 external tree_select_desc_or_foll_only : tree -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_select_foll_only" *)
  97
  98 type descr =
  99   | Nil
 100   | Node of [`Tree] node
 101   | Text of [`Text] node * [`Tree] node
 102
 103 type t = { doc : tree;
 104            node : descr;
 105            ttable : (Tag.t,(Ptset.Int.t*Ptset.Int.t)) Hashtbl.t;
 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.Int.hash s1
 115     and y = Ptset.Int.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.Int.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.Int.hash s) in
 127       try
 128         Hashtbl.find h_add k
 129       with
 130       | Not_found -> let r = Ptset.Int.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.Int.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.Int.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.Int.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   | Nil -> Tag.nullt
 402
 403 (*
 404 let select_next tb tf t s =
 405   match s.node  with
 406     | Node (below) -> begin
 407         match t.node with
 408           | Node( n)  ->
 409               { t with node = norm (tree_select_next t.doc n (Ptset.Int.to_int_vector tb) (Ptset.Int.to_int_vector tf) below) }
 410           | Text (i,n)  when equal_node nil n ->
 411               let p = tree_parent_doc t.doc i in
 412                 { t with node = norm (tree_select_next t.doc p (Ptset.Int.to_int_vector tb) (Ptset.Int.to_int_vector tf) below) }
 413           | Text(_,n)  ->
 414               if Ptset.mem (tree_tag_id t.doc n) (Ptset.Int.union tb tf)
 415               then { t with node=Node(n) }
 416               else
 417                 let vb = Ptset.Int.to_int_vector tb in
 418                 let vf = Ptset.Int.to_int_vector tf in
 419                 let node =
 420                   let dsc = tree_select_below t.doc n vb vf in
 421                     if equal_node nil dsc
 422                     then tree_select_next t.doc n vb vf below
 423                     else dsc
 424                 in
 425                   { t with node = norm node }
 426           | _ -> {t with node = Nil }
 427       end
 428
 429     | _ -> { t with node = Nil }
 430
 431
 432
 433
 434   let select_foll_only  tf t s =
 435     match s.node  with
 436       | Node (below)  ->
 437           begin
 438             match t.node with
 439             | Node(n) ->
 440                 { t with node= norm (tree_select_foll_only t.doc n (Ptset.Int.to_int_vector tf) below) }
 441             | Text(i,n)  when equal_node nil n ->
 442                 let p = tree_parent_doc t.doc i in
 443                   { t with node= norm (tree_select_foll_only t.doc p (Ptset.Int.to_int_vector tf) below) }
 444             |  Text(_,n) ->
 445                  if Ptset.mem (tree_tag_id t.doc n) tf
 446                  then { t with node=Node(n) }
 447                  else
 448                    let vf = Ptset.Int.to_int_vector tf in
 449                    let node =
 450                      let dsc = tree_select_desc_only t.doc n vf in
 451                        if tree_is_nil dsc
 452                        then tree_select_foll_only t.doc n vf below
 453                        else dsc
 454                    in
 455                      { t with node = norm node }
 456             | _ -> { t with node = Nil }
 457         end
 458       | _ -> {t with node=Nil }
 459
 460 let select_below  tc td t=
 461   match t.node with
 462     | Node( n) ->
 463         let vc = Ptset.Int.to_int_vector tc
 464         in
 465         let vd = Ptset.Int.to_int_vector td
 466         in
 467           { t with node= norm(tree_select_below t.doc n vc vd) }
 468     | _ -> { t with node=Nil }
 469
 470
 471 let select_desc_only  td t =
 472   match t.node with
 473     | Node(n) ->
 474         let vd = Ptset.Int.to_int_vector td
 475         in
 476           { t with node = norm(tree_select_desc_only t.doc n vd) }
 477     | _ -> { t with node = Nil }
 478
 479 *)
 480 let tagged_desc tag t =
 481   match t.node with
 482     | Node(n) ->
 483           { t with node = norm(tree_tagged_desc t.doc n tag) }
 484     | _ -> { t with node = Nil }
 485
 486
 487 let tagged_foll_ctx tag t s =
 488     match s.node  with
 489       | Node (below)  ->
 490           begin
 491             match t.node with
 492             | Node(n) ->
 493                 { t with node= norm (tree_tagged_foll_below t.doc n tag below) }
 494             | Text(i,n)  when equal_node nil n ->
 495                 let p = tree_prev_doc t.doc i in
 496                   { t with node= norm (tree_tagged_foll_below t.doc p tag below) }
 497             |  Text(_,n) ->
 498                  if (tree_tag_id t.doc n) == tag
 499                  then { t with node=Node(n) }
 500                  else
 501                    let node =
 502                      let dsc = tree_tagged_desc t.doc n tag in
 503                        if tree_is_nil dsc
 504                        then tree_tagged_foll_below t.doc n tag below
 505                        else dsc
 506                    in
 507                      { t with node = norm node }
 508             | _ -> { t with node = Nil }
 509           end
 510       | _ -> {t with node=Nil }
 511
 512
 513
 514
 515 let last_idx = ref 0
 516 let array_find a i j =
 517   let l = Array.length a in
 518   let rec loop idx x y =
 519     if x > y || idx >= l then nil
 520         else
 521           if a.(idx) >= x then if a.(idx) > y then nil else (last_idx := idx;a.(idx))
 522           else loop (idx+1) x y
 523   in
 524     if a.(0) > j || a.(l-1) < i then nil
 525     else loop !last_idx i j
 526
 527
 528
 529 let text_below t =
 530   let l = Array.length !contains_array in
 531       match t.node with
 532         | Node(n)  ->
 533             let i,j = tree_doc_ids t.doc n in
 534             let id = if l == 0 then i else (array_find !contains_array i j)
 535             in
 536 (*            Printf.printf "Looking for text below node %i with tag %s in range %i %i, in array : [|\n%!"
 537                 n (Tag.to_string (tree_tag_id t.doc n)) i j;
 538               Array.iter (fun i -> Printf.printf "%i " (int_of_node i )) !contains_array;
 539               Printf.printf "|]\nResult is %i\n%!" id;        *)
 540               if id == nil then
 541                 { t with  node=Nil }
 542               else
 543                 { t with  node = Text(id, tree_next_sibling t.doc (tree_prev_doc t.doc id)) }
 544         | _ -> (*Printf.printf "Here\n%!"; *)
 545             { t with node = Nil }
 546
 547 let text_next t root =
 548   let l = Array.length !contains_array in
 549       let inf = match t.node with
 550         | Node(n)  -> snd(tree_doc_ids t.doc n)+1
 551         | Text(i,_)  -> i+1
 552         | _ -> assert false
 553       in
 554         match root.node with
 555           | Node (n)  ->
 556               let _,j = tree_doc_ids t.doc n in
 557               let id = if l == 0 then if inf > j then nil else inf
 558               else array_find !contains_array inf j
 559               in
 560                 if id == nil then  { t with node= Nil }
 561                 else
 562                   { t with node = Text(id,tree_next_sibling t.doc (tree_prev_doc t.doc id)) }
 563           | _ -> { t with node = Nil}
 564
 565
 566 (*
 567     let subtree_tags t tag =
 568       match t with
 569           { doc = d; node = Node(NC n) } ->
 570             subtree_tags d n tag
 571         | _ -> 0
 572
 573     let select_desc_array = ref [| |]
 574     let idx = ref 0
 575
 576     let init_tagged_next t tagid =
 577       let l = subtree_tags (root t) tagid
 578       in
 579         tagged_desc_array := Array.create l { t with node= Nil };
 580         let i = ref 0 in
 581           let rec collect t =
 582             if is_node t then begin
 583               if tag t == tagid then
 584                 begin
 585                   !tagged_desc_array.(!i) <- t;
 586                   incr i;
 587                 end;
 588               collect (first_child t);
 589               collect (next_sibling t)
 590             end;
 591           in
 592             collect t;
 593             idx := 0
 594
 595     let print_id ppf v =
 596       let pr x= Format.fprintf ppf x in
 597         match v with
 598             { node=Nil } -> pr "NULLT: -1"
 599           | { node=String(i) } | { node=Node(SC(i,_)) } -> pr "DocID: %i" (int_of_node i)
 600           | { node=Node(NC(i)) } -> pr "Node: %i" (int_of_node i)
 601
 602
 603
 604 (*    let tagged_next t tag =
 605       if !idx >= Array.length !tagged_desc_array
 606       then {t with node=Nil}
 607       else
 608         let r = !tagged_desc_array.(!idx)
 609         in
 610           incr idx; r
 611 *)
 612
 613
 614     let has_tagged_foll t tag = is_node (tagged_foll t tag)
 615     let has_tagged_desc t tag = is_node (tagged_desc t tag)
 616
 617     let contains t s =
 618       Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s)
 619
 620
 621     let contains_old t s =
 622       let regexp = Str.regexp_string s in
 623       let matching arg =
 624         try
 625           let _ = Str.search_forward regexp arg 0;
 626           in true
 627         with _ -> false
 628       in
 629       let rec find t acc = match t.node with
 630         | Nil -> acc
 631         | String i ->
 632             if  matching (string t) then DocIdSet.add i acc else acc
 633         | Node(_) ->  (find (left t )) ((find (right t))  acc)
 634       in
 635         find t DocIdSet.empty
 636
 637
 638     let contains_iter t s =
 639       let regexp = Str.regexp_string s in
 640       let matching arg =
 641         try
 642           let _ = Str.search_forward regexp arg 0;
 643           in true
 644         with _ -> false
 645       in
 646       let size = Text.size t.doc in
 647       let rec find acc n =
 648         if n == size then acc
 649         else
 650           find
 651             (if matching (Text.get_cached_text t.doc (Obj.magic n)) then
 652              DocIdSet.add (Obj.magic n) acc
 653            else acc) (n+1)
 654       in
 655         find DocIdSet.empty 0
 656
 657
 658
 659
 660     let count_contains t s =   Text.count_contains t.doc s
 661 *)
 662
 663   let count t s = text_count t.doc s
 664 (*
 665     let is_left t =
 666       if is_root t then false
 667       else
 668       if tag (parent t) == Tag.pcdata then false
 669       else
 670         let u = left (parent t) in
 671           (id t) == (id u)
 672 *)
 673   let print_xml_fast outc t =
 674     let rec loop ?(print_right=true) t =
 675       match t.node with
 676       | Nil -> ()
 677       | Text(i,n) -> output_string outc (get_cached_text t.doc i);
 678           if print_right
 679           then loop (right t)
 680       | Node (n) ->
 681           let tg = Tag.to_string (tag t) in
 682           let l = left t
 683           and r = right t
 684           in
 685             output_char outc  '<';
 686             output_string outc  tg;
 687             ( match l.node with
 688                   Nil -> output_string outc  "/>"
 689                 | Node(_) when Tag.equal (tag l) Tag.attribute ->
 690                     (loop_attributes (left l);
 691                      match (right l).node with
 692                        | Nil -> output_string outc  "/>"
 693                        | _ ->
 694                            output_char outc  '>';
 695                            loop (right l);
 696                            output_string outc  "</";
 697                            output_string outc  tg;
 698                            output_char outc '>' )
 699                 | _ ->
 700                     output_char outc  '>';
 701                     loop l;
 702                     output_string outc "</";
 703                     output_string outc tg;
 704                     output_char outc '>'
 705             );if print_right then loop r
 706     and loop_attributes a =
 707         match a.node with
 708           | Node(_) ->
 709               let value =
 710                 match (left a).node with
 711                   | Text(i,_) -> (get_cached_text a.doc i)
 712                   | _ -> assert false
 713               in
 714                 output_char outc ' ';
 715                 output_string outc (Tag.to_string (tag a));
 716                 output_string outc "=\"";
 717                 output_string outc value;
 718                 output_char outc '"';
 719                 loop_attributes (right a)
 720           | _ -> ()
 721     in
 722         loop ~print_right:false t
 723
 724
 725     let print_xml_fast outc t =
 726       if Tag.to_string (tag t) = "" then
 727         print_xml_fast outc (first_child t)
 728       else print_xml_fast outc t
 729
 730
 731 let tags_below t tag =
 732   fst(Hashtbl.find t.ttable tag)
 733
 734 let tags_after t tag =
 735   snd(Hashtbl.find t.ttable tag)
 736
 737 let tags t tag = Hashtbl.find t.ttable tag
 738
 739 let  tagged_lowest t tag =
 740   let rec loop_lowest i =
 741     let j = tree_tagged_desc t.doc i tag in
 742     if tree_is_nil j then i else loop_lowest j
 743   in
 744     match t.node with
 745       | Node i ->
 746           let j = loop_lowest i in
 747             { t with
 748                 node = norm(
 749                   if tree_is_nil j then
 750                     if (tree_tag_id t.doc i) == tag
 751                     then i
 752                     else j
 753                   else j) }
 754       | Nil -> t
 755       | _ -> assert false
 756
 757
 758 let tagged_next t tag =
 759   match t.node with
 760     | Node(i) ->
 761         let n = tree_tagged_foll_below t.doc i tag (Obj.magic 0)
 762         in
 763           if tree_is_nil  n then mk_nil t
 764           else
 765             tagged_lowest { t with node = Node n } tag
 766     | Nil -> t
 767     | _ -> assert false
 768
 769 let rec binary_parent t =
 770   let res =
 771   match t.node with
 772   | Node(0) -> { t with node = Nil }
 773   | Node(i) ->
 774       let j = tree_prev_sibling t.doc i in
 775         if tree_is_nil j then
 776           let idoc = tree_prev_text t.doc i in
 777             if equal_node nil idoc then
 778               { t with node = Node (tree_parent t.doc i) }
 779             else
 780               { t with node = Text(idoc,i) }
 781         else
 782           let idoc = tree_prev_text t.doc i in
 783             if equal_node nil idoc then
 784               { t with node = Node (j) }
 785             else { t with node = Text(idoc,i) }
 786   | Text(d,i) ->
 787       if tree_is_nil i then
 788         let n = tree_parent_doc t.doc d in
 789         let lc = tree_last_child t.doc n in
 790           if tree_is_nil lc then {t with node = Node n }
 791           else { t with node = Node lc }
 792       else
 793         let j = tree_prev_sibling t.doc i in
 794           if tree_is_nil j then
 795             { t with node = Node (tree_parent t.doc i) }
 796           else { t with node = Node j }
 797   | Nil -> t
 798   in match res.node with
 799     | Text(idoc,t) ->
 800         if (Array.length !contains_array) != 0
 801         then if in_array !contains_array idoc then res
 802         else binary_parent res
 803         else res
 804     | _ -> res
 805
 806 let benchmark_text t =
 807   let doc = t.doc in
 808     match (root t).node with
 809       | Node i -> let _,size = tree_doc_ids doc i in
 810           Printf.eprintf "%i will take ~ %i seconds\n%!"
 811             size (size/10000) ;
 812         let a = Array.create size "" in
 813           for i = 0 to size
 814           do
 815             a.(i) <- text_get_tc_text t.doc (i+1)
 816           done; a
 817       | _ -> assert false
 818
 819 let doc_ids (t:t) : (int*int) =
 820   (Obj.magic (
 821     match t.node with
 822       | Node i -> tree_doc_ids t.doc i
 823       | Text (i,_) -> (i,i)
 824       | Nil -> (nil,nil)
 825    ))
 826
 827 let subtree_tags t tag = match t.node with
 828   | Nil -> 0
 829   | Node(i) -> tree_subtree_tags t.doc i tag
 830   | Text(_,i) -> tree_subtree_tags t.doc i tag
 831
 832 let get_text t = match t.node with
 833   | Text(i,_) -> get_cached_text t.doc i
 834   | _ -> ""