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, 0 insertions, 492 deletions
diff --git a/lib/csc/hash-map.csc b/lib/csc/hash-map.csc
deleted file mode 100644
index 682fa30..0000000
--- a/lib/csc/hash-map.csc
+++ /dev/null
@@ -1,492 +0,0 @@
-(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 13:53:12 +0000