Generalize the hash map.

Before we were assuming keys could be compared with eqv?. But it seems
like that assumption isn't true when we want to hold identifiers in the
hash map.

1 files changed, 30 insertions, 31 deletions

diff --git a/csc/hash-map.csc b/csc/hash-map.csc
index 01d4158..2862e84 100644
--- a/csc/hash-map.csc
+++ b/csc/hash-map.csc
@@ -21,15 +21,14 @@
       (hash key-hash-hash))
 
 
-    (define (key-hash<? k1 k2 key<?)
+    (define (key-hash<? k1 k2 cmp)
       (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)))
+            (else (< (cmp (key-hash-value k1) (key-hash-value k2)) 0))))
 
 
-    (define (key-hash=? k1 k2)
-      (and (= (key-hash-hash k1) (key-hash-hash k2)) (eqv? (key-hash-value k1) (key-hash-value k2))))
+    (define (key-hash=? k1 k2 cmp)
+      (and (= (key-hash-hash k1) (key-hash-hash k2)) (= 0 (cmp (key-hash-value k1) (key-hash-value k2)))))
 
 
     (define-record-type <node>
@@ -162,31 +161,31 @@
               (else m))))
 
 
-    (define (insert-node m k v key<?)
+    (define (insert-node m k v cmp)
       (cond ((null? m) (make-node 'red k v '() '()))
-            ((key-hash<? k (node-key m) key<?)
+            ((key-hash<? k (node-key m) cmp)
              (rebalance-left
                (make-node (node-color m) (node-key m) (node-value m)
-                          (insert-node (node-left m) k v key<?)
+                          (insert-node (node-left m) k v cmp)
                           (node-right m))))
-            ((key-hash=? k (node-key m)) (make-node (node-color m) k v (node-left m) (node-right m)))
+            ((key-hash=? k (node-key m) cmp) (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<?))))))
+                           (insert-node (node-right m) k v cmp))))))
 
 
-    (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-record-type <map>
+      (construct-map hash cmp root)
+      map?
+      (hash map-raw-hash)
+      (cmp map-cmp)
+      (root map-root))
 
 
-    (define (make-map hash key<?)
-      (construct-hash-map hash key<? '()))
+    (define (make-map hash cmp)
+      (construct-map hash cmp '()))
 
 
     (define (shuffle n)
@@ -195,16 +194,16 @@
         #x10000000000000000))
 
 
-    (define (hash-map-hash m)
+    (define (map-hash m)
       (lambda (k)
-        (shuffle ((hash-map-raw-hash m) k))))
+        (shuffle ((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)
+      (let ((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)))))
 
 
@@ -214,14 +213,14 @@
 
 
     (define (lookup m k)
-      (letrec ((k* (make-key-hash k ((hash-map-hash m) k)))
+      (letrec ((k* (make-key-hash k ((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))
+                         ((key-hash<? k* (node-key n) (map-cmp m)) (lookup (node-left n)))
+                         ((key-hash=? k* (node-key n) (map-cmp m)) (node-value n))
                          (else (lookup (node-right n)))))))
-              (lookup (hash-map-root m))))
+              (lookup (map-root m))))
 
 
     (define (for-each f m)
@@ -231,7 +230,7 @@
                      (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))))
+              (node-foreach (map-root m))))
 
 
     (define (map->alist m)
@@ -243,9 +242,9 @@
         alist))
 
 
-    (define (alist->map hash key<? alist)
+    (define (alist->map hash cmp alist)
       (let loop ((alist alist)
-                 (m (make-map hash key<?)))
+                 (m (make-map hash cmp)))
         (if (null? alist)
             m
           (loop (cdr alist) (insert m (caar alist) (cdar alist))))))