X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;ds=sidebyside;f=ata.ml;h=a291367bfad6e8e05a6c32373c5084d92afc61ae;hb=ac8720a930e5757a72f73e80aff7a988b0082831;hp=9197cbca94ebb7b55354098bbc24aef3c30fcff6;hpb=d046f2b9d8e39b30350399eafe122c30ff61c8c1;p=SXSI%2Fxpathcomp.git

diff --git a/ata.ml b/ata.ml
index 9197cbc..a291367 100644
--- a/ata.ml
+++ b/ata.ml
@@ -13,8 +13,9 @@ sig
 end =
 struct
   type t = int
-  let make = let id = ref ~-1 in
-  fun () -> incr id; !id
+  let make = 
+    let id = ref ~-1 in
+    fun () -> incr id; !id
 
   let compare = (-)
   let equal = (==)
@@ -25,8 +26,25 @@ struct
     if x < 0 then failwith (Printf.sprintf "State: Assertion %i < 0 failed" x)
 end
 
-module StateSet = Ptset.Int
-  
+module StateSet = 
+struct
+  include Ptset.Make ( struct type t = int 
+			      type data = t
+			      external hash : t -> int = "%identity"
+			      external uid : t -> Uid.t = "%identity"
+			      external equal : t -> t -> bool = "%eq"
+			      external make : t -> int = "%identity"
+			      external node : t -> int = "%identity"
+			      external with_id : Uid.t -> t = "%identity"
+		       end
+		     ) 
+  let print ppf s = 
+    Format.pp_print_string ppf "{ ";
+    iter (fun i -> Format.fprintf ppf "%i " i) s;
+    Format.pp_print_string ppf "}";
+    Format.pp_print_flush ppf ()
+end
+
 module Formula =
 struct
     type 'hcons expr = 
@@ -221,8 +239,6 @@ module Transition = struct
 
 end
 
-module TransTable = Hashtbl
- 
 module Formlist = struct 
   include Hlist.Make(Transition)
   let print ppf fl = 
@@ -238,9 +254,9 @@ end
   
 type 'a t = { 
     id : int;
-    mutable states : Ptset.Int.t;
-    init : Ptset.Int.t;
-    starstate : Ptset.Int.t option;
+    mutable states : StateSet.t;
+    init : StateSet.t;
+    starstate : StateSet.t option;
     (* Transitions of the Alternating automaton *)
     trans : (State.t,(TagSet.t*Transition.t) list) Hashtbl.t;
     query_string: string;
@@ -454,7 +470,7 @@ let tags_of_state a q =
 	else 0
       let merge conf t res1 res2 = 
 	match conf with
-	   NO -> 0                         
+	  | NO -> 0                         
 	  | ONLY1 -> res1                
 	  | ONLY2 -> res2           
 	  | ONLY12 -> res1+res2     
@@ -462,6 +478,10 @@ let tags_of_state a q =
 	  | MARK1 -> res1+1         
 	  | MARK2 -> res2+1         
 	  | MARK12 -> res1+res2+1   
+      let merge conf _ res1 res2 =
+	let conf = Obj.magic conf in 
+	(conf lsr 2) + ((conf land 0b10) lsr 1)*res2 + (conf land 0b1)*res1
+
 
       let mk_quick_tag_loop _ sl ss tree tag = ();
 	fun t ctx ->
@@ -849,7 +869,7 @@ END
 	type t = fun_tree array array
 
 	let dummy = fun _ _ _ _ _ -> failwith "Uninitializd CodeCache"
-	let default_line = Array.create 256 dummy (* 256 = max_tag *)
+	let default_line = Array.create 1024 dummy (* 1024 = max_tag *)
 	let create n = Array.create n default_line 
 	let init f = 
 	  for i = 0 to (Array.length default_line) - 1
@@ -871,9 +891,6 @@ END
 
       end
 
-      let td_trans = CodeCache.create 10000 (* should be number of tags *number of states^2
-						in the document *)
-
       let empty_size n =
 	let rec loop acc = function 0 -> acc
 	  | n -> loop (SList.cons StateSet.empty acc) (n-1)
@@ -887,9 +904,9 @@ END
 	type t = Obj.t array array array array
 	let dummy_val = Obj.repr ((),2,()) 
 
-	let default_line3 = Array.create 10000 dummy_val
-	let default_line2 = Array.create 10000 default_line3
-	let default_line1 = Array.create 10000 default_line2
+	let default_line3 = Array.create BIG_A_SIZE dummy_val
+	let default_line2 = Array.create BIG_A_SIZE default_line3
+	let default_line1 = Array.create BIG_A_SIZE default_line2
 
 	let create n = Array.create n default_line1
 	
@@ -905,18 +922,18 @@ END
 	  if e == default then
 	  let ne = Array.copy e in (set tab idx ne;ne)
 	  else e
