1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
----------------------------------------------------------------------
-- |
-- Module : RedBlackSet
-- Maintainer : Peter Ljunglöf
-- Stability : Stable
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/03/21 14:17:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Modified version of Okasaki's red-black trees
-- incorporating sets and set-valued maps
----------------------------------------------------------------------
module GF.Data.RedBlackSet ( -- * Red-black sets
RedBlackSet,
rbEmpty,
rbList,
rbElem,
rbLookup,
rbInsert,
rbMap,
rbOrdMap,
-- * Red-black finite maps
RedBlackMap,
rbmEmpty,
rbmList,
rbmElem,
rbmLookup,
rbmInsert,
rbmOrdMap
) where
--------------------------------------------------------------------------------
-- sets
data Color = R | B deriving (Eq, Show)
data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a)
deriving (Eq, Show)
rbBalance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
rbBalance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
rbBalance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
rbBalance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
rbBalance color a x b = T color a x b
rbBlack (T _ a x b) = T B a x b
-- | the empty set
rbEmpty :: RedBlackSet a
rbEmpty = E
-- | the elements of a set as a sorted list
rbList :: RedBlackSet a -> [a]
rbList tree = rbl tree []
where rbl E = id
rbl (T _ left a right) = rbl right . (a:) . rbl left
-- | checking for containment
rbElem :: Ord a => a -> RedBlackSet a -> Bool
rbElem _ E = False
rbElem a (T _ left a' right)
= case compare a a' of
LT -> rbElem a left
GT -> rbElem a right
EQ -> True
-- | looking up a key in a set of keys and values
rbLookup :: Ord k => k -> RedBlackSet (k, a) -> Maybe a
rbLookup _ E = Nothing
rbLookup a (T _ left (a',b) right)
= case compare a a' of
LT -> rbLookup a left
GT -> rbLookup a right
EQ -> Just b
-- | inserting a new element.
-- returns 'Nothing' if the element is already contained
rbInsert :: Ord a => a -> RedBlackSet a -> Maybe (RedBlackSet a)
rbInsert value tree = fmap rbBlack (rbins tree)
where rbins E = Just (T R E value E)
rbins (T color left value' right)
= case compare value value' of
LT -> do left' <- rbins left
return (rbBalance color left' value' right)
GT -> do right' <- rbins right
return (rbBalance color left value' right')
EQ -> Nothing
-- | mapping each value of a key-value set
rbMap :: (a -> b) -> RedBlackSet (k, a) -> RedBlackSet (k, b)
rbMap f E = E
rbMap f (T color left (key, value) right)
= T color (rbMap f left) (key, f value) (rbMap f right)
-- | mapping each element to another type.
-- /observe/ that the mapping function needs to preserve
-- the order between objects
rbOrdMap :: (a -> b) -> RedBlackSet a -> RedBlackSet b
rbOrdMap f E = E
rbOrdMap f (T color left value right)
= T color (rbOrdMap f left) (f value) (rbOrdMap f right)
----------------------------------------------------------------------
-- finite maps
type RedBlackMap k a = RedBlackSet (k, RedBlackSet a)
-- | the empty map
rbmEmpty :: RedBlackMap k a
rbmEmpty = E
-- | converting a map to a key-value list, sorted on the keys,
-- and for each key, a sorted list of values
rbmList :: RedBlackMap k a -> [(k, [a])]
rbmList tree = [ (k, rbList sub) | (k, sub) <- rbList tree ]
-- | checking whether a key-value pair is contained in the map
rbmElem :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Bool
rbmElem key value = maybe False (rbElem value) . rbLookup key
-- | looking up a key, returning a (sorted) list of all matching values
rbmLookup :: Ord k => k -> RedBlackMap k a -> [a]
rbmLookup key = maybe [] rbList . rbLookup key
-- | inserting a key-value pair.
-- returns 'Nothing' if the pair is already contained in the map
rbmInsert :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Maybe (RedBlackMap k a)
rbmInsert key value tree = fmap rbBlack (rbins tree)
where rbins E = Just (T R E (key, T B E value E) E)
rbins (T color left item@(key', vtree) right)
= case compare key key' of
LT -> do left' <- rbins left
return (rbBalance color left' item right)
GT -> do right' <- rbins right
return (rbBalance color left item right')
EQ -> do vtree' <- rbInsert value vtree
return (T color left (key', vtree') right)
-- | mapping each value to another type.
-- /observe/ that the mapping function needs to preserve
-- order between objects
rbmOrdMap :: (a -> b) -> RedBlackMap k a -> RedBlackMap k b
rbmOrdMap f E = E
rbmOrdMap f (T color left (key, tree) right)
= T color (rbmOrdMap f left) (key, rbOrdMap f tree) (rbmOrdMap f right)
|
