Mercurial > hg > Members > Moririn
annotate hoareRedBlackTree.agda @ 583:d18df2e6135d
add replaceNode
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Sun, 03 Nov 2019 08:53:00 +0900 |
parents | 1a5dd71199f1 |
children | 7e551cef35d7 |
rev | line source |
---|---|
576 | 1 module hoareRedBlackTree where |
2 | |
3 | |
4 open import Level hiding (zero) | |
5 | |
6 open import Data.Nat hiding (compare) | |
7 open import Data.Nat.Properties as NatProp | |
8 open import Data.Maybe | |
581 | 9 -- open import Data.Bool |
576 | 10 open import Data.Empty |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
11 open import Data.List |
576 | 12 |
13 open import Relation.Binary | |
14 open import Relation.Binary.PropositionalEquality | |
579 | 15 open import logic |
576 | 16 |
17 | |
18 record TreeMethods {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where | |
19 field | |
20 putImpl : treeImpl → a → (treeImpl → t) → t | |
21 getImpl : treeImpl → (treeImpl → Maybe a → t) → t | |
22 open TreeMethods | |
23 | |
24 record Tree {n m : Level } {a : Set n } {t : Set m } (treeImpl : Set n ) : Set (m Level.⊔ n) where | |
25 field | |
26 tree : treeImpl | |
27 treeMethods : TreeMethods {n} {m} {a} {t} treeImpl | |
28 putTree : a → (Tree treeImpl → t) → t | |
29 putTree d next = putImpl (treeMethods ) tree d (\t1 → next (record {tree = t1 ; treeMethods = treeMethods} )) | |
30 getTree : (Tree treeImpl → Maybe a → t) → t | |
31 getTree next = getImpl (treeMethods ) tree (\t1 d → next (record {tree = t1 ; treeMethods = treeMethods} ) d ) | |
32 | |
33 open Tree | |
34 | |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
35 SingleLinkedStack = List |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
36 |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
37 emptySingleLinkedStack : {n : Level } {Data : Set n} -> SingleLinkedStack Data |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
38 emptySingleLinkedStack = [] |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
39 |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
40 pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} -> List Data -> Data -> (Code : SingleLinkedStack Data -> t) -> t |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
41 pushSingleLinkedStack stack datum next = next ( datum ∷ stack ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
42 |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
43 popSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
44 popSingleLinkedStack [] cs = cs [] nothing |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
45 popSingleLinkedStack (data1 ∷ s) cs = cs s (just data1) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
46 |
576 | 47 data Color {n : Level } : Set n where |
48 Red : Color | |
49 Black : Color | |
50 | |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
51 record Node {n : Level } (a : Set n) : Set n where |
576 | 52 inductive |
53 field | |
54 key : ℕ | |
55 value : a | |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
56 right : Maybe (Node a ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
57 left : Maybe (Node a ) |
576 | 58 color : Color {n} |
59 open Node | |
60 | |
580 | 61 record RedBlackTree {n : Level } (a : Set n) : Set n where |
576 | 62 field |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
63 root : Maybe (Node a ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
64 nodeStack : SingleLinkedStack (Node a ) |
576 | 65 -- compare : k → k → Tri A B C |
66 -- <-cmp | |
67 | |
68 open RedBlackTree | |
69 | |
70 | |
71 ---- | |
72 -- find node potition to insert or to delete, the path will be in the stack | |
73 -- | |
74 | |
75 {-# TERMINATING #-} | |
580 | 76 findNode : {n m : Level } {a : Set n} {t : Set m} → RedBlackTree {n} a → (Node a ) → (RedBlackTree {n} a → t) → t |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
77 findNode {n} {m} {a} {t} tree n0 next with root tree |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
78 findNode {n} {m} {a} {t} tree n0 next | nothing = next tree |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
79 findNode {n} {m} {a} {t} tree n0 next | just x with <-cmp (key x) (key n0) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
80 findNode {n} {m} {a} {t} tree n0 next | just x | tri≈ ¬a b ¬c = next tree |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
81 findNode {n} {m} {a} {t} tree n0 next | just x | tri< a₁ ¬b ¬c = pushSingleLinkedStack (nodeStack tree) x (λ s → findNode (record {root = (left x) ; nodeStack = s}) n0 next) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
82 findNode {n} {m} {a} {t} tree n0 next | just x | tri> ¬a ¬b c = pushSingleLinkedStack (nodeStack tree) x (λ s → findNode (record {root = (right x) ; nodeStack = s}) n0 next) |
576 | 83 |
84 | |
580 | 85 findNode1 : {n m : Level } {a : Set n} {t : Set m} → RedBlackTree {n} a → (Node a ) → (RedBlackTree {n} a → t) → t |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
86 findNode1 {n} {m} {a} {t} tree n0 next = findNode2 (root tree) (nodeStack tree) |
577 | 87 module FindNode where |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
88 findNode2 : (Maybe (Node a )) → SingleLinkedStack (Node a ) → t |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
89 findNode2 nothing st = next record { root = nothing ; nodeStack = st } |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
90 findNode2 (just x) st with <-cmp (key n0) (key x) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
91 ... | tri≈ ¬a b ¬c = next (record {root = just x ; nodeStack = st }) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
92 ... | tri< a ¬b ¬c = pushSingleLinkedStack st x (λ s1 → findNode2 (right x) s1) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
93 ... | tri> ¬a ¬b c = pushSingleLinkedStack st x (λ s1 → findNode2 (left x) s1) |
576 | 94 |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
95 node001 : Node ℕ |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
96 node001 = record { key = 2 ; value = 3 ; left = nothing ; right = nothing ; color = Black } |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
97 node002 : Node ℕ |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
98 node002 = record { key = 1 ; value = 3 ; left = just node001 ; right = nothing ; color = Black } |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
99 node003 : Node ℕ |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
100 node003 = record { key = 0 ; value = 3 ; left = just node002 ; right = nothing ; color = Black } |
576 | 101 |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
102 test001 = findNode1 {Level.zero} {Level.zero} {ℕ} {RedBlackTree ℕ} ( record { root = nothing ; nodeStack = emptySingleLinkedStack } ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
103 node001 ( λ tree → tree ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
104 test002 = findNode1 {Level.zero} {Level.zero} {ℕ} {RedBlackTree ℕ} ( record { root = just node001 ; nodeStack = emptySingleLinkedStack } ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
105 node001 ( λ tree → tree ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
106 test003 = findNode1 {Level.zero} {Level.zero} {ℕ} {RedBlackTree ℕ} ( record { root = just node003 ; nodeStack = emptySingleLinkedStack } ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
107 node001 ( λ tree → tree ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
108 test004 = findNode {Level.zero} {Level.zero} {ℕ} {RedBlackTree ℕ} ( record { root = just node003 ; nodeStack = emptySingleLinkedStack } ) |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
109 node001 ( λ tree → tree ) |
576 | 110 |
583 | 111 replaceNode : {n m : Level } {a : Set n} {t : Set m} → RedBlackTree {n} a → (Node a ) → (RedBlackTree {n} a → t) → t |
112 replaceNode {n} {m} {a} {t} tree n0 next = replaceNode2 (nodeStack tree) (λ newNode → next record { root = just newNode ; nodeStack = emptySingleLinkedStack } ) | |
113 module FindNodeR where | |
114 replaceNode1 : (Maybe (Node a )) → Node a | |
115 replaceNode1 nothing = record n0 { left = nothing ; right = nothing } | |
116 replaceNode1 (just x) = record n0 { left = left x ; right = right x } | |
117 replaceNode2 : SingleLinkedStack (Node a ) → (Node a → t) → t | |
118 replaceNode2 [] next = next ( replaceNode1 (root tree) ) | |
119 replaceNode2 (x ∷ st) next with <-cmp (key x) (key n0) | |
120 replaceNode2 (x ∷ st) next | tri< a ¬b ¬c = replaceNode2 st ( λ new → next ( record x { left = left new } ) ) | |
121 replaceNode2 (x ∷ st) next | tri≈ ¬a b ¬c = replaceNode2 st ( λ new → next ( record x { left = left new ; right = right new } ) ) | |
122 replaceNode2 (x ∷ st) next | tri> ¬a ¬b c = replaceNode2 st ( λ new → next ( record x { right = right new } ) ) | |
123 | |
124 insertNode : {n m : Level } {a : Set n} {t : Set m} → RedBlackTree {n} a → (Node a ) → (RedBlackTree {n} a → t) → t | |
125 insertNode tree n0 next = findNode1 tree n0 ( λ new → replaceNode tree n0 next ) | |
126 | |
576 | 127 createEmptyRedBlackTreeℕ : {n m : Level} {t : Set m} (a : Set n) (b : ℕ) |
580 | 128 → RedBlackTree {n} a |
576 | 129 createEmptyRedBlackTreeℕ a b = record { |
130 root = nothing | |
131 ; nodeStack = emptySingleLinkedStack | |
132 } | |
133 | |
581 | 134 findNodeLeft : {n : Level } {a : Set n} (r : Node a ) (t : SingleLinkedStack (Node a)) → Set n |
135 findNodeLeft x [] = (left x ≡ nothing ) ∧ (right x ≡ nothing ) | |
136 findNodeLeft {n} x (h ∷ t) = Lift n ((key x) < (key h)) | |
137 findNodeRight : {n : Level } {a : Set n} (r : Node a ) (t : SingleLinkedStack (Node a)) → Set n | |
138 findNodeRight x [] = (left x ≡ nothing ) ∧ (right x ≡ nothing ) | |
139 findNodeRight {n} x (h ∷ t) = Lift n ((key x) > (key h)) | |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
140 |
581 | 141 data FindNodeInvariant {n : Level } {a : Set n} : (t : SingleLinkedStack (Node a)) (original : RedBlackTree {n} a ) → Set n where |
142 fni-Top : (now : RedBlackTree {n} a ) → FindNodeInvariant [] now | |
143 fni-Left : (x : Node a) (t : SingleLinkedStack (Node a)) (original : RedBlackTree {n} a ) | |
144 → FindNodeInvariant ( x ∷ t ) original → findNodeLeft x t → FindNodeInvariant t original | |
145 fni-Right : (x : Node a) (t : SingleLinkedStack (Node a)) (original : RedBlackTree {n} a ) | |
146 → FindNodeInvariant ( x ∷ t ) original → findNodeRight x t → FindNodeInvariant t original | |
147 | |
148 | |
149 findNode1h : {n m : Level } {a : Set n} {t : Set m} → (tree : RedBlackTree {n} a ) → (Node a ) | |
582 | 150 → ((new : RedBlackTree {n} a) → FindNodeInvariant (nodeStack new) tree → t ) |
151 → ( FindNodeInvariant (nodeStack tree) tree) → t | |
152 findNode1h {n} {m} {a} {t} tree n0 next prev = findNode2h (root tree) (nodeStack tree) prev | |
581 | 153 module FindNodeH where |
154 findNode2h : (Maybe (Node a )) → (s : SingleLinkedStack (Node a )) → FindNodeInvariant s tree → t | |
582 | 155 findNode2h nothing st prev = next record { root = nothing ; nodeStack = st } {!!} |
581 | 156 findNode2h (just x) st prev with <-cmp (key n0) (key x) |
157 ... | tri≈ ¬a b ¬c = next (record {root = just x ; nodeStack = st }) {!!} -- ( fni-Last ? ) | |
158 ... | tri< a ¬b ¬c = pushSingleLinkedStack st x (λ s1 → findNode2h (right x) s1 (fni-Left x s1 tree {!!} {!!}) ) | |
159 ... | tri> ¬a ¬b c = pushSingleLinkedStack st x (λ s1 → findNode2h (left x) s1 (fni-Right x s1 tree {!!} {!!}) ) | |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
160 |
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
161 |
583 | 162 replaceNodeH : {n m : Level } {a : Set n} {t : Set m} → RedBlackTree {n} a → (Node a ) → (RedBlackTree {n} a → {!!} → t) → {!!} → t |
163 replaceNodeH = {!!} | |
578
7bacba816277
use list base simple stack
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
577
diff
changeset
|
164 |