(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))))))))