INCLUDE "debug.ml"
INCLUDE "utils.ml"
+
module type S =
sig
type t
type elt = Tree.node
val empty : t
+ val var : (int*State.t) -> t
+ val close : ((int*State.t), t) Hashtbl.t -> t -> t
+ val is_open : t -> bool
val singleton : elt -> t
val cons : elt -> t -> t
val snoc : 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
+ val serialize : string -> bool -> Tree.t -> t -> unit
+
end
module Count : S with type t = int =
type elt = Tree.node
let empty = 0
+ let var _ = empty
+ let is_open _ = false
+ let close _ x = x
let singleton _ = 1
let cons _ x = x+1
let snoc x _ = x+1
let fold _ _ _ = failwith "fold not implemented"
let map _ _ = failwith "map not implemented"
let length x = x
- let serialize _ _ _ = ()
+ let serialize f b _ x =
+ let o = open_out f in
+ if not b then output_string o "<xml_result>\n";
+ output_string o (string_of_int x);
+ output_char o '\n';
+ if not b then output_string o "</xml_result>\n";
+ close_out o
end
type clist =
struct
type t = Tree.node mat
type elt = Tree.node
-
+ let is_open _ = false
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 }
{ 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 var _ = empty
+ let close _ x = x
let conscat e l1 l2 =
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 len = Tree.subtree_tags tree node tag in
+ if len == 0 then empty
+ else
+ { clist = SubtreeTags(tree, node, tag);
+ length = len }
+
let subtree_elements tree node =
- { clist = SubtreeElts(tree, node);
- length = Tree.subtree_elements tree node }
+ let len = Tree.subtree_elements tree node in
+ if len == 0 then empty
+ else
+ { clist = SubtreeElts(tree, node);
+ length = len }
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 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
+ if tag == Tag.document_node then
+ Tree.first_element tree t
+ else t
+*)
let element_fold f tree t acc =
let rec loop node acc =
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 t' = Tree.first_element tree t in loop 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 newf = fun e () -> f e in
+ element_fold newf tree t ()
let tag_fold f tree t tag acc =
let rec loop close node acc =
let length l = l.length
- let serialize name v l =
+ let serialize name b 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;
+ if not b then ignore (Unix.write fd "<xml_result>\n" 0 13);
+ if l.length > 0 then begin
+ iter (fun node -> Tree.print_xml v node fd) l;
+ Tree.flush v fd;
+ end;
+ if not b then ignore (Unix.write fd "</xml_result>\n" 0 14);
finish fd
end
(Obj.magic node)
let debug l = debug_clist l.clist
+
+
+
+module Partial(N : S) : S =
+struct
+
+ type elt = Tree.node
+ type t = { env : ((int*State.t), t) Hashtbl.t;
+ elem : list;
+ opened : bool;
+ }
+ and list =
+ | Var of (int * State.t)
+ | Nil
+ | Cons of elt * list
+ | Concat of list * list
+ | Lambda of t
+
+ let dummy = Hashtbl.create 0
+ let empty = { env = dummy;
+ elem = Nil;
+ opened = false }
+ let is_open t = t.opened
+
+
+ let close h t =
+ {empty with elem =
+ Lambda { t with env = h; opened = false } }
+
+ let singleton i = { empty with elem = Cons(i, Nil) }
+ let cons e t = { t with elem = Cons(e, t.elem) }
+ let concat t1 t2 =
+ { t1 with elem = Concat (t1.elem, t2.elem) }
+
+ let snoc t e = concat t (singleton e)
+ let concat3 t1 t2 t3 = concat t1 (concat t2 t3)
+ let concat4 t1 t2 t3 t4 = concat (concat t1 t2) (concat t3 t4)
+ let conscat e t1 t2 = cons e (concat t1 t2)
+ let conscat3 e t1 t2 t3 = cons e (concat3 t1 t2 t3)
+ let conscat4 e t1 t2 t3 t4 = cons e (concat4 t1 t2 t3 t4)
+ let subtree_tags _ = failwith "not implemented"
+ let subtree_elements _ = failwith "not_implemented"
+
+ let iter f t =
+ let rec loop t =
+ loop_list t.env t.elem
+ and loop_list h = function
+ | Nil -> ()
+ | Var i -> loop (Hashtbl.find h i)
+ | Cons (e, l) -> f e; loop_list h l
+ | Concat (l1, l2) -> loop_list h l1; loop_list h l2
+ | Lambda t -> loop t
+ in
+ loop t
+
+ let fold f t acc =
+ let rec loop t acc =
+ loop_list t.env acc t.elem
+ and loop_list h acc = function
+ | Nil -> acc
+ | Var i -> loop (try Hashtbl.find h i with Not_found -> let a,b = i in Printf.eprintf "%i,%i not found\n%!" a b; empty) acc
+ | Cons (e, l) -> loop_list h (f e acc) l
+ | Concat (l1, l2) -> loop_list h (loop_list h acc l1) l2
+ | Lambda t -> loop t acc
+ in
+ loop t acc
+
+
+ let rec dump t =
+ Hashtbl.iter (fun (i,j) t ->
+ Format.eprintf "%i, %a ->" i State.print j;
+ dump t;
+ Format.eprintf "----------------\n%!";
+ ) t.env;
+ dump_list t.elem
+ and dump_list = function
+ | Nil -> ()
+ | Var (i,j) -> Format.eprintf "Var(%i, %a) " i State.print j;
+ | Cons (e, l) -> Format.eprintf "%i " (Node.to_int e); dump_list l
+ | Concat (l1, l2) -> dump_list l1 ; dump_list l2
+ | Lambda t -> dump t
+
+
+ let length t = fold (fun _ acc -> 1 + acc) t 0
+
+
+ let var i =
+ { empty with elem = Var i; opened = true }
+
+ let serialize _ = failwith "not implemented"
+end
projects / SXSI / xpathcomp.git / blobdiff