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