├── .gitignore
├── .hgignore
├── .hgtags
├── .travis.yml
├── Data
└── CritBit
│ ├── Core.hs
│ ├── Map
│ └── Lazy.hs
│ ├── Set.hs
│ ├── Tree.hs
│ └── Types
│ └── Internal.hs
├── LICENSE
├── README.markdown
├── Setup.lhs
├── benchmarks
└── Benchmarks.hs
├── critbit.cabal
├── doc
└── criterion-sample-lookup.html
└── tests
├── Main.hs
└── Properties
├── Common.hs
├── Map.hs
└── Set.hs
/.gitignore:
--------------------------------------------------------------------------------
1 | cabal-dev
2 | .cabal-sandbox
3 | cabal.sandbox.config
4 | dist
5 |
--------------------------------------------------------------------------------
/.hgignore:
--------------------------------------------------------------------------------
1 | ^(?:.cabal-sandbox|dist|cabal.sandbox.config|benchmarks/dist)$
2 | ^tests/(?:\.hpc|bm|qc|qc-hpc|stdio-hpc|text/test)$
3 | \.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp|tix)$
4 | ~$
5 |
6 | syntax: glob
7 | .\#*
8 |
--------------------------------------------------------------------------------
/.hgtags:
--------------------------------------------------------------------------------
1 | 54255d499795341278d127771a31b82702ae70de 0.1.0.0
2 | 4fd4c4dab39c5727db38514dcc5300c0f696eaba 0.2.0.0
3 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: haskell
2 |
3 |
4 | env:
5 | - GHCVER=7.4.1
6 | - GHCVER=7.4.2
7 | - GHCVER=7.6.1
8 | - GHCVER=7.6.2
9 | - GHCVER=7.6.3
10 | - GHCVER=7.8.1
11 | - GHCVER=7.8.2
12 |
13 | before_install:
14 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
15 | - travis_retry sudo apt-get update
16 | - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER ghc-$GHCVER-prof ghc-$GHCVER-dyn happy
17 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH
18 |
19 | install:
20 | - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache
21 | - /opt/ghc/$GHCVER/bin/ghc-pkg recache --user
22 | - cabal update
23 | - cabal install --only-dependencies --enable-tests --enable-benchmarks
24 |
25 | script:
26 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
27 | - cabal build # this builds all libraries and executables (including tests/benchmarks)
28 | - cabal test
29 | #- cabal check # leave this out for now as it gives warnings about the use of -Werror and -O2
30 | - cabal sdist # tests that a source-distribution can be generated
31 |
32 | # The following scriptlet checks that the resulting source distribution can be built & installed
33 | - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;
34 | cd dist/;
35 | if [ -f "$SRC_TGZ" ]; then
36 | cabal install "$SRC_TGZ";
37 | else
38 | echo "expected '$SRC_TGZ' not found";
39 | exit 1;
40 | fi
41 |
--------------------------------------------------------------------------------
/Data/CritBit/Core.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, RecordWildCards, ScopedTypeVariables #-}
2 | -- |
3 | -- Module : Data.CritBit.Core
4 | -- Copyright : (c) Bryan O'Sullivan 2013
5 | -- License : BSD-style
6 | -- Maintainer : bos@serpentine.com
7 | -- Stability : experimental
8 | -- Portability : GHC
9 | --
10 | -- "Core" functions that implement the crit-bit tree algorithms.
11 | --
12 | -- I plopped these functions into their own source file to demonstrate
13 | -- just how small the core of the crit-bit tree concept is.
14 | --
15 | -- I have also commented this module a bit more heavily than I usually
16 | -- do, in the hope that the comments will make the code more
17 | -- approachable to less experienced Haskellers.
18 | module Data.CritBit.Core
19 | (
20 | -- * Public functions
21 | insertWithKey
22 | , insertLookupWithKey
23 | , insertLookupGen
24 | , lookupWith
25 | , updateLookupWithKey
26 | , leftmost
27 | , rightmost
28 | -- * Internal functions
29 | , Diff(..)
30 | , diffOrd
31 | , followPrefixes
32 | , followPrefixesFrom
33 | , followPrefixesByteFrom
34 | , findPosition
35 | -- ** Predicates
36 | , onLeft
37 | , above
38 | -- ** Smart constructors
39 | , setLeft
40 | , setRight
41 | , setLeft'
42 | , setRight'
43 | , internal
44 | ) where
45 |
46 | import Data.Bits ((.|.), (.&.), complement, shiftR, xor)
47 | import Data.CritBit.Types.Internal
48 |
49 | -- | /O(k)/. Insert with a function, combining key, new value and old value.
50 | -- @'insertWithKey' f key value cb@
51 | -- will insert the pair (key, value) into cb if key does not exist in the map.
52 | -- If the key does exist, the function will insert the pair
53 | -- @(key,f key new_value old_value)@.
54 | -- Note that the key passed to f is the same key passed to insertWithKey.
55 | --
56 | -- > let f key new_value old_value = byteCount key + new_value + old_value
57 | -- > insertWithKey f "a" 1 (fromList [("a",5), ("b",3)]) == fromList [("a",7), ("b",3)]
58 | -- > insertWithKey f "c" 1 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("c",1)]
59 | -- > insertWithKey f "a" 1 empty == singleton "a" 1
60 | insertWithKey :: CritBitKey k => (k -> v -> v -> v) -> k -> v -> CritBit k v
61 | -> CritBit k v
62 | insertWithKey f k v m = insertLookupGen (flip const) f k v m
63 | {-# INLINABLE insertWithKey #-}
64 |
65 | -- | /O(k)/. Combines insert operation with old value retrieval.
66 | -- The expression (@'insertLookupWithKey' f k x map@)
67 | -- is a pair where the first element is equal to (@'lookup' k map@)
68 | -- and the second element equal to (@'insertWithKey' f k x map@).
69 | --
70 | -- > let f key new_value old_value = length key + old_value + new_value
71 | -- > insertLookupWithKey f "a" 2 (fromList [("a",5), ("b",3)]) == (Just 5, fromList [("a",8), ("b",3)])
72 | -- > insertLookupWithKey f "c" 2 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [("a",5), ("b",3), ("c",2)])
73 | -- > insertLookupWithKey f "a" 2 empty == (Nothing, singleton "a" 2)
74 | --
75 | -- This is how to define @insertLookup@ using @insertLookupWithKey@:
76 | --
77 | -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
78 | -- > insertLookup "a" 1 (fromList [("a",5), ("b",3)]) == (Just 5, fromList [("a",1), ("b",3)])
79 | -- > insertLookup "c" 1 (fromList [("a",5), ("b",3)]) == (Nothing, fromList [("a",5), ("b",3), ("c",1)])
80 | insertLookupWithKey :: CritBitKey k
81 | => (k -> v -> v -> v)
82 | -> k -> v -> CritBit k v
83 | -> (Maybe v, CritBit k v)
84 | insertLookupWithKey f k v m = insertLookupGen (,) f k v m
85 | {-# INLINABLE insertLookupWithKey #-}
86 |
87 | -- | General function used to implement all insert functions.
88 | insertLookupGen :: CritBitKey k
89 | => (Maybe v -> CritBit k v -> a)
90 | -> (k -> v -> v -> v)
91 | -> k -> v -> CritBit k v -> a
92 | insertLookupGen ret f !k v m = findPosition ret' finish setLeft setRight k m
93 | where
94 | finish _ Empty = Leaf k v
95 | finish diff (Leaf _ v')
96 | | diffOrd diff == EQ = Leaf k $ f k v v'
97 | finish diff node = internal diff node (Leaf k v)
98 |
99 | ret' a b = ret a (CritBit b)
100 | {-# INLINE insertLookupGen #-}
101 |
102 | -- | Common part of key finding/insert functions
103 | findPosition :: (CritBitKey k)
104 | => (Maybe v -> r -> t) -> (Diff -> Node k v -> r)
105 | -> (Node k v -> r -> r) -> (Node k v -> r -> r)
106 | -> k -> CritBit k v -> t
107 | findPosition ret finish toLeft toRight k (CritBit root) = go root
108 | where
109 | go i@(Internal {..})
110 | | k `onLeft` i = go ileft
111 | | otherwise = go iright
112 | go (Leaf lk lv)
113 | | diffOrd diff == EQ = ret (Just lv) $ rewalk root
114 | | otherwise = ret Nothing $ rewalk root
115 | where
116 | rewalk i@(Internal left right _ _)
117 | | diff `above` i = finish diff i
118 | | k `onLeft` i = toLeft i (rewalk left )
119 | | otherwise = toRight i (rewalk right)
120 | rewalk i = finish diff i
121 |
122 | diff = followPrefixes k lk
123 | go Empty = ret Nothing $ finish undefined Empty
124 | {-# INLINE findPosition #-}
125 |
126 | data Diff = Diff {-# UNPACK #-} !Int
127 | {-# UNPACK #-} !BitMask
128 | {-# UNPACK #-} !BitMask
129 |
130 | -- | Smart consturctor for Internal nodes
131 | internal :: Diff -> Node k v -> Node k v -> Node k v
132 | internal diff@(Diff byte bits _) child1 child2 = case diffOrd diff of
133 | LT -> Internal child1 child2 byte bits
134 | GT -> Internal child2 child1 byte bits
135 | EQ -> error "Data.CritBit.Cord.internal: Equal."
136 | {-# INLINE internal #-}
137 |
138 | setLeft :: Node k v -> Node k v -> Node k v
139 | setLeft i@(Internal{}) node = i { ileft = node }
140 | setLeft _ _ = error "Data.CritBit.Core.setLeft: Non-Internal node"
141 | {-# INLINE setLeft #-}
142 |
143 | setRight :: Node k v -> Node k v -> Node k v
144 | setRight i@(Internal{}) node = i { iright = node }
145 | setRight _ _ = error "Data.CritBit.Core.setRight: Non-Internal node"
146 | {-# INLINE setRight #-}
147 |
148 | setLeft' :: Node k v -> Node k v -> Node k v
149 | setLeft' i@(Internal{}) Empty = iright i
150 | setLeft' i@(Internal{}) child = i { ileft = child }
151 | setLeft' _ _ = error "Data.CritBit.Core.setLeft': Non-internal node"
152 | {-# INLINE setLeft' #-}
153 |
154 | setRight' :: Node k v -> Node k v -> Node k v
155 | setRight' i@(Internal{}) Empty = ileft i
156 | setRight' i@(Internal{}) child = i { iright = child }
157 | setRight' _ _ = error "Data.CritBit.Core.alter.setRight': Non-internal node"
158 | {-# INLINE setRight' #-}
159 |
160 | above :: Diff -> Node k v -> Bool
161 | above (Diff dbyte dbits _) (Internal _ _ byte bits) =
162 | dbyte < byte || dbyte == byte && dbits < bits
163 | above _ _ = error "Data.CritBit.Core.above: Non-Internal node"
164 | {-# INLINE above #-}
165 |
166 | lookupWith :: (CritBitKey k) =>
167 | a -- ^ Failure continuation
168 | -> (v -> a) -- ^ Success continuation
169 | -> k
170 | -> CritBit k v -> a
171 | -- We use continuations here to avoid reimplementing the lookup
172 | -- algorithm with trivial variations.
173 | lookupWith notFound found k (CritBit root) = go root
174 | where
175 | go i@(Internal {..})
176 | | k `onLeft` i = go ileft
177 | | otherwise = go iright
178 | go (Leaf lk v)
179 | | k == lk = found v
180 | go _ = notFound
181 | {-# INLINE lookupWith #-}
182 |
183 | -- | /O(k)/. Lookup and update; see also 'updateWithKey'.
184 | -- This function returns the changed value if it is updated, or
185 | -- the original value if the entry is deleted.
186 | --
187 | -- > let f k x = if x == 5 then Just (x + fromEnum (k < "d")) else Nothing
188 | -- > updateLookupWithKey f "a" (fromList [("b",3), ("a",5)]) == (Just 6, fromList [("a", 6), ("b",3)])
189 | -- > updateLookupWithKey f "c" (fromList [("a",5), ("b",3)]) == (Nothing, fromList [("a",5), ("b",3)])
190 | -- > updateLookupWithKey f "b" (fromList [("a",5), ("b",3)]) == (Just 3, singleton "a" 5)
191 | updateLookupWithKey :: (CritBitKey k) => (k -> v -> Maybe v) -> k
192 | -> CritBit k v -> (Maybe v, CritBit k v)
193 | -- Once again with the continuations! It's somewhat faster to do
194 | -- things this way than to expicitly unwind our recursion once we've
195 | -- found the leaf to delete. It's also a ton less code.
196 | --
197 | -- (If you want a good little exercise, rewrite this function without
198 | -- using continuations, and benchmark the two versions.)
199 | updateLookupWithKey f k t@(CritBit root) = go root (CritBit Empty) CritBit
200 | where
201 | go i@(Internal left right _ _) _ cont = dispatch i left right cont
202 | go (Leaf lk lv) other cont
203 | | k == lk = case f lk lv of
204 | Just lv' -> (Just lv', cont $! Leaf lk lv')
205 | Nothing -> (Just lv, other)
206 | | otherwise = (Nothing, t)
207 | go Empty _ _ = (Nothing, t)
208 | {-# INLINE go #-}
209 |
210 | dispatch i left right cont
211 | | k `onLeft` i = go left (cont right) $ (cont $!) . setLeft' i
212 | | otherwise = go right (cont left) $ (cont $!) . setRight' i
213 | {-# INLINABLE updateLookupWithKey #-}
214 |
215 | -- | Determine whether specified key is on the left subtree of the
216 | -- 'Internal' node.
217 | onLeft :: (CritBitKey k) => k -> Node k v -> Bool
218 | onLeft k (Internal _ _ byte bits) =
219 | (1 + (bits .|. getByte k byte)) `shiftR` 9 == 0
220 | onLeft _ _ = error "Data.CritBit.Core.onLeft: Non-Internal node"
221 | {-# INLINE onLeft #-}
222 |
223 | -- | Given a diff of two keys determines result of comparison of them.
224 | diffOrd :: Diff -> Ordering
225 | diffOrd (Diff _ bits c)
226 | | bits == 0x1ff = EQ
227 | | (1 + (bits .|. c)) `shiftR` 9 == 0 = LT
228 | | otherwise = GT
229 | {-# INLINE diffOrd #-}
230 |
231 | -- | Figure out the byte offset at which the key we are interested in
232 | -- differs from the leaf we reached when we initially walked the tree.
233 | --
234 | -- We return some auxiliary stuff that we'll bang on to help us figure
235 | -- out which direction to go in to insert a new node.
236 | followPrefixes :: (CritBitKey k) =>
237 | k -- ^ The key from "outside" the tree.
238 | -> k -- ^ Key from the leaf we reached.
239 | -> Diff
240 | followPrefixes = followPrefixesFrom 0
241 | {-# INLINE followPrefixes #-}
242 |
243 | -- | Figure out the offset of the first different byte in two keys,
244 | -- starting from specified position.
245 | --
246 | -- We return some auxiliary stuff that we'll bang on to help us figure
247 | -- out which direction to go in to insert a new node.
248 | followPrefixesFrom :: (CritBitKey k) =>
249 | Int -- ^ Positition to start from
250 | -> k -- ^ First key.
251 | -> k -- ^ Second key.
252 | -> Diff
253 | followPrefixesFrom !position !k !l = Diff n (maskLowerBits (b `xor` c)) c
254 | where
255 | n = followPrefixesByteFrom position k l
256 | b = getByte k n
257 | c = getByte l n
258 |
259 | maskLowerBits v = (n3 .&. complement (n3 `shiftR` 1)) `xor` 0x1FF
260 | where
261 | n3 = n2 .|. (n2 `shiftR` 8)
262 | n2 = n1 .|. (n1 `shiftR` 4)
263 | n1 = n0 .|. (n0 `shiftR` 2)
264 | n0 = v .|. (v `shiftR` 1)
265 | {-# INLINE followPrefixesFrom #-}
266 |
267 | -- | Figure out the offset of the first different byte in two keys,
268 | -- starting from specified position.
269 | followPrefixesByteFrom :: (CritBitKey k) =>
270 | Int -- ^ Positition to start from
271 | -> k -- ^ First key.
272 | -> k -- ^ Second key.
273 | -> Int
274 | followPrefixesByteFrom !position !k !l = go position
275 | where
276 | go !n | b /= c || b == 0 || c == 0 = n
277 | | otherwise = go (n + 1)
278 | where b = getByte k n
279 | c = getByte l n
280 | {-# INLINE followPrefixesByteFrom #-}
281 |
282 | leftmost, rightmost :: a -> (k -> v -> a) -> Node k v -> a
283 | leftmost = extremity ileft
284 | {-# INLINE leftmost #-}
285 | rightmost = extremity iright
286 | {-# INLINE rightmost #-}
287 |
288 | -- | Generic function so we can easily implement 'leftmost' and 'rightmost'.
289 | extremity :: (Node k v -> Node k v) -- ^ Either 'ileft' or 'iright'.
290 | -> a -- ^ 'Empty' continuation.
291 | -> (k -> v -> a) -- ^ 'Leaf' continuation.
292 | -> Node k v
293 | -> a
294 | extremity direct onEmpty onLeaf node = go node
295 | where
296 | go i@(Internal{}) = go $ direct i
297 | go (Leaf k v) = onLeaf k v
298 | go _ = onEmpty
299 | {-# INLINE go #-}
300 | {-# INLINE extremity #-}
301 |
--------------------------------------------------------------------------------
/Data/CritBit/Map/Lazy.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Data.CritBit.Map.Lazy
3 | -- Copyright : (c) Bryan O'Sullivan 2013
4 | -- License : BSD-style
5 | -- Maintainer : bos@serpentine.com
6 | -- Stability : experimental
7 | -- Portability : GHC
8 | --
9 | -- A crit-bit tree that does not evaluate its values by default.
10 | --
11 | -- For every /n/ key-value pairs stored, a crit-bit tree uses /n/-1
12 | -- internal nodes, for a total of 2/n/-1 internal nodes and leaves.
13 | module Data.CritBit.Map.Lazy
14 | (
15 | -- * Types
16 | CritBitKey(..)
17 | , CritBit
18 | , module Data.CritBit.Tree
19 | ) where
20 |
21 | import Data.CritBit.Tree
22 | import Data.CritBit.Types.Internal
23 |
--------------------------------------------------------------------------------
/Data/CritBit/Set.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
2 |
3 | -- |
4 | -- Module : Data.CritBit.Set
5 | -- Copyright : (c) Bryan O'Sullivan and others 2013-2014
6 | -- License : BSD-style
7 | -- Maintainer : bos@serpentine.com
8 | -- Stability : experimental
9 | -- Portability : GHC
10 | --
11 | -- A set type that uses crit-bit trees internally.
12 | --
13 | -- For every /n/ key-value pairs stored, a crit-bit tree uses /n/-1
14 | -- internal nodes, for a total of 2/n/-1 internal nodes and leaves.
15 | module Data.CritBit.Set
16 | (
17 | -- * Set type
18 | Set
19 |
20 | -- * Operators
21 | , (\\)
22 |
23 | -- * Query
24 | , null
25 | , size
26 | , member
27 | , notMember
28 | , lookupLT
29 | , lookupGT
30 | , lookupLE
31 | , lookupGE
32 | , isSubsetOf
33 | , isProperSubsetOf
34 |
35 | -- * Construction
36 | , empty
37 | , singleton
38 | , insert
39 | , delete
40 |
41 | -- * Combine
42 | , union
43 | , unions
44 | , difference
45 | , intersection
46 |
47 | -- * Filter
48 | , filter
49 | , partition
50 | , split
51 | , splitMember
52 |
53 | -- * Map
54 | , map
55 | , mapMonotonic
56 |
57 | -- * Folds
58 | , foldr
59 | , foldl
60 | -- ** Strict folds
61 | , foldr'
62 | , foldl'
63 |
64 | -- * Min\/Max
65 | , findMin
66 | , findMax
67 | , deleteMin
68 | , deleteMax
69 | , deleteFindMin
70 | , deleteFindMax
71 | , maxView
72 | , minView
73 |
74 | -- * Conversion
75 |
76 | -- ** List
77 | , elems
78 | , toList
79 | , fromList
80 |
81 | -- ** Ordered list
82 | , toAscList
83 | , toDescList
84 | , fromAscList
85 | , fromDistinctAscList
86 | ) where
87 |
88 | import Control.Arrow ((***))
89 | import Data.CritBit.Types.Internal (CritBit(..), Set(..), CritBitKey, Node(..))
90 | import Data.Foldable (Foldable, foldMap)
91 | import Data.Maybe (isJust)
92 | import Data.Monoid (Monoid(..))
93 | import Prelude hiding (null, filter, map, foldl, foldr)
94 | import qualified Data.CritBit.Tree as T
95 | import qualified Data.List as List
96 |
97 | instance (Show a) => Show (Set a) where
98 | show s = "fromList " ++ show (toList s)
99 |
100 | instance CritBitKey k => Monoid (Set k) where
101 | mempty = empty
102 | mappend = union
103 | mconcat = unions
104 |
105 | instance Foldable Set where
106 | foldMap f (Set (CritBit n)) = foldSet f n
107 |
108 | foldSet :: (Monoid m) => (a -> m) -> Node a () -> m
109 | foldSet f (Internal l r _ _) = mappend (foldSet f l) (foldSet f r)
110 | foldSet f (Leaf k _) = f k
111 | foldSet _ Empty = mempty
112 | {-# INLINABLE foldSet #-}
113 |
114 | -- | Same as 'difference'.
115 | (\\) :: CritBitKey a => Set a -> Set a -> Set a
116 | s \\ p = difference s p
117 | {-# INLINABLE (\\) #-}
118 |
119 | -- | /O(1)/. Is the set empty?
120 | --
121 | -- > null (empty) == True
122 | -- > null (singleton "a") == False
123 | null :: Set a -> Bool
124 | null (Set a) = T.null a
125 |
126 | -- | /O(1)/. The empty set.
127 | --
128 | -- > empty == fromList []
129 | -- > size empty == 0
130 | empty :: Set a
131 | empty = Set T.empty
132 | {-# INLINABLE empty #-}
133 |
134 | -- | /O(1)/. A set with a single element.
135 | --
136 | -- > singleton "a" == fromList ["a"]
137 | singleton :: a -> Set a
138 | singleton a = Set $ T.singleton a ()
139 | {-# INLINE singleton #-}
140 |
141 | -- | /O(k)/. Build a set from a list of values.
142 | --
143 | -- > fromList [] == empty
144 | -- > fromList ["a", "b", "a"] == fromList ["a", "b"]
145 | fromList :: (CritBitKey a) => [a] -> Set a
146 | fromList = liftFromList T.fromList
147 | {-# INLINABLE fromList #-}
148 |
149 | -- | /O(n)/. An alias of 'toList'.
150 | --
151 | -- Returns the elements of a set in ascending order.
152 | elems :: Set a -> [a]
153 | elems = toList
154 |
155 | -- | /O(n)/. Convert the set to a list of values. The list returned
156 | -- will be sorted in lexicographically ascending order.
157 | --
158 | -- > toList (fromList ["b", "a"]) == ["a", "b"]
159 | -- > toList empty == []
160 | toList :: Set a -> [a]
161 | toList = wrapS id T.keys
162 | {-# INLINABLE toList #-}
163 |
164 | -- | /O(n)/. The number of elements in the set.
165 | --
166 | -- > size empty == 0
167 | -- > size (singleton "a") == 1
168 | -- > size (fromList ["a", "c", "b"]) == 3
169 | size :: Set a -> Int
170 | size = wrapS id T.size
171 | {-# INLINABLE size #-}
172 |
173 | -- | /O(k)/. Is the element in the set?
174 | --
175 | -- > member "a" (fromList ["a", "b"]) == True
176 | -- > member "c" (fromList ["a", "b"]) == False
177 | --
178 | -- See also 'notMember'.
179 | member :: (CritBitKey a) => a -> Set a -> Bool
180 | member a (Set s) = T.member a s
181 | {-# INLINABLE member #-}
182 |
183 | -- | /O(k)/. Is the element not in the set?
184 | --
185 | -- > notMember "a" (fromList ["a", "b"]) == False
186 | -- > notMember "c" (fromList ["a", "b"]) == True
187 | --
188 | -- See also 'member'.
189 | notMember :: (CritBitKey a) => a -> Set a -> Bool
190 | notMember a (Set s) = T.notMember a s
191 | {-# INLINABLE notMember #-}
192 |
193 | -- | /O(k)/. Find largest element smaller than the given one.
194 | --
195 | -- > lookupLT "b" (fromList ["a", "b"]) == Just "a"
196 | -- > lookupLT "aa" (fromList ["a", "b"]) == Just "a"
197 | -- > lookupLT "a" (fromList ["a", "b"]) == Nothing
198 | lookupLT :: (CritBitKey a) => a -> Set a -> Maybe a
199 | lookupLT = wrapVS (fmap fst) T.lookupLT
200 | {-# INLINABLE lookupLT #-}
201 |
202 | -- | /O(k)/. Find smallest element greater than the given one.
203 | --
204 | -- > lookupGT "b" (fromList ["a", "b"]) == Nothing
205 | -- > lookupGT "aa" (fromList ["a", "b"]) == Just "b"
206 | -- > lookupGT "a" (fromList ["a", "b"]) == Just "b"
207 | lookupGT :: (CritBitKey a) => a -> Set a -> Maybe a
208 | lookupGT = wrapVS (fmap fst) T.lookupGT
209 | {-# INLINABLE lookupGT #-}
210 |
211 | -- | /O(k)/. Find largest element smaller than or equal to the given one.
212 | --
213 | -- > lookupGE "b" (fromList ["a", "b"]) == Just "b"
214 | -- > lookupGE "aa" (fromList ["a", "b"]) == Just "b"
215 | -- > lookupGE "a" (fromList ["a", "b"]) == Just "a"
216 | -- > lookupGE "" (fromList ["a", "b"]) == Nothing
217 | lookupLE :: (CritBitKey a) => a -> Set a -> Maybe a
218 | lookupLE = wrapVS (fmap fst) T.lookupLE
219 | {-# INLINABLE lookupLE #-}
220 |
221 | -- | /O(k)/. Find smallest element greater than or equal to the given one.
222 | --
223 | -- > lookupGE "aa" (fromList ["a", "b"]) == Just "b"
224 | -- > lookupGE "b" (fromList ["a", "b"]) == Just "b"
225 | -- > lookupGE "bb" (fromList ["a", "b"]) == Nothing
226 | lookupGE :: (CritBitKey a) => a -> Set a -> Maybe a
227 | lookupGE = wrapVS (fmap fst) T.lookupGE
228 | {-# INLINABLE lookupGE #-}
229 |
230 | -- | /O(n+m)/. Is this a subset?
231 | -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
232 | isSubsetOf :: (CritBitKey a) => Set a -> Set a -> Bool
233 | isSubsetOf = wrapSS id T.isSubmapOf
234 | {-# INLINABLE isSubsetOf #-}
235 |
236 | -- | /O(n+m)/. Is this a proper subset (ie. a subset but not equal)?
237 | -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a proper subset of @s2@.
238 | isProperSubsetOf :: (CritBitKey a) => Set a -> Set a -> Bool
239 | isProperSubsetOf = wrapSS id T.isProperSubmapOf
240 | {-# INLINABLE isProperSubsetOf #-}
241 |
242 | -- | /O(k)/. Insert an element in a set.
243 | -- If the set already contains an element equal to the given value,
244 | -- it is replaced with the new value.
245 | insert :: (CritBitKey a) => a -> Set a -> Set a
246 | insert = wrapVS Set (`T.insert` ())
247 | {-# INLINABLE insert #-}
248 |
249 | -- | /O(k)/. Delete an element from a set.
250 | delete :: (CritBitKey a) => a -> Set a -> Set a
251 | delete = wrapVS Set T.delete
252 | {-# INLINABLE delete #-}
253 |
254 | -- | /O(k)/. The union of two sets, preferring the first set when
255 | -- equal elements are encountered.
256 | union :: (CritBitKey a) => Set a -> Set a -> Set a
257 | union = wrapSS Set T.union
258 | {-# INLINABLE union #-}
259 |
260 | -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
261 | unions :: (CritBitKey a) => [Set a] -> Set a
262 | unions = List.foldl' union empty
263 | {-# INLINABLE unions #-}
264 |
265 | -- | /O(k)/. The difference of two sets.
266 | difference :: (CritBitKey a) => Set a -> Set a -> Set a
267 | difference = wrapSS Set T.difference
268 | {-# INLINABLE difference #-}
269 |
270 | -- | /O(k)/. The intersection of two sets. Elements of the
271 | -- result come from the first set.
272 | intersection :: (CritBitKey a) => Set a -> Set a -> Set a
273 | intersection = wrapSS Set T.intersection
274 | {-# INLINABLE intersection #-}
275 |
276 | -- | /O(n)/. Filter all elements that satisfy the predicate.
277 | --
278 | -- > filter (> "a") (fromList ["a", "b"]) == fromList [("3","b")]
279 | -- > filter (> "x") (fromList ["a", "b"]) == empty
280 | -- > filter (< "a") (fromList ["a", "b"]) == empty
281 | filter :: (a -> Bool) -> Set a -> Set a
282 | filter = wrapVS Set (T.filterWithKey . (const .))
283 | {-# INLINABLE filter #-}
284 |
285 | -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
286 | -- the predicate and one with all elements that don't satisfy the predicate.
287 | -- See also 'split'.
288 | partition :: (CritBitKey a) => (a -> Bool) -> Set a -> (Set a, Set a)
289 | partition = wrapVS (Set *** Set) (T.partitionWithKey . (const .))
290 | {-# INLINABLE partition #-}
291 |
292 | -- | /O(k)/. The expression (@'split' x set@) is a pair @(set1,set2)@
293 | -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
294 | -- comprises the elements of @set@ greater than @x@.
295 | --
296 | -- > split "a" (fromList ["b", "d"]) == (empty, fromList ["b", "d")])
297 | -- > split "b" (fromList ["b", "d"]) == (empty, singleton "d")
298 | -- > split "c" (fromList ["b", "d"]) == (singleton "b", singleton "d")
299 | -- > split "d" (fromList ["b", "d"]) == (singleton "b", empty)
300 | -- > split "e" (fromList ["b", "d"]) == (fromList ["b", "d"], empty)
301 | split :: (CritBitKey a) => a -> Set a -> (Set a, Set a)
302 | split = wrapVS (Set *** Set) T.split
303 | {-# INLINABLE split #-}
304 |
305 | -- | /O(k)/. Performs a 'split' but also returns whether the pivot
306 | -- element was found in the original set.
307 | --
308 | -- > splitMember "a" (fromList ["b", "d"]) == (empty, False, fromList ["b", "d"])
309 | -- > splitMember "b" (fromList ["b", "d"]) == (empty, True, singleton "d")
310 | -- > splitMember "c" (fromList ["b", "d"]) == (singleton "b", False, singleton "d")
311 | -- > splitMember "d" (fromList ["b", "d"]) == (singleton "b", True, empty)
312 | -- > splitMember "e" (fromList ["b", "d"]) == (fromList ["b", "d"], False, empty)
313 | splitMember :: (CritBitKey a) => a -> Set a -> (Set a, Bool, Set a)
314 | splitMember = wrapVS pack T.splitLookup
315 | where pack (l, m, r) = (Set l, isJust m, Set r)
316 | {-# INLINABLE splitMember #-}
317 |
318 | -- | /O(k)/. @'map' f s@ is the set obtained by applying @f@ to each
319 | -- element of @s@.
320 | --
321 | -- It's worth noting that the size of the result may be smaller if,
322 | -- for some @(x,y)@, @x \/= y && f x == f y@
323 | map :: (CritBitKey a2) => (a1 -> a2) -> Set a1 -> Set a2
324 | map = wrapVS Set T.mapKeys
325 | {-# INLINABLE map #-}
326 |
327 | -- | /O(n)/. The @'mapMonotonic' f s == 'map' f s@, but works only when
328 | -- @f@ is monotonic.
329 | -- /The precondition is not checked./
330 | -- Semi-formally, we have:
331 | --
332 | -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
333 | -- > ==> mapMonotonic f s == map f s
334 | -- > where ls = toList s
335 | mapMonotonic :: (CritBitKey a2) => (a1 -> a2) -> Set a1 -> Set a2
336 | mapMonotonic = wrapVS Set T.mapKeysMonotonic
337 | {-# INLINABLE mapMonotonic #-}
338 |
339 | -- | /O(n)/. Fold the elements in the set using the given left-associative
340 | -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.
341 | --
342 | -- For example,
343 | --
344 | -- > toDescList set = foldl (flip (:)) [] set
345 | foldl :: (a -> b -> a) -> a -> Set b -> a
346 | foldl f = wrapVS id (T.foldlWithKey ((const .) . f))
347 | {-# INLINE foldl #-}
348 |
349 | -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
350 | -- evaluated before using the result in the next application. This
351 | -- function is strict in the starting value.
352 | foldl' :: (a -> b -> a) -> a -> Set b -> a
353 | foldl' f = wrapVS id (T.foldlWithKey' ((const .) . f))
354 | {-# INLINE foldl' #-}
355 |
356 | -- | /O(n)/. Fold the elements in the set using the given right-associative
357 | -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.
358 | --
359 | -- For example,
360 | --
361 | -- > toAscList set = foldr (:) [] set
362 | foldr :: (a -> b -> b) -> b -> Set a -> b
363 | foldr f = wrapVS id (T.foldrWithKey (const . f))
364 | {-# INLINE foldr #-}
365 |
366 | -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
367 | -- evaluated before using the result in the next application. This
368 | -- function is strict in the starting value.
369 | foldr' :: (a -> b -> b) -> b -> Set a -> b
370 | foldr' f = wrapVS id (T.foldrWithKey' (const . f))
371 | {-# INLINE foldr' #-}
372 |
373 | -- | /O(k')/. The minimal element of a set.
374 | findMin :: Set a -> a
375 | findMin = wrapS fst T.findMin
376 | {-# INLINE findMin #-}
377 |
378 | -- | /O(k)/. The maximal element of a set.
379 | findMax :: Set a -> a
380 | findMax = wrapS fst T.findMax
381 | {-# INLINE findMax #-}
382 |
383 | -- | /O(k')/. Delete the minimal element. Returns an empty set if the
384 | -- set is empty.
385 | deleteMin :: Set a -> Set a
386 | deleteMin = wrapS Set T.deleteMin
387 | {-# INLINE deleteMin #-}
388 |
389 | -- | /O(k)/. Delete the maximal element. Returns an empty set if the
390 | -- set is empty.
391 | deleteMax :: Set a -> Set a
392 | deleteMax = wrapS Set T.deleteMax
393 | {-# INLINE deleteMax #-}
394 |
395 | -- | /O(k')/. Delete and find the minimal element.
396 | --
397 | -- > deleteFindMin set = (findMin set, deleteMin set)
398 | deleteFindMin :: Set a -> (a, Set a)
399 | deleteFindMin = wrapS (fst *** Set) T.deleteFindMin
400 | {-# INLINE deleteFindMin #-}
401 |
402 | -- | /O(k)/. Delete and find the maximal element.
403 | --
404 | -- > deleteFindMax set = (findMax set, deleteMax set)
405 | deleteFindMax :: Set a -> (a, Set a)
406 | deleteFindMax = wrapS (fst *** Set) T.deleteFindMax
407 | {-# INLINE deleteFindMax #-}
408 |
409 | -- | /O(k')/. Retrieves the minimal key of the set, and the set
410 | -- stripped of that element, or 'Nothing' if passed an empty set.
411 | minView :: Set a -> Maybe (a, Set a)
412 | minView = wrapS (fmap (fst *** Set)) T.minViewWithKey
413 | {-# INLINE minView #-}
414 |
415 | -- | /O(k)/. Retrieves the maximal key of the set, and the set
416 | -- stripped of that element, or 'Nothing' if passed an empty set.
417 | maxView :: Set a -> Maybe (a, Set a)
418 | maxView = wrapS (fmap (fst *** Set)) T.maxViewWithKey
419 | {-# INLINE maxView #-}
420 |
421 | -- | /O(n)/. Convert the set to an ascending list of elements.
422 | toAscList :: Set a -> [a]
423 | toAscList = toList
424 |
425 | -- | /O(n)/. Convert the set to a descending list of elements.
426 | toDescList :: Set a -> [a]
427 | toDescList = reverse . toAscList
428 |
429 | -- | /O(n)/. Build a set from an ascending list in linear time.
430 | -- /The precondition (input list is ascending) is not checked./
431 | fromAscList :: (CritBitKey a) => [a] -> Set a
432 | fromAscList = liftFromList T.fromAscList
433 |
434 | -- | /O(n)/. Build a set from an ascending list in linear time.
435 | -- /The precondition (input list is ascending) is not checked./
436 | fromDistinctAscList :: (CritBitKey a) => [a] -> Set a
437 | fromDistinctAscList = liftFromList T.fromDistinctAscList
438 |
439 | -- | Wraps tree operation to set operation
440 | wrapS :: (r -> q) -> (CritBit a () -> r) -> Set a -> q
441 | wrapS f g (Set s) = f $ g s
442 | {-# INLINE wrapS #-}
443 |
444 | -- | Wraps (value, tree) operation to (value, set) operation
445 | wrapVS :: (r -> q) -> (t -> CritBit a () -> r) -> t -> Set a -> q
446 | wrapVS f g a (Set s) = f $ g a s
447 | {-# INLINE wrapVS #-}
448 |
449 | -- | Wraps (tree, tree) operation to (set, set) operation
450 | wrapSS :: (r -> q) -> (CritBit a () -> CritBit a () -> r) -> Set a -> Set a -> q
451 | wrapSS f g (Set s1) (Set s2) = f $ g s1 s2
452 | {-# INLINE wrapSS #-}
453 |
454 | liftFromList :: ([(a, ())] -> CritBit a ()) -> [a] -> Set a
455 | liftFromList f xs = Set . f . zip xs . repeat $ ()
456 | {-# INLINE liftFromList #-}
457 |
--------------------------------------------------------------------------------
/Data/CritBit/Tree.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, RecordWildCards, ScopedTypeVariables #-}
2 | {-# OPTIONS_GHC -fno-warn-orphans #-}
3 |
4 | -- |
5 | -- Module : Data.CritBit.Tree
6 | -- Copyright : (c) Bryan O'Sullivan and others 2013-2014
7 | -- License : BSD-style
8 | -- Maintainer : bos@serpentine.com
9 | -- Stability : experimental
10 | -- Portability : GHC
11 | module Data.CritBit.Tree
12 | (
13 | -- * Operators
14 | (!)
15 | , (\\)
16 |
17 | -- * Query
18 | , null
19 | , size
20 | , member
21 | , notMember
22 | , lookup
23 | , findWithDefault
24 | , lookupGT
25 | , lookupGE
26 | , lookupLT
27 | , lookupLE
28 |
29 | -- * Construction
30 | , empty
31 | , singleton
32 |
33 | -- * Insertion
34 | , insert
35 | , insertWith
36 | , insertWithKey
37 | , insertLookupWithKey
38 |
39 | -- * Deletion
40 | , delete
41 | , adjust
42 | , adjustWithKey
43 | , update
44 | , updateWithKey
45 | , updateLookupWithKey
46 | , alter
47 |
48 | -- * Combination
49 | -- ** Union
50 | , union
51 | , unionWith
52 | , unionWithKey
53 | , unions
54 | , unionsWith
55 | , unionL
56 | , unionR
57 |
58 | -- ** Difference
59 | , difference
60 | , differenceWith
61 | , differenceWithKey
62 |
63 | -- ** Intersection
64 | , intersection
65 | , intersectionWith
66 | , intersectionWithKey
67 |
68 | -- * Traversal
69 | -- ** Map
70 | , map
71 | , mapWithKey
72 | , traverseWithKey
73 | , mapAccum
74 | , mapAccumWithKey
75 | , mapAccumRWithKey
76 | , mapKeys
77 | , mapKeysWith
78 | , mapKeysMonotonic
79 |
80 | -- * Folds
81 | , foldl
82 | , foldr
83 | , foldlWithKey
84 | , foldrWithKey
85 |
86 | -- ** Strict folds
87 | , foldl'
88 | , foldr'
89 | , foldlWithKey'
90 | , foldrWithKey'
91 |
92 | -- * Conversion
93 | , elems
94 | , keys
95 | , assocs
96 | , keysSet
97 | , fromSet
98 |
99 | -- ** Lists
100 | , toList
101 | , fromList
102 | , fromListWith
103 | , fromListWithKey
104 |
105 | -- ** Ordered lists
106 | , toAscList
107 | , toDescList
108 | , fromAscList
109 | , fromAscListWith
110 | , fromAscListWithKey
111 | , fromDistinctAscList
112 |
113 | -- * Filter
114 | , filter
115 | , filterWithKey
116 | , partition
117 | , partitionWithKey
118 |
119 | , mapMaybe
120 | , mapMaybeWithKey
121 | , mapEither
122 | , mapEitherWithKey
123 |
124 | , split
125 | , splitLookup
126 |
127 | -- * Submap
128 | , isSubmapOf
129 | , isSubmapOfBy
130 | , isProperSubmapOf
131 | , isProperSubmapOfBy
132 |
133 | -- -- * Min\/Max
134 | , findMin
135 | , findMax
136 | , deleteMin
137 | , deleteMax
138 | , deleteFindMin
139 | , deleteFindMax
140 | , updateMin
141 | , updateMax
142 | , updateMinWithKey
143 | , updateMaxWithKey
144 | , minView
145 | , maxView
146 | , minViewWithKey
147 | , maxViewWithKey
148 | ) where
149 |
150 | import Control.Applicative (Applicative(..), (<$>), (<|>))
151 | import Control.Arrow (second, (***))
152 | import Data.CritBit.Core
153 | import Data.CritBit.Types.Internal
154 | import Data.Maybe (fromMaybe)
155 | import Data.Monoid (Monoid(..))
156 | import Data.Traversable (Traversable(traverse))
157 | import Prelude hiding (foldl, foldr, lookup, null, map, filter)
158 | import qualified Data.Array as A
159 | import qualified Data.Foldable as Foldable
160 | import qualified Data.List as List
161 |
162 | instance CritBitKey k => Monoid (CritBit k v) where
163 | mempty = empty
164 | mappend = union
165 | mconcat = unions
166 |
167 | instance CritBitKey k => Traversable (CritBit k) where
168 | traverse f m = traverseWithKey (\_ v -> f v) m
169 |
170 | infixl 9 !, \\
171 |
172 | -- | /O(k)/. Find the value at a key.
173 | -- Calls 'error' when the element can not be found.
174 | --
175 | -- > fromList [("a",5), ("b",3)] ! "c" Error: element not in the map
176 | -- > fromList [("a",5), ("b",3)] ! "a" == 5
177 | (!) :: CritBitKey k => CritBit k v -> k -> v
178 | (!) m k = lookupWith err id k m
179 | where err = error "CritBit.!: given key is not an element in the map"
180 | {-# INLINABLE (!) #-}
181 |
182 | -- | Same as 'difference'.
183 | (\\) :: CritBitKey k => CritBit k v -> CritBit k w -> CritBit k v
184 | (\\) m n = difference m n
185 | {-# INLINABLE (\\) #-}
186 |
187 | -- | /O(1)/. Is the map empty?
188 | --
189 | -- > null (empty) == True
190 | -- > null (singleton 1 'a') == False
191 | null :: CritBit k v -> Bool
192 | null (CritBit Empty) = True
193 | null _ = False
194 |
195 | -- | /O(1)/. The empty map.
196 | --
197 | -- > empty == fromList []
198 | -- > size empty == 0
199 | empty :: CritBit k v
200 | empty = CritBit Empty
201 |
202 | -- | /O(k)/. Is the key a member of the map?
203 | --
204 | -- > member "a" (fromList [("a",5), ("b",3)]) == True
205 | -- > member "c" (fromList [("a",5), ("b",3)]) == False
206 | --
207 | -- See also 'notMember'.
208 | member :: (CritBitKey k) => k -> CritBit k v -> Bool
209 | member k m = lookupWith False (const True) k m
210 | {-# INLINABLE member #-}
211 |
212 | -- | /O(k)/. Is the key not a member of the map?
213 | --
214 | -- > notMember "a" (fromList [("a",5), ("b",3)]) == False
215 | -- > notMember "c" (fromList [("a",5), ("b",3)]) == True
216 | --
217 | -- See also 'member'.
218 | notMember :: (CritBitKey k) => k -> CritBit k v -> Bool
219 | notMember k m = lookupWith True (const False) k m
220 | {-# INLINE notMember #-}
221 |
222 | -- | /O(k)/. Lookup the value at a key in the map.
223 | --
224 | -- The function will return the corresponding value as @('Just' value)@,
225 | -- or 'Nothing' if the key isn't in the map.
226 | --
227 | -- An example of using @lookup@:
228 | --
229 | -- > {-# LANGUAGE OverloadedStrings #-}
230 | -- > import Data.Text
231 | -- > import Prelude hiding (lookup)
232 | -- > import Data.CritBit.Map.Lazy
233 | -- >
234 | -- > employeeDept, deptCountry, countryCurrency :: CritBit Text Text
235 | -- > employeeDept = fromList [("John","Sales"), ("Bob","IT")]
236 | -- > deptCountry = fromList [("IT","USA"), ("Sales","France")]
237 | -- > countryCurrency = fromList [("USA", "Dollar"), ("France", "Euro")]
238 | -- >
239 | -- > employeeCurrency :: Text -> Maybe Text
240 | -- > employeeCurrency name = do
241 | -- > dept <- lookup name employeeDept
242 | -- > country <- lookup dept deptCountry
243 | -- > lookup country countryCurrency
244 | -- >
245 | -- > main = do
246 | -- > putStrLn $ "John's currency: " ++ show (employeeCurrency "John")
247 | -- > putStrLn $ "Pete's currency: " ++ show (employeeCurrency "Pete")
248 | --
249 | -- The output of this program:
250 | --
251 | -- > John's currency: Just "Euro"
252 | -- > Pete's currency: Nothing
253 | lookup :: (CritBitKey k) => k -> CritBit k v -> Maybe v
254 | lookup k m = lookupWith Nothing Just k m
255 | {-# INLINABLE lookup #-}
256 |
257 | -- | /O(k)/. Delete a key and its value from the map. When the key
258 | -- is not a member of the map, the original map is returned.
259 | --
260 | -- > delete "a" (fromList [("a",5), ("b",3)]) == singleton "b" 3
261 | -- > delete "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
262 | -- > delete "a" empty == empty
263 | delete :: (CritBitKey k) => k -> CritBit k v -> CritBit k v
264 | delete k t@(CritBit root) = go root empty CritBit
265 | where
266 | go i@(Internal left right _ _) _ cont
267 | | k `onLeft` i = go left (cont right) $ ((cont $!) . setLeft i)
268 | | otherwise = go right (cont left) $ ((cont $!) . setRight i)
269 | go (Leaf lk _) other _
270 | | k == lk = other
271 | | otherwise = t
272 | go Empty _ _ = t
273 | {-# INLINABLE delete #-}
274 |
275 | -- | /O(k)/. The expression (@'update' f k map@ updates the value @x@
276 | -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
277 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
278 | --
279 | -- > let f x = if x == 5 then Just 50 else Nothing
280 | -- > update f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 50), ("b",3)]
281 | -- > update f "c" (fromList [("b",3), ("a",5)]) == fromList [("a", 50), ("b",3)]
282 | -- > update f "b" (fromList [("b",3), ("a",5)]) == singleton "a" 5
283 | update :: (CritBitKey k) => (v -> Maybe v) -> k -> CritBit k v -> CritBit k v
284 | update f = updateWithKey (const f)
285 | {-# INLINABLE update #-}
286 |
287 | -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
288 | -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
289 | -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
290 | -- to the new value @y@.
291 | --
292 | -- > let f k x = if x == 5 then Just (x + fromEnum (k < "d")) else Nothing
293 | -- > updateWithKey f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 6), ("b",3)]
294 | -- > updateWithKey f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
295 | -- > updateWithKey f "b" (fromList [("a",5), ("b",3)]) == singleton "a" 5
296 | updateWithKey :: (CritBitKey k) => (k -> v -> Maybe v) -> k -> CritBit k v
297 | -> CritBit k v
298 | updateWithKey f k = snd . updateLookupWithKey f k
299 | {-# INLINABLE updateWithKey #-}
300 |
301 | -- | /O(k)/. Update a value at a specific key with the result of the
302 | -- provided function. When the key is not a member of the map, the original
303 | -- map is returned.
304 | --
305 | -- > let f k x = x + 1
306 | -- > adjustWithKey f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 6), ("b",3)]
307 | -- > adjustWithKey f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
308 | -- > adjustWithKey f "c" empty == empty
309 | adjust :: (CritBitKey k) => (v -> v) -> k -> CritBit k v -> CritBit k v
310 | adjust f = updateWithKey (\_ v -> Just (f v))
311 | {-# INLINABLE adjust #-}
312 |
313 | -- | /O(k)/. Adjust a value at a specific key. When the key is not
314 | -- a member of the map, the original map is returned.
315 | --
316 | -- > let f k x = x + fromEnum (k < "d")
317 | -- > adjustWithKey f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 6), ("b",3)]
318 | -- > adjustWithKey f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
319 | -- > adjustWithKey f "c" empty == empty
320 | adjustWithKey :: (CritBitKey k) => (k -> v -> v) -> k -> CritBit k v
321 | -> CritBit k v
322 | adjustWithKey f = updateWithKey (\k v -> Just (f k v))
323 | {-# INLINABLE adjustWithKey #-}
324 |
325 | -- | /O(k)/. Returns the value associated with the given key, or
326 | -- the given default value if the key is not in the map.
327 | --
328 | -- > findWithDefault 1 "x" (fromList [("a",5), ("b",3)]) == 1
329 | -- > findWithDefault 1 "a" (fromList [("a",5), ("b",3)]) == 5
330 | findWithDefault :: (CritBitKey k) =>
331 | v -- ^ Default value to return if lookup fails.
332 | -> k -> CritBit k v -> v
333 | findWithDefault d k m = lookupWith d id k m
334 | {-# INLINABLE findWithDefault #-}
335 |
336 | -- | /O(k)/. Find smallest key greater than the given one and
337 | -- return the corresponding (key, value) pair.
338 | --
339 | -- > lookupGT "aa" (fromList [("a",3), ("b",5)]) == Just ("b",5)
340 | -- > lookupGT "b" (fromList [("a",3), ("b",5)]) == Nothing
341 | lookupGT :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
342 | lookupGT k r = lookupOrd (GT ==) k r
343 | {-# INLINABLE lookupGT #-}
344 |
345 | -- | /O(k)/. Find smallest key greater than or equal to the given one and
346 | -- return the corresponding (key, value) pair.
347 | --
348 | -- > lookupGE "aa" (fromList [("a",3), ("b",5)]) == Just("b",5)
349 | -- > lookupGE "b" (fromList [("a",3), ("b",5)]) == Just("b",5)
350 | -- > lookupGE "bb" (fromList [("a",3), ("b",5)]) == Nothing
351 | lookupGE :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
352 | lookupGE k r = lookupOrd (LT /=) k r
353 | {-# INLINABLE lookupGE #-}
354 |
355 | -- | /O(k)/. Find largest key smaller than the given one and
356 | -- return the corresponding (key, value) pair.
357 | --
358 | -- > lookupLT "aa" (fromList [("a",3), ("b",5)]) == Just ("a",3)
359 | -- > lookupLT "a" (fromList [("a",3), ("b",5)]) == Nothing
360 | lookupLT :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
361 | lookupLT k r = lookupOrd (LT ==) k r
362 | {-# INLINABLE lookupLT #-}
363 |
364 | -- | /O(k)/. Find largest key smaller than or equal to the given one and
365 | -- return the corresponding (key, value) pair.
366 | --
367 | -- > lookupGE "bb" (fromList [("aa",3), ("b",5)]) == Just("b",5)
368 | -- > lookupGE "aa" (fromList [("aa",3), ("b",5)]) == Just("aa",5)
369 | -- > lookupGE "a" (fromList [("aa",3), ("b",5)]) == Nothing
370 | lookupLE :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
371 | lookupLE k r = lookupOrd (GT /=) k r
372 | {-# INLINABLE lookupLE #-}
373 |
374 | -- | /O(k)/. Common part of lookupXX functions.
375 | lookupOrd :: (CritBitKey k) =>
376 | (Ordering -> Bool) -> k -> CritBit k v -> Maybe (k, v)
377 | lookupOrd accepts k m = findPosition (const id) finish toLeft toRight k m
378 | where
379 | finish _ Empty = Nothing
380 | finish diff (Leaf lk lv)
381 | | accepts (diffOrd diff) = pair lk lv
382 | | otherwise = Nothing
383 | finish diff i@(Internal{}) = case diffOrd diff of
384 | LT -> ifLT i
385 | GT -> ifGT i
386 | EQ -> error "Data.CritBit.Tree.lookupOrd.finish: Unpossible."
387 |
388 | toLeft i = (<|> ifGT (iright i))
389 | toRight i = (<|> ifLT (ileft i))
390 | pair a b = Just (a, b)
391 | ifGT = test GT leftmost
392 | ifLT = test LT rightmost
393 | test v f node
394 | | accepts v = f Nothing pair node
395 | | otherwise = Nothing
396 | {-# INLINE lookupOrd #-}
397 |
398 | -- | /O(k)/. Build a map from a list of key\/value pairs. If
399 | -- the list contains more than one value for the same key, the last
400 | -- value for the key is retained.
401 | --
402 | -- > fromList [] == empty
403 | -- > fromList [("a",5), ("b",3), ("a",2)] == fromList [("a",2), ("b",3)]
404 | fromList :: (CritBitKey k) => [(k, v)] -> CritBit k v
405 | fromList = List.foldl' ins empty
406 | where
407 | ins t (k,x) = insert k x t
408 | {-# INLINABLE fromList #-}
409 |
410 | -- | /O(k)/. Build a map from a list of key\/value pairs
411 | -- with a combining function. See also 'fromAscListWith'.
412 | --
413 | -- > fromListWith (+) [("a",5), ("b",5), ("b",3), ("a",3), ("a",5)] ==
414 | -- > fromList [("a",13), ("b",8)]
415 | -- > fromListWith (+) [] == empty
416 | fromListWith :: (CritBitKey k) => (v -> v -> v) -> [(k,v)] -> CritBit k v
417 | fromListWith f xs = fromListWithKey (const f) xs
418 | {-# INLINABLE fromListWith #-}
419 |
420 | -- | /O(k)/. Build a map from a list of key\/value pairs
421 | -- with a combining function. See also 'fromAscListWithKey'.
422 | --
423 | -- > let f key a1 a2 = byteCount key + a1 + a2
424 | -- > fromListWithKey f [("a",5), ("b",5), ("b",3), ("a",3), ("a",5)] ==
425 | -- > fromList [("a",16), ("b",10)]
426 | -- > fromListWithKey f [] == empty
427 | fromListWithKey :: (CritBitKey k) =>
428 | (k -> v -> v -> v) -> [(k,v)] -> CritBit k v
429 | fromListWithKey f xs
430 | = List.foldl' ins empty xs
431 | where
432 | ins t (k,x) = insertWithKey f k x t
433 | {-# INLINABLE fromListWithKey #-}
434 |
435 | -- | /O(1)/. A map with a single element.
436 | --
437 | -- > singleton "a" 1 == fromList [("a",1)]
438 | singleton :: k -> v -> CritBit k v
439 | singleton k v = CritBit (Leaf k v)
440 | {-# INLINE singleton #-}
441 |
442 | -- | /O(n)/. The number of elements in the map.
443 | --
444 | -- > size empty == 0
445 | -- > size (singleton "a" 1) == 1
446 | -- > size (fromList [("a",1), ("c",2), ("b",3)]) == 3
447 | size :: CritBit k v -> Int
448 | size (CritBit root) = go root 0
449 | where
450 | go (Internal{..}) !c = go iright (go ileft c)
451 | go (Leaf{}) c = c + 1
452 | go Empty c = c
453 |
454 | -- | /O(n)/. Fold the values in the map using the given
455 | -- left-associative function, such that
456 | -- @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.
457 | --
458 | -- Examples:
459 | --
460 | -- > elems = reverse . foldl (flip (:)) []
461 | --
462 | -- > foldl (+) 0 (fromList [("a",5), ("bbb",3)]) == 8
463 | foldl :: (a -> v -> a) -> a -> CritBit k v -> a
464 | foldl f z m = Foldable.foldl f z m
465 | {-# INLINE foldl #-}
466 |
467 | -- | /O(n)/. A strict version of 'foldl'. Each application of the
468 | -- function is evaluated before using the result in the next
469 | -- application. This function is strict in the starting value.
470 | foldl' :: (a -> v -> a) -> a -> CritBit k v -> a
471 | foldl' f z m = foldlWithKey' (\a _ v -> f a v) z m
472 | {-# INLINABLE foldl' #-}
473 |
474 | -- | /O(n)/. Fold the values in the map using the given
475 | -- right-associative function, such that
476 | -- @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.
477 | --
478 | -- Example:
479 | --
480 | -- > elems map = foldr (:) [] map
481 | foldr :: (v -> a -> a) -> a -> CritBit k v -> a
482 | foldr f z m = Foldable.foldr f z m
483 | {-# INLINE foldr #-}
484 |
485 | -- | /O(n)/. A strict version of 'foldr'. Each application of the
486 | -- function is evaluated before using the result in the next
487 | -- application. This function is strict in the starting value.
488 | foldr' :: (v -> a -> a) -> a -> CritBit k v -> a
489 | foldr' f z m = foldrWithKey' (const f) z m
490 | {-# INLINABLE foldr' #-}
491 |
492 | -- | /O(n)/. Return all the elements of the map in ascending order of
493 | -- their keys.
494 | --
495 | -- > elems (fromList [("b",5), ("a",3)]) == [3,5]
496 | -- > elems empty == []
497 | elems :: CritBit k v -> [v]
498 | elems m = foldr (:) [] m
499 | {-# INLINE elems #-}
500 |
501 | -- | /O(n)/. An alias for 'toAscList'. Return all key/value pairs in the map in
502 | -- ascending order.
503 | --
504 | -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
505 | -- > assocs empty == []
506 | assocs :: CritBit k v -> [(k,v)]
507 | assocs m = toAscList m
508 |
509 | -- | /O(n)/. Return set of all keys of the map.
510 | --
511 | -- > keysSet (fromList [("b",5), ("a",3)]) == Set.fromList ["a", "b"]
512 | -- > keysSet empty == []
513 | keysSet :: CritBit k v -> Set k
514 | keysSet m = Set (fmap (const ()) m)
515 | {-# INLINABLE keysSet #-}
516 |
517 | -- | /O(n)/. Build a map from a set of keys and a function which for each key
518 | -- computes its value.
519 | --
520 | -- > fromSet (\k -> length k) (Data.IntSet.fromList ["a", "bb"]) == fromList [("a",1), ("bb",2)]
521 | -- > fromSet undefined Data.IntSet.empty == empty
522 | fromSet :: (k -> v) -> Set k -> CritBit k v
523 | fromSet f (Set s) = mapWithKey (const . f) s
524 | {-# INLINABLE fromSet #-}
525 |
526 | -- | /O(n)/. Return all keys of the map in ascending order.
527 | --
528 | -- > keys (fromList [("b",5), ("a",3)]) == ["a","b"]
529 | -- > keys empty == []
530 | keys :: CritBit k v -> [k]
531 | keys (CritBit root) = go root []
532 | where
533 | go (Internal{..}) acc = go ileft $ go iright acc
534 | go (Leaf k _) acc = k : acc
535 | go Empty acc = acc
536 | {-# INLINABLE keys #-}
537 |
538 | unionL :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v
539 | unionL a b = unionWithKey (\_ x _ -> x) a b
540 | {-# INLINABLE unionL #-}
541 |
542 | unionR :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v
543 | unionR a b = unionWithKey (\_ x _ -> x) b a
544 | {-# INLINABLE unionR #-}
545 |
546 | -- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased
547 | -- union of @t1@ and @t2@.
548 | --
549 | -- It prefers @t1@ when duplicate keys are encountered,
550 | -- i.e. (@'union' == 'unionWith' 'const'@).
551 | --
552 | -- > union (fromList [("a", 5), ("b", 3)]) (fromList [("a", 4), ("c", 7)]) == fromList [("a", 5), ("b", "3"), ("c", 7)]
553 | union :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v
554 | union a b = unionL a b
555 | {-# INLINE union #-}
556 |
557 | -- | Union with a combining function.
558 | --
559 | -- > let l = fromList [("a", 5), ("b", 3)]
560 | -- > let r = fromList [("A", 5), ("b", 7)]
561 | -- > unionWith (+) l r == fromList [("A",5),("a",5),("b",10)]
562 | unionWith :: (CritBitKey k) => (v -> v -> v)
563 | -> CritBit k v -> CritBit k v -> CritBit k v
564 | unionWith f a b = unionWithKey (const f) a b
565 |
566 | -- | Union with a combining function.
567 | --
568 | -- > let f key new_value old_value = byteCount key + new_value + old_value
569 | -- > let l = fromList [("a", 5), ("b", 3)]
570 | -- > let r = fromList [("A", 5), ("C", 7)]
571 | -- > unionWithKey f l r == fromList [("A",5),("C",7),("a",5),("b",3)]
572 | unionWithKey :: (CritBitKey k) => (k -> v -> v -> v)
573 | -> CritBit k v -> CritBit k v -> CritBit k v
574 | unionWithKey f (CritBit lt) (CritBit rt) = CritBit (top lt rt)
575 | where
576 | -- Assumes that empty nodes exist only on the top level
577 | top Empty b = b
578 | top a Empty = a
579 | top a b = go a (minKey a) b (minKey b)
580 |
581 | -- Each node is followed by the minimum key in that node.
582 | -- This trick assures that overall time spend by minKey in O(n+m)
583 | go a@(Leaf ak av) _ b@(Leaf bk bv) _
584 | | ak == bk = Leaf ak (f ak av bv)
585 | | otherwise = fork a ak b bk
586 | go a@(Leaf{}) ak b@(Internal{}) bk =
587 | leafBranch a b bk (splitB a ak b bk) (fork a ak b bk)
588 | go a@(Internal{}) ak b@(Leaf{}) bk =
589 | leafBranch b a ak (splitA a ak b bk) (fork a ak b bk)
590 | go a@(Internal al ar abyte abits) ak b@(Internal bl br bbyte bbits) bk
591 | | (dbyte, dbits) < min (abyte, abits) (bbyte, bbits) = fork a ak b bk
592 | | otherwise =
593 | case compare (abyte, abits) (bbyte, bbits) of
594 | LT -> splitA a ak b bk
595 | GT -> splitB a ak b bk
596 | EQ -> setBoth' a (go al ak bl bk) (go ar (minKey ar) br (minKey br))
597 | where
598 | Diff dbyte dbits _ = followPrefixes ak bk
599 | -- Assumes that empty nodes exist only on the top level
600 | go _ _ _ _ = error "Data.CritBit.Tree.unionWithKey.go: Empty"
601 |
602 | splitA a@(Internal al ar _ _) ak b bk =
603 | switch bk a (go al ak b bk) ar al (go ar (minKey ar) b bk)
604 | splitA _ _ _ _ =
605 | error "Data.CritBit.Tree.unionWithKey.splitA: unpossible"
606 | {-# INLINE splitA #-}
607 |
608 | splitB a ak b@(Internal bl br _ _) bk =
609 | switch ak b (go a ak bl bk) br bl (go a ak br (minKey br))
610 | splitB _ _ _ _ =
611 | error "Data.CritBit.Tree.unionWithKey.splitB: unpossible"
612 | {-# INLINE splitB #-}
613 |
614 | fork a ak b bk = internal (followPrefixes ak bk) b a
615 | {-# INLINE fork #-}
616 | {-# INLINEABLE unionWithKey #-}
617 |
618 | -- | The union of a list of maps:
619 | -- (@'unions' == 'List.foldl' 'union' 'empty'@).
620 | --
621 | -- > unions [(fromList [("a", 5), ("b", 3)]), (fromList [("a", 6), ("c", 7)]), (fromList [("a", 9), ("b", 5)])]
622 | -- > == fromList [("a", 5), ("b", 4), (c, 7)]
623 | -- > unions [(fromList [("a", 9), ("b", 8)]), (fromList [("ab", 5), ("c",7)]), (fromList [("a", 5), ("b", 3)])]
624 | -- > == fromList [("a", 9), ("ab", 5), ("b", 8), ("c", 7)]
625 | unions :: (CritBitKey k) => [CritBit k v] -> CritBit k v
626 | unions cs = List.foldl' union empty cs
627 |
628 | -- | The union of a list of maps, with a combining operation:
629 | -- (@'unionsWith' f == 'List.foldl' ('unionWith' f) 'empty'@).
630 | --
631 | -- > unionsWith (+) [(fromList [("a",5), ("b", 3)]), (fromList [("a", 3), ("c", 7)]), (fromList [("a", 5), ("b", 5)])]
632 | -- > == fromList [("a", 12), ("b", 8), ("c")]
633 | unionsWith :: (CritBitKey k) => (v -> v -> v) -> [CritBit k v] -> CritBit k v
634 | unionsWith f cs = List.foldl' (unionWith f) empty cs
635 |
636 | -- | /O(n+m)/. Difference of two maps.
637 | -- | Return data in the first map not existing in the second map.
638 | --
639 | -- > let l = fromList [("a", 5), ("b", 3)]
640 | -- > let r = fromList [("A", 2), ("b", 7)]
641 | -- > difference l r == fromList [("a", 5)]
642 | difference :: (CritBitKey k) => CritBit k v -> CritBit k w -> CritBit k v
643 | difference a b = differenceWithKey (\_ _ _ -> Nothing) a b
644 | {-# INLINEABLE difference #-}
645 |
646 | -- | /O(n+m)/. Difference with a combining function.
647 | -- | When two equal keys are encountered, the combining function is applied
648 | -- | to the values of theese keys. If it returns 'Nothing', the element is
649 | -- | discarded (proper set difference). If it returns (@'Just' y@),
650 | -- | the element is updated with a new value @y@.
651 | --
652 | -- > let f av bv = if av == 3 then Just (av + bv) else Nothing
653 | -- > let l = fromList [(pack "a", 5), (pack "b", 3), (pack "c", 8)]
654 | -- > let r = fromList [(pack "a", 2), (pack "b", 7), (pack "d", 8)]
655 | -- > differenceWith f l r == fromList [(pack "b", 10), (pack "c", 8)]
656 | differenceWith :: (CritBitKey k) => (v -> w -> Maybe v)
657 | -> CritBit k v -> CritBit k w -> CritBit k v
658 | differenceWith f a b = differenceWithKey (const f) a b
659 | {-# INLINEABLE differenceWith #-}
660 |
661 | -- | /O(n+m)/. Difference with a combining function.
662 | -- | When two equal keys are encountered, the combining function is applied
663 | -- | to the key and both values. If it returns 'Nothing', the element is
664 | -- | discarded (proper set difference). If it returns (@'Just' y@),
665 | -- | the element is updated with a new value @y@.
666 | --
667 | -- > let f k av bv = if k == "b" then Just (length k + av + bv) else Nothing
668 | -- > let l = fromList [("a", 5), ("b", 3), ("c", 8)]
669 | -- > let r = fromList [("a", 2), ("b", 7), ("d", 8)]
670 | -- > differenceWithKey f l r == fromList [("b", 11), ("c", 8)]
671 | differenceWithKey :: (CritBitKey k) => (k -> v -> w -> Maybe v)
672 | -> CritBit k v -> CritBit k w -> CritBit k v
673 | differenceWithKey = binarySetOpWithKey id
674 | {-# INLINEABLE differenceWithKey #-}
675 |
676 | -- | /O(n+m)/. Intersection of two maps.
677 | -- | Return data in the first map for the keys existing in both maps.
678 | --
679 | -- > let l = fromList [("a", 5), ("b", 3)]
680 | -- > let r = fromList [("A", 2), ("b", 7)]
681 | -- > intersection l r == fromList [("b", 3)]
682 | intersection :: (CritBitKey k) => CritBit k v -> CritBit k w -> CritBit k v
683 | intersection a b = intersectionWithKey (\_ x _ -> x) a b
684 | {-# INLINEABLE intersection #-}
685 |
686 | -- | /O(n+m)/. Intersection with a combining function.
687 | --
688 | -- > let l = fromList [("a", 5), ("b", 3)]
689 | -- > let r = fromList [("A", 2), ("b", 7)]
690 | -- > intersectionWith (+) l r == fromList [("b", 10)]
691 | intersectionWith :: (CritBitKey k) => (v -> w -> x)
692 | -> CritBit k v -> CritBit k w -> CritBit k x
693 | intersectionWith f a b = intersectionWithKey (const f) a b
694 | {-# INLINEABLE intersectionWith #-}
695 |
696 | -- | /O(n+m)/. Intersection with a combining function.
697 | --
698 | -- > let f key new_value old_value = length key + new_value + old_value
699 | -- > let l = fromList [("a", 5), ("b", 3)]
700 | -- > let r = fromList [("A", 2), ("b", 7)]
701 | -- > intersectionWithKey f l r == fromList [("b", 11)]
702 | intersectionWithKey :: (CritBitKey k) => (k -> v -> w -> x)
703 | -> CritBit k v -> CritBit k w -> CritBit k x
704 | intersectionWithKey f = binarySetOpWithKey (const Empty) f'
705 | where
706 | f' k v1 v2 = Just (f k v1 v2)
707 |
708 | -- | Perform binary set operation on two maps.
709 | binarySetOpWithKey :: (CritBitKey k)
710 | => (Node k v -> Node k x) -- ^ Process unmatched node in first map
711 | -> (k -> v -> w -> Maybe x) -- ^ Process matching values
712 | -> CritBit k v -- ^ First map
713 | -> CritBit k w -- ^ Second map
714 | -> CritBit k x
715 | binarySetOpWithKey left both (CritBit lt) (CritBit rt) = CritBit $ top lt rt
716 | where
717 | -- Assumes that empty nodes exist only on the top level.
718 | top Empty _ = Empty
719 | top a Empty = left a
720 | top a b = go a (minKey a) b (minKey b)
721 |
722 | -- Each node is followed by the minimum key in that node.
723 | -- This trick assures that overall time spend by minKey is O(n+m).
724 | go a@(Leaf ak av) _ (Leaf bk bv) _
725 | | ak == bk = case both ak av bv of
726 | Just v -> Leaf ak v
727 | Nothing -> Empty
728 | | otherwise = left a
729 | go a@(Leaf{}) ak b@(Internal{}) bk =
730 | leafBranch a b bk (splitB a ak b bk) (left a)
731 | go a@(Internal{}) ak b@(Leaf{}) bk =
732 | leafBranch b a ak (splitA a ak b bk) (left a)
733 | go a@(Internal al ar abyte abits) ak b@(Internal bl br bbyte bbits) bk =
734 | case compare (abyte, abits) (bbyte, bbits) of
735 | LT -> splitA a ak b bk
736 | GT -> splitB a ak b bk
737 | EQ -> setBoth' a (go al ak bl bk) (go ar (minKey ar) br (minKey br))
738 | -- Assumes that empty nodes exist only on the top level.
739 | go _ _ _ _ = error "Data.CritBit.Tree.binarySetOpWithKey.go: Empty"
740 |
741 | splitA a@(Internal al ar _ _) ak b bk =
742 | switch bk a (go al ak b bk) (left ar) (left al) (go ar (minKey ar) b bk)
743 | splitA _ _ _ _ =
744 | error "Data.CritBit.Tree.binarySetOpWithKey.splitA: unpossible"
745 | {-# INLINE splitA #-}
746 |
747 | splitB a ak b@(Internal bl br _ _) bk =
748 | switch ak b (go a ak bl bk) Empty Empty (go a ak br (minKey br))
749 | splitB _ _ _ _ =
750 | error "Data.CritBit.Tree.binarySetOpWithKey.splitB: unpossible"
751 | {-# INLINE splitB #-}
752 | {-# INLINEABLE binarySetOpWithKey #-}
753 |
754 | -- | Detect whether branch in 'Internal' node comes 'before' or
755 | -- 'after' branch initiated by 'Leaf'.
756 | leafBranch :: CritBitKey k => Node k v -> Node k w -> k -> t -> t -> t
757 | leafBranch (Leaf lk _) i@(Internal{}) sk before after
758 | | followPrefixes lk sk `above` i = after
759 | | otherwise = before
760 | leafBranch _ _ _ _ _ = error "Data.CritBit.Tree.leafBranch: unpossible"
761 | {-# INLINE leafBranch #-}
762 |
763 | -- | Select child to link under node 'n' by 'k'.
764 | switch :: (CritBitKey k) => k -> Node k v -> Node k w -> Node k w
765 | -> Node k w -> Node k w -> Node k w
766 | switch k n a0 b0 a1 b1
767 | | k `onLeft` n = setBoth' n a0 b0
768 | | otherwise = setBoth' n a1 b1
769 | {-# INLINE switch #-}
770 |
771 | -- | Extract minimum key from the subtree.
772 | minKey :: (CritBitKey k) => Node k v -> k
773 | minKey n = leftmost
774 | (error "Data.CritBit.Tree.minKey: Empty")
775 | const n
776 | {-# INLINE minKey #-}
777 |
778 | -- | Extract maximum key from the subtree.
779 | maxKey :: (CritBitKey k) => Node k v -> k
780 | maxKey n = rightmost
781 | (error "Data.CritBit.Tree.maxKey: Empty")
782 | const n
783 | {-# INLINE maxKey #-}
784 |
785 | -- | Sets both children to the parent node.
786 | setBoth' :: Node k v -> Node k w -> Node k w -> Node k w
787 | setBoth' _ Empty b = b
788 | setBoth' _ a Empty = a
789 | setBoth' (Internal _ _ byte bits) !a !b = Internal a b byte bits
790 | setBoth' _ _ _ = error "Data.CritBit.Tree.setBoth': unpossible"
791 | {-# INLINE setBoth' #-}
792 |
793 | setBoth :: Node k v -> Node k w -> Node k w -> Node k w
794 | setBoth (Internal _ _ byte bits) !a !b = Internal a b byte bits
795 | setBoth _ _ _ = error "Data.CritBit.Tree.setBoth: unpossible"
796 | {-# INLINE setBoth #-}
797 |
798 | -- | /O(n)/. Apply a function to all values.
799 | --
800 | -- > map show (fromList [("b",5), ("a",3)]) == fromList [("b","5"), ("a","3")]
801 | map :: (CritBitKey k) => (v -> w) -> CritBit k v -> CritBit k w
802 | map = fmap
803 |
804 | -- | /O(k)/.
805 | -- @mapKeys f@ applies the function @f@ to the keys of the map.
806 | --
807 | -- If @f@ maps multiple keys to the same new key, the new key is
808 | -- associated with the value of the greatest of the original keys.
809 | --
810 | -- > let f = fromString . (++ "1") . show
811 | -- > mapKeys f (fromList [("a", 5), ("b", 3)]) == fromList ([("a1", 5), ("b1", 3)])
812 | -- > mapKeys (\ _ -> "a") (fromList [("a", 5), ("b", 3)]) == singleton "a" 3
813 | mapKeys :: (CritBitKey k2) => (k1 -> k2) -> CritBit k1 v -> CritBit k2 v
814 | mapKeys f m = mapKeysWith (\_ v -> v) f m
815 | {-# INLINABLE mapKeys #-}
816 |
817 | -- | /O(k)/.
818 | -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
819 | --
820 | -- The size of the result may be smaller if @f@ maps two or more distinct
821 | -- keys to the same new key. In this case the associated values will be
822 | -- combined using @c@.
823 | --
824 | -- > mapKeysWith (+) (\ _ -> "a") (fromList [("b",1), ("a",2), ("d",3), ("c",4)]) == singleton "a" 10
825 | mapKeysWith :: (CritBitKey k2)
826 | => (v -> v -> v)
827 | -> (k1 -> k2)
828 | -> CritBit k1 v -> CritBit k2 v
829 | mapKeysWith c f m = foldrWithKey ins empty m
830 | where ins k v nm = insertWith c (f k) v nm
831 | {-# INLINABLE mapKeysWith #-}
832 |
833 | -- | /O(k)/.
834 | -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
835 | -- is strictly monotonic.
836 | -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
837 | -- /The precondition is not checked./
838 | -- Semi-formally, we have:
839 | --
840 | -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
841 | -- > ==> mapKeysMonotonic f s == mapKeys f s
842 | -- > where ls = keys s
843 | --
844 | -- This means that @f@ maps distinct original keys to distinct resulting keys.
845 | -- This function has slightly better performance than 'mapKeys'.
846 | --
847 | -- > mapKeysMonotonic (\ k -> succ k) (fromList [("a",5), ("b",3)]) == fromList [("b",5), ("c",3)]
848 | mapKeysMonotonic :: (CritBitKey k)
849 | => (a -> k) -> CritBit a v -> CritBit k v
850 | mapKeysMonotonic f m = foldlWithKey (insertRight f) empty m
851 | {-# INLINABLE mapKeysMonotonic #-}
852 |
853 | insertRight :: CritBitKey k
854 | => (a -> k) -> CritBit k v -> a -> v -> CritBit k v
855 | insertRight f (CritBit root) ok v
856 | | Empty <- root = CritBit $ Leaf k v
857 | | otherwise = CritBit $ go root
858 | where
859 | k = f ok
860 | go i@(Internal _ right _ _)
861 | | diff `above` i = append i
862 | | otherwise = setRight' i $ go right
863 | go i = append i
864 |
865 | append i = internal diff i (Leaf k v)
866 |
867 | diff = followPrefixes k $ maxKey root
868 | {-# INLINE insertRight #-}
869 |
870 | -- | /O(n)/. Convert the map to a list of key/value pairs where the keys are in
871 | -- ascending order.
872 | --
873 | -- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
874 | toAscList :: CritBit k v -> [(k,v)]
875 | toAscList m = foldrWithKey f [] m
876 | where f k v vs = (k,v) : vs
877 |
878 | -- | /O(n)/. Convert the map to a list of key/value pairs where the keys are in
879 | -- descending order.
880 | --
881 | -- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]
882 | toDescList :: CritBit k v -> [(k,v)]
883 | toDescList m = foldlWithKey f [] m
884 | where f vs k v = (k,v):vs
885 |
886 | -- | /O(n)/. Build a tree from an ascending list in linear time.
887 | -- /The precondition (input list is ascending) is not checked./
888 | --
889 | -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
890 | -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
891 | -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
892 | -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
893 | fromAscList :: (CritBitKey k) => [(k, v)] -> CritBit k v
894 | fromAscList = fromAscListWithKey (\_ x _ -> x)
895 | {-# INLINABLE fromAscList #-}
896 |
897 | -- | /O(n)/. Build a tree from an ascending list in linear time
898 | -- with a combining function for equal keys.
899 | -- /The precondition (input list is ascending) is not checked./
900 | --
901 | -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
902 | -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
903 | -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
904 | fromAscListWith :: (CritBitKey k) => (v -> v -> v) -> [(k,v)] -> CritBit k v
905 | fromAscListWith f = fromAscListWithKey (const f)
906 | {-# INLINABLE fromAscListWith #-}
907 |
908 | -- | /O(n)/. Build a map from an ascending list in linear time with a
909 | -- combining function for equal keys.
910 | -- /The precondition (input list is ascending) is not checked./
911 | --
912 | -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
913 | -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
914 | -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
915 | -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
916 | fromAscListWithKey :: (CritBitKey k) =>
917 | (k -> v -> v -> v) -> [(k,v)] -> CritBit k v
918 | fromAscListWithKey _ [] = empty
919 | fromAscListWithKey _ [(k, v)] = singleton k v
920 | fromAscListWithKey f kvs = build 0 1 upper fromContext kvs RCNil
921 | -- This implementation is based on the idea of binary search in
922 | -- a suffix array using LCP array.
923 | --
924 | -- Input list is converted to array and processed top-down.
925 | -- When building tree for interval we finds the length of
926 | -- the common prefix of all keys in this interval. We never
927 | -- compare known common prefixes, thus reducing number of
928 | -- comparisons. Then we merge trees, building recursively on
929 | -- halves of this interval.
930 | --
931 | -- This algorithm runs in /O(n+K)/ time, where /K/ is the total
932 | -- length of all keys minus . When many keys have equal prefixes,
933 | -- the second summand may be much smaller.
934 | --
935 | -- See also:
936 | --
937 | -- Manber, Udi; Myers, Gene (1990). "Suffix arrays: a new method for
938 | -- on-line string searches". In Proceedings of the first annual
939 | -- ACM-SIAM symposium on Discrete algorithms 90 (319): 327.
940 | where
941 | upper = length kvs - 1
942 | array = fst . (A.listArray (0, upper) kvs A.!)
943 |
944 | fromContext = add (Diff 0 0 0)
945 | (const $ \(RCCons node _ _ _) -> CritBit node)
946 |
947 | build z left right cont xs cx
948 | | left == right = add diffI cont xs cx
949 | | otherwise = (build diffO left mid $
950 | build diffO (mid + 1) right cont) xs cx
951 | where
952 | mid = (left + right - 1) `div` 2
953 | diffO = followPrefixesByteFrom z (fst (head xs)) (array right)
954 | diffI = followPrefixesFrom z (fst (head xs)) (array right)
955 | {-# INLINE build #-}
956 |
957 | add (Diff byte bits _) cont (x:xs) cx
958 | | bits == 0x1ff = let (k, v1) = x; (_, v2) = head xs
959 | in cont ((k, f k v2 v1) : tail xs) cx
960 | | otherwise = cont xs $ pop (uncurry Leaf x) cx
961 | where
962 | pop right cs@(RCCons left cbyte cbits cs')
963 | | cbyte > byte || cbyte == byte && cbits > bits
964 | = pop (Internal left right cbyte cbits) cs'
965 | | otherwise = RCCons right byte bits cs
966 | pop right cs = RCCons right byte bits cs
967 | add _ _ _ _ = error "CritBit.fromAscListWithKey.add: Unpossible"
968 | {-# INLINE add #-}
969 | {-# INLINABLE fromAscListWithKey #-}
970 |
971 | -- | /O(n)/. Build a tree from an ascending list of distinct elements
972 | -- in linear time.
973 | -- /The precondition is not checked./
974 | --
975 | -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
976 | -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
977 | -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
978 | fromDistinctAscList :: (CritBitKey k) => [(k,v)] -> CritBit k v
979 | fromDistinctAscList = fromAscListWithKey undefined
980 | {-# INLINABLE fromDistinctAscList #-}
981 |
982 | -- | One-hole CritBit context focused on the maximum leaf
983 | data RightContext k v
984 | = RCNil
985 | | RCCons !(Node k v) !Int !BitMask !(RightContext k v)
986 |
987 | -- | /O(n)/. Filter all values that satisfy the predicate.
988 | --
989 | -- > filter (> "a") (fromList [("5","a"), ("3","b")]) == fromList [("3","b")]
990 | -- > filter (> "x") (fromList [("5","a"), ("3","b")]) == empty
991 | -- > filter (< "a") (fromList [("5","a"), ("3","b")]) == empty
992 | filter :: (v -> Bool) -> CritBit k v -> CritBit k v
993 | filter p m = filterWithKey (const p) m
994 |
995 | -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
996 | --
997 | -- > filterWithKey (\k _ -> k > "4") (fromList [("5","a"), ("3","b")]) == fromList[("5","a")]
998 | filterWithKey :: (k -> v -> Bool) -> CritBit k v -> CritBit k v
999 | filterWithKey p (CritBit root) = CritBit $ go root
1000 | where
1001 | go i@(Internal left right _ _) = setBoth' i (go left) (go right)
1002 | go leaf@(Leaf k v) | p k v = leaf
1003 | go _ = Empty
1004 | {-# INLINABLE filterWithKey #-}
1005 |
1006 | -- | /O(n)/. Map values and collect the 'Just' results.
1007 | --
1008 | -- > let f x = if x == 5 then Just 10 else Nothing
1009 | -- > mapMaybe f (fromList [("a",5), ("b",3)]) == singleton "a" 10
1010 | mapMaybe :: (v -> Maybe w) -> CritBit k v -> CritBit k w
1011 | mapMaybe = mapMaybeWithKey . const
1012 |
1013 | -- | /O(n)/. Map keys\/values and collect the 'Just' results.
1014 | --
1015 | -- > let f k v = if k == "a" then Just ("k,v: " ++ show k ++ "," ++ show v) else Nothing
1016 | -- > mapMaybeWithKey f (fromList [("a",5), ("b",3)]) == singleton "a" "k,v: \"a\",3"
1017 | mapMaybeWithKey :: (k -> v -> Maybe v') -> CritBit k v -> CritBit k v'
1018 | mapMaybeWithKey f (CritBit root) = CritBit $ go root
1019 | where
1020 | go i@(Internal left right _ _) = setBoth' i (go left) (go right)
1021 | go (Leaf k v) = maybe Empty (Leaf k) $ f k v
1022 | go Empty = Empty
1023 | {-# INLINABLE mapMaybeWithKey #-}
1024 |
1025 | -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
1026 | --
1027 | -- > let f a = if a < 5 then Left a else Right a
1028 | -- > mapEither f (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
1029 | -- > == (fromList [("b",3), ("x",1)], fromList [("a",5), ("z",7)])
1030 | -- >
1031 | -- > mapEither (\ a -> Right a) (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
1032 | -- > == (empty, fromList [("a",5), ("b",3), ("x",1), ("z",7)])
1033 | mapEither :: (v -> Either w x) -> CritBit k v -> (CritBit k w, CritBit k x)
1034 | mapEither = mapEitherWithKey . const
1035 |
1036 | -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
1037 | --
1038 | -- > let f k a = if k < "c" then Left (k ++ k) else Right (a * 2)
1039 | -- > mapEitherWithKey f (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
1040 | -- > == (fromList [("a","aa"), ("b","bb")], fromList [("x",2), ("z",14)])
1041 | -- >
1042 | -- > mapEitherWithKey (\_ a -> Right a) (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
1043 | -- > == (empty, fromList [("x",1), ("b",3), ("a",5), ("z",7)])
1044 | mapEitherWithKey :: (k -> v -> Either w x) ->
1045 | CritBit k v -> (CritBit k w, CritBit k x)
1046 | mapEitherWithKey f (CritBit root) = (CritBit *** CritBit) $ go root
1047 | where
1048 | go i@(Internal l r _ _) = (setBoth' i ll rl, setBoth' i lr rr)
1049 | where
1050 | (ll, lr) = go l
1051 | (rl, rr) = go r
1052 | go (Leaf k v) = case f k v of
1053 | Left v' -> (Leaf k v', Empty)
1054 | Right v' -> (Empty, Leaf k v')
1055 | go Empty = (Empty, Empty)
1056 | {-# INLINABLE mapEitherWithKey #-}
1057 |
1058 | -- | /O(k)/. The expression (@'split' k map@) is a pair
1059 | -- @(map1,map2)@ where the keys in @map1@ are smaller than @k@ and the
1060 | -- keys in @map2@ larger than @k@. Any key equal to @k@ is found in
1061 | -- neither @map1@ nor @map2@.
1062 | --
1063 | -- > split "a" (fromList [("b",1), ("d",2)]) == (empty, fromList [("b",1), ("d",2)])
1064 | -- > split "b" (fromList [("b",1), ("d",2)]) == (empty, singleton "d" 2)
1065 | -- > split "c" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, singleton "d" 2)
1066 | -- > split "d" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, empty)
1067 | -- > split "e" (fromList [("b",1), ("d",2)]) == (fromList [("b",1), ("d",2)], empty)
1068 | split :: (CritBitKey k) => k -> CritBit k v -> (CritBit k v, CritBit k v)
1069 | -- Note that this is nontrivially faster than an implementation
1070 | -- in terms of 'splitLookup'.
1071 | split k m = CritBit *** CritBit $
1072 | findPosition (const id) finish goLeft goRight k m
1073 | where
1074 | finish _ Empty = (Empty, Empty)
1075 | finish diff node = case diffOrd diff of
1076 | LT -> (node, Empty)
1077 | GT -> (Empty, node)
1078 | EQ -> (Empty, Empty)
1079 |
1080 | goLeft i (lt, Empty) = (lt, iright i)
1081 | goLeft i (lt, gt ) = (lt, setLeft i gt)
1082 |
1083 | goRight i (Empty, gt) = (ileft i, gt)
1084 | goRight i (lt , gt) = (setRight i lt, gt)
1085 | {-# INLINABLE split #-}
1086 |
1087 | -- | /O(k)/. The expression (@'splitLookup' k map@) splits a map just
1088 | -- like 'split' but also returns @'lookup' k map@.
1089 | --
1090 | -- > splitLookup "a" (fromList [("b",1), ("d",2)]) == (empty, Nothing, fromList [("b",1), ("d",2)])
1091 | -- > splitLookup "b" (fromList [("b",1), ("d",2)]) == (empty, Just 1, singleton "d" 2)
1092 | -- > splitLookup "c" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, Nothing, singleton "d" 2)
1093 | -- > splitLookup "d" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, Just 2, empty)
1094 | -- > splitLookup "e" (fromList [("b",1), ("d",2)]) == (fromList [("b",1), ("d",2)], Nothing, empty)
1095 | splitLookup :: (CritBitKey k) =>
1096 | k -> CritBit k v -> (CritBit k v, Maybe v, CritBit k v)
1097 | splitLookup k m = (\(lt, eq, gt) -> (CritBit lt, eq, CritBit gt)) $
1098 | findPosition (const id) finish goLeft goRight k m
1099 | where
1100 | finish _ Empty = (Empty, Nothing, Empty)
1101 | finish diff node = case diffOrd diff of
1102 | LT -> (node, Nothing , Empty)
1103 | GT -> (Empty, Nothing , node )
1104 | EQ -> (Empty, leaf node, Empty)
1105 |
1106 | leaf (Leaf _ v) = Just v
1107 | leaf _ = error "Data.CritBit.Tree.splitLookup.leaf: Unpossible."
1108 |
1109 | goLeft i (lt, eq, Empty) = (lt, eq, iright i)
1110 | goLeft i (lt, eq, gt ) = (lt, eq, setLeft i gt)
1111 |
1112 | goRight i (Empty, eq, gt) = (ileft i , eq, gt)
1113 | goRight i (lt , eq, gt) = (setRight i lt, eq, gt)
1114 | {-# INLINABLE splitLookup #-}
1115 |
1116 | -- | /O(n+m)/. This function is defined as
1117 | -- (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
1118 | isSubmapOf :: (CritBitKey k, Eq v) => CritBit k v -> CritBit k v -> Bool
1119 | isSubmapOf = isSubmapOfBy (==)
1120 | {-# INLINABLE isSubmapOf #-}
1121 |
1122 | -- | /O(n+m)/. The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
1123 | -- all keys in @t1@ are in map @t2@, and when @f@ returns 'True' when
1124 | -- applied to their respective values. For example, the following
1125 | -- expressions are all 'True':
1126 | --
1127 | -- > isSubmapOfBy (==) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
1128 | -- > isSubmapOfBy (<=) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
1129 | -- > isSubmapOfBy (==) (fromList [("a",1),("b",2)]) (fromList [("a",1),("b",2)])
1130 | --
1131 | -- But the following are all 'False':
1132 | --
1133 | -- > isSubmapOfBy (==) (fromList [("a",2)]) (fromList [("a",1),("b",2)])
1134 | -- > isSubmapOfBy (<) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
1135 | -- > isSubmapOfBy (==) (fromList [("a",1),("b",2)]) (fromList [("a",1)])
1136 | isSubmapOfBy :: (CritBitKey k) =>
1137 | (v -> w -> Bool) -> CritBit k v -> CritBit k w -> Bool
1138 | isSubmapOfBy f a b = submapTypeBy f a b /= No
1139 | {-# INLINABLE isSubmapOfBy #-}
1140 |
1141 | -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
1142 | -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
1143 | isProperSubmapOf :: (CritBitKey k, Eq v) => CritBit k v -> CritBit k v -> Bool
1144 | isProperSubmapOf = isProperSubmapOfBy (==)
1145 | {-# INLINABLE isProperSubmapOf #-}
1146 |
1147 | -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
1148 | -- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
1149 | -- @m1@ and @m2@ are not equal,
1150 | -- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
1151 | -- applied to their respective values. For example, the following
1152 | -- expressions are all 'True':
1153 | --
1154 | -- > isProperSubmapOfBy (==) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
1155 | -- > isProperSubmapOfBy (<=) (fromList [("a",0)]) (fromList [("a",1),("b",2)])
1156 | --
1157 | -- But the following are all 'False':
1158 | --
1159 | -- > isProperSubmapOfBy (==) (fromList [("a",1),("b",2)]) (fromList [("a",1),("b",2)])
1160 | -- > isProperSubmapOfBy (==) (fromList ["a",1),("b",2)]) (fromList [("a",1)])
1161 | -- > isProperSubmapOfBy (<) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
1162 | isProperSubmapOfBy :: (CritBitKey k) =>
1163 | (v -> w -> Bool) -> CritBit k v -> CritBit k w -> Bool
1164 | isProperSubmapOfBy f a b = submapTypeBy f a b == Yes
1165 | {-# INLINABLE isProperSubmapOfBy #-}
1166 |
1167 | data SubmapType = No | Yes | Equal deriving (Eq, Ord)
1168 | submapTypeBy :: (CritBitKey k) =>
1169 | (v -> w -> Bool) -> CritBit k v -> CritBit k w -> SubmapType
1170 | submapTypeBy f (CritBit root1) (CritBit root2) = top root1 root2
1171 | where
1172 | -- Assumes that empty nodes exist only on the top level
1173 | top Empty Empty = Equal
1174 | top Empty _ = Yes
1175 | top _ Empty = No
1176 | top a b = go a (minKey a) b (minKey b)
1177 | {-# INLINE top #-}
1178 |
1179 | -- Each node is followed by the minimum key in that node.
1180 | -- This trick assures that overall time spend by minKey in O(n+m)
1181 | go (Leaf ak av) _ (Leaf bk bv) _
1182 | | ak == bk = if f av bv then Equal else No
1183 | | otherwise = No
1184 | go a@(Leaf{}) ak b@(Internal{}) bk =
1185 | leafBranch a b bk (splitB a ak b bk) No
1186 | go (Internal{}) _ (Leaf{}) _ = No
1187 | go a@(Internal al ar abyte abits) ak b@(Internal bl br bbyte bbits) bk =
1188 | case compare (abyte, abits) (bbyte, bbits) of
1189 | LT -> No
1190 | GT -> splitB a ak b bk
1191 | EQ -> min (go al ak bl bk) (go ar (minKey ar) br (minKey br))
1192 | -- Assumes that empty nodes exist only on the top level
1193 | go _ _ _ _ = error "Data.CritBit.Tree.isSubmapOfBy.go: Empty"
1194 |
1195 | splitB a ak b@(Internal bl br _ _) bk = if t == No then No else Yes
1196 | where
1197 | t = if ak `onLeft` b then go a ak bl bk
1198 | else go a ak br (minKey br)
1199 |
1200 | splitB _ _ _ _ =
1201 | error "Data.CritBit.Tree.isSubmapOfBy.splitB: unpossible"
1202 | {-# INLINE splitB #-}
1203 | {-# INLINABLE submapTypeBy #-}
1204 |
1205 | -- | /O(minimum K)/. The minimal key of the map. Calls 'error' if the map
1206 | -- is empty.
1207 | --
1208 | -- > findMin (fromList [("b",3), ("a",5)]) == ("a",5)
1209 | -- > findMin empty Error: empty map has no minimal element
1210 | findMin :: CritBit k v -> (k,v)
1211 | findMin (CritBit root) = leftmost emptyMap (,) root
1212 | where
1213 | emptyMap = error "CritBit.findMin: empty map has no minimal element"
1214 | {-# INLINABLE findMin #-}
1215 |
1216 | -- | /O(k)/. The maximal key of the map. Calls 'error' if the map
1217 | -- is empty.
1218 | --
1219 | -- > findMax empty Error: empty map has no minimal element
1220 | findMax :: CritBit k v -> (k,v)
1221 | findMax (CritBit root) = rightmost emptyMap (,) root
1222 | where
1223 | emptyMap = error "CritBit.findMax: empty map has no maximal element"
1224 | {-# INLINABLE findMax #-}
1225 |
1226 | -- | /O(k')/. Delete the minimal key. Returns an empty map if the
1227 | -- map is empty.
1228 | --
1229 | -- > deleteMin (fromList [("a",5), ("b",3), ("c",7)]) == fromList [("b",3), ("c",7)]
1230 | -- > deleteMin empty == empty
1231 | deleteMin :: CritBit k v -> CritBit k v
1232 | deleteMin m = updateMinWithKey (\_ _ -> Nothing) m
1233 | {-# INLINABLE deleteMin #-}
1234 |
1235 | -- | /O(k)/. Delete the maximal key. Returns an empty map if the
1236 | -- map is empty.
1237 | --
1238 | -- > deleteMin (fromList [("a",5), ("b",3), ("c",7)]) == fromList [("a",5), ("b","3")]
1239 | -- > deleteMin empty == empty
1240 | deleteMax :: CritBit k v -> CritBit k v
1241 | deleteMax m = updateMaxWithKey (\_ _ -> Nothing) m
1242 | {-# INLINABLE deleteMax #-}
1243 |
1244 | -- | /O(k')/. Delete and find the minimal element.
1245 | --
1246 | -- > deleteFindMin (fromList [("a",5), ("b",3), ("c",10)]) == (("a",5), fromList[("b",3), ("c",10)])
1247 | -- > deleteFindMin Error: can not return the minimal element of an empty map
1248 | deleteFindMin :: CritBit k v -> ((k, v), CritBit k v)
1249 | deleteFindMin = fromMaybe (error msg) . minViewWithKey
1250 | where msg = "CritBit.deleteFindMin: cannot return the minimal \
1251 | \element of an empty map"
1252 | {-# INLINABLE deleteFindMin #-}
1253 |
1254 | -- | /O(k)/. Delete and find the maximal element.
1255 | --
1256 | -- > deleteFindMax (fromList [("a",5), ("b",3), ("c",10)]) == (("c",10), fromList[("a",5), ("b",3)])
1257 | -- > deleteFindMax Error: can not return the maximal element of an empty map
1258 | deleteFindMax :: CritBit k v -> ((k, v), CritBit k v)
1259 | deleteFindMax = fromMaybe (error msg) . maxViewWithKey
1260 | where msg = "CritBit.deleteFindMax: cannot return the minimal \
1261 | \element of an empty map"
1262 | {-# INLINABLE deleteFindMax #-}
1263 |
1264 | -- | /O(k')/. Retrieves the value associated with minimal key of the
1265 | -- map, and the map stripped of that element, or 'Nothing' if passed an
1266 | -- empty map.
1267 | --
1268 | -- > minView (fromList [("a",5), ("b",3)]) == Just (5, fromList [("b",3)])
1269 | -- > minView empty == Nothing
1270 | minView :: CritBit k v -> Maybe (v, CritBit k v)
1271 | minView = fmap (first snd) . minViewWithKey
1272 | {-# INLINABLE minView #-}
1273 |
1274 | -- | /O(k)/. Retrieves the value associated with maximal key of the
1275 | -- map, and the map stripped of that element, or 'Nothing' if passed an
1276 | -- empty map.
1277 | --
1278 | -- > maxView (fromList [("a",5), ("b",3)]) == Just (3, fromList [("a",5)])
1279 | -- > maxView empty == Nothing
1280 | maxView :: CritBit k v -> Maybe (v, CritBit k v)
1281 | maxView = fmap (first snd) . maxViewWithKey
1282 | {-# INLINABLE maxView #-}
1283 |
1284 | -- | /O(k')/. Retrieves the minimal (key,value) pair of the map, and
1285 | -- the map stripped of that element, or 'Nothing' if passed an empty map.
1286 | --
1287 | -- > minViewWithKey (fromList [("a",5), ("b",3)]) == Just (("a",5), fromList [("b",3)])
1288 | -- > minViewWithKey empty == Nothing
1289 | minViewWithKey :: CritBit k v -> Maybe ((k, v), CritBit k v)
1290 | minViewWithKey (CritBit root) = go root CritBit
1291 | where
1292 | go (Internal (Leaf lk lv) right _ _) cont = Just ((lk,lv), cont right)
1293 | go i@(Internal left _ _ _) cont = go left $ (cont $!) . setLeft i
1294 | go (Leaf lk lv) _ = Just ((lk,lv),empty)
1295 | go _ _ = Nothing
1296 | {-# INLINABLE minViewWithKey #-}
1297 |
1298 | -- | /O(k)/. Retrieves the maximal (key,value) pair of the map, and
1299 | -- the map stripped of that element, or 'Nothing' if passed an empty map.
1300 | --
1301 | -- > maxViewWithKey (fromList [("a",5), ("b",3)]) == Just (("b",3), fromList [("a",5)])
1302 | -- > maxViewWithKey empty == Nothing
1303 | maxViewWithKey :: CritBit k v -> Maybe ((k,v), CritBit k v)
1304 | maxViewWithKey (CritBit root) = go root CritBit
1305 | where
1306 | go (Internal left (Leaf lk lv) _ _) cont = Just ((lk,lv), cont left)
1307 | go i@(Internal _ right _ _) cont = go right $ (cont $!) . setRight i
1308 | go (Leaf lk lv) _ = Just ((lk,lv),empty)
1309 | go _ _ = Nothing
1310 | {-# INLINABLE maxViewWithKey #-}
1311 |
1312 | first :: (a -> b) -> (a,c) -> (b,c)
1313 | first f (x,y) = (f x, y)
1314 | {-# INLINE first #-}
1315 |
1316 | -- | /O(k')/. Update the value at the minimal key.
1317 | --
1318 | -- > updateMin (\ a -> Just (a + 7)) (fromList [("a",5), ("b",3)]) == fromList [("a",12), ("b",3)]
1319 | -- > updateMin (\ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("b",3)]
1320 | updateMin :: (v -> Maybe v) -> CritBit k v -> CritBit k v
1321 | updateMin f m = updateMinWithKey (const f) m
1322 | {-# INLINABLE updateMin #-}
1323 |
1324 | -- | /O(k)/. Update the value at the maximal key.
1325 | --
1326 | -- > updateMax (\ a -> Just (a + 7)) (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",10)]
1327 | -- > updateMax (\ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("a",5)]
1328 | updateMax :: (v -> Maybe v) -> CritBit k v -> CritBit k v
1329 | updateMax f m = updateMaxWithKey (const f) m
1330 | {-# INLINABLE updateMax #-}
1331 |
1332 | -- | /O(k')/. Update the value at the minimal key.
1333 | --
1334 | -- > updateMinWithKey (\ k a -> Just (length k + a)) (fromList [("a",5), ("b",3)]) == fromList [("a",6), ("b",3)]
1335 | -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("b",3)]
1336 | updateMinWithKey :: (k -> v -> Maybe v) -> CritBit k v -> CritBit k v
1337 | updateMinWithKey maybeUpdate (CritBit root) = CritBit $ go root
1338 | where
1339 | go i@(Internal left _ _ _) = setLeft' i (go left)
1340 | go (Leaf k v) = maybe Empty (Leaf k) $ maybeUpdate k v
1341 | go _ = Empty
1342 | {-# INLINABLE updateMinWithKey #-}
1343 |
1344 | -- | /O(k)/. Update the value at the maximal key.
1345 | --
1346 | -- > updateMaxWithKey (\ k a -> Just (length k + a)) (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",4)]
1347 | -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("a",5)]
1348 | updateMaxWithKey :: (k -> v -> Maybe v) -> CritBit k v -> CritBit k v
1349 | updateMaxWithKey maybeUpdate (CritBit root) = CritBit $ go root
1350 | where
1351 | go i@(Internal _ right _ _) = setRight' i (go right)
1352 | go (Leaf k v) = maybe Empty (Leaf k) $ maybeUpdate k v
1353 | go _ = Empty
1354 | {-# INLINABLE updateMaxWithKey #-}
1355 |
1356 | -- | /O(k)/. Insert a new key and value in the map. If the key is
1357 | -- already present in the map, the associated value is replaced with
1358 | -- the supplied value. 'insert' is equivalent to @'insertWith'
1359 | -- 'const'@.
1360 | --
1361 | -- > insert "b" 7 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",7)]
1362 | -- > insert "x" 7 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("x",7)]
1363 | -- > insert "x" 5 empty == singleton "x" 5
1364 | insert :: (CritBitKey k) => k -> v -> CritBit k v -> CritBit k v
1365 | insert = insertLookupGen (flip const) (\_ v _ -> v)
1366 | {-# INLINABLE insert #-}
1367 |
1368 | -- | /O(k)/. Insert with a function, combining new value and old value.
1369 | -- @'insertWith' f key value cb@
1370 | -- will insert the pair (key, value) into @cb@ if key does
1371 | -- not exist in the map. If the key does exist, the function will
1372 | -- insert the pair @(key, f new_value old_value)@.
1373 | --
1374 | -- > insertWith (+) "a" 1 (fromList [("a",5), ("b",3)]) == fromList [("a",6), ("b",3)]
1375 | -- > insertWith (+) "c" 7 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("c",7)]
1376 | -- > insertWith (+) "x" 5 empty == singleton "x" 5
1377 | --
1378 | insertWith :: CritBitKey k =>
1379 | (v -> v -> v) -> k -> v -> CritBit k v -> CritBit k v
1380 | insertWith f = insertLookupGen (flip const) (const f)
1381 | {-# INLINABLE insertWith #-}
1382 |
1383 | -- | /O(n)/. Apply a function to all values.
1384 | --
1385 | -- > let f key x = show key ++ ":" ++ show x
1386 | -- > mapWithKey f (fromList [("a",5), ("b",3)]) == fromList [("a","a:5"), ("b","b:3")]
1387 | mapWithKey :: (k -> v -> w) -> CritBit k v -> CritBit k w
1388 | mapWithKey f (CritBit root) = CritBit (go root)
1389 | where
1390 | go i@(Internal l r _ _) = setBoth i (go l) (go r)
1391 | go (Leaf k v) = Leaf k (f k v)
1392 | go Empty = Empty
1393 | {-# INLINABLE mapWithKey #-}
1394 |
1395 | -- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating
1396 | -- argument through the map in descending order of keys.
1397 | mapAccumRWithKey :: (CritBitKey k) => (a -> k -> v -> (a, w)) -> a
1398 | -> CritBit k v -> (a, CritBit k w)
1399 | mapAccumRWithKey f start (CritBit root) = second CritBit (go start root)
1400 | where
1401 | go a i@(Internal{..}) = let (a0, r') = go a iright
1402 | (a1, l') = go a0 ileft
1403 | in (a1, setBoth i l' r')
1404 | go a (Leaf k v) = let (a0, w) = f a k v in (a0, Leaf k w)
1405 | go a Empty = (a, Empty)
1406 | {-# INLINABLE mapAccumRWithKey #-}
1407 |
1408 | -- | /O(n)/.
1409 | -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
1410 | --
1411 | -- That is, behaves exactly like a regular 'traverse' except
1412 | -- that the traversing function also has access to the key associated
1413 | -- with a value.
1414 | --
1415 | -- > let f key value = show key ++ ":" ++ show value
1416 | -- > traverseWithKey (\k v -> if odd v then Just (f k v) else Nothing) (fromList [("a",3), ("b",5)]) == Just (fromList [("a","a:3"), ("b","b:5")])
1417 | -- > traverseWithKey (\k v -> if odd v then Just (f k v) else Nothing) (fromList [("c", 2)]) == Nothing
1418 | traverseWithKey :: (CritBitKey k, Applicative t)
1419 | => (k -> v -> t w)
1420 | -> CritBit k v
1421 | -> t (CritBit k w)
1422 | traverseWithKey f (CritBit root) = fmap CritBit (go root)
1423 | where
1424 | go i@(Internal l r _ _) = setBoth i <$> go l <*> go r
1425 | go (Leaf k v) = Leaf k <$> f k v
1426 | go Empty = pure Empty
1427 | {-# INLINABLE traverseWithKey #-}
1428 |
1429 | -- | /O(n)/. The function 'mapAccum' threads an accumulating
1430 | -- argument through the map in ascending order of keys.
1431 | --
1432 | -- > let f a b = (a ++ show b, show b ++ "X")
1433 | -- > mapAccum f "Everything: " (fromList [("a",5), ("b",3)]) == ("Everything: 53", fromList [("a","5X"), ("b","3X")])
1434 | mapAccum :: (CritBitKey k)
1435 | => (a -> v -> (a, w))
1436 | -> a
1437 | -> CritBit k v
1438 | -> (a, CritBit k w)
1439 | mapAccum f = mapAccumWithKey (\a _ v -> f a v)
1440 | {-# INLINE mapAccum #-}
1441 |
1442 | -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
1443 | -- argument through the map in ascending order of keys.
1444 | --
1445 | -- > let f a k b = (a ++ " " ++ show k ++ "-" ++ show b, show b ++ "X")
1446 | -- > mapAccumWithKey f "Everything: " (fromList [("a",5), ("b",3)]) == ("Everything: a-5 b-3", fromList [("a","5X"), ("b","3X")])
1447 | mapAccumWithKey :: (CritBitKey k)
1448 | => (a -> k -> v -> (a, w))
1449 | -> a
1450 | -> CritBit k v
1451 | -> (a, CritBit k w)
1452 | mapAccumWithKey f start (CritBit root) = second CritBit (go start root)
1453 | where
1454 | go a i@(Internal{..}) = let (a0, l') = go a ileft
1455 | (a1, r') = go a0 iright
1456 | in (a1, setBoth i l' r')
1457 |
1458 | go a (Leaf k v) = let (a0, w) = f a k v in (a0, Leaf k w)
1459 | go a Empty = (a, Empty)
1460 | {-# INLINABLE mapAccumWithKey #-}
1461 |
1462 | -- | /O(k)/. The expression (@'alter' f k map@) alters the value @x@
1463 | -- at @k@, or absence thereof. 'alter' can be used to insert, delete,
1464 | -- or update a value in a 'CritBit'. In short : @'lookup' k ('alter'
1465 | -- f k m) = f ('lookup' k m)@.
1466 | --
1467 | -- > let f _ = Nothing
1468 | -- > alter f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
1469 | -- > alter f "a" (fromList [("a",5), ("b",3)]) == fromList [("b",3)]
1470 | -- >
1471 | -- > let f _ = Just 1
1472 | -- > alter f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("c",1)]
1473 | -- > alter f "a" (fromList [(5,"a"), (3,"b")]) == fromList [("a",1), ("b",3)]
1474 | alter :: (CritBitKey k)
1475 | => (Maybe v -> Maybe v) -> k -> CritBit k v -> CritBit k v
1476 | alter f !k m = findPosition (const CritBit) finish setLeft' setRight' k m
1477 | where
1478 | finish _ Empty = maybe Empty (Leaf k) $ f Nothing
1479 | finish diff (Leaf _ v) | diffOrd diff == EQ =
1480 | maybe Empty (Leaf k) $ f (Just v)
1481 | finish diff node = maybe node (internal diff node . Leaf k) $ f Nothing
1482 | {-# INLINABLE alter #-}
1483 |
1484 | -- | /O(n)/. Partition the map according to a predicate. The first
1485 | -- map contains all elements that satisfy the predicate, the second all
1486 | -- elements that fail the predicate. See also 'split'.
1487 | --
1488 | -- > partitionWithKey (\ k _ -> k < "b") (fromList [("a",5), ("b",3)]) == (fromList [("a",5)], fromList [("b",3)])
1489 | -- > partitionWithKey (\ k _ -> k < "c") (fromList [(5,"a"), (3,"b")]) == (fromList [("a",5), ("b",3)], empty)
1490 | -- > partitionWithKey (\ k _ -> k > "c") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [("a",5), ("b",3)])
1491 | partitionWithKey :: (CritBitKey k)
1492 | => (k -> v -> Bool)
1493 | -> CritBit k v
1494 | -> (CritBit k v, CritBit k v)
1495 | partitionWithKey f (CritBit root) = CritBit *** CritBit $ go root
1496 | where
1497 | go l@(Leaf k v)
1498 | | f k v = (l,Empty)
1499 | | otherwise = (Empty,l)
1500 | go i@(Internal{..}) = (setBoth' i l1 r1, setBoth' i l2 r2)
1501 | where
1502 | (!l1,!l2) = go ileft
1503 | (!r1,!r2) = go iright
1504 | go _ = (Empty,Empty)
1505 | {-# INLINABLE partitionWithKey #-}
1506 |
1507 | -- | /O(n)/. Partition the map according to a predicate. The first
1508 | -- map contains all elements that satisfy the predicate, the second all
1509 | -- elements that fail the predicate. See also 'split'.
1510 | --
1511 | -- > partition (> 4) (fromList [("a",5), ("b",3)]) == (fromList [("a",5)], fromList [("b",3)])
1512 | -- > partition (< 6) (fromList [("a",5), ("b",3)]) == (fromList [("a",5), ("b",3)], empty)
1513 | -- > partition (> 6) (fromList [("a",5), ("b",3)]) == (empty, fromList [("a",5), ("b",3)])
1514 | partition :: (CritBitKey k)
1515 | => (v -> Bool)
1516 | -> CritBit k v
1517 | -> (CritBit k v, CritBit k v)
1518 | partition f m = partitionWithKey (const f) m
1519 | {-# INLINABLE partition #-}
1520 |
--------------------------------------------------------------------------------
/Data/CritBit/Types/Internal.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-}
2 | -- |
3 | -- Module : Data.CritBit.Types.Internal
4 | -- Copyright : (c) Bryan O'Sullivan and others 2013-2014
5 | -- License : BSD-style
6 | -- Maintainer : bos@serpentine.com
7 | -- Stability : experimental
8 | -- Portability : GHC
9 |
10 | #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
11 | #include "MachDeps.h"
12 | #endif
13 |
14 | module Data.CritBit.Types.Internal
15 | (
16 | CritBitKey(..)
17 | , CritBit(..)
18 | , Set(..)
19 | , BitMask
20 | , Node(..)
21 | , foldlWithKey
22 | , foldlWithKey'
23 | , foldrWithKey
24 | , foldrWithKey'
25 | , toList
26 | ) where
27 |
28 | import Control.DeepSeq (NFData(..))
29 | import Data.Bits (Bits, (.|.), (.&.), shiftL, shiftR)
30 | import Data.ByteString (ByteString)
31 | import Data.Foldable hiding (toList)
32 | import Data.Monoid (Monoid(..))
33 | import Data.Text ()
34 | import Data.Text.Internal (Text(..))
35 | import Data.Word (Word, Word8, Word16, Word32, Word64)
36 | import qualified Data.ByteString as B
37 | import qualified Data.ByteString.Unsafe as B
38 | import qualified Data.Text.Array as T
39 | import qualified Data.Vector.Generic as G
40 | import qualified Data.Vector.Unboxed as U
41 | import qualified Data.Vector as V
42 |
43 | type BitMask = Word16
44 |
45 | data Node k v =
46 | Internal {
47 | ileft, iright :: !(Node k v)
48 | , ibyte :: !Int
49 | -- ^ The byte at which the left and right subtrees differ.
50 | , iotherBits :: !BitMask
51 | -- ^ The bitmask representing the critical bit within the
52 | -- differing byte. If the critical bit is e.g. 0x8, the bitmask
53 | -- will have every bit other than 0x8 set, hence 0x1F7
54 | -- (the ninth bit is set because we're using 9 bits for representing
55 | -- bytes).
56 | }
57 | | Leaf k v
58 | | Empty
59 | -- ^ Logically, the 'Empty' constructor is a property of the tree,
60 | -- rather than a node (a non-empty tree will never contain any
61 | -- 'Empty' constructors). In practice, turning 'CritBit' from a
62 | -- newtype into an ADT with an 'Empty' constructor adds a
63 | -- pattern-match and a memory indirection to every function, which
64 | -- slows them all down.
65 | deriving (Eq, Show)
66 |
67 | instance (NFData k, NFData v) => NFData (Node k v) where
68 | rnf (Internal l r _ _) = rnf l `seq` rnf r
69 | rnf (Leaf k v) = rnf k `seq` rnf v
70 | rnf Empty = ()
71 |
72 | instance Functor (Node k) where
73 | fmap f i@(Internal l r _ _) = i { ileft = fmap f l, iright = fmap f r }
74 | fmap f (Leaf k v) = Leaf k (f v)
75 | fmap _ Empty = Empty
76 |
77 | instance Foldable (Node k) where
78 | foldl f z m = foldlWithKey (\a _ v -> f a v) z (CritBit m)
79 | foldr f z m = foldrWithKey (\_ v a -> f v a) z (CritBit m)
80 |
81 | foldMap f (Internal l r _ _) = mappend (foldMap f l) (foldMap f r)
82 | foldMap f (Leaf _ v) = f v
83 | foldMap _ Empty = mempty
84 | {-# INLINABLE foldMap #-}
85 |
86 | -- | /O(n)/. Fold the keys and values in the map using the given
87 | -- left-associative function, such that
88 | -- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.
89 | --
90 | -- Examples:
91 | --
92 | -- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []
93 | --
94 | -- > let f result k a = result ++ "(" ++ show k ++ ":" ++ a ++ ")"
95 | -- > foldlWithKey f "Map: " (fromList [("a",5), ("b",3)]) == "Map: (b:3)(a:5)"
96 | foldlWithKey :: (a -> k -> v -> a) -> a -> CritBit k v -> a
97 | foldlWithKey f z m = foldlWithKeyWith (\_ b -> b) f z m
98 | {-# INLINABLE foldlWithKey #-}
99 |
100 | -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of
101 | -- the function is evaluated before using the result in the next
102 | -- application. This function is strict in the starting value.
103 | foldlWithKey' :: (a -> k -> v -> a) -> a -> CritBit k v -> a
104 | foldlWithKey' f z m = foldlWithKeyWith seq f z m
105 | {-# INLINABLE foldlWithKey' #-}
106 |
107 | -- | /O(n)/. Fold the keys and values in the map using the given
108 | -- right-associative function, such that
109 | -- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
110 | --
111 | -- Examples:
112 | --
113 | -- > keys map = foldrWithKey (\k x ks -> k:ks) [] map
114 | --
115 | -- > let f k a result = result ++ "(" ++ show k ++ ":" ++ a ++ ")"
116 | -- > foldrWithKey f "Map: " (fromList [("a",5), ("b",3)]) == "Map: (a:5)(b:3)"
117 | foldrWithKey :: (k -> v -> a -> a) -> a -> CritBit k v -> a
118 | foldrWithKey f z m = foldrWithKeyWith (\_ b -> b) f z m
119 | {-# INLINABLE foldrWithKey #-}
120 |
121 | -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of
122 | -- the function is evaluated before using the result in the next
123 | -- application. This function is strict in the starting value.
124 | foldrWithKey' :: (k -> v -> a -> a) -> a -> CritBit k v -> a
125 | foldrWithKey' f z m = foldrWithKeyWith seq f z m
126 | {-# INLINABLE foldrWithKey' #-}
127 |
128 | foldlWithKeyWith :: (a -> a -> a) -> (a -> k -> v -> a) -> a -> CritBit k v -> a
129 | foldlWithKeyWith maybeSeq f z0 (CritBit root) = go z0 root
130 | where
131 | go z (Internal left right _ _) = let z' = go z left
132 | in z' `maybeSeq` go z' right
133 | go z (Leaf k v) = f z k v
134 | go z Empty = z
135 | {-# INLINE foldlWithKeyWith #-}
136 |
137 | foldrWithKeyWith :: (a -> a -> a) -> (k -> v -> a -> a) -> a -> CritBit k v -> a
138 | foldrWithKeyWith maybeSeq f z0 (CritBit root) = go root z0
139 | where
140 | go (Internal left right _ _) z = let z' = go right z
141 | in z' `maybeSeq` go left z'
142 | go (Leaf k v) z = f k v z
143 | go Empty z = z
144 | {-# INLINE foldrWithKeyWith #-}
145 |
146 | -- | A crit-bit tree.
147 | newtype CritBit k v = CritBit (Node k v)
148 | deriving (Eq, NFData, Functor, Foldable)
149 |
150 | instance (Show k, Show v) => Show (CritBit k v) where
151 | show t = "fromList " ++ show (toList t)
152 |
153 | -- | A type that can be used as a key in a crit-bit tree.
154 | --
155 | -- We use 9 bits to represent 8-bit bytes so that we can distinguish
156 | -- between an interior byte that is zero (which must have the 9th bit
157 | -- set) and a byte past the end of the input (which must /not/ have
158 | -- the 9th bit set).
159 | --
160 | -- Without this trick, the critical bit calculations would fail on
161 | -- zero bytes /within/ a string, and our tree would be unable to
162 | -- handle arbitrary binary data.
163 | class (Eq k) => CritBitKey k where
164 | -- | Return the number of bytes used by this key.
165 | --
166 | -- For reasonable performance, implementations must be inlined and
167 | -- /O(1)/.
168 | byteCount :: k -> Int
169 |
170 | -- | Return the byte at the given offset (counted in bytes) of
171 | -- this key, bitwise-ORed with 256. If the offset is past the end
172 | -- of the key, return zero.
173 | --
174 | -- For reasonable performance, implementations must be inlined and
175 | -- /O(1)/.
176 | getByte :: k -> Int -> Word16
177 |
178 | instance CritBitKey ByteString where
179 | byteCount = B.length
180 | {-# INLINE byteCount #-}
181 |
182 | getByte bs n
183 | | n < B.length bs = fromIntegral (B.unsafeIndex bs n) .|. 256
184 | | otherwise = 0
185 | {-# INLINE getByte #-}
186 |
187 | instance CritBitKey Text where
188 | byteCount (Text _ _ len) = len `shiftL` 1
189 | {-# INLINE byteCount #-}
190 |
191 | getByte (Text arr off len) n
192 | | n < len `shiftL` 1 =
193 | let word = T.unsafeIndex arr (off + (n `shiftR` 1))
194 | byteInWord = (word `shiftR` ((n .&. 1) `shiftL` 3)) .&. 0xff
195 | in byteInWord .|. 256
196 | | otherwise = 0
197 | {-# INLINE getByte #-}
198 |
199 | #if WORD_SIZE_IN_BITS == 64
200 | # define WORD_SHIFT 3
201 | #else
202 | # define WORD_SHIFT 2
203 | #endif
204 |
205 | instance CritBitKey (U.Vector Word8) where
206 | byteCount = G.length
207 | getByte = getByteV 0
208 |
209 | instance CritBitKey (U.Vector Word16) where
210 | byteCount = (`shiftL` 1) . G.length
211 | getByte = getByteV 1
212 |
213 | instance CritBitKey (U.Vector Word32) where
214 | byteCount = (`shiftL` 2) . G.length
215 | getByte = getByteV 2
216 |
217 | instance CritBitKey (U.Vector Word64) where
218 | byteCount = (`shiftL` 3) . G.length
219 | getByte = getByteV 3
220 |
221 | instance CritBitKey (U.Vector Word) where
222 | byteCount = (`shiftL` WORD_SHIFT) . G.length
223 | getByte = getByteV WORD_SHIFT
224 |
225 | instance CritBitKey (U.Vector Char) where
226 | byteCount = (`shiftL` 2) . G.length
227 | getByte = getByteV_ fromEnum 2
228 |
229 | instance CritBitKey (V.Vector Word8) where
230 | byteCount = G.length
231 | getByte = getByteV 0
232 |
233 | instance CritBitKey (V.Vector Word16) where
234 | byteCount = (`shiftL` 1) . G.length
235 | getByte = getByteV 1
236 |
237 | instance CritBitKey (V.Vector Word32) where
238 | byteCount = (`shiftL` 2) . G.length
239 | getByte = getByteV 2
240 |
241 | instance CritBitKey (V.Vector Word64) where
242 | byteCount = (`shiftL` 3) . G.length
243 | getByte = getByteV 3
244 |
245 | instance CritBitKey (V.Vector Word) where
246 | byteCount = (`shiftL` WORD_SHIFT) . G.length
247 | getByte = getByteV WORD_SHIFT
248 |
249 | instance CritBitKey (V.Vector Char) where
250 | byteCount = (`shiftL` 2) . G.length
251 | getByte = getByteV_ fromEnum 2
252 |
253 | getByteV :: (Bits a, Integral a, G.Vector v a) => Int -> v a -> Int -> Word16
254 | getByteV = getByteV_ id
255 | {-# INLINE getByteV #-}
256 |
257 | getByteV_ :: (Bits a, Integral a, G.Vector v b) =>
258 | (b -> a) -> Int -> v b -> Int -> Word16
259 | getByteV_ convert shiftSize = \v n ->
260 | if n < G.length v `shiftL` shiftSize
261 | then reindex shiftSize n $ \wordOffset shiftRight ->
262 | let word = convert (G.unsafeIndex v wordOffset)
263 | byteInWord = (word `shiftR` shiftRight) .&. 255
264 | in fromIntegral byteInWord .|. 256
265 | else 0
266 | {-# INLINE getByteV_ #-}
267 |
268 | reindex :: Int -> Int -> (Int -> Int -> r) -> r
269 | reindex shiftSize n f = f wordOffset shiftRight
270 | where
271 | wordOffset = n `shiftR` shiftSize
272 | shiftRight = (size - (n .&. size)) `shiftL` 3
273 | where size = (1 `shiftL` shiftSize) - 1
274 | {-# INLINE reindex #-}
275 |
276 | -- | /O(n)/. Convert the map to a list of key\/value pairs. The list
277 | -- returned will be sorted in lexicographically ascending order.
278 | --
279 | -- > toList (fromList [("b",3), ("a",5)]) == [("a",5),("b",3)]
280 | -- > toList empty == []
281 | toList :: CritBit k v -> [(k, v)]
282 | toList (CritBit root) = go root []
283 | where
284 | go (Internal l r _ _) next = go l (go r next)
285 | go (Leaf k v) next = (k,v) : next
286 | go Empty next = next
287 |
288 |
289 | -- | A set based on crit-bit trees.
290 | newtype Set a = Set (CritBit a ())
291 | deriving (Eq, NFData)
292 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2013 Bryan O'Sullivan
2 | All rights reserved.
3 |
4 | Redistribution and use in source and binary forms, with or without
5 | modification, are permitted provided that the following conditions
6 | are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 |
--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
1 | Crit-bit trees for Haskell
2 | ====
3 |
4 | This is the first purely functional implementation of [crit-bit
5 | trees](http://cr.yp.to/critbit.html) that I'm aware of.
6 |
7 | A crit-bit tree is a key/value container that allows efficient lookups
8 | and ordered traversal for data that can be represented as a string of
9 | bits.
10 |
11 | This package exists in part with education in mind:
12 |
13 | * The core data structures are simple.
14 |
15 | * The core algorithms are easy to grasp.
16 |
17 | * I have intentionally structured the source to be easy to follow and
18 | extend.
19 |
20 | * Originally, I *deliberately* left the package incomplete. (It has
21 | since been substantially fleshed out.) Ever thought to yourself,
22 | "I'd write a bit of Haskell if only I had a project to work on"?
23 | Well, here's your chance! I will set aside time to review your code
24 | and answer what questions I can.
25 |
26 | Education aside, crit-bit trees offer some interesting features
27 | compared to other key/value container types in Haskell.
28 |
29 | * For some operations, they are much faster than `Data.Map` from the
30 | `containers` package, while for others, they are slower.
31 |
32 | * Compared to `Data.HashMap`, you get about the same lookup
33 | performance, but also some features that a hash-based structure
34 | can't provide: prefix-based search, efficient neighbour lookup,
35 | ordered storage.
36 |
37 | Of course crit-bit trees have some downsides, too. For example,
38 | building a tree from randomly ordered inputs is somewhat slow, and of
39 | course the set of usable key types is small (only types that can be
40 | interpreted as bitstrings "for free").
41 |
42 | Compared to the most easily findable crit-bit tree code you'll come
43 | across that's [written in C](https://github.com/glk/critbit), the core
44 | of this library has a lot less accidental complexity, and so may be
45 | easier to understand. It also handles arbitrary binary data that will
46 | cause the C library to go wrong.
47 |
48 |
49 |
50 | How to contribute
51 | ====
52 |
53 | I've purposely published this package in an incomplete state, and I'd
54 | like your help to round it out. In return, you get to learn a little
55 | Haskell, have your code reviewed by someone who wants to see you
56 | succeed, and contribute to a rather nifty library.
57 |
58 | Do you need any prior experience with Haskell to get started? No! All
59 | you need is curiosity and the ability to learn from context. Oh, and a
60 | github account.
61 |
62 | My aim with this library is drop-in API compatibility with the widely
63 | used Haskell [`containers`](https://github.com/haskell/containers)
64 | library, which has two happy consequences:
65 |
66 | * There are lots of functions to write!
67 |
68 | * In almost every case, you'll find a pre-existing function in
69 | `containers` that (from a user's perspective) does exactly what its
70 | counterparts in *this* library ought to do.
71 |
72 |
73 | Getting started
74 | ----
75 |
76 | If you want to contribute or play around, please use the most modern
77 | version of the [Haskell Platform](http://www.haskell.org/platform/).
78 |
79 | Once you have the Platform installed, there are just a few more steps.
80 |
81 | Set up your local database of known open source Haskell packages.
82 |
83 | cabal update
84 |
85 | Both the new `cabal` command and `cabal-dev` will install to
86 | `$HOME/.cabal/bin`, so put that directory at the front of your shell's
87 | search path before you continue.
88 |
89 | Get the `critbit` source.
90 |
91 | git clone git://github.com/bos/critbit
92 |
93 | Set up a sandbox.
94 |
95 | The first time through, you may need to download and install a ton of
96 | dependencies, so hang in there.
97 |
98 | cd critbit
99 | cabal sandbox init
100 | cabal install \
101 | --enable-tests \
102 | --enable-benchmarks \
103 | --only-dependencies \
104 | -j
105 |
106 | The `-j` flag above tells `cabal` to use all of your CPUs, so even the
107 | initial build shouldn't take more than a few minutes.
108 |
109 | To actually build:
110 |
111 | cabal build
112 |
113 |
114 | Running the test suite
115 | ----
116 |
117 | Once you've built the code, you can run the entire test suite fairly
118 | quickly. This takes about 30 seconds on my oldish 8-core Mac laptop:
119 |
120 | dist/build/tests/tests +RTS -N
121 |
122 | (The `+RTS -N` above tells GHC's runtime system to use all available
123 | cores.)
124 |
125 | If you're feeling impatient, run a subset of the test suite:
126 |
127 | dist/build/tests/tests -t properties/map/bytestring +RTS -N
128 |
129 | And if you want to explore, the `tests` program accepts a `--help`
130 | option. Try it out.
131 |
132 |
133 | Running benchmarks
134 | ----
135 |
136 | It is just as easy to benchmark stuff as to test it.
137 |
138 | First, you need a dictionary. If your system doesn't have a file named
139 | `/usr/share/dict/words`, you can [download a dictionary
140 | here](http://www.cs.duke.edu/~ola/ap/linuxwords).
141 |
142 | If you've downloaded a dictionary, tell the benchmark
143 | suite where to find it by setting the `WORDS` environment variable.
144 |
145 | export WORDS=/my/path/to/linuxwords
146 |
147 | You can then run benchmarks and generate a report. For instance, this
148 | runs every benchmark that begins with `bytestring/lookup`.
149 |
150 | dist/build/benchmarks/benchmarks -o lookup.html \
151 | bytestring/lookup
152 |
153 | Open the `lookup.html` file in your browser. [Here's an
154 | example](http://htmlpreview.github.io/?https://github.com/bos/critbit/blob/master/doc/criterion-sample-lookup.html)
155 | of what to expect.
156 |
157 | As with `tests`, run the `benchmarks` program with `--help` if you
158 | want to do some exploring.
159 |
160 |
161 |
162 | What your code should look like
163 | ----
164 |
165 | Okay, so you've bought into this idea, and would like to try writing a
166 | patch. How to begin?
167 |
168 | I've generally tried to write commits with a view to being readable,
169 | so there are examples you can follow.
170 |
171 | For instance, [here's the commit where I added the `keys`
172 | function](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3). This
173 | commit follows a simple pattern:
174 |
175 | * [Uncomment the export](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L0L91) of the function.
176 |
177 | * [Write the function
178 | definition](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L0R503).
179 | In this case, the documentation is taken almost verbatim from the
180 | corresponding function in [the `Data.Map`
181 | module](https://github.com/haskell/containers/blob/342a95002822cca56f2d5b086cdd5a98592d5c10/Data/Map/Base.hs#L1889).
182 |
183 | * [Write a
184 | test](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L2R108)
185 | and [make sure it gets
186 | run](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L2R124).
187 |
188 | * [Add an entry to the benchmark
189 | suite](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L1R179)
190 | so it's easy to see how this compares to other key/value map types.
191 |
192 | Naturally, you'll follow the prevailing coding and formatting style.
193 | If you forget, I'll be sad and offer you only a terse "fix your
194 | formatting" review, and then you'll be sad too.
195 |
196 |
197 | What your commits should look like
198 | ----
199 |
200 | Please follow the guidelines below, as they make it easier to review
201 | your pull request and deal with your commits afterwards.
202 |
203 | * One logical idea per commit! If you want to add five functions,
204 | that's fine, but please spread them across five commits.
205 |
206 | * Do not reorganize or refactor unrelated code in a commit whose
207 | purpose is to add new code.
208 |
209 | * When you add a new function, add its tests and benchmarks in the
210 | same commit.
211 |
212 | * Do not add trailing whitespace. Follow the same formatting
213 | and naming conventions as you already see in the code around you.
214 |
215 | * Keep your maximum line length at 80 columns for everything except
216 | lines of example code in documentation.
217 |
218 | (If you can't follow the guidelines, there's a good chance I'll ask
219 | you to fix your commits and resubmit them.)
220 |
--------------------------------------------------------------------------------
/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env runhaskell
2 | > import Distribution.Simple
3 | > main = defaultMain
4 |
--------------------------------------------------------------------------------
/benchmarks/Benchmarks.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, OverloadedStrings #-}
2 | module Main (main) where
3 |
4 | import Control.Applicative ((<$>))
5 | import Control.Arrow (first)
6 | import Control.DeepSeq (NFData(..))
7 | import Control.Monad (when)
8 | import Control.Monad.Trans (liftIO)
9 | import Criterion.Main (bench, bgroup, defaultMain, nf, whnf)
10 | import Criterion.Types (Pure)
11 | import Data.Foldable (foldMap)
12 | import Data.Functor.Identity (Identity(..))
13 | import Data.Hashable (Hashable(..), hashByteArray)
14 | import Data.Maybe (fromMaybe, fromJust)
15 | import Data.Monoid (Sum(..),mappend)
16 | import Data.Text.Array (aBA)
17 | import Data.Text.Encoding (decodeUtf8)
18 | import Data.Text.Internal (Text(..))
19 | import System.Environment (getEnv)
20 | import System.IO (hPutStrLn, stderr)
21 | import System.IO.Error (ioError, isDoesNotExistError)
22 | import System.Random.MWC (GenIO, GenST, asGenST, create, uniform, uniformR)
23 | import qualified Control.Exception as Exc
24 | import qualified Data.ByteString.Char8 as B
25 | import qualified Data.CritBit.Map.Lazy as C
26 | import qualified Data.CritBit.Set as CSet
27 | import qualified Data.HashMap.Lazy as H
28 | import qualified Data.Map as Map
29 | import qualified Data.Set as Set
30 | import qualified Data.Text as T
31 | import qualified Data.Trie as Trie
32 | import qualified Data.Trie.Convenience as TC
33 | import qualified Data.Vector as V
34 | import qualified Data.Vector.Generic as G
35 | import qualified Data.Vector.Generic.Mutable as M
36 | import qualified Data.Vector.Unboxed as U
37 | import qualified Data.List as L
38 |
39 | #if 0
40 | instance Hashable Text where
41 | hash (Text arr off len) = hashByteArray (aBA arr) (off * 2) (len * 2)
42 | {-# INLINE hash #-}
43 | #endif
44 |
45 | #if !MIN_VERSION_bytestring(0,10,0)
46 | instance NFData B.ByteString
47 | #endif
48 |
49 | instance (NFData a) => NFData (Trie.Trie a) where
50 | rnf = rnf . Trie.toList
51 |
52 | forcePair :: (a,b) -> ()
53 | forcePair (a,b) = a `seq` b `seq` ()
54 |
55 | addvs :: (Num v) => k -> v -> v -> v
56 | addvs _ v1 v2 = v1 + v2
57 |
58 | every k = go 0
59 | where
60 | go i (x:xs)
61 | | i == k-1 = x : go 0 xs
62 | | otherwise = go (i+1) xs
63 | go _ _ = []
64 |
65 | shuffle :: GenIO -> Double -> [Int] -> IO [Int]
66 | shuffle gen prob xs = do
67 | let vec = V.fromList xs
68 | len = G.length vec
69 | v <- G.unsafeThaw vec
70 | let go i | i == 1 = return ()
71 | | otherwise = do
72 | p <- uniform gen
73 | when (p <= prob) $
74 | M.unsafeSwap v i =<< uniformR (0, i) gen
75 | go (i-1)
76 | go (len - 1)
77 | V.toList <$> G.unsafeFreeze v
78 |
79 | chartres = do
80 | let xs = [0..2999]
81 | nxs = fromIntegral (length xs) :: Double
82 | go pct = do
83 | gen <- create
84 | let prob = fromIntegral pct / 100
85 | ys <- shuffle gen prob xs
86 | let mismatches = length . filter id . zipWith (/=) xs $ ys
87 | putStrLn $ show prob ++ " " ++ show (fromIntegral mismatches / nxs)
88 | mapM_ go [0..100]
89 |
90 | mapFKey :: (Num v, C.CritBitKey k) => k -> v -> v
91 | mapFKey _ x = x + 1
92 |
93 | mapAccumFKey :: (C.CritBitKey k, Num v) => Int -> k -> v -> (Int, v)
94 | mapAccumFKey a _ v = (a + 1, v + 1)
95 |
96 | updateFKey :: Num v => k -> v -> Maybe v
97 | updateFKey _ v = Just $ v + 1
98 |
99 | updateFVal :: Num v => v -> Maybe v
100 | updateFVal v = updateFKey undefined v
101 |
102 | main = do
103 | fileName <- getEnv "WORDS" `Exc.catch` \(_::IOError) ->
104 | return "/usr/share/dict/words"
105 | ordKeys <- L.sort <$> (every 5 . B.words) <$> B.readFile fileName
106 | `Exc.catch` \(err::IOError) -> do
107 | when (isDoesNotExistError err) $
108 | hPutStrLn stderr
109 | ("(point the 'WORDS' environment variable at a file " ++
110 | "to use it for benchmark data)")
111 | ioError err
112 | let b_ordKVs = zip ordKeys [(0::Int)..]
113 | prefix = B.concat $ L.map fst b_ordKVs
114 | b_longKVs = map (first (B.append prefix)) b_ordKVs
115 | b_revKVs = reverse b_ordKVs
116 | b_randKVs <- do
117 | gen <- create
118 | let kvVec = V.fromList b_ordKVs
119 | (G.toList . G.backpermute kvVec) <$>
120 | G.replicateM (G.length kvVec) (uniformR (0, G.length kvVec - 1) gen)
121 | let t_ordKVs = map (first decodeUtf8) b_ordKVs
122 | t_randKVs = map (first decodeUtf8) b_randKVs
123 | t_revKVs = map (first decodeUtf8) b_revKVs
124 | b_critbit = C.fromList b_randKVs
125 | b_map = Map.fromList b_randKVs
126 | b_hashmap = H.fromList b_randKVs
127 | b_trie = Trie.fromList b_randKVs
128 | key = fst . head $ b_randKVs
129 | b_critbit_1 = C.delete key b_critbit
130 | b_map_1 = Map.delete key b_map
131 | b_hashmap_1 = H.delete key b_hashmap
132 | b_trie_1 = Trie.delete key b_trie
133 | (b_randKVs_13, b_randKVs_23) = (take (l - n) b_randKVs, drop n b_randKVs)
134 | where
135 | l = length b_randKVs
136 | n = l `div` 3
137 | b_critbit_13 = C.fromList b_randKVs_13
138 | b_critbit_23 = C.fromList b_randKVs_23
139 | b_map_13 = Map.fromList b_randKVs_13
140 | b_map_23 = Map.fromList b_randKVs_23
141 | b_hashmap_13 = H.fromList b_randKVs_13
142 | b_hashmap_23 = H.fromList b_randKVs_23
143 | b_trie_13 = Trie.fromList b_randKVs_13
144 | b_trie_23 = Trie.fromList b_randKVs_23
145 | fromList kvs = [
146 | bench "critbit" $ whnf C.fromList kvs
147 | , bench "map" $ whnf Map.fromList kvs
148 | , bench "hashmap" $ whnf H.fromList kvs
149 | ]
150 | fromListWith kvs = [
151 | bench "critbit" $ whnf (C.fromListWith (+)) kvs
152 | , bench "map" $ whnf (Map.fromListWith (+)) kvs
153 | , bench "hashmap" $ whnf (H.fromListWith (+)) kvs
154 | , bench "trie" $ whnf (TC.fromListWith (+)) kvs
155 | ]
156 | fromListWithKey kvs = [
157 | bench "critbit" $ whnf (C.fromListWithKey addvs) kvs
158 | , bench "map" $ whnf (Map.fromListWithKey addvs) kvs
159 | -- , bench "hashmap" $ whnf (H.fromListWithKey (\a b -> a+b)) kvs
160 | -- , bench "trie" $ whnf (TC.fromListWithKey (\a b -> a+b)) kvs
161 | ]
162 | keyed critbit map hashmap trie =
163 | [
164 | bgroup "present" [
165 | bench "critbit" $ whnf (critbit key) b_critbit
166 | , bench "map" $ whnf (map key) b_map
167 | , bench "hashmap" $ whnf (hashmap key) b_hashmap
168 | , bench "trie" $ whnf (trie key) b_trie
169 | ]
170 | , bgroup "missing" [
171 | bench "critbit" $ whnf (critbit key) b_critbit_1
172 | , bench "map" $ whnf (map key) b_map_1
173 | , bench "hashmap" $ whnf (hashmap key) b_hashmap_1
174 | , bench "trie" $ whnf (trie key) b_trie_1
175 | ]
176 | ]
177 | twoMaps critbit map hashmap trie = [
178 | bench "critbit" $ whnf (critbit b_critbit_13) b_critbit_23
179 | , bench "map" $ whnf (map b_map_13) b_map_23
180 | , bench "hashmap" $ whnf (hashmap b_hashmap_13) b_hashmap_23
181 | , bench "trie" $ whnf (trie b_trie_13) b_trie_23
182 | ]
183 | function (eval :: forall a b. NFData b => (a -> b) -> a -> Pure)
184 | critbit map hashmap trie = [
185 | bench "critbit" $ eval critbit b_critbit
186 | , bench "map" $ eval map b_map
187 | , bench "hashmap" $ eval hashmap b_hashmap
188 | , bench "trie" $ eval trie b_trie
189 | ]
190 | Exc.evaluate $ rnf [rnf b_critbit, rnf b_critbit_1, rnf b_map, rnf b_map_1,
191 | rnf b_hashmap, rnf b_hashmap_1, rnf b_trie, rnf b_trie_1,
192 | rnf b_randKVs, rnf b_revKVs, rnf key,
193 | rnf b_critbit_13, rnf b_critbit_23,
194 | rnf b_map_13, rnf b_map_23,
195 | rnf b_hashmap_13, rnf b_hashmap_23,
196 | rnf b_trie_13, rnf b_trie_23]
197 | defaultMain
198 | [ bgroup "bytestring" [
199 | bgroup "size" $ function whnf C.size Map.size H.size Trie.size
200 | , bgroup "fromList" [
201 | bgroup "ordered" $ fromList b_ordKVs ++
202 | [ bench "trie" $ whnf Trie.fromList b_ordKVs ]
203 | , bgroup "random" $ fromList b_randKVs ++
204 | [ bench "trie" $ whnf Trie.fromList b_randKVs ]
205 | , bgroup "reversed" $ fromList b_revKVs ++
206 | [ bench "trie" $ whnf Trie.fromList b_revKVs ]
207 | ]
208 | , bgroup "fromListWith" [
209 | bgroup "ordered" $ fromListWith b_ordKVs
210 | , bgroup "random" $ fromListWith b_randKVs
211 | , bgroup "reversed" $ fromListWith b_revKVs
212 | ]
213 | , bgroup "fromListWithKey" [
214 | bgroup "ordered" $ fromListWithKey b_ordKVs
215 | , bgroup "random" $ fromListWithKey b_randKVs
216 | , bgroup "reversed" $ fromListWithKey b_revKVs
217 | ]
218 | , bgroup "delete" $ keyed C.delete Map.delete H.delete Trie.delete
219 | , bgroup "insert" $ keyed (`C.insert` 1) (`Map.insert` 1)
220 | (`H.insert` 1) (`Trie.insert` 1)
221 | , bgroup "insertWith" [
222 | bgroup "present" [
223 | bench "critbit" $ whnf (C.insertWith (+) key 1) b_critbit
224 | , bench "map" $ whnf (Map.insertWith (+) key 1) b_map
225 | , bench "hashmap" $ whnf (H.insertWith (+) key 1) b_hashmap
226 | ]
227 | , bgroup "missing" [
228 | bench "critbit" $ whnf (C.insertWith (+) key 1) b_critbit_1
229 | , bench "map" $ whnf (Map.insertWith (+) key 1) b_map_1
230 | , bench "hashmap" $ whnf (H.insertWith (+) key 1) b_hashmap_1
231 | ]
232 | ]
233 | , bgroup "insertWithKey" [
234 | bgroup "present" [
235 | bench "critbit" $ whnf (C.insertWithKey addvs key 1) b_critbit
236 | , bench "map" $ whnf (Map.insertWithKey addvs key 1) b_map
237 | ]
238 | , bgroup "missing" [
239 | bench "critbit" $ whnf (C.insertWithKey addvs key 1) b_critbit_1
240 | , bench "map" $ whnf (Map.insertWithKey addvs key 1) b_map_1
241 | ]
242 | ]
243 | , bgroup "insertLookupWithKey" [
244 | bgroup "present" [
245 | bench "critbit" $
246 | whnf (forcePair . C.insertLookupWithKey addvs key 1) b_critbit
247 | , bench "map" $
248 | whnf (forcePair . Map.insertLookupWithKey addvs key 1) b_map
249 | ]
250 | , bgroup "missing" [
251 | bench "critbit" $
252 | whnf (forcePair . C.insertLookupWithKey addvs key 1) b_critbit_1
253 | , bench "map" $
254 | whnf (forcePair . Map.insertLookupWithKey addvs key 1) b_map_1
255 | ]
256 | ]
257 | , bgroup "adjust" $
258 | let f v = (v + 10) in [
259 | bgroup "present" [
260 | bench "critbit" $ whnf (C.adjust f key) b_critbit
261 | , bench "map" $ whnf (Map.adjust f key) b_map
262 | ]
263 | , bgroup "missing" [
264 | bench "critbit" $ whnf (C.adjust f key) b_critbit_1
265 | , bench "map" $ whnf (Map.adjust f key) b_map_1
266 | ]
267 | ]
268 | , bgroup "adjustWithKey" $
269 | let f k v = (v + fromIntegral (C.byteCount k)) in [
270 | bgroup "present" [
271 | bench "critbit" $ whnf (C.adjustWithKey f key) b_critbit
272 | , bench "map" $ whnf (Map.adjustWithKey f key) b_map
273 | , bench "trie" $ whnf (TC.adjustWithKey f key) b_trie
274 | ]
275 | , bgroup "missing" [
276 | bench "critbit" $ whnf (C.adjustWithKey f key) b_critbit_1
277 | , bench "map" $ whnf (Map.adjustWithKey f key) b_map_1
278 | , bench "trie" $ whnf (TC.adjustWithKey f key) b_trie_1
279 | ]
280 | ]
281 | , bgroup "updateWithKey" $
282 | let f k v = Just (v + fromIntegral (C.byteCount k)) in [
283 | bgroup "present" [
284 | bench "critbit" $ whnf (C.updateWithKey f key) b_critbit
285 | , bench "map" $ whnf (Map.updateWithKey f key) b_map
286 | , bench "trie" $ whnf (TC.updateWithKey f key) b_trie
287 | ]
288 | , bgroup "missing" [
289 | bench "critbit" $ whnf (C.updateWithKey f key) b_critbit_1
290 | , bench "map" $ whnf (Map.updateWithKey f key) b_map_1
291 | , bench "trie" $ whnf (TC.updateWithKey f key) b_trie_1
292 | ]
293 | ]
294 | , bgroup "update" $
295 | let f = updateFVal in [
296 | bgroup "present" [
297 | bench "critbit" $ whnf (C.update f key) b_critbit
298 | , bench "map" $ whnf (Map.update f key) b_map
299 | , bench "trie" $ whnf (TC.update f key) b_trie
300 | ]
301 | , bgroup "missing" [
302 | bench "critbit" $ whnf (C.update f key) b_critbit_1
303 | , bench "map" $ whnf (Map.update f key) b_map_1
304 | , bench "trie" $ whnf (TC.update f key) b_trie_1
305 | ]
306 | ]
307 | , bgroup "updateLookupWithKey" $
308 | -- The Map implementation immediately returns a tuple with lazy values,
309 | -- so we need to force it to evaluate the update.
310 | let f k v = Just (v + fromIntegral (C.byteCount k)) in [
311 | bgroup "present" [
312 | bench "critbit" $ whnf
313 | (snd . C.updateLookupWithKey f key) b_critbit
314 | , bench "map" $ whnf
315 | (snd . Map.updateLookupWithKey f key) b_map
316 | ]
317 | , bgroup "missing" [
318 | bench "critbit" $ whnf
319 | (snd . C.updateLookupWithKey f key) b_critbit_1
320 | , bench "map" $ whnf
321 | (snd . Map.updateLookupWithKey f key) b_map_1
322 | ]
323 | ]
324 | , bgroup "lookup" $ keyed C.lookup Map.lookup H.lookup Trie.lookup
325 | #if MIN_VERSION_containers(0,5,0)
326 | , bgroup "lookupGT" $ [
327 | bench "critbit" $ whnf (C.lookupGT key) b_critbit
328 | , bench "map" $ whnf (Map.lookupGT key) b_map
329 | ]
330 | , bgroup "lookupGE" $ [
331 | bench "critbit" $ whnf (C.lookupGE key) b_critbit
332 | , bench "map" $ whnf (Map.lookupGE key) b_map
333 | ]
334 | , bgroup "lookupLT" $ [
335 | bench "critbit" $ whnf (C.lookupLT key) b_critbit
336 | , bench "map" $ whnf (Map.lookupLT key) b_map
337 | ]
338 | , bgroup "lookupLE" $ [
339 | bench "critbit" $ whnf (C.lookupLE key) b_critbit
340 | , bench "map" $ whnf (Map.lookupLE key) b_map
341 | ]
342 | , bgroup "fromSet" $
343 | let
344 | keys = map fst t_ordKVs
345 | f = length . show
346 | in [
347 | bench "critbit" $ nf (C.fromSet f) (CSet.fromList keys)
348 | , bench "map" $ nf (Map.fromSet f) (Set.fromList keys)
349 | ]
350 | #endif
351 | , bgroup "member" $ keyed C.member Map.member H.member Trie.member
352 | , bgroup "foldlWithKey'" $ let f a _ b = a + b
353 | in function whnf (C.foldlWithKey' f 0)
354 | (Map.foldlWithKey' f 0)
355 | (H.foldlWithKey' f 0) id
356 | , bgroup "foldl'" $ function whnf (C.foldl' (+) 0) (Map.foldl' (+) 0)
357 | (H.foldl' (+) 0) id
358 | , bgroup "elems" $ function nf C.elems Map.elems H.elems Trie.elems
359 | , bgroup "keys" $ function nf C.keys Map.keys H.keys Trie.keys
360 | , bgroup "keysSet" [
361 | bench "critbit" $ nf C.keysSet b_critbit
362 | , bench "map" $ nf Map.keysSet b_map
363 | ]
364 | , bgroup "map" $ let f = (+3)
365 | in function nf (C.map f) (Map.map f) (H.map f) (fmap f)
366 | , bgroup "mapWithKey" [
367 | bench "critbit" $ whnf (C.mapWithKey mapFKey) b_critbit
368 | , bench "map" $ whnf (Map.mapWithKey mapFKey) b_map
369 | ]
370 | , bgroup "mapKeys" $ let f = (`mappend` "test") in [
371 | bench "critbit" $ nf (C.mapKeys f) b_critbit
372 | , bench "map" $ nf (Map.mapKeys f) b_map
373 | ]
374 | , bgroup "mapKeysWith" $ let f = (`mappend` "test") in [
375 | bench "critbit" $ nf (C.mapKeysWith (+) f) b_critbit
376 | , bench "map" $ nf (Map.mapKeysWith (+) f) b_map
377 | ]
378 | , bgroup "mapKeysMonotonic" $ let f = mappend "test" in [
379 | bench "critbit" $ nf (C.mapKeysMonotonic f) b_critbit
380 | , bench "map" $ nf (Map.mapKeysMonotonic f) b_map
381 | ]
382 | , bgroup "mapAccumWithKey" [
383 | bench "critbit" $ whnf (C.mapAccumWithKey mapAccumFKey 0) b_critbit
384 | , bench "map" $ whnf (Map.mapAccumWithKey mapAccumFKey 0) b_map
385 | ]
386 | , bgroup "mapAccumRWithKey" [
387 | bench "critbit" $ whnf (C.mapAccumRWithKey mapAccumFKey 0) b_critbit
388 | , bench "map" $ whnf (Map.mapAccumRWithKey mapAccumFKey 0) b_map
389 | ]
390 | , bgroup "union" $ twoMaps C.unionR Map.union H.union Trie.unionR
391 | , bgroup "unionWith" [
392 | bench "critbit" $ whnf (C.unionWith (+) b_critbit_13) b_critbit_23
393 | , bench "map" $ whnf (Map.unionWith (+) b_map_13) b_map_23
394 | ]
395 | , bgroup "unionWithKey" [
396 | bench "critbit" $ whnf (C.unionWithKey addvs b_critbit_13) b_critbit_23
397 | , bench "map" $ whnf (Map.unionWithKey addvs b_map_13) b_map_23
398 | ]
399 | , bgroup "unions" [
400 | bench "critbit" $ whnf C.unions [b_critbit_13, b_critbit_23]
401 | , bench "map" $ whnf Map.unions [b_map_13, b_map_23]
402 | ]
403 | , bgroup "unionsWith" [
404 | bench "critbit" $ whnf (C.unionsWith (+)) [b_critbit_13, b_critbit_23]
405 | , bench "map" $ whnf (Map.unionsWith (+)) [b_map_13, b_map_23]
406 | ]
407 | , bgroup "difference" [
408 | bench "critbit" $ whnf (C.difference b_critbit_13) b_critbit_23
409 | , bench "map" $ whnf (Map.difference b_map_13) b_map_23
410 | , bench "hashmap" $ whnf (H.difference b_hashmap_13) b_hashmap_23
411 | ]
412 | , bgroup "differenceWith" $ let f a b = Just (a + b) in [
413 | bench "critbit" $ whnf (C.differenceWith f b_critbit_13) b_critbit_23
414 | , bench "map" $ whnf (Map.differenceWith f b_map_13) b_map_23
415 | ]
416 | , bgroup "differenceWithKey" $ let f _ a b = Just(a + b) in [
417 | bench "critbit" $ whnf (C.differenceWithKey f b_critbit_13) b_critbit_23
418 | , bench "map" $ whnf (Map.differenceWithKey f b_map_13) b_map_23
419 | ]
420 | , bgroup "intersection" [
421 | bench "critbit" $ whnf (C.intersection b_critbit_13) b_critbit_23
422 | , bench "map" $ whnf (Map.intersection b_map_13) b_map_23
423 | , bench "hashmap" $ whnf (H.intersection b_hashmap_13) b_hashmap_23
424 | ]
425 | , bgroup "intersectionWith" [
426 | bench "critbit" $ whnf (C.intersectionWith (+) b_critbit_13) b_critbit_23
427 | , bench "map" $ whnf (Map.intersectionWith (+) b_map_13) b_map_23
428 | , bench "hashmap" $ whnf (H.intersectionWith (+) b_hashmap_13) b_hashmap_23
429 | ]
430 | , bgroup "intersectionWithKey" [
431 | bench "critbit" $
432 | whnf (C.intersectionWithKey addvs b_critbit_13) b_critbit_23
433 | , bench "map" $
434 | whnf (Map.intersectionWithKey addvs b_map_13) b_map_23
435 | ]
436 | , bgroup "toAscList" $ function nf C.toAscList Map.toAscList id id
437 | , bgroup "toDescList" $ function nf C.toDescList Map.toDescList id id
438 | , bgroup "fromAscList_short" [
439 | bench "critbit" $ nf C.fromAscList b_ordKVs
440 | , bench "map" $ nf Map.fromAscList b_ordKVs
441 | ]
442 | , bgroup "fromAscList_long" [
443 | bench "critbit" $ nf C.fromAscList b_longKVs
444 | , bench "map" $ nf Map.fromAscList b_longKVs
445 | ]
446 | , bgroup "fromAscListWith" [
447 | bench "critbit" $ nf ( C.fromAscListWith (+)) b_ordKVs
448 | , bench "map" $ nf (Map.fromAscListWith (+)) b_ordKVs
449 | ]
450 | , bgroup "fromAscListWithKey" [
451 | bench "critbit" $ nf ( C.fromAscListWithKey (const (+))) b_ordKVs
452 | , bench "map" $ nf (Map.fromAscListWithKey (const (+))) b_ordKVs
453 | ]
454 | , bgroup "fromAscDistinctList_short" [
455 | bench "critbit" $ nf C.fromDistinctAscList b_ordKVs
456 | , bench "map" $ nf Map.fromDistinctAscList b_ordKVs
457 | ]
458 | , bgroup "fromAscDistinctList_long" [
459 | bench "critbit" $ nf C.fromDistinctAscList b_longKVs
460 | , bench "map" $ nf Map.fromDistinctAscList b_longKVs
461 | ]
462 | , bgroup "filter" $ let p = (< 128)
463 | p' = \e -> if p e then Just e else Nothing
464 | in function nf (C.filter p) (Map.filter p)
465 | (H.filter p) (Trie.filterMap p')
466 | , bgroup "mapMaybe" $
467 | let f x = if even x then Just (2 * x) else Nothing
468 | in [
469 | bench "critbit" $ whnf (C.mapMaybe f) b_critbit
470 | , bench "map" $ whnf (Map.mapMaybe f) b_map
471 | ]
472 | , bgroup "mapMaybeWithKey" $
473 | let f k v | even (fromIntegral v :: Int) =
474 | Just (v + fromIntegral (C.byteCount k))
475 | | otherwise = Nothing
476 | in [
477 | bench "critbit" $ whnf (C.mapMaybeWithKey f) b_critbit
478 | , bench "map" $ whnf (Map.mapMaybeWithKey f) b_map
479 | ]
480 | , bgroup "mapEither" $
481 | let f x = if even x then Left (2 * x) else Right (3 * x)
482 | in [
483 | bench "critbit" $ whnf (C.mapEither f) b_critbit
484 | , bench "map" $ whnf (Map.mapEither f) b_map
485 | ]
486 | , bgroup "mapEitherWithKey" $
487 | let f k v | even (fromIntegral v :: Int) =
488 | Left (v + fromIntegral (C.byteCount k))
489 | | otherwise = Right (2 * v)
490 | in [
491 | bench "critbit" $ nf (C.mapEitherWithKey f) b_critbit
492 | , bench "map" $ nf (Map.mapEitherWithKey f) b_map
493 | ]
494 | , bgroup "split" [
495 | bench "critbit" $ whnf (forcePair . C.split key) b_critbit
496 | , bench "map" $ whnf (forcePair . Map.split key) b_map
497 | ]
498 | , bgroup "splitLookup" $
499 | let forceTriple (a,_,b) = a `seq` b `seq` ()
500 | in [
501 | bench "critbit" $ whnf (forceTriple . C.splitLookup key) b_critbit
502 | , bench "map" $ whnf (forceTriple . Map.splitLookup key) b_map
503 | ]
504 | , bgroup "isSubmapOf" [
505 | bench "critbit" $ whnf (C.isSubmapOf b_critbit_1) b_critbit
506 | , bench "map" $ whnf (Map.isSubmapOf b_map_1) b_map
507 | ]
508 | , bgroup "isSubmapOfBy" [
509 | bench "critbit" $ whnf (C.isSubmapOfBy (<=) b_critbit_1) b_critbit
510 | , bench "map" $ whnf (Map.isSubmapOfBy (<=) b_map_1) b_map
511 | ]
512 | , bgroup "isProperSubmapOf" [
513 | bench "critbit" $ whnf (C.isProperSubmapOf b_critbit_1) b_critbit
514 | , bench "map" $ whnf (Map.isProperSubmapOf b_map_1) b_map
515 | ]
516 | , bgroup "isProperSubmapOfBy" [
517 | bench "critbit" $
518 | whnf (C.isProperSubmapOfBy (<=) b_critbit_1) b_critbit
519 | , bench "map" $
520 | whnf (Map.isProperSubmapOfBy (<=) b_map_1) b_map
521 | ]
522 | , bgroup "findMin" [
523 | bench "critbit" $ whnf C.findMin b_critbit
524 | , bench "map" $ whnf Map.findMin b_map
525 | ]
526 | , bgroup "findMax" [
527 | bench "critbit" $ whnf C.findMax b_critbit
528 | , bench "map" $ whnf Map.findMax b_map
529 | ]
530 | , bgroup "deleteMin" [
531 | bench "critbit" $ whnf C.deleteMin b_critbit
532 | , bench "map" $ whnf Map.deleteMin b_map
533 | ]
534 | , bgroup "deleteMax" [
535 | bench "critbit" $ whnf C.deleteMax b_critbit
536 | , bench "map" $ whnf Map.deleteMax b_map
537 | ]
538 | , bgroup "deleteFindMin" [
539 | bench "critbit" $ whnf (snd . C.deleteFindMin) b_critbit
540 | , bench "map" $ whnf (snd . Map.deleteFindMin) b_map
541 | ]
542 | , bgroup "deleteFindMax" [
543 | bench "critbit" $ whnf (snd . C.deleteFindMax) b_critbit
544 | , bench "map" $ whnf (snd . Map.deleteFindMax) b_map
545 | ]
546 | , bgroup "minView" [
547 | bench "critbit" $ whnf (snd . fromJust . C.minView) b_critbit
548 | , bench "map" $ whnf (snd . fromJust . Map.minView) b_map
549 | ]
550 | , bgroup "maxView" [
551 | bench "critbit" $ whnf (snd . fromJust . C.maxView) b_critbit
552 | , bench "map" $ whnf (snd . fromJust . Map.maxView) b_map
553 | ]
554 | , bgroup "minViewWithKey" [
555 | bench "critbit" $ whnf (snd . fromJust . C.minViewWithKey) b_critbit
556 | , bench "map" $ whnf (snd . fromJust . Map.minViewWithKey) b_map
557 | ]
558 | , bgroup "maxViewWithKey" [
559 | bench "critbit" $ whnf (snd . fromJust . C.minViewWithKey) b_critbit
560 | , bench "map" $ whnf (snd . fromJust . Map.minViewWithKey) b_map
561 | ]
562 | , bgroup "updateMin" [
563 | bench "critbit" $ whnf (C.updateMin updateFVal) b_critbit
564 | , bench "map" $ whnf (Map.updateMin updateFVal) b_map
565 | ]
566 | , bgroup "updateMax" [
567 | bench "critbit" $ whnf (C.updateMax updateFVal) b_critbit
568 | , bench "map" $ whnf (Map.updateMax updateFVal) b_map
569 | ]
570 | , bgroup "traverseWithKey" $ let f _ = Identity . (+3) in [
571 | bench "critbit" $ nf (runIdentity . C.traverseWithKey f) b_critbit
572 | #if MIN_VERSION_containers(0,5,0)
573 | , bench "map" $ nf (runIdentity . Map.traverseWithKey f) b_map
574 | #endif
575 | , bench "hashmap" $ nf (runIdentity . H.traverseWithKey f) b_hashmap
576 | , bench "trie" $ nf (fmap f) b_trie
577 | ]
578 | , bgroup "updateMinWithKey" [
579 | bench "critbit" $ whnf (C.updateMinWithKey updateFKey) b_critbit
580 | , bench "map" $ whnf (Map.updateMinWithKey updateFKey) b_map
581 | ]
582 | , bgroup "updateMaxWithKey" [
583 | bench "critbit" $ whnf (C.updateMaxWithKey updateFKey) b_critbit
584 | , bench "map" $ whnf (Map.updateMaxWithKey updateFKey) b_map
585 | ]
586 | , bgroup "foldMap" [
587 | bench "critbit" $ let c_foldmap :: (C.CritBitKey k, Num v)
588 | => C.CritBit k v
589 | -> Sum v
590 | c_foldmap = foldMap Sum
591 | in whnf c_foldmap b_critbit
592 | , bench "map" $ let m_foldmap :: (Eq k, Num v)
593 | => Map.Map k v
594 | -> Sum v
595 | m_foldmap = foldMap Sum
596 | in whnf m_foldmap b_map
597 | ]
598 | , bgroup "alter" $ let altF (Just v) =
599 | if odd v
600 | then Just (v+1)
601 | else Nothing
602 | altF Nothing = Just 1
603 | in [
604 | bench "critbit" $ whnf (C.alter altF key) b_critbit
605 | , bench "map" $ whnf (Map.alter altF key) b_map
606 | ]
607 | , bgroup "partitionWithKey" $ let predicate k _ = odd $ C.byteCount k in [
608 | bench "critbit" $ whnf (forcePair . C.partitionWithKey predicate) b_critbit
609 | , bench "map" $ whnf (forcePair . Map.partitionWithKey predicate) b_map
610 | ]
611 | , bgroup "partition" [
612 | bench "critbit" $ whnf (forcePair . C.partition odd) b_critbit
613 | , bench "map" $ whnf (forcePair . Map.partition odd) b_map
614 | ]
615 | ]
616 | , bgroup "text" [
617 | bgroup "fromList" [
618 | bgroup "ordered" $ fromList t_ordKVs
619 | , bgroup "random" $ fromList t_randKVs
620 | , bgroup "reversed" $ fromList t_revKVs
621 | ]
622 | , bgroup "fromListWith" [
623 | bgroup "ordered" $ fromListWith b_ordKVs
624 | , bgroup "random" $ fromListWith b_randKVs
625 | , bgroup "reversed" $ fromListWith b_revKVs
626 | ]
627 | , bgroup "fromListWithKey" [
628 | bgroup "ordered" $ fromListWithKey b_ordKVs
629 | , bgroup "random" $ fromListWithKey b_randKVs
630 | , bgroup "reversed" $ fromListWithKey b_revKVs
631 | ]
632 | ]
633 | ]
634 |
--------------------------------------------------------------------------------
/critbit.cabal:
--------------------------------------------------------------------------------
1 | name: critbit
2 | version: 0.2.0.0
3 | homepage: https://github.com/bos/critbit
4 | bug-reports: https://github.com/bos/critbit/issues
5 | synopsis: Crit-bit maps and sets
6 | description:
7 | This package implements crit-bit trees, a key-value container type
8 | for storing keys that can be treated as bitstrings (e.g.
9 | 'ByteString' and 'Text').
10 | .
11 | Compared to the data structures from the containers and
12 | unordered-containers packages, you will find that sometimes the
13 | functions implemented in this package are faster, sometimes
14 | slower.
15 | .
16 | In many cases, a 'CritBit' tree provides performance close to that
17 | of a 'HashMap', while providing ordered storage and traversal
18 | like a 'Map'.
19 | license: BSD3
20 | license-file: LICENSE
21 | author: Bryan O'Sullivan
22 | maintainer: Bryan O'Sullivan
23 | copyright: 2013-2014 Bryan O'Sullivan and others
24 | category: Data
25 | build-type: Simple
26 | cabal-version: >= 1.14
27 | extra-source-files:
28 | README.markdown
29 |
30 | flag developer
31 | description: operate in developer mode
32 | default: False
33 |
34 | library
35 | default-language: Haskell2010
36 | exposed-modules:
37 | Data.CritBit.Map.Lazy
38 | Data.CritBit.Set
39 | other-modules:
40 | Data.CritBit.Core
41 | Data.CritBit.Types.Internal
42 | Data.CritBit.Tree
43 |
44 | build-depends:
45 | array,
46 | base >= 4 && < 5,
47 | bytestring >= 0.9,
48 | deepseq,
49 | text >= 0.11.2.3,
50 | vector
51 |
52 | ghc-options: -Wall -funbox-strict-fields -O2 -fwarn-tabs
53 | if flag(developer)
54 | ghc-prof-options: -auto-all
55 | ghc-options: -Werror
56 | cpp-options: -DASSERTS
57 |
58 | test-suite tests
59 | default-language: Haskell2010
60 | type: exitcode-stdio-1.0
61 | hs-source-dirs: tests
62 | main-is: Main.hs
63 | if impl(ghc >= 7.4)
64 | other-modules:
65 | Properties.Common
66 | Properties.Map
67 | Properties.Set
68 |
69 | ghc-options:
70 | -Wall -threaded -rtsopts -with-rtsopts=-N
71 |
72 | build-depends:
73 | QuickCheck >= 2.7,
74 | base >= 4 && < 5,
75 | bytestring,
76 | containers,
77 | critbit,
78 | test-framework >= 0.4,
79 | test-framework-quickcheck2 >= 0.2,
80 | text,
81 | transformers >= 0.3,
82 | vector
83 |
84 | benchmark benchmarks
85 | default-language: Haskell2010
86 | type: exitcode-stdio-1.0
87 | hs-source-dirs: benchmarks
88 | main-is: Benchmarks.hs
89 | ghc-options: -O2 -rtsopts
90 |
91 | build-depends:
92 | base >= 4 && < 5,
93 | bytestring,
94 | bytestring-trie,
95 | containers,
96 | critbit,
97 | criterion >= 0.8,
98 | deepseq,
99 | hashable < 1.2,
100 | mtl,
101 | mwc-random,
102 | text,
103 | transformers >= 0.3,
104 | unordered-containers,
105 | vector
106 |
107 | source-repository head
108 | type: git
109 | location: https://github.com/bos/critbit
110 |
111 | source-repository head
112 | type: mercurial
113 | location: https://bitbucket.org/bos/critbit
114 |
--------------------------------------------------------------------------------
/tests/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | module Main (main) where
3 |
4 | import Test.Framework
5 |
6 | #if MIN_VERSION_base(4,5,0)
7 | import qualified Properties.Map as Map
8 | import qualified Properties.Set as Set
9 |
10 | properties :: [Test]
11 | properties = [ testGroup "map" Map.properties,
12 | testGroup "set" Set.properties ]
13 | #else
14 | import Test.Framework.Providers.QuickCheck2 (testProperty)
15 |
16 | -- Don't run any tests on GHC < 7.4, but *do* generate a test output
17 | -- file that a continuous build system can consume so that it won't
18 | -- crash. The output file can't be devoid of tests, because then
19 | -- instead of crashing Jenkins will fail because no tests were run.
20 | -- Thanks for being so inflexible, Jenkins!
21 | properties = [ testProperty "fuck you, jenkins" True ]
22 | #endif
23 |
24 | main :: IO ()
25 | main = defaultMain [
26 | testGroup "properties" properties
27 | ]
28 |
--------------------------------------------------------------------------------
/tests/Properties/Common.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances #-}
2 | {-# LANGUAGE OverloadedStrings, Rank2Types #-}
3 | {-# OPTIONS_GHC -fno-warn-orphans #-}
4 | module Properties.Common
5 | (
6 | Small(..)
7 | , qc
8 | , Props
9 | , Eq'(..)
10 | , SameAs(..)
11 | , (=?=)
12 | , (=??=)
13 | , (=*=)
14 | , (=?*=)
15 | , (=??*=)
16 | , (=**=)
17 | , (=*==)
18 | , notEmpty
19 | , prepends
20 | , kf
21 | ) where
22 |
23 | import Control.Applicative ((<$>))
24 | import qualified Data.ByteString.Char8 as B
25 | import Data.CritBit.Map.Lazy (CritBitKey, byteCount)
26 | import Data.Monoid (Monoid, mappend)
27 | import Data.String (IsString, fromString)
28 | import qualified Data.Text as T
29 | import qualified Data.Vector.Generic as G
30 | import qualified Data.Vector.Unboxed as U
31 | import Data.Word
32 | import Test.Framework (Test)
33 | import Test.QuickCheck (Arbitrary(..), Args(..), quickCheckWith, stdArgs)
34 | import Test.QuickCheck.Gen (Gen, resize, sized)
35 | import Test.QuickCheck.Property (Property, Testable, (===), (.&&.), (.||.))
36 |
37 | instance IsString (U.Vector Word8) where
38 | fromString = fromStringV
39 |
40 | instance IsString (U.Vector Word16) where
41 | fromString = fromStringV
42 |
43 | instance IsString (U.Vector Word32) where
44 | fromString = fromStringV
45 |
46 | instance IsString (U.Vector Word64) where
47 | fromString = fromStringV
48 |
49 | instance IsString (U.Vector Word) where
50 | fromString = fromStringV
51 |
52 | instance IsString (U.Vector Char) where
53 | fromString = G.fromList
54 |
55 | fromStringV :: (G.Vector v a, Integral a) => String -> v a
56 | fromStringV = G.fromList . map (fromIntegral . fromEnum)
57 |
58 | instance Arbitrary B.ByteString where
59 | arbitrary = B.pack <$> arbitrary
60 | shrink = map B.pack . shrink . B.unpack
61 |
62 | instance Arbitrary T.Text where
63 | arbitrary = T.pack <$> arbitrary
64 | shrink = map T.pack . shrink . T.unpack
65 |
66 | instance Arbitrary (U.Vector Word8) where
67 | arbitrary = arbitraryV
68 | shrink = shrinkV
69 |
70 | instance Arbitrary (U.Vector Word16) where
71 | arbitrary = arbitraryV
72 | shrink = shrinkV
73 |
74 | instance Arbitrary (U.Vector Word32) where
75 | arbitrary = arbitraryV
76 | shrink = shrinkV
77 |
78 | instance Arbitrary (U.Vector Word64) where
79 | arbitrary = arbitraryV
80 | shrink = shrinkV
81 |
82 | instance Arbitrary (U.Vector Word) where
83 | arbitrary = arbitraryV
84 | shrink = shrinkV
85 |
86 | instance Arbitrary (U.Vector Char) where
87 | arbitrary = arbitraryV
88 | shrink = shrinkV
89 |
90 | arbitraryV :: (G.Vector v a, Arbitrary a) => Gen (v a)
91 | arbitraryV = G.fromList <$> arbitrary
92 |
93 | shrinkV :: (G.Vector v a, Arbitrary a) => v a -> [v a]
94 | shrinkV = map G.fromList . shrink . G.toList
95 |
96 | newtype Small a = Small { fromSmall :: a }
97 | deriving (Eq, Ord, Show)
98 |
99 | instance (Show a, Arbitrary a) => Arbitrary (Small a) where
100 | arbitrary = Small <$> (sized $ \n -> resize (smallish n) arbitrary)
101 | where
102 | smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
103 | shrink = map Small . shrink . fromSmall
104 |
105 | type Props k = (Arbitrary k, CritBitKey k, Ord k, IsString k, Monoid k, Show k) => k -> [Test]
106 |
107 | infix 4 =^=, =?=, =??=
108 |
109 | -- | Compares heterogeneous values
110 | class (Show f, Show g) => Eq' f g where
111 | (=^=) :: f -> g -> Property
112 |
113 | instance (Show t, Eq t) => Eq' t t where
114 | (=^=) = (===)
115 |
116 | instance (Eq' a1 b1, Eq' a2 b2, Eq' a3 b3) => Eq' (a1, a2, a3) (b1, b2, b3)
117 | where (a1, a2, a3) =^= (b1, b2, b3) = a1 =^= b1 .&&. a2 =^= b2 .&&. a3 =^= b3
118 |
119 | -- | Compares functions taking one scalar
120 | (=?=) :: Eq' a b => (t -> a) -> (t -> b) -> k -> t -> Property
121 | f =?= g = const $ \t -> f t =^= g t
122 |
123 | -- | Compares functions taking two scalars
124 | (=??=) :: Eq' a b => (t -> s -> a) -> (t -> s -> b) -> k -> t -> s -> Property
125 | f =??= g = const $ \t s -> f t s =^= g t s
126 |
127 | infix 4 =*=, =?*=, =*==
128 |
129 | -- | Types 'f' and 'g' have same behavior and common represenation 'r'.
130 | data SameAs f g r = SameAs {
131 | toF :: r -> f
132 | , fromF :: f -> r
133 | , toG :: r -> g
134 | , fromG :: g -> r
135 | }
136 |
137 | -- | Compares two functions taking one container
138 | (=*=) :: (Eq' a b) => (f -> a) -> (g -> b)
139 | -> SameAs f g r -> r -> Property
140 | (f =*= g) sa i = f (toF sa i) =^= g (toG sa i)
141 |
142 | -- | Compares two functions taking one scalar and one container
143 | (=?*=) :: (Eq' a b) => (t -> f -> a) -> (t -> g -> b)
144 | -> SameAs f g r -> r -> t -> Property
145 | (f =?*= g) sa i t = (f t =*= g t) sa i
146 |
147 | -- | Compares functions taking two scalars and one container
148 | (=??*=) :: (Eq' a b) => (t -> s -> f -> a) -> (t -> s -> g -> b)
149 | -> SameAs f g r -> r -> t -> s -> Property
150 | (f =??*= g) sa i t s = (f t s =*= g t s) sa i
151 |
152 | -- | Compares two functions taking two containers
153 | (=**=) :: (Eq' a b) => (f -> f -> a) -> (g -> g -> b)
154 | -> SameAs f g r -> r -> r -> Property
155 | (f =**= g) sa i = (f (toF sa i) =*= g (toG sa i)) sa
156 |
157 | -- | Compares two functions taking one container with preprocessing
158 | (=*==) :: (Eq' f g) => (z -> f) -> (z -> g) -> (p -> z)
159 | -> SameAs f g r -> p -> Property
160 | (f =*== g) p _ i = f i' =^= g i'
161 | where i' = p i
162 |
163 | -- | Input litst is non-empty
164 | notEmpty :: (SameAs c1 c2 [i] -> [i] -> Property)
165 | -> SameAs c1 c2 [i] -> [i] -> Property
166 | notEmpty f t items = null items .||. f t items
167 |
168 | prepends :: (IsString k, Monoid k) => k -> k
169 | prepends = mappend "test"
170 |
171 | -- | Keys mapping function
172 | kf :: (CritBitKey k, IsString k, Monoid k) => k -> k
173 | kf k = fromString (show (byteCount k)) `mappend` k
174 |
175 | -- Handy functions for fiddling with from ghci.
176 |
177 | qc :: Testable prop => Int -> prop -> IO ()
178 | qc n = quickCheckWith stdArgs { maxSuccess = n }
179 |
--------------------------------------------------------------------------------
/tests/Properties/Map.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}
2 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}
3 | {-# OPTIONS_GHC -fno-warn-orphans #-}
4 | module Properties.Map
5 | where
6 |
7 | import qualified Data.ByteString.Char8 as B
8 | import Data.CritBit.Map.Lazy (CritBitKey, CritBit, byteCount)
9 | import qualified Data.CritBit.Map.Lazy as C
10 | import qualified Data.CritBit.Set as CSet
11 | import Data.Foldable (foldMap)
12 | import Data.Function (on)
13 | import Data.List (unfoldr, sort, nubBy)
14 | import Data.Map (Map)
15 | import qualified Data.Map as Map
16 | import Data.Monoid (Sum(..))
17 | import qualified Data.Set as Set
18 | import qualified Data.Text as T
19 | import qualified Data.Vector.Generic as G
20 | import qualified Data.Vector.Unboxed as U
21 | import Data.Word
22 | import Properties.Common
23 | import Test.Framework (Test, testGroup)
24 | import Test.Framework.Providers.QuickCheck2 (testProperty)
25 | import Test.QuickCheck.Property ((.&&.))
26 |
27 | --only needed for a test requiring containers >= 0.5
28 | #if MIN_VERSION_containers(0,5,0)
29 | import Data.Functor.Identity (Identity(..))
30 | #endif
31 |
32 | type V = Word8
33 |
34 | -- * Common modifier functions
35 |
36 | kvvf :: (CritBitKey k) => k -> V -> V -> V
37 | kvvf k v1 v2 = fromIntegral (byteCount k) * 3 + v1 * 2 - v2
38 |
39 | kvvfm :: (CritBitKey k) => k -> V -> V -> Maybe V
40 | kvvfm k v1 v2 = if even v1 then Just (kvvf k v1 v2) else Nothing
41 |
42 | kvf :: (CritBitKey k) => k -> V -> V
43 | kvf k v = kvvf k v 0
44 |
45 | kvfm :: (CritBitKey k) => k -> V -> Maybe V
46 | kvfm k v = kvvfm k v 0
47 |
48 | vvfm :: V -> V -> Maybe V
49 | vvfm = kvvfm ("" :: T.Text)
50 |
51 | vfm :: V -> Maybe V
52 | vfm = kvfm ("" :: T.Text)
53 |
54 | propertiesFor :: Props k
55 | propertiesFor w = concat [[]
56 | -- ** Lists
57 | , prop sa "t_fromList" $
58 | (C.fromList =*== Map.fromList) id
59 | , prop sa "t_fromListWith" $
60 | (C.fromListWith (-) =*== Map.fromListWith (-)) id
61 | , prop sa "t_fromListWithKey" $
62 | (C.fromListWithKey kvvf =*== Map.fromListWithKey kvvf) id
63 |
64 | -- * Query
65 | , prop sa "t_null" $
66 | C.null =*= Map.null
67 | , prop sa "t_size" $
68 | C.size =*= Map.size
69 | , prop sa "t_member" $
70 | C.member =?*= Map.member
71 | , prop sa "t_member" $
72 | C.notMember =?*= Map.notMember
73 | , prop sa "t_lookup" $
74 | C.lookup =?*= Map.lookup
75 | , prop sa "t_findWithDefault" $
76 | C.findWithDefault =??*= Map.findWithDefault
77 |
78 | #if MIN_VERSION_containers(0,5,0)
79 | , prop sa "t_lookupGT" $
80 | C.lookupGT =?*= Map.lookupGT
81 | , prop sa "t_lookupGE" $
82 | C.lookupGE =?*= Map.lookupGE
83 | , prop sa "t_lookupLT" $
84 | C.lookupLT =?*= Map.lookupLT
85 | , prop sa "t_lookupLE" $
86 | C.lookupLE =?*= Map.lookupLE
87 | #endif
88 |
89 | -- * Insertion
90 | , pmprop sa "t_insert" $
91 | C.insert =??*= Map.insert
92 | , pmprop sa "t_insertWith" $
93 | C.insertWith (-) =??*= Map.insertWith (-)
94 | , pmprop sa "t_insertWithKey" $
95 | C.insertWithKey kvvf =??*= Map.insertWithKey kvvf
96 | , pmprop sa "t_insertLookupWithKey" $
97 | C.insertLookupWithKey kvvf =??*= Map.insertLookupWithKey kvvf
98 |
99 | -- * Deletion
100 | , pmprop sa "t_delete" $
101 | C.delete =?*= Map.delete
102 | , pmprop sa "t_adjust" $
103 | C.adjust (+3) =?*= Map.adjust (+3)
104 | , pmprop sa "t_adjustWithKey" $
105 | C.adjustWithKey kvf =?*= Map.adjustWithKey kvf
106 | , pmprop sa "t_update" $
107 | C.update vfm =?*= Map.update vfm
108 | , pmprop sa "t_updateWithKey" $
109 | C.updateWithKey kvfm =?*= Map.updateWithKey kvfm
110 | , pmprop sa "t_updateLookupWithKey" $
111 | C.updateLookupWithKey kvfm =?*= Map.updateLookupWithKey kvfm
112 | , prop sa "t_alter" $
113 | let f = Just . maybe 1 (+1)
114 | in C.alter f =?*= Map.alter f
115 | , prop sa "t_alter_delete" $
116 | C.alter (const Nothing) =?*= Map.alter (const Nothing)
117 |
118 | -- * Combination
119 | -- ** Union
120 | , prop sa "t_union" $
121 | C.union =**= Map.union
122 | , prop sa "t_unionWith" $
123 | C.unionWith (-) =**= Map.unionWith (-)
124 | , prop sa "t_unionWithKey" $
125 | C.unionWithKey kvvf =**= Map.unionWithKey kvvf
126 | , prop sa "t_unions" $
127 | ( C.unions . map C.fromList =*==
128 | Map.unions . map Map.fromList) fromSmall
129 | , prop sa "t_unionsWith" $
130 | ( C.unionsWith (-) . map C.fromList =*==
131 | Map.unionsWith (-) . map Map.fromList) fromSmall
132 | , prop sa "t_unionL" $
133 | C.unionL =**= Map.union
134 | , prop sa "t_unionR" $
135 | C.unionR =**= flip Map.union
136 |
137 | -- ** Difference
138 | , prop sa "t_difference" $
139 | C.difference =**= Map.difference
140 | , prop sa "t_differenceWith" $
141 | C.differenceWith vvfm =**= Map.differenceWith vvfm
142 | , prop sa "t_differenceWithKey" $
143 | C.differenceWithKey kvvfm =**= Map.differenceWithKey kvvfm
144 |
145 | -- ** Intersection
146 | , prop sa "t_intersection" $
147 | C.intersection =**= Map.intersection
148 | , prop sa "t_intersectionWith" $
149 | C.intersectionWith (-) =**= Map.intersectionWith (-)
150 | , prop sa "t_intersectionWithKey" $
151 | C.intersectionWithKey kvvf =**= Map.intersectionWithKey kvvf
152 |
153 | -- * Traversal
154 | -- ** Map
155 | , prop sa "t_map" $
156 | C.map (+3) =*= Map.map (+3)
157 | , prop sa "t_mapWithKey" $
158 | C.mapWithKey kvf =*= Map.mapWithKey kvf
159 | #if MIN_VERSION_containers(0,5,0)
160 | , prop sa "t_traverseWithKey" $
161 | let f _ = Identity . show . (+3)
162 | in runIdentity . C.traverseWithKey f =*= runIdentity . Map.traverseWithKey f
163 | #endif
164 | , prop sa "t_mapAccum" $
165 | let f i v = (i + 1 :: Int, show $ v + 3)
166 | in C.mapAccum f 0 =*= Map.mapAccum f 0
167 | , prop sa "t_mapAccumWithKey" $
168 | let f i k v = (i + byteCount k, show $ v + 3)
169 | in C.mapAccumWithKey f 0 =*= Map.mapAccumWithKey f 0
170 | , prop sa "t_mapAccumRWithKey" $
171 | let f i k v = (i + byteCount k, show $ v + 3)
172 | in C.mapAccumRWithKey f 0 =*= Map.mapAccumRWithKey f 0
173 | , prop sa "t_mapKeys" $
174 | C.mapKeys kf =*= Map.mapKeys kf
175 | , prop sa "t_mapKeysWith" $
176 | C.mapKeysWith (+) kf =*= Map.mapKeysWith (+) kf
177 | , prop sa "t_mapKeysMonotonic" $
178 | C.mapKeysMonotonic prepends =*= Map.mapKeysMonotonic prepends
179 |
180 | -- * Folds
181 | , prop sa "t_foldl" $
182 | C.foldl (-) 0 =*= Map.foldl (-) 0
183 | , prop sa "t_foldlWithKey" $
184 | let f i k v = i * 37 + (byteCount k) * 17 + fromIntegral v
185 | in C.foldlWithKey f 0 =*= Map.foldlWithKey f 0
186 | , prop sa "t_foldr" $
187 | C.foldr (-) 0 =*= Map.foldr (-) 0
188 | , prop sa "t_foldrWithKey" $
189 | let f k v i = i * 37 + (byteCount k) * 17 + fromIntegral v
190 | in C.foldrWithKey f 0 =*= Map.foldrWithKey f 0
191 |
192 | -- ** Strict folds
193 | , prop sa "t_foldl'" $
194 | C.foldl' (-) 0 =*= Map.foldl' (-) 0
195 | , prop sa "t_foldlWithKey'" $
196 | let f i k v = i * 37 + (byteCount k) * 17 + fromIntegral v
197 | in C.foldlWithKey' f 0 =*= Map.foldlWithKey' f 0
198 | , prop sa "t_foldr'" $
199 | C.foldr' (-) 0 =*= Map.foldr' (-) 0
200 | , prop sa "t_foldrWithKey'" $
201 | let f k v i = i * 37 + (byteCount k) * 17 + fromIntegral v
202 | in C.foldrWithKey' f 0 =*= Map.foldrWithKey' f 0
203 |
204 | -- * Conversion
205 | , prop sa "t_elems" $
206 | C.elems =*= Map.elems
207 | , prop sa "t_keys" $
208 | C.keys =*= Map.keys
209 | , prop sa "assocs" $
210 | C.assocs =*= Map.assocs
211 | , prop sa "t_keysSet" $
212 | CSet.toList . C.keysSet =*= Set.toList . Map.keysSet
213 | #if MIN_VERSION_containers(0,5,0)
214 | , prop sa "t_fromSet" $
215 | let f = length . show
216 | in C.fromSet f . C.keysSet =*= Map.fromSet f . Map.keysSet
217 | #endif
218 |
219 | -- ** Ordered lists
220 | , prop sa "t_toAscList" $
221 | C.toAscList =*= Map.toAscList
222 | , prop sa "t_toDescList" $
223 | C.toDescList =*= Map.toDescList
224 | , prop sa "t_fromAscList" $
225 | (C.fromAscList =*== Map.fromAscList) sort
226 | , prop sa "t_fromAscListWith" $
227 | (C.fromAscListWith (+) =*== Map.fromAscListWith (+)) sort
228 | , prop sa "t_fromAscListWithKey" $
229 | (C.fromAscListWithKey kvvf =*== Map.fromAscListWithKey kvvf) sort
230 | , prop sa "t_fromDistinctAscList" $
231 | let p = nubBy ((==) `on` fst) . sort
232 | in (C.fromDistinctAscList =*== Map.fromDistinctAscList) p
233 |
234 | -- * Filter
235 | , prop sa "t_filter" $
236 | C.filter odd =*= Map.filter odd
237 | , prop sa "t_filterWithKey" $
238 | let p k v = odd $ kvf k v
239 | in C.filterWithKey p =*= Map.filterWithKey p
240 | , prop sa "t_partition" $ C.partition odd =*= Map.partition odd
241 | , prop sa "t_partitionWithKey" $
242 | let p k v = odd $ kvf k v
243 | in C.partitionWithKey p =*= Map.partitionWithKey p
244 |
245 | , prop sa "t_mapMaybe" $
246 | C.mapMaybe vfm =*= Map.mapMaybe vfm
247 | , prop sa "t_mapMaybeWithKey" $
248 | C.mapMaybeWithKey kvfm =*= Map.mapMaybeWithKey kvfm
249 | , prop sa "t_mapEither" $
250 | let f v = if even v then Left (2 * v) else Right (3 * v)
251 | in C.mapEither f =*= Map.mapEither f
252 | , prop sa "t_mapEitherWithKey" $
253 | let f k v = if even v then Left (kvf k v) else Right (3 * v)
254 | in C.mapEitherWithKey f =*= Map.mapEitherWithKey f
255 |
256 | , pmprop sa "t_split" $
257 | C.split =?*= Map.split
258 | , pmprop sa "t_splitLookup" $
259 | C.splitLookup =?*= Map.splitLookup
260 |
261 | -- * Submap
262 | , prop sa "t_isSubmapOf" $
263 | C.isSubmapOf =**= Map.isSubmapOf
264 | , prop sa "t_isSubmapOfBy" $
265 | C.isSubmapOfBy (<=) =**= Map.isSubmapOfBy (<=)
266 | , prop sa "t_isProperSubmapOf" $
267 | C.isProperSubmapOf =**= Map.isProperSubmapOf
268 | , prop sa "t_isProperSubmapOfBy" $
269 | C.isProperSubmapOfBy (<=) =**= Map.isProperSubmapOfBy (<=)
270 |
271 | -- * Min\/Max
272 | , prop sa "t_findMin" $ notEmpty $
273 | C.findMin =*= Map.findMin
274 | , prop sa "t_findMax" $ notEmpty $
275 | C.findMax =*= Map.findMax
276 | , prop sa "t_deleteMin" $ notEmpty $
277 | C.deleteMin =*= Map.deleteMin
278 | , prop sa "t_deleteMax" $ notEmpty $
279 | C.deleteMax =*= Map.deleteMax
280 | , prop sa "t_deleteFindMin" $ notEmpty $
281 | C.deleteFindMin =*= Map.deleteFindMin
282 | , prop sa "t_deleteFindMax" $ notEmpty $
283 | C.deleteFindMax =*= Map.deleteFindMax
284 | , prop sa "t_updateMin" $
285 | C.updateMinWithKey kvfm =*= Map.updateMinWithKey kvfm
286 | , prop sa "t_updateMax" $
287 | C.updateMaxWithKey kvfm =*= Map.updateMaxWithKey kvfm
288 | , prop sa "t_updateMinWithKey" $
289 | C.updateMinWithKey kvfm =*= Map.updateMinWithKey kvfm
290 | , prop sa "t_updateMaxWithKey" $
291 | C.updateMaxWithKey kvfm =*= Map.updateMaxWithKey kvfm
292 | , prop sa "t_minView" $
293 | unfoldr C.minView =*= unfoldr Map.minView
294 | , prop sa "t_maxView" $
295 | unfoldr C.maxView =*= unfoldr Map.maxView
296 | , prop sa "t_minViewWithKey" $
297 | unfoldr C.minViewWithKey =*= unfoldr Map.minViewWithKey
298 | , prop sa "t_maxViewWithKey" $
299 | unfoldr C.maxViewWithKey =*= unfoldr Map.maxViewWithKey
300 |
301 | , prop sa "t_foldMap" $
302 | foldMap Sum =*= foldMap Sum
303 | ]
304 | where
305 | prop sa' name q = [testProperty name $ q sa']
306 | pmprop sa' name t = [
307 | testProperty (name ++ "_general") $ general
308 | , testProperty (name ++ "_present") $ present
309 | , testProperty (name ++ "_missing") $ missing
310 | ]
311 | where
312 | general k kvs = t sa' kvs k
313 | present k v kvs = t sa' ((k, v):kvs) k
314 | missing k kvs = t sa' (filter ((/= k) . fst) kvs) k
315 |
316 | sa = sameAs w
317 |
318 | sameAs :: (CritBitKey k, Ord k)
319 | => k -> SameAs (CritBit k V) (Map k V) [(k, V)]
320 | sameAs _ = SameAs C.fromList C.toList Map.fromList Map.toList
321 |
322 | properties :: [Test]
323 | properties = [
324 | testGroup "text" $ propertiesFor T.empty
325 | , testGroup "bytestring" $ propertiesFor B.empty
326 | , testGroup "vector" [
327 | testGroup "unboxed" [
328 | testGroup "Word8" $ propertiesFor (G.empty :: U.Vector Word8)
329 | , testGroup "Word16" $ propertiesFor (G.empty :: U.Vector Word16)
330 | , testGroup "Word32" $ propertiesFor (G.empty :: U.Vector Word32)
331 | , testGroup "Word64" $ propertiesFor (G.empty :: U.Vector Word64)
332 | , testGroup "Word" $ propertiesFor (G.empty :: U.Vector Word)
333 | , testGroup "Char" $ propertiesFor (G.empty :: U.Vector Char)
334 | ]
335 | ]
336 | ]
337 |
338 | instance (Eq k, Show k, Eq v, Show v) => Eq' (CritBit k v) (Map k v) where
339 | c =^= m = C.toList c =^= Map.toList m
340 |
341 | instance (Eq' a1 b1, Eq k, Show k, Eq v, Show v) => Eq' (a1, CritBit k v) (b1, Map k v) where
342 | (a1, a2) =^= (b1, b2) = a1 =^= b1 .&&. a2 =^= b2
343 |
344 | -- Handy functions for fiddling with from ghci.
345 |
346 | blist :: [B.ByteString] -> CritBit B.ByteString Word8
347 | blist = C.fromList . flip zip [0..]
348 |
349 | tlist :: [T.Text] -> CritBit T.Text Word8
350 | tlist = C.fromList . flip zip [0..]
351 |
352 | mlist :: [B.ByteString] -> Map B.ByteString Word8
353 | mlist = Map.fromList . flip zip [0..]
354 |
--------------------------------------------------------------------------------
/tests/Properties/Set.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances #-}
2 | {-# OPTIONS_GHC -fno-warn-orphans #-}
3 | module Properties.Set
4 | where
5 |
6 | import qualified Data.ByteString.Char8 as B
7 | import Data.CritBit.Map.Lazy (CritBitKey, byteCount)
8 | import qualified Data.CritBit.Set as C
9 | import Data.List (unfoldr, sort, nub)
10 | import qualified Data.Set as S
11 | import qualified Data.Text as T
12 | import Properties.Common
13 | import Test.Framework (Test, testGroup)
14 | import Test.Framework.Providers.QuickCheck2 (testProperty)
15 | import Test.QuickCheck.Property ((.&&.))
16 |
17 | kp :: (CritBitKey k) => k -> Bool
18 | kp = even . byteCount
19 |
20 | kii :: (CritBitKey k, Show k) => k -> Int -> Int
21 | kii k v = byteCount k * 13 + v
22 |
23 | propertiesFor :: Props k
24 | propertiesFor t = concat [[]
25 | -- * Operators
26 | , prop "t_diff" $ (C.\\) =**= (S.\\)
27 |
28 | -- * Query
29 | , prop "t_null" $ C.null =*= S.null
30 | , prop "t_size" $ C.size =*= S.size
31 | , prop "t_member" $ C.member =?*= S.member
32 | , prop "t_notMember" $ C.notMember =?*= S.notMember
33 | #if MIN_VERSION_containers(0,5,0)
34 | , prop "t_lookupLT" $ C.lookupLT =?*= S.lookupLT
35 | , prop "t_lookupGT" $ C.lookupGT =?*= S.lookupGT
36 | , prop "t_lookupLE" $ C.lookupLE =?*= S.lookupLE
37 | , prop "t_lookupGE" $ C.lookupGE =?*= S.lookupGE
38 | #endif
39 | , prop "t_isSubsetOf" $ C.isSubsetOf =**= S.isSubsetOf
40 | , prop "t_isProperSubsetOf" $ C.isProperSubsetOf =**= S.isProperSubsetOf
41 |
42 | -- * Construction
43 | -- , prop "t_empty" $ C.empty =^= S.empty
44 | , prop "t_singleton" $ notEmpty $ (C.singleton =*== S.singleton) head
45 | , prop "t_insert" $ C.insert =?*= S.insert
46 | , prop "t_delete" $ C.delete =?*= S.delete
47 |
48 | -- * Combine
49 | , prop "t_union" $ C.union =**= S.union
50 | , prop "t_unions" $ (C.unions . map C.fromList =*==
51 | S.unions . map S.fromList) fromSmall
52 | , prop "t_difference" $ C.difference =**= S.difference
53 | , prop "t_intersection" $ C.intersection =**= S.intersection
54 |
55 | -- * Filter
56 | , prop "t_filter" $ C.filter kp =*= S.filter kp
57 | , prop "t_partition" $ C.partition kp =*= S.partition kp
58 | , prop "t_split" $ C.split =?*= S.split
59 | , prop "t_splitMember" $ C.splitMember =?*= S.splitMember
60 |
61 | -- * Map
62 | , prop "t_map" $ C.map kf =*= S.map kf
63 | , prop "t_mapMonotonic" $ C.mapMonotonic prepends =*= S.mapMonotonic prepends
64 |
65 | -- * Folds
66 | , prop "t_foldr" $ C.foldr kii 0 =*= S.foldr kii 0
67 | , prop "t_foldl" $ C.foldl (flip kii) 0 =*= S.foldl (flip kii) 0
68 | -- ** Strict folds
69 | , prop "t_foldr'" $ C.foldr' kii 0 =*= S.foldr' kii 0
70 | , prop "t_foldl'" $ C.foldl' (flip kii) 0 =*= S.foldl' (flip kii) 0
71 |
72 | -- * Min\/Max
73 | , prop "t_findMin" $ notEmpty $ C.findMin =*= S.findMin
74 | , prop "t_findMax" $ notEmpty $ C.findMax =*= S.findMax
75 | , prop "t_deleteMin" $ notEmpty $ C.deleteMin =*= S.deleteMin
76 | , prop "t_deleteMax" $ notEmpty $ C.deleteMax =*= S.deleteMax
77 | , prop "t_deleteFindMin" $ notEmpty $ C.deleteFindMin =*= S.deleteFindMin
78 | , prop "t_deleteFindMax" $ notEmpty $ C.deleteFindMax =*= S.deleteFindMax
79 | , prop "t_maxView" $ notEmpty $ unfoldr C.maxView =*= unfoldr S.maxView
80 | , prop "t_minView" $ notEmpty $ unfoldr C.minView =*= unfoldr S.minView
81 |
82 | -- * Conversion
83 | -- ** List
84 | , prop "t_elems" $ C.elems =*= S.elems
85 | , prop "t_toList" $ C.toList =*= S.toList
86 | , prop "t_fromList" $ (C.fromList =*== S.fromList) id
87 |
88 | -- ** Ordered list
89 | , prop "t_toAscList" $ C.toAscList =*= S.toAscList
90 | #if MIN_VERSION_containers(0,5,0)
91 | , prop "t_toDescList" $ C.toDescList =*= S.toDescList
92 | #endif
93 | , prop "t_fromAscList" $ (C.fromAscList =*== S.fromAscList) sort
94 | , prop "t_fromDistinctAscList" $
95 | (C.fromDistinctAscList =*== S.fromDistinctAscList) (nub . sort)
96 | ]
97 | where
98 | prop name q = [testProperty name $ q $ sameAs t]
99 |
100 | sameAs :: (CritBitKey k, Ord k) => k -> SameAs (C.Set k) (S.Set k) [k]
101 | sameAs _ = SameAs C.fromList C.toList S.fromList S.toList
102 |
103 | properties :: [Test]
104 | properties = [
105 | testGroup "text" $ propertiesFor T.empty
106 | , testGroup "bytestring" $ propertiesFor B.empty
107 | ]
108 |
109 | instance (Show k, Eq k) => Eq' (C.Set k) (S.Set k) where
110 | c =^= m = C.toList c =^= S.toList m
111 |
112 | instance (Eq' a1 b1, Eq k, Show k) => Eq' (a1, C.Set k) (b1, S.Set k) where
113 | (a1, a2) =^= (b1, b2) = a1 =^= b1 .&&. a2 =^= b2
114 |
115 | -- Handy functions for fiddling with from ghci.
116 |
117 | blist :: [B.ByteString] -> C.Set B.ByteString
118 | blist = C.fromList
119 |
120 | tlist :: [T.Text] -> S.Set T.Text
121 | tlist = S.fromList
122 |
--------------------------------------------------------------------------------