From: kim Date: Tue, 27 Jan 2009 10:48:06 +0000 (+0000) Subject: . X-Git-Url: http://git.nguyen.vg/gitweb/?a=commitdiff_plain;h=24fdea81b5506233d139bd7d72364a190bef35b8;p=SXSI%2Fxpathcomp.git . git-svn-id: svn+ssh://idea.nguyen.vg/svn/sxsi/trunk/xpathcomp@67 3cdefd35-fc62-479d-8e8d-bae585ffb9ca --- diff --git a/Makefile b/Makefile index b7084f0..4b37144 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ MLOBJS = $(MLSRCS:.ml=.cmx) MLCINT = $(MLISRCS:.mli=.cmi) -OCAMLPACKAGES = unix,ulex,camlp4 +OCAMLPACKAGES = str,unix,ulex,camlp4 PPINCLUDES=$(OCAMLINCLUDES:%=-ppopt %) @@ -44,24 +44,25 @@ ifeq ($(PROFILE), true) SYNT_PROF = $(SYNT_DEBUG) -ppopt -DPROFILE endif - OCAMLFIND = ocamlfind OCAMLMKLIB = ocamlmklib OCAMLDEP = ocamldep -LINK=$(OCAMLOPT) -linkpkg camlp4lib.cmxa +#Ugly but seems difficult with a makefile + +LINK=$(OCAMLOPT) -linkpkg `ocamlc -version | grep -q "3.11.0" && echo dynlink.cmxa` camlp4lib.cmxa SYNTAX= -syntax camlp4o $(PPINCLUDES) -ppopt pa_macro.cmo $(SYNT_PROF) LIBS=-lxml2 -lxml++-2.6 -lglibmm-2.4 -lgobject-2.0 -lglib-2.0 -lsigc-2.0 -all: libcamlshredder.a $(MLOBJS) +all: version libcamlshredder.a $(MLOBJS) + $(OCAMLFIND) $(LINK) -o main -package "$(OCAMLPACKAGES)" $(SYNTAX) -cclib \ "$(LIBS) ./libcamlshredder.a" $(MLOBJS) .SUFFIXES: .ml .mli .cmx .cmi .cpp -.PHONY:compute_depend - +.PHONY:compute_depend version .cpp.o: $(CXX) $(CXXINCLUDES) -c $(CXXFLAGS) $< .ml.cmx: @@ -69,7 +70,7 @@ all: libcamlshredder.a $(MLOBJS) .mli.cmi: $(OCAMLFIND) $(OCAMLOPT) -package "$(OCAMLPACKAGES)" $(SYNTAX) -c $< -libcamlshredder.a: $(CXXOBJECTS) +libcamlshredder.a: $(CXXOBJECTS) XMLTree/XMLTree.a mkdir -p .libs/ cd .libs/ && ar x ../XMLTree/XMLTree.a $(OCAMLMKLIB) -o camlshredder -custom $(CXXOBJECTS) ./.libs/*.o $(LIBS) @@ -79,6 +80,14 @@ clean: rm -f *~ *.cm* *.[oa] *.so main .libs +testSuccint: $(CXXOBJECTS) XMLTree/XMLTree.a + mkdir -p .libs/ + cd .libs/ && ar x ../XMLTree/XMLTree.a + $(CXX) -o testSuccint $(CXXFLAGS) $(CXXINCLUDES) XMLDocShredder.o \ +SXSIStorageInterface.o StorageInterface.o ./.libs/*.o \ +$(LIBS) testSuccint.cpp + rm -rf .libs + SXSIStorageInterface.o: SXSIStorageInterface.h SXSIStorageInterface.cpp StorageInterface.h StorageInterface.o: StorageInterface.h XMLDocShredder.o: XMLDocShredder.h XMLDocShredder.cpp OCamlStorageInterface.h StorageInterface.h diff --git a/OCamlDriver.cpp b/OCamlDriver.cpp index 490e007..636a952 100644 --- a/OCamlDriver.cpp +++ b/OCamlDriver.cpp @@ -68,36 +68,32 @@ extern "C" CAMLprim value caml_call_shredder_string(value data){ } void traversal_rec(XMLTree* tree, treeNode id){ + DocID tid; if (id == NULLT) return; - char * tag = (char*)tree->GetTagName(tree->Tag(id)); - if (id) { - DocID tid = tree->PrevText(id); - char * data = (char *) (tree->getTextCollection())->GetText(tid); - if (tree->IsLeaf(id)){ - tid = tree->MyText(id); - data = (char*) (tree->getTextCollection())->GetText(tid); - }; + int tag = tree->Tag(id); + if (id) { + tid = tree->PrevText(id); + char * data = (char *) (tree->getTextCollection())->GetText(tid); + if (tree->IsLeaf(id)){ + tid = tree->MyText(id); + + data = (char*) (tree->getTextCollection())->GetText(tid); + }; - if (tree->NextSibling(id) == NULLT){ - tid = tree->NextText(id); - data = (char*) (tree->getTextCollection())->GetText(tid); - }; - } - traversal_rec(tree,tree->FirstChild(id)); - traversal_rec(tree,tree->NextSibling(id)); - return; + if (tree->NextSibling(id) == NULLT){ + tid = tree->NextText(id); + data = (char*) (tree->getTextCollection())->GetText(tid); + }; + }; + traversal_rec(tree,tree->FirstChild(id)); + traversal_rec(tree,tree->NextSibling(id)); + return; } -void traversal (XMLTree* tree){ - traversal_rec(tree, tree->Root()); - return; -} - - extern "C" CAMLprim value caml_cpp_traversal(value tree){ CAMLparam1(tree); - traversal(XMLTREE(tree)); + traversal_rec(XMLTREE(tree),XMLTREE(tree)->Root()); CAMLreturn(Val_unit); } @@ -113,6 +109,35 @@ extern "C" CAMLprim value caml_text_collection_empty_text(value tc,value id){ CAMLreturn ( Val_int(((TextCollection*) tc)->EmptyText((DocID) Int_val(id)))); } +extern "C" CAMLprim value caml_text_collection_is_contains(value tc,value str){ + CAMLparam2(tc,str); + uchar * cstr = (uchar *) String_val(str); + CAMLreturn ( Val_bool((int) ((TextCollection*) tc)->IsContains(cstr))); +} + +extern "C" CAMLprim value caml_text_collection_count_contains(value tc,value str){ + CAMLparam2(tc,str); + uchar * cstr = (uchar *) String_val(str); + CAMLreturn ( Val_int(((TextCollection*) tc)->CountContains(cstr))); + +} + +extern "C" CAMLprim value caml_text_collection_contains(value tc,value str){ + CAMLparam2(tc,str); + CAMLlocal1(resarray); + uchar * cstr = (uchar *) String_val(str); + std::vector results; + results = ((TextCollection*) tc)->Contains(cstr); + + resarray = caml_alloc_tuple(results.size()); + + for (int i=0; iRoot())); @@ -121,6 +146,32 @@ extern "C" CAMLprim value caml_xml_tree_text_collection(value tree){ CAMLparam1(tree); CAMLreturn((value) XMLTREE(tree)->getTextCollection()); } +extern "C" CAMLprim value caml_xml_tree_parent(value tree, value id){ + CAMLparam2(tree,id); + CAMLreturn(Val_int (XMLTREE(tree)->Parent(TREENODEVAL(id)))); +} +extern "C" CAMLprim value caml_xml_tree_parent_doc(value tree, value id){ + CAMLparam2(tree,id); + CAMLreturn(Val_int (XMLTREE(tree)->ParentNode(TREENODEVAL(id)))); +} + +extern "C" CAMLprim value caml_xml_tree_is_ancestor(value tree,value id1, value id2) { + CAMLparam3(tree,id1,id2); + CAMLreturn(Val_bool (XMLTREE(tree)->IsAncestor(TREENODEVAL(id1),TREENODEVAL(id2)))); +} + +extern "C" CAMLprim value caml_xml_tree_serialize(value tree, value filename){ + CAMLparam2(tree,filename); + NOT_IMPLEMENTED("caml_xml_tree_serialize"); + CAMLreturn(Val_unit); +} + +extern "C" CAMLprim value caml_xml_tree_unserialize(value filename){ + CAMLparam1(filename); + NOT_IMPLEMENTED("caml_xml_tree_unserialize"); + CAMLreturn(Val_unit); +} + extern "C" CAMLprim value caml_xml_tree_first_child(value tree, value id){ CAMLparam2(tree,id); @@ -154,15 +205,11 @@ extern "C" CAMLprim value caml_xml_tree_my_text(value tree, value id){ extern "C" CAMLprim value caml_xml_tree_text_xml_id(value tree, value id){ CAMLparam2(tree,id); - - NOT_IMPLEMENTED("caml_xml_tree_text_xml_id"); - CAMLreturn (Val_unit); + CAMLreturn(Val_int((XMLTREE(tree)->TextXMLId(TREENODEVAL(id))))); } extern "C" CAMLprim value caml_xml_tree_node_xml_id(value tree, value id){ CAMLparam2(tree,id); - - NOT_IMPLEMENTED("caml_xml_tree_node_xml_id"); - CAMLreturn (Val_unit); + CAMLreturn(Val_int((XMLTREE(tree)->NodeXMLId(TREENODEVAL(id))))); } extern "C" CAMLprim value caml_xml_tree_tag(value tree, value id){ CAMLparam2(tree,id); @@ -171,6 +218,13 @@ extern "C" CAMLprim value caml_xml_tree_tag(value tree, value id){ CAMLreturn (caml_copy_string(tag)); } +extern "C" CAMLprim value caml_xml_tree_tag_id(value tree,value id){ + CAMLparam2(tree,id); + + int tag =XMLTREE(tree)->Tag(TREENODEVAL(id)); + + CAMLreturn (Val_unit); +} extern "C" CAMLprim value caml_xml_tree_nullt(value unit){ CAMLparam1(unit); CAMLreturn (NULLT); diff --git a/SXSIStorageInterface.cpp b/SXSIStorageInterface.cpp index 5df826b..af7ba7f 100644 --- a/SXSIStorageInterface.cpp +++ b/SXSIStorageInterface.cpp @@ -16,6 +16,7 @@ SXSIStorageInterface::SXSIStorageInterface() { tree = new XMLTree(); tree->OpenDocument(true,64); + } SXSIStorageInterface::~SXSIStorageInterface() @@ -24,16 +25,23 @@ SXSIStorageInterface::~SXSIStorageInterface() void SXSIStorageInterface::newChild(string name) { + _new_child++; tree->NewOpenTag((unsigned char*) name.c_str()); } void SXSIStorageInterface::newText(string text) { - if (text.empty()) + + if (text.empty()) { + _new_empty_text++; tree->NewEmptyText(); - else + } + else { + _new_text++; + _length_text += text.size(); tree->NewText((unsigned char*) text.c_str()); + } } @@ -45,12 +53,25 @@ void SXSIStorageInterface::nodeFinished(string name) void SXSIStorageInterface::parsingFinished() { - tree->CloseDocument(); + + tree->CloseDocument(); } void *SXSIStorageInterface::returnDocument(){ + printStats(); return ((void *) tree); } +void SXSIStorageInterface::printStats(){ + std::cerr << "Parsing stats : \n"; + std::cerr << _new_child << " calls to newOpenTag/newClosingTag\n"; + std::cerr << _new_text << " calls to newText\n"; + std::cerr << _new_empty_text << " calls to newEmptyText\n"; + std::cerr << _length_text << " bytes (=" << _length_text/1024 << "kb ) added to TextCollection\n"; + std::cerr << _heap_base << " bytes of memory (initial)\n"; + std::cerr << _heap_parsing << " bytes of memory (during parsing)\n"; + std::cerr << _heap_done << " bytes of memory (final)\n"; + return; +} diff --git a/SXSIStorageInterface.h b/SXSIStorageInterface.h index 8f09a48..a627d3e 100644 --- a/SXSIStorageInterface.h +++ b/SXSIStorageInterface.h @@ -26,9 +26,18 @@ class SXSIStorageInterface: public StorageInterface virtual void nodeFinished(string name); virtual void parsingFinished(); virtual void* returnDocument(); + virtual void printStats(); private: XMLTree* tree; + int _new_text; + int _new_empty_text; + int _new_child; + int _length_text; + int _heap_base; + int _heap_parsing; + int _heap_done; + }; #endif /*SXSISTORAGEINTERFACE_H_*/ diff --git a/StorageInterface.h b/StorageInterface.h index 5af866f..843a55e 100644 --- a/StorageInterface.h +++ b/StorageInterface.h @@ -27,6 +27,7 @@ class StorageInterface virtual void nodeFinished(string name) = 0; virtual void parsingFinished() = 0; virtual void* returnDocument() = 0; + virtual void printStats() = 0; private: diff --git a/XMLDocShredder.cpp b/XMLDocShredder.cpp index 1c25d61..d2e4a75 100644 --- a/XMLDocShredder.cpp +++ b/XMLDocShredder.cpp @@ -127,7 +127,6 @@ void XMLDocShredder::processPCDATA() if (reader_->has_value()) { buffer += reader_->get_value(); - }; } diff --git a/automaton.ml b/automaton.ml index 5c09143..12eee0b 100644 --- a/automaton.ml +++ b/automaton.ml @@ -287,7 +287,6 @@ let mk () = { initial = SSet.empty; module BottomUp = struct - exception Fail let pr_states fmt st = SSet.iter (fun s -> State.print fmt s; @@ -303,17 +302,29 @@ struct loop ([],SSet.empty) l let mem s x = SSet.mem x s - let rec accepting_among auto t r = - if SSet.is_empty r then r else - + + + let rec accepting_among ?(strings=None)auto t r = + if SSet.is_empty r then r else + match strings with + | Some valid_strings when (Tree.Binary.DocIdSet.for_all (fun i -> + not (Tree.Binary.string_below t i)) valid_strings ) + -> SSet.empty + | _ -> ( + let to_ignore = SSet.inter auto.ignore r in let r = SSet.diff r to_ignore in let res = match Tree.Binary.descr t with - | Tree.Binary.Nil | Tree.Binary.String _ -> - let i = SSet.inter r auto.final in i - + | Tree.Binary.Nil -> SSet.inter r auto.final + | Tree.Binary.String id -> ( + match strings with + | None -> SSet.inter r auto.final + | Some valid_strings when (Tree.Binary.DocIdSet.mem id valid_strings) + -> SSet.inter r auto.final + | _ -> SSet.empty + ) | Tree.Binary.Node(_) -> let t1 = Tree.Binary.left t and t2 = Tree.Binary.right t @@ -348,18 +359,17 @@ struct else (if SSet.exists (mem auto.marking) s1 || SSet.exists (mem auto.marking) s2 then auto.result <- BST.add t auto.result;s) - in SSet.union to_ignore res + in SSet.union to_ignore res) - let accept auto t = + let accept ?(strings=None) auto t = auto.result <- BST.empty; - if SSet.is_empty (accepting_among auto t auto.initial) + if SSet.is_empty (accepting_among ~strings:strings auto t auto.initial) then false else true end -module TopDown = struct - +module TopDown = struct let rec accept_at auto t q = if SSet.mem q auto.ignore then true else @@ -384,7 +394,10 @@ module TopDown = struct then begin if (SSet.mem q1 auto.marking)||(SSet.mem q2 auto.marking) - then auto.result <- BST.add t auto.result; + then + begin + auto.result <- BST.add t auto.result; + end; iter_trans true r end else @@ -447,3 +460,4 @@ module TopDown = struct run_in auto t auto.initial end + diff --git a/main.ml b/main.ml index e7bdd35..6295044 100644 --- a/main.ml +++ b/main.ml @@ -21,19 +21,6 @@ let time f x = ;; let total_time () = List.fold_left (+.) 0. !l;; -let test filename query output = - Printf.eprintf "Parsing document : %!"; - let v = time Tree.Binary.parse_xml_uri filename in -(* Tree.dump v; - Printf.eprintf "\n\n\n\n\n%!"; - Tree.Binary.print_xml_fast stderr v *) - Printf.eprintf "Full Traversal\n%!"; - time (Tree.full_traversal) v; - Printf.eprintf "Traversal\n%!"; - time (Tree.traversal) v; - Printf.eprintf "CPP Traversal\n%!"; - time (Tree.cpp_traversal) v - let main filename query output = Printf.eprintf "Parsing document : %!"; @@ -52,7 +39,8 @@ let main filename query output = let auto = time XPath.Compile.compile query in XPath.Ast.print Format.err_formatter query; Format.eprintf "\n%!"; - +(* Format.eprintf "Internal rep of the tree is :\n%!"; + Tree.Binary.dump v; *) Printf.eprintf "TopDown (No BackTrack) : \n"; time (fun v -> ignore (TopDown.accept auto v)) v; Printf.eprintf "Number of nodes in the result set : %i\n" (BST.cardinal auto.result); @@ -66,13 +54,11 @@ let main filename query output = let oc = open_out f in output_string oc "\n"; BST.iter (fun t -> Tree.Binary.print_xml_fast oc t; - output_string oc "\n------------------"; - output_char oc '\n') auto.result) (); + output_char oc '\n') auto.result) (); end; Printf.eprintf "Total time : %fms\n Coherence : %i\n%!" (total_time()) ;; - let argc = Array.length Sys.argv;; if (argc < 3 || argc >4) then @@ -81,5 +67,9 @@ then ;; -test Sys.argv.(1) Sys.argv.(2) (if argc == 4 then Some Sys.argv.(3) else None) ;; +main Sys.argv.(1) Sys.argv.(2) (if argc == 4 then Some Sys.argv.(3) else None) ;; + +Printf.eprintf "\n=================================================\nDEBUGGING\n%!"; +Tree.DEBUGTREE.print_stats Format.err_formatter;; + diff --git a/tree.ml b/tree.ml index 5e2a44b..0c1f10b 100644 --- a/tree.ml +++ b/tree.ml @@ -16,204 +16,19 @@ sig val descr : t -> descr val left : t -> t val right : t -> t + val parent : t -> t 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 : Set.S with type elt = string_content + val string_below : t -> string_content -> bool + val contains : t -> string -> DocIdSet.t + val contains_old : t -> string -> bool + val dump : t -> unit end -module OldBinary = -struct - - type string_content = string - type descr = Nil | Node of node_content | String of string_content - and node_content = int*Tag.t * descr * descr * (descr ref) - type t = descr - - let descr t = t - - let string = function String s -> s | _ -> failwith "string" - - - external parse_xml_uri : string -> t = "caml_call_shredder_uri" - external parse_xml_string : string -> t = "caml_call_shredder_string" - - let parse_xml_uri s = Node(0,Tag.tag "",parse_xml_uri s,Nil,ref Nil) - let parse_xml_string s = Node(0,Tag.tag "",parse_xml_string s,Nil,ref Nil) - let tstring = function Nil -> "Nil" - | Node (_,_,_,_,_) -> "Node" - | String _ -> "String" - - -let print_xml fmt t = - let pp_str = Format.pp_print_string fmt in - let rec loop = function Nil -> () - | String (s) -> pp_str s - | Node (_,t,l,r,_) when Tag.equal t Tag.pcdata -> loop l;loop r - | Node (_,t,l,r,_) -> - pp_str ("<" ^ (Tag.to_string t)); - ( match l with - Nil -> pp_str "/>" - | Node(_,t',atts,children,_) when Tag.equal t' Tag.attribute -> - (loop_attributes atts; - match children with - | Nil -> pp_str "/>" - | _ -> - pp_str ">"; - loop children; - pp_str ("" ) - ) - | _ -> pp_str ">"; loop l; - pp_str ("" ); - );loop r - and loop_attributes = function - | Node(_,t,Node(_,_,String(s),_,_),r,_) -> - pp_str (" "^(Tag.to_string t)^"=\""^ s ^"\"") ; - loop_attributes r - | _ -> () - - in - loop t - -let print_xml fmt = - function Node(i,t,l,_,_) -> print_xml fmt (Node(i,t,l,Nil,ref Nil)) - | t -> print_xml fmt t - - -(* a bit ugly but inlining like this makes serialization faster *) - -let print_xml_fast outc t = - let rec loop = function Nil -> () - | String (s) -> output_string outc s - | Node (_,t,l,r,_) when Tag.equal t Tag.pcdata -> loop l;loop r - | Node (_,t,l,r,_) -> let t = Tag.to_string t in - output_char outc '<'; - output_string outc t; - ( match l with - Nil -> output_string outc "/>" - | Node(_,t',atts,children,_) when Tag.equal t' Tag.attribute -> - (loop_attributes atts; - match children with - | Nil -> output_string outc "/>" - | _ -> - output_char outc '>'; - loop children; - output_string outc "' ) - | _ -> - output_char outc '>'; - loop l; - output_string outc "' - );loop r - and loop_attributes = function - | Node(_,t,Node(_,_,String(s),_,_),r,_) -> - output_char outc ' '; - output_string outc (Tag.to_string t); - output_string outc "=\""; - output_string outc s; - output_char outc '"'; - loop_attributes r - | _ -> () - - in - loop t - -let print_xml_fast outc = - function Node(i,t,l,_,_) -> print_xml_fast outc (Node(i,t,l,Nil,ref Nil)) - | t -> print_xml_fast outc t - - - -let tabs = ref 0 - -let prtabs fmt = - for i = 0 to !tabs - do - Format.fprintf fmt " " - done - - -let rec dump fmt t = - incr tabs; - let _ = match t with - | Nil -> prtabs fmt; Format.fprintf fmt "#" - | String s -> prtabs fmt; Format.fprintf fmt "(String %s)" s - | Node(id,t,l,r,_) -> - prtabs fmt; - Format.fprintf fmt " (tag='"; - Tag.print fmt t; - Format.fprintf fmt "', id='%i')\n" id; - prtabs fmt; - dump fmt l; - Format.fprintf fmt "\n"; - prtabs fmt; - dump fmt r; - Format.fprintf fmt "\n"; - prtabs fmt;prtabs fmt; - Format.fprintf fmt "(id='%i'end )\n" id - in decr tabs - - -let dump fmt t = - tabs:=0; - dump fmt t; - tabs:=0 - -let id = function Node(i,_,_,_,_) -> i - | _ -> failwith "id" - -let tag = function Node(_,t,_,_,_) -> t - | _ -> failwith "tag" - -let left = function Node(_,_,l,_,_) -> l - | _ -> failwith "left" - -let right = function Node(_,_,_,r,_) -> r - | _ -> failwith "right" - -let first_child = left -let next_sibling = right - -let is_root = function Node (_,_,_,_,{contents=Nil}) -> true | _ -> false -let is_left n = match n with - | Node (_,_,_,_,{contents=p}) when not(is_root n) && (left p) == n -> true - | _ -> false - -let is_right n = match n with - | Node (_,_,_,_,{contents=p}) when not(is_root n) && (right p) == n -> true - | _ -> false - - -let compare t1 t2 = match t1,t2 with - | Nil,Nil -> 0 - | String s1, String s2 -> String.compare s1 s2 - | Nil, String _ -> -1 - | String _, Nil -> 1 - | Node(i1,_,_,_,_), Node(i2,_,_,_,_) -> i1 - i2 - | _, Node _ -> -1 - | Node _ , _ -> 1 -let equal t1 t2 = (compare t1 t2) == 0 - -let int_size = Sys.word_size/8 -let ssize s = ((String.length s)/4 +1)*4 -let rec size = - function Nil -> (int_size,1,0,0) - | String s -> (int_size + (ssize s),0,1,0) - | Node(_,_,l,r,_) -> - let sizel,nl,sl,il = size l - and sizer,nr,sr,ir = size r - in - (sizel+sizer+(7*int_size),nl+nr,sl+sr,il+ir+1) -let size t = - let s,n,st,i = size t in - s/1024,n,st,i -end - - module XML = struct @@ -248,6 +63,12 @@ struct else get_text t n 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 is_contains : t -> string -> bool = "caml_text_collection_is_contains" + external count_contains : t -> string -> int = "caml_text_collection_count_contains" + external contains : t -> string -> [`Text ] node array = "caml_text_collection_contains" end @@ -255,7 +76,7 @@ struct struct - external serialize : string -> unit = "caml_xml_tree_serialize" + external serialize : t -> string -> unit = "caml_xml_tree_serialize" external unserialize : string -> t = "caml_xml_tree_unserialize" external root : t -> [`Tree] node = "caml_xml_tree_root" @@ -264,7 +85,7 @@ struct let nil = nullt () let is_nil x = equal x nil - external parent : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child" + 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" @@ -275,6 +96,7 @@ struct external is_leaf : t -> [`Tree] node -> bool = "caml_xml_tree_is_leaf" external tag : t -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag" + external tag_id : t -> [`Tree ] node -> unit = "caml_xml_tree_tag_id" external text_collection : t -> Text.t = "caml_xml_tree_text_collection" @@ -288,18 +110,19 @@ struct 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" let print_skel t = let textcol = text_collection t in let rec aux id = if (is_nil id) - then Printf.eprintf "#" + then Printf.eprintf "#\n" else begin - Printf.eprintf "Node %i has tag '%s', DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s)\n%!" + Printf.eprintf "Node %i has tag '%s' DocOrder=%i, DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s)\n%!" (int_of_node id) (Tag.to_string (tag t id)) + (node_xml_id t id) (int_of_node (prev_text t id)) (Text.get_text textcol (prev_text t id)) (int_of_node (my_text t id)) @@ -318,12 +141,12 @@ struct if not (is_nil id) then begin - ignore (tag t id); + (* ignore (tag t id); ignore (Text.get_text textcol (prev_text t id)); if (is_leaf t id) then ignore (Text.get_text textcol (my_text t id)); if (is_last t id) - then ignore (Text.get_text textcol (next_text t id)); + then ignore (Text.get_text textcol (next_text t id)); *) aux (first_child t id); aux (next_sibling t id); end @@ -349,7 +172,11 @@ struct text : Text.t; node : descr } - let dump { doc=t } = Tree.print_skel t + let dump { doc=t } = Tree.print_skel t + module DocIdSet = Set.Make (struct type t = string_content + let compare = (-) end) + + open Tree let node_of_t t = { doc= t; text = text_collection t; @@ -387,6 +214,18 @@ struct | 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 parent n = + let node' = + match n.node with + | Node(NC t) | Node(SC (_,t)) -> + if (Tree.root n.doc) == t + then Nil + else Node(NC(Tree.parent n.doc t)) (* A parent node can never be a SC *) + | _ -> assert false + in + { n with node = node' } + let first_child n = let node' = match n.node with @@ -426,8 +265,8 @@ struct let right = next_sibling let id = - function { doc=d; node=Node(NC n)} -> text_xml_id d n - | { doc=d; node=Node(SC (i,_) )} -> node_xml_id d i + 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 = @@ -435,8 +274,36 @@ struct | { doc=d; node=Node(NC n)} -> tag d n | _ -> failwith "Tag" - - + let tag_id = + function { node=Node(SC _) } -> () + | { doc=d; node=Node(NC n)} -> tag_id d n + | _ -> () + + let string_below t id = + let pid = parent_doc t.doc id in + match t.node with + | Node(NC(i)) -> (is_ancestor t.doc i pid) + | Node(SC(i,_)) -> (is_ancestor t.doc (parent_doc t.doc i) pid) + | _ -> false + + let contains t s = + Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.text s) + + 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 = match t.node with + | Nil -> false + | String _ -> matching (string t) + | Node(_) -> (find (left t )) || (find (right t)) + in + find t + let print_xml_fast outc t = let rec loop ?(print_right=true) t = match t.node with | Nil -> () @@ -500,9 +367,9 @@ struct let rec aux n = match n.node with | Nil -> () - | String i -> ignore(Text.get_text t.text i) + | String i -> () (*ignore(Text.get_text t.text i) *) | Node(_) -> - ignore (tag n); + (* tag_id n; *) aux (first_child n); aux (next_sibling n) in aux t @@ -511,10 +378,190 @@ struct end -let dump = XML.Binary.dump -let traversal = XML.Binary.traversal -let full_traversal = XML.Binary.full_traversal -external cpp_traversal : XML.t -> unit = "caml_cpp_traversal" -let cpp_traversal t = cpp_traversal t.XML.Binary.doc -include XML + + +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 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 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 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 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.text 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.text 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 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 is_empty_ n.text txt + then norm ns + else Node (SC (txt, ns)) + | Nil | String _ -> failwith "next_sibling" + in + { n with node = node'} + + 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 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 + + + + +end + +module Binary = DEBUGTREE + diff --git a/xPath.ml b/xPath.ml index 661863d..6c88d9a 100644 --- a/xPath.ml +++ b/xPath.ml @@ -190,14 +190,19 @@ module Functions = struct type value = [ `NodeSet of Automaton.BST.t | `Int of int | `String of string | `Bool of bool | `True | `False ] + type expr = [ value | `Call of (string*(expr list)) - | `Auto of Automaton.t ] + | `Auto of Automaton.t | `Contains of expr list ] let count = function [`NodeSet(s) ] -> `Int(Automaton.BST.cardinal s) | _ -> failwith "count" - + let contains_old = function [`NodeSet(s) ; `String(str) ] -> + `Bool(Automaton.BST.exists (fun tree -> Tree.Binary.contains_old tree str + ) s) + | _ -> failwith "contains_old" + let equal = function [ `Int i; `Int j ] -> `Bool (i == j) |_ -> failwith "equal" @@ -205,22 +210,25 @@ module Functions = struct ("count",count); ("equal",equal); + ("contains_old",contains_old); ] let text t = Tree.Binary.string (Tree.Binary.left t) let rec eval_expr tree (e:expr) : value = match e with | `Call (f,args) -> (List.assoc f globals) (List.map (eval_expr tree) args) - | `Auto(a) -> `NodeSet(ignore (Automaton.dump Format.err_formatter a; - Tree.Binary.print_xml_fast stderr tree; - Printf.eprintf "\n=======================\n%!"; - Automaton.TopDown.run a tree); - Printf.eprintf "Results : %i\n%!" - (Automaton.BST.cardinal a.Automaton.result); - Automaton.BST.iter (fun t -> Tree.Binary.print_xml_fast stderr t; - Printf.eprintf "^^^^^^^^^^^^^^^^^^^^^^^^\n%!") - a.Automaton.result; - a.Automaton.result) + | `Auto(a) -> `NodeSet(ignore (Automaton.BottomUp.accept a tree); + a.Automaton.result) + | `Contains(args) -> + begin + match args with + [ `Auto(a); `String(s) ] -> + let docs = Tree.Binary.contains tree s + in + let _ = Automaton.BottomUp.accept ~strings:(Some docs) a tree + in `NodeSet(a.Automaton.result) + | _ -> failwith "contains invalid" + end | #value as x -> x let truth_value = @@ -356,8 +364,7 @@ module Compile = struct | Expr e -> match compile_expr e with | `True -> `Label (TagSet.Xml.any) | `False -> `Label (TagSet.Xml.empty) - | e -> `Fun (fun t -> let r = Functions.truth_value (Functions.eval_expr t e) - in Printf.eprintf "Truth value is %b\n%!" r;r) + | e -> `Fun (fun t -> Functions.truth_value (Functions.eval_expr t e)) in match pred_rec p with `Fun f -> mk_pred_trs f tkeep tchange @@ -369,6 +376,7 @@ module Compile = struct | Path p -> `Auto(compile p) | Int i -> `Int i | String s -> `String s + | Function ("contains",elist) ->`Contains(List.map compile_expr elist) | Function (f,elist) -> `Call(f,List.map compile_expr elist) and cup a b = match a,b with