Export some common comparers from hash-map.

1 files changed, 48 insertions, 9 deletions

diff --git a/csc/hash-map.csc b/csc/hash-map.csc
index 5a604ad..064b4ae 100644
--- a/csc/hash-map.csc
+++ b/csc/hash-map.csc
@@ -1,17 +1,24 @@
 (define-library (csc hash-map)
   (export
     alist->map
+    compare-numbers
+    compare-strings
+    compare-symbols
+    delete
     hash-bytevector
     insert
     key-not-found-error?
     lookup
+    make-comparer
     make-map
-    delete
     map->alist
     map-for-each
     map?
     merge)
   (import (scheme base)
+          (only (csc loop)
+            loop
+            return)
           (only (csc match)
             define-match-record-type
             match)
@@ -198,8 +205,15 @@
       (root map-root))
 
 
-    (define (make-map hash cmp)
-      (construct-map hash cmp '()))
+    (define-record-type <comparer>
+      (make-comparer hash cmp)
+      comparer?
+      (hash comparer-hash)
+      (cmp comparer-cmp))
+
+
+    (define (make-map comparer)
+      (construct-map (comparer-hash comparer) (comparer-cmp comparer) '()))
 
 
     (define (shuffle n)
@@ -269,12 +283,11 @@
         alist))
 
 
-    (define (alist->map hash cmp alist)
-      (let loop ((alist alist)
-                 (m (make-map hash cmp)))
-        (if (null? alist)
-            m
-          (loop (cdr alist) (insert m (caar alist) (cdar alist))))))
+    (define (alist->map comparer alist)
+      (loop with m = (make-map comparer)
+            for elem in alist
+            do (set! m (insert m (car elem) (cdr elem)))
+            finally (return m)))
 
 
     (define (hash-bytevector b)
@@ -285,6 +298,32 @@
           (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i))))))
 
 
+    (define compare-symbols
+      (make-comparer
+        (lambda (s) (hash-bytevector (string->utf8 (symbol->string s))))
+        (lambda (s1 s2)
+          (cond
+            ((symbol=? s1 s2) 0)
+            ((string<? (symbol->string s1) (symbol->string s2)) -1)
+            (else 1)))))
+
+
+    (define compare-numbers
+      (make-comparer
+        (lambda (x) x)
+        (lambda (y x) (- y x))))
+
+
+    (define compare-strings
+      (make-comparer
+        (lambda (s) (hash-bytevector (string->utf8 s)))
+        (lambda (s1 s2)
+          (cond
+            ((string=? s1 s2) 0)
+            ((string<? (symbol->string s1) (symbol->string s2)) -1)
+            (else 1)))))
+
+
     (define (merge2 m1 m2)
       (let ((m1 m1))
         (map-for-each