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)