/**************************************
* OCamlDriver.cpp
* -------------------
- * A Test Ocaml Driver which calls the C++ methods and
+ * An Ocaml Driver which calls the C++ methods and
* adds a C wrapper interface with OCaml code.
*
* Author: Kim Nguyen
* Date: 04/11/08
*/
-/* OCaml memory managment */
+
+
#include <unordered_set>
+#include <algorithm>
+#include "XMLDocShredder.h"
+#include "XMLTree.h"
+#include "Utils.h"
+
extern "C" {
+/* OCaml memory managment */
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/custom.h>
-} //extern C
-
-
-//#include "TextCollection/TextCollection.h"
-#include "XMLDocShredder.h"
-#include "XMLTree.h"
-#include "Utils.h"
-
#define CAMLRAISEMSG(msg) (caml_raise_with_string(*cpp_exception,(msg) ))
#define NOT_IMPLEMENTED(s) (caml_failwith(s))
#define XMLTREE(x) ((XMLTree *)(* (XMLTree**) Data_custom_val(x)))
#define TEXTCOLLECTION(x)
#define TREENODEVAL(i) ((treeNode) (Int_val(i)))
#define XMLTREE_ROOT 0
-
-
-
-extern "C" {
+
static struct custom_operations ops;
static struct custom_operations set_ops;
static value * cpp_exception = NULL;
static bool ops_initialized = false;
-
+
}
+
extern "C" void caml_xml_tree_finalize(value tree){
delete XMLTREE(tree);
return;
}
+
extern "C" void caml_hset_finalize(value hblock){
delete HSET(hblock);
return;
extern "C" CAMLprim value caml_init_lib (value unit) {
CAMLparam1(unit);
if (!ops_initialized){
-
+
ops.identifier = (char*) "XMLTree";
ops.finalize = caml_xml_tree_finalize;
set_ops.finalize = caml_hset_finalize;
cpp_exception = caml_named_value("CPlusPlusError");
+ if (cpp_exception == NULL){
+ string s = "FATAL: Unregistered exception ";
+ s += "CPlusPlusError";
+ caml_failwith(s.c_str());
+ };
ops_initialized = true;
CAMLreturn (Val_unit);
}
+bool docId_comp(DocID x, DocID y) { return x < y; };
extern "C" CAMLprim value caml_text_collection_contains(value tree,value str){
CAMLparam2(tree,str);
std::vector<DocID> results;
results = XMLTREE(tree)->Contains(cstr);
//free(cstr);
- resarray = caml_alloc_tuple(results.size());
+ std::sort(results.begin(), results.end(), docId_comp);
+ size_t s = results.size();
+ resarray = caml_alloc_tuple(s);
- for (unsigned int i=0; i<results.size();i++){
+ for (size_t i = 0; i < s ;i++){
caml_initialize(&Field(resarray,i),Val_int(results[i]));
};
CAMLreturn (resarray);
}
+
extern "C" CAMLprim value caml_text_collection_unsorted_contains(value tree,value str){
CAMLparam2(tree,str);
uchar * cstr = (uchar *) String_val(str);
return (Val_int (XMLTREE(tree)->ParentNode((DocID) Int_val(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))));
let psize = (size f1) + (size f2) in
let nsize = (size (not_ f1)) + (size (not_ f2)) in
let sp,sn = merge_states f1 f2 in
- fst (cons (Or(f1,f2)) (And(not_ f1,not_ f2)) sp sn psize nsize)
+ fst (cons (Or(f1,f2)) (And(not_ f1,not_ f2)) sp sn psize nsize)
let and_ f1 f2 =
if TagSet.is_finite ts
then "{" ^ (TagSet.fold (fun t a -> a ^ " '" ^ (Tag.to_string t)^"'") ts "") ^" }"
else let cts = TagSet.neg ts in
- if TagSet.is_empty cts then "*" else
- (TagSet.fold (fun t a -> a ^ " " ^ (Tag.to_string t)) cts "*\\{"
- )^ "}"
+ if TagSet.is_empty cts then "*" else
+ (TagSet.fold (fun t a -> a ^ " " ^ (Tag.to_string t)) cts "*\\{"
+ )^ "}"
in
let s = Printf.sprintf "(%s,%i)" s q in
let s_frm =
StateSet.print fmt k;
Format.fprintf fmt "-> %i\n" (RS.length d)) c.results;
Format.fprintf fmt "\n%!"
-
+
let merge c1 c2 =
- let acc1 = IMap.fold (fun s r acc ->
- IMap.add s
- (try
- RS.concat r (IMap.find s acc)
- with
- | Not_found -> r) acc) c1.results IMap.empty
+ let acc1 =
+ IMap.fold
+ ( fun s r acc ->
+ IMap.add s
+ (try
+ RS.concat r (IMap.find s acc)
+ with
+ | Not_found -> r) acc) c1.results IMap.empty
in
let imap =
- IMap.fold (fun s r acc ->
- IMap.add s
- (try
- RS.concat r (IMap.find s acc)
- with
- | Not_found -> r) acc) c2.results acc1
+ IMap.fold (fun s r acc ->
+ IMap.add s
+ (try
+ RS.concat r (IMap.find s acc)
+ with
+ | Not_found -> r) acc) c2.results acc1
in
let h,s =
Ptss.fold
|SList.Cons(s,sll), formlist::fll ->
let r',(rb,rb1,rb2,mark) =
let key = SList.hash sl,Formlist.hash formlist,dir in
- try
- Hashtbl.find h_fold key
- with
- Not_found -> let res =
- if dir then eval_formlist s Ptset.Int.empty formlist
- else eval_formlist Ptset.Int.empty s formlist
- in (Hashtbl.add h_fold key res;res)
+ try
+ Hashtbl.find h_fold key
+ with
+ Not_found -> let res =
+ if dir then eval_formlist s Ptset.Int.empty formlist
+ else eval_formlist Ptset.Int.empty s formlist
+ in (Hashtbl.add h_fold key res;res)
+ in
+ if rb && ((dir&&rb1)|| ((not dir) && rb2))
+ then
+ let acc =
+ let old_r =
+ try Configuration.IMap.find s conf.Configuration.results
+ with Not_found -> RS.empty
in
- if rb && ((dir&&rb1)|| ((not dir) && rb2))
- then
- let acc =
- let old_r =
- try Configuration.IMap.find s conf.Configuration.results
- with Not_found -> RS.empty
- in
- Configuration.add acc r' (if mark then RS.cons t old_r else old_r)
- in
- loop sll fll acc
- else loop sll fll acc
+ Configuration.add acc r' (if mark then RS.cons t old_r else old_r)
+ in
+ loop sll fll acc
+ else loop sll fll acc
| _ -> assert false
in
loop slist fl_list Configuration.empty
accu,conf,next
else
- let below_right = Tree.is_below_right tree t next in
-
- let accu,rightconf,next_of_next =
- if below_right then (* jump to the next *)
- bottom_up a tree next conf (jump_fun next) jump_fun (Tree.next_sibling tree t) true init accu
- else accu,Configuration.empty,next
- in
+ let below_right = Tree.is_below_right tree t next in
+
+ let accu,rightconf,next_of_next =
+ if below_right then (* jump to the next *)
+ bottom_up a tree next conf (jump_fun next) jump_fun (Tree.next_sibling tree t) true init accu
+ else accu,Configuration.empty,next
+ in
let sub =
if dotd then
- if below_right then prepare_topdown a tree t true
- else prepare_topdown a tree t false
+ if below_right then prepare_topdown a tree t true
+ else prepare_topdown a tree t false
else conf
in
let conf,next =
(Configuration.merge rightconf sub, next_of_next)
in
- if t == root then accu,conf,next
- else
+ if t == root then accu,conf,next else
let parent = Tree.binary_parent tree t in
let ptag = Tree.tag tree parent in
let dir = Tree.is_left tree t in
in
bottom_up a tree parent newconf next jump_fun root false init accu
-
+
and prepare_topdown a tree t noright =
let tag = Tree.tag tree t in
(* pr "Going top down on tree with tag %s = %s "
projects / SXSI / xpathcomp.git / commitdiff