- 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'}
+
+type t = {
+ doc : tree;
+ ttable : (Tag.t,(Ptset.Int.t*Ptset.Int.t*Ptset.Int.t*Ptset.Int.t)) Hashtbl.t;
+}
+let subtree_size t i = tree_subtree_size t.doc i
+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)
+
+module MemAdd = Hashtbl.Make (
+ struct
+ type t = Tag.t*Ptset.Int.t
+ let equal (x,y) (z,t) = (x == z)&&(Ptset.Int.equal y t)
+ let hash (x,y) = HASHINT2(x,Ptset.Int.hash y)
+ 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 = MemAdd.create BIG_H_SIZE in
+ let pt_add t s =
+ try MemAdd.find h_add (t,s)
+ with
+ | Not_found -> let r = Ptset.Int.add t s in
+ MemAdd.add h_add (t,s) r;r
+ in
+ let h = Hashtbl.create BIG_H_SIZE in
+ let update t sc sb ss sa =
+ let schild,sbelow,ssibling,safter =
+ try
+ Hashtbl.find h t
+ with
+ | Not_found ->
+ (Ptset.Int.empty,Ptset.Int.empty,Ptset.Int.empty,Ptset.Int.empty)
+ in
+ Hashtbl.replace h t
+ (pt_cup sc schild,pt_cup sbelow sb, pt_cup ssibling ss, pt_cup safter sa)
+ in
+ let rec loop_right id acc_sibling acc_after=
+ if id == nil
+ then (acc_sibling,acc_after)
+ else
+ let sibling2,after2 = loop_right (tree_next_sibling tree id) acc_sibling acc_after in
+ let child1,below1 = loop_left (tree_first_child tree id) after2 in
+ let tag = tree_tag_id tree id in
+ update tag child1 below1 sibling2 after2;
+ (pt_add tag sibling2, (pt_add tag (pt_cup after2 below1)))
+ and loop_left id acc_after =
+ if id == nil
+ then (Ptset.Int.empty,Ptset.Int.empty)
+ else
+ let sibling2,after2 = loop_right (tree_next_sibling tree id) Ptset.Int.empty acc_after in
+ let child1,below1 = loop_left (tree_first_child tree id) after2 in
+ let tag = tree_tag_id tree id in
+ update tag child1 below1 sibling2 after2;
+ (pt_add tag sibling2,(pt_add tag (pt_cup after2 below1)))
+ in
+ let _ = loop_left (tree_root tree) Ptset.Int.empty in h
+
+
+