diff --git a/Data/BitUtil.hs b/Data/BitUtil.hs new file mode 100644 --- /dev/null +++ b/Data/BitUtil.hs @@ -0,0 +1,287 @@ +module Data.BitUtil where + +import Data.Bits +import Data.Word +import Data.Int + +-- Bit operations + +-- Given a bitmap and a subhash, this function returns the index into the list +fromBitmap :: (Integral b, Integral c) => Int32 -> b -> c +fromBitmap bitmap subHash = + let mask = fromIntegral (pred (toBitmap subHash :: Word32)) :: Int32 + in bitCount32 $ bitmap .&. mask + +toBitmap :: (Bits t, Integral a) => a -> t +toBitmap subHash = 1 `shiftL` fromIntegral subHash + +bitmapToIndices :: (Bits a, Num b) => a -> [b] +bitmapToIndices bitmap = loop 0 bitmap + where loop _ 0 = [] + loop 32 _ = [] + loop ix bitmap | bitmap .&. 1 == 0 = loop (ix+1) (bitmap `shiftR` 1) + | otherwise = ix:(loop (ix+1) (bitmap `shiftR` 1)) + +bitCount32 :: (Integral a) => Int32 -> a +bitCount32 x = bitCount8 ((x `shiftR` 24) .&. 0xff) + + bitCount8 ((x `shiftR` 16) .&. 0xff) + + bitCount8 ((x `shiftR` 8) .&. 0xff) + + bitCount8 (x .&. 0xff) + +bitCount8 :: (Bits a, Integral b) => a -> b +bitCount8 0 = 0 +bitCount8 1 = 1 +bitCount8 2 = 1 +bitCount8 3 = 2 +bitCount8 4 = 1 +bitCount8 5 = 2 +bitCount8 6 = 2 +bitCount8 7 = 3 +bitCount8 8 = 1 +bitCount8 9 = 2 +bitCount8 10 = 2 +bitCount8 11 = 3 +bitCount8 12 = 2 +bitCount8 13 = 3 +bitCount8 14 = 3 +bitCount8 15 = 4 +bitCount8 16 = 1 +bitCount8 17 = 2 +bitCount8 18 = 2 +bitCount8 19 = 3 +bitCount8 20 = 2 +bitCount8 21 = 3 +bitCount8 22 = 3 +bitCount8 23 = 4 +bitCount8 24 = 2 +bitCount8 25 = 3 +bitCount8 26 = 3 +bitCount8 27 = 4 +bitCount8 28 = 3 +bitCount8 29 = 4 +bitCount8 30 = 4 +bitCount8 31 = 5 +bitCount8 32 = 1 +bitCount8 33 = 2 +bitCount8 34 = 2 +bitCount8 35 = 3 +bitCount8 36 = 2 +bitCount8 37 = 3 +bitCount8 38 = 3 +bitCount8 39 = 4 +bitCount8 40 = 2 +bitCount8 41 = 3 +bitCount8 42 = 3 +bitCount8 43 = 4 +bitCount8 44 = 3 +bitCount8 45 = 4 +bitCount8 46 = 4 +bitCount8 47 = 5 +bitCount8 48 = 2 +bitCount8 49 = 3 +bitCount8 50 = 3 +bitCount8 51 = 4 +bitCount8 52 = 3 +bitCount8 53 = 4 +bitCount8 54 = 4 +bitCount8 55 = 5 +bitCount8 56 = 3 +bitCount8 57 = 4 +bitCount8 58 = 4 +bitCount8 59 = 5 +bitCount8 60 = 4 +bitCount8 61 = 5 +bitCount8 62 = 5 +bitCount8 63 = 6 +bitCount8 64 = 1 +bitCount8 65 = 2 +bitCount8 66 = 2 +bitCount8 67 = 3 +bitCount8 68 = 2 +bitCount8 69 = 3 +bitCount8 70 = 3 +bitCount8 71 = 4 +bitCount8 72 = 2 +bitCount8 73 = 3 +bitCount8 74 = 3 +bitCount8 75 = 4 +bitCount8 76 = 3 +bitCount8 77 = 4 +bitCount8 78 = 4 +bitCount8 79 = 5 +bitCount8 80 = 2 +bitCount8 81 = 3 +bitCount8 82 = 3 +bitCount8 83 = 4 +bitCount8 84 = 3 +bitCount8 85 = 4 +bitCount8 86 = 4 +bitCount8 87 = 5 +bitCount8 88 = 3 +bitCount8 89 = 4 +bitCount8 90 = 4 +bitCount8 91 = 5 +bitCount8 92 = 4 +bitCount8 93 = 5 +bitCount8 94 = 5 +bitCount8 95 = 6 +bitCount8 96 = 2 +bitCount8 97 = 3 +bitCount8 98 = 3 +bitCount8 99 = 4 +bitCount8 100 = 3 +bitCount8 101 = 4 +bitCount8 102 = 4 +bitCount8 103 = 5 +bitCount8 104 = 3 +bitCount8 105 = 4 +bitCount8 106 = 4 +bitCount8 107 = 5 +bitCount8 108 = 4 +bitCount8 109 = 5 +bitCount8 110 = 5 +bitCount8 111 = 6 +bitCount8 112 = 3 +bitCount8 113 = 4 +bitCount8 114 = 4 +bitCount8 115 = 5 +bitCount8 116 = 4 +bitCount8 117 = 5 +bitCount8 118 = 5 +bitCount8 119 = 6 +bitCount8 120 = 4 +bitCount8 121 = 5 +bitCount8 122 = 5 +bitCount8 123 = 6 +bitCount8 124 = 5 +bitCount8 125 = 6 +bitCount8 126 = 6 +bitCount8 127 = 7 +bitCount8 128 = 1 +bitCount8 129 = 2 +bitCount8 130 = 2 +bitCount8 131 = 3 +bitCount8 132 = 2 +bitCount8 133 = 3 +bitCount8 134 = 3 +bitCount8 135 = 4 +bitCount8 136 = 2 +bitCount8 137 = 3 +bitCount8 138 = 3 +bitCount8 139 = 4 +bitCount8 140 = 3 +bitCount8 141 = 4 +bitCount8 142 = 4 +bitCount8 143 = 5 +bitCount8 144 = 2 +bitCount8 145 = 3 +bitCount8 146 = 3 +bitCount8 147 = 4 +bitCount8 148 = 3 +bitCount8 149 = 4 +bitCount8 150 = 4 +bitCount8 151 = 5 +bitCount8 152 = 3 +bitCount8 153 = 4 +bitCount8 154 = 4 +bitCount8 155 = 5 +bitCount8 156 = 4 +bitCount8 157 = 5 +bitCount8 158 = 5 +bitCount8 159 = 6 +bitCount8 160 = 2 +bitCount8 161 = 3 +bitCount8 162 = 3 +bitCount8 163 = 4 +bitCount8 164 = 3 +bitCount8 165 = 4 +bitCount8 166 = 4 +bitCount8 167 = 5 +bitCount8 168 = 3 +bitCount8 169 = 4 +bitCount8 170 = 4 +bitCount8 171 = 5 +bitCount8 172 = 4 +bitCount8 173 = 5 +bitCount8 174 = 5 +bitCount8 175 = 6 +bitCount8 176 = 3 +bitCount8 177 = 4 +bitCount8 178 = 4 +bitCount8 179 = 5 +bitCount8 180 = 4 +bitCount8 181 = 5 +bitCount8 182 = 5 +bitCount8 183 = 6 +bitCount8 184 = 4 +bitCount8 185 = 5 +bitCount8 186 = 5 +bitCount8 187 = 6 +bitCount8 188 = 5 +bitCount8 189 = 6 +bitCount8 190 = 6 +bitCount8 191 = 7 +bitCount8 192 = 2 +bitCount8 193 = 3 +bitCount8 194 = 3 +bitCount8 195 = 4 +bitCount8 196 = 3 +bitCount8 197 = 4 +bitCount8 198 = 4 +bitCount8 199 = 5 +bitCount8 200 = 3 +bitCount8 201 = 4 +bitCount8 202 = 4 +bitCount8 203 = 5 +bitCount8 204 = 4 +bitCount8 205 = 5 +bitCount8 206 = 5 +bitCount8 207 = 6 +bitCount8 208 = 3 +bitCount8 209 = 4 +bitCount8 210 = 4 +bitCount8 211 = 5 +bitCount8 212 = 4 +bitCount8 213 = 5 +bitCount8 214 = 5 +bitCount8 215 = 6 +bitCount8 216 = 4 +bitCount8 217 = 5 +bitCount8 218 = 5 +bitCount8 219 = 6 +bitCount8 220 = 5 +bitCount8 221 = 6 +bitCount8 222 = 6 +bitCount8 223 = 7 +bitCount8 224 = 3 +bitCount8 225 = 4 +bitCount8 226 = 4 +bitCount8 227 = 5 +bitCount8 228 = 4 +bitCount8 229 = 5 +bitCount8 230 = 5 +bitCount8 231 = 6 +bitCount8 232 = 4 +bitCount8 233 = 5 +bitCount8 234 = 5 +bitCount8 235 = 6 +bitCount8 236 = 5 +bitCount8 237 = 6 +bitCount8 238 = 6 +bitCount8 239 = 7 +bitCount8 240 = 4 +bitCount8 241 = 5 +bitCount8 242 = 5 +bitCount8 243 = 6 +bitCount8 244 = 5 +bitCount8 245 = 6 +bitCount8 246 = 6 +bitCount8 247 = 7 +bitCount8 248 = 5 +bitCount8 249 = 6 +bitCount8 250 = 6 +bitCount8 251 = 7 +bitCount8 252 = 6 +bitCount8 253 = 7 +bitCount8 254 = 7 +bitCount8 255 = 8 diff --git a/Data/HamtMap.hs b/Data/HamtMap.hs new file mode 100644 --- /dev/null +++ b/Data/HamtMap.hs @@ -0,0 +1,525 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.HamtMap +-- Copyright : (c) Kevin Wu Won 2011 +-- License : BSD-style +-- Maintainer : exclipy@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- An implementation of maps from keys to values (dictionaries) based on the +-- hash array mapped trie. +-- +-- Since many function names (but not the type name) clash with +-- "Prelude" names, this module is usually imported @qualified@, e.g. +-- +-- > import qualified Data.HamtMap as HM +-- +-- This data structure is based on Phil Bagwell's hash array mapped trie, +-- which is described by his original paper: +-- +-- * +----------------------------------------------------------------------------- + +module Data.HamtMap ( + -- * HamtMap type + HamtMap + -- * Operators + , (Data.HamtMap.!) + -- * Query + , member + , notMember + , Data.HamtMap.lookup + -- * Construction + , empty + , singleton + -- * Insertion + , insert + , insertWith + -- * Delete\/Update + , Data.HamtMap.delete + , adjust + , update + , alter + -- * Traversal + , Data.HamtMap.map + , mapWithKey + -- * Conversion + , Data.HamtMap.elems + , keys + , toList + , fromListWith + , fromList + ) where + +import Data.BitUtil +import Control.Monad +import Control.DeepSeq +import Data.Bits +import Data.Int +import Data.List hiding (insert, lookup) +import Data.Array as A +import Prelude as P + +-- | A HamtMap from keys @k@ to values @v@ +data (Eq k) => HamtMap k v = HM { + hashFn :: k -> Int32 + , root :: Node k v + } + +instance (Eq k, Show k, Show v) => Show (HamtMap k v) where + show (HM h r) = show r + -- show = ("fromList hashFn "++).show.(Data.HamtMap.toList) + +instance (Eq k, NFData k, NFData v) => NFData (HamtMap k v) where + rnf (HM f r) = f `seq` rnf r + +instance (Eq k, NFData k, NFData v) => NFData (Node k v) where + rnf EmptyNode = () + rnf (LeafNode h k v) = rnf h `seq` rnf k `seq` rnf v + rnf (HashCollisionNode h xs) = rnf h `seq` rnf xs + rnf (BitmapIndexedNode bm arr) = rnf bm `seq` rnf arr + rnf (ArrayNode n arr) = rnf n `seq` rnf arr + +data (Eq k) => Node k v = EmptyNode | + LeafNode { + hash :: Int32 + , key :: k + , value :: v + } | + HashCollisionNode { + hash :: Int32 + , pairs :: [(k, v)] + } | + BitmapIndexedNode { + bitmap :: Int32 + , subNodes :: Array Int32 (Node k v) + } | + ArrayNode { + numChildren :: Int32 + , subNodes :: Array Int32 (Node k v) + } + +instance (Eq k, Show k, Show v) => Show (Node k v) where + show EmptyNode = "" + show (LeafNode _hash key value) = show (key, value) + show (HashCollisionNode _hash pairs) = "h" ++ show pairs + show (BitmapIndexedNode bitmap subNodes) = "b" ++ show bitmap ++ (show $ A.elems subNodes) + show (ArrayNode numChildren subNodes) = "a" ++ show numChildren ++ (show $ A.elems subNodes) + + +-- Some constants +shiftStep = 5 +chunk = 2^shiftStep +mask = pred chunk +bmnodeMax = 16 -- maximum size of a BitmapIndexedNode +arraynodeMin = 8 -- minimum size of an ArrayNode + +-- Some miscellaneous helper functions + +isEmptyNode :: Node k v -> Bool +isEmptyNode EmptyNode = True +isEmptyNode _ = False + +hashFragment shift hash = (hash `shiftR` shift) .&. fromIntegral mask + + +-- | @('empty' hashFn)@ is the empty HamtMap, with hashFn being the key hash function. +empty :: (Eq k) => (k -> Int32) -> HamtMap k v + +empty hashFn = HM hashFn EmptyNode + + +-- | @('singleton' hashFn key value)@ is a single-element HamtMap holding @(key, value)@ +singleton :: (Eq k) => (k -> Int32) -> k -> v -> HamtMap k v + +singleton hashFn key value = HM hashFn $ LeafNode (hashFn key) key value + + +-- Helper data type for alterNode +data Change = Removed | Modified | Nil | Added deriving Eq + + +-- | The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in a 'Map'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Eq k) => (Maybe v -> Maybe v) -> k -> HamtMap k v -> HamtMap k v + +alter updateFn key (HM hashFn root) = + HM hashFn $ alterNode 0 updateFn (hashFn key) key root + + +alterNode :: (Eq k) => Int -> (Maybe v -> Maybe v) -> Int32 -> k -> Node k v -> Node k v + +alterNode _shift updateFn hash key EmptyNode = + maybe EmptyNode + (LeafNode hash key) + (updateFn Nothing) + +alterNode shift updateFn hash' key' node@(LeafNode hash key value) = + if key' == key + then maybe EmptyNode + (LeafNode hash key) + (updateFn (Just value)) + else let node' = alterNode shift updateFn hash' key' EmptyNode + in if isEmptyNode node' + then node + else combineNodes shift node node' + where + combineNodes :: (Eq k) => Int -> Node k v -> Node k v -> Node k v + combineNodes shift node1@(LeafNode h1 k1 v1) node2@(LeafNode h2 k2 v2) = + let hash1 = nodeHash node1 + hash2 = nodeHash node2 + subHash1 = hashFragment shift hash1 + subHash2 = hashFragment shift hash2 + (nodeA, nodeB) = if (subHash1 < subHash2) + then (node1, node2) + else (node2, node1) + bitmap' = ((toBitmap subHash1) .|. (toBitmap subHash2)) + subNodes' = if subHash1 == subHash2 + then listArray (0, 0) [combineNodes (shift+shiftStep) node1 node2] + else listArray (0, 1) [nodeA, nodeB] + in if hash1 == hash2 + then HashCollisionNode hash1 [(k2, v2), (k1, v1)] + else BitmapIndexedNode bitmap' subNodes' + nodeHash (LeafNode hash key value) = hash + nodeHash (HashCollisionNode hash pairs) = hash + +alterNode _shift updateFn _hash' key (HashCollisionNode hash pairs) = + let pairs' = updateList updateFn key pairs + in case pairs' of + [] -> undefined -- should never happen + [(key, value)] -> LeafNode hash key value + otherwise -> HashCollisionNode hash pairs' + where updateList updateFn key [] = + maybe [] + (\value' -> [(key, value')]) + (updateFn Nothing) + updateList updateFn key' ((key, value):pairs) | key' == key = + maybe pairs + (\value' -> (key, value'):pairs) + (updateFn (Just value)) + updateList updateFn key (p:pairs) = + p : updateList updateFn key pairs + +alterNode shift updateFn hash key bmnode@(BitmapIndexedNode bitmap subNodes) = + let subHash = hashFragment shift hash + ix = fromBitmap bitmap subHash + bit = toBitmap subHash + exists = (bitmap .&. bit) /= 0 + child = if exists then subNodes A.! fromIntegral ix else EmptyNode + child' = alterNode (shift+shiftStep) updateFn hash key child + removed = exists && isEmptyNode child' + added = not exists && not (isEmptyNode child') + change = if exists + then if isEmptyNode child' + then Removed + else Modified + else if isEmptyNode child' + then Nil + else Added + bound = snd $ bounds subNodes + bound' = case change of + Removed -> bound-1 + Modified -> bound + Nil -> bound + Added -> bound+1 + (left, right) = splitAt ix $ A.elems subNodes + subNodes' = case change of + Removed -> listArray (0, bound') $ left ++ (tail right) + Modified -> subNodes // [(fromIntegral ix, child')] + Nil -> subNodes + Added -> listArray (0, bound') $ left ++ (child':right) + bitmap' = case change of + Removed -> bitmap .&. (complement bit) + Modified -> bitmap + Nil -> bitmap + Added -> bitmap .|. bit + in if bitmap' == 0 + then -- Remove an empty BitmapIndexedNode + -- Note: it's possible to have a single-element BitmapIndexedNode + -- if there are two keys with the same subHash in the trie. + EmptyNode + else if bound' == 0 && isLeafNode (subNodes' A.! 0) + then -- Pack a BitmapIndexedNode into a LeafNode + subNodes' A.! 0 + else if change == Added && bound' > bmnodeMax - 1 + then -- Expand a BitmapIndexedNode into an ArrayNode + expandBitmapNode shift subHash child' bitmap subNodes + else BitmapIndexedNode bitmap' subNodes' + where + isLeafNode (LeafNode _ _ _) = True + isLeafNode _ = False + + expandBitmapNode :: (Eq k) => + Int -> Int32 -> Node k v -> Int32 -> Array Int32 (Node k v) -> Node k v + expandBitmapNode shift subHash node' bitmap subNodes = + let assocs = zip (bitmapToIndices bitmap) (A.elems subNodes) + assocs' = (subHash, node'):assocs + blank = listArray (0, 31) $ replicate 32 EmptyNode + numChildren = (bitCount32 bitmap) + 1 + in ArrayNode numChildren $ blank // assocs' + -- TODO: an array copy could be avoided here + +alterNode shift updateFn hash key node@(ArrayNode numChildren subNodes) = + let subHash = hashFragment shift hash + child = subNodes A.! subHash + child' = alterNode (shift+shiftStep) updateFn hash key child + change = if isEmptyNode child + then if isEmptyNode child' + then Nil + else Added + else if isEmptyNode child' + then Removed + else Modified + numChildren' = case change of + Removed -> numChildren-1 + Modified -> numChildren + Nil -> numChildren + Added -> numChildren+1 + in if numChildren' < arraynodeMin + -- Pack an ArrayNode into a BitmapIndexedNode when usage drops below 25% + then packArrayNode subHash numChildren subNodes + else ArrayNode numChildren' $ subNodes // [(subHash, child')] + where + packArrayNode :: (Eq k) => Int32 -> Int32 -> Array Int32 (Node k v) -> Node k v + packArrayNode subHashToRemove numChildren subNodes = + let elems' = P.map (\i -> if i == subHashToRemove + then EmptyNode + else subNodes A.! i) + [0..pred chunk] + subNodes' = listArray (0, (numChildren-2)) $ filter (not.isEmptyNode) elems' + listToBitmap = foldr (\on bm -> (bm `shiftL` 1) .|. (if on then 1 else 0)) 0 + bitmap = listToBitmap $ P.map (not.isEmptyNode) elems' + in BitmapIndexedNode bitmap subNodes' + + +-- | Insert with a function, combining new value and old value. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert the pair @(key, f new_value old_value)@. +insertWith :: (Eq k) => (v -> v -> v) -> k -> v -> HamtMap k v -> HamtMap k v + +insertWith accumFn key value hm = + let fn :: (v -> v -> v) -> v -> Maybe v -> Maybe v + fn accumFn x' Nothing = Just x' + fn accumFn x' (Just x) = Just $ accumFn x' x + in alter (fn accumFn value) key hm + + +-- | Insert a new key and value in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value. 'insert' is equivalent to +-- @'insertWith' 'const'@. +insert :: (Eq k) => k -> v -> HamtMap k v -> HamtMap k v + +insert = insertWith const + + +-- | The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +update :: (Eq k) => (v -> Maybe v) -> k -> HamtMap k v -> HamtMap k v + +update updateFn = alter ((=<<) updateFn) + + +-- | Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +delete :: (Eq k) => k -> HamtMap k v -> HamtMap k v + +delete = alter (const Nothing) + + +-- | Update a value at a specific key with the result of the provided function. +-- When the key is not a member of the map, the original map is returned. +adjust :: (Eq k) => (v -> v) -> k -> HamtMap k v -> HamtMap k v + +adjust updateFn = alter ((=<<) ((Just).updateFn)) + + +-- | Map a function over all values in the map. +mapWithKey :: (Eq k) => (k -> v -> v) -> HamtMap k v -> HamtMap k v + +mapWithKey mapFn (HM hashFn root) = + HM hashFn $ mapWithKeyNode mapFn root + + +mapWithKeyNode :: (Eq k) => (k -> v -> v) -> Node k v -> Node k v + +mapWithKeyNode _mapFn EmptyNode = EmptyNode + +mapWithKeyNode mapFn (LeafNode hash key value) = LeafNode hash key $ mapFn key value + +mapWithKeyNode mapFn (HashCollisionNode hash pairs) = + HashCollisionNode hash (P.map (\(key, value) -> (key, mapFn key value)) pairs) + +mapWithKeyNode mapFn (BitmapIndexedNode bitmap subNodes) = + BitmapIndexedNode bitmap $ arrayMap (mapWithKeyNode mapFn) subNodes + +mapWithKeyNode mapFn (ArrayNode numChildren subNodes) = + ArrayNode numChildren $ arrayMap (mapWithKeyNode mapFn) subNodes + + +arrayMap :: (Ix i) => (a -> a) -> Array i a -> Array i a + +arrayMap fn arr = array (bounds arr) $ P.map (\(key, value) -> (key, fn value)) $ A.assocs arr + + +-- | Map a function over all values in the map. +map :: (Eq k) => (v -> v) -> HamtMap k v -> HamtMap k v + +map fn = mapWithKey (const fn) + + +-- | Lookup the value at a key in the map. +-- +-- The function will return the corresponding value as @('Just' value)@, +-- or 'Nothing' if the key isn't in the map. +lookup :: (Eq k) => k -> HamtMap k v -> Maybe v + +lookup key (HM hashFn root) = lookupNode 0 (hashFn key) key root + + +lookupNode :: (Eq k) => Int -> Int32 -> k -> Node k v -> Maybe v + +lookupNode _ _ _ EmptyNode = Nothing + +lookupNode _ _ key' (LeafNode _ key value) = + if key' == key then Just value + else Nothing + +lookupNode _ _ key (HashCollisionNode _ pairs) = + P.lookup key pairs + +lookupNode shift hash key (BitmapIndexedNode bitmap subNodes) = + let subHash = hashFragment shift hash + ix = fromBitmap bitmap subHash + exists = (bitmap .&. (toBitmap subHash)) /= 0 + in if exists + then lookupNode (shift+shiftStep) hash key (subNodes A.! ix) + else Nothing + +lookupNode shift hash key (ArrayNode _numChildren subNodes) = + let subHash = hashFragment shift hash + in lookupNode (shift+shiftStep) hash key (subNodes A.! subHash) + + +-- | Find the value at a key. +-- Calls 'error' when the element can not be found. +(!) :: (Eq k) => HamtMap k v -> k -> v + +hm ! key = maybe (error "element not in the map") + id + (Data.HamtMap.lookup key hm) + + +-- | Is the key a member of the map? See also 'notMember'. +member :: (Eq k) => k -> HamtMap k v -> Bool + +member key hm = maybe False (const True) (Data.HamtMap.lookup key hm) + +-- | Is the key a member of the map? See also 'member'. +notMember :: (Eq k) => k -> HamtMap k v -> Bool + +notMember key = not.(member key) + + +-- | Convert to a list of key\/value pairs. +toList :: (Eq k) => HamtMap k v -> [(k, v)] + +toList (HM _hashFn root) = toListNode root + + +toListNode :: (Eq k) => Node k v -> [(k, v)] + +toListNode EmptyNode = [] + +toListNode (LeafNode _hash key value) = [(key, value)] + +toListNode (HashCollisionNode _hash pairs) = pairs + +toListNode (BitmapIndexedNode _bitmap subNodes) = + concat $ P.map toListNode $ A.elems subNodes + +toListNode (ArrayNode _numChildren subNodes) = + concat $ P.map toListNode $ A.elems subNodes + + +-- | Build a map from a list of key\/value pairs with a combining function. +fromListWith :: (Eq k) => (k -> Int32) -> (v -> v -> v) -> [(k, v)] -> HamtMap k v + +fromListWith hashFn combineFn assocs = + HM hashFn $ fromListNode 0 combineFn $ P.map (\(k, v) -> ((hashFn k), k, v)) assocs + + +fromListNode :: (Eq k) => Int -> (v -> v -> v) -> [(Int32, k, v)] -> Node k v + +fromListNode shift combineFn hkvs = + let subHashed = P.map (\triple@(h, k, v) -> (hashFragment shift h, triple)) hkvs + divided = accumArray (flip (:)) [] (0, mask) subHashed + -- this will alternately reverse and unreverse the list on each level down + dividedList = A.elems divided + subNodes = listArray (0, mask) $ P.map (fromListNode (shift+shiftStep) combineFn) $ dividedList + numChildren = length $ filter (not.null) dividedList + in case hkvs of + [] -> EmptyNode + [(h, k, v)] -> LeafNode h k v + (h, k, v):hkvs' | all (\(h', _, _) -> h' == h) hkvs' -> + if all (\(_, k', _) -> k' == k) hkvs' + then let combineFn' = if even shift then flip combineFn else combineFn + -- correct for the alternate reversing of the list + v' = foldl1' combineFn' (P.map (\(_, _, v) -> v) hkvs) + in LeafNode h k v' + else let keyCmp (k1, _) (k2, _) = k1 == k2 + collisions = P.map (\(_, k', v') -> (k', v')) hkvs + grouped = groupBy' keyCmp collisions + combineFn' = if even shift then flip combineFn else combineFn + collisionKeys = P.map (fst.head) grouped + collisionVals = P.map ((foldl1' combineFn').(P.map snd)) grouped + collisions' = zip collisionKeys collisionVals + in HashCollisionNode h collisions' + _ | numChildren > fromIntegral bmnodeMax -> + ArrayNode (fromIntegral numChildren) subNodes + _ | otherwise -> + makeBMNode numChildren subNodes + where + makeBMNode :: (Eq k) => Int -> Array Int32 (Node k v) -> Node k v + makeBMNode numChildren subNodes = + let subNodeList = A.elems subNodes + subNodes' = listArray (0, (fromIntegral numChildren-1)) $ filter (not.isEmptyNode) subNodeList + listToBitmap = foldr (\on bm -> (bm `shiftL` 1) .|. (if on then 1 else 0)) 0 + bitmap = listToBitmap $ P.map (not.isEmptyNode) subNodeList + in BitmapIndexedNode bitmap subNodes' + + -- groupBy' is like Data.List.groupBy, but also groups non-adjacent elements + groupBy' :: (a -> a -> Bool) -> [a] -> [[a]] + groupBy' eq list = P.map reverse $ foldl' (insertGrouped eq) [] list + + insertGrouped :: (a -> a -> Bool) -> [[a]] -> a -> [[a]] + insertGrouped eq [] y = [[y]] + insertGrouped eq ((x:xs):gs) y | eq x y = (y:x:xs) : gs + | otherwise = (x:xs) : insertGrouped eq gs y + + +-- | Build a map from a list of key\/value pairs. +-- If the list contains more than one value for the same key, the last value +-- for the key is retained. +fromList :: (Eq k) => (k -> Int32) -> [(k, v)] -> HamtMap k v + +fromList hashFn assocs = + fromListWith hashFn const assocs + + + +-- | Return all keys of the map. +keys :: (Eq k) => HamtMap k v -> [k] + +keys = (P.map fst).toList + + +-- | Return all elements of the map. +elems :: (Eq k) => HamtMap k v -> [v] + +elems = (P.map snd).toList diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright 2011, Kevin Wu Won. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,103 @@ +Hash Array Mapped Tries +======================= + +One of the prominent features of the [Clojure][1] language are a set of +[immutable data structures][2] with efficient manipulation operations. One of +the most innovative and important is the persistent hash map based on the +*hash array mapped trie* (HAMT). + +This project is a port of this structure to Haskell, as Data.HamtMap. The +interface has been kept as consistent as possible with Data.Map. + +[1]: http://clojure.org/ +[2]: http://clojure.org/datatypes + + +Basic usage +----------- +Here's a demo of what you can do with a HamtMap: + + ghci> :m + Data.HamtMap + ghci> empty Data.HashTable.hashString + -- an empty HamtMap (requires a key hash function) + fromList hashFn [] + + ghci> insert "foo" 1 it + fromList hashFn [("foo",1)] + + ghci> insert "bar" 42 it + fromList hashFn [("foo",1),("bar",42)] + + ghci> insert "qux" 123 it + fromList hashFn [("qux",12),("foo",1),("bar",42)] + + ghci> insert "qux" 13 it -- inserting an existing key overwrites by default + fromList hashFn [("qux",13),("foo",1),("bar",42)] + + ghci> let a = it + ghci> a ! "foo" + 1 + + ghci> a ! "baz" -- using (!) is unsafe + *** Exception: array index out of range: element not in the map + + ghci> Data.HamtMap.lookup "bar" a + Just 42 + + ghci> Data.HamtMap.lookup "baz" a -- 'lookup' returns a safe Maybe + Nothing + + ghci> adjust succ "foo" a -- apply a function to a value + fromList hashFn [("qux",13),("foo",2),("bar",42)] + + ghci> Data.HamtMap.map succ a -- apply a function to all values + fromList hashFn [("qux",14),("foo",2),("bar",43)] + + ghci> keys a + ["qux","foo","bar"] + + ghci> elems a + [13,1,42] + + ghci> fromList Data.HashTable.hashString [("a", 1), ("b", 2), ("c", 3)] + fromList hashFn [("b",2),("c",3),("a",1)] + + ghci> toList it + [("b",2),("c",3),("a",1)] + + +Installation +------------ + +To try it yourself, just do the usual: + + $ runghc Setup.hs configure --user + $ runghc Setup.hs build + $ runghc Setup.hs install + +Performance +----------- + +The single-element operations for the hash map have logarithmic asymtotic +runtime complexity. However, it is implemented as a 32-ary tree, which means it +never exceeds a depth of 7 nodes, so you can treat them as constant-time +operations (for relatively large constants). + +How it works +------------ + +I wrote this code after reading the following explanatory blog posts on how the +Clojure version works. They should also provide a decent birds-eye overview of +my Haskell implementation. + +* [Understanding Clojure’s PersistentHashMap + ](http://blog.higher-order.net/2009/09/08/understanding-clojures-persistenthashmap-deftwice/) +* [Assoc and Clojure’s PersistentHashMap: part II + ](http://blog.higher-order.net/2010/08/16/assoc-and-clojures-persistenthashmap-part-ii/) + + +To do +----- +* Match Data.Map in completeness +* Performance tuning + * Efficient implementations of (//), etc. based on fromList diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/benchmark.hs b/benchmarks/benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmarks/benchmark.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GADTs #-} + +module Main where + +import Control.DeepSeq +import Control.Exception (evaluate) +import Control.Monad.Trans (liftIO) +import Criterion.Config +import Criterion.Main +import Data.Hashable (Hashable(hash)) +import Data.Int (Int32) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import qualified Data.HamtMap as HM +import Data.List (foldl') +import Data.Maybe (fromMaybe) +import Prelude hiding (lookup) +import System.Random (mkStdGen, randomRs) + +instance NFData BS.ByteString + +hashBS :: BS.ByteString -> Int32 +hashBS = fromIntegral . hash + +main :: IO () +main = do + let hmbs = HM.fromList hashBS elemsBS :: HM.HamtMap BS.ByteString Int + defaultMainWith defaultConfig + (liftIO . evaluate $ rnf [hmbs]) + [ bench "fromList" $ nf (HM.fromList hashBS) elemsBS + , bench "lookup" $ nf (lookup keysBS) hmbs + , bench "insert" $ nf (insert elemsBS) (HM.empty hashBS) + , bench "delete" $ nf (delete keysBS) hmbs + ] + where + n :: Int + n = 2^(12 :: Int) + + elemsBS = zip keysBS [1..n] + keysBS = rnd 8 n + +lookup :: Eq k => [k] -> HM.HamtMap k Int -> Int +lookup xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs + +insert :: Eq k => [(k, Int)] -> HM.HamtMap k Int -> HM.HamtMap k Int +insert xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs + +delete :: Eq k => [k] -> HM.HamtMap k Int -> HM.HamtMap k Int +delete xs m0 = foldl' (\m k -> HM.delete k m) m0 xs + +-- | Generate a number of fixed length strings where the content of +-- the strings are letters in random order. +rnd :: Int -- ^ Length of each string + -> Int -- ^ Number of strings + -> [BS.ByteString] +rnd strlen num = map C.pack $ take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234 + where + split cs = case splitAt strlen cs of (str, cs') -> str : split cs' diff --git a/benchmarks/benchmarkmap.hs b/benchmarks/benchmarkmap.hs new file mode 100644 --- /dev/null +++ b/benchmarks/benchmarkmap.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE GADTs #-} + +module Main where + +import Control.DeepSeq +import Control.Exception (evaluate) +import Control.Monad.Trans (liftIO) +import Criterion.Config +import Criterion.Main +import Data.Hashable (Hashable(hash)) +import Data.Int (Int32) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import qualified Data.Map as M +import Data.List (foldl') +import Data.Maybe (fromMaybe) +import Prelude hiding (lookup) +import System.Random (mkStdGen, randomRs) + +instance NFData BS.ByteString + +hashBS :: BS.ByteString -> Int32 +hashBS = fromIntegral . hash + +main :: IO () +main = do + let hmbs = M.fromList elemsBS :: M.Map BS.ByteString Int + defaultMainWith defaultConfig + (liftIO . evaluate $ rnf [hmbs]) + [ bench "fromList" $ nf M.fromList elemsBS + , bench "lookup" $ nf (lookup keysBS) hmbs + , bench "insert" $ nf (insert elemsBS) (M.empty) + , bench "delete" $ nf (delete keysBS) hmbs + ] + where + n :: Int + n = 2^(12 :: Int) + + elemsBS = zip keysBS [1..n] + keysBS = rnd 8 n + +lookup :: Ord k => [k] -> M.Map k Int -> Int +lookup xs m = foldl' (\z k -> fromMaybe z (M.lookup k m)) 0 xs + +insert :: Ord k => [(k, Int)] -> M.Map k Int -> M.Map k Int +insert xs m0 = foldl' (\m (k, v) -> M.insert k v m) m0 xs + +delete :: Ord k => [k] -> M.Map k Int -> M.Map k Int +delete xs m0 = foldl' (\m k -> M.delete k m) m0 xs + +-- | Generate a number of fixed length strings where the content of +-- the strings are letters in random order. +rnd :: Int -- ^ Length of each string + -> Int -- ^ Number of strings + -> [BS.ByteString] +rnd strlen num = map C.pack $ take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234 + where + split cs = case splitAt strlen cs of (str, cs') -> str : split cs' + diff --git a/hamtmap.cabal b/hamtmap.cabal new file mode 100644 --- /dev/null +++ b/hamtmap.cabal @@ -0,0 +1,26 @@ +name: hamtmap +version: 0.2 +cabal-version: >= 1.2 +synopsis: A purely functional and persistent hash map +description: A port of Clojure's efficient persistent and hash + map data structure to Haskell +license: BSD3 +license-File: LICENSE +author: Kevin Wu Won +maintainer: Kevin Wu Won +homepage: https://github.com/exclipy/pdata +category: Data Structures +build-type: Simple +extra-source-files: + Data/BitUtil.hs + benchmarks/benchmark.hs + benchmarks/benchmarkmap.hs + tests/tests.hs + README.md +stability: experimental + +library + build-depends: base >= 4 && < 5, array, deepseq + exposed-modules: Data.HamtMap + other-modules: Data.BitUtil + ghc-options: -O2 diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,79 @@ +import Test.QuickCheck +import Test.QuickCheck.Batch +import Data.Hashable +import Data.HamtMap as HM +import Data.Int +import Data.List (foldl', sort) +import Data.Maybe (isNothing) +import Prelude as P + +ldelete :: (Eq k) => k -> [(k, v)] -> [(k, v)] +ldelete _ [] = [] +ldelete k ((k', v'):xs) | k' == k = ldelete k xs + | otherwise = (k', v') : ldelete k xs + +lset :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)] +lset k v [] = [] +lset k v ((k', v'):xs) | k' == k = (k, v) : lset k v xs + | otherwise = (k', v') : lset k v xs + +prop_insert :: (Eq k, Hashable k, Eq v) => (k -> Int32) -> k -> v -> [(k, v)] -> Bool +prop_insert hashFn k v lm = + let hm = fromList hashFn lm + hm' = insert k v hm + in member k hm' + && not (notMember k hm') + && HM.lookup k hm' == Just v + && hm' ! k == v + && (if member k hm + then toList hm == lset k (hm ! k) (toList hm') + else toList hm == ldelete k (toList hm') + ) + +prop_delete :: (Eq k, Hashable k, Eq v) => (k -> Int32) -> k -> [(k, v)] -> Bool +prop_delete hashFn k lm = + let hm = fromList hashFn lm + hm' = delete k hm + in not (member k hm') + && notMember k hm' + && isNothing (HM.lookup k hm') + && (if member k hm + then toList hm' == ldelete k (toList hm) + else toList hm' == toList hm + ) + +prop_fromList :: (Eq k, Hashable k, Ord k, Eq v, Ord v) => (k -> Int32) -> [(k, v)] -> Bool +prop_fromList hashFn lm = + let hm = fromList hashFn lm + hm' = foldl' (\hm (k,v) -> insert k v hm) (empty hashFn) lm + in sort (toList hm) == sort (toList hm') + +prop_toList :: (Eq k, Hashable k, Ord k, Eq v, Ord v) => (k -> Int32) -> [(k, v)] -> Bool +prop_toList hashFn lm = + let hm = fromList hashFn lm + lm' = toList hm + ks = keys hm + ks' = P.map fst lm' + els = elems hm + els' = P.map snd lm' + els'' = P.map (\k -> hm ! k) ks + in ks == ks' + && els == els' + && els == els'' + + +options = TestOptions + { no_of_tests = 200 + , length_of_tests = 2 -- seconds + , debug_tests = False } + +main = runTests "tests" options + [ run (prop_insert fromIntegral :: Int -> Int -> [(Int,Int)] -> Bool) + , run (prop_insert (fromIntegral.(`mod` 2)) :: Int -> Int -> [(Int,Int)] -> Bool) + , run (prop_delete fromIntegral :: Int -> [(Int, Int)] -> Bool) + , run (prop_delete (fromIntegral.(`mod` 2)) :: Int -> [(Int,Int)] -> Bool) + , run (prop_fromList fromIntegral :: [(Int, Int)] -> Bool) + , run (prop_fromList (fromIntegral.(`mod` 2)) :: [(Int, Int)] -> Bool) + , run (prop_toList fromIntegral :: [(Int, Int)] -> Bool) + , run (prop_toList (fromIntegral.(`mod` 2)) :: [(Int, Int)] -> Bool) + ]