X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=tree.ml;h=e3e8fe218ddc98436c4c6426bb88e132a6c2a90f;hb=451e60ad59e35344dff62da5ca27fcd5eec1bff9;hp=354e03139e36a2f870721b90afcf109b2c24bc0e;hpb=83aa6cf8a120ea6681402ce42ae56631fca1ddf4;p=SXSI%2Fxpathcomp.git diff --git a/tree.ml b/tree.ml index 354e031..e3e8fe2 100644 --- a/tree.ml +++ b/tree.ml @@ -4,712 +4,443 @@ (* Copyright NICTA 2008 *) (* Distributed under the terms of the LGPL (see LICENCE) *) (******************************************************************************) -INCLUDE "debug.ml" -module type BINARY = -sig - type node_content - type string_content - type descr = Nil | Node of node_content |String of string_content - type t - val parse_xml_uri : string -> t - val parse_xml_string : string -> t - val save : t -> string -> unit - val load : ?sample:int -> string -> t - val tag_pool : t -> Tag.pool - val string : t -> string - val descr : t -> descr - val is_node : t -> bool - val left : t -> t - val right : t -> t - val first_child : t -> t - val next_sibling : t -> t - val parent : t -> t - val root : t -> t - val is_root : t -> bool - val id : t -> int - val tag : t -> Tag.t - val print_xml_fast : out_channel -> t -> unit - val compare : t -> t -> int - val equal : t -> t -> bool - module DocIdSet : - sig - include Set.S - end - with type elt = string_content - val string_below : t -> string_content -> bool - val contains : t -> string -> DocIdSet.t - val contains_old : t -> string -> DocIdSet.t - val contains_iter : t -> string -> DocIdSet.t - val count_contains : t -> string -> int - val count : t -> string -> int - val dump : t -> unit - val get_string : t -> string_content -> string - val has_tagged_desc : t -> Tag.t -> bool - val has_tagged_foll : t -> Tag.t -> bool - val tagged_desc : t -> Tag.t -> t - val tagged_foll : t -> Tag.t -> t - val tagged_next : t -> Tag.t -> t - val subtree_tags : t -> Tag.t -> int - val is_left : t -> bool -end - -module XML = -struct - - type t - type 'a node = int - type node_kind = [`Text | `Tree ] +INCLUDE "utils.ml" - let compare : 'a node -> 'a node -> int = (-) - let equal : 'a node -> 'a node -> bool = (==) - - (* abstract type, values are pointers to a XMLTree C++ object *) +type tree +type 'a node = int +type node_kind = [`Text | `Tree ] - external int_of_node : 'a node -> int = "%identity" - - external parse_xml_uri : string -> int -> bool -> bool -> t = "caml_call_shredder_uri" - external parse_xml_string : string -> int -> bool -> bool -> t = "caml_call_shredder_string" - - external save_tree : t -> string -> unit = "caml_xml_tree_save" - external load_tree : string -> int -> t = "caml_xml_tree_load" - - - module Text = - struct - let equal : [`Text] node -> [`Text] node -> bool = equal - - (* Todo *) - external nullt : unit -> [`Text ] node = "caml_xml_tree_nullt" - let nil = nullt () - external get_text : t -> [`Text] node -> string = "caml_text_collection_get_text" - -(* let get_text t n = - if equal nil n then "" - else get_text t n -*) +let compare_node : 'a node -> 'a node -> int = (-) +let equal_node : 'a node -> 'a node -> bool = (==) + +(* abstract type, values are pointers to a XMLTree C++ object *) + +external int_of_node : 'a node -> int = "%identity" + +external parse_xml_uri : string -> int -> bool -> bool -> tree = "caml_call_shredder_uri" +external parse_xml_string : string -> int -> bool -> bool -> tree = "caml_call_shredder_string" + +external save_tree : tree -> string -> unit = "caml_xml_tree_save" +external load_tree : string -> int -> tree = "caml_xml_tree_load" + +external nullt : unit -> 'a node = "caml_xml_tree_nullt" + +let nil : 'a node = Obj.magic (-1) + +external text_get_tc_text : tree -> [`Text] node -> string = "caml_text_collection_get_text" - external is_empty : t -> [`Text ] node -> bool = "caml_text_collection_empty_text" - let is_empty t n = - (equal nil n) || is_empty t n +external text_is_empty : tree -> [`Text ] node -> bool = "caml_text_collection_empty_text" - external get_cached_text : t -> [`Text ] node -> string = "caml_text_collection_get_cached_text" - +let text_is_empty t n = + (equal_node nil n) || text_is_empty t n + - let get_text t n = - if (equal nil n) || is_empty t n then "" - else get_cached_text t n - external size : t -> int = "caml_text_collection_size" - external is_contains : t -> string -> bool = "caml_text_collection_is_contains" - external count_contains : t -> string -> int = "caml_text_collection_count_contains" - external count : t -> string -> int = "caml_text_collection_count" - external contains : t -> string -> [`Text ] node array = "caml_text_collection_contains" - end +external text_is_contains : tree -> string -> bool = "caml_text_collection_is_contains" +external text_count_contains : tree -> string -> int = "caml_text_collection_count_contains" +external text_count : tree -> string -> int = "caml_text_collection_count" +external text_contains : tree -> string -> [`Text ] node array = "caml_text_collection_contains" +external text_unsorted_contains : tree -> string -> unit = "caml_text_collection_unsorted_contains" +external text_get_cached_text : tree -> [`Text] node -> string = "caml_text_collection_get_cached_text" - module Tree = - struct +external tree_serialize : tree -> string -> unit = "caml_xml_tree_serialize" - let equal : [`Tree ] node -> [`Tree] node -> bool = equal - external serialize : t -> string -> unit = "caml_xml_tree_serialize" - external unserialize : string -> t = "caml_xml_tree_unserialize" +external tree_unserialize : string -> tree = "caml_xml_tree_unserialize" - external root : t -> [`Tree] node = "caml_xml_tree_root" - external nullt : unit -> [`Tree ] node = "caml_xml_tree_nullt" +external tree_root : tree -> [`Tree] node = "caml_xml_tree_root" - let nil = nullt () - let is_nil x = equal x nil +let tree_is_nil x = equal_node x nil - external parent : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent" - external parent_doc : t -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc" - external first_child : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child" - +external tree_parent : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent" +external tree_parent_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc" +external tree_prev_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_prev_doc" +external tree_first_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child" +external tree_tagged_child : tree -> [`Tree] node -> Tag.t -> [`Tree] node = "caml_xml_tree_tagged_child" +external tree_next_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling" +external tree_tagged_sibling : tree -> [`Tree] node -> Tag.t -> [`Tree] node = "caml_xml_tree_tagged_sibling" - - external next_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling" +external tree_prev_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling" +external tree_is_leaf : tree -> [`Tree] node -> bool = "caml_xml_tree_is_leaf" +external tree_last_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_last_child" +external tree_is_first_child : tree -> [`Tree] node -> bool = "caml_xml_tree_is_first_child" - external is_leaf : t -> [`Tree] node -> bool = "caml_xml_tree_is_leaf" +(* external tag : tree -> [`Tree ] node -> T = "caml_xml_tree_tag"*) +external tree_tag_id : tree -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id" -(* external tag : t -> [`Tree ] node -> T = "caml_xml_tree_tag"*) - external tag_id : t -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id" - let is_last t n = equal nil (next_sibling t n) - - external prev_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text" - - - external my_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text" - external next_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text" - - external text_xml_id : t -> [`Text ] node -> int = "caml_xml_tree_text_xml_id" - external node_xml_id : t -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id" - external is_ancestor : t -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor" - external tagged_desc : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc" - external tagged_foll : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_foll" - external tagged_next : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_next" - external subtree_tags : t -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags" - - let print_skel t = - let rec aux id = - if (is_nil id) - then Printf.eprintf "#\n" - else - begin - Printf.eprintf "Node %i has tag '%s' DocOrder=%i, DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s) parent_doc(my_text)=%i\n%!" - (int_of_node id) - (Tag.to_string (tag_id t id)) - (node_xml_id t id) - (int_of_node (prev_text t id)) - (Text.get_text t (prev_text t id)) - (int_of_node (my_text t id)) - (Text.get_text t (my_text t id)) - (int_of_node (next_text t id)) - (Text.get_text t (next_text t id)) - (int_of_node(parent_doc t (my_text t id))); +let tree_is_last t n = equal_node nil (tree_next_sibling t n) - aux(first_child t id); - aux(next_sibling t id); - end - in - aux (root t) - - let traversal t = - let rec aux id = - if not (is_nil id) - then - begin - (* ignore (tag t id); - ignore (Text.get_text t (prev_text t id)); - if (is_leaf t id) - then ignore (Text.get_text t (my_text t id)); - if (is_last t id) - then ignore (Text.get_text t (next_text t id)); *) - aux (first_child t id); - aux (next_sibling t id); - end - in - aux (root t) - end - - - module Binary = struct +external tree_prev_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text" - type node_content = - NC of [`Tree ] node - | SC of [`Text ] node * [`Tree ] node - type string_content = [ `Text ] node - type descr = - | Nil - | Node of node_content - | String of string_content +external tree_my_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text" +external tree_next_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text" +external tree_doc_ids : tree -> [`Tree ] node -> [`Text ] node * [`Text ] node = "caml_xml_tree_doc_ids" - type doc = t - - type t = { doc : doc; - node : descr } - - let dump { doc=t } = Tree.print_skel t - module DocIdSet = struct - include Set.Make (struct type t = string_content - let compare = (-) end) - - end - let is_node = function { node=Node(_) } -> true | _ -> false - - let get_string t (i:string_content) = Text.get_text t.doc i - open Tree - let node_of_t t = { doc= t; - node = Node(NC (root t)) } +let text_size tree = int_of_node (snd ( tree_doc_ids tree (Obj.magic 0) )) +let text_get_cached_text t x = + if x == -1 then "" + else + text_get_cached_text t x - let parse_xml_uri str = node_of_t - (MM((parse_xml_uri str - !Options.sample_factor - !Options.index_empty_texts - !Options.disable_text_collection),__LOCATION__)) - let parse_xml_string str = node_of_t - (MM((parse_xml_string str - !Options.sample_factor - !Options.index_empty_texts - !Options.disable_text_collection),__LOCATION__)) +external tree_text_xml_id : tree -> [`Text ] node -> int = "caml_xml_tree_text_xml_id" +external tree_node_xml_id : tree -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id" +external tree_is_ancestor : tree -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor" +external tree_tagged_desc : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc" +external tree_tagged_foll_below : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_below" +external tree_subtree_tags : tree -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags" - let save t str = save_tree t.doc str - let load ?(sample=64) str = node_of_t (load_tree str sample) +type int_vector +external int_vector_alloc : int -> int_vector = "caml_int_vector_alloc" +external int_vector_length : int_vector -> int = "caml_int_vector_length" +external int_vector_set : int_vector -> int -> int -> unit = "caml_int_vector_set" +external tree_select_child : tree -> [`Tree ] node -> int_vector -> [`Tree] node = "caml_xml_tree_select_child" +external tree_select_foll_sibling : tree -> [`Tree ] node -> int_vector -> [`Tree] node = "caml_xml_tree_select_foll_sibling" +external tree_select_desc : tree -> [`Tree ] node -> int_vector -> [`Tree] node = "caml_xml_tree_select_desc" +external tree_select_foll_below : tree -> [`Tree ] node -> int_vector -> [`Tree] node -> [`Tree] node = "caml_xml_tree_select_foll_below" - external pool : doc -> Tag.pool = "%identity" - let tag_pool t = pool t.doc - let compare a b = match a.node,b.node with - | Node(NC i),Node(NC j) -> compare i j - | _, Node(NC( _ )) -> 1 - | Node(SC (i,_)),Node(SC (j,_)) -> compare i j - | Node(NC( _ )),Node(SC (_,_)) -> -1 - | _, Node(SC (_,_)) -> 1 - | String i, String j -> compare i j - | Node _ , String _ -> -1 - | _ , String _ -> 1 - | Nil, Nil -> 0 - | _,Nil -> -1 +module HPtset = Hashtbl.Make(Ptset.Int) - let equal a b = (compare a b) == 0 +let vector_htbl = HPtset.create MED_H_SIZE - let string t = match t.node with - | String i -> Text.get_text t.doc i - | _ -> assert false - - let norm (n : [`Tree ] node ) = if is_nil n then Nil else Node (NC n) - - let descr t = t.node - - let nts = function - Nil -> "Nil" - | String i -> Printf.sprintf "String %i" i - | Node (NC t) -> Printf.sprintf "Node (NC %i)" (int_of_node t) - | Node (SC (t,i)) -> Printf.sprintf "Node (SC (%i,%i))" (int_of_node t) (int_of_node i) - - - let root n = { n with node = norm (Tree.root n.doc) } - let is_root n = match n.node with - | Node(NC t) when (Tree.root n.doc) == t -> true - | _ -> false - - let parent n = - let node' = - match n.node with - | Node(NC t) -> - let txt = prev_text n.doc t in - if Text.is_empty n.doc txt then - Node(NC (Tree.parent n.doc t)) - else - Node(SC (txt,t)) - | Node(SC(t,_)) -> Node (NC(parent_doc n.doc t)) - | _ -> failwith "parent" - in - { n with node = node' } - - let first_child n = - let node' = - match n.node with - | Node (NC t) when is_leaf n.doc t -> - let txt = my_text n.doc t in - if Text.is_empty n.doc txt - then Nil - else Node(SC (txt,Tree.nil)) - | Node (NC t) -> - let fs = first_child n.doc t in - let txt = prev_text n.doc fs in - if Text.is_empty n.doc txt - then norm fs - else Node (SC (txt, fs)) - | Node(SC (i,_)) -> String i - | Nil | String _ -> failwith "first_child" - in - { n with node = node'} +let ptset_to_vector s = + try + HPtset.find vector_htbl s + with + Not_found -> + let v = int_vector_alloc (Ptset.Int.cardinal s) in + let _ = Ptset.Int.fold (fun e i -> int_vector_set v i e;i+1) s 0 in + HPtset.add vector_htbl s v; v - - let next_sibling n = - let node' = - match n.node with - | Node (SC (_,ns)) -> norm ns - | Node(NC t) -> - let ns = next_sibling n.doc t in - let txt = next_text n.doc t in - if Text.is_empty n.doc txt - then norm ns - else Node (SC (txt, ns)) - | Nil | String _ -> failwith "next_sibling" + +type t = { doc : tree; + node : [`Tree] node; + ttable : (Tag.t,(Ptset.Int.t*Ptset.Int.t)) Hashtbl.t; + } + +let text_size t = text_size t.doc + +module MemUnion = Hashtbl.Make (struct + type t = Ptset.Int.t*Ptset.Int.t + let equal (x,y) (z,t) = (Ptset.Int.equal x z)&&(Ptset.Int.equal y t) + let equal a b = equal a b || equal b a + let hash (x,y) = (* commutative hash *) + let x = Ptset.Int.hash x + and y = Ptset.Int.hash y + in + if x < y then HASHINT2(x,y) else HASHINT2(y,x) + end) + +let collect_tags tree = + let h_union = MemUnion.create BIG_H_SIZE in + let pt_cup s1 s2 = + try + MemUnion.find h_union (s1,s2) + with + | Not_found -> let s = Ptset.Int.union s1 s2 + in + MemUnion.add h_union (s1,s2) s;s + in + let h_add = Hashtbl.create BIG_H_SIZE in + let pt_add t s = + let k = HASHINT2(Tag.hash t,Ptset.Int.hash s) in + try + Hashtbl.find h_add k + with + | Not_found -> let r = Ptset.Int.add t s in + Hashtbl.add h_add k r;r + in + let h = Hashtbl.create BIG_H_SIZE in + let update t sb sa = + let sbelow,safter = + try + Hashtbl.find h t + with + | Not_found -> + (Ptset.Int.empty,Ptset.Int.empty) + in + Hashtbl.replace h t (pt_cup sbelow sb, pt_cup safter sa) + in + let rec loop id acc = + if equal_node id nil + then (Ptset.Int.empty,acc) + else + let below2,after2 = loop (tree_next_sibling tree id) acc in + let below1,after1 = loop (tree_first_child tree id) after2 in + let tag = tree_tag_id tree id in + update tag below1 after2; + pt_add tag (pt_cup below1 below2), (pt_add tag after1) + in + let _ = loop (tree_root tree) Ptset.Int.empty in h + + + + + +let contains_array = ref [| |] +let contains_index = Hashtbl.create 4096 +let in_array _ i = + try + Hashtbl.find contains_index i + with + Not_found -> false + +let init_contains t s = + let a = text_contains t.doc s + in + Array.fast_sort (compare) a; + contains_array := a; + Array.iter (fun x -> Hashtbl.add contains_index x true) !contains_array + +let count_contains t s = text_count_contains t.doc s +let unsorted_contains t s = text_unsorted_contains t.doc s + +let init_naive_contains t s = + let i,j = tree_doc_ids t.doc (tree_root t.doc) + in + let regexp = Str.regexp_string s in + let matching arg = + try + let _ = Str.search_forward regexp arg 0; + in true + with _ -> false + in + let rec loop n acc l = + if n >= j then acc,l + else + let s = text_get_cached_text t.doc n in - { n with node = node'} + if matching s + then loop (n+1) (n::acc) (l+1) + else loop (n+1) acc l + in + let acc,l = loop i [] 0 in + let a = Array.create l nil in + let _ = List.fold_left (fun cpt e -> a.(cpt) <- e; (cpt-1)) (l-1) acc + in + contains_array := a - - let left = first_child - let right = next_sibling + + +module DocIdSet = struct + include Set.Make (struct type t = [`Text] node + let compare = compare_node end) - let id = - function { doc=d; node=Node(NC n)} -> node_xml_id d n - | { doc=d; node=Node(SC (i,_) )} -> text_xml_id d i - | _ -> failwith "id" - - let tag = - function { node=Node(SC _) } -> Tag.pcdata - | { doc=d; node=Node(NC n)} -> tag_id d n - | _ -> failwith "tag" +end +let is_nil t = t.node == nil + +let is_node t = t.node != nil + +let node_of_t t = + let _ = Tag.init (Obj.magic t) in + let table = collect_tags t + in + { doc= t; + node = tree_root t; + ttable = table; + } +let finalize _ = Printf.eprintf "Release the string list !\n%!" +;; + +let parse f str = + node_of_t + (f str + !Options.sample_factor + !Options.index_empty_texts + !Options.disable_text_collection) -(* let tag_id = - function { node=Node(SC _) } -> () - | { doc=d; node=Node(NC n)} -> tag_id d n - | _ -> () -*) - let string_below t id = - let strid = parent_doc t.doc id in - match t.node with - | Node(NC(i)) -> - (Tree.equal i strid) || (is_ancestor t.doc i strid) - | Node(SC(i,_)) -> Text.equal i id - | _ -> false - - - let tagged_foll t tag = - if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_foll" - else match t with - | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_foll d n tag) } - | { doc=d; node=Node(SC (_,n)) } when is_nil n -> { t with node= Nil } - | { doc=d; node=Node(SC (_,n)) } -> - let nnode = - if tag_id d n == tag then n - else - let n' = tagged_desc d n tag in - if is_nil n' then tagged_foll d n tag - else n' - in {t with node= norm nnode} - | _ -> { t with node=Nil } - +let parse_xml_uri str = parse parse_xml_uri str +let parse_xml_string str = parse parse_xml_string str - let tagged_desc t tag = - if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_desc" - else match t with - | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_desc d n tag) } - | _ -> { t with node=Nil } + +external pool : tree -> Tag.pool = "%identity" +let save t str = (save_tree t.doc str) +;; - let tagged_next t tag = - if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_next" - else match t with - | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_next d n tag) } - | { doc=d; node=Node(SC (_,n)) } -> { t with node = norm (tagged_next d n tag) } - | _ -> { t with node=Nil } +let load ?(sample=64) str = + node_of_t (load_tree str sample) + - let subtree_tags t tag = - match t with - { doc = d; node = Node(NC n) } -> subtree_tags d n tag - | _ -> 0 +let tag_pool t = pool t.doc + +let compare a b = a.node - b.node - let has_tagged_foll t tag = is_node (tagged_foll t tag) - let has_tagged_desc t tag = is_node (tagged_desc t tag) +let equal a b = a.node == b.node + +let nts = function + -1 -> "Nil" + | i -> Printf.sprintf "Node (%i)" i + +let dump_node t = nts t.node - let contains t s = - Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s) +let mk_nil t = { t with node = nil } +let root n = { n with node = tree_root n.doc } +let is_root n = n.node == (tree_root n.doc) + +let is_left n = tree_is_first_child n.doc n.node - let contains_old t s = - let regexp = Str.regexp_string s in - let matching arg = - try - let _ = Str.search_forward regexp arg 0; - in true - with _ -> false - in - let rec find t acc = match t.node with - | Nil -> acc - | String i -> - if matching (string t) then DocIdSet.add i acc else acc - | Node(_) -> (find (left t )) ((find (right t)) acc) - in - find t DocIdSet.empty +let is_below_right t1 t2 = tree_is_ancestor t1.doc (tree_parent t1.doc t1.node) t2.node +let parent n = { n with node = tree_parent n.doc n.node } - let contains_iter t s = - let regexp = Str.regexp_string s in - let matching arg = - try - let _ = Str.search_forward regexp arg 0; - in true - with _ -> false - in - let size = Text.size t.doc in - let rec find acc n = - if n == size then acc - else - find - (if matching (Text.get_cached_text t.doc (Obj.magic n)) then - DocIdSet.add (Obj.magic n) acc - else acc) (n+1) - in - find DocIdSet.empty 0 +let first_child n = { n with node = tree_first_child n.doc n.node } +let tagged_child tag n = { n with node = tree_tagged_child n.doc n.node tag } +let select_child ts n = { n with node = tree_select_child n.doc n.node (ptset_to_vector ts) } + +let next_sibling n = { n with node = tree_next_sibling n.doc n.node } +let tagged_sibling tag n = { n with node = tree_tagged_sibling n.doc n.node tag } +let select_sibling ts n = { n with node = tree_select_foll_sibling n.doc n.node (ptset_to_vector ts) } + +let next_sibling_ctx n _ = next_sibling n +let tagged_sibling_ctx tag n _ = tagged_sibling tag n +let select_sibling_ctx ts n _ = select_sibling ts n + +let id t = tree_node_xml_id t.doc t.node + +let tag t = if t.node == nil then Tag.nullt else tree_tag_id t.doc t.node + +let tagged_desc tag n = { n with node = tree_tagged_desc n.doc n.node tag } +let select_desc ts n = { n with node = tree_select_desc n.doc n.node (ptset_to_vector ts) } +let tagged_foll_ctx tag t ctx = + { t with node = tree_tagged_foll_below t.doc t.node tag ctx.node } +let select_foll_ctx ts n ctx = { n with node = tree_select_foll_below n.doc n.node (ptset_to_vector ts) ctx.node } +let last_idx = ref 0 +let array_find a i j = + let l = Array.length a in + let rec loop idx x y = + if x > y || idx >= l then nil + else + if a.(idx) >= x then if a.(idx) > y then nil else (last_idx := idx;a.(idx)) + else loop (idx+1) x y + in + if a.(0) > j || a.(l-1) < i then nil + else loop !last_idx i j - let count_contains t s = Text.count_contains t.doc s - let count t s = Text.count t.doc s - let is_left t = - let u = left (parent t) in - (id t) == (id u) + let count t s = text_count t.doc s - let print_xml_fast outc t = - let rec loop ?(print_right=true) t = match t.node with - | Nil -> () - | String (s) -> output_string outc (string t) - | Node _ when Tag.equal (tag t) Tag.pcdata -> - loop (left t); - if print_right then loop (right t) + let print_xml_fast outc t = + let rec loop ?(print_right=true) t = + if t.node != nil + then + let tagid = tree_tag_id t.doc t.node in + if tagid==Tag.pcdata + then output_string outc (text_get_cached_text t.doc t.node); + if print_right + then loop (next_sibling t) - | Node (_) -> - let tg = Tag.to_string (tag t) in - let l = left t - and r = right t + else + let tagstr = Tag.to_string tagid in + let l = first_child t + and r = next_sibling t in output_char outc '<'; - output_string outc tg; - ( match l.node with - Nil -> output_string outc "/>" - | String _ -> assert false - | Node(_) when Tag.equal (tag l) Tag.attribute -> - (loop_attributes (left l); - match (right l).node with - | Nil -> output_string outc "/>" - | _ -> - output_char outc '>'; - loop (right l); - output_string outc "' ) - | _ -> - output_char outc '>'; - loop l; - output_string outc "' - );if print_right then loop r - and loop_attributes a = - - match a.node with - | Node(_) -> - let value = - match (left a).node with - | Nil -> "" - | _ -> string (left(left a)) - in - output_char outc ' '; - output_string outc (Tag.to_string (tag a)); - output_string outc "=\""; - output_string outc value; - output_char outc '"'; - loop_attributes (right a) - | _ -> () - in + output_string outc tagstr; + if l.node == nil then output_string outc "/>" + else + if (tag l) == Tag.attribute then + begin + loop_attributes (first_child l); + if (next_sibling l).node == nil then output_string outc "/>" + else + begin + output_char outc '>'; + loop (next_sibling l); + output_string outc "'; + end; + end + else + begin + output_char outc '>'; + loop l; + output_string outc "'; + end; + if print_right then loop r + and loop_attributes a = + let s = (Tag.to_string (tag a)) in + let attname = String.sub s 3 ((String.length s) -3) in + output_char outc ' '; + output_string outc attname; + output_string outc "=\""; + output_string outc (text_get_cached_text t.doc + (tree_my_text a.doc (first_child a).node)); + output_char outc '"'; + loop_attributes (next_sibling a) + in loop ~print_right:false t - - + + let print_xml_fast outc t = - if Tag.to_string (tag t) = "" then + if (tag t) = Tag.document_node then print_xml_fast outc (first_child t) - else print_xml_fast outc t + else print_xml_fast outc t - let traversal t = Tree.traversal t.doc - let full_traversal t = - let rec aux n = - match n.node with - | Nil -> () - | String i -> () (*ignore(Text.get_text t.doc i) *) - | Node(_) -> - (* tag_id n; *) - aux (first_child n); - aux (next_sibling n) - in aux t - - let print_stats _ = () - end - -end - - - -IFDEF DEBUG -THEN -module DEBUGTREE - = struct - - let _timings = Hashtbl.create 107 - - - let time _ref f arg = - let t1 = Unix.gettimeofday () in - let r = f arg in - let t2 = Unix.gettimeofday () in - let t = (1000. *.(t2 -. t1)) in - - let (time,count) = try - Hashtbl.find _timings _ref - with - | Not_found -> 0.,0 - in - let time = time+. t - and count = count + 1 - in - Hashtbl.replace _timings _ref (time,count);r - include XML.Binary +let tags_below t tag = + fst(Hashtbl.find t.ttable tag) +let tags_after t tag = + snd(Hashtbl.find t.ttable tag) - let first_child_ doc node = - time ("XMLTree.FirstChild()") (XML.Tree.first_child doc) node - let next_sibling_ doc node = - time ("XMLTree.NextSibling()") (XML.Tree.next_sibling doc) node +let tags t tag = Hashtbl.find t.ttable tag - let is_empty_ text node = - time ("TextCollection.IsEmpty()") (XML.Text.is_empty text) node - let prev_text_ doc node = - time ("XMLTree.PrevText()") (XML.Tree.prev_text doc) node +let rec binary_parent t = + if tree_is_first_child t.doc t.node + then { t with node = tree_parent t.doc t.node } + else { t with node = tree_prev_sibling t.doc t.node } - let my_text_ doc node = - time ("XMLTree.MyText()") (XML.Tree.my_text doc) node - - let next_text_ doc node = - time ("XMLTree.NextText()") (XML.Tree.next_text doc) node +let doc_ids (t:t) : (int*int) = + (Obj.magic (tree_doc_ids t.doc t.node)) - let is_leaf_ doc node = - time ("XMLTree.IsLeaf()") (XML.Tree.is_leaf doc ) node - - let node_xml_id_ doc node = - time ("XMLTree.NodeXMLId()") (XML.Tree.node_xml_id doc ) node - - let text_xml_id_ doc node = - time ("XMLTree.TextXMLId()") (XML.Tree.text_xml_id doc ) node - - - let first_child n = - let node' = - match n.node with - | Node (NC t) when is_leaf_ n.doc t -> - let txt = my_text_ n.doc t in - if is_empty_ n.doc txt - then Nil - else Node(SC (txt,XML.Tree.nil)) - | Node (NC t) -> - let fs = first_child_ n.doc t in - let txt = prev_text_ n.doc fs in - if is_empty_ n.doc txt - then norm fs - else Node (SC (txt, fs)) - | Node(SC (i,_)) -> String i - | Nil | String _ -> failwith "first_child" - in - { n with node = node'} +let subtree_tags t tag = + if t.node == nil then 0 else + tree_subtree_tags t.doc t.node tag - - let next_sibling n = - let node' = - match n.node with - | Node (SC (_,ns)) -> norm ns - | Node(NC t) -> - let ns = next_sibling_ n.doc t in - let txt = - if XML.Tree.is_nil ns then - next_text_ n.doc t - else prev_text_ n.doc ns - in - if is_empty_ n.doc txt - then norm ns - else Node (SC (txt, ns)) - | Nil | String _ -> failwith "next_sibling" - in - { n with node = node'} +let get_text t = + let tid = tree_my_text t.doc t.node in + if tid == nil then "" else + let a, b = tree_doc_ids t.doc (tree_root t.doc) in + let _ = Printf.eprintf "Trying to take text %i of node %i in %i %i\n%!" tid t.node a b in + text_get_cached_text t.doc tid - let id = - function { doc=d; node=Node(NC n)} -> node_xml_id_ d n - | { doc=d; node=Node(SC (i,_) )} -> text_xml_id_ d i - | _ -> failwith "id" - - (* Wrapper around critical function *) - let string t = time ("TextCollection.GetText()") (string) t - let left = first_child - let right = next_sibling - let tag t = time ("XMLTree.GetTag()") (tag) t - - let print_stats ppf = - let total_time,total_calls = - Hashtbl.fold (fun _ (t,c) (tacc,cacc) -> - tacc+. t, cacc + c) _timings (0.,0) - in - Format.fprintf ppf - "Timing : Function Name, number of calls,%% of total calls, mean time, total time, %% of total time\n%!"; - Hashtbl.iter (fun name (time,count) -> - Format.fprintf ppf "%-27s% 8d\t% 4.2f%%\t% 4.6f ms\t% 4.6f ms\t%04.2f%%\n%!" - name - count - (100. *. (float_of_int count)/.(float_of_int total_calls)) - (time /. (float_of_int count)) - time - (100. *. time /. total_time)) _timings; - Format.fprintf ppf "-------------------------------------------------------------------\n"; - Format.fprintf ppf "%-27s% 8d\t% 4.0f%%\t########## ms\t% 4.6f ms\t% 4.0f%%\n%!" - "Total" total_calls 100. total_time 100. - - - let print_xml_fast outc t = - let rec loop ?(print_right=true) t = match t.node with - | Nil -> () - | String (s) -> output_string outc (string t) - | Node _ when Tag.equal (tag t) Tag.pcdata -> loop (left t); loop (right t) - - | Node (_) -> - let tg = Tag.to_string (tag t) in - let l = left t - and r = right t - in - output_char outc '<'; - output_string outc tg; - ( match l.node with - Nil -> output_string outc "/>" - | String _ -> assert false - | Node(_) when Tag.equal (tag l) Tag.attribute -> - (loop_attributes (left l); - match (right l).node with - | Nil -> output_string outc "/>" - | _ -> - output_char outc '>'; - loop (right l); - output_string outc "' ) - | _ -> - output_char outc '>'; - loop l; - output_string outc "' - );if print_right then loop r - and loop_attributes a = - - match a.node with - | Node(_) -> - let value = - match (left a).node with - | Nil -> "" - | _ -> string (left(left a)) - in - output_char outc ' '; - output_string outc (Tag.to_string (tag a)); - output_string outc "=\""; - output_string outc value; - output_char outc '"'; - loop_attributes (right a) - | _ -> () - in - loop ~print_right:false t +let dump_tree fmt t = + let rec loop tree n = + if tree != nil then + let tag = (tree_tag_id t.doc tree ) in + let tagstr = Tag.to_string tag in + let tab = String.make n ' ' in - - let print_xml_fast outc t = - if Tag.to_string (tag t) = "" then - print_xml_fast outc (first_child t) - else print_xml_fast outc t + if tag == Tag.pcdata || tag == Tag.attribute_data + then + Format.fprintf fmt "%s<%s>%s\n" + tab tagstr (text_get_cached_text t.doc (tree_my_text t.doc tree)) tagstr + else begin + Format.fprintf fmt "%s<%s>\n" tab tagstr; + loop (tree_first_child t.doc tree) (n+2); + Format.fprintf fmt "%s\n%!" tab tagstr; + end; + loop (tree_next_sibling t.doc tree) n + in + loop (tree_root t.doc) 0 +;; - - -end - -module Binary = DEBUGTREE -ELSE -module Binary = XML.Binary -END (* IFDEF DEBUG *)