From 56df584eed3a7228ca06a9ed1e49272410a7e671 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sat, 23 Jul 2022 11:06:55 -0700
Subject: Add a delete method to the red-black tree.

God damn delete is even more complicated than insert. I think it works,
at least.
---
 csc/cps.csc           |   3 +-
 csc/hash-map-test.csc | 129 +++++++++++++++++-----
 csc/hash-map.csc      | 291 ++++++++++++++++++++++++++++++++++++++++----------
 csc/linker.csc        |   9 +-
 csc/macros.csc        |  23 +++-
 5 files changed, 361 insertions(+), 94 deletions(-)

(limited to 'csc')

diff --git a/csc/cps.csc b/csc/cps.csc
index 230a1c4..e7f0fe6 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -320,8 +320,7 @@
         (lambda (ref)
           (gensym->int (lexical-ref-gensym ref)))
         (lambda (x y)
-          (< (gensym->int (lexical-ref-gensym x))
-                         (gensym->int (lexical-ref-gensym y))))))
+          (- (gensym->int (lexical-ref-gensym y)) (gensym->int (lexical-ref-gensym x))))))
 
 
     (define (get-boxed expr)
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))
diff --git a/csc/hash-map.csc b/csc/hash-map.csc
index a8579fb..5a604ad 100644
--- a/csc/hash-map.csc
+++ b/csc/hash-map.csc
@@ -1,18 +1,22 @@
 (define-library (csc hash-map)
   (export
     alist->map
-    map-for-each
     hash-bytevector
     insert
     key-not-found-error?
     lookup
     make-map
+    delete
     map->alist
+    map-for-each
     map?
     merge)
   (import (scheme base)
-          (only (csc format) sprintf)
-          (only (csc match) match))
+          (only (csc match)
+            define-match-record-type
+            match)
+          (only (scheme case-lambda)
+            case-lambda))
   (begin
 
 
@@ -23,29 +27,17 @@
       (hash key-hash-hash))
 
 
-    (define (key-hash<? k1 k2 cmp)
-      (define h1 (key-hash-hash k1))
-      (define h2 (key-hash-hash k2))
-      (cond
-        ((< h1 h2)
-          #t)
-        ((> h1 h2)
-          #f)
-        (else
-          (cmp (key-hash-value k1) (key-hash-value k2)))))
-
-
-    (define (key-hash=? k1 k2 cmp)
-      (define v1 (key-hash-value k1))
-      (define v2 (key-hash-value k2))
-      (and (= (key-hash-hash k1) (key-hash-hash k2))
-           (not (cmp v1 v2))
-           (not (cmp v2 v1))))
+    (define (cmp-key-hash k1 k2 cmp)
+      (define d (- (key-hash-hash k2) (key-hash-hash k1)))
+      (if (zero? d)
+        (cmp (key-hash-value k1) (key-hash-value k2))
+        d))
 
 
-    (define-record-type <node>
+    (define-match-record-type <node>
       (make-node color key-hash val left right)
       node?
+      %node
       (color node-color)
       (key-hash node-key)
       (val node-value)
@@ -63,6 +55,21 @@
           (eq? 'black (node-color n))))
 
 
+    (define (node-kv n)
+      (cons (node-key n) (node-value n)))
+
+
+    (define (node-colored color kv left right)
+      (make-node color (car kv) (cdr kv) left right))
+
+
+    (define (red-node kv left right)
+      (node-colored 'red kv left right))
+
+    (define (black-node kv left right)
+      (node-colored 'black kv left right))
+
+
     (define (rebalance-left m)
       (define p (node-left m))
       (define u (node-right m))
@@ -84,9 +91,9 @@
           ; 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))))
+          (red-node (node-kv m)
+            (black-node (node-kv p) (node-left p) (node-right p))
+            (black-node (node-kv u) (node-left u) (node-right u))))
         ((and (red? p)
               (red? (node-right p))
               (black? u))
@@ -163,19 +170,24 @@
         (else m)))
 
 
-    (define (insert-node m k v cmp)
-      (cond ((null? m) (make-node 'red k v '() '()))
-            ((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 cmp)
-                          (node-right m))))
-            ((key-hash=? k (node-key m) cmp) (make-node (node-color m) k v (node-left m) (node-right m)))
+    (define (insert-node n k v cmp)
+      (match n
+        ('() (make-node 'red k v '() '()))
+        ((% %node color node-key node-val left right)
+          (define ord (cmp-key-hash k node-key cmp))
+          (cond
+            ((negative? ord)
+              (rebalance-left
+                (make-node color node-key node-val
+                  (insert-node left k v cmp)
+                  right)))
+            ((zero? ord)
+              (make-node color k v left right))
             (else
               (rebalance-right
-                (make-node (node-color m) (node-key m) (node-value m)
-                           (node-left m)
-                           (insert-node (node-right m) k v cmp))))))
+                (make-node color node-key node-val
+                  left
+                  (insert-node right k v cmp))))))))
 
 
     (define-record-type <map>
@@ -202,11 +214,11 @@
 
 
     (define (insert m k v)
-      (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)))))
+      (define 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))))
 
 
     (define-record-type <key-not-found-error>
@@ -214,25 +226,38 @@
       key-not-found-error?)
 
 
