diff options
Diffstat (limited to 'lib/csc/map.scheme')
| -rw-r--r-- | lib/csc/map.scheme | 72 |
1 files changed, 51 insertions, 21 deletions
diff --git a/lib/csc/map.scheme b/lib/csc/map.scheme index be27758..27eb0c2 100644 --- a/lib/csc/map.scheme +++ b/lib/csc/map.scheme @@ -13,7 +13,10 @@ map? not-found-error? singleton - union) + size + subset? + union + union-with) (import (scheme base) (only (scheme case-lambda) case-lambda)) (begin @@ -67,12 +70,16 @@ (make-map cmp (singleton-node key val))) - (define (size n) + (define (sz n) (if n (node-size n) 0)) + (define (size m) + (sz (map-root m))) + + (define-record-type <not-found-error> (make-not-found-error) not-found-error?) @@ -99,7 +106,7 @@ ; The bin constructor maintains the size of the tree. (define (bin k x l r) - (make-node (+ (size l) (size r) 1) k x l r)) + (make-node (+ (sz l) (sz r) 1) k x l r)) ; https://hackage.haskell.org/package/containers-0.4.0.0/docs/src/Data-Map.html#delta @@ -131,20 +138,20 @@ (define (rotate-l k x l r) - (if (< (size (node-left r)) (* ratio (size (node-right r)))) + (if (< (sz (node-left r)) (* ratio (sz (node-right r)))) (single-l k x l r) (double-l k x l r))) (define (rotate-r k x l r) - (if (< (size (node-right l)) (* ratio (size (node-left l)))) + (if (< (sz (node-right l)) (* ratio (sz (node-left l)))) (single-r k x l r) (double-r k x l r))) (define (balance k x l r) - (define size-l (size l)) - (define size-r (size r)) + (define size-l (sz l)) + (define size-r (sz r)) (cond ((<= (+ size-l size-r) 1) (bin k x l r)) ((> size-r (* delta size-l)) (rotate-l k x l r)) @@ -186,11 +193,11 @@ (define (split cmp t k) (match t - (tip (values #f #f #f)) + (tip (values #f *not-found-error* #f)) ((node km m l r) (define ord (cmp k km)) (cond - ((zero? ord) (values l #t r)) + ((zero? ord) (values l m r)) ((negative? ord) (let-values (((ll b lr) (split cmp l k))) (values ll b (join km m lr r)))) @@ -232,28 +239,36 @@ (foldl f (f acc (car l)) (cdr l)))) - (define (union-node cmp t1 t2) + (define (union-node cmp f t1 t2) (cond - ((not t1) t2) ((not t2) t1) + ((not t1) t2) (else - (match t2 ((node k2 x2 l2 r2) - (define-values (l1 b r1) (split cmp t1 k2)) - (define tl (union-node cmp l1 l2)) - (define tr (union-node cmp r1 r2)) - (join k2 x2 tl tr)))))) + (match t1 ((node k1 x1 l1 r1) + (define-values (l2 x2 r2) (split cmp t2 k1)) + (define tl (union-node cmp f l1 l2)) + (define tr (union-node cmp f r1 r2)) + (define x + (if (eq? x2 *not-found-error*) + x1 + (f x1 x2))) + (join k1 x tl tr)))))) - (define (union m . ms) + (define (union-with f m . ms) (define cmp (map-cmp m)) (make-map cmp (foldl (lambda (acc x) - (union-node cmp acc (map-root x))) + (union-node cmp f acc (map-root x))) (map-root m) ms))) + (define (union m . ms) + (apply union-with (lambda (l r) r) m ms)) + + (define (intersect-node cmp t1 t2) (cond ((not (and t1 t2)) #f) @@ -262,9 +277,9 @@ (define-values (l1 b r1) (split cmp t1 k2)) (define tl (intersect-node cmp l1 l2)) (define tr (intersect-node cmp r1 r2)) - (if b - (join k2 x2 tl tr) - (join2 tl tr))))))) + (if (eq? b *not-found-error*) + (join2 tl tr) + (join k2 x2 tl tr))))))) (define (intersect m . ms) @@ -298,6 +313,21 @@ ms))) + (define (subset-node cmp a b) + (match a + (tip #t) + ((node k x al ar) + (define-values (bl found? br) (split cmp b k)) + (and (not (eq? found? *not-found-error*)) + (subset-node cmp al bl) + (subset-node cmp ar br))))) + + + (define (subset? a b) + (define cmp (map-cmp a)) + (make-map cmp (subset-node cmp (map-root a) (map-root b)))) + + (define (list->map cmp l) (foldl (lambda (acc x) |