aboutsummaryrefslogtreecommitdiffstats
path: root/hash-map.csc
diff options
context:
space:
mode:
Diffstat (limited to 'hash-map.csc')
-rw-r--r--hash-map.csc259
1 files changed, 0 insertions, 259 deletions
diff --git a/hash-map.csc b/hash-map.csc
deleted file mode 100644
index 01d4158..0000000
--- a/hash-map.csc
+++ /dev/null
@@ -1,259 +0,0 @@
-(define-library (csc hash-map)
- (export
- alist->map
- hash-bytevector
- map->alist
- for-each
- insert
- lookup
- map?
- key-not-found-error?
- make-map)
- (import (scheme base)
- (only (csc format) sprintf))
- (begin
-
-
- (define-record-type <key-hash>
- (make-key-hash k hash)
- key-hash?
- (k key-hash-value)
- (hash key-hash-hash))
-
-
- (define (key-hash<? k1 k2 key<?)
- (cond ((< (key-hash-hash k1) (key-hash-hash k2)) #t)
- ((> (key-hash-hash k1) (key-hash-hash k2)) #f)
- ((key<? (key-hash-value k1) (key-hash-value k2)) #t)
- (else #f)))
-
-
- (define (key-hash=? k1 k2)
- (and (= (key-hash-hash k1) (key-hash-hash k2)) (eqv? (key-hash-value k1) (key-hash-value k2))))
-
-
- (define-record-type <node>
- (make-node color key-hash val left right)
- node?
- (color node-color)
- (key-hash node-key)
- (val node-value)
- (left node-left)
- (right node-right))
-
-
- (define (red? n)
- (if (null? n)
- #f
- (eq? 'red (node-color n))))
-
-
- (define (black? n)
- (if (null? n)
- #t
- (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
-
- ; 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
-
- ; 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 key<?)
- (cond ((null? m) (make-node 'red k v '() '()))
- ((key-hash<? k (node-key m) key<?)
- (rebalance-left
- (make-node (node-color m) (node-key m) (node-value m)
- (insert-node (node-left m) k v key<?)
- (node-right m))))
- ((key-hash=? k (node-key m)) (make-node (node-color m) k v (node-left m) (node-right m)))
- (else
- (rebalance-right
- (make-node (node-color m) (node-key m) (node-value m)
- (node-left m)
- (insert-node (node-right m) k v key<?))))))
-
-
- (define-record-type <hash-map>
- (construct-hash-map hash key<? root)
- hash-map?
- (hash hash-map-raw-hash)
- (key<? hash-map-key<?)
- (root hash-map-root))
-
-
- (define (make-map hash key<?)
- (construct-hash-map hash key<? '()))
-
-
- (define (shuffle n)
- (truncate-remainder
- (* #x9e3779b97f4a7c55 n)
- #x10000000000000000))
-
-
- (define (hash-map-hash m)
- (lambda (k)
- (shuffle ((hash-map-raw-hash m) k))))
-
-
- (define (insert m k v)
- (let ((res (insert-node (hash-map-root m) (make-key-hash k ((hash-map-hash m) k)) v (hash-map-key<? m))))
- (construct-hash-map
- (hash-map-raw-hash m)
- (hash-map-key<? 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 (lookup m k)
- (letrec ((k* (make-key-hash k ((hash-map-hash m) k)))
- (lookup
- (lambda (n)
- (cond ((null? n) (raise (make-key-not-found-error)))
- ((key-hash<? k* (node-key n) (hash-map-key<? m)) (lookup (node-left n)))
- ((key-hash=? k* (node-key n)) (node-value n))
- (else (lookup (node-right n)))))))
- (lookup (hash-map-root m))))
-
-
- (define (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 (hash-map-root m))))
-
-
- (define (map->alist m)
- (let ((alist '()))
- (for-each
- (lambda (k v)
- (set! alist (cons (cons k v) alist)))
- m)
- alist))
-
-
- (define (alist->map hash key<? alist)
- (let loop ((alist alist)
- (m (make-map hash key<?)))
- (if (null? alist)
- m
- (loop (cdr alist) (insert m (caar alist) (cdar alist))))))
-
-
- (define (hash-bytevector b)
- (let loop ((i 0)
- (hash 0))
- (if (>= i (bytevector-length b))
- hash
- (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i))))))))
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 14:27:22 +0000