Ported RedBlack-Tree based on our new match. Seems to work, though compiled version crashes on memory-out-of-bounds while interpreted works - will have to debug later

rb_tree_test/matching.kp

@@ -165,6 +165,119 @@
                                                                true                     (array true (array error "none matched"))))
               ) (vau de (x & cases) (eval (array let (array '___MATCH_SYM x) (concat (array cond) (helper '___MATCH_SYM cases 0))) de)))
 
+         empty (array 'B  nil nil nil)
+         E     empty
+         EE    (array 'BB nil nil nil)
+
+         size (rec-lambda recurse (t) (match t
+                                             ,E        0
+                                             (c a x b) (+ 1 (recurse a) (recurse b))))
+
+         generic-foldl (rec-lambda recurse (f z t) (match t
+                                                          ,E         z
+                                                          (c a x b)  (recurse f (f (recurse f z a) x) b)))
+
+         generic-contains? (rec-lambda recurse (t cmp v found not-found) (match t
+                                                 ,E                            (not-found)
+                                                 (c a x b) (match (cmp v x) '< (recurse a cmp v found not-found)
+                                                                            '= (found x)
+                                                                            '> (recurse b cmp v found not-found))))
+         blacken (lambda (t) (match t
+                                 ('R a x b) (array '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)    (array 'R (array 'B a x b) y (array 'B c z d))
+                                 ('B ('R a x ('R b y c)) z d)    (array 'R (array 'B a x b) y (array 'B c z d))
+                                 ('B a x ('R ('R b y c) z d))    (array 'R (array 'B a x b) y (array 'B c z d))
+                                 ('B a x ('R b y ('R c z d)))    (array 'R (array 'B a x b) y (array 'B c z d))
+                                 ; figure 8, double black cases
+                                 ('BB ('R a x ('R b y c)) z d)   (array 'B (array 'B a x b) y (array 'B c z d))
+                                 ('BB a x ('R ('R b y c) z d))   (array 'B (array 'B a x b) y (array 'B c z d))
+                                 ; already balenced
+                                 t                               t))
+         generic-insert (lambda (t cmp v replace) (let (
+             ins (rec-lambda ins (t) (match t
+                                         ,E                            (array 'R t v t)
+                                         (c a x b) (match (cmp v x) '< (balance (array c (ins a) x b))
+                                                                    '= (if replace (array c a v b)
+                                                                                   t)
+                                                                    '> (balance (array 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 (array 'B (array 'R (array 'B a x b) y c) z d))
+           ('R ('B a x b) y ('BB c z d))          (balance (array 'B a x (array 'R b y (array 'B c z d))))
+           ; case 2, figure 7
+           ('B ('BB a x b) y ('B c z d))          (balance (array 'BB (array 'R (array 'B a x b) y c) z d))
+           ('B ('B a x b) y ('BB c z d))          (balance (array 'BB a x (array 'R b y (array 'B c z d))))
+           ; case 3, figure 9
+           ('B ('BB a w b) x ('R ('B c y d) z e)) (array 'B (balance (array 'B (array 'R (array 'B a w b) x c) y d)) z e)
+           ('B ('R a w ('B b x c)) y ('BB d z e)) (array 'B a w (balance (array 'B b x (array 'R c y (array '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))) (array '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)                            (array x E)
+                         ('B ,E x ,E)                            (array x EE)
+                         ('B ,E x ('R a y b))                    (array x (array 'B a y b))
+                         (c a x b)   (let ((v ap) (recurse a))   (array v (rotate (array c ap x b))))))
+
+         generic-delete (lambda (t cmp v) (let (
+             del (rec-lambda del (t v) (match t
+                                         ; figure 3
+                                         ,E                                          t
+                                         ; figure 4
+                                         ('R ,E x ,E)            (match (cmp v x) '= E
+                                                                                  _  t)
+                                         ('B ('R a x b) y ,E)    (match (cmp v y) '< (rotate (array 'B (del (array 'R a x b) v) y E))
+                                                                                  '= (array 'B a x b)
+                                                                                  '> t)
+                                         ; figure 5
+                                         ('B ,E x ,E)            (match (cmp v x) '= EE
+                                                                                  _  t)
+                                         (c a x b)               (match (cmp v x) '< (rotate (array c (del a v) x b))
+                                                                                  '= (let ((array vp bp) (min_delete b))
+                                                                                     (rotate (array c a vp bp)))
+                                                                                  '> (rotate (array c a x (del b v))))))
+         ) (del (redden t) v)))
+
+         set-cmp (lambda (a b) (cond (< a b) '<
+                                     (= a b) '=
+                                     true    '>))
+         set-empty            empty
+         set-foldl            generic-foldl
+         set-insert           (lambda (t x)   (generic-insert     t set-cmp x false))
+         set-contains?        (lambda (t x)   (generic-contains?  t set-cmp x       (lambda (f) true)      (lambda () false)))
+         set-remove           (lambda (t x)   (generic-delete     t set-cmp x))
+
+         map-cmp (lambda (a b) (let (ak (idx a 0)
+                                     bk (idx b 0))
+                                     (cond (< ak bk) '<
+                                           (= ak bk) '=
+                                           true      '>)))
+         map-empty            empty
+         map-insert           (lambda (t k v) (generic-insert     t map-cmp (array k v) true))
+         map-contains-key?    (lambda (t k)   (generic-contains?  t map-cmp (array k nil) (lambda (f) true)      (lambda () false)))
+         map-get              (lambda (t k)   (generic-contains?  t map-cmp (array k nil) (lambda (f) (idx f 1)) (lambda () (error (str "didn't find key " k " in map " t)))))
+         map-get-or-default   (lambda (t k d) (generic-contains?  t map-cmp (array k nil) (lambda (f) (idx f 1)) (lambda () d)))
+         map-get-with-default (lambda (t k d) (generic-contains?  t map-cmp (array k nil) (lambda (f) (idx f 1)) (lambda () (d))))
+         map-remove           (lambda (t k)   (generic-delete     t map-cmp (array k nil)))
+
+         ; This could be 2x as efficent by being implmented on generic instead of map,
+         ; as we wouldn't have to traverse once to find and once to insert
+         multimap-empty            map-empty
+         multimap-insert           (lambda (t k v) (map-insert t k (set-insert (map-get-or-default t k set-empty) v)))
+         multimap-get              (lambda (t k)   (map-get-or-default t k set-empty))
+
+
 
          match_result1 (match 1 
                     2 true
@@ -174,15 +287,67 @@
 
          monad  (array 'write  1 (str "enter number to fact: " match_result1 " ") (vau (written code)
                       (array 'read 0 60 (vau (data code)
-                            (array 'exit (match (read-string data)
+
-                                                1 "one"
+        (let (
-                                                'jkl "it's jkl"
+            first set-empty
-                                                ,match_result1 383838
+           ;_ (log first " set-contains? " 1 " ? " (set-contains? first 1) " size " (size first))
-                                                (1 b) (+ 1337 b)
+           ;second (set-insert first 1)
-                                                (,match_result1 b) (+ 2337 b)
+           ;_ (log second " set-contains? " 1 " ? " (set-contains? second 1) " size " (size second))
-                                                (a b) (+ a b)
+           ;third (set-insert second 2)
-                                                a (+ a 13)
+           ;_ (log third " set-contains? " 1 " ? " (set-contains? third 1) " size " (size third))
-                                         ))
+           ;_ (log third " set-contains? " 2 " ? " (set-contains? third 2) " size " (size third))
+           ;fourth (set-insert third 3)
+           ;_ (log fourth " set-contains? " 1 " ? " (set-contains? fourth 1) " size " (size fourth))
+           ;_ (log fourth " set-contains? " 2 " ? " (set-contains? fourth 2) " size " (size fourth))
+           ;_ (log fourth " set-contains? " 3 " ? " (set-contains? fourth 3) " size " (size fourth))
+           ;_ (log fourth " set-contains? " 4 " ? " (set-contains? fourth 4) " size " (size fourth))
+           ;_ (log fourth " foldl with + " (set-foldl + 0 fourth))
+           ;fifth (set-remove fourth 1)
+           ;_ (log fifth " set-contains? " 1 " ? " (set-contains? fifth 1) " size " (size fifth))
+           ;_ (log fifth " set-contains? " 2 " ? " (set-contains? fifth 2) " size " (size fifth))
+           ;_ (log fifth " set-contains? " 3 " ? " (set-contains? fifth 3) " size " (size fifth))
+           ;_ (log fifth " set-contains? " 4 " ? " (set-contains? fifth 4) " size " (size fifth))
+           ;sixth (set-remove fifth 3)
+           ;_ (log sixth " set-contains? " 1 " ? " (set-contains? sixth 1) " size " (size sixth))
+           ;_ (log sixth " set-contains? " 2 " ? " (set-contains? sixth 2) " size " (size sixth))
+           ;_ (log sixth " set-contains? " 3 " ? " (set-contains? sixth 3) " size " (size sixth))
+           ;_ (log sixth " set-contains? " 4 " ? " (set-contains? sixth 4) " size " (size sixth))
+           ;seventh (set-remove sixth 2)
+           ;_ (log seventh " set-contains? " 1 " ? " (set-contains? seventh 1) " size " (size seventh))
+           ;_ (log seventh " set-contains? " 2 " ? " (set-contains? seventh 2) " size " (size seventh))
+           ;_ (log seventh " set-contains? " 3 " ? " (set-contains? seventh 3) " size " (size seventh))
+           ;_ (log seventh " set-contains? " 4 " ? " (set-contains? seventh 4) " size " (size seventh))
+
+           ;first map-empty
+           ;_ (log first " map-contains-key? " 1 " ? " (map-contains-key? first 1) " size " (size first))
+           ;second (map-insert first 1 "hello")
+           ;_ (log second " map-contains-key? " 1 " ? " (map-contains-key? second 1) " size " (size second))
+           ;_ (log second " map-get " 1 " ? " (map-get second 1) " size " (size second))
+           ;third (map-insert second 1 "goodbye")
+           ;_ (log third " map-contains-key? " 1 " ? " (map-contains-key? third 1) " size " (size third))
+           ;_ (log third " map-get " 1 " ? " (map-get third 1) " size " (size third))
+           ;fourth (map-insert third 2 "hmmm")
+           ;_ (log fourth " map-contains-key? " 2 " ? " (map-contains-key? fourth 2) " size " (size fourth))
+           ;_ (log fourth " map-get " 2 " ? " (map-get fourth 2) " size " (size fourth))
+           ;_ (log fourth " map-contains-key? " 1 " ? " (map-contains-key? fourth 1) " size " (size fourth))
+           ;_ (log fourth " map-get " 1 " ? " (map-get fourth 1) " size " (size fourth))
+           ;_ (log fourth " map-contains-key? " 3 " ? " (map-contains-key? fourth 3) " size " (size fourth))
+           ;_ (log fourth " map-get-or-default " 3 " 'hi ? " (map-get-or-default fourth 3 'hi) " size " (size fourth))
+           ;_ (log fourth " map-get-with-default " 3 " (lambda () 'bye) ? " (map-get-with-default fourth 3 (lambda () 'bye)) " size " (size fourth))
+           ;fifth (map-remove fourth 2)
+           ;_ (log fifth " map-contains-key? " 2 " ? " (map-contains-key? fifth 2) " size " (size fifth))
+        ) (array 'exit (map-contains-key? first (read-string data))))
+
+
+                           ;(array 'exit (match (read-string data)
+                           ;                    1 "one"
+                           ;                    'jkl "it's jkl"
+                           ;                    ,match_result1 383838
+                           ;                    (1 b) (+ 1337 b)
+                           ;                    (,match_result1 b) (+ 2337 b)
+                           ;                    (a b) (+ a b)
+                           ;                    a (+ a 13)
+                           ;             ))
                       ))
 
                 ))