[r2005-03-23 16:03:28 by afrisch] Empty log message

Original author: afrisch
Date: 2005-03-23 16:03:29+00:00

misc/bool.ml

@@ -360,7 +360,7 @@ struct
       | Split (_,y,p,i,n) ->
 	  let c = X.compare x y in
 	  assert (c <> 0);
-	  if x < y then 
+	  if (c < 0) then 
 	    if pos then split x a False False
 	    else split x False False a
 	  else split y (cap_atom x pos p) (cap_atom x pos i) (cap_atom x pos n)

runtime/value.ml

@@ -699,9 +699,14 @@ let mk_record labels fields =
   Record (LabelMap.from_list_disj !l)
   
 
+(* TODO: optimize cases
+     - (f x = [])
+     - all chars copied or deleted *)
+
 let rec transform_aux f accu = function
   | Pair (x,y) -> let accu = Concat (accu, f x) in transform_aux f accu y
   | Atom _ -> accu
   | v -> transform_aux f accu (normalize v)
 
 let transform f v = transform_aux f nil v
+

types/sequence.ml

@@ -105,7 +105,6 @@ let approx t =
 let map_tree f seq =
   let memo = ref H.empty in
   let rec aux t =
- (*   Printf.eprintf "A"; flush stderr; *)
     try H.find t !memo
     with Not_found ->
       let v = V.forward () in
@@ -126,18 +125,48 @@ let map_tree f seq =
     if iter = [] then result else
       V.cup [V.times (V.cup iter) v; result ]
   in
-  let d = Types.descr (V.solve (aux seq)) in
-(*  Printf.eprintf "Done."; flush stderr; *)
-(*  Format.fprintf Format.std_formatter "%a\n" Types.Print.print_descr d; *)
-  d
+  Types.descr (V.solve (aux seq))
 
-(* TODO: avoid flushing the memo between calls to mapping inside map_tree *)
+let map_tree_mono domain seq =
+  let ts = ref [] in
+  let vs = ref [] in
 
-  (* <helpers> *)
+  let memo = ref H.empty in
+  let rec aux t =
+    try H.find t !memo
+    with Not_found ->
+      let v = V.forward () in
+      memo := H.add t v !memo;
+      let v' = mapping descr_aux t (V.ty nil_type) in
+      V.define v v';
+      v
+  and descr_aux t v =
+    let residual = Types.diff t domain in
+
+    let f2 (attr,child) = V.times (V.ty attr) (aux child) in
+    let f1 (tag,x) =
+      let x = V.cup (List.map f2 (Types.Product.get x)) in
+      V.xml (V.ty tag) x in
+    let iter = List.map f1 (Types.Product.get ~kind:`XML residual) in
+    let resid = Types.Product.other ~kind:`XML residual in
+    let iter = if Types.is_empty resid then iter else V.ty resid :: iter in
+
+    let result = V.forward () in
+    ts := (Types.cap domain t) :: !ts; vs := (result,v) :: !vs;
+    if iter = [] then result else
+    V.cup [V.times (V.cup iter) v; result ]
+
+  in
+  let r = aux seq in
+  !ts, (fun fts ->
+	  List.iter2 (fun t (result,v) -> V.define result (aux_concat t v))
+	    fts !vs;
+	  solve r)
+
+(* TODO: avoid flushing the memo between calls to mapping inside map_tree *)
 
 let seq_of_list l =
   let times' t acc = Types.times (Types.cons t) (Types.cons acc) in
   List.fold_right times' l nil_type
 
-  (* </helpers> *)
 

types/sequence.mli

@@ -10,12 +10,14 @@ val concat: Types.t -> Types.t -> Types.t
 val flatten: Types.t -> Types.t
 val map: (Types.t -> Types.t) -> Types.t -> Types.t
 
-val map_mono: Types.t -> Types.t list * (Types.t list -> Types.t)
 
 val map_tree: 
   (Types.t -> Types.t * Types.t) -> Types.t -> Types.t
  (* input type -> (result, residual) *)         (* sequence type *)
 
+val map_mono: Types.t -> Types.t list * (Types.t list -> Types.t)
+val map_tree_mono: Types.t -> Types.t -> Types.t list * (Types.t list -> Types.t)
+
 val star: Types.t -> Types.t
   (* For a type t, returns [t*] *)
 val plus: Types.t -> Types.t