data-stringmap 1.0.0 → 1.0.1.1
raw patch · 4 files changed
+547/−4 lines, 4 filesnew-uploader
Files
- Data/StringMap/Base.hs +3/−3
- Data/StringMap/Dim2Search.hs +275/−0
- data-stringmap.cabal +2/−1
- tests/Dim2Test.hs +267/−0
Data/StringMap/Base.hs view
@@ -11,7 +11,7 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental- Portability: not portable+ Portability: portable An efficient implementation of maps from strings to arbitrary values. @@ -592,9 +592,9 @@ look _ _ = normError "lookupLE" -- | Combination of 'lookupLE' and 'lookupGE'--- +-- -- > keys $ lookupRange "a" "b" $ fromList $ zip ["", "a", "ab", "b", "ba", "c"] [1..] = ["a","ab","b"]--- +-- -- For all keys in @k = keys $ lookupRange lb ub m@, this property holts true: @k >= ub && k <= lb@ lookupRange :: Key -> Key -> StringMap a -> StringMap a
+ Data/StringMap/Dim2Search.hs view
@@ -0,0 +1,275 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Data.StringMap.Dim2Search+ Copyright : Copyright (C) 2014 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable++ 2-dimensional range search of numeric values, e.g. pairs of Ints or Doubles+ using StringMap and prefix search++ Assumption: The coordinates, e.g. Int values are converted into strings+ of equal length such that the ordering is preserved by the lexikographic ordering.++ Example: convert an Int (>= 0) into a String+ @intToString = reverse . take 19 . (++ repeat '0') . reverse . show@++ Do this for both coordinates of a tuple+ @(x,y)::(Int,Int)@+ and merge the two strings character by character.+ The resulting string is used as key and stored together with an attribute+ in a StringMap.++ A range search for all keys within a rectangle @(p1, p2) = ((x1,y1),(x2,y2))@+ in a map @m@ can be done by @lookupGE p1' . lookupLE p2' $ m@ with+ @p1'@ and @p2'@ as the to string converted points of the rectangle.++ @lookupGE p1'@ throws away all keys not located in the quadrant with @p1@+ as lower left corner, @lookupLE p2'@ all key not located in the quadrant+ with @p2@ as upper right corner. So the combination (@lookupRange@) computed+ the intersection of these two quadrants.++ Efficiency of these two function is about the same as a normal lookup+ from StringMap.Base.++ This module should be imported @qualified@, the names in Data.StringMap.Dim2Search are the+ same as theirs siblings in Data.StringMap:++ > import Data.StringMap (StringMap)+ > import qualified Data.StringMap as M+ > import qualified Data.StringMap.Dim2Search as Dim2++-}++-- ----------------------------------------------------------------------------++module Data.StringMap.Dim2Search+-- {-+ ( lookupGE+ , lookupLE+ , lookupRange+ )+-- -}+where++import Data.StringMap.Base hiding (lookupGE, lookupLE, lookupRange)++-- ----------------------------------------++-- | remove all entries from the map with key less than the argument key++lookupGE :: Key -> StringMap a -> StringMap a+lookupGE = lookupGE'++lookupGE' :: Key -> StringMap a -> StringMap a+lookupGE' k0 = look k0 . norm+ where++ -- take all values in tree t, they are larger than the key+ look [] t = t++ look k@(c : k1) (Branch c' s' n')+ -- this dimension fits for s', the other dimension has to be checked+ -- with lookupGE2, process has to be repeated for the rest+ | c < c' = branch c' (lookupGE2 k1 s') rest++ -- symbols are equal, no info about ordering gathered, repeat the+ -- the same lookup for the subtree s'+ -- the rest in n' has to be processed the same way as this branch+ | c == c' = branch c' (lookupGE' k1 s') rest++ -- this dimension does not fit, throw away this branch and continue with n'+ | otherwise = rest+ where+ rest = lookupGE' k n'++ -- empty remains empty+ look _ Empty = empty++ -- throw away the value, its smaller than required+ look k (Val _v' t') = lookupGE' k t'++ -- the impossible has happened+ look _ _ = normError "lookupGE'"++lookupGE2 :: Key -> StringMap a -> StringMap a+lookupGE2 k0 = look k0 . norm+ where+ -- key is empty, all values in t are larger, so they are included+ look [] t = t++ look k@(c : k1) t@(Branch c' s' n')+ -- tree s' and all others in n' contain values larger than required+ -- take them+ | c < c' = t++ -- the 1. symbols are equal, so lookup has to continue,+ -- but only along this dimension, so skip the next key symbol (lookupLE1) and+ -- repeat this comparison procedure (call of lookupLE2 in lookupLE1)+ -- the rest (n') is taken like in the 1. case+ | c == c' = branch c' (lookupGE1 k1 s') n'++ -- the 1. symbol in the key is larger, so cut off this subtree (s')+ -- and repeat lookup for the rest (n')+ | otherwise = lookupGE2 k n'++ -- empty remains empty+ look _ Empty = empty++ -- throw away the value, its smaller than required+ look k (Val _v' t') = lookupGE2 k t'++ -- the impossible has happened+ look _ _ = normError "lookupGE2"++lookupGE1 :: Key -> StringMap a -> StringMap a+lookupGE1 k0 = look k0 . norm+ where+ -- like above+ look [] t = t++ -- ignore the 1. symbol of the key, take the subtree s' and+ -- continue comparison of every other symbol,+ -- do the same for all remaining trees in n'+ look k@(_c : k1) (Branch c' s' n')+ = branch c' (lookupGE2 k1 s') $ lookupGE1 k n'++ -- like above+ look _ Empty = empty++ -- like above+ look k (Val _v' t') = lookupGE1 k t'++ -- like above+ look _ _ = normError "lookupGE1"++-- ----------------------------------------+--+-- the same stuff for less or equal++lookupLE :: Key -> StringMap a -> StringMap a+lookupLE = lookupLE'++lookupLE' :: Key -> StringMap a -> StringMap a+lookupLE' k0 = look k0 . norm+ where++ -- if key is empty and node stores a value+ -- take this value, it's the upper limit,+ -- all other values in the subtree _t' are larger and thrown away+ look [] (Val v' _t') = (Val v' empty)++ -- key is empty, all remaining values in _t are larger and thrown away+ look [] _t = empty++ look k@(c : k1) (Branch c' s' n')+ -- the char c' is larger than the 1. char in the search key+ -- so this and all other others (n') are cut off+ | c < c' = empty++ -- the char c and c' are the same, so search for this subtree s' must+ -- continue, but all further trees (n') are cut off+ | c == c' = branch c' (lookupLE' k1 s') empty++ -- the char c' is smaller than the 1. char in the search key+ -- so concerning this dimension, the elements must be included into the+ -- result, but the other dimension must be checked (with lookupLE2)+ -- all remaining values in n' have also to be taken, therfore the rec. call with n'+ | otherwise = branch c' (lookupLE2 k1 s') (lookupLE' k n')++ -- the empty tree remains empty+ look _ Empty = empty++ -- the values v' are included into the result, and the lookup process+ -- continues with the subtree t'+ -- this case will not occur, when the 2-dim keys are normalized and all+ -- are of the same length, in that case the values occur only on leaf nodes not in inner nodes+ look k (Val v' t') = val v' (lookupLE' k t')++ -- the impossible has happend+ look _ _ = normError "lookupLE'"++lookupLE2 :: Key -> StringMap a -> StringMap a+lookupLE2 k0 = look k0 . norm+ where++ -- if key is empty and node stores a value+ -- take this value, it's the upper limit,+ -- all other values in the subtree _t' are larger and thrown away+ look [] (Val v' _t') = (Val v' empty)++ -- key is empty, all remaining values in _t are larger and thrown away+ look [] _t = empty++ look k@(c : k1) (Branch c' s' n')+ -- tree s' and all others in n' contain values larger than required+ -- throw them away+ | c < c' = empty++ -- the 1. symbols are equal, so lookup has to continue,+ -- but only along this dimension, so skip the next key symbol (lookupLE1) and+ -- repeat this comparison procedure (call of lookupLE2 in lookupLE1)+ -- the rest (n') can be thrown away like in the 1. case+ | c == c' = branch c' (lookupLE1 k1 s') empty++ -- the 1. symbol in the key is larger, so take this subtree (s')+ -- and repeat lookup for the rest (n')+ | otherwise = branch c' s' (lookupLE2 k n')++ -- the empty tree remains empty+ look _ Empty = empty++ -- the values v' are included into the result, and the lookup process+ -- continues with the subtree t'+ -- this case will not occur, when the 2-dim keys are normalized and all+ -- are of the same length, in that case the values occur only on leaf nodes not in inner nodes+ look k (Val v' t') = val v' (lookupLE2 k t')++ -- the impossible has happend+ look _ _ = normError "lookupLE2"++lookupLE1 :: Key -> StringMap a -> StringMap a+lookupLE1 k0 = look k0 . norm+ where+ -- like above+ look [] (Val v' _t') = (Val v' empty)++ -- like above+ look [] t = t++ -- ignore the 1. symbol of the key, take the subtree s' and+ -- continue comparison of every other symbol,+ -- do the same for all remaining trees in n'+ look k@(_c : k1) (Branch c' s' n')+ = branch c' (lookupLE2 k1 s') (lookupLE1 k n')++ -- like above+ look _ Empty = empty++ -- like above+ look k (Val v' t') = val v' (lookupLE1 k t')++ -- like above+ look _ _ = normError "lookupLE1"+++-- | Combination of 'lookupLE' and 'lookupGE'+--+-- > keys $ lookupRange "a" "b" $ fromList $ zip ["", "a", "ab", "b", "ba", "c"] [1..] = ["a","ab","b"]+--+-- For all keys in @k = keys $ lookupRange lb ub m@, this property holts true: @k >= ub && k <= lb@++lookupRange :: Key -> Key -> StringMap a -> StringMap a+lookupRange lb ub = lookupGE lb . lookupLE ub++-- ----------------------------------------++normError :: String -> a+normError = normError' "Data.StringMap.Dim2Search"++-- ----------------------------------------+
data-stringmap.cabal view
@@ -1,5 +1,5 @@ name: data-stringmap-version: 1.0.0+version: 1.0.1.1 license: MIT license-file: LICENSE author: Uwe Schmidt, Sebastian Philipp@@ -55,6 +55,7 @@ Data.StringMap.StringSet Data.StringMap.Types Data.StringMap.Base+ Data.StringMap.Dim2Search other-modules: Data.StringMap.FuzzySearch
+ tests/Dim2Test.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Main where++import Data.List (sort)+import qualified Data.StringMap as M+import qualified Data.StringMap.Dim2Search as D2++-- ----------------------------------------+--+-- auxiliary functions for mapping pairs of Ints to Strings and vice versa++intToKey :: Int -> Int -> Int -> String+intToKey base len val = tok len val ""+ where+ tok 0 _ acc = acc+ tok i v acc = tok (i - 1) v' (d : acc)+ where+ (v', r) = v `divMod` base+ d = toEnum (r + fromEnum '0')++intPairToKey :: Int -> Int -> (Int, Int) -> String+intPairToKey base len (x, y) = merge x' y'+ where+ x' = intToKey base len x+ y' = intToKey base len y++merge :: [a] -> [a] -> [a]+merge [] [] = []+merge (x : xs) (y : ys) = x : y : merge xs ys++intFromKey :: String -> Int+intFromKey = read++unMerge :: [a] -> ([a], [a])+unMerge [] = ([], [])+unMerge (x : y : s) = (x : xs, y : ys)+ where+ (xs, ys) = unMerge s++-- ----------------------------------------+--+-- experiment to understand 2-dimensional location+-- search implemented by using the StringMap impl.+--+-- an ordering on strings (representing pairs of ints)+-- that is isomorphic to the partial ordering+-- used for 2-dimensional search++instance Ord Point' where+ (P' s1) <= (P' s2) = s1 `le` s2+ where+ le [] [] = True+ le (x1 : y1 : ds1) (x2 : y2 : ds2)+ | x1 == x2 && y1 == y2 = ds1 `le` ds2+ | x1 == x2 && y1 < y2 = ds1 `leX` ds2+ | x1 < x2 && y1 == y2 = ds1 `leY` ds2+ | x1 < x2 && y1 < y2 = True+ | otherwise = False++ leX [] [] = True -- the result for the Y dimension is already known+ leX (x1 : y1 : ds1) (x2 : y2 : ds2)+ | x1 == x2 = ds1 `leX` ds2+ | x1 < x2 = True+ | otherwise = False++ leY [] [] = True -- the result for the X dimension is already known+ leY (x1 : y1 : ds1) (x2 : y2 : ds2)+ | y1 == y2 = ds1 `leY` ds2+ | y1 < y2 = True+ | otherwise = False++-- toPoint' and fromPoint': the bijection Point <-> Point'++toPoint' :: Point -> Point'+toPoint' (P p) = P' $ intPairToKey base len p+ where+ base = 2 -- or 10+ len = 10 -- or 3 (or something else)++fromPoint' :: Point' -> Point+fromPoint' (P' ds) = P (intFromKey xs, intFromKey ys)+ where+ (xs, ys) = unMerge ds++-- the test, whether the `le` ordering is preserved, when working with Point'+propOrdered :: Point -> Point -> Bool+propOrdered p1 p2+ = (p1 `le` p2) == (toPoint' p1 <= toPoint' p2)++-- very quick check test+propTest :: Int -> [(Point, Point)]+propTest n+ = filter (not . uncurry propOrdered) qs+ where+ xs = [1..n]+ ps = [P (x, y) | x <- xs, y <- xs]+ qs = [(p1, p2) | p1 <- ps, p2 <- ps]++test1 :: Bool+test1 = null $ propTest 20++-- ----------------------------------------++newtype Point = P {unP :: (Int, Int) } deriving (Eq)+newtype PointSet = PS {unPS :: [Point] } deriving (Eq)+ -- assuming only smart constructor mkPS is used++newtype Point' = P' {unP' :: String } deriving (Eq)+newtype PointSet' = PS' {unPS' :: M.StringMap ()} deriving (Eq)++instance Show Point where show = show . unP+instance Show Point' where show = show . unP'+instance Show PointSet where show = show . unPS+instance Show PointSet' where show = show . M.keys . unPS'++class PartOrd a where+ le :: a -> a -> Bool+ ge :: a -> a -> Bool++instance PartOrd Point where+ (P (x1, y1)) `le` (P (x2, y2))+ = x1 <= x2 && y1 <= y2++ (P (x1, y1)) `ge` (P (x2, y2))+ = x1 >= x2 && y1 >= y2++instance PartOrd Point' where+ (P' p1) `le` (P' p2)+ = not . M.null . D2.lookupLE p2 $ (M.singleton p1 ())++ (P' p1) `ge` (P' p2)+ = not . M.null . D2.lookupGE p2 $ (M.singleton p1 ())++class Lookup p s | s -> p where+ lookupLE :: p -> s -> s+ lookupGE :: p -> s -> s++instance Lookup Point PointSet where+ lookupLE p ps = PS . filter (`le` p) . unPS $ ps+ lookupGE p ps = PS . filter (`ge` p) . unPS $ ps++instance Lookup Point' PointSet' where+ lookupLE p ps = PS' . D2.lookupLE (unP' p) . unPS' $ ps+ lookupGE p ps = PS' . D2.lookupGE (unP' p) . unPS' $ ps++-- the bijection between Point and Point'++pToP' :: Point -> Point'+pToP' = P' . intPairToKey 10 5 . unP -- base 10, 5 digits++p'ToP :: Point' -> Point+p'ToP (P' p') = P (intFromKey xs, intFromKey ys)+ where+ (xs, ys) = unMerge p'++-- the bijection between PointSet and PointSet'++psToPS' :: PointSet -> PointSet'+psToPS' = PS' . M.fromList . map (\(P' x) -> (x, ())) . map pToP' . unPS++ps'ToPS :: PointSet' -> PointSet+ps'ToPS = mkPS . map (unP . p'ToP . P') . M.keys . unPS'++mkP :: Int -> Int -> Point+mkP x y = P (x, y)++mkP' :: Int -> Int -> Point'+mkP' x y = pToP' $ mkP x y++mkPS :: [(Int, Int)] -> PointSet+mkPS = PS . map P . sort++mkPS' :: [(Int, Int)] -> PointSet'+mkPS' = psToPS' . mkPS++mkxx :: Int -> Point+mkxx i = mkP i i++mkxx' :: Int -> Point'+mkxx' = pToP' . mkxx++mkD2 :: [Int] -> PointSet+mkD2 = PS . map mkxx++mkD2' :: [Int] -> PointSet'+mkD2' = psToPS' . mkD2++d1 :: PointSet+d1 = mkD2 [1,10,100,105,107,125,200, 205, 222]++d1' :: PointSet'+d1' = psToPS' d1++d2 :: PointSet+d2 = mkD2 [2,10,20,25,100,111,155,200,333,500]++d2' :: PointSet'+d2' = psToPS' d2++d0' :: PointSet'+d0' = mkD2' [10,100]+++mkSquare :: Int -> Int -> PointSet+mkSquare n m = mkPS [(i, j) | i <- [n..m], j <- [n..m]]++-- input list must contain at least 3 different elements+mkPointPointSet :: [Int] -> ([Point], PointSet)+mkPointPointSet xs0+ = (ps, ps')+ where+ xs@(_ : ys@(_:_:_)) = sort xs0+ xs' = init ys+ ps = [mkP i j | i <- xs, j <- xs ]+ ps' = mkPS [ (i, j) | i <- xs', j <- xs']+++ps1 :: PointSet+xs1 :: [Point]+(xs1, ps1) = mkPointPointSet [1,2,10,20,25,100,111,155,200,333,500,505]++lawBijection :: PointSet -> Bool+lawBijection ps+ = ps == (ps'ToPS . psToPS' $ ps)++lawPredicateMorphism :: (Point -> Bool) -> (Point' -> Bool) ->+ Point -> Bool+lawPredicateMorphism p p' x+ = p x == (p' $ pToP' x)++lawPredicate2Morphism :: (Point -> Point -> Bool) -> (Point' -> Point' -> Bool) ->+ Point -> Point -> Bool+lawPredicate2Morphism p2 p2' x y+ = lawPredicateMorphism (p2 x) (p2' $ pToP' x) y++lawPointSetMorphism :: (PointSet -> PointSet) -> (PointSet' -> PointSet') ->+ PointSet -> Bool+lawPointSetMorphism f f' ps+ = f ps == (ps'ToPS . f' . psToPS' $ ps)++lawLookupGE :: Point -> PointSet -> Bool+lawLookupGE p ps = lawPointSetMorphism (lookupGE p) (lookupGE $ pToP' p) ps++lawLookupLE :: Point -> PointSet -> Bool+lawLookupLE p ps = lawPointSetMorphism (lookupLE p) (lookupLE $ pToP' p) ps++testPointPointSet :: (Point -> PointSet -> Bool) -> ([Point], PointSet) -> [Point]+testPointPointSet law (xs, ps)+ = filter (\p -> not $ law p ps) xs++testLookup :: ([Point], PointSet) -> Bool+testLookup ps+ = null (testPointPointSet lawLookupLE ps)+ &&+ null (testPointPointSet lawLookupGE ps)++theTest :: Bool+theTest = testLookup $+ mkPointPointSet [1,2,10,20,25,100,111,155,200,333,500,505]++main :: IO ()+main = print theTest >> return ()++-- ----------------------------------------+