Extend match to support ~unquote for matching against the *value* of expressions or variables, and use that to implement deletion for the RB-tree set

match.kp

@@ -14,7 +14,10 @@
             ; check for invocation of quote directly
             ; not necessarily ideal if they define their own quote or something
             (and (symbol?     x) (array?      c) (= 2 (len c)) (= quote (idx c 0)) (= x (idx c 1))) name_dict
-            ; ditto with above, but with array
+            ; ditto with above, but with unquote to allow matching against the *value* of variables
+            (and (array?      c) (= 2 (len c)) (= 'unquote (idx c 0)) (= x (eval (idx c 1) de)))    name_dict
+            ; ditto with above, but with array. Also note this means you have to use '[' and ']' as calling
+            ; array explicitly will give you the symbol array instead...
             (and (array?      x) (array?      c) (= (+ 1 (len x)) (len c)) (= array (idx c 0)))     (foldl recurse name_dict x (slice c 1 -1))
             true                                                                                    nil
         ))

match_test.kp

@@ -38,4 +38,12 @@
                [ 1337 "str" 'walla + a false b [ 'inner c 'end ] d ] (str "matched, and got " a b c d)
                     a (+ a 1)
         ))
+    (println "seventh "
+        (let (b 2)
+        (match [ 1337 [ 1 2 3] 11 ]
+                    1                       true
+                    "str"                   "It was a string!"
+                    [ 1337 [ a ~b c] 11 ]   (str "matched, and got " a c " while checking based on inserted " b)
+                    a                       "sigh, failed to match"
+        )))
 ))

rb.kp

@@ -1,12 +1,20 @@
 
 (with_import "./match.kp"
 (let (
-    ; ['R ..] or ['B ..] or ['BB]
+    ; This is based on https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf
-    ; possibly temporarily ['BB ..] during rebalencing
+    ; and the figure references refer to it
-    empty ['B]
+    ; Insert is taken from the same paper, but is origional to Okasaki, I belive
+
+    ; I think this is actually pretty cool - instead of having a bunch of seperate ['B]
+    ; be our leaf node, we use ['B] with all nils. This allows us to not use -B, as
+    ; both leaf and non-leaf 'BB has the same structure with children! Also, we make
+    ; sure to use empty itself so we don't make a ton of empties...
+    empty ['B nil nil nil]
+    E  empty
+    EE ['BB nil nil nil]
 
     contains? (rec-lambda recurse (t v) (match t
-                                            ['B]        false
+                                            ~E                        false
                                             [c a x b]   (cond (< v x) (recurse a v)
                                                               (= v x) true
                                                               true    (recurse b v))))
@@ -15,18 +23,62 @@
                             ['R a x b] ['B a x b]
                             t          t))
     balance (lambda (t) (match t
+                            ; figures 1 and 2
                             ['B ['R ['R a x b] y c] z d] ['R ['B a x b] y ['B c z d]]
                             ['B ['R a x ['R b y c]] z d] ['R ['B a x b] y ['B c z d]]
                             ['B a x ['R ['R b y c] z d]] ['R ['B a x b] y ['B c z d]]
                             ['B a x ['R b y ['R c z d]]] ['R ['B a x b] y ['B c z d]]
+                            ; figure 8, double black cases
+                            ['BB ['R a x ['R b y c]] z d] ['B ['B a x b] y ['B c z d]]
+                            ['BB a x ['R ['R b y c] z d]] ['B ['B a x b] y ['B c z d]]
+                            ; already balenced
                             t                            t))
     insert (lambda (t v) (let (
         ins (rec-lambda ins (t) (match t
-                                    ['B]        ['R ['B] v ['B]]
+                                    ~E                        ['R t v t]
                                     [c a x b]   (cond (< v x) (balance [c (ins a) x b])
                                                       (= v x) [c a x b]
                                                       true    (balance [c a x (ins b)]))))
     ) (blacken (ins t))))
+
+    rotate (lambda (t) (match t
+      ; case 1, fig 6
+      ['R ['BB a x b] y ['B c z d]]          (balance ['B ['R ['B a x b] y c] z d])
+      ['R ['B a x b] y ['BB c z d]]          (balance ['B a x ['R b y ['B c z d]]])
+      ; case 2, figure 7
+      ['B ['BB a x b] y ['B c z d]]          (balance ['BB ['R ['B a x b] y c] z d])
+      ['B ['B a x b] y ['BB c z d]]          (balance ['BB a x ['R b y ['B c z d]]])
+      ; case 3, figure 9
+      ['B ['BB a w b] x ['R ['B c y d] z e]] ['B (balance ['B ['R ['B a w b] x c] y d]) z e]
+      ['B ['R a w ['B b x c]] y ['BB d z e]] ['B a w (balance ['B b x ['R c y ['B d z e]]])]
+      ; fall through
+      t                                     t))
+
+    redden (lambda (t) (match t
+                        ['B a x b] (if (and (= 'B (idx a 0)) (= 'B (idx b 0))) ['R a x b]
+                                                                               t)
+                        t                                                      t))
+
+    min_delete (rec-lambda recurse (t) (match t
+                    ~E                                      (error "min_delete empty tree")
+                    ['R ~E x ~E]                            [x E]
+                    ['B ~E x ~E]                            [x EE]
+                    ['B ~E x ['R a y b]]                    [x ['B a y b]]
+                    [c a x b]   (let ((v ap) (recurse a))   [v (rotate [c ap x b])])))
+    delete (lambda (t v) (let (
+        del (rec-lambda del (t v) (match t
+                                    ; figure 3
+                                    ~E                      t
+                                    ; figure 4
+                                    ['R ~E ~v ~E]           E
+                                    ['B ['R a x b] ~v ~E]   ['B a x b]
+                                    ; figure 5
+                                    ['B ~E ~v ~E]           EE
+                                    [c a x b] (cond (< v x) (rotate [c (del a v) x b])
+                                                    (= v x) (let ((vp bp) (min_delete b))
+                                                            (rotate [c a vp bp]))
+                                                    true    (rotate [c a x (del b v)]))))
+    ) (del (redden t) v)))
 )
-    (provide empty contains? insert)
+    (provide empty contains? insert delete)
 ))

rb_test.kp

@@ -12,4 +12,19 @@
     _ (println fourth " contains? " 2 " ? " (contains? fourth 2))
     _ (println fourth " contains? " 3 " ? " (contains? fourth 3))
     _ (println fourth " contains? " 4 " ? " (contains? fourth 4))
+    fifth (delete fourth 1)
+    _ (println fifth " contains? " 1 " ? " (contains? fifth 1))
+    _ (println fifth " contains? " 2 " ? " (contains? fifth 2))
+    _ (println fifth " contains? " 3 " ? " (contains? fifth 3))
+    _ (println fifth " contains? " 4 " ? " (contains? fifth 4))
+    sixth (delete fifth 3)
+    _ (println sixth " contains? " 1 " ? " (contains? sixth 1))
+    _ (println sixth " contains? " 2 " ? " (contains? sixth 2))
+    _ (println sixth " contains? " 3 " ? " (contains? sixth 3))
+    _ (println sixth " contains? " 4 " ? " (contains? sixth 4))
+    seventh (delete sixth 2)
+    _ (println seventh " contains? " 1 " ? " (contains? seventh 1))
+    _ (println seventh " contains? " 2 " ? " (contains? seventh 2))
+    _ (println seventh " contains? " 3 " ? " (contains? seventh 3))
+    _ (println seventh " contains? " 4 " ? " (contains? seventh 4))
 ) nil))