Contents of /types/sequence.ml

Revision 58 - (hide annotations)
Tue Jul 10 17:01:56 2007 UTC (5 years, 10 months ago) by abate
File size: 1624 byte(s)
```[r2002-10-29 18:49:26 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-29 18:49:26+00:00```
 1 abate 18 let nil_atom = Types.mk_atom "nil" 2 let nil_type = Types.atom (Atoms.atom nil_atom) 3 abate 17 4 let decompose t = 5 abate 18 (Types.Atom.has_atom t nil_atom, 6 abate 17 Types.Product.get t) 7 8 module V = Types.Positive 9 module H = Types.DescrHash 10 11 let mapping f t queue = 12 let memo = H.create 13 in 13 abate 31 let rec aux t = 14 abate 17 try H.find memo t 15 with Not_found -> 16 let v = V.forward () in 17 H.add memo t v; 18 let (has_nil,rect) = decompose t in 19 abate 31 let l = List.map (fun (t1,t2) -> f t1 (aux t2)) rect in 20 abate 17 let l = if has_nil then queue :: l else l in 21 V.define v (V.cup l); 22 v 23 in 24 abate 31 aux t 25 abate 17 26 27 let aux_concat = mapping (fun t v -> V.times (V.ty t) v) 28 abate 18 let aux_flatten t = mapping aux_concat t (V.ty nil_type) 29 let aux_map f t = mapping (fun t v -> V.times (V.ty (f t)) v) t (V.ty nil_type) 30 abate 17 31 let solve x = Types.descr (V.solve x) 32 33 let concat t1 t2 = solve (aux_concat t1 (V.ty t2)) 34 let flatten t = solve (aux_flatten t) 35 let map f t = solve (aux_map f t) 36 37 let recurs f = 38 let n = Types.make () in 39 Types.define n (f n); 40 Types.internalize n 41 42 abate 31 let star_node t = recurs (fun n -> Types.cup nil_type (Types.times t n )) 43 abate 17 44 abate 31 let any_node = star_node (Types.cons Types.any) 45 abate 17 let any = Types.descr any_node 46 abate 31 let seqseq = Types.descr (star_node any_node) 47 abate 17 48 abate 31 let star t = Types.descr (star_node (Types.cons t)) 49 abate 58 let string = star (Types.Char.any) 50 abate 31 51 let approx t = 52 let memo = H.create 13 in 53 let res = ref Types.empty in 54 let rec aux t = 55 try H.find memo t 56 with Not_found -> 57 H.add memo t (); 58 let rect = Types.Product.get t in 59 List.iter (fun (t1,t2) -> res := Types.cup t1 !res; aux t2) rect; 60 in 61 aux t; 62 !res 63 64