viewcvs.cgi/types/sequence.ml

let nil_atom = Types.AtomPool.mk "nil"
let nil_type = Types.atom (Atoms.atom nil_atom)

let decompose t =
  (Types.Atom.has_atom t nil_atom,
   Types.Product.get t)

module V = Types.Positive
module H = Types.DescrMap

let mapping f t queue =
  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 (has_nil,rect) = decompose t in
      let l = List.map (fun (t1,t2) -> f t1 (aux t2)) rect in
      let l = if has_nil then queue :: l else l in
      V.define v (V.cup l);
      v
  in
  aux t
  

let aux_concat = mapping (fun t v -> V.times (V.ty t) v)
let aux_flatten t = mapping aux_concat t (V.ty nil_type)
let aux_map f t = mapping (fun t v -> V.times (V.ty (f t)) v) t (V.ty nil_type)

let solve x = Types.descr (V.solve x)

let concat t1 t2 = solve (aux_concat t1 (V.ty t2))
let flatten t = solve (aux_flatten t)
let map f t = solve (aux_map f t)

let recurs f =
  let n = Types.make () in
  Types.define n (f n);
  Types.internalize n

let star_node t = recurs (fun n -> Types.cup nil_type (Types.times t n ))

let any_node = star_node (Types.cons Types.any)
let any = Types.descr any_node
let seqseq = Types.descr (star_node any_node)

let star t = Types.descr (star_node (Types.cons t))
let plus t = let t = Types.cons t in Types.times t (star_node t)
let string = star (Types.Char.any)  

let approx t =
  let memo = ref H.empty in
  let res = ref Types.empty in
  let rec aux t =
    try H.find t !memo
    with Not_found ->
      memo := H.add t () !memo;
      let rect = Types.Product.get t in
      List.iter (fun (t1,t2) -> res := Types.cup t1 !res; aux t2) rect;
  in
  aux t;
  !res

  
1	abate	78	let nil_atom = Types.AtomPool.mk "nil"
2	abate	18	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	abate	68	module H = Types.DescrMap
10	abate	17
11			let mapping f t queue =
12	abate	68	let memo = ref H.empty in
13	abate	31	let rec aux t =
14	abate	68	try H.find t !memo
15	abate	17	with Not_found ->
16			let v = V.forward () in
17	abate	68	memo := H.add t v !memo;
18	abate	17	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	66	let plus t = let t = Types.cons t in Types.times t (star_node t)
50	abate	58	let string = star (Types.Char.any)
51	abate	31
52			let approx t =
53	abate	68	let memo = ref H.empty in
54	abate	31	let res = ref Types.empty in
55			let rec aux t =
56	abate	68	try H.find t !memo
57	abate	31	with Not_found ->
58	abate	68	memo := H.add t () !memo;
59	abate	31	let rect = Types.Product.get t in
60			List.iter (fun (t1,t2) -> res := Types.cup t1 !res; aux t2) rect;
61			in
62			aux t;
63			!res
64
65