diff options
Diffstat (limited to 'hash-map.csc')
| -rw-r--r-- | hash-map.csc | 251 |
1 files changed, 251 insertions, 0 deletions
diff --git a/hash-map.csc b/hash-map.csc new file mode 100644 index 0000000..2c95b36 --- /dev/null +++ b/hash-map.csc @@ -0,0 +1,251 @@ +(define-library (csc hash-map) + (export + alist->hash-map + hash-bytevector + hash-map->alist + hash-map-foreach + hash-map-insert + hash-map-lookup + hash-map? + make-hash-map) + (import (scheme base) + (only (csc format) sprintf)) + (begin + + + (define-record-type <key-hash> + (make-key-hash hash k) + key-hash? + (hash key-hash-hash) + (k key-hash-value)) + + + (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 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-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-right m) k v key<?)))))) + + + (define-record-type <hash-map> + (construct-hash-map hash key<? root) + hash-map? + (hash hash-map-hash) + (key<? hash-map-key<?) + (root hash-map-root)) + + + (define (make-hash-map hash key<?) + (construct-hash-map hash key<? '())) + + + (define (hash-map-insert m k v) + (let* ((shuffle + (lambda (hash) + (truncate-remainder + (* #x9e3779b97f4a7c55 hash) + #x10000000000000000))) + (res (insert (hash-map-root m) (make-key-hash (shuffle ((hash-map-hash m) k)) k) v (hash-map-key<? m)))) + (construct-hash-map + (hash-map-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 (hash-map-lookup m k) + (letrec ((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 (hash-map-foreach 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 (hash-map->alist m) + (let ((alist '())) + (hash-map-foreach + (lambda (k v) + (set! alist (cons (cons k v) alist))) + m) + alist)) + + + (define (alist->hash-map hash key<? alist) + (let loop ((alist alist) + (m (make-hash-map hash key<?))) + (if (null? alist) + m + (loop (cdr alist) (hash-map-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)))))))) |