Add a delete method to the red-black tree.

God damn delete is even more complicated than insert. I think it works,
at least.

1 files changed, 100 insertions, 29 deletions

diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc
index 677406e..7885908 100644
--- a/csc/hash-map-test.csc
+++ b/csc/hash-map-test.csc
@@ -1,4 +1,9 @@
 (import (scheme base)
+        (only (csc format)
+          sprintf)
+        (only (csc loop)
+          loop
+          return)
         (only (csc sort) sort)
         (only (csc testing)
               assert-equal
@@ -11,78 +16,144 @@
   (hash-bytevector (string->utf8 (symbol->string s))))
 
 
-(define (symbol<? s1 s2)
-  (string<? (symbol->string s1) (symbol->string s2)))
+(define (cmp-symbols s1 s2)
+  (cond
+    ((symbol=? s1 s2) 0)
+    ((string<? (symbol->string s1) (symbol->string s2)) -1)
+    (else 1)))
 
 
 (define (alist->map->alist l)
-  (map->alist (alist->map hash-symbol symbol<? l)))
-
-
-(define (sort-alist l)
-  (sort (lambda (x1 x2) (symbol<? (car x1) (car x2))) l))
+  (map->alist (alist->map hash-symbol cmp-symbols l)))
 
 
 (test map->alist-singleton
-  (assert-equal (sort-alist '((a . 1))) (sort-alist (alist->map->alist '((a . 1))))))
+  (assert-equal
+    '((a . 1))
+    (alist->map->alist '((a . 1)))))
 
 
 (test map->alist-two
-  (assert-equal (sort-alist '((a . 1) (b . 2))) (sort-alist (alist->map->alist '((a . 1) (b . 2))))))
+  (assert-equal
+    '((a . 1) (b . 2))
+    (alist->map->alist '((a . 1) (b . 2))))
 
 
 (test map->alist-longer
   (assert-equal
-    (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))
-    (sort-alist (alist->map->alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))))))
+    '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))
+    (alist->map->alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))))))
 
 
 (test map->alist-larger
   (assert-equal
-    (sort-alist '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8)))
-    (sort-alist (alist->map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8))))))
+    '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8))
+    (alist->map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8)))))
 
 
 (test map->alist-in-order
   (assert-equal
-    (sort-alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))
-    (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))))))
+    '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))
+    (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))
 
 
 (test map->alist-reversed
   (assert-equal
-    (sort-alist '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ())))
-    (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))))))
+    '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ()))
+    (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))
 
 
 (test map->alist-overwrite
   (assert-equal
-    (sort-alist '((a . 2)))
-    (sort-alist (alist->map->alist '((a . 1) (a . 2))))))
+    '((a . 2))
+    (alist->map->alist '((a . 1) (a . 2)))))
 
 
 (test map->alist-alternating
   (assert-equal
-    (sort-alist '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ())))
-    (sort-alist (alist->map->alist '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ()))))))
+    '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ()))
+    (alist->map->alist '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ())))))
 
 
 (test lookup
   (assert-equal
     2
-    (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'b)))
+    (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'b)))
 
 
 (test lookup-notfound
   (assert-raises key-not-found-error?
-    (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'd)))
+    (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'd)))
+
+
+(test lookup-default
+  (assert-equal
+    #f
+    (lookup (alist->map hash-symbol cmp-symbols '((a . #t) (b . #t))) 'c #f)))
+
+
+(define transform-map
+  (list
+    (cons map? map->alist)))
+
+
+(define (test-map . bindings)
+  (alist->map hash-symbol cmp-symbols bindings))
 
 
 (test merge
   (assert-equal
-    (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4)))
-    (sort-alist
-      (map->alist
-        (merge
-          (alist->map hash-symbol symbol<? '((a . 1) (b . 2)))
-          (alist->map hash-symbol symbol<? '((c . 3) (d . 4))))))))
+    '((a . 1) (b . 2) (c . 3) (d . 4))
+    (merge
+      (test-map '(a . 1) '(b . 2))
+      (test-map '(c . 3) '(d . 4)))
+    transform-map))
+
+
+(test delete
+  (assert-equal
+    '((a . 1) (b . 2) (d . 4))
+    (delete
+      (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4))
+      'c)
+    transform-map))
+
+
+(test delete-only
+  (assert-equal
+    '()
+    (delete
+      (test-map '(a . 1))
+      'a)
+    transform-map))
+
+
+(test delete-first
+  (assert-equal
+    '((b . 2) (c . 3) (d . 4))
+    (delete
+      (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4))
+      'a)
+    transform-map))
+
+
+(test delete-last
+  (assert-equal
+    '((a . 1) (b . 2) (c . 3))
+    (delete
+      (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4))
+      'd)
+    transform-map))
+
+
+(test delete-many
+  (assert-equal
+    '()
+    (loop with m = (loop with m = (test-map)
+                         for i from 1 to 100
+                         do (set! m (insert m (string->symbol (sprintf "key{}" i)) i))
+                         finally (return m))
+          for i from 1 to 100
+          do (set! m (delete m (string->symbol (sprintf "key{}" i))))
+          finally (return m))
+    transform-map))