X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=ata.ml;h=fa44fd621851f5dc5c77d9eab2af8d07b4651eb0;hb=f0557f21878be17ddc75b1bc8f4f86da68c8e604;hp=ca137a705a767ea55bfe8c6e7a249695d9bf6ffa;hpb=04639fe524ee20f7f84c8b08387312d714c9bd56;p=SXSI%2Fxpathcomp.git

diff --git a/ata.ml b/ata.ml
index ca137a7..fa44fd6 100644
--- a/ata.ml
+++ b/ata.ml
@@ -160,7 +160,7 @@ struct
       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 = 
@@ -255,9 +255,9 @@ let dump ppf a =
 	  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 =
@@ -280,44 +280,6 @@ module FormTable = Hashtbl.Make(struct
 				  let hash (f,s,t) = 
 				    HASHINT3(Formula.uid f ,StateSet.uid s,StateSet.uid t)
 				end)
-(* Too slow  
-module MemoForm = Memoizer.Make(
-
-module F = Formula
-(*
-let eval_form_bool = 
-  MemoForm.make_rec( 
-    fun eval (f, ((s1,s2) as sets)) ->
-      match F.expr f with
-	| F.True -> true,true,true
-	| F.False -> false,false,false
-	| F.Atom((`Left|`LLeft),b,q) ->
-	    if b == (StateSet.mem q s1) 
-	    then (true,true,false) 
-	    else false,false,false
-	| F.Atom(_,b,q) -> 
-	    if b == (StateSet.mem q s2) 
-	    then (true,false,true)
-	    else false,false,false			
-	| F.Or(f1,f2) ->	    
-	    let b1,rl1,rr1 = eval (f1,sets)
-	    in
-	      if b1 && rl1 && rr1 then (true,true,true)  else
-		let b2,rl2,rr2 = eval (f2,sets)  in
-		let rl1,rr1 = if b1 then rl1,rr1 else false,false
-		and rl2,rr2 = if b2 then rl2,rr2 else false,false
-		in (b1 || b2, rl1||rl2,rr1||rr2)
-		     
-	| F.And(f1,f2) -> 
-	    let b1,rl1,rr1 = eval (f1,sets) in
-	      if b1 && rl1 && rr1 then (true,true,true) else
-		if b1 then 
-		  let b2,rl2,rr2 = eval (f2,sets) in
-		    if b2 then (true,rl1||rl2,rr1||rr2) else (false,false,false)
-		else (false,false,false) 	    
-  )
-
-*) *)
 module F = Formula
 
 let eval_form_bool = 
@@ -493,7 +455,7 @@ let tags_of_state a q =
       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
+ 	  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;}
@@ -504,7 +466,32 @@ let tags_of_state a q =
 
 	   
     end
