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

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

Browse Source
This commit is contained in:
Nathan Braswell
2021-08-01 23:48:41 -04:00
parent 93fd0d1943
commit e0802baf5e
4 changed files with 85 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
match.kp
View File

@@ -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
))

8
match_test.kp
View File

@@ -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"
)))
))

64
rb.kp
View File

@@ -1,12 +1,20 @@
(with_import "./match.kp"
(let (
; ['R ..] or ['B ..] or ['BB]
; possibly temporarily ['BB ..] during rebalencing
empty ['B]
; This is based on https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf
; and the figure references refer to it
; 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)
))

15
rb_test.kp
View File

@@ -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))