diff options
Diffstat (limited to 'csc/hash-map.csc')
| -rw-r--r-- | csc/hash-map.csc | 224 |
1 files changed, 110 insertions, 114 deletions
diff --git a/csc/hash-map.csc b/csc/hash-map.csc index be9e507..a8579fb 100644 --- a/csc/hash-map.csc +++ b/csc/hash-map.csc @@ -24,17 +24,23 @@ (define (key-hash<? k1 k2 cmp) - (cond ((< (key-hash-hash k1) (key-hash-hash k2)) #t) - ((> (key-hash-hash k1) (key-hash-hash k2)) #f) - (else (cmp (key-hash-value k1) (key-hash-value k2))))) + (define h1 (key-hash-hash k1)) + (define h2 (key-hash-hash k2)) + (cond + ((< h1 h2) + #t) + ((> h1 h2) + #f) + (else + (cmp (key-hash-value k1) (key-hash-value k2))))) (define (key-hash=? k1 k2 cmp) - (let ((v1 (key-hash-value k1)) - (v2 (key-hash-value k2))) - (and (= (key-hash-hash k1) (key-hash-hash k2)) - (not (cmp v1 v2)) - (not (cmp v2 v1))))) + (define v1 (key-hash-value k1)) + (define v2 (key-hash-value k2)) + (and (= (key-hash-hash k1) (key-hash-hash k2)) + (not (cmp v1 v2)) + (not (cmp v2 v1)))) (define-record-type <node> @@ -48,123 +54,113 @@ (define (red? n) - (if (null? n) - #f - (eq? 'red (node-color n)))) + (and (not (null? n)) + (eq? 'red (node-color n)))) (define (black? n) - (if (null? n) - #t - (eq? 'black (node-color n)))) + (or (null? n) + (eq? 'black (node-color n)))) (define (rebalance-left m) - (let ((p (node-left m)) - (u (node-right m))) - (cond ((or - (and - (red? p) - (red? (node-left p)) - (red? u)) - (and - (red? p) - (red? (node-right p)) - (red? u))) - ; b r - ; / \ / \ - ; r r => b b - ; / / - ; r r + (define p (node-left m)) + (define u (node-right m)) + (cond + ((or (and (red? p) + (red? (node-left p)) + (red? u)) + (and (red? p) + (red? (node-right p)) + (red? u))) + ; b r + ; / \ / \ + ; r r => b b + ; / / + ; r r - ; b r - ; / \ / \ - ; r r => b b - ; \ \ - ; r r - (make-node 'red (node-key m) (node-value m) - (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)) - (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)))) - ((and - (red? p) - (red? (node-right p)) - (black? u)) - ; b b - ; / \ / \ - ; r b => r r - ; \ \ - ; r b - (let ((n (node-right p))) - (make-node 'black (node-key n) (node-value n) - (make-node 'red (node-key p) (node-value p) (node-left p) (node-left n)) - (make-node 'red (node-key m) (node-value m) (node-right n) u)))) - ((and - (red? p) - (red? (node-left p)) - (black? u)) - ; b b - ; / \ / \ - ; r b => r r - ; / \ - ; r b - (make-node 'black (node-key p) (node-value p) - (node-left p) - (make-node 'red (node-key m) (node-value m) (node-right p) u))) - (else m)))) + ; b r + ; / \ / \ + ; r r => b b + ; \ \ + ; r r + (make-node 'red (node-key m) (node-value m) + (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)) + (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)))) + ((and (red? p) + (red? (node-right p)) + (black? u)) + ; b b + ; / \ / \ + ; r b => r r + ; \ \ + ; r b + (let ((n (node-right p))) + (make-node 'black (node-key n) (node-value n) + (make-node 'red (node-key p) (node-value p) (node-left p) (node-left n)) + (make-node 'red (node-key m) (node-value m) (node-right n) u)))) + ((and (red? p) + (red? (node-left p)) + (black? u)) + ; b b + ; / \ / \ + ; r b => r r + ; / \ + ; r b + (make-node 'black (node-key p) (node-value p) + (node-left p) + (make-node 'red (node-key m) (node-value m) (node-right p) u))) + (else m))) (define (rebalance-right m) - (let ((u (node-left m)) - (p (node-right m))) - (cond ((or - (and - (red? u) - (red? p) - (red? (node-left p))) - (and - (red? u) - (red? p) - (red? (node-right p)))) - ; b r - ; / \ / \ - ; r r => b b - ; \ \ - ; r r + (define u (node-left m)) + (define p (node-right m)) + (cond + ((or (and (red? u) + (red? p) + (red? (node-left p))) + (and (red? u) + (red? p) + (red? (node-right p)))) + ; b r + ; / \ / \ + ; r r => b b + ; \ \ + ; r r - ; b r - ; / \ / \ - ; r r => b b - ; / / - ; r r - (make-node 'red (node-key m) (node-value m) - (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)) - (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)))) - ((and - (black? u) - (red? p) - (red? (node-left p))) - ; b b - ; / \ / \ - ; b r => r r - ; / / - ; r b - (let ((n (node-left p))) - (make-node 'black (node-key n) (node-value n) - (make-node 'red (node-key m) (node-value m) u (node-left n)) - (make-node 'red (node-key p) (node-value p) (node-right n) (node-right p))))) - ((and - (black? u) - (red? p) - (red? (node-right p))) - ; b b - ; / \ / \ - ; b r => r r - ; \ / - ; r b - (make-node 'black (node-key p) (node-value p) - (make-node 'red (node-key m) (node-value m) u (node-left p)) - (node-right p))) - (else m)))) + ; b r + ; / \ / \ + ; r r => b b + ; / / + ; r r + (make-node 'red (node-key m) (node-value m) + (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)) + (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)))) + ((and (black? u) + (red? p) + (red? (node-left p))) + ; b b + ; / \ / \ + ; b r => r r + ; / / + ; r b + (let ((n (node-left p))) + (make-node 'black (node-key n) (node-value n) + (make-node 'red (node-key m) (node-value m) u (node-left n)) + (make-node 'red (node-key p) (node-value p) (node-right n) (node-right p))))) + ((and (black? u) + (red? p) + (red? (node-right p))) + ; b b + ; / \ / \ + ; b r => r r + ; \ / + ; r b + (make-node 'black (node-key p) (node-value p) + (make-node 'red (node-key m) (node-value m) u (node-left p)) + (node-right p))) + (else m))) (define (insert-node m k v cmp) |