-
+	  
 	let add h tag fl s1 s2 (data: SList.t*bool*(merge_conf array)) =
 	  let l1 = get_replace h tag default_line1 in
 	  let l2 = get_replace l1 (Uid.to_int fl.Formlistlist.Node.id) default_line2 in
-	  let l3 = get_replace l2 (Uid.to_int s1.SList.Node.id) default_line3 in 
+	  let l3 = get_replace l2 (Uid.to_int s1.SList.Node.id) default_line3  in 
 	  set l3 (Uid.to_int s2.SList.Node.id) (Obj.repr data)
       end
 
 	     
-      let h_fold2 = Fold2Res.create 256
+
       
-      let top_down ?(noright=false) a tree t slist ctx slot_size =	
+      let top_down ?(noright=false) a tree t slist ctx slot_size td_trans h_fold2=	
 	let pempty = empty_size slot_size in	
 	let rempty = Array.make slot_size RS.empty in
 	(* evaluation starts from the right so we put sl1,res1 at the end *)
@@ -1139,15 +1156,218 @@ END
 	let _ = CodeCache.init mk_trans in
 	(if noright then loop_no_right else loop) t ctx slist Tag.dummy
 
-	let run_top_down a tree =
-	  let init = SList.cons a.init SList.nil in
-	  let _,res = top_down a tree Tree.root init Tree.root 1 
-	  in 
-	    D_IGNORE_(
-	      output_trace a tree "trace.html"
-		(RS.fold (fun t a -> IntSet.add (Tree.id tree t) a) res.(0) IntSet.empty),
+
+      let run_top_down a tree =
+	let init = SList.cons a.init SList.nil in
+	let _,res = top_down a tree Tree.root init Tree.root 1 (CodeCache.create BIG_A_SIZE) (Fold2Res.create 1024)
+	in 
+	D_IGNORE_(
+	  output_trace a tree "trace.html"
+	    (RS.fold (fun t a -> IntSet.add (Tree.id tree t) a) res.(0) IntSet.empty),
 	      res.(0))
-	;;
+      ;;
+      
+
+
+
+
+      module Code3Cache = 
+      struct
+	let get = Array.unsafe_get
+	let set = Array.set
+
+	type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> StateSet.t ->  Tag.t -> StateSet.t*RS.t
+	type t = fun_tree array array
+
+	let dummy = fun _ _ _ _ -> failwith "Uninitializd Code3Cache"
+	let default_line = Array.create 1024 dummy (* 256 = max_tag *)
+	let create n = Array.create n default_line 
+	let init f = 
+	  for i = 0 to (Array.length default_line) - 1
+	  do
+	    default_line.(i) <- f
+	  done
+	    
+	let get_fun h slist tag =
+	  get (get h (Uid.to_int slist.StateSet.Node.id)) tag
+
+	let set_fun (h : t) slist tag (data : fun_tree) =
+	  let tab = get h (Uid.to_int slist.StateSet.Node.id) in
+	  let line = if tab == default_line then
+	    let x = Array.copy tab in
+	    (set h (Uid.to_int slist.StateSet.Node.id) x;x)
+	  else tab
+	  in
+	  set line tag data	  
+
+      end
+
+
+	  
+      module Fold3Res = struct
+	let get = Array.unsafe_get
+	let set = Array.set 
+	external field1 : Obj.t -> int = "%field1"
+	type t = Obj.t array array array array
+	let dummy_val = Obj.repr ((),2,()) 
+
+	let default_line3 = Array.create 1024 dummy_val
+	let default_line2 = Array.create BIG_A_SIZE default_line3
+	let default_line1 = Array.create BIG_A_SIZE default_line2
+
+	let create n = Array.create n default_line1
+	
+	let find h tag fl s1 s2 : StateSet.t*bool*merge_conf = 
+	  let l1 = get h (Uid.to_int fl.Formlist.Node.id) in
+	  let l2 = get l1 (Uid.to_int s1.StateSet.Node.id) in
+	  let l3 = get l2 (Uid.to_int s2.StateSet.Node.id) in
+	  Obj.magic (get l3 tag)
+	  
+	let is_valid b = b != (Obj.magic dummy_val)
+	let get_replace tab idx default =
+	  let e = get tab idx in
+	  if e == default then
+	  let ne = Array.copy e in (set tab idx ne;ne)
+	  else e
+	  
+	let add h tag fl s1 s2 (data: StateSet.t*bool*merge_conf) =
+	  let l1 = get_replace h (Uid.to_int fl.Formlist.Node.id) default_line1 in
+	  let l2 = get_replace l1 (Uid.to_int s1.StateSet.Node.id) default_line2 in
+	  let l3 = get_replace l2 (Uid.to_int s2.StateSet.Node.id) default_line3 in 
+	  set l3 tag (Obj.repr data)
+      end
+
+
+      let empty_res = StateSet.empty,RS.empty
+
+      let top_down1 a tree t slist ctx td_trans h_fold2  =	
+	(* evaluation starts from the right so we put sl1,res1 at the end *)
+	let eval_fold2_slist fll t tag (sl2,res2) (sl1,res1) =	 
+	  let data = Fold3Res.find h_fold2 tag fll sl1 sl2  in
+	  if Fold3Res.is_valid data then
+	  let r,b,conf = data in
+	  (r,if b then RS.merge conf t res1 res2 else RS.empty)
+	  else
+	  let r,conf = eval_formlist tag sl1 sl2 fll in
+	  let b = conf <> NO in
+	  (Fold3Res.add h_fold2 tag fll sl1 sl2 (r,b,conf);
+	   (r, if b then RS.merge conf t res1 res2 else RS.empty))
+	 
+	in
+	let rec loop t ctx slist _  =
+	  if t == Tree.nil then empty_res else
+	  let tag = Tree.tag tree t in
+	  (Code3Cache.get_fun td_trans slist tag) t ctx slist tag
+
+	and loop_tag t ctx slist tag  =
+	  if t == Tree.nil then empty_res else 
+	  (Code3Cache.get_fun td_trans slist tag) t ctx slist tag
+	  
+	and mk_trans t ctx slist tag = 
+	  let fl_list,llist,rlist,ca,da,sa,fa = 
+	    StateSet.fold
+	      (fun q acc ->			    
+	 	 List.fold_left 
+		   (fun ((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc) as acc) 
+		    (ts,t)  ->
+		      if (TagSet.mem tag ts)
+		      then 
+		      let _,_,_,f,_ = t.Transition.node in
+		      let (child,desc,below),(sibl,foll,after) = Formula.st f in
+		      (Formlist.cons t fl_acc,
+		       StateSet.union ll_acc below,
+		       StateSet.union rl_acc after,
+		       StateSet.union child c_acc,
+		       StateSet.union desc d_acc,
+		       StateSet.union sibl s_acc,
+		       StateSet.union foll f_acc)		 
+		      else acc ) acc (
+		     try Hashtbl.find a.trans q 
+		     with
+			Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
+			  q;[]
+		   )
+		   
+	      ) slist (Formlist.nil,StateSet.empty,StateSet.empty,
+		       StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty)
+
+	  in			
+	  (* Logic to chose the first and next function *)
+	  let tags_child,tags_below,tags_siblings,tags_after = Tree.tags tree tag in
+	  let d_f = Algebra.decide a tags_child tags_below (StateSet.union ca da) true in
+	  let d_n = Algebra.decide a tags_siblings tags_after (StateSet.union sa fa) false in
+	  let f_kind,first = choose_jump_down tree d_f
+	  and n_kind,next = choose_jump_next tree d_n in 
+
+          let cont =
+            match f_kind,n_kind with
+              | `NIL,`NIL -> 
+		  fun t _ _ tag   -> eval_fold2_slist fl_list t tag empty_res empty_res
+		
+	      |  _,`NIL -> (
+                   match f_kind with
+                     |`TAG(tag1) -> 
+			(fun t _ _ tag  -> eval_fold2_slist fl_list t tag empty_res
+			  (loop_tag (first t) t llist tag1))
+		     | _ ->
+			 fun t _ _ tag  -> eval_fold2_slist fl_list t tag empty_res
+			   (loop (first t) t llist tag)
+		 )
+              | `NIL,_ -> (
+                  match n_kind with
+                    |`TAG(tag2) -> 
+		       fun t ctx _ tag  ->
+			 eval_fold2_slist fl_list t tag 
+			   (loop_tag (next t ctx) ctx rlist tag2)
+			   empty_res
+
+                    | _ -> 
+			fun t ctx _ tag ->
+			  eval_fold2_slist fl_list t tag 
+			    (loop (next t ctx) ctx rlist tag)
+			    empty_res
+                        
+		)
+		  
+              | `TAG(tag1),`TAG(tag2) -> 
+		  fun t ctx _ tag -> 
+		    eval_fold2_slist fl_list t tag
+		      (loop_tag (next t ctx) ctx rlist tag2)		  
+		      (loop_tag (first t) t llist tag1)
+ 
+              | `TAG(tag1),`ANY -> 
+		  fun t ctx _ tag -> 
+		    eval_fold2_slist fl_list t tag
+		      (loop (next t ctx) ctx rlist tag)
+		      (loop_tag (first t) t llist tag1)
+
+              | `ANY,`TAG(tag2) -> 
+		  fun t ctx _ tag -> 
+		    eval_fold2_slist fl_list t tag
+		      (loop_tag (next t ctx) ctx rlist tag2)		  
+		      (loop (first t) t llist tag)
+                         
+								   
+              | _,_ -> 
+                  fun t ctx _ tag -> 
+		    eval_fold2_slist fl_list t tag
+		      (loop (next t ctx) ctx rlist tag)		  
+		      (loop (first t) t llist tag)
+
+	      
+
+	  in
+	  Code3Cache.set_fun td_trans slist tag cont; 
+	  cont t ctx slist tag 
+	in 
+	let _ = Code3Cache.init mk_trans in
+	loop t ctx slist Tag.dummy
+
+
+      let run_top_down1 a tree =
+	let _,res = top_down1 a tree Tree.root a.init Tree.root (Code3Cache.create BIG_A_SIZE) (Fold3Res.create BIG_A_SIZE)
+	in 
+	  res
 
 	module Configuration =
 	struct
