imap.ml 4.84 KB
 Pietro Abate committed Oct 05, 2007 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 `````` Pietro Abate committed Oct 05, 2007 69 `````` if i < get t m then find_aux t i low (m-2) `````` Pietro Abate committed Oct 05, 2007 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; `````` Pietro Abate committed Oct 05, 2007 75 `````` let j = find_aux t i 1 (get t 0 - 2) in `````` Pietro Abate committed Oct 05, 2007 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 `````` Pietro Abate committed Oct 05, 2007 82 `````` let j = find_aux t i 1 (get t 0 - 2) in `````` Pietro Abate committed Oct 05, 2007 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 = `````` Pietro Abate committed Oct 05, 2007 87 `````` Obj.magic get t (succ (find_aux t i 1 (get t 0 - 2))) `````` Pietro Abate committed Oct 05, 2007 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 `````` Pietro Abate committed Oct 05, 2007 194 `````` let j = find_aux t i 1 (get t 0 - 2) in `````` Pietro Abate committed Oct 05, 2007 195 196 197 198 `````` if (get t j != i) then t else let n = get t 0 - 2 in if (n = 1) then empty `````` Pietro Abate committed Oct 05, 2007 199 `````` else `````` Pietro Abate committed Oct 05, 2007 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)``````