[r2005-06-13 15:20:13 by afrisch] Simplifications

Original author: afrisch
Date: 2005-06-13 15:20:14+00:00

Makefile.distrib

@@ -145,6 +145,7 @@ OBJECTS = \
  misc/state.cmo misc/pool.cmo misc/encodings.cmo \
   misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
  misc/html.cmo \
+ misc/ptmap.cmo misc/hashset.cmo \
  \
  types/sortedList.cmo misc/bool.cmo types/boolean.cmo types/ident.cmo \
  types/intervals.cmo \

depend

@@ -26,11 +26,13 @@ misc/imap.cmo: misc/imap.cmi
 misc/imap.cmx: misc/imap.cmi 
 misc/html.cmo: misc/html.cmi 
 misc/html.cmx: misc/html.cmi 
+misc/ptmap.cmo: misc/ptmap.cmi 
+misc/ptmap.cmx: misc/ptmap.cmi 
 types/sortedList.cmo: misc/serialize.cmi misc/custom.cmo types/sortedList.cmi 
 types/sortedList.cmx: misc/serialize.cmx misc/custom.cmx types/sortedList.cmi 
-misc/bool.cmo: types/sortedList.cmi misc/serialize.cmi misc/custom.cmo \
+misc/bool.cmo: misc/serialize.cmi misc/hashset.cmo misc/custom.cmo \
     misc/bool.cmi 
-misc/bool.cmx: types/sortedList.cmx misc/serialize.cmx misc/custom.cmx \
+misc/bool.cmx: misc/serialize.cmx misc/hashset.cmx misc/custom.cmx \
     misc/bool.cmi 
 types/boolean.cmo: types/sortedList.cmi misc/custom.cmo types/boolean.cmi 
 types/boolean.cmx: types/sortedList.cmx misc/custom.cmx types/boolean.cmi 

driver/cduce.ml

@@ -200,7 +200,7 @@ let debug ppf tenv cenv = function
       Format.fprintf ppf "[DEBUG:compile]@.";
       let t = Typer.typ tenv t
       and pl = List.map (Typer.pat tenv) pl in  
-      Patterns.Compile2.debug_compile ppf t pl;
+      Patterns.Compile.debug_compile ppf t pl;
       Format.fprintf ppf "@.";
 
 (*

misc/bool.mli

@@ -4,6 +4,7 @@ sig
   type elem
 
   val get: t -> (elem list * elem list) list
+  val get': t -> (elem list * (elem list) list) list
 
   val empty : t
   val full  : t
@@ -30,6 +31,7 @@ module type MAKE = functor (X : Custom.T) -> S with type elem = X.t
 
 module Make : MAKE
 
+(*
 module type S' = sig
   include S
   type bdd = False | True | Br of elem * t * t
@@ -38,12 +40,10 @@ end
 
 module MakeBdd(X : Custom.T) : S' with type elem = X.t
 
-(*
 module type S'' = sig
   include S
-  type tree = Split of elem list * elem list * tree list option
-  val get_tree: t -> tree
+  val dnf: (elem list -> (elem list) list -> unit) -> t -> unit
 end
 
-module Simplify(X : Custom.T) : S'' with type elem = X.t
+module Make2(X : Custom.T) : S'' with type elem = X.t
 *)

types/patterns.ml

@@ -599,6 +599,8 @@ module Normal = struct
   module NodeSet = SortedList.Make(Node)
 
   module Nnf = struct
+    include Custom.Dummy
+
     type t = NodeSet.t * Types.t * IdSet.t (* pl,t;   t <= \accept{pl} *)
 	
     let check (pl,t,xs) =
@@ -909,6 +911,13 @@ module Normal = struct
       IdSet.empty
       pl
 
+  let factorize t0 (pl,t,xs) =
+    let t0 = if Types.subtype t t0 then t else Types.cap t t0 in
+    let vs_var = facto Factorize.var t0 xs pl in
+    let xs = IdSet.diff xs vs_var in
+    let vs_nil = facto Factorize.nil t0 xs pl in
+    (vs_var,vs_nil,(pl,t,xs))
+
   let normal f l t pl xs =
     let a = nconstr l t in
 
@@ -936,7 +945,7 @@ module Normal = struct
     let t =
       if Types.subtype t t0 then t else Types.cap t t0 in
 (*    let ppf = Format.std_formatter in
-     Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs); *)
+     Format.fprintf ppf "normal nnf=%a@." Nnf.print (pl,t,xs);  *)
     normal facto lab t (NodeSet.get pl) xs
     
 
