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 "debug.ml"
   8 module type BINARY =
   9 sig
  10   type node_content
  11   type string_content
  12   type descr = Nil | Node of node_content  |String of string_content
  13   type t
  14   val parse_xml_uri : string -> t
  15   val parse_xml_string : string -> t
  16   val save : t -> string -> unit
  17   val load : ?sample:int -> string -> t
  18   val tag_pool : t -> Tag.pool
  19   val string : t -> string
  20   val descr : t -> descr
  21   val is_node : t -> bool
  22   val left : t -> t
  23   val right : t -> t
  24   val first_child : t -> t
  25   val next_sibling : t -> t
  26   val parent : t -> t
  27   val root : t -> t
  28   val is_root : t -> bool
  29   val id : t -> int
  30   val tag : t -> Tag.t
  31   val print_xml_fast : out_channel -> t -> unit
  32   val compare : t -> t -> int
  33   val equal : t -> t -> bool
  34   module DocIdSet :
  35   sig
  36     include Set.S
  37   end
  38     with type elt = string_content
  39   val string_below : t -> string_content -> bool
  40   val contains : t -> string -> DocIdSet.t
  41   val contains_old : t -> string -> DocIdSet.t
  42   val contains_iter : t -> string -> DocIdSet.t
  43   val count_contains : t -> string -> int
  44   val count : t -> string -> int
  45   val dump : t -> unit
  46   val get_string : t -> string_content -> string
  47   val has_tagged_desc : t -> Tag.t -> bool
  48   val has_tagged_foll : t -> Tag.t -> bool
  49   val tagged_desc : t -> Tag.t -> t
  50   val tagged_foll : t -> Tag.t -> t
  51   val tagged_below : t -> Ptset.t -> Ptset.t -> t
  52   val tagged_next : t -> Ptset.t -> Ptset.t -> t -> t
  53   val tagged_desc_only : t -> Ptset.t -> t
  54   val tagged_foll_only : t -> Ptset.t -> t -> t
  55   val text_below : t -> t
  56   val text_next : t -> t -> t
  57   val init_tagged_next : t -> Tag.t -> unit
  58   val subtree_tags : t -> Tag.t -> int
  59   val is_left : t -> bool
  60   val print_id : Format.formatter -> t -> unit
  61   val test_xml_tree : Format.formatter -> Ptset.t -> t -> unit
  62   val init_contains : t -> string -> unit
  63   val init_naive_contains : t -> string -> unit
  64   val mk_nil : t -> t
  65   val test_jump : t -> Tag.t -> unit
  66 end
  67
  68 module XML =
  69 struct
  70
  71   type t
  72   type 'a node = int
  73   type node_kind = [`Text | `Tree ]
  74
  75   let compare : 'a node -> 'a node -> int = (-)
  76   let equal : 'a node -> 'a node -> bool = (==)
  77
  78         (* abstract type, values are pointers to a XMLTree C++ object *)
  79
  80   external int_of_node : 'a node -> int = "%identity"
  81
  82   external parse_xml_uri : string -> int -> bool -> bool -> t = "caml_call_shredder_uri"
  83   external parse_xml_string :  string -> int -> bool -> bool -> t = "caml_call_shredder_string"
  84
  85   external save_tree : t -> string -> unit = "caml_xml_tree_save"
  86   external load_tree : string -> int -> t = "caml_xml_tree_load"
  87
  88
  89   module Text =
  90   struct
  91     let equal : [`Text] node -> [`Text] node -> bool = equal
  92
  93     (* Todo *)
  94     external nullt : unit -> [`Text ] node = "caml_xml_tree_nullt"
  95     let nil = nullt ()
  96     external get_text : t -> [`Text] node -> string = "caml_text_collection_get_text"
  97
  98 (*    let get_text t n =
  99       if equal nil n then ""
 100       else  get_text t n
 101 *)
 102
 103     external is_empty : t -> [`Text ] node -> bool = "caml_text_collection_empty_text"
 104
 105     let is_empty t n =
 106       (equal nil n) || is_empty t n
 107
 108     external get_cached_text : t -> [`Text ] node -> string = "caml_text_collection_get_cached_text"
 109
 110
 111     let get_text t n =
 112       if equal nil n then ""
 113       else get_cached_text t n
 114
 115     external size : t -> int = "caml_text_collection_size"
 116     external is_contains : t -> string -> bool = "caml_text_collection_is_contains"
 117     external count_contains : t -> string -> int = "caml_text_collection_count_contains"
 118     external count : t -> string -> int = "caml_text_collection_count"
 119     external contains : t -> string -> [`Text ] node array = "caml_text_collection_contains"
 120   end
 121
 122
 123   module Tree =
 124   struct
 125
 126     let equal : [`Tree ] node -> [`Tree] node -> bool = equal
 127     external serialize : t -> string -> unit = "caml_xml_tree_serialize"
 128     external unserialize : string -> t = "caml_xml_tree_unserialize"
 129
 130     external root : t -> [`Tree] node = "caml_xml_tree_root"
 131     external nullt : unit -> [`Tree ] node = "caml_xml_tree_nullt"
 132
 133     let nil = nullt ()
 134     let is_nil x = equal x nil
 135
 136     external parent : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent"
 137     external parent_doc : t -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
 138     external prev_doc : t -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_prev_doc"
 139     external first_child : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
 140
 141
 142
 143     external next_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
 144     external prev_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling"
 145     external is_leaf : t  -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
 146
 147 (*    external tag : t -> [`Tree ] node -> T = "caml_xml_tree_tag"*)
 148     external tag_id : t -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"
 149
 150 (*
 151     let tag_hash = Array.make 6_000_000 (Tag.nullt)
 152
 153     let tag_id t id =
 154         let tag =  tag_hash.(int_of_node id)
 155         in
 156           if tag != Tag.nullt then tag
 157           else
 158             let tag = tag_id t id in
 159             (tag_hash.(int_of_node id) <- tag; tag)
 160 *)
 161     let is_last t n = equal nil (next_sibling t n)
 162
 163     external prev_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
 164
 165
 166     external my_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
 167     external next_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
 168     external doc_ids : t -> [`Tree ] node -> [`Text ] node * [`Text ] node = "caml_xml_tree_doc_ids"
 169     external text_xml_id : t -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
 170     external node_xml_id : t -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
 171     external is_ancestor : t -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor"
 172     external tagged_desc : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc"
 173     external tagged_foll : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_foll"
 174     external subtree_tags : t -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags"
 175     external tagged_below : t -> [`Tree ] node -> Ptset.int_vector -> Ptset.int_vector -> [`Tree ] node = "caml_xml_tree_tagged_below"
 176     external tagged_desc_only : t -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node = "caml_xml_tree_tagged_desc_only"
 177     external tagged_next : t -> [`Tree ] node -> Ptset.int_vector -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_next"
 178     external tagged_foll_only : t -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_only"
 179     external tagged_desc_or_foll_only : t -> [`Tree ] node -> Ptset.int_vector -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_only"
 180
 181     let test_jump tree tag =
 182       let rec loop id ctx =
 183         if id != nil
 184         then
 185           let first = tagged_desc tree id tag
 186           and next = tagged_desc tree id tag
 187           in
 188             loop first id;
 189             loop next ctx
 190       in
 191         loop (root tree) (root tree)
 192
 193
 194     let test_xml_tree ppf tags v =
 195       let pr x = Format.fprintf ppf x in
 196       let rec aux id =
 197         if (is_nil id)
 198         then ()
 199         else
 200           begin
 201             pr "Node %i, (Tag) %i='%s' (GetTagName), NodeXMLId (Preorder)=%i\n%!"
 202               (int_of_node id)
 203               (tag_id v id)
 204               (Tag.to_string (tag_id v id))
 205               (node_xml_id v id);
 206             pr "DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s) ParentDoc(my_text)=%i PrevDoc(next_text)=%i\n%!"
 207               (int_of_node (prev_text v id))
 208               (Text.get_text v (prev_text v id))
 209               (int_of_node (my_text v id))
 210               (Text.get_text v (my_text v id))
 211               (int_of_node (next_text v id))
 212               (Text.get_text v (next_text v id))
 213               (int_of_node(parent_doc v (my_text v id)))
 214               (int_of_node(prev_doc v (next_text v id)));
 215             let i1,i2 = doc_ids v id in
 216               pr "Testing DocIds below (%i,%i)*\n%!"
 217                 (int_of_node i1) (int_of_node i2);
 218               pr "Testing Tagged*\n%!";
 219               Ptset.iter (fun t ->
 220                             let str = Tag.to_string t in
 221                             if Tag.pcdata <> t
 222                             then begin
 223                               pr "Tag: %s : \n%!" str;
 224                               pr "TaggedDesc = %i%!, " (tagged_desc v id t);
 225                               pr "TaggedFoll = %i\n%!" (tagged_foll v id t);
 226                               pr "SubtreeTags = %i\n%!" (subtree_tags v id t);
 227                             end) tags;
 228               pr "----------------------------\n";
 229             aux(first_child v id);
 230             aux(next_sibling v id);
 231           end
 232       in
 233         aux (root v)
 234
 235
 236
 237
 238
 239
 240     let print_skel t =
 241       let rec aux id =
 242         if (is_nil id)
 243         then Printf.eprintf "#\n"
 244         else
 245           begin
 246             Printf.eprintf "Node %i has tag '%i=%s' DocOrder=%i, DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s) parent_doc(my_text)=%i\n%!"
 247               (int_of_node id)
 248               (tag_id t id)
 249               (Tag.to_string (tag_id t id))
 250               (node_xml_id t id)
 251               (int_of_node (prev_text t id))
 252               (Text.get_text t (prev_text t id))
 253               (int_of_node (my_text t id))
 254               (Text.get_text t (my_text t id))
 255               (int_of_node (next_text t id))
 256               (Text.get_text t (next_text t id))
 257               (int_of_node(parent_doc t (my_text t id)));
 258
 259             aux(first_child t id);
 260             aux(next_sibling t id);
 261           end
 262       in
 263         aux (root t)
 264
 265     let traversal t =
 266         let rec aux id =
 267           if not (is_nil id)
 268           then
 269             begin
 270               (* ignore (tag t id);
 271               ignore (Text.get_text t (prev_text t id));
 272               if (is_leaf t id)
 273                 then ignore (Text.get_text t (my_text t id));
 274               if (is_last t id)
 275                 then ignore (Text.get_text t (next_text t id)); *)
 276               aux (first_child t id);
 277               aux (next_sibling t id);
 278             end
 279         in
 280           aux (root t)
 281
 282
 283
 284   end
 285
 286
 287   module Binary  = struct
 288
 289     type node_content =
 290         NC of [`Tree ] node
 291       | SC of [`Text ] node * [`Tree ] node
 292     type string_content = [ `Text ] node
 293     type descr =
 294       | Nil
 295       | Node of node_content
 296       | String of string_content
 297
 298     type doc = t
 299
 300     type t = { doc : doc;
 301                node : descr }
 302
 303     let dump { doc=t } = Tree.print_skel t
 304     let test_xml_tree ppf tags { doc=t } = Tree.test_xml_tree ppf tags t
 305     let test_jump { doc=t } tag = Tree.test_jump t tag
 306     let contains_array = ref [| |]
 307
 308     let init_contains t s =
 309       let a = Text.contains t.doc s
 310       in
 311         Array.fast_sort (compare) a;
 312         contains_array := a
 313
 314     let init_naive_contains t s =
 315       let i,j = Tree.doc_ids t.doc (Tree.root t.doc)
 316       in
 317       let regexp = Str.regexp_string s in
 318       let matching arg =
 319         try
 320           let _ = Str.search_forward regexp arg 0;
 321           in true
 322         with _ -> false
 323       in
 324       let rec loop n acc l =
 325         if n >= j then acc,l
 326         else
 327           let s = (*Printf.eprintf "%i \n%!" n;*)Text.get_cached_text t.doc n
 328           in
 329             if matching s
 330             then loop (n+1) (n::acc) (l+1)
 331             else loop (n+1) acc l
 332       in
 333       let acc,l = loop i [] 0 in
 334       let a = Array.create l Text.nil in
 335         let _ = List.fold_left (fun cpt e -> a.(cpt) <- e; (cpt-1)) (l-1) acc
 336         in
 337           contains_array := a
 338
 339
 340
 341     module DocIdSet = struct
 342       include Set.Make (struct type t = string_content
 343                                let compare = (-) end)
 344
 345     end
 346     let is_node = function { node=Node(_) } -> true | _ -> false
 347
 348     let get_string t (i:string_content) = Text.get_text t.doc i
 349     open Tree
 350     let node_of_t t = { doc= t;
 351                         node = Node(NC (root t)) }
 352
 353
 354     let parse_xml_uri str = node_of_t
 355       (MM((parse_xml_uri str
 356              !Options.sample_factor
 357              !Options.index_empty_texts
 358              !Options.disable_text_collection),__LOCATION__))
 359
 360     let parse_xml_string str = node_of_t
 361       (MM((parse_xml_string str
 362          !Options.sample_factor
 363          !Options.index_empty_texts
 364          !Options.disable_text_collection),__LOCATION__))
 365
 366
 367     let save t str = save_tree t.doc str
 368
 369     let load ?(sample=64) str = node_of_t (load_tree str sample)
 370
 371
 372     external pool : doc -> Tag.pool = "%identity"
 373     let tag_pool t = pool t.doc
 374
 375     let compare a b = match a.node,b.node  with
 376       | Node(NC i),Node(NC j) -> compare i j
 377       | _, Node(NC( _ )) -> 1
 378       | Node(SC (i,_)),Node(SC (j,_)) -> compare i j
 379       | Node(NC( _ )),Node(SC (_,_)) -> -1
 380       | _, Node(SC (_,_)) -> 1
 381       | String i, String j -> compare i j
 382       | Node _ , String _ -> -1
 383       | _ , String _ -> 1
 384       | Nil, Nil -> 0
 385       | _,Nil -> -1
 386
 387     let equal a b = (compare a b) == 0
 388
 389     let string t = match t.node with
 390       | String i ->  Text.get_text t.doc i
 391       | _ -> assert false
 392
 393     let norm (n : [`Tree ] node ) =  if is_nil n then Nil else Node (NC n)
 394
 395     let descr t = t.node
 396
 397     let nts = function
 398         Nil -> "Nil"
 399       | String i -> Printf.sprintf "String %i" i
 400       | Node (NC t) -> Printf.sprintf "Node (NC %i)"  (int_of_node t)
 401       | Node (SC (t,i)) -> Printf.sprintf "Node (SC (%i,%i))"  (int_of_node t) (int_of_node i)
 402
 403     let mk_nil t = { t with node = Nil }
 404     let root n = { n with node = norm (Tree.root n.doc) }
 405     let is_root n = match n.node with
 406       | Node(NC t) -> (int_of_node t) == 0
 407       | _ -> false
 408
 409     let parent n =
 410       if is_root n then { n with node=Nil}
 411       else
 412       let node' =
 413         match n.node with
 414           |  Node(NC t) ->
 415                let txt = prev_text n.doc t in
 416                  if Text.is_empty n.doc txt then
 417                    let ps = Tree.prev_sibling n.doc t in
 418                      if is_nil ps
 419                      then
 420                        Node(NC (Tree.parent n.doc t))
 421                      else Node(NC ps)
 422                  else
 423                    Node(SC (txt,t))
 424           | Node(SC(i,t)) ->
 425               let ps = Tree.prev_sibling n.doc t in
 426                 if is_nil ps
 427                 then Node (NC(parent_doc n.doc i))
 428                 else Node(NC ps)
 429           | _ -> failwith "parent"
 430       in
 431         { n with node = node' }
 432
 433     let first_child n =
 434       let node' =
 435         match n.node with
 436           | Node (NC t) when is_leaf n.doc t ->
 437               let txt = my_text n.doc t in
 438                 if Text.is_empty n.doc txt
 439                 then Nil
 440                 else Node(SC (txt,Tree.nil))
 441           | Node (NC t) ->
 442               let fs = first_child n.doc t in
 443               let txt = prev_text n.doc fs in
 444                 if Text.is_empty n.doc txt
 445                 then norm fs
 446                 else Node (SC (txt, fs))
 447           | Node(SC (i,_)) -> String i
 448           | Nil | String _ -> failwith "first_child"
 449       in
 450         { n with node = node'}
 451
 452     let next_sibling n =
 453       let node' =
 454         match n.node with
 455           | Node (SC (_,ns)) -> norm ns
 456           | Node(NC t) ->
 457               let ns = next_sibling n.doc t in
 458               let txt = next_text n.doc t in
 459                 if Text.is_empty n.doc txt
 460                 then norm ns
 461                 else Node (SC (txt, ns))
 462           | Nil | String _  -> failwith "next_sibling"
 463       in
 464         { n with node = node'}
 465
 466
 467     let left = first_child
 468     let right = next_sibling
 469
 470     let id =
 471       function  { doc=d; node=Node(NC n)}  -> node_xml_id d n
 472         | { doc=d;  node=Node(SC (i,_) )} -> text_xml_id d i
 473         | _ ->  -1 (*
 474             Format.fprintf Format.err_formatter "Failure id on %s\n%!" (nts x.node);
 475             failwith "id" *)
 476
 477     let tag =
 478       function { node=Node(SC _) } -> Tag.pcdata
 479         | { doc=d; node=Node(NC n)} -> tag_id d n
 480         | _ -> failwith "tag"
 481
 482     let string_below t id =
 483       let strid = parent_doc t.doc id in
 484         match t.node with
 485           | Node(NC(i)) ->
 486               (Tree.equal i strid) || (is_ancestor t.doc i strid)
 487           | Node(SC(i,_)) -> Text.equal i id
 488           | _ -> false
 489
 490
 491     let tagged_foll t tag =
 492       if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_foll"
 493       else match t with
 494         | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_foll d n tag) }
 495         | { doc=d; node=Node(SC (_,n)) } when is_nil n -> { t with node= Nil }
 496         | { doc=d; node=Node(SC (_,n)) } ->
 497             let nnode =
 498               if tag_id d n == tag then n
 499               else
 500                 let n' = tagged_desc d n tag in
 501                   if is_nil n' then tagged_foll d n tag
 502                   else n'
 503             in {t with node= norm nnode}
 504         | _ -> { t with node=Nil }
 505
 506
 507     let tagged_desc t tag =
 508       if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_desc"
 509       else match t with
 510         | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_desc d n tag) }
 511         | _ -> { t with node=Nil }
 512
 513
 514     let tagged_next t tb tf s =
 515       match s  with
 516         | { node = Node (NC(below)) } -> begin
 517             match t with
 518               | { doc = d; node=Node(NC n) } ->
 519                   { t with node= norm (tagged_next d n (Ptset.to_int_vector tb) (Ptset.to_int_vector tf) below) }
 520               | { doc = d; node=Node(SC (i,n) ) } when is_nil n ->
 521                   let p = parent_doc d i in
 522                     { t with node= norm (tagged_next d p (Ptset.to_int_vector tb) (Ptset.to_int_vector tf) below) }
 523               | { doc = d; node=Node(SC (_,n) ) } ->
 524                   if Ptset.mem (tag_id d n) (Ptset.union tb tf)
 525                   then { t with node=Node(NC(n)) }
 526                   else
 527                     let vb = Ptset.to_int_vector tb in
 528                     let vf = Ptset.to_int_vector tf in
 529                     let node =
 530                       let dsc = tagged_below d n vb vf in
 531                         if is_nil dsc
 532                         then tagged_next d n vb vf below
 533                         else dsc
 534                     in
 535                       { t with node = norm node }
 536               | _ -> {t with node=Nil }
 537           end
 538
 539         | _ -> {t with node=Nil }
 540
 541     let tagged_foll_only t tf s =
 542       match s  with
 543         | { node = Node (NC(below)) } -> begin
 544             match t with
 545               | { doc = d; node=Node(NC n) } ->
 546                   { t with node= norm (tagged_foll_only d n (Ptset.to_int_vector tf) below) }
 547               | { doc = d; node=Node(SC (i,n) ) } when is_nil n ->
 548                   let p = parent_doc d i in
 549                     { t with node= norm (tagged_foll_only d p  (Ptset.to_int_vector tf) below) }
 550               | { doc = d; node=Node(SC (_,n) ) } ->
 551                   if Ptset.mem (tag_id d n) tf
 552                   then { t with node=Node(NC(n)) }
 553                   else
 554                     let vf = Ptset.to_int_vector tf in
 555                     let node =
 556                       let dsc = tagged_desc_only d n vf in
 557                         if is_nil dsc
 558                         then tagged_foll_only d n vf below
 559                         else dsc
 560                     in
 561                       { t with node = norm node }
 562               | _ -> {t with node=Nil }
 563           end
 564
 565         | _ -> {t with node=Nil }
 566
 567
 568     let tagged_below t tc td =
 569       match t with
 570         | { doc = d; node=Node(NC n) } ->
 571             let vc = Ptset.to_int_vector tc
 572             in
 573             let vd = Ptset.to_int_vector td
 574             in
 575               { t with node= norm(tagged_below d n vc vd) }
 576         | _ -> { t with node=Nil }
 577
 578     let tagged_desc_only t td =
 579       match t with
 580         | { doc = d; node=Node(NC n) } ->
 581             let vd = Ptset.to_int_vector td
 582             in
 583               { t with node= norm(tagged_desc_only d n vd) }
 584         | _ -> { t with node=Nil }
 585
 586
 587     let last_idx = ref 0
 588     let array_find a i j =
 589       let l = Array.length a in
 590       let rec loop idx x y =
 591         if x > y || idx >= l then Text.nil
 592         else
 593           if a.(idx) >= x then if a.(idx) > y then Text.nil else (last_idx := idx;a.(idx))
 594           else loop (idx+1) x y
 595       in
 596         if a.(0) > j || a.(l-1) < i then Text.nil
 597         else loop !last_idx i j
 598
 599
 600     let text_below t =
 601       let l = Array.length !contains_array in
 602         if l = 0 then { t with node=Nil }
 603         else
 604           match t with
 605             | { doc = d; node=Node(NC n) } ->
 606                 let i,j = doc_ids t.doc n in
 607                 let id = array_find !contains_array i j
 608                 in
 609                   if id == Text.nil then
 610                     { t with  node=Nil }
 611                   else
 612                     {t with  node = Node(SC(id, Tree.next_sibling d (Tree.prev_doc d id))) }
 613             | _ -> { t with node=Nil }
 614
 615     let text_next t root =
 616       let l = Array.length !contains_array in
 617         if l = 0 then { t with node=Nil }
 618         else
 619           let inf = match t with
 620             | { doc =d; node = Node(NC n) } -> snd(doc_ids d n)+1
 621             | { node = Node(SC(i,_)) } -> i+1
 622             | _ -> assert false
 623           in
 624             match root with
 625               | { doc = d; node= Node (NC n) } ->
 626                   let _,j = doc_ids t.doc n in
 627
 628                   let id = array_find !contains_array inf j
 629                   in
 630                     if id == Text.nil then  { doc = d; node= Nil }
 631                     else
 632                       {doc = d; node = Node(SC(id,Tree.next_sibling d (Tree.prev_doc d id))) }
 633               | _ -> { t with node=Nil}
 634
 635
 636
 637     let subtree_tags t tag =
 638       match t with
 639           { doc = d; node = Node(NC n) } ->
 640             subtree_tags d n tag
 641         | _ -> 0
 642
 643     let tagged_desc_array = ref [| |]
 644     let idx = ref 0
 645
 646     let init_tagged_next t tagid =
 647       let l = subtree_tags (root t) tagid
 648       in
 649         tagged_desc_array := Array.create l { t with node= Nil };
 650         let i = ref 0 in
 651           let rec collect t =
 652             if is_node t then begin
 653               if tag t == tagid then
 654                 begin
 655                   !tagged_desc_array.(!i) <- t;
 656                   incr i;
 657                 end;
 658               collect (first_child t);
 659               collect (next_sibling t)
 660             end;
 661           in
 662             collect t;
 663             idx := 0
 664
 665     let print_id ppf v =
 666       let pr x= Format.fprintf ppf x in
 667         match v with
 668             { node=Nil } -> pr "NULLT: -1"
 669           | { node=String(i) } | { node=Node(SC(i,_)) } -> pr "DocID: %i" (int_of_node i)
 670           | { node=Node(NC(i)) } -> pr "Node: %i" (int_of_node i)
 671
 672
 673
 674 (*    let tagged_next t tag =
 675       if !idx >= Array.length !tagged_desc_array
 676       then {t with node=Nil}
 677       else
 678         let r = !tagged_desc_array.(!idx)
 679         in
 680           incr idx; r
 681 *)
 682
 683
 684     let has_tagged_foll t tag = is_node (tagged_foll t tag)
 685     let has_tagged_desc t tag = is_node (tagged_desc t tag)
 686
 687     let contains t s =
 688       Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s)
 689
 690
 691     let contains_old t s =
 692       let regexp = Str.regexp_string s in
 693       let matching arg =
 694         try
 695           let _ = Str.search_forward regexp arg 0;
 696           in true
 697         with _ -> false
 698       in
 699       let rec find t acc = match t.node with
 700         | Nil -> acc
 701         | String i ->
 702             if  matching (string t) then DocIdSet.add i acc else acc
 703         | Node(_) ->  (find (left t )) ((find (right t))  acc)
 704       in
 705         find t DocIdSet.empty
 706
 707
 708     let contains_iter t s =
 709       let regexp = Str.regexp_string s in
 710       let matching arg =
 711         try
 712           let _ = Str.search_forward regexp arg 0;
 713           in true
 714         with _ -> false
 715       in
 716       let size = Text.size t.doc in
 717       let rec find acc n =
 718         if n == size then acc
 719         else
 720           find
 721             (if matching (Text.get_cached_text t.doc (Obj.magic n)) then
 722              DocIdSet.add (Obj.magic n) acc
 723            else acc) (n+1)
 724       in
 725         find DocIdSet.empty 0
 726
 727
 728
 729
 730     let count_contains t s =   Text.count_contains t.doc s
 731     let count t s =   Text.count t.doc s
 732
 733     let is_left t =
 734       if is_root t then false
 735       else
 736       if tag (parent t) == Tag.pcdata then false
 737       else
 738         let u = left (parent t) in
 739           (id t) == (id u)
 740
 741     let print_xml_fast outc t =
 742       let rec loop ?(print_right=true) t = match t.node with
 743         | Nil -> ()
 744         | String (s) -> output_string outc (Text.get_text t.doc s)
 745         | Node _ when Tag.equal (tag t) Tag.pcdata ->
 746             loop (left t);
 747             if print_right then loop (right t)
 748
 749         | Node (_) ->
 750             let tg = Tag.to_string (tag t) in
 751             let l = left t
 752             and r = right t
 753             in
 754               output_char outc  '<';
 755               output_string outc  tg;
 756               ( match l.node with
 757                     Nil -> output_string outc  "/>"
 758                   | String _ -> assert false
 759                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 760                       (loop_attributes (left l);
 761                        match (right l).node with
 762                          | Nil -> output_string outc  "/>"
 763                          | _ ->
 764                              output_char outc  '>';
 765                              loop (right l);
 766                              output_string outc  "</";
 767                              output_string outc  tg;
 768                              output_char outc '>' )
 769                   | _ ->
 770                       output_char outc  '>';
 771                       loop l;
 772                       output_string outc "</";
 773                       output_string outc tg;
 774                       output_char outc '>'
 775               );if print_right then loop r
 776       and loop_attributes a =
 777
 778         match a.node with
 779           | Node(_) ->
 780               let value =
 781                 match (left a).node with
 782                   | Nil -> ""
 783                   | _ -> string (left(left a))
 784               in
 785                 output_char outc ' ';
 786                 output_string outc (Tag.to_string (tag a));
 787                 output_string outc "=\"";
 788                 output_string outc value;
 789                 output_char outc '"';
 790                 loop_attributes (right a)
 791         | _ -> ()
 792       in
 793         loop ~print_right:false t
 794
 795
 796     let print_xml_fast outc t =
 797       if Tag.to_string (tag t) = "" then
 798         print_xml_fast outc (first_child t)
 799       else print_xml_fast outc t
 800
 801
 802
 803
 804
 805     let traversal t = Tree.traversal t.doc
 806     let full_traversal t =
 807       let rec aux n =
 808         match n.node with
 809         | Nil -> ()
 810         | String i -> () (*ignore(Text.get_text t.doc i)  *)
 811         | Node(_) ->
 812             (* tag_id n; *)
 813             aux (first_child n);
 814             aux (next_sibling n)
 815       in aux t
 816
 817     let print_stats _ = ()
 818   end
 819
 820 end
 821
 822
 823
 824 IFDEF DEBUG
 825 THEN
 826 module DEBUGTREE
 827   = struct
 828
 829     let _timings = Hashtbl.create 107
 830
 831
 832     let time _ref f arg =
 833       let t1 = Unix.gettimeofday () in
 834       let r = f arg in
 835       let t2 = Unix.gettimeofday () in
 836       let t = (1000. *.(t2 -. t1)) in
 837
 838       let (time,count) = try
 839         Hashtbl.find _timings _ref
 840       with
 841         | Not_found -> 0.,0
 842       in
 843       let time = time+. t
 844       and count = count + 1
 845       in
 846         Hashtbl.replace _timings _ref (time,count);r
 847
 848     include XML.Binary
 849
 850
 851     let first_child_ doc node =
 852      time ("XMLTree.FirstChild()") (XML.Tree.first_child doc)  node
 853     let next_sibling_ doc node =
 854       time ("XMLTree.NextSibling()") (XML.Tree.next_sibling doc) node
 855
 856     let is_empty_ text node =
 857       time ("TextCollection.IsEmpty()") (XML.Text.is_empty text) node
 858
 859     let prev_text_ doc node =
 860       time ("XMLTree.PrevText()") (XML.Tree.prev_text doc) node
 861
 862     let my_text_ doc node =
 863       time ("XMLTree.MyText()") (XML.Tree.my_text doc) node
 864
 865     let next_text_ doc node =
 866       time ("XMLTree.NextText()") (XML.Tree.next_text doc) node
 867
 868     let is_leaf_ doc node =
 869       time ("XMLTree.IsLeaf()") (XML.Tree.is_leaf doc ) node
 870
 871     let node_xml_id_ doc node =
 872       time ("XMLTree.NodeXMLId()") (XML.Tree.node_xml_id doc ) node
 873
 874     let text_xml_id_ doc node =
 875       time ("XMLTree.TextXMLId()") (XML.Tree.text_xml_id doc ) node
 876
 877
 878     let first_child n =
 879       let node' =
 880         match n.node with
 881           | Node (NC t) when is_leaf_ n.doc t ->
 882               let txt = my_text_ n.doc t in
 883                 if is_empty_ n.doc txt
 884                 then Nil
 885                 else Node(SC (txt,XML.Tree.nil))
 886           | Node (NC t) ->
 887               let fs = first_child_ n.doc t in
 888               let txt = prev_text_ n.doc fs in
 889                 if is_empty_ n.doc txt
 890                 then norm fs
 891                 else Node (SC (txt, fs))
 892           | Node(SC (i,_)) -> String i
 893           | Nil | String _ -> failwith "first_child"
 894       in
 895         { n with node = node'}
 896
 897
 898     let next_sibling n =
 899       let node' =
 900         match n.node with
 901           | Node (SC (_,ns)) -> norm ns
 902           | Node(NC t) ->
 903               let ns = next_sibling_ n.doc t in
 904               let txt =
 905                 if XML.Tree.is_nil ns then
 906                   next_text_ n.doc t
 907                 else prev_text_ n.doc ns
 908               in
 909                 if is_empty_ n.doc txt
 910                 then norm ns
 911                 else Node (SC (txt, ns))
 912           | Nil | String _  -> failwith "next_sibling"
 913       in
 914         { n with node = node'}
 915
 916     let id =
 917       function  { doc=d; node=Node(NC n)}  -> node_xml_id_ d n
 918         | { doc=d;  node=Node(SC (i,_) )} -> text_xml_id_ d i
 919         | _ -> failwith "id"
 920
 921     (* Wrapper around critical function *)
 922     let string t = time ("TextCollection.GetText()") (string) t
 923     let left = first_child
 924     let right = next_sibling
 925     let tag t =  time ("XMLTree.GetTag()") (tag) t
 926
 927     let print_stats ppf =
 928       let total_time,total_calls =
 929         Hashtbl.fold  (fun _ (t,c) (tacc,cacc) ->
 930                          tacc+. t, cacc + c)  _timings (0.,0)
 931
 932       in
 933         Format.fprintf ppf
 934           "Timing : Function Name, number of calls,%% of total calls, mean time, total time, %% of total time\n%!";
 935         Hashtbl.iter (fun name (time,count) ->
 936                         Format.fprintf ppf  "%-27s% 8d\t% 4.2f%%\t% 4.6f ms\t% 4.6f ms\t%04.2f%%\n%!"
 937                           name
 938                           count
 939                           (100. *. (float_of_int count)/.(float_of_int total_calls))
 940                           (time /. (float_of_int count))
 941                           time
 942                           (100. *. time /.  total_time)) _timings;
 943         Format.fprintf ppf  "-------------------------------------------------------------------\n";
 944         Format.fprintf ppf "%-27s% 8d\t% 4.0f%%\t########## ms\t% 4.6f ms\t% 4.0f%%\n%!"
 945           "Total" total_calls 100. total_time 100.
 946
 947
 948     let print_xml_fast outc t =
 949       let rec loop ?(print_right=true) t = match t.node with
 950         | Nil -> ()
 951         | String (s) -> output_string outc (string t)
 952         | Node _ when Tag.equal (tag t) Tag.pcdata -> loop (left t); loop (right t)
 953
 954         | Node (_) ->
 955             let tg = Tag.to_string (tag t) in
 956             let l = left t
 957             and r = right t
 958             in
 959               output_char outc  '<';
 960               output_string outc  tg;
 961               ( match l.node with
 962                     Nil -> output_string outc  "/>"
 963                   | String _ -> assert false
 964                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 965                       (loop_attributes (left l);
 966                        match (right l).node with
 967                          | Nil -> output_string outc  "/>"
 968                          | _ ->
 969                              output_char outc  '>';
 970                              loop (right l);
 971                              output_string outc  "</";
 972                              output_string outc  tg;
 973                              output_char outc '>' )
 974                   | _ ->
 975                       output_char outc  '>';
 976                       loop l;
 977                       output_string outc "</";
 978                       output_string outc tg;
 979                       output_char outc '>'
 980               );if print_right then loop r
 981       and loop_attributes a =
 982
 983         match a.node with
 984           | Node(_) ->
 985               let value =
 986                 match (left a).node with
 987                   | Nil -> ""
 988                   | _ -> string (left(left a))
 989               in
 990                 output_char outc ' ';
 991                 output_string outc (Tag.to_string (tag a));
 992                 output_string outc "=\"";
 993                 output_string outc value;
 994                 output_char outc '"';
 995                 loop_attributes (right a)
 996         | _ -> ()
 997       in
 998         loop ~print_right:false t
 999
1000
1001     let print_xml_fast outc t =
1002       if Tag.to_string (tag t) = "" then
1003         print_xml_fast outc (first_child t)
1004       else print_xml_fast outc t
1005
1006
1007
1008
1009 end
1010
1011 module Binary = DEBUGTREE
1012 ELSE
1013 module Binary = XML.Binary
1014 END (* IFDEF DEBUG *)