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

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

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

let atom x = Finite [x]

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

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

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

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

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

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

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

72
73

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

82
83
84
85
86
87
88
89
90
91
92
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
  
93

94

95
96
97
98
(* Optimize lookup:
   - decision tree
   - merge adjacent segment with same result
*)
99
100
101
102
103
104
105
106
107
108
109
110
111
112
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
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