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