aboutsummaryrefslogtreecommitdiffstats
path: root/lib/csc/hash-map.csc
diff options
context:
space:
mode:
Diffstat (limited to 'lib/csc/hash-map.csc')
-rw-r--r--lib/csc/hash-map.csc492
1 files changed, 492 insertions, 0 deletions
diff --git a/lib/csc/hash-map.csc b/lib/csc/hash-map.csc
new file mode 100644
index 0000000..682fa30
--- /dev/null
+++ b/lib/csc/hash-map.csc
@@ -0,0 +1,492 @@
+(define-library (csc hash-map)
+ (export
+ alist->map
+ compare-numbers
+ compare-strings
+ compare-symbols
+ delete
+ hash-bytevector
+ insert
+ key-not-found-error?
+ lookup
+ make-comparer
+ make-map
+ map->alist
+ map-for-each
+ map?
+ merge)
+ (import (scheme base)
+ (only (csc loop)
+ loop
+ return)
+ (only (csc match)
+ define-match-record-type
+ match)
+ (only (scheme case-lambda)
+ case-lambda))
+ (begin
+
+
+ (define-record-type <key-hash>
+ (make-key-hash k hash)
+ key-hash?
+ (k key-hash-value)
+ (hash key-hash-hash))
+
+
+ (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-match-record-type <node>
+ (make-node color key-hash val left right)
+ node?
+ %node
+ (color node-color)
+ (key-hash node-key)
+ (val node-value)
+ (left node-left)
+ (right node-right))
+
+
+ (define (red? n)
+ (and (not (null? n))
+ (eq? 'red (node-color n))))
+
+
+ (define (black? n)
+ (or (null? n)
+ (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))
+ (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
+ (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))
+ ; 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)
+ (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)))
+
+
+ (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 color node-key node-val
+ left
+ (insert-node right k v cmp))))))))
+
+
+ (define-record-type <map>
+ (construct-map hash cmp root)
+ map?
+ (hash map-raw-hash)
+ (cmp map-cmp)
+ (root map-root))
+
+
+ (define-record-type <comparer>
+ (make-comparer hash cmp)
+ comparer?
+ (hash comparer-hash)
+ (cmp comparer-cmp))
+
+
+ (define (make-map comparer)
+ (construct-map (comparer-hash comparer) (comparer-cmp comparer) '()))
+
+
+ (define (shuffle n)
+ (remainder
+ (* #x9e3779b97f4a7c55 n)
+ #x10000000000000000))
+
+
+ (define (map-hash m)
+ (lambda (k)
+ (shuffle ((map-raw-hash m) k))))
+
+
+ (define (insert m k v)
+ (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>
+ (make-key-not-found-error)
+ key-not-found-error?)
+
+
+ (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)
+ (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)
+ (let ((alist '()))
+ (map-for-each
+ (lambda (k v)
+ (set! alist (cons (cons k v) alist)))
+ m)
+ alist))
+
+
+ (define (alist->map comparer alist)
+ (loop with m = (make-map comparer)
+ for elem in alist
+ do (set! m (insert m (car elem) (cdr elem)))
+ finally (return m)))
+
+
+ (define (hash-bytevector b)
+ (loop for i from 0 below (bytevector-length b)
+ with hash = 0
+ do (set! hash (remainder
+ (+ (* hash #x100) (bytevector-u8-ref b i))
+ #x10000000000000000))
+ finally (return hash)))
+
+
+ (define compare-symbols
+ (make-comparer
+ (lambda (s) (hash-bytevector (string->utf8 (symbol->string s))))
+ (lambda (s1 s2)
+ (cond
+ ((symbol=? s1 s2) 0)
+ ((string<? (symbol->string s1) (symbol->string s2)) -1)
+ (else 1)))))
+
+
+ (define compare-numbers
+ (make-comparer
+ (lambda (x) x)
+ (lambda (y x) (- y x))))
+
+
+ (define compare-strings
+ (make-comparer
+ (lambda (s) (hash-bytevector (string->utf8 s)))
+ (lambda (s1 s2)
+ (cond
+ ((string=? s1 s2) 0)
+ ((string<? (symbol->string s1) (symbol->string s2)) -1)
+ (else 1)))))
+
+
+ (define (merge2 m1 m2)
+ (let ((m1 m1))
+ (map-for-each
+ (lambda (k v)
+ (set! m1 (insert m1 k v)))
+ m2)
+ m1))
+
+
+ (define (merge m . m*)
+ (let loop ((m* m*)
+ (m m))
+ (match m*
+ ('() m)
+ ((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 17:31:32 +0000