@@ -1000,7 +1009,7 @@ struct
   and dispatcher = {
     id : int;
     t  : Types.t;
-    pl : Normal.t array;
+    pl : Normal.Nnf.t array;
     label : label option;
     interface : interface;
     codes : return_code array;
@@ -1112,10 +1121,10 @@ struct
   let cur_id = State.ref "Patterns.cur_id" 0
 		 (* TODO: save dispatchers ? *)
 		 
-  module NfMap = Map.Make(Normal)
-  module NfSet = Set.Make(Normal)
+  module NfMap = Map.Make(Normal.Nnf)
+  module NfSet = Set.Make(Normal.Nnf)
 
-  module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Normal)))
+  module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Normal.Nnf)))
 
     (* Try with a hash-table ! *)
     
@@ -1136,7 +1145,7 @@ struct
     let ppf = Format.std_formatter in
     Format.fprintf ppf "Dispatcher t=%a@." Types.Print.print disp.t;
     Array.iter (fun p ->
-		 Format.fprintf ppf "  pat %a@." Normal.print p;
+		 Format.fprintf ppf "  pat %a@." Normal.Nnf.print p;
 	      ) disp.pl
    
   let dispatcher t pl lab : dispatcher =
@@ -1149,14 +1158,11 @@ struct
 	then (incr nb; let r = Array.of_list (List.rev accu) in 
 	      codes := (t,arity,r)::!codes; `Result (!nb - 1))
 	else
-	  let p = pl.(i) in
-	  let tp = p.Normal.na in
-
+	  let (_,tp,v) = pl.(i) in
 	  let a1 = Types.cap t tp in
 	  if Types.is_empty a1 then
 	    `Switch (`None,aux t arity (i+1) (None::accu))
 	  else
-	    let v = p.Normal.nfv in
 	    let a2 = Types.diff t tp in
 	    let accu' = Some (IdMap.num arity v) :: accu in
 	    if Types.is_empty a2 then
@@ -1243,9 +1249,9 @@ struct
 	   | (l,r) -> Recompose (l,r))
 
   module TypeList = SortedList.Make(Types)
-  let dispatch_basic disp : (Types.t * result) list =
+  let dispatch_basic disp pl : (Types.t * result) list =
 (* TODO: try other algo, using disp.codes .... *)
-    let pl = Array.map (fun p -> p.Normal.nbasic) disp.pl in
+    let pl = Array.map (fun p -> p.Normal.nbasic) pl in
     let tests =
       let accu = ref [] in
       let aux i (res,x) = accu := (x, [i,res]) :: !accu in
@@ -1280,24 +1286,31 @@ struct
   let get_tests facto pl f t d post =
     let pl = Array.map (List.map f) pl in
     let lab = first_lab t pl in
-    let pl = Array.map (List.map (fun (x,info) -> Normal.nnf facto lab t x,info)) pl
-    in
+
     (* Collect all subrequests *)
-    let aux reqs ((_,_,req),_) = NfSet.add req reqs in
+    let aux reqs (req,_) = NfSet.add req reqs in
     let reqs = Array.fold_left (List.fold_left aux) NfSet.empty pl in
     let reqs = Array.of_list (NfSet.elements reqs) in
+
     (* Map subrequest -> idx in reqs *)
     let idx = ref NfMap.empty in
     Array.iteri (fun i req -> idx := NfMap.add req i !idx) reqs;
     let idx = !idx in
 
     (* Build dispatcher *)
+    let reqs_facto =
+      if facto then Array.map (Normal.factorize t) reqs
+      else Array.map (fun r -> [],[],r) reqs in
+    let reqs = Array.map (fun (_,_,req) -> req) reqs_facto in
+
     let disp = dispatcher t reqs lab in
     
     (* Build continuation *)
     let result (t,ar,m) =
-      let get a ((vars,nils,req),info) =
-	match m.(NfMap.find req idx) with Some res -> ((vars,nils,res),info)::a | _ -> a in
+      let get a (req,info) =
+	let i = NfMap.find req idx in
+	let (var,nil,_) = reqs_facto.(i) in
+	match m.(i) with Some res -> ((var,nil,res),info)::a | _ -> a in
       let pl = Array.map (List.fold_left get []) pl in
       d t ar pl
     in
@@ -1310,8 +1323,9 @@ struct
     let t0 = ref t in
     let aux (p,e) = 
       let xs = fv p in
-      let nnf = (Normal.NodeSet.singleton p, !t0, xs) in
-      t0 := Types.diff !t0 (Types.descr (accept p));
+      let tp = Types.descr (accept p) in
+      let nnf = (Normal.NodeSet.singleton p, Types.cap !t0 tp, xs) in
+      t0 := Types.diff !t0 tp;
       [(nnf, (xs, e))] in
     let res _ _ pl =
       let aux r = function 
@@ -1324,12 +1338,12 @@ struct
     get_tests false pl (fun x -> x) t res (fun x -> x)
 
 
-  let rec dispatch_prod ?(kind=`Normal) disp =
+  let rec dispatch_prod ?(kind=`Normal) disp pl =
     let extr = match kind with
 	| `Normal ->  fun p -> Normal.NLineProd.get p.Normal.nprod
 	| `XML -> fun p -> Normal.NLineProd.get p.Normal.nxml in
     let t = Types.Product.get ~kind disp.t in
-    dispatch_prod0 disp t (Array.map extr disp.pl)
+    dispatch_prod0 disp t (Array.map extr pl)
   and dispatch_prod0 disp t pl =
     get_tests true pl
       (fun (res,p,q) -> p, (res,q))
@@ -1348,7 +1362,7 @@ struct
     return disp pl aux_final (ar1 + ar2)
 
 
-  let dispatch_record disp : record option =
+  let dispatch_record disp pl : record option =
     let t = disp.t in
     if not (Types.Record.has_record t) then None 
     else
@@ -1360,7 +1374,7 @@ struct
 		let pl = Array.map (fun p -> match p.Normal.nrecord with
 				      | Normal.RecNolabel (Some x,_) -> [x]
 				      | Normal.RecNolabel (None,_) -> []
-				      | _ -> assert false) disp.pl in
+				      | _ -> assert false) pl in
 		Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
 	      else None
 	    in
@@ -1369,7 +1383,7 @@ struct
 		let pl = Array.map (fun p -> match p.Normal.nrecord with
 				      | Normal.RecNolabel (_,Some x) -> [x]
 				      | Normal.RecNolabel (_,None) -> []
-				      | _ -> assert false) disp.pl in
+				      | _ -> assert false) pl in
 		Some (return disp pl (IdMap.map_to_list conv_source_basic) 0)
 	      else None
 	    in	      
@@ -1379,7 +1393,7 @@ struct
 	    let pl = Array.map (fun p -> match p.Normal.nrecord with
 				  | Normal.RecLabel (_,l) -> 
 				      Normal.NLineProd.get l
-				  | _ -> assert false) disp.pl in
+				  | _ -> assert false) pl in
 	    Some (RecLabel (lab,dispatch_prod0 disp t pl))
       
   let iter_disp_disp f g = function
@@ -1402,11 +1416,16 @@ struct
     match disp.actions with
       | Some a -> a
       | None ->
+	  let pl =
+	    Array.map
+	      (fun n -> let _,_,p = Normal.nnf false disp.label disp.t n in p)
+	      disp.pl in
+
 	  let a = combine_kind
-		    (dispatch_basic disp)
-		    (dispatch_prod disp)
-		    (dispatch_prod ~kind:`XML disp)
-		    (dispatch_record disp)
+		    (dispatch_basic disp pl)
+		    (dispatch_prod disp pl)
+		    (dispatch_prod ~kind:`XML disp pl)
+		    (dispatch_record disp pl)
 	  in
 	  disp.actions <- Some a;
 	  iter_disp_actions (fun d -> to_generate := d :: !to_generate) a;
@@ -1585,13 +1604,8 @@ struct
 	(Types.Record.first_label t) pl in
     let lab = if lab == LabelPool.dummy_max then None else Some lab in
     
-    let pl = Array.of_list 
-	       (List.map (fun p -> 
-			    let n = Normal.nnf false lab t ([p],t,fv p) in
-			    match n with
-			      | [],[],x -> x
-			      | _ -> assert false
-			 ) pl) in
+    let pl = Array.of_list
+	       (List.map (fun p -> ([p],Types.cap t (Types.descr (accept p)),fv p)) pl) in
     show ppf t pl lab;
     Format.fprintf ppf "# compiled states: %i@\n" !generated
 
@@ -1612,7 +1626,6 @@ end
 
 (****** More efficient compilation (less optimized) ******)
 
-
 module Compile2 = 
 struct
   type source = 
@@ -2032,6 +2045,41 @@ struct
 	  | None -> map_filter f tl 
 	  | Some x -> x :: (map_filter f tl)
 
+(*
+  let cup x y t =
+    match x t with
+      | `Binds _ as r1 -> r1
+      | `Fail -> y t
+      | r1 -> match y t with
+	  | `Fail -> r1
+	  | r2 -> `Cup (r1,r2)
+
+  let cap x y t =
+    match x t with
+      | `Fail -> `Fail
+      | `Binds b1 as r1 -> 
+	  (match y t with
+	     | `Fail -> `Fail
+	     | `Binds b2 -> `Binds (LabelMap.union_disj b1 b2)
+	     | r2 -> `Cap (r1,r2))
+      | r1 -> match y t with
+	  | `Fail -> `Fail
+	  | r2 -> `Cap (r1,r2)
+
+  let rec prod_tests t0 d tests1 = match d with
+    | Req.RBinds b -> `Binds b
+    | Req.RTimes (q1,q2,xs,_) -> 
+	`Times (reg_test tests1 (Types.Product.pi1 t0) q1 xs,q2,xs)
+    | Req.RCup (p1,p2) -> cup (prod_tests t0 p1) (prod_tests t0 p2) tests1
+    | Req.RCap (p2,p1) -> cap (prod_tests t0 p1) (prod_tests t0 p2) tests1
+    | Req.RConstr s -> 
+	let rects = Types.Product.get ~kind:`Normal s in
+	let rects = List.map (fun (s1,s2) -> reg_test_type tests1 s1, s2) rects in
+	`Prod rects
+    | _ -> `Fail
+*)
+
+
   let rec prod_tests t0 d tests1 = match d with
     | Req.RBinds b -> (fun t1 ar1 tests2 ar2 -> Some b)
     | Req.RTimes (q1,q2,xs,_) ->

web/site.cd

@@ -11,7 +11,6 @@ let (input,outdir) =
   | [ s ("-o" o | /(o := "www")) ] -> (s,o)
   | _ -> raise "Please use --arg to specify an input file on the command line"
 
-
 (** Generic purpose functions **)
 
 (* Recursive inclusion of XML files and verbatim text files *)
@@ -35,8 +34,6 @@ let [<site>[ <title>site (<footer>footer | /(footer:=[])) main_page ] ] =
    print ['Invalid input document:\n' !err '\n']; 
    exit 2 
 
-
-
 (* Highlighting text between {{...}} *)
 
 let highlight (String -> [ (Char | H.strong | H.i)* ] )
@@ -392,7 +389,7 @@ match page with
 
 (* Preparing left panel *)
 
- let left = 
+ let left =
   if leftbar then
   let navig = transform items with <left>c -> [ c ] in
   let left = match navig with [] -> [ [<boxes-toc>[]] ] | n -> n in