1
(* $Id: absOrd.ml,v 1.5 2003/06/18 15:11:06 yori Exp $ *)
2
(* Copyright 2002 Yamagata Yoriyuki *)
6
module Int = struct type t = int let compare = (-) end
9
module Map = Map.Make (Int)
15
| Node of Set.t * node * node * int
22
| Node (_, _, _, h) -> h
26
| Leaf p -> Set.add p Set.empty
27
| Node (s, _, _, _) -> s
36
let h = 1 + max hl hr in
37
let s = Set.union (elts l) (elts r) in
40
let rec bal = function
43
| Node (s, l, r, _) as node ->
48
Node (ls, ll, lr, _) ->
49
let hll = height ll in
50
let hlr = height lr in
52
Node (s, ll, concat lr r, 1 + hll)
55
Node (_, lrl, lrr, _) ->
56
let l' = concat ll lrl in
57
let r' = concat lrr r in
58
let h = 1 + max (height l') (height r') in
62
else if hr - hl > 2 then
64
Node (rs, rl, rr, _) ->
65
let hrl = height rl in
66
let hrr = height rr in
68
Node (s, concat l rl, rr, 1 + hrr)
71
Node (_, rll, rlr, _) ->
72
let l' = concat l rll in
73
let r' = concat rlr rr in
74
let h = 1 + max (height l') (height r') in
80
and concat l r = bal (create l r)
85
| Node (s, _, _, _) -> Set.mem p s
87
let rec compare p1 p2 = function
88
Empty -> raise Not_found
90
if p1 = p && p2 = p then 0 else
92
| Node (s, s1, s2, _) ->
94
if mem p2 s1 then compare p1 p2 s1 else
95
if mem p2 s2 then -1 else
97
else if mem p1 s2 then
98
if mem p2 s1 then 1 else
99
if mem p2 s2 then compare p1 p2 s2 else
104
let rec top = function
105
Empty -> raise Not_found
107
| Node (_, s1, s2, _) ->
108
try top s2 with Not_found -> top s1
110
let rec top_in m = function
111
Empty -> raise Not_found
113
if Map.mem p m then p else raise Not_found
114
| Node (_, s1, s2, _) ->
115
try top_in m s2 with Not_found -> top_in m s1
117
let rec bottom = function
118
Empty -> raise Not_found
120
| Node (_, s1, s2, _) ->
121
try bottom s1 with Not_found -> bottom s2
123
let rec bottom_in m = function
124
Empty -> raise Not_found
126
if Map.mem p m then p else raise Not_found
127
| Node (_, s1, s2, _) ->
128
try bottom_in m s1 with Not_found -> bottom_in m s1
130
let rec next p = function
131
Empty -> raise Not_found
132
| Leaf _ -> raise Not_found
133
| Node (_, s1, s2, _) ->
134
if mem p s1 then try next p s1 with Not_found -> bottom s2 else
137
let rec prev p = function
138
Empty -> raise Not_found
139
| Leaf _ -> raise Not_found
140
| Node (_, s1, s2, _) ->
141
if mem p s2 then try prev p s2 with Not_found -> top s1 else
144
let rec before p = function
147
if p = p' then Empty else raise Not_found
148
| Node (_, s1, s2, h) ->
152
concat s1 (before p s2)
154
let rec upto p = function
157
if p = p' then s else raise Not_found
158
| Node (_, s1, s2, h) ->
162
concat s1 (upto p s2)
164
let rec after p = function
167
if p = p' then Empty else raise Not_found
168
| Node (_, s1, s2, h) ->
170
concat (after p s1) s2
174
let rec from p = function
177
if p = p' then s else raise Not_found
178
| Node (_, s1, s2, h) ->
180
concat (from p s1) s2
184
let rec iter proc = function
187
| Node (_, s1, s2, _) ->
191
let rec fold f s init =
195
| Node (_, s1, s2, _) ->
196
fold f s2 (fold f s1 init)
198
let rec put_to_top p = function
200
| Leaf _ as s1 -> create s1 (Leaf p)
201
| Node (s, s1, s2, h) ->
202
let s' = Set.add p s in
203
let s2' = put_to_top p s2 in
204
let h = 1 + max (height s1) (height s2') in
205
bal (Node (s', s1, s2', h))
207
let rec put_to_bottom p = function
209
| Leaf _ as s2 -> create (Leaf p) s2
210
| Node (s, s1, s2, h) ->
211
let s' = Set.add p s in
212
let s1' = put_to_bottom p s1 in
213
let h = 1 + max (height s1') (height s2) in
214
bal (Node (s', s1', s2, h))
216
let rec put_before p0 p = function
217
Empty -> raise Not_found
219
if p1 = p0 then create (Leaf p) s else raise Not_found
220
| Node (s, s1, s2, h) ->
221
let s' = Set.add p s in
223
if mem p0 s1 then (put_before p0 p s1), s2 else
224
s1, (put_before p0 p s2)
226
let h = 1 + max (height s1') (height s2') in
227
bal (Node (s', s1', s2', h))
229
let rec put_after p0 p = function
230
Empty -> raise Not_found
232
if p1 = p0 then create s (Leaf p) else raise Not_found
233
| Node (s, s1, s2, h) ->
234
let s' = Set.add p s in
236
if mem p0 s1 then (put_after p0 p s1), s2 else
237
s1, (put_after p0 p s2)
239
let h = 1 + max (height s1') (height s2') in
240
bal (Node (s', s1', s2', h))
246
let compare p1 p2 (node, _) = Node.compare p1 p2 node
247
let top (node, _) = Node.top node
248
let bottom (node, _) = Node.bottom node
249
let next p (node, _) = Node.next p node
250
let prev p (node, _) = Node.prev p node
252
let add_top (node, id) = (id, (Node.put_to_top id node, id + 1))
254
let add_bottom (node, id) = (id, (Node.put_to_bottom id node, id + 1))
256
let add_before p (node, id) =
257
let l = Node.before p node in
258
let r = Node.from p node in
259
(id, (Node.put_before p id node, id + 1))
261
let add_after p (node, id) =
262
let l = Node.upto p node in
263
let r = Node.after p node in
264
(id, (Node.put_after p id node, id + 1))
266
let iter proc (node, _) = Node.iter proc node
267
let fold f (node, _) init = Node.fold f node init
269
let rec import_aux a i j w2p p2w id =
271
(Leaf id, IntMap.add a.(i) id w2p, Map.add id a.(i) p2w, id + 1)
273
let i' = i + (j - i) / 2 in
274
let ord1, w2p, p2w, id = import_aux a i i' w2p p2w id in
275
let ord2, w2p, p2w, id = import_aux a (i' + 1) j w2p p2w id in
276
(Node.concat ord1 ord2, w2p, p2w, id)
279
let set = List.fold_left (fun set w ->
284
let weights = IntSet.fold (fun w ws -> w :: ws) set [] in
285
let a = Array.of_list weights in
287
let node, w2p, p2w, id =
288
import_aux a 0 (Array.length a - 1) IntMap.empty Map.empty 0
290
((node, id), w2p, p2w)
added
removed
toolslib/absOrd.ml
