imap.ml 6.65 KB
Newer Older
1 2 3 4 5 6
type 'a t = Obj.t array

let empty = Obj.magic ()
  (* [| |] does not ensure physical equality with ocamlopt (?) after deserialization.
     0 does not work either: the code generator considers registers set to empty as integer-only
     registers, which is not safe. *)
7 8 9 10

let get = Array.unsafe_get
let set = Array.unsafe_set

11 12 13 14 15 16
let get_len a : int = Obj.magic (get a 0)
let set_len a (i : int) = set a 0 (Obj.repr i)
let get_int a i : int = Obj.magic (get a i)
let set_int a (i : int) (x : int) = set a i (Obj.repr x)

let acreate n = Array.create n (Obj.repr n)
17 18 19 20 21

let elements (t : 'a t) : (int * 'a) list =
  if t == empty then [] else
  let rec aux accu i =
    if (i > 0) 
22
    then aux ((get_int t i, Obj.magic (get t (succ i)))::accu) (i - 2)
23 24
    else accu
  in
25
  aux [] (get_len t - 2)
26 27 28 29 30

let map_elements f t =
  if t == empty then [] else
  let rec aux accu i =
    if (i > 0) 
31
    then aux (f (get_int t i) (Obj.magic (get t (succ i)))::accu) (i - 2)
32 33
    else accu
  in
34
  aux [] (get_len t - 2)
35

36 37 38 39 40

(* TODO: check that the comparison function is necessarily called
   on a pair of equal elements if such a pair exist.
   I guess any sort algorithm must do that! *)
exception DuplicateKey
41
let sort a = 
42 43
  Array.sort 
    (fun (i,_) (j,_) -> 
44 45
       if (i == j) then raise DuplicateKey;
       if (i:int) < j then (-1) else 1) a
46 47 48 49

let real_create a = 
  let n = Array.length a in
  let m = (n lsl 1) + 1 in
50
  let t = acreate m in
51 52
  for i = 1 to n do
    let j = i lsl 1 in
53 54 55
    let (idx,v) = a.(pred i) in
    set_int t (pred j) idx;
    set t j (Obj.repr v);
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
  done;
  t

let create a =
  if Array.length a = 0 then empty else (sort a; real_create a)

let create_default def a =
  sort a;
  let l = Array.to_list a in
  let rec aux i = function
    | [] ->
	if (i == max_int) then []
	else [(succ i, def)]
    | ((i1,_) as c)::rest ->
	if (succ i == i1) then c :: (aux i1 rest)
	else (succ i, def) :: c :: (aux i1 rest)
  in
  let l =  
    match l with
      | ((i1,_) as c)::rest ->
	  if (i1 == min_int) then c :: (aux i1 rest)
	  else (min_int,def) :: c :: (aux i1 rest)
      | [] -> [(min_int,def)] in
  let a = Array.of_list l in
  real_create a
  

let rec find_aux t (i : int) low high =
  if (low >= high) then low
  else
    let m = ((low + high) lsr 1) lor 1 in
87
    if i < get_int t m then find_aux t i low (m-2)
88 89 90 91
    else find_aux t i m high

