Commit | Line | Data |
---|---|---|
34e49164 C |
1 | (*pad: taken from set.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *) |
2 | (* with some addons such as from list *) | |
3 | ||
4 | ||
5 | (***********************************************************************) | |
6 | (* *) | |
7 | (* Objective Caml *) | |
8 | (* *) | |
9 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) | |
10 | (* *) | |
11 | (* Copyright 1996 Institut National de Recherche en Informatique et *) | |
12 | (* en Automatique. All rights reserved. This file is distributed *) | |
13 | (* under the terms of the GNU Library General Public License, with *) | |
14 | (* the special exception on linking described in file ../LICENSE. *) | |
15 | (* *) | |
16 | (***********************************************************************) | |
17 | ||
18 | (* set.ml 1.18.4.1 2004/11/03 21:19:49 doligez Exp *) | |
19 | ||
20 | (* Sets over ordered types *) | |
21 | ||
22 | (* pad: | |
23 | type elt = Ord.t | |
24 | type t = Empty | Node of t * elt * t * int | |
25 | and subst all Ord.compare with just compare | |
26 | *) | |
27 | type 'elt t = Empty | Node of 'elt t * 'elt * 'elt t * int | |
28 | ||
29 | (* Sets are represented by balanced binary trees (the heights of the | |
30 | children differ by at most 2 *) | |
31 | ||
32 | let height = function | |
33 | Empty -> 0 | |
34 | | Node(_, _, _, h) -> h | |
35 | ||
36 | (* Creates a new node with left son l, value v and right son r. | |
37 | We must have all elements of l < v < all elements of r. | |
38 | l and r must be balanced and | height l - height r | <= 2. | |
39 | Inline expansion of height for better speed. *) | |
40 | ||
41 | let create l v r = | |
42 | let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in | |
43 | let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in | |
44 | Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) | |
45 | ||
46 | (* Same as create, but performs one step of rebalancing if necessary. | |
47 | Assumes l and r balanced and | height l - height r | <= 3. | |
48 | Inline expansion of create for better speed in the most frequent case | |
49 | where no rebalancing is required. *) | |
50 | ||
51 | let bal l v r = | |
52 | let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in | |
53 | let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in | |
54 | if hl > hr + 2 then begin | |
55 | match l with | |
56 | Empty -> invalid_arg "Set.bal" | |
57 | | Node(ll, lv, lr, _) -> | |
58 | if height ll >= height lr then | |
59 | create ll lv (create lr v r) | |
60 | else begin | |
61 | match lr with | |
62 | Empty -> invalid_arg "Set.bal" | |
63 | | Node(lrl, lrv, lrr, _)-> | |
64 | create (create ll lv lrl) lrv (create lrr v r) | |
65 | end | |
66 | end else if hr > hl + 2 then begin | |
67 | match r with | |
68 | Empty -> invalid_arg "Set.bal" | |
69 | | Node(rl, rv, rr, _) -> | |
70 | if height rr >= height rl then | |
71 | create (create l v rl) rv rr | |
72 | else begin | |
73 | match rl with | |
74 | Empty -> invalid_arg "Set.bal" | |
75 | | Node(rll, rlv, rlr, _) -> | |
76 | create (create l v rll) rlv (create rlr rv rr) | |
77 | end | |
78 | end else | |
79 | Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) | |
80 | ||
81 | (* Insertion of one element *) | |
82 | ||
83 | let rec add x = function | |
84 | Empty -> Node(Empty, x, Empty, 1) | |
85 | | Node(l, v, r, _) as t -> | |
86 | let c = compare x v in | |
87 | if c = 0 then t else | |
88 | if c < 0 then bal (add x l) v r else bal l v (add x r) | |
89 | ||
90 | (* Same as create and bal, but no assumptions are made on the | |
91 | relative heights of l and r. *) | |
92 | ||
93 | let rec join l v r = | |
94 | match (l, r) with | |
95 | (Empty, _) -> add v r | |
96 | | (_, Empty) -> add v l | |
97 | | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> | |
98 | if lh > rh + 2 then bal ll lv (join lr v r) else | |
99 | if rh > lh + 2 then bal (join l v rl) rv rr else | |
100 | create l v r | |
101 | ||
102 | (* Smallest and greatest element of a set *) | |
103 | ||
104 | let rec min_elt = function | |
105 | Empty -> raise Not_found | |
106 | | Node(Empty, v, r, _) -> v | |
107 | | Node(l, v, r, _) -> min_elt l | |
108 | ||
109 | let rec max_elt = function | |
110 | Empty -> raise Not_found | |
111 | | Node(l, v, Empty, _) -> v | |
112 | | Node(l, v, r, _) -> max_elt r | |
113 | ||
114 | (* Remove the smallest element of the given set *) | |
115 | ||
116 | let rec remove_min_elt = function | |
117 | Empty -> invalid_arg "Set.remove_min_elt" | |
118 | | Node(Empty, v, r, _) -> r | |
119 | | Node(l, v, r, _) -> bal (remove_min_elt l) v r | |
120 | ||
121 | (* Merge two trees l and r into one. | |
122 | All elements of l must precede the elements of r. | |
123 | Assume | height l - height r | <= 2. *) | |
124 | ||
125 | let merge t1 t2 = | |
126 | match (t1, t2) with | |
127 | (Empty, t) -> t | |
128 | | (t, Empty) -> t | |
129 | | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) | |
130 | ||
131 | (* Merge two trees l and r into one. | |
132 | All elements of l must precede the elements of r. | |
133 | No assumption on the heights of l and r. *) | |
134 | ||
135 | let concat t1 t2 = | |
136 | match (t1, t2) with | |
137 | (Empty, t) -> t | |
138 | | (t, Empty) -> t | |
139 | | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) | |
140 | ||
141 | (* Splitting. split x s returns a triple (l, present, r) where | |
142 | - l is the set of elements of s that are < x | |
143 | - r is the set of elements of s that are > x | |
144 | - present is false if s contains no element equal to x, | |
145 | or true if s contains an element equal to x. *) | |
146 | ||
147 | let rec split x = function | |
148 | Empty -> | |
149 | (Empty, false, Empty) | |
150 | | Node(l, v, r, _) -> | |
151 | let c = compare x v in | |
152 | if c = 0 then (l, true, r) | |
153 | else if c < 0 then | |
154 | let (ll, pres, rl) = split x l in (ll, pres, join rl v r) | |
155 | else | |
156 | let (lr, pres, rr) = split x r in (join l v lr, pres, rr) | |
157 | ||
158 | (* Implementation of the set operations *) | |
159 | ||
160 | let empty = Empty | |
161 | ||
162 | let is_empty = function Empty -> true | _ -> false | |
163 | ||
164 | let rec mem x = function | |
165 | Empty -> false | |
166 | | Node(l, v, r, _) -> | |
167 | let c = compare x v in | |
168 | c = 0 || mem x (if c < 0 then l else r) | |
169 | ||
170 | let singleton x = Node(Empty, x, Empty, 1) | |
171 | ||
172 | let rec remove x = function | |
173 | Empty -> Empty | |
174 | | Node(l, v, r, _) -> | |
175 | let c = compare x v in | |
176 | if c = 0 then merge l r else | |
177 | if c < 0 then bal (remove x l) v r else bal l v (remove x r) | |
178 | ||
179 | let rec union s1 s2 = | |
180 | match (s1, s2) with | |
181 | (Empty, t2) -> t2 | |
182 | | (t1, Empty) -> t1 | |
183 | | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> | |
184 | if h1 >= h2 then | |
185 | if h2 = 1 then add v2 s1 else begin | |
186 | let (l2, _, r2) = split v1 s2 in | |
187 | join (union l1 l2) v1 (union r1 r2) | |
188 | end | |
189 | else | |
190 | if h1 = 1 then add v1 s2 else begin | |
191 | let (l1, _, r1) = split v2 s1 in | |
192 | join (union l1 l2) v2 (union r1 r2) | |
193 | end | |
194 | ||
195 | let rec inter s1 s2 = | |
196 | match (s1, s2) with | |
197 | (Empty, t2) -> Empty | |
198 | | (t1, Empty) -> Empty | |
199 | | (Node(l1, v1, r1, _), t2) -> | |
200 | match split v1 t2 with | |
201 | (l2, false, r2) -> | |
202 | concat (inter l1 l2) (inter r1 r2) | |
203 | | (l2, true, r2) -> | |
204 | join (inter l1 l2) v1 (inter r1 r2) | |
205 | ||
206 | let rec diff s1 s2 = | |
207 | match (s1, s2) with | |
208 | (Empty, t2) -> Empty | |
209 | | (t1, Empty) -> t1 | |
210 | | (Node(l1, v1, r1, _), t2) -> | |
211 | match split v1 t2 with | |
212 | (l2, false, r2) -> | |
213 | join (diff l1 l2) v1 (diff r1 r2) | |
214 | | (l2, true, r2) -> | |
215 | concat (diff l1 l2) (diff r1 r2) | |
216 | ||
217 | let rec compare_aux l1 l2 = | |
218 | match (l1, l2) with | |
219 | ([], []) -> 0 | |
220 | | ([], _) -> -1 | |
221 | | (_, []) -> 1 | |
222 | | (Empty :: t1, Empty :: t2) -> | |
223 | compare_aux t1 t2 | |
224 | | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> | |
225 | let c = compare v1 v2 in | |
226 | if c <> 0 then c else compare_aux (r1::t1) (r2::t2) | |
227 | | (Node(l1, v1, r1, _) :: t1, t2) -> | |
228 | compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 | |
229 | | (t1, Node(l2, v2, r2, _) :: t2) -> | |
230 | compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) | |
231 | ||
232 | let compare s1 s2 = | |
233 | compare_aux [s1] [s2] | |
234 | ||
235 | let equal s1 s2 = | |
236 | compare s1 s2 = 0 | |
237 | ||
238 | let rec subset s1 s2 = | |
239 | match (s1, s2) with | |
240 | Empty, _ -> | |
241 | true | |
242 | | _, Empty -> | |
243 | false | |
244 | | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> | |
245 | let c = Pervasives.compare v1 v2 in | |
246 | if c = 0 then | |
247 | subset l1 l2 && subset r1 r2 | |
248 | else if c < 0 then | |
249 | subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 | |
250 | else | |
251 | subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 | |
252 | ||
253 | let rec iter f = function | |
254 | Empty -> () | |
255 | | Node(l, v, r, _) -> iter f l; f v; iter f r | |
256 | ||
257 | let rec fold f s accu = | |
258 | match s with | |
259 | Empty -> accu | |
260 | | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) | |
261 | ||
262 | let rec for_all p = function | |
263 | Empty -> true | |
264 | | Node(l, v, r, _) -> p v && for_all p l && for_all p r | |
265 | ||
266 | let rec exists p = function | |
267 | Empty -> false | |
268 | | Node(l, v, r, _) -> p v || exists p l || exists p r | |
269 | ||
270 | let filter p s = | |
271 | let rec filt accu = function | |
272 | | Empty -> accu | |
273 | | Node(l, v, r, _) -> | |
274 | filt (filt (if p v then add v accu else accu) l) r in | |
275 | filt Empty s | |
276 | ||
277 | let partition p s = | |
278 | let rec part (t, f as accu) = function | |
279 | | Empty -> accu | |
280 | | Node(l, v, r, _) -> | |
281 | part (part (if p v then (add v t, f) else (t, add v f)) l) r in | |
282 | part (Empty, Empty) s | |
283 | ||
284 | let rec cardinal = function | |
285 | Empty -> 0 | |
286 | | Node(l, v, r, _) -> cardinal l + 1 + cardinal r | |
287 | ||
288 | let rec elements_aux accu = function | |
289 | Empty -> accu | |
290 | | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l | |
291 | ||
292 | let elements s = | |
293 | elements_aux [] s | |
294 | ||
295 | let choose = min_elt | |
296 | ||
297 | (* pad: *) | |
298 | let (from_list: 'a list -> 'a t) = fun xs -> | |
299 | List.fold_left (fun a e -> add e a) empty xs | |
300 | ||
301 | ||
302 |