identifiers 0.3.0.0 → 0.3.1.0
raw patch · 2 files changed
+106/−71 lines, 2 files
Files
- identifiers.cabal +1/−1
- src/Data/TrieMap.hs +105/−70
identifiers.cabal view
@@ -1,5 +1,5 @@ name: identifiers-version: 0.3.0.0+version: 0.3.1.0 synopsis: Numeric identifiers for values. description: Useful for situations where repeated-storage requirements of values become too costly.
src/Data/TrieMap.hs view
@@ -4,25 +4,40 @@ import Data.List (foldl') import Prelude hiding (lookup) +-- Deep Wide+data TrieMap k v = Root !(TrieNode k v)+ | ValueRoot !v !(TrieNode k v)+ | FlatRoot !v+ | EmptyRoot+ deriving (Show, Eq) -data TrieMap k v = Map !(Maybe v) [TrieNode k v] deriving (Show, Eq)-data TrieNode k v = EmptyNode !k [TrieNode k v]- | ValueNode !k !v [TrieNode k v]- | ValueEnd !k !v+data TrieNode k v = Node !k !(TrieNode k v) !(TrieNode k v)+ | Vertical !k !(TrieNode k v)+ | Horizontal !k !(TrieNode k v)+ | ValueVert !k !v !(TrieNode k v)+ | ValueHoriz !k !v !(TrieNode k v)+ | ValueNode !k !v !(TrieNode k v) !(TrieNode k v)+ | ValueBottom !k !v deriving (Show, Eq) instance (NFData k, NFData v) => NFData (TrieMap k v) where- rnf (Map v ns) = rnf (v, ns)+ rnf (Root a) = rnf a+ rnf (ValueRoot a b) = rnf (a, b)+ rnf (FlatRoot a) = rnf a+ rnf (EmptyRoot) = rnf () instance (NFData k, NFData v) => NFData (TrieNode k v) where- rnf (EmptyNode k ns) = rnf (k, ns)- rnf (ValueNode k v ns) = rnf (k, v, ns)- rnf (ValueEnd k v) = rnf (k, v)-+ rnf (Node a b c) = rnf (a, b, c)+ rnf (Vertical a b) = rnf (a, b)+ rnf (Horizontal a b) = rnf (a, b)+ rnf (ValueVert a b c) = rnf (a, b, c)+ rnf (ValueHoriz a b c) = rnf (a, b, c)+ rnf (ValueNode a b c d) = rnf (a, b, c, d)+ rnf (ValueBottom a b) = rnf (a, b) -- | The empty TrieMap empty :: TrieMap k v-empty = Map Nothing []+empty = EmptyRoot -- | Create map from list of associations fromList :: Eq k => [([k], v)] -> TrieMap k v@@ -31,73 +46,93 @@ -- | Search for a value in the map lookup :: Eq k => TrieMap k v -> [k] -> Maybe v-lookup (Map Nothing []) _ = Nothing-lookup (Map v _) [] = v-lookup (Map _ ns) ks = go ns ks where- go [] _ = Nothing- go _ [] = Nothing- go (EmptyNode j next:ns') ks'@(k:ks'') | j == k = go next ks''- | otherwise = go ns' ks'- go (ValueNode j v _:ns') ks'@[k] | j == k = Just v- | otherwise = go ns' ks'- go (ValueNode j _ next:ns') ks'@(k:ks'') | j == k = go next ks''- | otherwise = go ns' ks'- go (ValueEnd j v:ns') ks'@[k] | j == k = Just v- | otherwise = go ns' ks'- go (ValueEnd j _:ns') ks'@(k:_) | j == k = Nothing- | otherwise = go ns' ks'+lookup (EmptyRoot) _ = Nothing+lookup (FlatRoot v) [] = Just v+lookup (FlatRoot _) _ = Nothing+lookup (ValueRoot v _) [] = Just v+lookup (ValueRoot _ next) ks = lookupNode next ks+lookup (Root _) [] = Nothing+lookup (Root next) ks = lookupNode next ks +-- | Recursive lookup from nodes down (excluding root)+lookupNode :: Eq k => TrieNode k v -> [k] -> Maybe v+lookupNode _ [] = Nothing+lookupNode (Node k down right) ks@(x:xs)+ | x == k = lookupNode down xs+ | otherwise = lookupNode right ks+lookupNode (ValueNode k v down right) ks@(x:xs)+ | null xs && x == k = Just v+ | x == k = lookupNode down xs+ | otherwise = lookupNode right ks+lookupNode (ValueBottom k v) (x:xs)+ | null xs && x == k = Just v+ | otherwise = Nothing+lookupNode (Vertical k down) (x:xs)+ | null xs || x /= k = Nothing+ | otherwise = lookupNode down xs+lookupNode (Horizontal k right) ks@(x:_)+ | x /= k = Nothing+ | otherwise = lookupNode right ks+lookupNode (ValueVert k v down) (x:xs)+ | null xs && x == k = Just v+ | x == k = lookupNode down xs+ | otherwise = Nothing+lookupNode (ValueHoriz k v right) ks@(x:xs)+ | null xs && x == k = Just v+ | x == k = Nothing+ | otherwise = lookupNode right ks +-- | Unsafe indexing into TrieMap (!) :: Eq k => TrieMap k v -> [k] -> v m ! k | Just v <- lookup m k = v- | otherwise = error "oh noes!"+ | otherwise = error "Key not found in TrieMap" -- | Insert new word into map insert :: Eq k => TrieMap k v -> [k] -> v -> TrieMap k v-insert (Map Nothing ns) [] v = Map (Just v) ns-insert m [] _ = m -- Don't clobber existing values-insert (Map v ns) ks v' = Map v $ go ns ks where- go _ [] = [] -- Not sure how we got here; try to handle anyway.- go [] (x:[]) = [ValueEnd x v']- go [] (x:xs) = [EmptyNode x (go [] xs)]-- -- Last key unit vs ValueNode- go ns''@(n@(ValueNode j _ _):ns') xs'@[x]- | j == x = ns'' -- No clobber- | otherwise = n : go ns' xs'-- -- Last key unit vs EmptyNode- go (n@(EmptyNode j next):ns') xs'@[x]- | j == x = ValueNode j v' next : ns' -- Promote to ValueNode- | otherwise = n : go ns' xs'-- -- Last key unit vs ValueEnd- go ns''@(n@(ValueEnd j _):ns') xs@[x]- | j == x = ns'' -- No clobber- | otherwise = n : go ns' xs-- -- Key unit vs ValueNode- go (n@(ValueNode j w next):ns') xs'@(x:xs)- | j == x = ValueNode j w (go next xs) : ns' -- Decend into node- | otherwise = n : go ns' xs'-- -- Key unit vs EmptyNode- go (n@(EmptyNode j next):ns') xs'@(x:xs)- | j == x = EmptyNode j (go next xs) : ns' -- Decend into node- | otherwise = n : go ns' xs'-- -- Key unit vs ValueEnd- go (n@(ValueEnd j w):ns') xs'@(x:xs)- | j == x = ValueNode j w (go [] xs) : ns' -- Promote to ValueNode- | otherwise = n : go ns' xs'+insert (Root down) [] v = ValueRoot v down+insert (ValueRoot _ down) [] v = ValueRoot v down+insert (FlatRoot _) [] v = FlatRoot v+insert EmptyRoot [] v = FlatRoot v+insert (Root down) ks v = Root $ insertNode down ks v+insert (ValueRoot w down) ks v = ValueRoot w $ insertNode down ks v+insert (FlatRoot w) ks v = ValueRoot w $ createNode ks v+insert EmptyRoot ks v = Root $ createNode ks v +-- | Insert value into existing tree of nodes+insertNode :: Eq k => TrieNode k v -> [k] -> v -> TrieNode k v+insertNode _ [] _ = error "insertNode should never be called with an empty key"+insertNode (Node k down right) ks@(x:xs) v+ | null xs && x == k = ValueNode k v down right+ | x == k = Node k (insertNode down xs v) right+ | otherwise = Node k down $ insertNode right ks v+insertNode (Vertical k down) ks@(x:xs) v + | null xs && x == k = ValueVert k v down+ | x == k = Vertical k $ insertNode down xs v+ | otherwise = Node k down $ createNode ks v+insertNode (Horizontal k right) ks@(x:xs) v+ | null xs && x == k = ValueHoriz k v right+ | x == k = Node k (createNode xs v) right+ | otherwise = Horizontal k $ insertNode right ks v+insertNode (ValueVert k w down) ks@(x:xs) v+ | null xs && x == k = ValueVert k v down+ | x == k = ValueVert k w $ insertNode down xs v+ | otherwise = ValueNode k w down $ createNode ks v+insertNode (ValueHoriz k w right) ks@(x:xs) v+ | null xs && x == k = ValueHoriz k v right+ | x == k = ValueNode k w (createNode xs v) right+ | otherwise = ValueHoriz k w $ insertNode right ks v+insertNode (ValueNode k w down right) ks@(x:xs) v+ | null xs && x == k = ValueNode k v down right+ | x == k = ValueNode k w (insertNode down xs v) right+ | otherwise = ValueNode k w down (insertNode right ks v)+insertNode (ValueBottom k w) ks@(x:xs) v+ | null xs && x == k = ValueBottom k v+ | x == k = ValueVert k w $ createNode xs v+ | otherwise = ValueHoriz k w $ createNode ks v -{--insert [] (k:[]) v = [R k (Just v) []]-insert [] (k:ks) v = [R k Nothing (insert [] ks v)]-insert (R j _ next : rs) (k:[]) v' | j == k = R j (Just v') next : rs-insert (R j v next : rs) (k:ks) v' | j == k = R j v (insert next ks v') : rs-insert xs [] _ = xs-insert (r:rows) ks v = r : insert rows ks v--}+-- | Create node (or series of nodes) to point to value+createNode :: Eq k => [k] -> v -> TrieNode k v+createNode [] _ = error "createNode should never be called with an empty key"+createNode (k:[]) v = ValueBottom k v+createNode (k:ks) v = Vertical k $ createNode ks v