Mercurial > hg > Gears > GearsAgda
annotate RedBlackTree.agda @ 537:fffeaf0b0024
add stackTest redBlackTreeTest
author | ryokka |
---|---|
date | Wed, 10 Jan 2018 15:44:13 +0900 |
parents | 2d86242ee853 |
children | 5c001e8ba0d5 |
rev | line source |
---|---|
417 | 1 module RedBlackTree where |
2 | |
3 open import stack | |
533 | 4 open import Level hiding (zero) |
511 | 5 record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where |
6 field | |
7 putImpl : treeImpl -> a -> (treeImpl -> t) -> t | |
8 getImpl : treeImpl -> (treeImpl -> Maybe a -> t) -> t | |
9 open TreeMethods | |
10 | |
11 record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where | |
417 | 12 field |
13 tree : treeImpl | |
513 | 14 treeMethods : TreeMethods {n} {m} {a} {t} treeImpl |
15 putTree : a -> (Tree treeImpl -> t) -> t | |
511 | 16 putTree d next = putImpl (treeMethods ) tree d (\t1 -> next (record {tree = t1 ; treeMethods = treeMethods} )) |
513 | 17 getTree : (Tree treeImpl -> Maybe a -> t) -> t |
511 | 18 getTree next = getImpl (treeMethods ) tree (\t1 d -> next (record {tree = t1 ; treeMethods = treeMethods} ) d ) |
427 | 19 |
478 | 20 open Tree |
21 | |
513 | 22 data Color {n : Level } : Set n where |
425 | 23 Red : Color |
24 Black : Color | |
25 | |
512 | 26 data CompareResult {n : Level } : Set n where |
27 LT : CompareResult | |
28 GT : CompareResult | |
29 EQ : CompareResult | |
30 | |
513 | 31 record Node {n : Level } (a k : Set n) : Set n where |
32 inductive | |
425 | 33 field |
512 | 34 key : k |
35 value : a | |
513 | 36 right : Maybe (Node a k) |
37 left : Maybe (Node a k) | |
514 | 38 color : Color {n} |
512 | 39 open Node |
425 | 40 |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
41 record RedBlackTree {n m : Level } {t : Set m} (a k si : Set n) : Set (m Level.⊔ n) where |
417 | 42 field |
514 | 43 root : Maybe (Node a k) |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
44 nodeStack : Stack {n} {m} (Node a k) {t} si |
514 | 45 compare : k -> k -> CompareResult {n} |
425 | 46 |
417 | 47 open RedBlackTree |
48 | |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
49 open Stack |
512 | 50 |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
51 -- |
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
52 -- put new node at parent node, and rebuild tree to the top |
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
53 -- |
519
0a723e418b2a
add some more directives in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
518
diff
changeset
|
54 {-# TERMINATING #-} -- https://agda.readthedocs.io/en/v2.5.3/language/termination-checking.html |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
55 replaceNode : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) si -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k si -> t) -> t |
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
56 replaceNode {n} {m} {t} {a} {k} {si} tree s parent n0 next = popStack s ( |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
57 \s grandParent -> replaceNode1 s grandParent ( compare tree (key parent) (key n0) ) ) |
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
58 where |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
59 replaceNode1 : Stack (Node a k) si -> Maybe ( Node a k ) -> CompareResult -> t |
529 | 60 replaceNode1 s Nothing LT = next ( record tree { root = Just ( record parent { left = Just n0 ; color = Black } ) } ) |
61 replaceNode1 s Nothing GT = next ( record tree { root = Just ( record parent { right = Just n0 ; color = Black } ) } ) | |
62 replaceNode1 s Nothing EQ = next ( record tree { root = Just ( record parent { right = Just n0 ; color = Black } ) } ) | |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
63 replaceNode1 s (Just grandParent) result with result |
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
64 ... | LT = replaceNode tree s grandParent ( record parent { left = Just n0 } ) next |
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
65 ... | GT = replaceNode tree s grandParent ( record parent { right = Just n0 } ) next |
529 | 66 ... | EQ = next tree |
478 | 67 |
525 | 68 |
532 | 69 rotateRight : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> |
70 (RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t | |
71 rotateRight {n} {m} {t} {a} {k} {si} tree s n0 parent rotateNext = getStack s (\ s n0 -> rotateRight1 tree s n0 parent rotateNext) | |
530 | 72 where |
532 | 73 rotateRight1 : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> |
74 (RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t | |
75 rotateRight1 {n} {m} {t} {a} {k} {si} tree s n0 parent rotateNext with n0 | |
76 ... | Nothing = rotateNext tree s Nothing n0 | |
530 | 77 ... | Just n1 with parent |
532 | 78 ... | Nothing = rotateNext tree s (Just n1 ) n0 |
530 | 79 ... | Just parent1 with left parent1 |
532 | 80 ... | Nothing = rotateNext tree s (Just n1) Nothing |
530 | 81 ... | Just leftParent with compare tree (key n1) (key leftParent) |
532 | 82 ... | EQ = rotateNext tree s (Just n1) parent |
83 ... | _ = rotateNext tree s (Just n1) parent | |
530 | 84 |
519
0a723e418b2a
add some more directives in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
518
diff
changeset
|
85 |
532 | 86 rotateLeft : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> |
87 (RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t | |
88 rotateLeft {n} {m} {t} {a} {k} {si} tree s n0 parent rotateNext = getStack s (\ s n0 -> rotateLeft1 tree s n0 parent rotateNext) | |
530 | 89 where |
532 | 90 rotateLeft1 : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> |
91 (RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> t) -> t | |
92 rotateLeft1 {n} {m} {t} {a} {k} {si} tree s n0 parent rotateNext with n0 | |
93 ... | Nothing = rotateNext tree s Nothing n0 | |
530 | 94 ... | Just n1 with parent |
532 | 95 ... | Nothing = rotateNext tree s (Just n1) Nothing |
530 | 96 ... | Just parent1 with right parent1 |
532 | 97 ... | Nothing = rotateNext tree s (Just n1) Nothing |
530 | 98 ... | Just rightParent with compare tree (key n1) (key rightParent) |
532 | 99 ... | EQ = rotateNext tree s (Just n1) parent |
100 ... | _ = rotateNext tree s (Just n1) parent | |
519
0a723e418b2a
add some more directives in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
518
diff
changeset
|
101 |
530 | 102 {-# TERMINATING #-} |
532 | 103 insertCase5 : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k si -> t) -> t |
530 | 104 insertCase5 {n} {m} {t} {a} {k} {si} tree s n0 parent grandParent next = pop2Stack s (\ s parent grandParent -> insertCase51 tree s n0 parent grandParent next) |
105 where | |
532 | 106 insertCase51 : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Maybe (Node a k) -> Maybe (Node a k) -> Maybe (Node a k) -> (RedBlackTree {n} {m} {t} a k si -> t) -> t |
107 insertCase51 {n} {m} {t} {a} {k} {si} tree s n0 parent grandParent next with n0 | |
108 ... | Nothing = next tree | |
109 ... | Just n1 with parent | grandParent | |
110 ... | Nothing | _ = next tree | |
111 ... | _ | Nothing = next tree | |
112 ... | Just parent1 | Just grandParent1 with left parent1 | left grandParent1 | |
113 ... | Nothing | _ = next tree | |
114 ... | _ | Nothing = next tree | |
115 ... | Just leftParent1 | Just leftGrandParent1 | |
116 with compare tree (key n1) (key leftParent1) | compare tree (key leftParent1) (key leftGrandParent1) | |
117 ... | EQ | EQ = rotateRight tree s n0 parent | |
118 (\ tree s n0 parent -> insertCase5 tree s n0 parent1 grandParent1 next) | |
119 ... | _ | _ = rotateLeft tree s n0 parent | |
120 (\ tree s n0 parent -> insertCase5 tree s n0 parent1 grandParent1 next) | |
519
0a723e418b2a
add some more directives in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
518
diff
changeset
|
121 |
528 | 122 insertCase4 : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Node a k -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k si -> t) -> t |
527 | 123 insertCase4 {n} {m} {t} {a} {k} {si} tree s n0 parent grandParent next |
528 | 124 with (right parent) | (left grandParent) |
532 | 125 ... | Nothing | _ = insertCase5 tree s (Just n0) parent grandParent next |
126 ... | _ | Nothing = insertCase5 tree s (Just n0) parent grandParent next | |
528 | 127 ... | Just rightParent | Just leftGrandParent with compare tree (key n0) (key rightParent) | compare tree (key parent) (key leftGrandParent) |
532 | 128 ... | EQ | EQ = popStack s (\ s n1 -> rotateLeft tree s (left n0) (Just grandParent) |
129 (\ tree s n0 parent -> insertCase5 tree s n0 rightParent grandParent next)) | |
530 | 130 ... | _ | _ = insertCase41 tree s n0 parent grandParent next |
131 where | |
132 insertCase41 : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Node a k -> Node a k -> Node a k -> (RedBlackTree {n} {m} {t} a k si -> t) -> t | |
133 insertCase41 {n} {m} {t} {a} {k} {si} tree s n0 parent grandParent next | |
134 with (left parent) | (right grandParent) | |
532 | 135 ... | Nothing | _ = insertCase5 tree s (Just n0) parent grandParent next |
136 ... | _ | Nothing = insertCase5 tree s (Just n0) parent grandParent next | |
530 | 137 ... | Just leftParent | Just rightGrandParent with compare tree (key n0) (key leftParent) | compare tree (key parent) (key rightGrandParent) |
532 | 138 ... | EQ | EQ = popStack s (\ s n1 -> rotateRight tree s (right n0) (Just grandParent) |
139 (\ tree s n0 parent -> insertCase5 tree s n0 leftParent grandParent next)) | |
140 ... | _ | _ = insertCase5 tree s (Just n0) parent grandParent next | |
527 | 141 |
532 | 142 colorNode : {n : Level } {a k : Set n} -> Node a k -> Color -> Node a k |
143 colorNode old c = record old { color = c } | |
527 | 144 |
519
0a723e418b2a
add some more directives in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
518
diff
changeset
|
145 {-# TERMINATING #-} |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
146 insertNode : {n m : Level } {t : Set m } {a k si : Set n} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) {t} si -> Node a k -> (RedBlackTree {n} {m} {t} a k si -> t) -> t |
532 | 147 insertNode {n} {m} {t} {a} {k} {si} tree s n0 next = get2Stack s (insertCase1 n0) |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
148 where |
532 | 149 insertCase1 : Node a k -> Stack (Node a k) si -> Maybe (Node a k) -> Maybe (Node a k) -> t -- placed here to allow mutual recursion |
519
0a723e418b2a
add some more directives in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
518
diff
changeset
|
150 -- http://agda.readthedocs.io/en/v2.5.2/language/mutual-recursion.html |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
151 insertCase3 : Stack (Node a k) si -> Node a k -> Node a k -> Node a k -> t |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
152 insertCase3 s n0 parent grandParent with left grandParent | right grandParent |
528 | 153 ... | Nothing | Nothing = insertCase4 tree s n0 parent grandParent next |
154 ... | Nothing | Just uncle = insertCase4 tree s n0 parent grandParent next | |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
155 ... | Just uncle | _ with compare tree ( key uncle ) ( key parent ) |
528 | 156 ... | EQ = insertCase4 tree s n0 parent grandParent next |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
157 ... | _ with color uncle |
532 | 158 ... | Red = pop2Stack s ( \s p0 p1 -> insertCase1 ( |
159 record grandParent { color = Red ; left = Just ( record parent { color = Black } ) ; right = Just ( record uncle { color = Black } ) }) s p0 p1 ) | |
528 | 160 ... | Black = insertCase4 tree s n0 parent grandParent next |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
161 insertCase2 : Stack (Node a k) si -> Node a k -> Node a k -> Node a k -> t |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
162 insertCase2 s n0 parent grandParent with color parent |
532 | 163 ... | Black = replaceNode tree s parent n0 next |
164 ... | Red = insertCase3 s n0 parent grandParent | |
165 insertCase1 n0 s Nothing Nothing = next tree | |
166 insertCase1 n0 s Nothing (Just grandParent) = next tree | |
167 insertCase1 n0 s (Just parent) Nothing = replaceNode tree s parent (colorNode n0 Black) next | |
168 insertCase1 n0 s (Just parent) (Just grandParent) = insertCase2 s n0 parent grandParent | |
528 | 169 |
531 | 170 ---- |
171 -- find node potition to insert or to delete, the pass will be in the stack | |
172 -- | |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
173 findNode : {n m : Level } {a k si : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) si -> (Node a k) -> (Node a k) -> (RedBlackTree {n} {m} {t} a k si -> Stack (Node a k) si -> Node a k -> t) -> t |
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
174 findNode {n} {m} {a} {k} {si} {t} tree s n0 n1 next = pushStack s n1 (\ s -> findNode1 s n1) |
417 | 175 where |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
176 findNode2 : Stack (Node a k) si -> (Maybe (Node a k)) -> t |
515 | 177 findNode2 s Nothing = next tree s n0 |
178 findNode2 s (Just n) = findNode tree s n0 n next | |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
179 findNode1 : Stack (Node a k) si -> (Node a k) -> t |
515 | 180 findNode1 s n1 with (compare tree (key n0) (key n1)) |
529 | 181 ... | EQ = next tree s n0 |
515 | 182 ... | GT = findNode2 s (right n1) |
183 ... | LT = findNode2 s (left n1) | |
425 | 184 |
185 | |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
186 leafNode : {n : Level } {a k : Set n} -> k -> a -> Node a k |
515 | 187 leafNode k1 value = record { |
188 key = k1 ; | |
189 value = value ; | |
190 right = Nothing ; | |
191 left = Nothing ; | |
532 | 192 color = Red |
518
c9f90f573efe
add more reblack tree in agda
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
515
diff
changeset
|
193 } |
417 | 194 |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
195 putRedBlackTree : {n m : Level } {a k si : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k si -> k -> a -> (RedBlackTree {n} {m} {t} a k si -> t) -> t |
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
196 putRedBlackTree {n} {m} {a} {k} {si} {t} tree k1 value next with (root tree) |
515 | 197 ... | Nothing = next (record tree {root = Just (leafNode k1 value) }) |
531 | 198 ... | Just n2 = clearStack (nodeStack tree) (\ s -> findNode tree s (leafNode k1 value) n2 (\ tree1 s n1 -> insertNode tree1 s n1 next)) |
515 | 199 |
522
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
200 getRedBlackTree : {n m : Level } {a k si : Set n} {t : Set m} -> RedBlackTree {n} {m} {t} a k si -> k -> (RedBlackTree {n} {m} {t} a k si -> (Maybe (Node a k)) -> t) -> t |
f63a9a081b61
remove implementation from RedBlackTree.aga
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
521
diff
changeset
|
201 getRedBlackTree {_} {_} {a} {k} {_} {t} tree k1 cs = checkNode (root tree) |
417 | 202 where |
515 | 203 checkNode : Maybe (Node a k) -> t |
204 checkNode Nothing = cs tree Nothing | |
205 checkNode (Just n) = search n | |
206 where | |
207 search : Node a k -> t | |
208 search n with compare tree k1 (key n) | |
209 search n | LT = checkNode (left n) | |
210 search n | GT = checkNode (right n) | |
211 search n | EQ = cs tree (Just n) | |
533 | 212 |
213 open import Data.Nat hiding (compare) | |
214 | |
215 createEmptyRedBlackTreeℕ : { m : Level } (a : Set Level.zero) {t : Set m} -> RedBlackTree {Level.zero} {m} {t} a ℕ ( SingleLinkedStack (Node a ℕ ) ) | |
216 createEmptyRedBlackTreeℕ {m} a {t} = record { | |
217 root = Nothing | |
218 ; nodeStack = createSingleLinkedStack | |
219 ; compare = compare1 | |
220 } where | |
221 compare1 : ℕ → ℕ → CompareResult {Level.zero} | |
222 compare1 x y with Data.Nat.compare x y | |
223 ... | less _ _ = LT | |
224 ... | equal _ = EQ | |
225 ... | greater _ _ = GT | |
226 |