4
4
-- Based on http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf
5
5
--
6
6
7
- module Data.Map
7
+ module Data.Map
8
8
( Map (),
9
9
showTree ,
10
10
empty ,
@@ -25,15 +25,16 @@ module Data.Map
25
25
unions ,
26
26
map
27
27
) where
28
-
28
+
29
29
import qualified Prelude as P
30
30
31
31
import qualified Data.Array as A
32
- import Data.Maybe
32
+ import Data.Maybe
33
33
import Data.Tuple
34
- import Data.Foldable (foldl )
35
-
36
- data Map k v
34
+ import Data.Foldable (foldl , foldMap , foldr , Foldable )
35
+ import Data.Traversable (traverse , Traversable )
36
+
37
+ data Map k v
37
38
= Leaf
38
39
| Two (Map k v ) k v (Map k v )
39
40
| Three (Map k v ) k v (Map k v ) k v (Map k v )
@@ -43,29 +44,38 @@ instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
43
44
(/=) m1 m2 = P .not (m1 P .== m2)
44
45
45
46
instance showMap :: (P.Show k , P.Show v ) => P.Show (Map k v ) where
46
- show m = " fromList " P .++ P .show (toList m)
47
+ show m = " fromList " P .++ P .show (toList m)
47
48
48
49
instance functorMap :: P.Functor (Map k ) where
49
50
(<$>) _ Leaf = Leaf
50
51
(<$>) f (Two left k v right) = Two (f P .<$> left) k (f v) (f P .<$> right)
51
52
(<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f P .<$> left) k1 (f v1) (f P .<$> mid) k2 (f v2) (f P .<$> right)
52
-
53
- showTree :: forall k v . (P.Show k , P.Show v ) => Map k v -> String
53
+
54
+ instance foldableMap :: Foldable (Map k ) where
55
+ foldl f z m = foldl f z (values m)
56
+ foldr f z m = foldr f z (values m)
57
+ foldMap f m = foldMap f (values m)
58
+
59
+ instance traversableMap :: (P.Ord k ) => Traversable (Map k ) where
60
+ traverse f ms = foldr (\x acc -> union P .<$> x P .<*> acc) (P .pure empty) ((P .(<$>) (uncurry singleton)) P .<$> (traverse f P .<$> toList ms))
61
+ sequence = traverse P .id
62
+
63
+ showTree :: forall k v . (P.Show k , P.Show v ) => Map k v -> String
54
64
showTree Leaf = " Leaf"
55
- showTree (Two left k v right) =
56
- " Two (" P .++ showTree left P .++
57
- " ) (" P .++ P .show k P .++
58
- " ) (" P .++ P .show v P .++
65
+ showTree (Two left k v right) =
66
+ " Two (" P .++ showTree left P .++
67
+ " ) (" P .++ P .show k P .++
68
+ " ) (" P .++ P .show v P .++
59
69
" ) (" P .++ showTree right P .++ " )"
60
- showTree (Three left k1 v1 mid k2 v2 right) =
61
- " Three (" P .++ showTree left P .++
62
- " ) (" P .++ P .show k1 P .++
63
- " ) (" P .++ P .show v1 P .++
70
+ showTree (Three left k1 v1 mid k2 v2 right) =
71
+ " Three (" P .++ showTree left P .++
72
+ " ) (" P .++ P .show k1 P .++
73
+ " ) (" P .++ P .show v1 P .++
64
74
" ) (" P .++ showTree mid P .++
65
- " ) (" P .++ P .show k2 P .++
66
- " ) (" P .++ P .show v2 P .++
75
+ " ) (" P .++ P .show k2 P .++
76
+ " ) (" P .++ P .show v2 P .++
67
77
" ) (" P .++ showTree right P .++ " )"
68
-
78
+
69
79
empty :: forall k v . Map k v
70
80
empty = Leaf
71
81
@@ -75,15 +85,15 @@ isEmpty _ = false
75
85
76
86
singleton :: forall k v . k -> v -> Map k v
77
87
singleton k v = Two Leaf k v Leaf
78
-
88
+
79
89
checkValid :: forall k v . Map k v -> Boolean
80
90
checkValid tree = A .length (A .nub (allHeights tree)) P .== 1
81
91
where
82
92
allHeights :: forall k v . Map k v -> [Number ]
83
93
allHeights Leaf = [0 ]
84
94
allHeights (Two left _ _ right) = A .map (\n -> n P .+ 1 ) (allHeights left P .++ allHeights right)
85
- allHeights (Three left _ _ mid _ _ right) = A .map (\n -> n P .+ 1 ) (allHeights left P .++ allHeights mid P .++ allHeights right)
86
-
95
+ allHeights (Three left _ _ mid _ _ right) = A .map (\n -> n P .+ 1 ) (allHeights left P .++ allHeights mid P .++ allHeights right)
96
+
87
97
lookup :: forall k v . (P.Ord k ) => k -> Map k v -> Maybe v
88
98
lookup _ Leaf = Nothing
89
99
lookup k (Two _ k1 v _) | k P .== k1 = Just v
@@ -104,15 +114,15 @@ data TreeContext k v
104
114
| ThreeLeft k v (Map k v ) k v (Map k v )
105
115
| ThreeMiddle (Map k v ) k v k v (Map k v )
106
116
| ThreeRight (Map k v ) k v (Map k v ) k v
107
-
117
+
108
118
fromZipper :: forall k v . (P.Ord k ) => [TreeContext k v ] -> Map k v -> Map k v
109
119
fromZipper [] tree = tree
110
120
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
111
121
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
112
122
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
113
123
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
114
124
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
115
-
125
+
116
126
data KickUp k v = KickUp (Map k v ) k v (Map k v )
117
127
118
128
insert :: forall k v . (P.Ord k ) => k -> v -> Map k v -> Map k v
@@ -127,39 +137,39 @@ insert = down []
127
137
down ctx k v (Three left k1 v1 mid k2 _ right) | k P .== k2 = fromZipper ctx (Three left k1 v1 mid k v right)
128
138
down ctx k v (Three left k1 v1 mid k2 v2 right) | k P .< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P .: ctx) k v left
129
139
down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 P .< k P .&& k P .<= k2 = down (ThreeMiddle left k1 v1 k2 v2 right P .: ctx) k v mid
130
- down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P .: ctx) k v right
131
-
140
+ down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P .: ctx) k v right
141
+
132
142
up :: forall k v . (P.Ord k ) => [TreeContext k v ] -> KickUp k v -> Map k v
133
143
up [] (KickUp left k v right) = Two left k v right
134
144
up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
135
145
up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
136
146
up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
137
147
up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
138
- up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))
139
-
148
+ up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))
149
+
140
150
delete :: forall k v . (P.Ord k ) => k -> Map k v -> Map k v
141
151
delete = down []
142
152
where
143
153
down :: forall k v . (P.Ord k ) => [TreeContext k v ] -> k -> Map k v -> Map k v
144
154
down ctx _ Leaf = fromZipper ctx Leaf
145
155
down ctx k (Two Leaf k1 _ Leaf ) | k P .== k1 = up ctx Leaf
146
- down ctx k (Two left k1 _ right) | k P .== k1 =
156
+ down ctx k (Two left k1 _ right) | k P .== k1 =
147
157
let max = maxNode left
148
158
in removeMaxNode (TwoLeft max.key max.value right P .: ctx) left
149
159
down ctx k (Two left k1 v1 right) | k P .< k1 = down (TwoLeft k1 v1 right P .: ctx) k left
150
160
down ctx k (Two left k1 v1 right) = down (TwoRight left k1 v1 P .: ctx) k right
151
161
down ctx k (Three Leaf k1 _ Leaf k2 v2 Leaf ) | k P .== k1 = fromZipper ctx (Two Leaf k2 v2 Leaf )
152
162
down ctx k (Three Leaf k1 v1 Leaf k2 _ Leaf ) | k P .== k2 = fromZipper ctx (Two Leaf k1 v1 Leaf )
153
- down ctx k (Three left k1 _ mid k2 v2 right) | k P .== k1 =
163
+ down ctx k (Three left k1 _ mid k2 v2 right) | k P .== k1 =
154
164
let max = maxNode left
155
165
in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right P .: ctx) left
156
166
down ctx k (Three left k1 v1 mid k2 _ right) | k P .== k2 =
157
167
let max = maxNode mid
158
168
in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right P .: ctx) mid
159
169
down ctx k (Three left k1 v1 mid k2 v2 right) | k P .< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P .: ctx) k left
160
170
down ctx k (Three left k1 v1 mid k2 v2 right) | k1 P .< k P .&& k P .< k2 = down (ThreeMiddle left k1 v1 k2 v2 right P .: ctx) k mid
161
- down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P .: ctx) k right
162
-
171
+ down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P .: ctx) k right
172
+
163
173
up :: forall k v . (P.Ord k ) => [TreeContext k v ] -> Map k v -> Map k v
164
174
up [] tree = tree
165
175
up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf )
@@ -179,27 +189,27 @@ delete = down []
179
189
up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
180
190
up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
181
191
up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
182
-
192
+
183
193
maxNode :: forall k v . (P.Ord k ) => Map k v -> { key :: k , value :: v }
184
194
maxNode (Two _ k v Leaf ) = { key: k, value: v }
185
195
maxNode (Two _ _ _ right) = maxNode right
186
196
maxNode (Three _ _ _ _ k v Leaf ) = { key: k, value: v }
187
197
maxNode (Three _ _ _ _ _ _ right) = maxNode right
188
-
198
+
189
199
removeMaxNode :: forall k v . (P.Ord k ) => [TreeContext k v ] -> Map k v -> Map k v
190
200
removeMaxNode ctx (Two Leaf _ _ Leaf ) = up ctx Leaf
191
201
removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v P .: ctx) right
192
202
removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf ) = up (TwoRight Leaf k1 v1 P .: ctx) Leaf
193
203
removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 P .: ctx) right
194
-
204
+
195
205
alter :: forall k v . (P.Ord k ) => (Maybe v -> Maybe v ) -> k -> Map k v -> Map k v
196
206
alter f k m = case f (k `lookup` m) of
197
207
Nothing -> delete k m
198
208
Just v -> insert k v m
199
209
200
210
update :: forall k v . (P.Ord k ) => (v -> Maybe v ) -> k -> Map k v -> Map k v
201
- update f k m = alter (maybe Nothing f) k m
202
-
211
+ update f k m = alter (maybe Nothing f) k m
212
+
203
213
toList :: forall k v . Map k v -> [Tuple k v ]
204
214
toList Leaf = []
205
215
toList (Two left k v right) = toList left P .++ [Tuple k v] P .++ toList right
0 commit comments