viewcvs.cgi/types/sequence.ml

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

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

(*
let memo_concat = Types.DescrHash.create 63

let rec aux_concat t s =
  try Types.DescrHash.find memo_concat t
  with Not_found ->
    let n = Types.make () in
    Types.DescrHash.add memo_concat t n;
    let (has_nil,rect) = decompose t in
    let d = List.fold_left
              (fun accu (t1,t2) ->
                 Types.cup accu (Types.times (Types.cons t1) (aux_concat t2 s))
              )
              (if has_nil then s else Types.empty)
              rect
    in
    Types.define n d;
    n

let concat t s =
  let n = aux_concat t s in
  Types.DescrHash.clear memo_concat;
  Types.descr (Types.internalize n)
*)

module V = Types.Positive
module H = Types.DescrHash

let mapping f t queue =
  let memo = H.create 13 in
  let rec aux_map t =
    try H.find memo t
    with Not_found ->
      let v = V.forward () in
      H.add memo t v;
      let (has_nil,rect) = decompose t in
      let l = List.map (fun (t1,t2) -> f t1 (aux_map t2)) rect in
      let l = if has_nil then queue :: l else l in
      V.define v (V.cup l);
      v

  in
  aux_map 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 t = recurs (fun n -> Types.cup nil_type (Types.times t n ))

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

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