aboutsummaryrefslogtreecommitdiffstats
path: root/csc/hash-map.csc
diff options
context:
space:
mode:
Diffstat (limited to 'csc/hash-map.csc')
-rw-r--r--csc/hash-map.csc291
1 files changed, 233 insertions, 58 deletions
diff --git a/csc/hash-map.csc b/csc/hash-map.csc
index a8579fb..5a604ad 100644
--- a/csc/hash-map.csc
+++ b/csc/hash-map.csc
@@ -1,18 +1,22 @@
(define-library (csc hash-map)
(export
alist->map
- map-for-each
hash-bytevector
insert
key-not-found-error?
lookup
make-map
+ delete
map->alist
+ map-for-each
map?
merge)
(import (scheme base)
- (only (csc format) sprintf)
- (only (csc match) match))
+ (only (csc match)
+ define-match-record-type
+ match)
+ (only (scheme case-lambda)
+ case-lambda))
(begin
@@ -23,29 +27,17 @@
(hash key-hash-hash))
- (define (key-hash<? k1 k2 cmp)
- (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)
- (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 (cmp-key-hash k1 k2 cmp)
+ (define d (- (key-hash-hash k2) (key-hash-hash k1)))
+ (if (zero? d)
+ (cmp (key-hash-value k1) (key-hash-value k2))
+ d))
- (define-record-type <node>
+ (define-match-record-type <node>
(make-node color key-hash val left right)
node?
+ %node
(color node-color)
(key-hash node-key)
(val node-value)
@@ -63,6 +55,21 @@
(eq? 'black (node-color n))))
+ (define (node-kv n)
+ (cons (node-key n) (node-value n)))
+
+
+ (define (node-colored color kv left right)
+ (make-node color (car kv) (cdr kv) left right))
+
+
+ (define (red-node kv left right)
+ (node-colored 'red kv left right))
+
+ (define (black-node kv left right)
+ (node-colored 'black kv left right))
+
+
(define (rebalance-left m)
(define p (node-left m))
(define u (node-right m))
@@ -84,9 +91,9 @@
; 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))))
+ (red-node (node-kv m)
+ (black-node (node-kv p) (node-left p) (node-right p))
+ (black-node (node-kv u) (node-left u) (node-right u))))
((and (red? p)
(red? (node-right p))
(black? u))
@@ -163,19 +170,24 @@
(else m)))
- (define (insert-node m k v cmp)
- (cond ((null? m) (make-node 'red k v '() '()))
- ((key-hash<? k (node-key m) cmp)
- (rebalance-left
- (make-node (node-color m) (node-key m) (node-value m)
- (insert-node (node-left m) k v cmp)
- (node-right m))))
- ((key-hash=? k (node-key m) cmp) (make-node (node-color m) k v (node-left m) (node-right m)))
+ (define (insert-node n k v cmp)
+ (match n
+ ('() (make-node 'red k v '() '()))
+ ((% %node color node-key node-val left right)
+ (define ord (cmp-key-hash k node-key cmp))
+ (cond
+ ((negative? ord)
+ (rebalance-left
+ (make-node color node-key node-val
+ (insert-node left k v cmp)
+ right)))
+ ((zero? ord)
+ (make-node color k v left right))
(else
(rebalance-right
- (make-node (node-color m) (node-key m) (node-value m)
- (node-left m)
- (insert-node (node-right m) k v cmp))))))
+ (make-node color node-key node-val
+ left
+ (insert-node right k v cmp))))))))
(define-record-type <map>
@@ -202,11 +214,11 @@
(define (insert m k v)
- (let ((res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m))))
- (construct-map
- (map-raw-hash m)
- (map-cmp m)
- (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res)))))
+ (define res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m)))
+ (construct-map
+ (map-raw-hash m)
+ (map-cmp m)
+ (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res))))
(define-record-type <key-not-found-error>
@@ -214,25 +226,38 @@
key-not-found-error?)
- (define (lookup m k)
- (letrec ((k* (make-key-hash k ((map-hash m) k)))
- (lookup
- (lambda (n)
- (cond ((null? n) (raise (make-key-not-found-error)))
- ((key-hash<? k* (node-key n) (map-cmp m)) (lookup (node-left n)))
- ((key-hash=? k* (node-key n) (map-cmp m)) (node-value n))
- (else (lookup (node-right n)))))))
- (lookup (map-root m))))
+ (define *key-not-found-error* (make-key-not-found-error))
+
+
+ (define lookup
+ (case-lambda
+ ((m k)
+ (define cmp (map-cmp m))
+ (define k* (make-key-hash k ((map-hash m) k)))
+ (let loop ((n (map-root m)))
+ (match n
+ ('() (raise *key-not-found-error*))
+ ((% %node _ node-key node-val left right)
+ (define ord (cmp-key-hash k* node-key cmp))
+ (cond
+ ((negative? ord)
+ (loop left))
+ ((zero? ord)
+ node-val)
+ (else
+ (loop right)))))))
+ ((m k def)
+ (guard (e ((key-not-found-error? e) def))
+ (lookup m k)))))
(define (map-for-each f m)
- (letrec ((node-foreach
- (lambda (n)
- (unless (null? n)
- (node-foreach (node-left n))
- (f (key-hash-value (node-key n)) (node-value n))
- (node-foreach (node-right n))))))
- (node-foreach (map-root m))))
+ (let loop ((n (map-root m)))
+ (match n
+ ((% %node _ node-key node-val left right)
+ (loop left)
+ (f (key-hash-value node-key) node-val)
+ (loop right)))))
(define (map->alist m)
@@ -274,4 +299,154 @@
(m m))
(match m*
('() m)
- ((head . tail) (loop tail (merge2 m head))))))))
+ ((head . tail) (loop tail (merge2 m head))))))
+
+
+ ; Jinkies!
+ (define (delete m k)
+ (define cmp (map-cmp m))
+ (define k* (make-key-hash k ((map-hash m) k)))
+ ; local variables
+ (define need-fix #f)
+ (define replacement-node #f)
+
+ (define (fix-black-height-left p)
+ ; n.b.: s must not be nil, because we deleted a black node and so
+ ; there must be at least one node in s to balance out the
+ ; black height.
+ (define s (node-right p))
+ (define n (node-left p))
+ (define c (node-left s))
+ (define d (node-right s))
+ (set! need-fix #f)
+ (cond
+ ((red? s)
+ ; p s
+ ; / \ / \
+ ; n s => p d
+ ; / \ / \
+ ; c d n c
+ (black-node (node-kv s)
+ (fix-black-height-left
+ (red-node (node-kv p) n c))
+ d))
+ ((red? d)
+ (node-colored (node-color p) (node-kv s)
+ (black-node (node-kv p) n c)
+ (black-node (node-kv d) (node-left d) (node-right d))))
+ ((red? c)
+ (fix-black-height-left
+ (node-colored (node-color p) (node-kv p)
+ n
+ (black-node (node-kv c)
+ (node-left c)
+ (red-node (node-kv s)
+ (node-right c)
+ d)))))
+ ((red? p)
+ (black-node (node-kv p)
+ n
+ (red-node (node-kv s) c d)))
+ (else
+ (set! need-fix #t) ; This is the only recursive case.
+ (black-node (node-kv p)
+ n
+ (red-node (node-kv s) c d)))))
+ (define (fix-black-height-right p)
+ (define s (node-left p))
+ (define n (node-right p))
+ (define c (node-right s))
+ (define d (node-left s))
+ (set! need-fix #f)
+ (cond
+ ((red? s)
+ (black-node (node-kv s)
+ d
+ (fix-black-height-right
+ (red-node (node-kv p) c n))))
+ ((red? d)
+ (node-colored (node-color p) (node-kv s)
+ (black-node (node-kv d) (node-left d) (node-right d))
+ (black-node (node-kv p) c n)))
+ ((red? c)
+ ; p p
+ ; / \ / \
+ ; s n => c n
+ ; / \ /
+ ; d c s
+ ; /
+ ; d
+ (fix-black-height-right
+ (node-colored (node-color p) (node-kv p)
+ (black-node (node-kv c)
+ (red-node (node-kv s)
+ d
+ (node-left c))
+ (node-right c))
+ n)))
+ ((red? p)
+ (black-node (node-kv p)
+ (red-node (node-kv s) d c)
+ n))
+ (else
+ (set! need-fix #t)
+ (black-node (node-kv p)
+ (red-node (node-kv s) d c)
+ n))))
+ (construct-map (map-raw-hash m) cmp
+ (let loop ((n (map-root m)))
+ (match n
+ ('() '())
+ ((% %node color nk nv left right)
+ (define ord (cmp-key-hash k* nk cmp))
+ (cond
+ ((negative? ord)
+ (let* ((left* (loop left))
+ (n* (make-node color nk nv left* right)))
+ (if need-fix
+ (fix-black-height-left n*)
+ n*)))
+ ((positive? ord)
+ (let* ((right* (loop right))
+ (n* (make-node color nk nv left right*)))
+ (if need-fix
+ (fix-black-height-right n*)
+ n*)))
+ ((and (not (null? left))
+ (not (null? right)))
+ (let* ((left* (let find-max ((r left))
+ (match r
+ ((% %node _ _ _ r-left '())
+ (set! replacement-node r)
+ (cond
+ ((red? r) '())
+ ((null? r-left)
+ (set! need-fix #t)
+ '())
+ (else
+ (black-node (node-kv r-left)
+ (node-left r-left)
+ (node-right r-left)))))
+ ((% %node r-color r-k r-v r-left r-right)
+ (define n* (make-node r-color r-k r-v
+ r-left
+ (find-max r-right)))
+ (if need-fix
+ (fix-black-height-right n*)
+ n*)))))
+ (n* (node-colored color (node-kv replacement-node) left* right)))
+ (if need-fix
+ (fix-black-height-left n*)
+ n*)))
+ ((red? n) '())
+ ((and (null? left)
+ (null? right))
+ (set! need-fix #t)
+ '())
+ (else
+ (let ((child (if (null? left)
+ right
+ left)))
+ (black-node (node-kv child)
+ (node-left child)
+ (node-right child))))))))))))
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 07:05:31 +0000