From 68986fe0410584c6934c835bb0ee784655f5f8c5 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Tue, 11 Jan 2022 22:01:23 -0800
Subject: Move scheme compiler into a separate directory.

---
 hash-map.csc | 259 -----------------------------------------------------------
 1 file changed, 259 deletions(-)
 delete mode 100644 hash-map.csc

(limited to 'hash-map.csc')

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))))))))
-- 
cgit v1.3.1