From dc712060cda4e9b905fbcda36d17bf0cf2f91059 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Mon, 2 Aug 2021 20:34:01 -0400 Subject: [PATCH] generalize RB-Tree and make wrapper functions to use as a set or map --- rb.kp | 70 ++++++++++++++++++++++++++++++++++++--------------- rb_test.kp | 73 ++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 96 insertions(+), 47 deletions(-) diff --git a/rb.kp b/rb.kp index d8c6690..04e670c 100644 --- a/rb.kp +++ b/rb.kp @@ -5,6 +5,9 @@ ; and the figure references refer to it ; Insert is taken from the same paper, but is origional to Okasaki, I belive + ; The tree has been modified slightly to take in a comparison function + ; and override if insert replaces or not to allow use as a set or as a map + ; 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 @@ -13,11 +16,11 @@ E empty EE ['BB nil nil nil] - contains? (rec-lambda recurse (t v) (match t - ~E false - [c a x b] (cond (< v x) (recurse a v) - (= v x) true - true (recurse b v)))) + 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] ['B a x b] @@ -33,12 +36,13 @@ ['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 ( + generic-insert (lambda (t cmp v replace) (let ( ins (rec-lambda ins (t) (match t - ~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)])))) + ~E ['R t v t] + [c a x b] (match (cmp v x) '< (balance [c (ins a) x b]) + '= (if replace [c a v b] + t) + '> (balance [c a x (ins b)])))) ) (blacken (ins t)))) rotate (lambda (t) (match t @@ -65,20 +69,46 @@ ['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 ( + generic-delete (lambda (t cmp v) (let ( del (rec-lambda del (t v) (match t ; figure 3 - ~E t + ~E t ; figure 4 - ['R ~E ~v ~E] E - ['B ['R a x b] ~v ~E] ['B a x b] + ['R ~E x ~E] (match (cmp v x) '= E + _ t) + ['B ['R a x b] y ~E] (match (cmp v y) '< (rotate ['B (del ['R a x b] v) y ~E]) + '= ['B a x b] + '> t) ; 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)])))) + ['B ~E x ~E] (match (cmp v x) '= EE + _ t) + [c a x b] (match (cmp v x) '< (rotate [c (del a v) x b]) + '= (let ((vp bp) (min_delete b)) + (rotate [c a vp bp])) + '> (rotate [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-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 [k v] true)) + map-contains-key? (lambda (t k) (generic-contains? t map-cmp [k nil] (lambda (f) true) (lambda () false))) + map-get (lambda (t k) (generic-contains? t map-cmp [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 [k nil] (lambda (f) (idx f 1)) (lambda () d))) + map-get-with-default (lambda (t k d) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () (d)))) + map-remove (lambda (t k) (generic-delete t map-cmp [k nil])) ) - (provide empty contains? insert delete) + (provide set-empty set-insert set-contains? set-remove + map-empty map-insert map-contains-key? map-get map-get-or-default map-get-with-default map-remove) )) diff --git a/rb_test.kp b/rb_test.kp index eaef666..4ccf32a 100644 --- a/rb_test.kp +++ b/rb_test.kp @@ -1,30 +1,49 @@ (with_import "./rb.kp" (let ( - first empty - _ (println first " contains? " 1 " ? " (contains? first 1)) - second (insert first 1) - _ (println second " contains? " 1 " ? " (contains? second 1)) - third (insert second 2) - _ (println third " contains? " 1 " ? " (contains? third 1)) - _ (println third " contains? " 2 " ? " (contains? third 2)) - fourth (insert third 3) - _ (println fourth " contains? " 1 " ? " (contains? fourth 1)) - _ (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)) + first set-empty + _ (println first " set-contains? " 1 " ? " (set-contains? first 1)) + second (set-insert first 1) + _ (println second " set-contains? " 1 " ? " (set-contains? second 1)) + third (set-insert second 2) + _ (println third " set-contains? " 1 " ? " (set-contains? third 1)) + _ (println third " set-contains? " 2 " ? " (set-contains? third 2)) + fourth (set-insert third 3) + _ (println fourth " set-contains? " 1 " ? " (set-contains? fourth 1)) + _ (println fourth " set-contains? " 2 " ? " (set-contains? fourth 2)) + _ (println fourth " set-contains? " 3 " ? " (set-contains? fourth 3)) + _ (println fourth " set-contains? " 4 " ? " (set-contains? fourth 4)) + fifth (set-remove fourth 1) + _ (println fifth " set-contains? " 1 " ? " (set-contains? fifth 1)) + _ (println fifth " set-contains? " 2 " ? " (set-contains? fifth 2)) + _ (println fifth " set-contains? " 3 " ? " (set-contains? fifth 3)) + _ (println fifth " set-contains? " 4 " ? " (set-contains? fifth 4)) + sixth (set-remove fifth 3) + _ (println sixth " set-contains? " 1 " ? " (set-contains? sixth 1)) + _ (println sixth " set-contains? " 2 " ? " (set-contains? sixth 2)) + _ (println sixth " set-contains? " 3 " ? " (set-contains? sixth 3)) + _ (println sixth " set-contains? " 4 " ? " (set-contains? sixth 4)) + seventh (set-remove sixth 2) + _ (println seventh " set-contains? " 1 " ? " (set-contains? seventh 1)) + _ (println seventh " set-contains? " 2 " ? " (set-contains? seventh 2)) + _ (println seventh " set-contains? " 3 " ? " (set-contains? seventh 3)) + _ (println seventh " set-contains? " 4 " ? " (set-contains? seventh 4)) + + first map-empty + _ (println first " map-contains-key? " 1 " ? " (map-contains-key? first 1)) + second (map-insert first 1 "hello") + _ (println second " map-contains-key? " 1 " ? " (map-contains-key? second 1)) + _ (println second " map-get " 1 " ? " (map-get second 1)) + third (map-insert second 1 "goodbye") + _ (println third " map-contains-key? " 1 " ? " (map-contains-key? third 1)) + _ (println third " map-get " 1 " ? " (map-get third 1)) + fourth (map-insert third 2 "hmmm") + _ (println fourth " map-contains-key? " 2 " ? " (map-contains-key? fourth 2)) + _ (println fourth " map-get " 2 " ? " (map-get fourth 2)) + _ (println fourth " map-contains-key? " 1 " ? " (map-contains-key? fourth 1)) + _ (println fourth " map-get " 1 " ? " (map-get fourth 1)) + _ (println fourth " map-contains-key? " 3 " ? " (map-contains-key? fourth 3)) + _ (println fourth " map-get-or-default " 3 " 'hi ? " (map-get-or-default fourth 3 'hi)) + _ (println fourth " map-get-with-default " 3 " (lambda () 'bye) ? " (map-get-with-default fourth 3 (lambda () 'bye))) + fifth (map-remove fourth 2) + _ (println fifth " map-contains-key? " 2 " ? " (map-contains-key? fifth 2)) ) nil))