miloignis/kraken
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

generalize RB-Tree and make wrapper functions to use as a set or map

Browse Source
This commit is contained in:
Nathan Braswell
2021-08-02 20:34:01 -04:00
parent e0802baf5e
commit dc712060cd
2 changed files with 96 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

64
rb.kp
View File

@@ -5,6 +5,9 @@
; and the figure references refer to it ; and the figure references refer to it
; Insert is taken from the same paper, but is origional to Okasaki, I belive ; 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] ; 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 ; 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 ; both leaf and non-leaf 'BB has the same structure with children! Also, we make
@@ -13,11 +16,11 @@
E empty E empty
EE ['BB nil nil nil] EE ['BB nil nil nil]
contains? (rec-lambda recurse (t v) (match t generic-contains? (rec-lambda recurse (t cmp v found not-found) (match t
~E false ~E (not-found)
[c a x b] (cond (< v x) (recurse a v) [c a x b] (match (cmp v x) '< (recurse a cmp v found not-found)
(= v x) true '= (found x)
true (recurse b v)))) '> (recurse b cmp v found not-found))))
blacken (lambda (t) (match t blacken (lambda (t) (match t
['R a x b] ['B a x b] ['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]] ['BB a x ['R ['R b y c] z d]] ['B ['B a x b] y ['B c z d]]
; already balenced ; already balenced
t t)) t t))
insert (lambda (t v) (let ( generic-insert (lambda (t cmp v replace) (let (
ins (rec-lambda ins (t) (match t ins (rec-lambda ins (t) (match t
~E ['R t v t] ~E ['R t v t]
[c a x b] (cond (< v x) (balance [c (ins a) x b]) [c a x b] (match (cmp v x) '< (balance [c (ins a) x b])
(= v x) [c a x b] '= (if replace [c a v b]
true (balance [c a x (ins b)])))) t)
'> (balance [c a x (ins b)]))))
) (blacken (ins t)))) ) (blacken (ins t))))
rotate (lambda (t) (match t rotate (lambda (t) (match t
@@ -65,20 +69,46 @@
['B ~E x ~E] [x EE] ['B ~E x ~E] [x EE]
['B ~E x ['R a y b]] [x ['B a y b]] ['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])]))) [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 del (rec-lambda del (t v) (match t
; figure 3 ; figure 3
~E t ~E t
; figure 4 ; figure 4
['R ~E ~v ~E] E ['R ~E x ~E] (match (cmp v x) '= E
['B ['R a x b] ~v ~E] ['B a x b] _ 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 ; figure 5
['B ~E ~v ~E] EE ['B ~E x ~E] (match (cmp v x) '= EE
[c a x b] (cond (< v x) (rotate [c (del a v) x b]) _ t)
(= v x) (let ((vp bp) (min_delete b)) [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 vp bp]))
true (rotate [c a x (del b v)])))) '> (rotate [c a x (del b v)]))))
) (del (redden t) 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
View File

@@ -1,30 +1,49 @@
(with_import "./rb.kp" (with_import "./rb.kp"
(let ( (let (
first empty first set-empty
_ (println first " contains? " 1 " ? " (contains? first 1)) _ (println first " set-contains? " 1 " ? " (set-contains? first 1))
second (insert first 1) second (set-insert first 1)
_ (println second " contains? " 1 " ? " (contains? second 1)) _ (println second " set-contains? " 1 " ? " (set-contains? second 1))
third (insert second 2) third (set-insert second 2)
_ (println third " contains? " 1 " ? " (contains? third 1)) _ (println third " set-contains? " 1 " ? " (set-contains? third 1))
_ (println third " contains? " 2 " ? " (contains? third 2)) _ (println third " set-contains? " 2 " ? " (set-contains? third 2))
fourth (insert third 3) fourth (set-insert third 3)
_ (println fourth " contains? " 1 " ? " (contains? fourth 1)) _ (println fourth " set-contains? " 1 " ? " (set-contains? fourth 1))
_ (println fourth " contains? " 2 " ? " (contains? fourth 2)) _ (println fourth " set-contains? " 2 " ? " (set-contains? fourth 2))
_ (println fourth " contains? " 3 " ? " (contains? fourth 3)) _ (println fourth " set-contains? " 3 " ? " (set-contains? fourth 3))
_ (println fourth " contains? " 4 " ? " (contains? fourth 4)) _ (println fourth " set-contains? " 4 " ? " (set-contains? fourth 4))
fifth (delete fourth 1) fifth (set-remove fourth 1)
_ (println fifth " contains? " 1 " ? " (contains? fifth 1)) _ (println fifth " set-contains? " 1 " ? " (set-contains? fifth 1))
_ (println fifth " contains? " 2 " ? " (contains? fifth 2)) _ (println fifth " set-contains? " 2 " ? " (set-contains? fifth 2))
_ (println fifth " contains? " 3 " ? " (contains? fifth 3)) _ (println fifth " set-contains? " 3 " ? " (set-contains? fifth 3))
_ (println fifth " contains? " 4 " ? " (contains? fifth 4)) _ (println fifth " set-contains? " 4 " ? " (set-contains? fifth 4))
sixth (delete fifth 3) sixth (set-remove fifth 3)
_ (println sixth " contains? " 1 " ? " (contains? sixth 1)) _ (println sixth " set-contains? " 1 " ? " (set-contains? sixth 1))
_ (println sixth " contains? " 2 " ? " (contains? sixth 2)) _ (println sixth " set-contains? " 2 " ? " (set-contains? sixth 2))
_ (println sixth " contains? " 3 " ? " (contains? sixth 3)) _ (println sixth " set-contains? " 3 " ? " (set-contains? sixth 3))
_ (println sixth " contains? " 4 " ? " (contains? sixth 4)) _ (println sixth " set-contains? " 4 " ? " (set-contains? sixth 4))
seventh (delete sixth 2) seventh (set-remove sixth 2)
_ (println seventh " contains? " 1 " ? " (contains? seventh 1)) _ (println seventh " set-contains? " 1 " ? " (set-contains? seventh 1))
_ (println seventh " contains? " 2 " ? " (contains? seventh 2)) _ (println seventh " set-contains? " 2 " ? " (set-contains? seventh 2))
_ (println seventh " contains? " 3 " ? " (contains? seventh 3)) _ (println seventh " set-contains? " 3 " ? " (set-contains? seventh 3))
_ (println seventh " contains? " 4 " ? " (contains? seventh 4)) _ (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)) ) nil))