-    (define (lookup 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) (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 (map-root m))))
+    (define *key-not-found-error* (make-key-not-found-error))
+
+
+    (define lookup
+      (case-lambda
+        ((m k)
+          (define cmp (map-cmp m))
+          (define k* (make-key-hash k ((map-hash m) k)))
+          (let loop ((n (map-root m)))
+            (match n
+              ('() (raise *key-not-found-error*))
+              ((% %node _ node-key node-val left right)
+                (define ord (cmp-key-hash k* node-key cmp))
+                (cond
+                  ((negative? ord)
+                    (loop left))
+                  ((zero? ord)
+                    node-val)
+                  (else
+                    (loop right)))))))
+        ((m k def)
+          (guard (e ((key-not-found-error? e) def))
+            (lookup m k)))))
 
 
     (define (map-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 (map-root m))))
+      (let loop ((n (map-root m)))
+        (match n
+          ((% %node _ node-key node-val left right)
+            (loop left)
+            (f (key-hash-value node-key) node-val)
+            (loop right)))))
 
 
     (define (map->alist m)
@@ -274,4 +299,154 @@
                  (m m))
         (match m*
           ('() m)
-          ((head . tail) (loop tail (merge2 m head))))))))
+          ((head . tail) (loop tail (merge2 m head))))))
+
+
+    ; Jinkies!
+    (define (delete m k)
+      (define cmp (map-cmp m))
+      (define k* (make-key-hash k ((map-hash m) k)))
+      ; local variables
+      (define need-fix #f)
+      (define replacement-node #f)
+
+      (define (fix-black-height-left p)
+        ; n.b.: s must not be nil, because we deleted a black node and so
+        ; there must be at least one node in s to balance out the
+        ; black height.
+        (define s (node-right p))
+        (define n (node-left p))
+        (define c (node-left s))
+        (define d (node-right s))
+        (set! need-fix #f)
+        (cond
+          ((red? s)
+            ;   p            s
+            ;  / \          / \
+            ; n   s   =>   p   d
+            ;    / \      / \
+            ;   c   d    n   c
+            (black-node (node-kv s)
+              (fix-black-height-left
+                (red-node (node-kv p) n c))
+              d))
+          ((red? d)
+            (node-colored (node-color p) (node-kv s)
+              (black-node (node-kv p) n c)
+              (black-node (node-kv d) (node-left d) (node-right d))))
+          ((red? c)
+            (fix-black-height-left
+              (node-colored (node-color p) (node-kv p)
+                n
+                (black-node (node-kv c)
+                  (node-left c)
+                  (red-node (node-kv s)
+                    (node-right c)
+                    d)))))
+          ((red? p)
+            (black-node (node-kv p)
+              n
+              (red-node (node-kv s) c d)))
+          (else
+            (set! need-fix #t) ; This is the only recursive case.
+            (black-node (node-kv p)
+              n
+              (red-node (node-kv s) c d)))))
+      (define (fix-black-height-right p)
+        (define s (node-left p))
+        (define n (node-right p))
+        (define c (node-right s))
+        (define d (node-left s))
+        (set! need-fix #f)
+        (cond
+          ((red? s)
+            (black-node (node-kv s)
+              d
+              (fix-black-height-right
+                (red-node (node-kv p) c n))))
+          ((red? d)
+            (node-colored (node-color p) (node-kv s)
+              (black-node (node-kv d) (node-left d) (node-right d))
+              (black-node (node-kv p) c n)))
+          ((red? c)
+            ;      p           p
+            ;     / \         / \
+            ;    s   n  =>   c   n
+            ;   / \         /
+            ;  d   c       s
+            ;             /
+            ;            d
+            (fix-black-height-right
+              (node-colored (node-color p) (node-kv p)
+                (black-node (node-kv c)
+                  (red-node (node-kv s)
+                    d
+                    (node-left c))
+                  (node-right c))
+                n)))
+          ((red? p)
+            (black-node (node-kv p)
+              (red-node (node-kv s) d c)
+              n))
+          (else
+            (set! need-fix #t)
+            (black-node (node-kv p)
+              (red-node (node-kv s) d c)
+              n))))
+      (construct-map (map-raw-hash m) cmp
+        (let loop ((n (map-root m)))
+          (match n
+            ('() '())
+            ((% %node color nk nv left right)
+              (define ord (cmp-key-hash k* nk cmp))
+              (cond
+                ((negative? ord)
+                  (let* ((left* (loop left))
+                         (n* (make-node color nk nv left* right)))
+                    (if need-fix
+                      (fix-black-height-left n*)
+                      n*)))
+                ((positive? ord)
+                  (let* ((right* (loop right))
+                         (n* (make-node color nk nv left right*)))
+                    (if need-fix
+                      (fix-black-height-right n*)
+                      n*)))
+                ((and (not (null? left))
+                      (not (null? right)))
+                  (let* ((left* (let find-max ((r left))
+                                  (match r
+                                    ((% %node _ _ _ r-left '())
+                                      (set! replacement-node r)
+                                      (cond
+                                        ((red? r) '())
+                                        ((null? r-left)
+                                          (set! need-fix #t)
+                                          '())
+                                        (else
+                                          (black-node (node-kv r-left)
+                                            (node-left r-left)
+                                            (node-right r-left)))))
+                                    ((% %node r-color r-k r-v r-left r-right)
+                                      (define n* (make-node r-color r-k r-v
+                                                   r-left
+                                                   (find-max r-right)))
+                                      (if need-fix
+                                        (fix-black-height-right n*)
+                                        n*)))))
+                         (n* (node-colored color (node-kv replacement-node) left* right)))
+                    (if need-fix
+                      (fix-black-height-left n*)
+                      n*)))
+                ((red? n) '())
+                ((and (null? left)
+                      (null? right))
+                  (set! need-fix #t)
+                  '())
+                (else
+                  (let ((child (if (null? left)
+                                 right
+                                 left)))
+                    (black-node (node-kv child)
+                      (node-left child)
+                      (node-right child))))))))))))
diff --git a/csc/linker.csc b/csc/linker.csc
index 852ee13..3327909 100644
--- a/csc/linker.csc
+++ b/csc/linker.csc
@@ -41,8 +41,15 @@
       (hash-bytevector (string->utf8 s)))
 
 
+    (define (cmp-strings s1 s2)
+      (cond
+        ((string=? s1 s2) 0)
+        ((string<? s1 s2) -1)
+        (else 1)))
+
+
     (define (make-label-map program)
-      (let loop ((m (make-map hash-string string<?))
+      (let loop ((m (make-map hash-string cmp-strings))
                  (program program)
                  (i 0))
         (match program
diff --git a/csc/macros.csc b/csc/macros.csc
index 41225ae..1edecd2 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -365,7 +365,7 @@
 
 
     (define (identifier-uuid i)
-      ; Join marks by ( because symbols aren't allowed to have ( in the name.
+      ; Join marks by ( because symbols are unlikely to have ( in the name.
       (sprintf "{}({}" (apply join "(" (map number->string (marks i))) (identifier-name i)))
 
 
@@ -373,12 +373,27 @@
       (hash-bytevector (string->utf8 (identifier-uuid i))))
 
 
-    (define (identifier<? i1 i2)
-      (string<? (identifier-uuid i1) (identifier-uuid i2)))
+    (define (marks<? m1 m2)
+      (loop for m1* in m1
+            for m2* in m2
+            if (< m1* m2*)
+              return #t
+            else if (> m1* m2*)
+              return #f
+            finally (return (< (length m1) (length m2)))))
+
+
+    (define (cmp-identifiers i1 i2)
+      (cond
+        ((bound-identifier=? i1 i2) 0)
+        ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2)))
+             (marks<? (marks i1) (marks i2)))
+          -1)
+        (else 1)))
 
 
     (define (alist->substitutions l)
-      (alist->map hash-identifier identifier<? l))
+      (alist->map hash-identifier cmp-identifiers l))
 
 
     (define (is-underscore expression)
-- 
cgit v1.3.1