@@ -1165,7 +1385,7 @@ END
 	    if Ptss.mem s c.sets then
 	      { c with results = IMap.add s (RS.concat r (IMap.find s c.results)) c.results}
 	    else
-	      { hash = HASHINT2(c.hash,Uid.to_int (Ptset.Int.uid s));
+	      { hash = HASHINT2(c.hash,Uid.to_int s.StateSet.Node.id);
 		sets = Ptss.add s c.sets;
 		results = IMap.add s r c.results
 	      }
@@ -1199,7 +1419,7 @@ END
 	    in
 	    let h,s =
 	      Ptss.fold 
-		(fun s (ah,ass) -> (HASHINT2(ah, Uid.to_int (Ptset.Int.uid s)),
+		(fun s (ah,ass) -> (HASHINT2(ah, Uid.to_int s.StateSet.Node.id ),
 				    Ptss.add s ass))
 		(Ptss.union c1.sets c2.sets) (0,Ptss.empty)
 	    in
@@ -1223,8 +1443,8 @@ END
 		     Hashtbl.find h_fold key
 		   with
 		      Not_found -> let res = 
-			if dir then eval_formlist tag s Ptset.Int.empty formlist
-			else eval_formlist tag Ptset.Int.empty s formlist 
+			if dir then eval_formlist tag s StateSet.empty formlist
+			else eval_formlist tag StateSet.empty s formlist 
 		      in (Hashtbl.add h_fold key res;res)
 		 in
 		 let (rb,rb1,rb2,mark) = bool_of_merge mcnf in
@@ -1297,7 +1517,7 @@ END
 	  let slist = SList.rev (slist) in 
 	  let newconf = fold_f_conf tree parent slist fl_list conf dir in
 	  let accu,newconf = Configuration.IMap.fold (fun s res (ar,nc) ->
-							if Ptset.Int.intersect s init then
+							if StateSet.intersect s init then
 							  ( RS.concat res ar ,nc)
 							else (ar,Configuration.add nc s res))
 	    (newconf.Configuration.results) (accu,Configuration.empty) 
@@ -1314,8 +1534,8 @@ END
 	      | Not_found -> 
 		  let res = Hashtbl.fold (fun q l acc -> 
 					    if List.exists (fun (ts,_) -> TagSet.mem tag ts) l
-					    then Ptset.Int.add q acc
-					    else acc) a.trans Ptset.Int.empty
+					    then StateSet.add q acc
+					    else acc) a.trans StateSet.empty
 		  in Hashtbl.add h_tdconf tag res;res
 	  in 
 (*	  let _ = pr ", among ";
@@ -1323,7 +1543,7 @@ END
 	    pr "\n%!";
 	  in *)
 	  let r = SList.cons r SList.nil in
-	  let set,res = top_down (~noright:noright) a tree t r t 1 in
+	  let set,res = top_down (~noright:noright) a tree t r t 1 (CodeCache.create BIG_A_SIZE) (Fold2Res.create 1024) in
 	  let set = match SList.node set with
 	    | SList.Cons(x,_) ->x
 	    | _ -> assert false 
@@ -1371,9 +1591,10 @@ END
 
     end
           
-    let top_down_count a t = let module RI = Run(Integer) in let r = Integer.length (RI.run_top_down a t)
-    in (*RI.TransCache.dump RI.td_trans; *)r
-     let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t)
+    let top_down_count a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down a t)
+    let top_down_count1 a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down1 a t)
+    let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t)
+    let top_down1 a t = let module RI = Run(IdSet) in (RI.run_top_down1 a t)
     let bottom_up_count a t k = let module RI = Run(Integer) in Integer.length (RI.run_bottom_up a t k)
     let bottom_up a t k = let module RI = Run(IdSet) in (RI.run_bottom_up a t k)
 
@@ -1381,5 +1602,6 @@ END
       struct
 	module Results = GResult(Doc)
 	let top_down a t = let module R = Run(Results) in (R.run_top_down a t)
+	let top_down1 a t = let module R = Run(Results) in (R.run_top_down1 a t)
       end