let find (t : 'a t) i : 'a =
  if t == empty then raise Not_found;
92 93
  let j = find_aux t i 1 (get_len t - 2) in
  if (get_int t j == i) then Obj.magic (get t (succ j))
94 95 96 97 98
  else raise Not_found

let find_default t def i =
  if t == empty then def
  else
99 100
    let j = find_aux t i 1 (get_len t - 2) in
    if (get_int t j == i) then Obj.magic (get t (succ j))
101 102 103
    else def

let find_lower (t : 'a t) i : 'a =
104
  Obj.magic (get t (succ (find_aux t i 1 (get_len t - 2))))
105 106 107 108

let merge (t1 : 'a t) (t2 : 'a t) =
  if t1 == empty then t2 else if t2 == empty then t1
  else
109
    let n1 = get_len t1 and n2 = get_len t2 in
110
    let m = pred (n1 + n2) in
111
    let t = acreate m in
112 113
    let rec aux i i1 (l1:int) i2 l2 =
      if l1 == l2 then
114
	(set_int t i l1;
115 116 117 118 119 120 121 122 123 124 125
	 set t (succ i) (get t2 (pred i2));
	 let i = i + 2 in
	 if (i1 = n1) then (
	   let l = n2 - i2 in
	   Array.blit t2 i2 t i l;
	   i + l
	 ) else if (i2 = n2) then (
	   let l = n1 - i1 in
	   Array.blit t1 i1 t i l;
	   i + l
	 ) else 
126
	   let l1 = get_int t1 i1 and l2 = get_int t2 i2 in
127 128 129
	   let i1 = i1 + 2 and i2 = i2 + 2 in
	   aux i i1 l1 i2 l2)
      else if l1 < l2 then
130
	(set_int t i l1;
131 132 133
	 set t (succ i) (get t1 (pred i1));
	 let i = i + 2 in
	 if (i1 = n1) then (
134
	   let i2 = i2 - 2 in
135 136 137 138
	   let l = n2 - i2 in
	   Array.blit t2 i2 t i l;
	   i + l
	 ) else
139
	   let l1 = get_int t1 i1 in 
140 141 142
	   let i1 = i1 + 2 in
	   aux i i1 l1 i2 l2)
      else 
143
	(set_int t i l2;
144 145 146
	 set t (succ i) (get t2 (pred i2));
	 let i = i + 2 in
	 if (i2 = n2) then (
147
	   let i1 = i1 - 2 in
148 149 150 151
	   let l = n1 - i1 in
	   Array.blit t1 i1 t i l;
	   i + l
	 ) else
152
	   let l2 = get_int t2 i2 in 
153 154 155
	   let i2 = i2 + 2 in
	   aux i i1 l1 i2 l2)
    in
156
    set_len t (aux 1 3 (get_int t1 1) 3 (get_int t2 1));
157 158 159 160
    t

let cardinal t =
  if t == empty then 0
161
  else (pred (get_len t)) lsr 1
162 163 164 165

let map f t =
  if t == empty then empty
  else 
166 167
    let n = get_len t in
    let t' = acreate n in
168 169 170 171 172 173 174 175 176 177 178 179
    Array.blit t 0 t' 0 n;
    let rec aux i =
      if (i = 0) then t'
      else (set t' i (Obj.magic (f (Obj.magic (get t i)))); aux (i - 2))
    in
    aux (pred n)

let compare f t1 t2 =
  if (t1 == t2) then 0
  else if t1 == empty then (-1)
  else if t2 == empty then 1
  else
180
    let n1 = get_len t1 and n2 = get_len t2 in
181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
    if (n1 < n2) then (-1) else if (n1 > n2) then 1
    else
      let rec aux i =
	if (i < 0) then 0
	else
	  let l1 = get t1 i and l2 = get t2 i in
	  if (l1 < l2) then (-1) else if (l1 > l2) then 1
	  else let x1 = Obj.magic (get t1 (succ i)) 
	       and x2 = Obj.magic (get t2 (succ i)) 
	  in let c = f x1 x2 in
	  if c != 0 then c else aux (i - 2)
      in
      aux (n1 - 2)

let hash f t =
  if t == empty then 1
  else
    let rec aux accu i =
      if (i < 0) then accu
      else aux (accu * 65537 
		+ 257 * (f (Obj.magic (get t (succ i))))
202 203
		+ (get_int t i)) (i - 2) in
    aux 1 (get_len t - 2)
204 205 206 207

let remove t i =
  if t == empty then t
  else
208 209
    let j = find_aux t i 1 (get_len t - 2) in
    if (get_int t j != i) then t
210
    else
211
      let n = get_len t - 2 in
212
      if (n = 1) then empty
213
      else
214
	let t' = acreate n in
215 216 217 218 219 220 221 222 223
	Array.blit t 1 t' 1 (j - 1);
	Array.blit t (j + 2) t' j (n - j);
	t'

let iter f t =
  if t == empty then ()
  else
    let rec aux i =
      if (i < 0) then ()
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277
      else f (get_int t i) (Obj.magic (get t (succ i))) in
    aux (get_len t - 2)

(*
type 'a t = (int * 'a) list

let empty = []

let create a =
  Array.sort (fun (i,_) (j,_) -> assert (i != j); if i < j then (-1) else 1) a;
  Array.to_list a

let create_default def a =
  let l = create a in
  let rec aux i = function
    | [] ->
	if (i == max_int) then []
	else [(succ i, def)]
    | ((i1,_) as c)::rest ->
	if (succ i == i1) then c :: (aux i1 rest)
	else (succ i, def) :: c :: (aux i1 rest)
  in
  let l =  
    match l with
      | ((i1,_) as c)::rest ->
	  if (i1 == min_int) then c :: (aux i1 rest)
	  else (min_int,def) :: c :: (aux i1 rest)
      | [] -> [(min_int,def)] in
  l

let merge l1 l2 = assert false

let find l x = List.assoc x l

let rec find_lower l x = match l with
  | (_,v)::(y,_)::_ when x < y -> v
  | _::l -> find_lower l x
  | [] -> assert false

let find_default l def x = try find l x with Not_found -> def

let cardinal = List.length

let elements l = l

let map f l = List.map (fun (x,v) -> (x, f v)) l

let map_elements f l = List.map (fun (x,v) -> f x v) l

let compare _ _ = assert false
let hash _ = assert false
let remove _ _ = assert false
let iter _ _ = assert false
*)