imap.ml 4.84 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
type 'a t = int array

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

let empty = [| |]

let elements (t : 'a t) : (int * 'a) list =
  if t == empty then [] else
  let rec aux accu i =
    if (i > 0) 
    then aux ((get t i, Obj.magic (get t (succ i)))::accu) (i - 2)
    else accu
  in
  aux [] (get t 0 - 2)

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

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

let real_create a = 
  let n = Array.length a in
  let m = (n lsl 1) + 1 in
  let t = Array.create m m in
  for i = 1 to n do
    let j = i lsl 1 in
    let (idx,v) = get a (pred i) in
    set t (pred j) idx;
    set t j (Obj.magic v);
  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
69
    if i < get t m then find_aux t i low (m-2)
70 71 72 73 74
    else find_aux t i m high


let find (t : 'a t) i : 'a =
  if t == empty then raise Not_found;
75
  let j = find_aux t i 1 (get t 0 - 2) in
76 77 78 79 80 81
  if (get t j == i) then (Obj.magic get t (succ j))
  else raise Not_found

let find_default t def i =
  if t == empty then def
  else
82
    let j = find_aux t i 1 (get t 0 - 2) in
83 84 85 86
    if (get t j == i) then (Obj.magic get t (succ j))
    else def

let find_lower (t : 'a t) i : 'a =
87
  Obj.magic get t (succ (find_aux t i 1 (get t 0 - 2)))
88 89 90 91 92 93 94 95 96 97 98 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 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193

let merge (t1 : 'a t) (t2 : 'a t) =
  if t1 == empty then t2 else if t2 == empty then t1
  else
    let n1 = get t1 0 and n2 = get t2 0 in
    let m = pred (n1 + n2) in
    let t = Array.create m m in
    let rec aux i i1 (l1:int) i2 l2 =
      if l1 == l2 then
	(set t i l1;
	 set t (succ i) (get t2 (pred i2));
	 let i = i + 2 in
	 if (i1 = n1) then (
	   let l = n2 - i2 in
	   let i2 = i2 - 2 in
	   Array.blit t2 i2 t i l;
	   i + l
	 ) else if (i2 = n2) then (
	   let l = n1 - i1 in
	   let i1 = i1 - 2 in
	   Array.blit t1 i1 t i l;
	   i + l
	 ) else 
	   let l1 = get t1 i1 and l2 = get t2 i2 in
	   let i1 = i1 + 2 and i2 = i2 + 2 in
	   aux i i1 l1 i2 l2)
      else if l1 < l2 then
	(set t i l1;
	 set t (succ i) (get t1 (pred i1));
	 let i = i + 2 in
	 if (i1 = n1) then (
	   let i2 = i2 - 2 in
	   let l = n2 - i2 in
	   Array.blit t2 i2 t i l;
	   i + l
	 ) else
	   let l1 = get t1 i1 in 
	   let i1 = i1 + 2 in
	   aux i i1 l1 i2 l2)
      else 
	(set t i l2;
	 set t (succ i) (get t2 (pred i2));
	 let i = i + 2 in
	 if (i2 = n2) then (
	   let l = n1 - i1 in
	   let i1 = i1 - 2 in
	   Array.blit t1 i1 t i l;
	   i + l
	 ) else
	   let l2 = get t2 i2 in 
	   let i2 = i2 + 2 in
	   aux i i1 l1 i2 l2)
    in
    set t 0 (aux 1 3 (get t1 1) 3 (get t2 1));
    t

let cardinal t =
  if t == empty then 0
  else (pred (get t 0)) lsr 1


let map f t =
  if t == empty then empty
  else 
    let n = get t 0 in
    let t' = Array.create n 0 in
    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
    let n1 = get t1 0 and n2 = get t2 0 in
    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))))
		+ (get t i)) (i - 2) in
    aux 1 (get t 0 - 2)

let remove t i =
  if t == empty then t
  else
194
    let j = find_aux t i 1 (get t 0 - 2) in
195 196 197 198
    if (get t j != i) then t
    else
      let n = get t 0 - 2 in
      if (n = 1) then empty
199
      else
200 201 202 203 204 205 206 207 208 209 210 211
	let t' = Array.create n n in
	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 ()
      else f (get t i) (Obj.magic (get t (succ i))) in
    aux (get t 0 - 2)