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_below 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 let last_idx = ref 0
 514 let array_find a i j =
 515   let l = Array.length a in
 516   let rec loop idx x y =
 517     if x > y || idx >= l then nil
 518         else
 519           if a.(idx) >= x then if a.(idx) > y then nil else (last_idx := idx;a.(idx))
 520           else loop (idx+1) x y
 521   in
 522     if a.(0) > j || a.(l-1) < i then nil
 523     else loop !last_idx i j
 524
 525
 526
 527 let text_below t =
 528   let l = Array.length !contains_array in
 529       match t.node with
 530         | Node(n)  ->
 531             let i,j = tree_doc_ids t.doc n in
 532             let id = if l == 0 then i else (array_find !contains_array i j)
 533             in
 534 (*            Printf.printf "Looking for text below node %i with tag %s in range %i %i, in array : [|\n%!"
 535                 n (Tag.to_string (tree_tag_id t.doc n)) i j;
 536               Array.iter (fun i -> Printf.printf "%i " (int_of_node i )) !contains_array;
 537               Printf.printf "|]\nResult is %i\n%!" id;        *)
 538               if id == nil then
 539                 { t with  node=Nil }
 540               else
 541                 { t with  node = Text(id, tree_next_sibling t.doc (tree_prev_doc t.doc id)) }
 542         | _ -> (*Printf.printf "Here\n%!"; *)
 543             { t with node = Nil }
 544
 545 let text_next t root =
 546   let l = Array.length !contains_array in
 547       let inf = match t.node with
 548         | Node(n)  -> snd(tree_doc_ids t.doc n)+1
 549         | Text(i,_)  -> i+1
 550         | _ -> assert false
 551       in
 552         match root.node with
 553           | Node (n)  ->
 554               let _,j = tree_doc_ids t.doc n in
 555               let id = if l == 0 then if inf > j then nil else inf
 556               else array_find !contains_array inf j
 557               in
 558                 if id == nil then  { t with node= Nil }
 559                 else
 560                   { t with node = Text(id,tree_next_sibling t.doc (tree_prev_doc t.doc id)) }
 561           | _ -> { t with node = Nil}
 562
 563
 564 (*
 565     let subtree_tags t tag =
 566       match t with
 567           { doc = d; node = Node(NC n) } ->
 568             subtree_tags d n tag
 569         | _ -> 0
 570
 571     let select_desc_array = ref [| |]
 572     let idx = ref 0
 573
 574     let init_tagged_next t tagid =
 575       let l = subtree_tags (root t) tagid
 576       in
 577         tagged_desc_array := Array.create l { t with node= Nil };
 578         let i = ref 0 in
 579           let rec collect t =
 580             if is_node t then begin
 581               if tag t == tagid then
 582                 begin
 583                   !tagged_desc_array.(!i) <- t;
 584                   incr i;
 585                 end;
 586               collect (first_child t);
 587               collect (next_sibling t)
 588             end;
 589           in
 590             collect t;
 591             idx := 0
 592
 593     let print_id ppf v =
 594       let pr x= Format.fprintf ppf x in
 595         match v with
 596             { node=Nil } -> pr "NULLT: -1"
 597           | { node=String(i) } | { node=Node(SC(i,_)) } -> pr "DocID: %i" (int_of_node i)
 598           | { node=Node(NC(i)) } -> pr "Node: %i" (int_of_node i)
 599
 600
 601
 602 (*    let tagged_next t tag =
 603       if !idx >= Array.length !tagged_desc_array
 604       then {t with node=Nil}
 605       else
 606         let r = !tagged_desc_array.(!idx)
 607         in
 608           incr idx; r
 609 *)
 610
 611
 612     let has_tagged_foll t tag = is_node (tagged_foll t tag)
 613     let has_tagged_desc t tag = is_node (tagged_desc t tag)
 614
 615     let contains t s =
 616       Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s)
 617
 618
 619     let contains_old t s =
 620       let regexp = Str.regexp_string s in
 621       let matching arg =
 622         try
 623           let _ = Str.search_forward regexp arg 0;
 624           in true
 625         with _ -> false
 626       in
 627       let rec find t acc = match t.node with
 628         | Nil -> acc
 629         | String i ->
 630             if  matching (string t) then DocIdSet.add i acc else acc
 631         | Node(_) ->  (find (left t )) ((find (right t))  acc)
 632       in
 633         find t DocIdSet.empty
 634
 635
 636     let contains_iter t s =
 637       let regexp = Str.regexp_string s in
 638       let matching arg =
 639         try
 640           let _ = Str.search_forward regexp arg 0;
 641           in true
 642         with _ -> false
 643       in
 644       let size = Text.size t.doc in
 645       let rec find acc n =
 646         if n == size then acc
 647         else
 648           find
 649             (if matching (Text.get_cached_text t.doc (Obj.magic n)) then
 650              DocIdSet.add (Obj.magic n) acc
 651            else acc) (n+1)
 652       in
 653         find DocIdSet.empty 0
 654
 655
 656
 657
 658     let count_contains t s =   Text.count_contains t.doc s
 659 *)
 660
 661   let count t s = text_count t.doc s
 662 (*
 663     let is_left t =
 664       if is_root t then false
 665       else
 666       if tag (parent t) == Tag.pcdata then false
 667       else
 668         let u = left (parent t) in
 669           (id t) == (id u)
 670 *)
 671   let print_xml_fast outc t =
 672     let rec loop ?(print_right=true) t =
 673       match t.node with
 674       | Nil -> ()
 675       | Text(i,n) -> output_string outc (get_cached_text t.doc i);
 676           if print_right
 677           then loop (right t)
 678       | Node (n) ->
 679           let tg = Tag.to_string (tag t) in
 680           let l = left t
 681           and r = right t
 682           in
 683             output_char outc  '<';
 684             output_string outc  tg;
 685             ( match l.node with
 686                   Nil -> output_string outc  "/>"
 687                 | Node(_) when Tag.equal (tag l) Tag.attribute ->
 688                     (loop_attributes (left l);
 689                      match (right l).node with
 690                        | Nil -> output_string outc  "/>"
 691                        | _ ->
 692                            output_char outc  '>';
 693                            loop (right l);
 694                            output_string outc  "</";
 695                            output_string outc  tg;
 696                            output_char outc '>' )
 697                 | _ ->
 698                     output_char outc  '>';
 699                     loop l;
 700                     output_string outc "</";
 701                     output_string outc tg;
 702                     output_char outc '>'
 703             );if print_right then loop r
 704     and loop_attributes a =
 705         match a.node with
 706           | Node(_) ->
 707               let value =
 708                 match (left a).node with
 709                   | Text(i,_) -> (get_cached_text a.doc i)
 710                   | _ -> assert false
 711               in
 712                 output_char outc ' ';
 713                 output_string outc (Tag.to_string (tag a));
 714                 output_string outc "=\"";
 715                 output_string outc value;
 716                 output_char outc '"';
 717                 loop_attributes (right a)
 718           | _ -> ()
 719     in
 720         loop ~print_right:false t
 721
 722
 723     let print_xml_fast outc t =
 724       if Tag.to_string (tag t) = "" then
 725         print_xml_fast outc (first_child t)
 726       else print_xml_fast outc t
 727
 728
 729 let tags_below t tag =
 730   fst(Hashtbl.find t.ttable tag)
 731
 732 let tags_after t tag =
 733   snd(Hashtbl.find t.ttable tag)
 734
 735 let tags t tag = Hashtbl.find t.ttable tag
 736
 737 let  tagged_lowest t tag =
 738   let rec loop_lowest i =
 739     let j = tree_tagged_desc t.doc i tag in
 740     if tree_is_nil j then i else loop_lowest j
 741   in
 742     match t.node with
 743       | Node i ->
 744           let j = loop_lowest i in
 745             { t with
 746                 node = norm(
 747                   if tree_is_nil j then
 748                     if (tree_tag_id t.doc i) == tag
 749                     then i
 750                     else j
 751                   else j) }
 752       | Nil -> t
 753       | _ -> assert false
 754
 755
 756 let tagged_next t tag =
 757   match t.node with
 758     | Node(i) ->
 759         let n = tree_tagged_foll_below t.doc i tag (Obj.magic 0)
 760         in
 761           if tree_is_nil  n then mk_nil t
 762           else
 763             tagged_lowest { t with node = Node n } tag
 764     | Nil -> t
 765     | _ -> assert false
 766
 767 let rec binary_parent t =
 768   let res =
 769   match t.node with
 770   | Node(0) -> { t with node = Nil }
 771   | Node(i) ->
 772       let j = tree_prev_sibling t.doc i in
 773         if tree_is_nil j then
 774           let idoc = tree_prev_text t.doc i in
 775             if equal_node nil idoc then
 776               { t with node = Node (tree_parent t.doc i) }
 777             else
 778               { t with node = Text(idoc,i) }
 779         else
 780           let idoc = tree_prev_text t.doc i in
 781             if equal_node nil idoc then
 782               { t with node = Node (j) }
 783             else { t with node = Text(idoc,i) }
 784   | Text(d,i) ->
 785       if tree_is_nil i then
 786         let n = tree_parent_doc t.doc d in
 787         let lc = tree_last_child t.doc n in
 788           if tree_is_nil lc then {t with node = Node n }
 789           else { t with node = Node lc }
 790       else
 791         let j = tree_prev_sibling t.doc i in
 792           if tree_is_nil j then
 793             { t with node = Node (tree_parent t.doc i) }
 794           else { t with node = Node j }
 795   | Nil -> t
 796   in match res.node with
 797     | Text(idoc,t) ->
 798         if (Array.length !contains_array) != 0
 799         then if in_array !contains_array idoc then res
 800         else binary_parent res
 801         else res
 802     | _ -> res
 803
 804 let benchmark_text t =
 805   let doc = t.doc in
 806     match (root t).node with
 807       | Node i -> let _,size = tree_doc_ids doc i in
 808           Printf.eprintf "%i will take ~ %i seconds\n%!"
 809             size (size/10000) ;
 810         let a = Array.create size "" in
 811           for i = 0 to size
 812           do
 813             a.(i) <- text_get_tc_text t.doc (i+1)
 814           done; a
 815       | _ -> assert false
 816
 817 let doc_ids (t:t) : (int*int) =
 818   (Obj.magic (
 819     match t.node with
 820       | Node i -> tree_doc_ids t.doc i
 821       | Text (i,_) -> (i,i)
 822       | Nil -> (nil,nil)
 823    ))
 824
 825 let subtree_tags t tag = match t.node with
 826   | Nil -> 0
 827   | Node(i) -> tree_subtree_tags t.doc i tag
 828   | Text(_,i) -> tree_subtree_tags t.doc i tag
 829
 830 let get_text t = match t.node with
 831   | Text(i,_) -> get_cached_text t.doc i
 832   | _ -> ""