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