Commit | Line | Data |
---|---|---|
b1103eb9 | 1 | ;;; Functional name maps |
9c8d2b85 | 2 | ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. |
b1103eb9 AW |
3 | ;;; |
4 | ;;; This library is free software: you can redistribute it and/or modify | |
5 | ;;; it under the terms of the GNU Lesser General Public License as | |
6 | ;;; published by the Free Software Foundation, either version 3 of the | |
7 | ;;; License, or (at your option) any later version. | |
8 | ;;; | |
9 | ;;; This library is distributed in the hope that it will be useful, but | |
10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;; Lesser General Public License for more details. | |
13 | ;;; | |
14 | ;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;; License along with this program. If not, see | |
16 | ;;; <http://www.gnu.org/licenses/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;;; | |
20 | ;;; A persistent, functional data structure representing a set of | |
21 | ;;; integers as a tree whose branches are vectors and whose leaves are | |
22 | ;;; fixnums. Intsets are careful to preserve sub-structure, in the | |
23 | ;;; sense of eq?, whereever possible. | |
24 | ;;; | |
25 | ;;; Code: | |
26 | ||
27 | (define-module (language cps intset) | |
28 | #:use-module (rnrs bytevectors) | |
29 | #:use-module (srfi srfi-9) | |
30 | #:use-module (ice-9 match) | |
31 | #:export (empty-intset | |
32 | intset? | |
49cc76ab AW |
33 | transient-intset? |
34 | persistent-intset | |
35 | transient-intset | |
b1103eb9 | 36 | intset-add |
49cc76ab | 37 | intset-add! |
b1103eb9 AW |
38 | intset-remove |
39 | intset-ref | |
40 | intset-next | |
9c8d2b85 AW |
41 | intset-fold |
42 | intset-fold2 | |
b1103eb9 | 43 | intset-union |
41296769 | 44 | intset-intersect |
7f6aafa5 AW |
45 | intset-subtract |
46 | bitvector->intset)) | |
b1103eb9 AW |
47 | |
48 | (define-syntax-rule (define-inline name val) | |
49 | (define-syntax name (identifier-syntax val))) | |
50 | ||
93e83842 AW |
51 | (eval-when (expand) |
52 | (use-modules (system base target)) | |
53 | (define-syntax compile-time-cond | |
54 | (lambda (x) | |
55 | (syntax-case x (else) | |
56 | ((_ (test body ...) rest ...) | |
57 | (if (primitive-eval (syntax->datum #'test)) | |
58 | #'(begin body ...) | |
59 | #'(begin (compile-time-cond rest ...)))) | |
60 | ((_ (else body ...)) | |
61 | #'(begin body ...)) | |
62 | ((_) | |
63 | (error "no compile-time-cond expression matched")))))) | |
64 | ||
65 | (compile-time-cond | |
66 | ((eqv? (target-word-size) 4) | |
67 | (define-inline *leaf-bits* 4)) | |
68 | ((eqv? (target-word-size) 8) | |
69 | (define-inline *leaf-bits* 5))) | |
70 | ||
49cc76ab AW |
71 | ;; FIXME: This should make an actual atomic reference. |
72 | (define-inlinable (make-atomic-reference value) | |
73 | (list value)) | |
74 | (define-inlinable (get-atomic-reference reference) | |
75 | (car reference)) | |
76 | (define-inlinable (set-atomic-reference! reference value) | |
77 | (set-car! reference value)) | |
78 | ||
b1103eb9 AW |
79 | (define-inline *leaf-size* (ash 1 *leaf-bits*)) |
80 | (define-inline *leaf-mask* (1- *leaf-size*)) | |
81 | (define-inline *branch-bits* 3) | |
82 | (define-inline *branch-size* (ash 1 *branch-bits*)) | |
49cc76ab AW |
83 | (define-inline *branch-size-with-edit* (1+ *branch-size*)) |
84 | (define-inline *edit-index* *branch-size*) | |
b1103eb9 AW |
85 | (define-inline *branch-mask* (1- *branch-size*)) |
86 | ||
87 | (define-record-type <intset> | |
88 | (make-intset min shift root) | |
89 | intset? | |
90 | (min intset-min) | |
91 | (shift intset-shift) | |
92 | (root intset-root)) | |
93 | ||
49cc76ab AW |
94 | (define-record-type <transient-intset> |
95 | (make-transient-intset min shift root edit) | |
96 | transient-intset? | |
97 | (min transient-intset-min set-transient-intset-min!) | |
98 | (shift transient-intset-shift set-transient-intset-shift!) | |
99 | (root transient-intset-root set-transient-intset-root!) | |
100 | (edit transient-intset-edit set-transient-intset-edit!)) | |
101 | ||
b1103eb9 AW |
102 | (define (new-leaf) 0) |
103 | (define-inlinable (clone-leaf-and-set leaf i val) | |
104 | (if val | |
105 | (if leaf | |
106 | (logior leaf (ash 1 i)) | |
107 | (ash 1 i)) | |
108 | (if leaf | |
109 | (logand leaf (lognot (ash 1 i))) | |
110 | #f))) | |
111 | (define (leaf-empty? leaf) | |
112 | (zero? leaf)) | |
113 | ||
49cc76ab AW |
114 | (define-inlinable (new-branch edit) |
115 | (let ((vec (make-vector *branch-size-with-edit* #f))) | |
116 | (when edit (vector-set! vec *edit-index* edit)) | |
117 | vec)) | |
b1103eb9 | 118 | (define (clone-branch-and-set branch i elt) |
49cc76ab | 119 | (let ((new (new-branch #f))) |
b1103eb9 AW |
120 | (when branch (vector-move-left! branch 0 *branch-size* new 0)) |
121 | (vector-set! new i elt) | |
122 | new)) | |
49cc76ab AW |
123 | (define-inlinable (assert-readable! root-edit) |
124 | (unless (eq? (get-atomic-reference root-edit) (current-thread)) | |
125 | (error "Transient intset owned by another thread" root-edit))) | |
126 | (define-inlinable (writable-branch branch root-edit) | |
127 | (let ((edit (vector-ref branch *edit-index*))) | |
128 | (if (eq? root-edit edit) | |
129 | branch | |
130 | (clone-branch-and-set branch *edit-index* root-edit)))) | |
b1103eb9 AW |
131 | (define (branch-empty? branch) |
132 | (let lp ((i 0)) | |
133 | (or (= i *branch-size*) | |
134 | (and (not (vector-ref branch i)) | |
135 | (lp (1+ i)))))) | |
136 | ||
137 | (define (round-down min shift) | |
138 | (logand min (lognot (1- (ash 1 shift))))) | |
139 | ||
140 | (define empty-intset (make-intset 0 *leaf-bits* #f)) | |
141 | ||
142 | (define (add-level min shift root) | |
143 | (let* ((shift* (+ shift *branch-bits*)) | |
144 | (min* (round-down min shift*)) | |
145 | (idx (logand (ash (- min min*) (- shift)) *branch-mask*))) | |
146 | (make-intset min* shift* (clone-branch-and-set #f idx root)))) | |
147 | ||
148 | (define (make-intset/prune min shift root) | |
b5cb1c77 AW |
149 | (cond |
150 | ((not root) | |
151 | empty-intset) | |
152 | ((= shift *leaf-bits*) | |
153 | (make-intset min shift root)) | |
154 | (else | |
155 | (let lp ((i 0) (elt #f)) | |
156 | (cond | |
157 | ((< i *branch-size*) | |
158 | (if (vector-ref root i) | |
159 | (if elt | |
160 | (make-intset min shift root) | |
161 | (lp (1+ i) i)) | |
162 | (lp (1+ i) elt))) | |
163 | (elt | |
164 | (let ((shift (- shift *branch-bits*))) | |
165 | (make-intset/prune (+ min (ash elt shift)) | |
166 | shift | |
167 | (vector-ref root elt)))) | |
168 | ;; Shouldn't be reached... | |
169 | (else empty-intset)))))) | |
b1103eb9 | 170 | |
49cc76ab AW |
171 | (define* (transient-intset #:optional (source empty-intset)) |
172 | (match source | |
173 | (($ <transient-intset> min shift root edit) | |
174 | (assert-readable! edit) | |
175 | source) | |
176 | (($ <intset> min shift root) | |
177 | (let ((edit (make-atomic-reference (current-thread)))) | |
178 | (make-transient-intset min shift root edit))))) | |
179 | ||
180 | (define* (persistent-intset #:optional (source empty-intset)) | |
181 | (match source | |
182 | (($ <transient-intset> min shift root edit) | |
183 | (assert-readable! edit) | |
184 | ;; Make a fresh reference, causing any further operations on this | |
185 | ;; transient to clone its root afresh. | |
186 | (set-transient-intset-edit! source | |
187 | (make-atomic-reference (current-thread))) | |
188 | ;; Clear the reference to the current thread, causing our edited | |
189 | ;; data structures to be persistent again. | |
190 | (set-atomic-reference! edit #f) | |
191 | (if min | |
192 | (make-intset min shift root) | |
193 | empty-intset)) | |
194 | (($ <intset>) | |
195 | source))) | |
196 | ||
197 | (define (intset-add! bs i) | |
198 | (define (adjoin-leaf i root) | |
199 | (clone-leaf-and-set root (logand i *leaf-mask*) #t)) | |
200 | (define (ensure-branch! root idx) | |
201 | (let ((edit (vector-ref root *edit-index*))) | |
202 | (match (vector-ref root idx) | |
203 | (#f (let ((v (new-branch edit))) | |
204 | (vector-set! root idx v) | |
205 | v)) | |
206 | (v (writable-branch v edit))))) | |
207 | (define (adjoin-branch! i shift root) | |
208 | (let* ((shift (- shift *branch-bits*)) | |
209 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
210 | (cond | |
211 | ((= shift *leaf-bits*) | |
212 | (vector-set! root idx (adjoin-leaf i (vector-ref root idx)))) | |
213 | (else | |
214 | (adjoin-branch! i shift (ensure-branch! root idx)))))) | |
215 | (match bs | |
216 | (($ <transient-intset> min shift root edit) | |
217 | (assert-readable! edit) | |
218 | (cond | |
219 | ((< i 0) | |
220 | ;; The power-of-two spanning trick doesn't work across 0. | |
221 | (error "Intsets can only hold non-negative integers." i)) | |
222 | ((not root) | |
223 | ;; Add first element. | |
224 | (let ((min (round-down i shift))) | |
225 | (set-transient-intset-min! bs min) | |
226 | (set-transient-intset-shift! bs *leaf-bits*) | |
227 | (set-transient-intset-root! bs (adjoin-leaf (- i min) root)))) | |
228 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
229 | ;; Add element to set; level will not change. | |
230 | (if (= shift *leaf-bits*) | |
231 | (set-transient-intset-root! bs (adjoin-leaf (- i min) root)) | |
232 | (adjoin-branch! (- i min) shift root))) | |
233 | (else | |
234 | (let lp ((min min) | |
235 | (shift shift) | |
236 | (root (if (eqv? shift *leaf-bits*) | |
237 | root | |
238 | (writable-branch root edit)))) | |
239 | (let* ((shift* (+ shift *branch-bits*)) | |
240 | (min* (round-down min shift*)) | |
241 | (idx (logand (ash (- min min*) (- shift)) *branch-mask*)) | |
242 | (root* (new-branch edit))) | |
243 | (vector-set! root* idx root) | |
244 | (cond | |
245 | ((and (<= min* i) (< i (+ min* (ash 1 shift*)))) | |
246 | (set-transient-intset-min! bs min*) | |
247 | (set-transient-intset-shift! bs shift*) | |
248 | (set-transient-intset-root! bs root*) | |
249 | (adjoin-branch! (- i min*) shift* root*)) | |
250 | (else | |
251 | (lp min* shift* root*))))))) | |
252 | bs) | |
253 | (($ <intset>) | |
254 | (intset-add! (transient-intset bs) i)))) | |
255 | ||
b1103eb9 AW |
256 | (define (intset-add bs i) |
257 | (define (adjoin i shift root) | |
258 | (cond | |
259 | ((= shift *leaf-bits*) | |
260 | (let ((idx (logand i *leaf-mask*))) | |
261 | (if (and root (logbit? idx root)) | |
262 | root | |
263 | (clone-leaf-and-set root idx #t)))) | |
264 | (else | |
265 | (let* ((shift (- shift *branch-bits*)) | |
266 | (idx (logand (ash i (- shift)) *branch-mask*)) | |
267 | (node (and root (vector-ref root idx))) | |
268 | (new-node (adjoin i shift node))) | |
269 | (if (eq? node new-node) | |
270 | root | |
271 | (clone-branch-and-set root idx new-node)))))) | |
272 | (match bs | |
273 | (($ <intset> min shift root) | |
274 | (cond | |
4296c36e AW |
275 | ((< i 0) |
276 | ;; The power-of-two spanning trick doesn't work across 0. | |
277 | (error "Intsets can only hold non-negative integers." i)) | |
b1103eb9 AW |
278 | ((not root) |
279 | ;; Add first element. | |
280 | (let ((min (round-down i shift))) | |
281 | (make-intset min *leaf-bits* | |
282 | (adjoin (- i min) *leaf-bits* root)))) | |
283 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
284 | ;; Add element to set; level will not change. | |
285 | (let ((old-root root) | |
286 | (root (adjoin (- i min) shift root))) | |
287 | (if (eq? root old-root) | |
288 | bs | |
289 | (make-intset min shift root)))) | |
290 | ((< i min) | |
291 | ;; Rebuild the tree by unioning two intsets. | |
292 | (intset-union (intset-add empty-intset i) bs)) | |
293 | (else | |
294 | ;; Add a new level and try again. | |
295 | (intset-add (add-level min shift root) i)))))) | |
296 | ||
297 | (define (intset-remove bs i) | |
298 | (define (remove i shift root) | |
299 | (cond | |
300 | ((= shift *leaf-bits*) | |
301 | (let ((idx (logand i *leaf-mask*))) | |
302 | (if (logbit? idx root) | |
303 | (let ((root (clone-leaf-and-set root idx #f))) | |
304 | (and (not (leaf-empty? root)) root)) | |
305 | root))) | |
306 | (else | |
307 | (let* ((shift (- shift *branch-bits*)) | |
308 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
309 | (cond | |
310 | ((vector-ref root idx) | |
311 | => (lambda (node) | |
312 | (let ((new-node (remove i shift node))) | |
313 | (if (eq? node new-node) | |
314 | root | |
315 | (let ((root (clone-branch-and-set root idx new-node))) | |
316 | (and (or new-node (not (branch-empty? root))) | |
317 | root)))))) | |
318 | (else root)))))) | |
319 | (match bs | |
320 | (($ <intset> min shift root) | |
321 | (cond | |
322 | ((not root) bs) | |
323 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
324 | ;; Add element to set; level will not change. | |
325 | (let ((old-root root) | |
326 | (root (remove (- i min) shift root))) | |
327 | (if (eq? root old-root) | |
328 | bs | |
329 | (make-intset/prune min shift root)))) | |
330 | (else bs))))) | |
331 | ||
332 | (define (intset-ref bs i) | |
49cc76ab AW |
333 | (define (ref min shift root) |
334 | (and (<= min i) (< i (+ min (ash 1 shift))) | |
335 | (let ((i (- i min))) | |
336 | (let lp ((node root) (shift shift)) | |
337 | (and node | |
338 | (if (= shift *leaf-bits*) | |
339 | (logbit? (logand i *leaf-mask*) node) | |
340 | (let* ((shift (- shift *branch-bits*)) | |
341 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
342 | (lp (vector-ref node idx) shift)))))))) | |
b1103eb9 AW |
343 | (match bs |
344 | (($ <intset> min shift root) | |
49cc76ab AW |
345 | (ref min shift root)) |
346 | (($ <transient-intset> min shift root edit) | |
347 | (assert-readable! edit) | |
348 | (ref min shift root)))) | |
b1103eb9 AW |
349 | |
350 | (define (intset-next bs i) | |
351 | (define (visit-leaf node i) | |
352 | (let lp ((idx (logand i *leaf-mask*))) | |
353 | (if (logbit? idx node) | |
354 | (logior (logand i (lognot *leaf-mask*)) idx) | |
355 | (let ((idx (1+ idx))) | |
356 | (and (< idx *leaf-size*) | |
357 | (lp idx)))))) | |
358 | (define (visit-branch node shift i) | |
359 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
360 | (and (< idx *branch-size*) | |
048d5d34 AW |
361 | (or (let ((node (vector-ref node idx))) |
362 | (and node (visit-node node shift i))) | |
b1103eb9 AW |
363 | (let ((inc (ash 1 shift))) |
364 | (lp (+ (round-down i shift) inc) (1+ idx))))))) | |
365 | (define (visit-node node shift i) | |
048d5d34 AW |
366 | (if (= shift *leaf-bits*) |
367 | (visit-leaf node i) | |
368 | (visit-branch node (- shift *branch-bits*) i))) | |
49cc76ab AW |
369 | (define (next min shift root) |
370 | (let ((i (if (and i (< min i)) | |
371 | (- i min) | |
372 | 0))) | |
373 | (and root (< i (ash 1 shift)) | |
374 | (let ((i (visit-node root shift i))) | |
375 | (and i (+ min i)))))) | |
b1103eb9 AW |
376 | (match bs |
377 | (($ <intset> min shift root) | |
49cc76ab AW |
378 | (next min shift root)) |
379 | (($ <transient-intset> min shift root edit) | |
380 | (assert-readable! edit) | |
381 | (next min shift root)))) | |
b1103eb9 | 382 | |
9c8d2b85 AW |
383 | (define (intset-fold f set seed) |
384 | (define (visit-branch node shift min seed) | |
385 | (cond | |
386 | ((= shift *leaf-bits*) | |
387 | (let lp ((i 0) (seed seed)) | |
388 | (if (< i *leaf-size*) | |
389 | (lp (1+ i) | |
390 | (if (logbit? i node) | |
391 | (f (+ i min) seed) | |
392 | seed)) | |
393 | seed))) | |
394 | (else | |
395 | (let ((shift (- shift *branch-bits*))) | |
396 | (let lp ((i 0) (seed seed)) | |
397 | (if (< i *branch-size*) | |
398 | (let ((elt (vector-ref node i))) | |
399 | (lp (1+ i) | |
400 | (if elt | |
401 | (visit-branch elt shift (+ min (ash i shift)) seed) | |
402 | seed))) | |
403 | seed)))))) | |
404 | (match set | |
405 | (($ <intset> min shift root) | |
406 | (cond | |
407 | ((not root) seed) | |
49cc76ab AW |
408 | (else (visit-branch root shift min seed)))) |
409 | (($ <transient-intset>) | |
410 | (intset-fold f (persistent-intset set) seed)))) | |
9c8d2b85 AW |
411 | |
412 | (define (intset-fold2 f set s0 s1) | |
413 | (define (visit-branch node shift min s0 s1) | |
414 | (cond | |
415 | ((= shift *leaf-bits*) | |
416 | (let lp ((i 0) (s0 s0) (s1 s1)) | |
417 | (if (< i *leaf-size*) | |
418 | (if (logbit? i node) | |
419 | (call-with-values (lambda () (f (+ i min) s0 s1)) | |
420 | (lambda (s0 s1) | |
421 | (lp (1+ i) s0 s1))) | |
422 | (lp (1+ i) s0 s1)) | |
423 | (values s0 s1)))) | |
424 | (else | |
425 | (let ((shift (- shift *branch-bits*))) | |
426 | (let lp ((i 0) (s0 s0) (s1 s1)) | |
427 | (if (< i *branch-size*) | |
428 | (let ((elt (vector-ref node i))) | |
429 | (if elt | |
430 | (call-with-values | |
431 | (lambda () | |
432 | (visit-branch elt shift (+ min (ash i shift)) s0 s1)) | |
433 | (lambda (s0 s1) | |
434 | (lp (1+ i) s0 s1))) | |
435 | (lp (1+ i) s0 s1))) | |
436 | (values s0 s1))))))) | |
437 | (match set | |
438 | (($ <intset> min shift root) | |
439 | (cond | |
440 | ((not root) (values s0 s1)) | |
49cc76ab AW |
441 | (else (visit-branch root shift min s0 s1)))) |
442 | (($ <transient-intset>) | |
443 | (intset-fold2 f (persistent-intset set) s0 s1)))) | |
9c8d2b85 | 444 | |
b1103eb9 AW |
445 | (define (intset-size shift root) |
446 | (cond | |
447 | ((not root) 0) | |
448 | ((= *leaf-bits* shift) *leaf-size*) | |
449 | (else | |
450 | (let lp ((i (1- *branch-size*))) | |
451 | (let ((node (vector-ref root i))) | |
452 | (if node | |
453 | (let ((shift (- shift *branch-bits*))) | |
454 | (+ (intset-size shift node) | |
455 | (* i (ash 1 shift)))) | |
456 | (lp (1- i)))))))) | |
457 | ||
458 | (define (intset-union a b) | |
459 | ;; Union leaves. | |
460 | (define (union-leaves a b) | |
461 | (logior (or a 0) (or b 0))) | |
462 | ;; Union A and B from index I; the result will be fresh. | |
463 | (define (union-branches/fresh shift a b i fresh) | |
464 | (let lp ((i 0)) | |
465 | (cond | |
466 | ((< i *branch-size*) | |
467 | (let* ((a-child (vector-ref a i)) | |
468 | (b-child (vector-ref b i))) | |
469 | (vector-set! fresh i (union shift a-child b-child)) | |
470 | (lp (1+ i)))) | |
471 | (else fresh)))) | |
472 | ;; Union A and B from index I; the result may be eq? to A. | |
473 | (define (union-branches/a shift a b i) | |
474 | (let lp ((i i)) | |
475 | (cond | |
476 | ((< i *branch-size*) | |
477 | (let* ((a-child (vector-ref a i)) | |
478 | (b-child (vector-ref b i))) | |
479 | (if (eq? a-child b-child) | |
480 | (lp (1+ i)) | |
481 | (let ((child (union shift a-child b-child))) | |
482 | (cond | |
483 | ((eq? a-child child) | |
484 | (lp (1+ i))) | |
485 | (else | |
486 | (let ((result (clone-branch-and-set a i child))) | |
487 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
488 | (else a)))) | |
489 | ;; Union A and B; the may could be eq? to either. | |
490 | (define (union-branches shift a b) | |
491 | (let lp ((i 0)) | |
492 | (cond | |
493 | ((< i *branch-size*) | |
494 | (let* ((a-child (vector-ref a i)) | |
495 | (b-child (vector-ref b i))) | |
496 | (if (eq? a-child b-child) | |
497 | (lp (1+ i)) | |
498 | (let ((child (union shift a-child b-child))) | |
499 | (cond | |
500 | ((eq? a-child child) | |
501 | (union-branches/a shift a b (1+ i))) | |
502 | ((eq? b-child child) | |
503 | (union-branches/a shift b a (1+ i))) | |
504 | (else | |
505 | (let ((result (clone-branch-and-set a i child))) | |
506 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
507 | ;; Seems they are the same but not eq?. Odd. | |
508 | (else a)))) | |
509 | (define (union shift a-node b-node) | |
510 | (cond | |
511 | ((not a-node) b-node) | |
512 | ((not b-node) a-node) | |
513 | ((eq? a-node b-node) a-node) | |
514 | ((= shift *leaf-bits*) (union-leaves a-node b-node)) | |
515 | (else (union-branches (- shift *branch-bits*) a-node b-node)))) | |
516 | (match (cons a b) | |
517 | ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root)) | |
518 | (cond | |
519 | ((not (= b-shift a-shift)) | |
520 | ;; Hoist the set with the lowest shift to meet the one with the | |
521 | ;; higher shift. | |
522 | (if (< b-shift a-shift) | |
523 | (intset-union a (add-level b-min b-shift b-root)) | |
524 | (intset-union (add-level a-min a-shift a-root) b))) | |
525 | ((not (= b-min a-min)) | |
526 | ;; Nodes at the same shift but different minimums will cover | |
527 | ;; disjoint ranges (due to the round-down call on min). Hoist | |
528 | ;; both until they cover the same range. | |
529 | (intset-union (add-level a-min a-shift a-root) | |
530 | (add-level b-min b-shift b-root))) | |
531 | (else | |
532 | ;; At this point, A and B cover the same range. | |
533 | (let ((root (union a-shift a-root b-root))) | |
534 | (cond | |
535 | ((eq? root a-root) a) | |
536 | ((eq? root b-root) b) | |
537 | (else (make-intset a-min a-shift root))))))))) | |
538 | ||
539 | (define (intset-intersect a b) | |
540 | (define tmp (new-leaf)) | |
541 | ;; Intersect leaves. | |
542 | (define (intersect-leaves a b) | |
543 | (logand a b)) | |
544 | ;; Intersect A and B from index I; the result will be fresh. | |
545 | (define (intersect-branches/fresh shift a b i fresh) | |
546 | (let lp ((i 0)) | |
547 | (cond | |
548 | ((< i *branch-size*) | |
549 | (let* ((a-child (vector-ref a i)) | |
550 | (b-child (vector-ref b i))) | |
551 | (vector-set! fresh i (intersect shift a-child b-child)) | |
552 | (lp (1+ i)))) | |
553 | ((branch-empty? fresh) #f) | |
554 | (else fresh)))) | |
555 | ;; Intersect A and B from index I; the result may be eq? to A. | |
556 | (define (intersect-branches/a shift a b i) | |
557 | (let lp ((i i)) | |
558 | (cond | |
559 | ((< i *branch-size*) | |
560 | (let* ((a-child (vector-ref a i)) | |
561 | (b-child (vector-ref b i))) | |
562 | (if (eq? a-child b-child) | |
563 | (lp (1+ i)) | |
564 | (let ((child (intersect shift a-child b-child))) | |
565 | (cond | |
566 | ((eq? a-child child) | |
567 | (lp (1+ i))) | |
568 | (else | |
569 | (let ((result (clone-branch-and-set a i child))) | |
570 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
571 | (else a)))) | |
572 | ;; Intersect A and B; the may could be eq? to either. | |
573 | (define (intersect-branches shift a b) | |
574 | (let lp ((i 0)) | |
575 | (cond | |
576 | ((< i *branch-size*) | |
577 | (let* ((a-child (vector-ref a i)) | |
578 | (b-child (vector-ref b i))) | |
579 | (if (eq? a-child b-child) | |
580 | (lp (1+ i)) | |
581 | (let ((child (intersect shift a-child b-child))) | |
582 | (cond | |
583 | ((eq? a-child child) | |
584 | (intersect-branches/a shift a b (1+ i))) | |
585 | ((eq? b-child child) | |
586 | (intersect-branches/a shift b a (1+ i))) | |
587 | (else | |
588 | (let ((result (clone-branch-and-set a i child))) | |
589 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
590 | ;; Seems they are the same but not eq?. Odd. | |
591 | (else a)))) | |
592 | (define (intersect shift a-node b-node) | |
593 | (cond | |
594 | ((or (not a-node) (not b-node)) #f) | |
595 | ((eq? a-node b-node) a-node) | |
596 | ((= shift *leaf-bits*) (intersect-leaves a-node b-node)) | |
597 | (else (intersect-branches (- shift *branch-bits*) a-node b-node)))) | |
793ca4c4 AW |
598 | |
599 | (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?) | |
600 | (cond | |
601 | ((<= lo-shift hi-shift) | |
602 | ;; If LO has a lower shift and a lower min, it is disjoint. If | |
603 | ;; it has the same shift and a different min, it is also | |
604 | ;; disjoint. | |
605 | empty-intset) | |
606 | (else | |
607 | (let* ((lo-shift (- lo-shift *branch-bits*)) | |
608 | (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) | |
609 | (cond | |
610 | ((>= lo-idx *branch-size*) | |
611 | ;; HI has a lower shift, but it not within LO. | |
612 | empty-intset) | |
613 | ((vector-ref lo-root lo-idx) | |
614 | => (lambda (lo-root) | |
615 | (let ((lo (make-intset (+ lo-min (ash lo-idx lo-shift)) | |
616 | lo-shift | |
617 | lo-root))) | |
618 | (if lo-is-a? | |
619 | (intset-intersect lo hi) | |
620 | (intset-intersect hi lo))))) | |
621 | (else empty-intset)))))) | |
622 | ||
623 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) | |
624 | (cond | |
625 | ((vector-ref hi-root 0) | |
626 | => (lambda (hi-root) | |
627 | (let ((hi (make-intset min | |
628 | (- hi-shift *branch-bits*) | |
629 | hi-root))) | |
630 | (if lo-is-a? | |
631 | (intset-intersect lo hi) | |
632 | (intset-intersect hi lo))))) | |
633 | (else empty-intset))) | |
634 | ||
b1103eb9 AW |
635 | (match (cons a b) |
636 | ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root)) | |
637 | (cond | |
638 | ((< a-min b-min) | |
793ca4c4 | 639 | (different-mins a-min a-shift a-root b-min b-shift b #t)) |
b1103eb9 | 640 | ((< b-min a-min) |
793ca4c4 | 641 | (different-mins b-min b-shift b-root a-min a-shift a #f)) |
b1103eb9 | 642 | ((< a-shift b-shift) |
793ca4c4 AW |
643 | (different-shifts-same-min b-min b-shift b-root a #t)) |
644 | ((< b-shift a-shift) | |
645 | (different-shifts-same-min a-min a-shift a-root b #f)) | |
b1103eb9 AW |
646 | (else |
647 | ;; At this point, A and B cover the same range. | |
648 | (let ((root (intersect a-shift a-root b-root))) | |
649 | (cond | |
650 | ((eq? root a-root) a) | |
651 | ((eq? root b-root) b) | |
652 | (else (make-intset/prune a-min a-shift root))))))))) | |
41296769 AW |
653 | |
654 | (define (intset-subtract a b) | |
655 | (define tmp (new-leaf)) | |
656 | ;; Intersect leaves. | |
657 | (define (subtract-leaves a b) | |
658 | (logand a (lognot b))) | |
659 | ;; Subtract B from A starting at index I; the result will be fresh. | |
660 | (define (subtract-branches/fresh shift a b i fresh) | |
661 | (let lp ((i 0)) | |
662 | (cond | |
663 | ((< i *branch-size*) | |
664 | (let* ((a-child (vector-ref a i)) | |
665 | (b-child (vector-ref b i))) | |
666 | (vector-set! fresh i (subtract-nodes shift a-child b-child)) | |
667 | (lp (1+ i)))) | |
668 | ((branch-empty? fresh) #f) | |
669 | (else fresh)))) | |
670 | ;; Subtract B from A. The result may be eq? to A. | |
671 | (define (subtract-branches shift a b) | |
672 | (let lp ((i 0)) | |
673 | (cond | |
674 | ((< i *branch-size*) | |
675 | (let* ((a-child (vector-ref a i)) | |
676 | (b-child (vector-ref b i))) | |
677 | (let ((child (subtract-nodes shift a-child b-child))) | |
678 | (cond | |
679 | ((eq? a-child child) | |
680 | (lp (1+ i))) | |
681 | (else | |
682 | (let ((result (clone-branch-and-set a i child))) | |
683 | (subtract-branches/fresh shift a b (1+ i) result))))))) | |
684 | (else a)))) | |
685 | (define (subtract-nodes shift a-node b-node) | |
686 | (cond | |
687 | ((or (not a-node) (not b-node)) a-node) | |
688 | ((eq? a-node b-node) #f) | |
689 | ((= shift *leaf-bits*) (subtract-leaves a-node b-node)) | |
690 | (else (subtract-branches (- shift *branch-bits*) a-node b-node)))) | |
691 | ||
692 | (match (cons a b) | |
693 | ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root)) | |
694 | (define (return root) | |
695 | (cond | |
696 | ((eq? root a-root) a) | |
697 | (else (make-intset/prune a-min a-shift root)))) | |
698 | (cond | |
699 | ((<= a-shift b-shift) | |
700 | (let lp ((b-min b-min) (b-shift b-shift) (b-root b-root)) | |
701 | (if (= a-shift b-shift) | |
702 | (if (= a-min b-min) | |
703 | (return (subtract-nodes a-shift a-root b-root)) | |
704 | a) | |
705 | (let* ((b-shift (- b-shift *branch-bits*)) | |
706 | (b-idx (ash (- a-min b-min) (- b-shift))) | |
707 | (b-min (+ b-min (ash b-idx b-shift))) | |
708 | (b-root (and b-root | |
709 | (<= 0 b-idx) | |
710 | (< b-idx *branch-size*) | |
711 | (vector-ref b-root b-idx)))) | |
712 | (lp b-min b-shift b-root))))) | |
713 | (else | |
714 | (return | |
715 | (let lp ((a-min a-min) (a-shift a-shift) (a-root a-root)) | |
716 | (if (= a-shift b-shift) | |
717 | (if (= a-min b-min) | |
718 | (subtract-nodes a-shift a-root b-root) | |
719 | a-root) | |
720 | (let* ((a-shift (- a-shift *branch-bits*)) | |
721 | (a-idx (ash (- b-min a-min) (- a-shift))) | |
722 | (a-min (+ a-min (ash a-idx a-shift))) | |
723 | (old (and a-root | |
724 | (<= 0 a-idx) | |
725 | (< a-idx *branch-size*) | |
726 | (vector-ref a-root a-idx))) | |
727 | (new (lp a-min a-shift old))) | |
728 | (if (eq? old new) | |
729 | a-root | |
730 | (clone-branch-and-set a-root a-idx new))))))))))) | |
7f6aafa5 AW |
731 | |
732 | (define (bitvector->intset bv) | |
733 | (define (finish-tail out min tail) | |
734 | (if (zero? tail) | |
735 | out | |
736 | (intset-union out (make-intset min *leaf-bits* tail)))) | |
737 | (let lp ((out empty-intset) (min 0) (pos 0) (tail 0)) | |
738 | (let ((pos (bit-position #t bv pos))) | |
739 | (cond | |
740 | ((not pos) | |
741 | (finish-tail out min tail)) | |
742 | ((< pos (+ min *leaf-size*)) | |
743 | (lp out min (1+ pos) (logior tail (ash 1 (- pos min))))) | |
744 | (else | |
745 | (let ((min* (round-down pos *leaf-bits*))) | |
746 | (lp (finish-tail out min tail) | |
747 | min* pos (ash 1 (- pos min*))))))))) |