-
+    module GResult = struct
+      type t
+      type elt = [` Tree] Tree.node
+      external create_empty : int -> t = "caml_result_set_create"
+      external set : t -> int -> t = "caml_result_set_set"
+      external next : t -> int -> int = "caml_result_set_next"
+      external clear : t -> int -> int -> unit = "caml_result_set_clear"
+      let empty = create_empty 100000000
+	
+      let cons e t = set t (Obj.magic e)
+      let concat _ t = t
+      let iter f t =
+	let rec loop i = 
+	  if i == -1 then ()
+	  else (f (Obj.magic i);loop (next t i))
+	in loop 0
+	  
+      let fold _ _ _ = failwith "noop"
+      let map _ _ = failwith "noop"
+      let length t = let cpt = ref ~-1 in
+      iter (fun _ -> incr cpt) t; !cpt
+      
+      let merge (rb,rb1,rb2,mark) elt t1 t2 =
+	if mark then (set t1 (Obj.magic elt) ; t1) else t1
+	  
+    end
     module Run (RS : ResultSet) =
     struct
 
@@ -529,6 +516,67 @@ END
       let string_of_ts tags = (Ptset.Int.fold (fun t a -> a ^ " " ^ (Tag.to_string t) ) tags "{")^ " }"
 
 
+
+      module Algebra =
+	struct
+	  type jump = [ `LONG | `CLOSE | `NIL ]
+	  type t = jump*Ptset.Int.t
+	      
+	  let merge_jump (j1,l1) (j2,l2) = 
+	    match j1,j2 with
+	      | _ when j1 = j2 -> (j1,Ptset.Int.union l1 l2)
+	      | _,`NIL -> j1,l1
+	      | `NIL,_ -> j2,l2
+	      | _,_ -> (`CLOSE, Ptset.Int.union l1 l2)
+
+	  let merge_jump_list = function 
+	    | [] -> `NIL,Ptset.Int.empty
+	    | p::r -> List.fold_left (merge_jump) p r
+	      
+	  let labels a s = 
+	    Hashtbl.fold 
+	    (
+	      fun q l acc -> 
+		if (q == s)
+		then 
+
+		  (List.fold_left 
+		      (fun acc (ts,f) ->
+			let _,_,_,bur = Transition.node f in
+			if bur then acc else TagSet.cup acc ts) 
+		    acc l)
+		else acc ) a.trans TagSet.empty
+	  exception Found
+	    
+	  let is_rec a s access = 
+	    List.exists
+	      (fun (_,t) -> let _,_,f,_ = Transition.node t in
+	      StateSet.mem s (access f)) (Hashtbl.find a.trans s) 
+		     
+
+	  let decide a c_label l_label dir_states access =
+			
+	    let l = StateSet.fold 
+	      (fun s l -> 
+		 let s_rec= is_rec a s access in
+		 let tlabels,jmp = 
+		   if s_rec then l_label,`LONG 
+		   else c_label,`CLOSE in			      
+		 let slabels = TagSet.positive ((TagSet.cap (labels a s) tlabels))
+		 in
+		   (if Ptset.Int.is_empty slabels
+		    then `NIL,Ptset.Int.empty
+		    else  jmp,slabels)::l) dir_states []
+	    in merge_jump_list l
+		 
+
+	    
+	    
+	      
+	end 
+
+
+
       let choose_jump tagset qtags1 qtagsn a f_nil  f_t1 f_s1 f_tn f_sn f_notext f_maytext =
 	let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
 	let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
@@ -769,22 +817,24 @@ END
 			 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 
@@ -807,25 +857,25 @@ END
 	      |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
@@ -851,32 +901,31 @@ END
 	      in
 		(Hashtbl.add h_trans key res;res) 
 		  
+
 	      
 	let h_tdconf = Hashtbl.create 511 
 	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 
+	  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
@@ -892,11 +941,9 @@ END
 	  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 "  
-	    (if Tree.is_nil t then "###" else (Tag.to_string(Tree.tag t))) (Tree.dump_node t); *)
  	  let r = 
 	    try
 	      Hashtbl.find h_tdconf tag
@@ -917,24 +964,21 @@ END
 	  let set = match SList.node set with
 	    | SList.Cons(x,_) ->x
 	    | _ -> assert false 
-	  in 
-(*	    pr "Result of topdown run is %!";
-	    StateSet.print fmt (Ptset.Int.elements set);
-	    pr ", number is %i\n%!" (RS.length res.(0));  *)
-	    Configuration.add Configuration.empty set res.(0) 
+	  in
+	  Configuration.add Configuration.empty set res.(0) 
 
 
 
 	let run_bottom_up a tree k =
 	  let t = Tree.root in
-	  let trlist = Hashtbl.find a.trans (Ptset.Int.choose a.init)
+	  let trlist = Hashtbl.find a.trans (StateSet.choose a.init)
 	  in
 	  let init = List.fold_left 
 	    (fun acc (_,t) ->
 	       let _,_,f,_ = Transition.node t in 
 	       let _,_,l = fst ( Formula.st f ) in
-		 Ptset.Int.union acc l)
-	    Ptset.Int.empty trlist
+		 StateSet.union acc l)
+	    StateSet.empty trlist
 	  in
 	  let tree1,jump_fun =
 	    match k with
@@ -942,22 +986,17 @@ END
 		  (*Tree.tagged_lowest t tag, fun tree -> Tree.tagged_next tree tag*)
 		  (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 
+	      | `CONTAINS(_) -> (Tree.text_below tree t,let jump = Tree.text_next tree 
 				 in fun n -> jump n t)
 	      | _ -> assert false
 	  in
 	  let tree2 = jump_fun tree1 in
 	  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 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 
-			    in *)	      
 	    let acc = Configuration.IMap.fold 
-	      ( fun s res acc -> if Ptset.Int.intersect init s
+	      ( fun s res acc -> if StateSet.intersect init s
 		then RS.concat res acc else acc) conf.Configuration.results acc
 	    in
 	      if Tree.is_nil next_of_next  (*|| Tree.equal next next_of_next *)then
@@ -970,7 +1009,7 @@ END
     end
           
     let top_down_count a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down a t)
-    let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t)
+    let top_down a t = let module RI = Run(GResult) in (RI.run_top_down a t)
     let bottom_up_count a t k = let module RI = Run(Integer) in Integer.length (RI.run_bottom_up a t k)