X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;ds=sidebyside;f=ata.ml;h=13d3cced2ae22153a5f4bf17c8707b2cd413e740;hb=70ff0bfc463882ecf233f1b1a7ac4a8007fa4cc2;hp=e06ac040ba9420cafec4414ff6542f4ff0efe30e;hpb=451e60ad59e35344dff62da5ca27fcd5eec1bff9;p=SXSI%2Fxpathcomp.git diff --git a/ata.ml b/ata.ml index e06ac04..13d3cce 100644 --- a/ata.ml +++ b/ata.ml @@ -434,27 +434,26 @@ let tags_of_state a q = match b with | `Positive s -> let r = Ptset.Int.inter a s in (r,Ptset.Int.mem Tag.pcdata r, true) | `Negative s -> let r = Ptset.Int.diff a s in (r, Ptset.Int.mem Tag.pcdata r, false) - - let mk_nil_ctx x _ = Tree.mk_nil x - let next_sibling_ctx x _ = Tree.next_sibling x - let r_ignore _ x = x module type ResultSet = sig type t + type elt = [` Tree] Tree.node val empty : t - val cons : Tree.t -> t -> t + val cons : elt -> t -> t val concat : t -> t -> t - val iter : (Tree.t -> unit) -> t -> unit - val fold : (Tree.t -> 'a -> 'a) -> t -> 'a -> 'a - val map : (Tree.t -> Tree.t) -> t -> t + val iter : ( elt -> unit) -> t -> unit + val fold : ( elt -> 'a -> 'a) -> t -> 'a -> 'a + val map : ( elt -> elt) -> t -> t val length : t -> int + val merge : bool -> bool -> bool -> bool -> elt -> t -> t -> t end module Integer : ResultSet = struct type t = int + type elt = [`Tree] Tree.node let empty = 0 let cons _ x = x+1 let concat x y = x + y @@ -462,12 +461,21 @@ let tags_of_state a q = let fold _ _ _ = failwith "fold not implemented" let map _ _ = failwith "map not implemented" let length x = x + let merge rb rb1 rb2 mark t res1 res2 = + if rb then + let res1 = if rb1 then res1 else 0 + and res2 = if rb2 then res2 else 0 + in + if mark then 1+res1+res2 + else res1+res2 + else 0 end module IdSet : ResultSet = struct + type elt = [`Tree] Tree.node type node = Nil - | Cons of Tree.t * node + | Cons of elt * node | Concat of node*node and t = { node : node; @@ -504,6 +512,18 @@ let tags_of_state a q = | Concat(t1,t2) -> Concat(loop t1,loop t2) in { l with node = loop l.node } + + let merge rb rb1 rb2 mark t res1 res2 = + if rb then + let res1 = if rb1 then res1 else empty + and res2 = if rb2 then res2 else empty + in + if mark then { node = Cons(t,(Concat(res1.node,res2.node))); + length = res1.length + res2.length + 1;} + else + { node = (Concat(res1.node,res2.node)); + length = res1.length + res2.length ;} + else empty end @@ -532,11 +552,12 @@ END let string_of_ts tags = (Ptset.Int.fold (fun t a -> a ^ " " ^ (Tag.to_string t) ) tags "{")^ " }" - let choose_jump tagset qtags1 qtagsn a f_nil f_text f_t1 f_s1 f_tn f_sn f_notext = + let choose_jump tagset qtags1 qtagsn a f_nil f_t1 f_s1 f_tn f_sn f_notext = let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in - if (hastext1||hastextn) then (`ANY,f_text) (* jumping to text nodes doesn't work really well *) - else if (Ptset.Int.is_empty tags1) && (Ptset.Int.is_empty tagsn) then (`NIL,f_nil) + (*if (hastext1||hastextn) then (`ANY,f_text) (* jumping to text nodes doesn't work really well *) + else*) + if (Ptset.Int.is_empty tags1) && (Ptset.Int.is_empty tagsn) then (`NIL,f_nil) else if (Ptset.Int.is_empty tagsn) then if (Ptset.Int.is_singleton tags1) then (* TaggedChild/Sibling *) @@ -551,25 +572,23 @@ END (`ANY,mk_app_fun f_sn tagsn (string_of_ts tagsn)) else (`ANY,f_notext) - let choose_jump_down a b c d = + let choose_jump_down tree a b c d = choose_jump a b c d - (mk_fun (Tree.mk_nil) "Tree.mk_nil") - (mk_fun (Tree.first_child) "Tree.text_below") - (mk_fun (Tree.tagged_child) "Tree.tagged_child") - (mk_fun (Tree.select_child) "Tree.select_child") (* !! no select_child in Tree.ml *) - (mk_fun (Tree.tagged_desc) "Tree.tagged_desc") - (mk_fun (Tree.select_desc) "Tree.select_desc") (* !! no select_desc *) - (mk_fun (Tree.first_child) "Tree.first_child") - - let choose_jump_next a b c d = + (mk_fun (fun _ -> Tree.nil) "Tree.mk_nil") + (mk_fun (Tree.tagged_child tree) "Tree.tagged_child") + (mk_fun (Tree.select_child tree) "Tree.select_child") (* !! no select_child in Tree.ml *) + (mk_fun (Tree.tagged_desc tree) "Tree.tagged_desc") + (mk_fun (Tree.select_desc tree) "Tree.select_desc") (* !! no select_desc *) + (mk_fun (Tree.first_child tree) "Tree.first_child") + + let choose_jump_next tree a b c d = choose_jump a b c d - (mk_fun (fun t _ -> Tree.mk_nil t) "Tree.mk_nil2") - (mk_fun (Tree.next_sibling_ctx) "Tree.text_next") - (mk_fun (Tree.tagged_sibling_ctx) "Tree.tagged_sibling_ctx")(* !! no tagged_sibling in Tree.ml *) - (mk_fun (Tree.select_sibling_ctx) "Tree.select_sibling_ctx")(* !! no select_sibling in Tree.ml *) - (mk_fun (Tree.tagged_foll_ctx) "Tree.tagged_foll_ctx") - (mk_fun (Tree.select_foll_ctx) "Tree.select_foll_ctx")(* !! no select_foll *) - (mk_fun (Tree.next_sibling_ctx) "Tree.node_sibling_ctx") + (mk_fun (fun _ _ -> Tree.nil) "Tree.mk_nil2") + (mk_fun (Tree.tagged_sibling_ctx tree) "Tree.tagged_sibling_ctx")(* !! no tagged_sibling in Tree.ml *) + (mk_fun (Tree.select_sibling_ctx tree) "Tree.select_sibling_ctx")(* !! no select_sibling in Tree.ml *) + (mk_fun (Tree.tagged_foll_ctx tree) "Tree.tagged_foll_ctx") + (mk_fun (Tree.select_foll_ctx tree) "Tree.select_foll_ctx")(* !! no select_foll *) + (mk_fun (Tree.next_sibling_ctx tree) "Tree.node_sibling_ctx") module SetTagKey = @@ -582,23 +601,22 @@ END module CachedTransTable = Hashtbl.Make(SetTagKey) let td_trans = CachedTransTable.create 4093 - let merge rb rb1 rb2 mark t res1 res2 = - if rb - then - let res1 = if rb1 then res1 else RS.empty - and res2 = if rb2 then res2 else RS.empty - in - if mark then RS.cons t (RS.concat res1 res2) - else RS.concat res1 res2 - else RS.empty let empty_size n = let rec loop acc = function 0 -> acc | n -> loop (SList.cons StateSet.empty acc) (n-1) in loop SList.nil n - + + let merge rb rb1 rb2 mark t res1 res2 = + if rb then + let res1 = if rb1 then res1 else RS.empty + and res2 = if rb2 then res2 else RS.empty + in + if mark then RS.cons t (RS.concat res1 res2) + else RS.concat res1 res2 + else RS.empty - let top_down ?(noright=false) a t slist ctx slot_size = + let top_down ?(noright=false) a tree t slist ctx slot_size = let pempty = empty_size slot_size in (* evaluation starts from the right so we put sl1,res1 at the end *) let eval_fold2_slist fll t (sl2,res2) (sl1,res1) = @@ -609,7 +627,7 @@ END SList.Cons(s2,ll2), fl::fll -> let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in - let _ = res.(i) <- merge rb rb1 rb2 mark t res1.(i) res2.(i) + let _ = res.(i) <- RS.merge rb rb1 rb2 mark t res1.(i) res2.(i) in fold ll1 ll2 fll (i+1) (SList.cons r' aq) @@ -621,12 +639,12 @@ END let null_result() = (pempty,Array.make slot_size RS.empty) in let rec loop t slist ctx = - if Tree.is_nil t then null_result() else get_trans t slist (Tree.tag t) ctx + if t == Tree.nil then null_result() else get_trans t slist (Tree.tag tree t) ctx and loop_tag tag t slist ctx = - if Tree.is_nil t then null_result() else get_trans t slist tag ctx + if t == Tree.nil then null_result() else get_trans t slist tag ctx and loop_no_right t slist ctx = - if Tree.is_nil t then null_result() else get_trans ~noright:true t slist (Tree.tag t) ctx + if t == Tree.nil then null_result() else get_trans ~noright:true t slist (Tree.tag tree t) ctx and get_trans ?(noright=false) t slist tag ctx = let cont = try @@ -665,10 +683,10 @@ END slist ([],SList.nil,SList.nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty) in (* Logic to chose the first and next function *) - let tags_below,tags_after = Tree.tags t tag in - let f_kind,first = choose_jump_down tags_below ca da a - and n_kind,next = if noright then (`NIL, fun t _ -> Tree.mk_nil t ) - else choose_jump_next tags_after sa fa a in + let tags_below,tags_after = Tree.tags tree tag in + let f_kind,first = choose_jump_down tree tags_below ca da a + and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil ) + else choose_jump_next tree tags_after sa fa a in let empty_res = null_result() in let cont = match f_kind,n_kind with @@ -730,12 +748,12 @@ END (if noright then loop_no_right else loop) t slist ctx - let run_top_down a t = + let run_top_down a tree = let init = SList.cons a.init SList.nil in - let _,res = top_down a t init t 1 + let _,res = top_down a tree Tree.root init Tree.root 1 in D_IGNORE_( - output_trace a t "trace.html" + output_trace a tree root "trace.html" (RS.fold (fun t a -> IntSet.add (Tree.id t) a) res.(0) IntSet.empty), res.(0)) ;; @@ -853,33 +871,33 @@ END let h_tdconf = Hashtbl.create 511 - let rec bottom_up a tree conf next jump_fun root dotd init accu = + let rec bottom_up a tree t conf next jump_fun root dotd init accu = if (not dotd) && (Configuration.is_empty conf ) then accu,conf,next else - let below_right = Tree.is_below_right tree 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 next conf (jump_fun next) jump_fun (Tree.next_sibling tree) true init accu + 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 true - else prepare_topdown a tree 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 Tree.equal tree root then accu,conf,next + if t == root then accu,conf,next else - let parent = Tree.binary_parent tree in - let ptag = Tree.tag parent in - let dir = Tree.is_left tree in + let parent = Tree.binary_parent tree t in + let ptag = Tree.tag tree parent in + let dir = Tree.is_left tree t in let slist = Configuration.Ptss.fold (fun e a -> SList.cons e a) conf.Configuration.sets SList.nil in let fl_list = get_up_trans slist ptag a parent in let slist = SList.rev (slist) in @@ -891,10 +909,10 @@ END (newconf.Configuration.results) (accu,Configuration.empty) in - bottom_up a parent newconf next jump_fun root false init accu + bottom_up a tree parent newconf next jump_fun root false init accu - and prepare_topdown a t noright = - let tag = Tree.tag t in + and prepare_topdown a tree t noright = + let tag = Tree.tag tree t in (* pr "Going top down on tree with tag %s = %s " (if Tree.is_nil t then "###" else (Tag.to_string(Tree.tag t))) (Tree.dump_node t); *) let r = @@ -913,7 +931,7 @@ END pr "\n%!"; in *) let r = SList.cons r SList.nil in - let set,res = top_down (~noright:noright) a t r t 1 in + let set,res = top_down (~noright:noright) a tree t r t 1 in let set = match SList.node set with | SList.Cons(x,_) ->x | _ -> assert false @@ -925,7 +943,8 @@ END - let run_bottom_up a t k = + let run_bottom_up a tree k = + let t = Tree.root in let trlist = Hashtbl.find a.trans (Ptset.Int.choose a.init) in let init = List.fold_left @@ -939,16 +958,18 @@ END match k with | `TAG (tag) -> (*Tree.tagged_lowest t tag, fun tree -> Tree.tagged_next tree tag*) - (Tree.tagged_desc tag t, fun tree -> Tree.tagged_foll_ctx tag tree t) - | `CONTAINS(_) -> (Tree.first_child t,fun tree -> Tree.next_sibling_ctx tree t) + (Tree.tagged_desc tree tag t, let jump = Tree.tagged_foll_ctx tree tag + in fun n -> jump n t ) + | `CONTAINS(_) -> (Tree.first_child tree t,let jump = Tree.next_sibling_ctx tree + in fun n -> jump n t) | _ -> assert false in let tree2 = jump_fun tree1 in - let rec loop tree next acc = + let rec loop t next acc = (* let _ = pr "\n_________________________\nNew iteration\n" in let _ = pr "Jumping to %s\n%!" (Tree.dump_node tree) in *) - let acc,conf,next_of_next = bottom_up a tree - Configuration.empty next jump_fun (Tree.root tree) true init acc + let acc,conf,next_of_next = bottom_up a tree t + Configuration.empty next jump_fun (Tree.root) true init acc in (* let _ = pr "End of first iteration, conf is:\n%!"; Configuration.pr fmt conf