--- /dev/null
+INCLUDE "debug.ml"
+INCLUDE "utils.ml"
+
+module type S =
+ sig
+ type t
+ type elt = Tree.node
+ val empty : t
+ val singleton : elt -> t
+ val cons : elt -> t -> t
+ val snoc : t -> elt -> t
+ val concat : t -> t -> t
+ val concat3 : t -> t -> t -> t
+ val concat4 : t -> t -> t -> t -> t
+ val conscat : elt -> t -> t -> t
+ val conscat3 : elt -> t -> t -> t -> t
+ val conscat4 : elt -> t -> t -> t -> t -> t
+ val subtree_tags : Tree.t -> elt -> Tag.t -> t
+ val subtree_elements : Tree.t -> elt -> t
+ val iter : ( elt -> unit) -> t -> unit
+ val fold : ( elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val length : t -> int
+ val serialize : string -> Tree.t -> t -> unit
+ end
+
+module Count : S with type t = int =
+ struct
+ type t = int
+ type elt = Tree.node
+
+ let empty = 0
+ let singleton _ = 1
+ let cons _ x = x+1
+ let snoc x _ = x+1
+ let concat x y = x + y
+ let concat3 x y z = x + y + z
+ let concat4 x y z t = x + y + z + t
+ let conscat _ x y = 1 + x + y
+ let conscat3 _ x y z = 1 + x + y + z
+ let conscat4 _ x y z t = 1 + x + y + z + t
+ let subtree_tags tree node tag = Tree.subtree_tags tree node tag
+ let subtree_elements tree node = Tree.subtree_elements tree node
+ let iter _ _ = failwith "iter not implemented"
+ let fold _ _ _ = failwith "fold not implemented"
+ let map _ _ = failwith "map not implemented"
+ let length x = x
+ let serialize _ _ _ = ()
+ end
+
+type clist =
+ | Nil
+ | Cons of Tree.node * clist
+ | Concat of clist * clist
+ | ConsCat of Tree.node * clist * clist
+ | SubtreeTags of Tree.t * Tree.node * Tag.t
+ | SubtreeElts of Tree.t * Tree.node
+
+
+type 'a mat = { mutable clist : clist;
+ mutable length : int }
+
+module Mat : S with type t = Tree.node mat =
+ struct
+ type t = Tree.node mat
+ type elt = Tree.node
+
+ let empty = { clist = Nil; length = 0 }
+ let singleton e = { clist = Cons(e, Nil) ; length = 1 }
+ let cons e l = { clist = Cons(e, l.clist); length = l.length + 1 }
+ let concat l1 l2 =
+ let ll1 = l1.length in
+ if ll1 == 0 then l2 else
+ let ll2 = l2.length in if ll2 == 0 then l1 else
+ { clist = Concat(l1.clist, l2.clist); length = ll1 + ll2 }
+
+ let snoc l e = concat l (singleton e)
+(*
+ let _total = ref 0
+ let _empty = ref 0
+ let () = at_exit (fun () -> Printf.eprintf "Dummy concatenations: %i/%i\n%!" !_empty !_total)
+
+ let concat l1 l2 =
+ let l = concat l1 l2 in
+ if l.length == 0 then incr _empty;
+ incr _total;
+ l
+*)
+ let concat3 l1 l2 l3 = concat l1 (concat l2 l3)
+ let concat4 l1 l2 l3 l4 = concat (concat l1 l2) (concat l3 l4)
+
+
+ let conscat e l1 l2 =
+ let ll1 = l1.length in
+ if ll1 == 0 then cons e l2 else
+ let ll2 = l2.length in if ll2 == 0 then cons e l1 else
+ { clist = ConsCat(e, l1.clist, l2.clist); length = 1 + ll1 + ll2 }
+
+(* let conscat e l1 l2 = cons e (concat l1 l2) *)
+
+ let conscat3 e l1 l2 l3 = conscat e l1 (concat l2 l3)
+ let conscat4 e l1 l2 l3 l4 = conscat e l1 (concat l2 (concat l3 l4))
+
+ let subtree_tags tree node tag =
+ { clist = SubtreeTags(tree, node, tag);
+ length = Tree.subtree_tags tree node tag }
+ let subtree_elements tree node =
+ { clist = SubtreeElts(tree, node);
+ length = Tree.subtree_elements tree node }
+
+ let fst_tagged tree t tag =
+ if Tree.tag tree t == tag then t
+ else Tree.tagged_descendant tree t tag
+
+ let fst_element tree t =
+ let tag = Tree.tag tree t in
+ let t = if Ptset.Int.mem tag
+ (Ptset.Int.remove Tag.document_node (Tree.element_tags tree))
+ then t
+ else Tree.first_element tree t
+ in Tree.first_element tree t
+
+ let element_fold f tree t acc =
+ let rec loop node acc =
+ if node == Tree.nil then acc
+ else
+ let acc = f node acc in
+ let acc' = loop (Tree.first_element tree node) acc in
+ loop (Tree.next_element tree node) acc'
+ in
+ loop (fst_element tree t) acc
+
+ let element_iter f tree t =
+ let rec loop node =
+ if node != Tree.nil then begin
+ f node;
+ loop (Tree.first_element tree node);
+ loop (Tree.next_element tree node)
+ end
+ in
+ let t' = fst_element tree t in loop t'
+
+ let tag_fold f tree t tag acc =
+ let rec loop close node acc =
+ if node == Tree.nil then acc
+ else
+ let acc = f node acc in
+ let acc' = loop close (Tree.tagged_descendant tree node tag) acc in
+ loop close (Tree.tagged_following_before tree node tag close) acc'
+ in
+ let t = fst_tagged tree t tag in
+ loop (Tree.closing tree t) t acc
+
+ let tag_iter f tree t tag =
+ let rec loop close node =
+ if node != Tree.nil then begin
+ f node;
+ loop close (Tree.tagged_descendant tree node tag);
+ loop close (Tree.tagged_following_before tree node tag close);
+ end
+ in
+ let t' = fst_tagged tree t tag in
+ loop (Tree.closing tree t) t'
+
+ let fold f l acc =
+ let rec loop l acc =
+ match l with
+ | Nil -> acc
+ | Cons(e, ll) -> loop ll (f e acc)
+ | Concat(l1, l2) -> loop l2 (loop l1 acc)
+ | ConsCat(e, l1, l2) -> loop l2 (loop l1 (f e acc))
+ | SubtreeTags(tree, t, tag) -> tag_fold f tree t tag acc
+ | SubtreeElts(tree, t) -> element_fold f tree t acc
+ in
+ loop l.clist acc
+
+ let iter f l =
+ let rec loop l =
+ match l with
+ | Nil -> ()
+ | Cons(e, l) -> f e; loop l
+ | Concat(l1, l2) -> loop l1; loop l2
+ | ConsCat(e, l1, l2) -> f e; loop l1; loop l2
+ | SubtreeTags(tree, t, tag) -> tag_iter f tree t tag
+ | SubtreeElts(tree, t) ->
+ element_iter f tree t
+ in
+ loop l.clist
+
+ let length l = l.length
+
+ let serialize name v l =
+ let fd, finish =
+ if name = "-" then Unix.stdout, ignore
+ else
+ Unix.openfile name [ Unix.O_WRONLY; Unix.O_TRUNC; Unix.O_CREAT ] 0o666,
+ Unix.close
+ in
+ iter (fun node -> Tree.print_xml v node fd) l;
+ Tree.flush v fd;
+ finish fd
+
+ end
+let rec debug_clist =
+ function
+ Nil -> Printf.eprintf "Nil"
+ | Cons(e, clist) ->
+ Printf.eprintf "Cons(%i," (Obj.magic e);
+ debug_clist clist;
+ Printf.eprintf ")";
+ | Concat(clist1, clist2) ->
+ Printf.eprintf "Concat(";
+ debug_clist clist1;
+ Printf.eprintf ",";
+ debug_clist clist2;
+ Printf.eprintf ")";
+ | ConsCat(_, clist1, clist2) ->
+ Printf.eprintf "Concat(";
+ debug_clist clist1;
+ Printf.eprintf ",";
+ debug_clist clist2;
+ Printf.eprintf ")";
+
+ | SubtreeTags(tree, node, tag) ->
+ Printf.eprintf "SubtreeTags(tree, %i, %s)"
+ (Obj.magic node)
+ (Tag.to_string tag);
+ | SubtreeElts(tree, node) ->
+ Printf.eprintf "SubtreeElts(tree, %i)"
+ (Obj.magic node)
+
+let debug l = debug_clist l.clist
projects / SXSI / xpathcomp.git / blobdiff