atoms.ml 4.17 KB
Newer Older
1
module AtomPool  = Pool.Make(SortedList.String)
2
3
4
type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
5
let vcompare = AtomPool.compare
6
let vhash = AtomPool.hash
7

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

let empty = Finite []
12
let any   = Cofinite []
13
14
15
16
17

let atom x = Finite [x]

let cup s t =
  match (s,t) with
18
19
20
21
    | (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)
22
23
24

let cap s t =
  match (s,t) with
25
26
27
28
    | (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)
29
30
31

let diff s t =
  match (s,t) with
32
33
34
35
    | (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)
36
37
	
let contains x = function
38
39
  | Finite s -> SList.mem s x
  | Cofinite s -> not (SList.mem s x)
40

41
42
43
44
45
46
47
48
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


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

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

62
63
64
65
66
let print_v ppf a = 
  if a = AtomPool.dummy_min then
    Format.fprintf ppf "(almost any atom)"
  else
    Format.fprintf ppf "`%s" (value a)
67

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

81
82

(* TODO: clean what follow to re-use SList operations *)
83
84
85
86
87
88
89
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
90

91
92
93
94
95
96
97
98
99
100
101
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
  
102
103
104
105
106
107
108
109
110
111
112
113
114
115
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
116

117
118
119
120
(* Optimize lookup:
   - decision tree
   - merge adjacent segment with same result
*)
121
122
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
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