atoms.ml 3.95 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

let is_empty = function
  | Finite [] -> true
  | _ -> false
44
45
46
47

let is_atom = function
  | Finite [a] -> Some a
  | _ -> None
48
      
49
let sample = function
50
  | Finite (x :: _) -> x
51
  | Cofinite l -> AtomPool.dummy_min
52
53
  | Finite [] -> raise Not_found

54
55
56
57
58
let print_v ppf a = 
  if a = AtomPool.dummy_min then
    Format.fprintf ppf "(almost any atom)"
  else
    Format.fprintf ppf "`%s" (value a)
59

60
61
let print = function
  | Finite l -> List.map (fun x ppf -> print_v ppf x) l
62
  | Cofinite [] ->
63
      [ fun ppf -> Format.fprintf ppf "Atom" ]
64
  | Cofinite [h] ->
65
      [ fun ppf -> Format.fprintf ppf "@[Atom - %a@]" print_v h ]
66
67
  | Cofinite (h::t) -> 
      [ fun ppf -> 
68
69
70
	  Format.fprintf ppf "@[Atom - (";
	  print_v ppf h;
	  List.iter (fun x -> Format.fprintf ppf " |@ %a" print_v x) t;
71
	  Format.fprintf ppf ")@]" ]
72

73
74

(* TODO: clean what follow to re-use SList operations *)
75
76
77
78
79
80
81
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
82

83
84
85
86
87
88
89
90
91
92
93
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
  
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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
108

109
110
111
112
(* Optimize lookup:
   - decision tree
   - merge adjacent segment with same result
*)
113
114
115
116
117
118
119
120
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
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