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