atoms.ml 4.22 KB
Newer Older
1
2
open Encodings
module AtomPool  = Pool.Make(Utf8)
3
4
5
type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
6
let mk_ascii s = mk (Utf8.mk s)
7
let vcompare = AtomPool.compare
8
let vhash = AtomPool.hash
9

10
module SList = SortedList.Make_transp(SortedList.Lift(AtomPool))
11
type t = Finite of unit SList.t | Cofinite of unit SList.t
12
13

let empty = Finite []
14
let any   = Cofinite []
15
16
17
18
19

let atom x = Finite [x]

let cup s t =
  match (s,t) with
20
21
22
23
    | (Finite s, Finite t) -> Finite (SList.cup s t)
    | (Finite s, Cofinite t) -> Cofinite (SList.diff t s)
    | (Cofinite s, Finite t) -> Cofinite (SList.diff s t)
    | (Cofinite s, Cofinite t) -> Cofinite (SList.cap s t)
24
25
26

let cap s t =
  match (s,t) with
27
28
29
30
    | (Finite s, Finite t) -> Finite (SList.cap s t)
    | (Finite s, Cofinite t) -> Finite (SList.diff s t)
    | (Cofinite s, Finite t) -> Finite (SList.diff t s)
    | (Cofinite s, Cofinite t) -> Cofinite (SList.cup s t)
31
32
33

let diff s t =
  match (s,t) with
34
35
36
37
    | (Finite s, Cofinite t) -> Finite (SList.cap s t)
    | (Finite s, Finite t) -> Finite (SList.diff s t)
    | (Cofinite s, Cofinite t) -> Finite (SList.diff t s)
    | (Cofinite s, Finite t) -> Cofinite (SList.cup s t)
38
39
	
let contains x = function
40
41
  | Finite s -> SList.mem s x
  | Cofinite s -> not (SList.mem s x)
42

43
44
45
46
47
48
49
50
let disjoint s t =
  match (s,t) with
    | (Finite s, Finite t) -> SList.disjoint s t
    | (Finite s, Cofinite t) -> SList.subset s t
    | (Cofinite s, Finite t) -> SList.subset t s
    | (Cofinite s, Cofinite t) -> false


51
52
53
let is_empty = function
  | Finite [] -> true
  | _ -> false
54
55
56
57

let is_atom = function
  | Finite [a] -> Some a
  | _ -> None
58
      
59
let sample = function
60
  | Finite (x :: _) -> x
61
  | Cofinite l -> AtomPool.dummy_min
62
63
  | Finite [] -> raise Not_found

64
65
66
67
let print_v ppf a = 
  if a = AtomPool.dummy_min then
    Format.fprintf ppf "(almost any atom)"
  else
68
    Format.fprintf ppf "`%a" Utf8.print (value a)
69

70
71
let print = function
  | Finite l -> List.map (fun x ppf -> print_v ppf x) l
72
  | Cofinite [] ->
73
      [ fun ppf -> Format.fprintf ppf "Atom" ]
74
  | Cofinite [h] ->
75
      [ fun ppf -> Format.fprintf ppf "@[Atom - %a@]" print_v h ]
76
77
  | Cofinite (h::t) -> 
      [ fun ppf -> 
78
79
80
	  Format.fprintf ppf "@[Atom - (";
	  print_v ppf h;
	  List.iter (fun x -> Format.fprintf ppf " |@ %a" print_v x) t;
81
	  Format.fprintf ppf ")@]" ]
82

83
84

(* TODO: clean what follow to re-use SList operations *)
85
86
87
88
89
90
91
let rec hash_seq accu = function
  | t::rem -> hash_seq (accu * 17 + t) rem
  | [] -> accu

let hash accu = function
  | Finite l -> hash_seq (accu + 1) l
  | Cofinite l -> hash_seq (accu + 3) l
92

93
94
95
96
97
98
99
100
101
102
103
let rec equal_rec l1 l2 =
  (l1 == l2) ||
  match (l1,l2) with
    | (x1::l1,x2::l2) -> (x1 == x2) && (equal_rec l1 l2)
    | _ -> false

let equal t1 t2 = match (t1,t2) with
  | (Finite l1, Finite l2) -> equal_rec l1 l2
  | (Cofinite l1, Cofinite l2) -> equal_rec l1 l2
  | _ -> false
  
104
105
106
107
108
109
110
111
112
113
114
115
116
117
let rec compare_rec l1 l2 =
  if (l1 == l2) then 0 else
  match (l1,l2) with
    | (x1::l1,x2::l2) ->
	let c = AtomPool.compare x1 x2 in if c <> 0 then c 
	else compare_rec l1 l2
    | ([],_) -> -1
    | _ -> 1

let compare t1 t2 = match (t1,t2) with
  | (Finite l1, Finite l2) -> compare_rec l1 l2
  | (Cofinite l1, Cofinite l2) -> compare_rec l1 l2
  | (Finite _, Cofinite _) -> -1
  | (Cofinite _, Finite _) -> 1
118

119
120
121
122
(* Optimize lookup:
   - decision tree
   - merge adjacent segment with same result
*)
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
type 'a map = (v * 'a) list * 'a option

let mk_map l =
  let rec find_cofinite = function
    | (Cofinite _, x)::_ -> Some x
    | _::rem -> find_cofinite rem
    | [] -> None
  in
  let finites = 
    List.fold_left 
      (fun accu -> function
	 | (Cofinite _, _) -> accu
	 | (Finite l, x) -> List.fold_left (fun accu a -> (a,x)::accu) accu l)
      [] l
  in
  let finites = 
    List.sort (fun (a1,_) (a2,_) -> AtomPool.compare a1 a2) finites in
  (finites, find_cofinite l)

let get_map v (f,def) =
  let rec aux_def def v = function
    | [] -> def
    | (a,x)::rem ->
	let c = AtomPool.compare a v in
	if c = 0 then x else
	  if c < 0 then aux_def def v rem
	  else def
  in
  let rec aux_nodef v = function
    | [] -> assert false
    | [a,x] -> x
    | (a,x)::rem ->
	let c = AtomPool.compare a v in
	if c = 0 then x else aux_nodef v rem
  in
  match def with
    | Some def -> aux_def def v f
    | None -> aux_nodef v f