sequence.ml 3.06 KB
Newer Older
1
let nil_atom = Atoms.V.mk_ascii "nil"
2
let nil_type = Types.atom (Atoms.atom nil_atom)
3
let nil_node = Types.cons nil_type
4
let nil_cst  = Types.Atom nil_atom
5
6

let decompose t =
7
  (Types.Atom.has_atom t nil_atom,
8
9
10
   Types.Product.get t)

module V = Types.Positive
11
module H = Map.Make(Types)
12
13

let mapping f t queue =
14
  let memo = ref H.empty in
15
  let rec aux t =
16
    try H.find t !memo
17
18
    with Not_found ->
      let v = V.forward () in
19
      memo := H.add t v !memo;
20
      let (has_nil,rect) = decompose t in
21
      let l = List.map (fun (t1,t2) -> f t1 (aux t2)) rect in
22
23
24
25
      let l = if has_nil then queue :: l else l in
      V.define v (V.cup l);
      v
  in
26
  aux t
27
28
29
  

let aux_concat = mapping (fun t v -> V.times (V.ty t) v)
30
31
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)
32
33
34
35
36
37
38
39
40
41
42
43

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

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

46
let any_node = star_node (Types.cons Types.any)
47
let any = Types.descr any_node
48
49
50
let seqseq = Types.descr (star_node any_node)

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

54
(* Mmmmh, it may be faster to add pi1(rect) and iterate over pi2(rect) ... ? *)
55
let approx t =
56
  let memo = ref H.empty in
57
58
  let res = ref Types.empty in
  let rec aux t =
59
    try H.find t !memo
60
    with Not_found ->
61
      memo := H.add t () !memo;
62
63
64
65
66
      let rect = Types.Product.get t in
      List.iter (fun (t1,t2) -> res := Types.cup t1 !res; aux t2) rect;
  in
  aux t;
  !res
67
68

  
69
70
71
let map_tree f seq =
  let memo = ref H.empty in
  let rec aux t =
72
 (*   Printf.eprintf "A"; flush stderr; *)
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
    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 (result,residual) = f t 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 = aux_concat result v in
    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

(* TODO: avoid flushing the memo between calls to mapping inside map_tree *)
99
100
101
102
103
104
105
106
107

  (* <helpers> *)

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> *)