generalize RB-Tree and make wrapper functions to use as a set or map
This commit is contained in:
Nathan Braswell
64
rb.kp
64
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)]))))
|
||||
[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
|
||||
; 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))
|
||||
['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]))
|
||||
true (rotate [c a x (del b v)]))))
|
||||
'> (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)
|
||||
))
|
||||
|
||||
73
rb_test.kp
73
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))
|
||||
|
||||
Reference in New Issue
Block a user