├── .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 | --------------------------------------------------------------------------------