diff --git a/Data/Chimera.hs b/Data/Chimera.hs --- a/Data/Chimera.hs +++ b/Data/Chimera.hs @@ -1,146 +1,325 @@ -- | -- Module: Data.Chimera --- Copyright: (c) 2018 Andrew Lelechenko +-- Copyright: (c) 2018-2019 Andrew Lelechenko -- Licence: MIT -- Maintainer: Andrew Lelechenko -- --- Lazy, infinite stream with O(1) indexing. +-- Lazy infinite streams with O(1) indexing. {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE TypeApplications #-} module Data.Chimera - ( Chimera - , index + ( -- * Memoization + memoize + , memoizeFix + -- * Chimera + , Chimera + , VChimera + , UChimera + -- * Construction , tabulate , tabulateFix + , iterate + , cycle + + -- * Elimination + , index + , toList + + -- * Monadic construction + -- $monadic , tabulateM , tabulateFixM + , iterateM - -- * Manipulation - , mapWithKey - , traverseWithKey - , zipWithKey - , zipWithKeyM + -- * Subvectors + -- $subvectors + , mapSubvectors + , zipSubvectors ) where -import Prelude hiding ((^), (*), div, mod, fromIntegral, not, and, or) +import Prelude hiding ((^), (*), div, fromIntegral, not, and, or, cycle, iterate, drop) import Control.Applicative import Data.Bits -import Data.Foldable hiding (and, or) import Data.Function (fix) import Data.Functor.Identity import qualified Data.Vector as V -import Data.Word +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U import Data.Chimera.Compat import Data.Chimera.FromIntegral --- | Representation of a lazy infinite stream, offering --- indexing via 'index' in constant time. -newtype Chimera a = Chimera { _unChimera :: V.Vector (V.Vector a) } +-- $monadic +-- Be careful: the stream is infinite, so +-- monadic effects must be lazy +-- in order to be executed in a finite time. +-- +-- For instance, lazy state monad works fine: +-- +-- >>> import Control.Monad.State.Lazy +-- >>> ch = evalState (tabulateM (\i -> do modify (+ i); get)) 0 :: UChimera Word +-- >>> take 10 (toList ch) +-- [0,1,3,6,10,15,21,28,36,45] +-- +-- But the same computation in the strict state +-- monad "Control.Monad.State.Strict" diverges. + +-- $subvectors +-- Internally 'Chimera' consists of a number of subvectors. +-- Following functions provide a low-level access to them. +-- This ability is especially important for streams of booleans. +-- +-- Let us use 'Chimera' to memoize predicates @f1@, @f2@ @::@ 'Word' @->@ 'Bool'. +-- Imagine them both already +-- caught in amber as @ch1@, @ch2@ @::@ 'UChimera' 'Bool', +-- and now we want to memoize @f3 x = f1 x && f2 x@ as @ch3@. +-- One can do it in as follows: +-- +-- > ch3 = tabulate (\i -> index ch1 i && index ch2 i) +-- +-- There are two unsatisfactory things here. Firstly, +-- even unboxed vectors store only one boolean per byte. +-- We would rather reach out for 'Data.Bit.Bit' wrapper, +-- which provides an instance of unboxed vector +-- with one boolean per bit. Secondly, combining +-- existing predicates by indexing them and tabulating again +-- becomes relatively expensive, given how small and simple +-- our data is. Fortunately, there is an ultra-fast 'Data.Bit.zipBits' +-- to zip bit vectors. We can combine it altogether like this: +-- +-- > import Data.Bit +-- > import Data.Bits +-- > ch1 = tabulate (Bit . f1) +-- > ch2 = tabulate (Bit . f2) +-- > ch3 = zipSubvectors (zipBits (.&.)) ch1 ch2 + +-- | Lazy infinite streams with elements from @a@, +-- backed by a 'G.Vector' @v@ (boxed, unboxed, storable, etc.). +-- Use 'tabulate', 'tabulateFix', etc. to create a stream +-- and 'index' to access its arbitrary elements +-- in constant time. +newtype Chimera v a = Chimera { _unChimera :: V.Vector (v a) } deriving (Functor, Foldable, Traversable) --- | Similar to 'ZipList'. -instance Applicative Chimera where +-- | Streams backed by boxed vectors. +type VChimera = Chimera V.Vector + +-- | Streams backed by unboxed vectors. +type UChimera = Chimera U.Vector + +-- | 'pure' creates a constant stream. +instance Applicative (Chimera V.Vector) where pure = tabulate . const - (<*>) = zipWithKey (const ($)) + (<*>) = zipSubvectors (<*>) #if __GLASGOW_HASKELL__ > 801 - liftA2 = zipWithKey . const + liftA2 f = zipSubvectors (liftA2 f) #endif bits :: Int bits = fbs (0 :: Word) --- | Create a stream from the function. --- The function must be well-defined for any value of argument --- and should not return 'error' / 'undefined'. -tabulate :: (Word -> a) -> Chimera a -tabulate f = runIdentity $ tabulateM (return . f) +-- | Create a stream of values of a given function. +-- Once created it can be accessed via 'index' or 'toList'. +-- +-- >>> ch = tabulate (^ 2) :: UChimera Word +-- >>> index ch 9 +-- 81 +-- >>> take 10 (toList ch) +-- [0,1,4,9,16,25,36,49,64,81] +tabulate :: G.Vector v a => (Word -> a) -> Chimera v a +tabulate f = runIdentity $ tabulateM (pure . f) --- | Create a stream from the monadic function. -tabulateM :: forall m a. Monad m => (Word -> m a) -> m (Chimera a) +-- | Monadic version of 'tabulate'. +tabulateM + :: forall m v a. + (Monad m, G.Vector v a) + => (Word -> m a) + -> m (Chimera v a) tabulateM f = do z <- f 0 - zs <- V.generateM bits tabulateU - return $ Chimera $ V.singleton z `V.cons` zs + zs <- V.generateM bits tabulateSubVector + pure $ Chimera $ G.singleton z `V.cons` zs where - tabulateU :: Int -> m (V.Vector a) - tabulateU i = V.generateM ii (\j -> f (int2word (ii + j))) + tabulateSubVector :: Int -> m (v a) + tabulateSubVector i = G.generateM ii (\j -> f (int2word (ii + j))) where ii = 1 `shiftL` i -{-# SPECIALIZE tabulateM :: (Word -> Identity a) -> Identity (Chimera a) #-} --- | Create a stream from the unfixed function. -tabulateFix :: ((Word -> a) -> Word -> a) -> Chimera a -tabulateFix uf = runIdentity $ tabulateFixM ((return .) . uf . (runIdentity .)) +{-# SPECIALIZE tabulateM :: G.Vector v a => (Word -> Identity a) -> Identity (Chimera v a) #-} --- | Create a stream from the unfixed monadic function. -tabulateFixM :: forall m a. Monad m => ((Word -> m a) -> Word -> m a) -> m (Chimera a) -tabulateFixM uf = bs +-- | For a given @f@ create a stream of values of a recursive function 'fix' @f@. +-- Once created it can be accessed via 'index' or 'toList'. +-- +-- For example, imagine that we want to tabulate +-- : +-- +-- >>> catalan n = if n == 0 then 1 else sum [ catalan i * catalan (n - 1 - i) | i <- [0 .. n - 1] ] +-- +-- Can we find @catalanF@ such that @catalan@ = 'fix' @catalanF@? +-- Just replace all recursive calls to @catalan@ with @f@: +-- +-- >>> catalanF f n = if n == 0 then 1 else sum [ f i * f (n - 1 - i) | i <- [0 .. n - 1] ] +-- +-- Now we are ready to use 'tabulateFix': +-- +-- >>> ch = tabulateFix catalanF :: VChimera Integer +-- >>> index ch 9 +-- 4862 +-- >>> take 10 (toList ch) +-- [1,1,2,5,14,42,132,429,1430,4862] +tabulateFix :: G.Vector v a => ((Word -> a) -> Word -> a) -> Chimera v a +tabulateFix uf = runIdentity $ tabulateFixM ((pure .) . uf . (runIdentity .)) + +-- | Monadic version of 'tabulateFix'. +-- There are no particular guarantees about the order of recursive calls: +-- they may be executed more than once or executed in different order. +-- That said, monadic effects must be idempotent and commutative. +tabulateFixM + :: forall m v a. + (Monad m, G.Vector v a) + => ((Word -> m a) -> Word -> m a) + -> m (Chimera v a) +tabulateFixM f = result where - bs :: m (Chimera a) - bs = do - z <- fix uf 0 - zs <- V.generateM bits tabulateU - return $ Chimera $ V.singleton z `V.cons` zs + result :: m (Chimera v a) + result = do + z <- fix f 0 + zs <- V.generateM bits tabulateSubVector + pure $ Chimera $ G.singleton z `V.cons` zs - tabulateU :: Int -> m (V.Vector a) - tabulateU i = vs + tabulateSubVector :: Int -> m (v a) + tabulateSubVector i = subResult where - vs = V.generateM ii (\j -> uf f (int2word (ii + j))) + subResult = G.generateM ii (\j -> f fixF (int2word (ii + j))) + subResultBoxed = V.generateM ii (\j -> f fixF (int2word (ii + j))) ii = 1 `shiftL` i - f k = if k < int2word ii - then flip index k <$> bs - else flip V.unsafeIndex (word2int k - ii) <$> vs -{-# SPECIALIZE tabulateFixM :: ((Word -> Identity a) -> Word -> Identity a) -> Identity (Chimera a) #-} + fixF :: Word -> m a + fixF k + | k < int2word ii + = flip index k <$> result + | k < int2word ii `shiftL` 1 + = (`V.unsafeIndex` (word2int k - ii)) <$> subResultBoxed + | otherwise + = f fixF k --- | Convert a stream back to a function. -index :: Chimera a -> Word -> a -index (Chimera vus) 0 = V.unsafeHead (V.unsafeHead vus) -index (Chimera vus) i = V.unsafeIndex (vus `V.unsafeIndex` (sgm + 1)) (word2int $ i - 1 `shiftL` sgm) +{-# SPECIALIZE tabulateFixM :: G.Vector v a => ((Word -> Identity a) -> Word -> Identity a) -> Identity (Chimera v a) #-} + +-- | 'iterate' @f@ @x@ returns an infinite stream +-- of repeated applications of @f@ to @x@. +-- +-- >>> ch = iterate (+ 1) 0 :: UChimera Int +-- >>> take 10 (toList ch) +-- [0,1,2,3,4,5,6,7,8,9] +iterate :: G.Vector v a => (a -> a) -> a -> Chimera v a +iterate f = runIdentity . iterateM (pure . f) + +-- | Monadic version of 'iterate'. +iterateM :: forall m v a. (Monad m, G.Vector v a) => (a -> m a) -> a -> m (Chimera v a) +iterateM f seed = do + nextSeed <- f seed + let z = G.singleton seed + zs <- V.iterateNM bits go (G.singleton nextSeed) + pure $ Chimera $ z `V.cons` zs where + go :: v a -> m (v a) + go vec = do + nextSeed <- f (G.unsafeLast vec) + G.iterateNM (G.length vec `shiftL` 1) f nextSeed + +{-# SPECIALIZE iterateM :: G.Vector v a => (a -> Identity a) -> a -> Identity (Chimera v a) #-} + +-- | Index a stream in a constant time. +-- +-- >>> ch = tabulate (^ 2) :: UChimera Word +-- >>> index ch 9 +-- 81 +index :: G.Vector v a => Chimera v a -> Word -> a +index (Chimera vs) 0 = G.unsafeHead (V.unsafeHead vs) +index (Chimera vs) i = G.unsafeIndex (vs `V.unsafeIndex` (sgm + 1)) (word2int $ i - 1 `shiftL` sgm) + where sgm :: Int sgm = fbs i - 1 - word2int (clz i) --- | Map over all indices and respective elements in the stream. -mapWithKey :: (Word -> a -> b) -> Chimera a -> Chimera b -mapWithKey f = runIdentity . traverseWithKey ((return .) . f) +-- | Convert a stream to an infinite list. +-- +-- >>> ch = tabulate (^ 2) :: UChimera Word +-- >>> take 10 (toList ch) +-- [0,1,4,9,16,25,36,49,64,81] +toList :: G.Vector v a => Chimera v a -> [a] +toList (Chimera vs) = foldMap G.toList vs --- | Traverse over all indices and respective elements in the stream. -traverseWithKey :: forall m a b. Monad m => (Word -> a -> m b) -> Chimera a -> m (Chimera b) -traverseWithKey f (Chimera bs) = do - bs' <- V.imapM g bs - return $ Chimera bs' +-- | Return an infinite repetion of a given vector. +-- Throw an error on an empty vector. +-- +-- >>> ch = cycle (Data.Vector.fromList [4, 2]) :: VChimera Int +-- >>> take 10 (toList ch) +-- [4,2,4,2,4,2,4,2,4,2] +cycle :: G.Vector v a => v a -> Chimera v a +cycle vec = case l of + 0 -> error "Data.Chimera.cycle: empty list" + _ -> tabulate (G.unsafeIndex vec . word2int . (`rem` l)) where - g :: Int -> V.Vector a -> m (V.Vector b) - g 0 = V.imapM (f . int2word) - g logOffset = V.imapM (f . int2word . (+ offset)) - where - offset = 1 `shiftL` (logOffset - 1) -{-# SPECIALIZE traverseWithKey :: (Word -> a -> Identity a) -> Chimera a -> Identity (Chimera a) #-} + l = int2word $ G.length vec --- | Zip two streams with the function, which is provided with an index and respective elements of both streams. -zipWithKey :: (Word -> a -> b -> c) -> Chimera a -> Chimera b -> Chimera c -zipWithKey f = (runIdentity .) . zipWithKeyM (((return .) .) . f) +-- | Memoize a function: +-- repeating calls to 'memoize' @f@ @n@ +-- would compute @f@ @n@ only once +-- and cache the result in 'VChimera'. +-- This is just a shortcut for 'index' '.' 'tabulate'. +-- +-- prop> memoize f n = f n +memoize :: (Word -> a) -> (Word -> a) +memoize = index @V.Vector . tabulate --- | Zip two streams with the monadic function, which is provided with an index and respective elements of both streams. -zipWithKeyM :: forall m a b c. Monad m => (Word -> a -> b -> m c) -> Chimera a -> Chimera b -> m (Chimera c) -zipWithKeyM f (Chimera bs1) (Chimera bs2) = do - bs' <- V.izipWithM g bs1 bs2 - return $ Chimera bs' - where - g :: Int -> V.Vector a -> V.Vector b -> m (V.Vector c) - g 0 = V.izipWithM (f . int2word) - g logOffset = V.izipWithM (f . int2word . (+ offset)) - where - offset = 1 `shiftL` (logOffset - 1) -{-# SPECIALIZE zipWithKeyM :: (Word -> a -> a -> Identity a) -> Chimera a -> Chimera a -> Identity (Chimera a) #-} +-- | For a given @f@ memoize a recursive function 'fix' @f@, +-- caching results in 'VChimera'. +-- This is just a shortcut for 'index' '.' 'tabulateFix'. +-- +-- prop> memoizeFix f n = fix f n +-- +-- For example, imagine that we want to memoize +-- : +-- +-- >>> fibo n = if n < 2 then fromIntegral n else fibo (n - 1) + fibo (n - 2) +-- +-- Can we find @fiboF@ such that @fibo@ = 'fix' @fiboF@? +-- Just replace all recursive calls to @fibo@ with @f@: +-- +-- >>> fiboF f n = if n < 2 then fromIntegral n else f (n - 1) + f (n - 2) +-- +-- Now we are ready to use 'memoizeFix': +-- +-- >>> memoizeFix fiboF 10 +-- 55 +-- >>> memoizeFix fiboF 100 +-- 354224848179261915075 +memoizeFix :: ((Word -> a) -> Word -> a) -> (Word -> a) +memoizeFix = index @V.Vector . tabulateFix + +-- | Map subvectors of a stream, using a given length-preserving function. +mapSubvectors + :: (G.Vector u a, G.Vector v b) + => (u a -> v b) + -> Chimera u a + -> Chimera v b +mapSubvectors f (Chimera bs) = Chimera (V.map f bs) + +-- | Zip subvectors from two streams, using a given length-preserving function. +zipSubvectors + :: (G.Vector u a, G.Vector v b, G.Vector w c) + => (u a -> v b -> w c) + -> Chimera u a + -> Chimera v b + -> Chimera w c +zipSubvectors f (Chimera bs1) (Chimera bs2) = Chimera (V.zipWith f bs1 bs2) diff --git a/Data/Chimera/Bool.hs b/Data/Chimera/Bool.hs deleted file mode 100644 --- a/Data/Chimera/Bool.hs +++ /dev/null @@ -1,297 +0,0 @@ --- | --- Module: Data.Chimera.Bool --- Copyright: (c) 2017 Andrew Lelechenko --- Licence: MIT --- Maintainer: Andrew Lelechenko --- --- Semilazy, infinite, compact stream of 'Bool' with O(1) indexing. --- Most useful for memoization of predicates. --- --- __Example 1__ --- --- Consider following predicate: --- --- > isOdd :: Word -> Bool --- > isOdd 0 = False --- > isOdd n = not (isOdd (n - 1)) --- --- Its computation is expensive, so we'd like to memoize its values into --- 'Chimera' using 'tabulate' and access this stream via 'index' --- instead of recalculation of @isOdd@: --- --- > isOddBS :: Chimera --- > isOddBS = tabulate isOdd --- > --- > isOdd' :: Word -> Bool --- > isOdd' = index isOddBS --- --- We can do even better by replacing part of recursive calls to @isOdd@ --- by indexing memoized values. Write @isOddF@ --- such that @isOdd = 'fix' isOddF@: --- --- > isOddF :: (Word -> Bool) -> Word -> Bool --- > isOddF _ 0 = False --- > isOddF f n = not (f (n - 1)) --- --- and use 'tabulateFix': --- --- > isOddBS :: Chimera --- > isOddBS = tabulateFix isOddF --- > --- > isOdd' :: Word -> Bool --- > isOdd' = index isOddBS --- --- __Example 2__ --- --- Define a predicate, which checks whether its argument is --- a prime number by trial division. --- --- > isPrime :: Word -> Bool --- > isPrime n --- > | n < 2 = False --- > | n < 4 = True --- > | even n = False --- > | otherwise = and [ n `rem` d /= 0 | d <- [3, 5 .. ceiling (sqrt (fromIntegral n))], isPrime d] --- --- Convert it to unfixed form: --- --- > isPrimeF :: (Word -> Bool) -> Word -> Bool --- > isPrimeF f n --- > | n < 2 = False --- > | n < 4 = True --- > | even n = False --- > | otherwise = and [ n `rem` d /= 0 | d <- [3, 5 .. ceiling (sqrt (fromIntegral n))], f d] --- --- Create its memoized version for faster evaluation: --- --- > isPrimeBS :: Chimera --- > isPrimeBS = tabulateFix isPrimeF --- > --- > isPrime' :: Word -> Bool --- > isPrime' = index isPrimeBS - -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Data.Chimera.Bool - ( Chimera - , index - , trueIndices - , falseIndices - - -- * Construction - , tabulate - , tabulateFix - , tabulateM - , tabulateFixM - - -- * Manipulation - , mapWithKey - , traverseWithKey - , not - , zipWithKey - , zipWithKeyM - , and - , or - ) where - -import Prelude hiding ((^), (*), div, mod, fromIntegral, not, and, or) -import Data.Bits -import Data.Foldable hiding (and, or) -import Data.Function (fix) -import Data.Functor.Identity -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector as V -import Data.Word - -import Data.Chimera.Compat -import Data.Chimera.FromIntegral - --- | Compact representation of an infinite stream of 'Bool', offering --- indexing via 'index' in constant time. --- --- It spends one bit (1/8 byte) for one 'Bool' in store. --- Compare it to at least 24 bytes per element in @[Bool]@, --- approximately 2 bytes per element in 'IntSet' --- and 1 byte per element in unboxed @Vector Bool@. --- --- This representation is less lazy than 'Data.Chimera.Chimera': --- Querying n-th element triggers computation --- of first @max(64, 2 ^ ceiling (logBase 2 n))@ elements. -newtype Chimera = Chimera { _unChimera :: V.Vector (U.Vector Word) } - -bits :: Int -bits = fbs (0 :: Word) - -bitsLog :: Int -bitsLog = bits - 1 - word2int (clz (int2word bits)) - --- | Create a bit stream from the predicate. --- The predicate must be well-defined for any value of argument --- and should not return 'error' / 'undefined'. -tabulate :: (Word -> Bool) -> Chimera -tabulate f = runIdentity $ tabulateM (return . f) - --- | Create a bit stream from the monadic predicate. --- The predicate must be well-defined for any value of argument --- and should not return 'error' / 'undefined'. -tabulateM :: forall m. Monad m => (Word -> m Bool) -> m Chimera -tabulateM f = do - z <- tabulateW 0 - zs <- V.generateM (bits - bitsLog) tabulateU - return $ Chimera $ U.singleton z `V.cons` zs - where - tabulateU :: Int -> m (U.Vector Word) - tabulateU i = U.generateM ii (\j -> tabulateW (ii + j)) - where - ii = 1 `shiftL` i - - tabulateW :: Int -> m Word - tabulateW j = foldlM go 0 [0 .. bits - 1] - where - jj = j `shiftL` bitsLog - go acc k = do - b <- f (int2word $ jj + k) - return $ if b then acc `setBit` k else acc -{-# SPECIALIZE tabulateM :: (Word -> Identity Bool) -> Identity Chimera #-} - --- | Create a bit stream from the unfixed predicate. --- The predicate must be well-defined for any value of argument --- and should not return 'error' / 'undefined'. -tabulateFix :: ((Word -> Bool) -> Word -> Bool) -> Chimera -tabulateFix uf = runIdentity $ tabulateFixM ((return .) . uf . (runIdentity .)) - --- | Create a bit stream from the unfixed monadic predicate. --- The predicate must be well-defined for any value of argument --- and should not return 'error' / 'undefined'. -tabulateFixM :: forall m. Monad m => ((Word -> m Bool) -> Word -> m Bool) -> m Chimera -tabulateFixM uf = bs - where - bs :: m Chimera - bs = do - z <- tabulateW (fix uf) 0 - zs <- V.generateM (bits - bitsLog) tabulateU - return $ Chimera $ U.singleton z `V.cons` zs - - tabulateU :: Int -> m (U.Vector Word) - tabulateU i = U.generateM ii (\j -> tabulateW (uf f) (ii + j)) - where - ii = 1 `shiftL` i - iii = ii `shiftL` bitsLog - f k = do - bs' <- bs - if k < int2word iii then return (index bs' k) else uf f k - - tabulateW :: (Word -> m Bool) -> Int -> m Word - tabulateW f j = foldlM go 0 [0 .. bits - 1] - where - jj = j `shiftL` bitsLog - go acc k = do - b <- f (int2word $ jj + k) - return $ if b then acc `setBit` k else acc -{-# SPECIALIZE tabulateFixM :: ((Word -> Identity Bool) -> Word -> Identity Bool) -> Identity Chimera #-} - --- | Convert a bit stream back to predicate. --- Indexing itself works in O(1) time, but triggers evaluation and allocation --- of surrounding elements of the stream, if they were not computed before. -index :: Chimera -> Word -> Bool -index (Chimera vus) i = - if sgm < 0 then indexU (V.unsafeHead vus) (word2int i) - else indexU (vus `V.unsafeIndex` (sgm + 1)) (word2int $ i - int2word bits `shiftL` sgm) - where - sgm :: Int - sgm = fbs i - 1 - bitsLog - word2int (clz i) - - indexU :: U.Vector Word -> Int -> Bool - indexU vec j = testBit (vec `U.unsafeIndex` jHi) jLo - where - jHi = j `shiftR` bitsLog - jLo = j .&. (bits - 1) - --- | List indices of elements equal to 'True'. -trueIndices :: Chimera -> [Word] -trueIndices bs = someIndices True bs - --- | List indices of elements equal to 'False'. -falseIndices :: Chimera -> [Word] -falseIndices bs = someIndices False bs - -someIndices :: Bool -> Chimera -> [Word] -someIndices bool (Chimera b) = V.ifoldr goU [] b - where - goU :: Int -> U.Vector Word -> [Word] -> [Word] - goU i vec rest = U.ifoldr (\j -> goW (ii + j)) rest vec - where - ii = case i of - 0 -> 0 - _ -> 1 `shiftL` (i - 1) - - goW :: Int -> Word -> [Word] -> [Word] - goW j w rest - = map (\k -> int2word $ jj + k) - (filter (\bt -> testBit w bt == bool) [0 .. bits - 1]) - ++ rest - where - jj = j `shiftL` bitsLog -{-# INLINE someIndices #-} - --- | Element-wise 'not'. -not :: Chimera -> Chimera -not (Chimera vus) = Chimera $ V.map (U.map (maxBound -)) vus - --- | Map over all indices and respective elements in the stream. -mapWithKey :: (Word -> Bool -> Bool) -> Chimera -> Chimera -mapWithKey f = runIdentity . traverseWithKey ((return .) . f) - --- | Traverse over all indices and respective elements in the stream. -traverseWithKey :: forall m. Monad m => (Word -> Bool -> m Bool) -> Chimera -> m Chimera -traverseWithKey f (Chimera bs) = do - bs' <- V.imapM g bs - return $ Chimera bs' - where - g :: Int -> U.Vector Word -> m (U.Vector Word) - g 0 = U.imapM h - g logOffset = U.imapM (h . (`shiftL` bitsLog) . (+ offset)) - where - offset = 1 `shiftL` (logOffset - 1) - - h :: Int -> Word -> m Word - h offset w = foldlM go 0 [0 .. bits - 1] - where - go acc k = do - b <- f (int2word $ offset + k) (testBit w k) - return $ if b then acc `setBit` k else acc -{-# SPECIALIZE traverseWithKey :: (Word -> Bool -> Identity Bool) -> Chimera -> Identity Chimera #-} - --- | Element-wise 'and'. -and :: Chimera -> Chimera -> Chimera -and (Chimera vus) (Chimera wus) = Chimera $ V.zipWith (U.zipWith (.&.)) vus wus - --- | Element-wise 'or'. -or :: Chimera -> Chimera -> Chimera -or (Chimera vus) (Chimera wus) = Chimera $ V.zipWith (U.zipWith (.|.)) vus wus - --- | Zip two streams with the function, which is provided with an index and respective elements of both streams. -zipWithKey :: (Word -> Bool -> Bool -> Bool) -> Chimera -> Chimera -> Chimera -zipWithKey f = (runIdentity .) . zipWithKeyM (((return .) .) . f) - --- | Zip two streams with the monadic function, which is provided with an index and respective elements of both streams. -zipWithKeyM :: forall m. Monad m => (Word -> Bool -> Bool -> m Bool) -> Chimera -> Chimera -> m Chimera -zipWithKeyM f (Chimera bs1) (Chimera bs2) = do - bs' <- V.izipWithM g bs1 bs2 - return $ Chimera bs' - where - g :: Int -> U.Vector Word -> U.Vector Word -> m (U.Vector Word) - g 0 = U.izipWithM h - g logOffset = U.izipWithM (h . (`shiftL` bitsLog) . (+ offset)) - where - offset = 1 `shiftL` (logOffset - 1) - - h :: Int -> Word -> Word -> m Word - h offset w1 w2 = foldlM go 0 [0 .. bits - 1] - where - go acc k = do - b <- f (int2word $ offset + k) (testBit w1 k) (testBit w2 k) - return $ if b then acc `setBit` k else acc -{-# SPECIALIZE zipWithKeyM :: (Word -> Bool -> Bool -> Identity Bool) -> Chimera -> Chimera -> Identity Chimera #-} diff --git a/Data/Chimera/Compat.hs b/Data/Chimera/Compat.hs --- a/Data/Chimera/Compat.hs +++ b/Data/Chimera/Compat.hs @@ -17,7 +17,6 @@ import Data.Bits import GHC.Exts -import GHC.Prim import Unsafe.Coerce #if __GLASGOW_HASKELL__ > 709 diff --git a/Data/Chimera/ContinuousMapping.hs b/Data/Chimera/ContinuousMapping.hs --- a/Data/Chimera/ContinuousMapping.hs +++ b/Data/Chimera/ContinuousMapping.hs @@ -5,58 +5,89 @@ -- Maintainer: Andrew Lelechenko -- -- Helpers for continuous mappings, useful to memoize --- predicates on 'Int' (instead of 'Word' only), and --- predicates over two, three and more arguments. +-- functions on 'Int' (instead of 'Word' only) and +-- functions over two and three arguments. -- --- __ Example__ +-- __Example 1__ -- --- An infinite plain board of live and dead cells (common for cellular automatons, --- e. g., ) --- can be represented as a predicate @board@ :: 'Int' -> 'Int' -> 'Bool'. Assume that --- we want to convert it to memoized form. We cannot do it directly, because 'Data.Chimera.Bool.tabulate' --- accepts predicates from 'Word' to 'Bool' only. +-- Imagine writing a program to simulate +-- . +-- This is a cellular automaton, +-- which consists of an infinite one-dimensional line of cells, +-- each being either dead ('False') or alive ('True'). +-- If two neighbours of a cell are equal, +-- it becomes dead on the next step, otherwise alive. -- --- The first step is to define: +-- Usually cellular automata are modelled by a finite vector. +-- This is a bit suboptimal, because cellular automata +-- may grow in different directions over time, but with +-- a finite vector one has to define a bounding segment well beforehand. +-- Moreover, what if we are interested to explore +-- an evolution of an essentially infinite initial configuration? -- --- > board'' :: Int -> Int -> Bool --- > board'' x y = board' (intToWord x) (intToWord y) --- > --- > board' :: Word -> Word -> Bool --- > board' x y = board (wordToInt x) (wordToInt y) +-- It would be natural to encode an initial configuration +-- as a function 'Int' @->@ 'Bool', which takes a coordinate +-- and returns the status of the corresponding cell. Define +-- a function, which translates the automaton to the next step: -- --- This is better, but @board'@ is a predicate over two arguments, and we need it to be a predicate over one. --- Conversion to Z-curve and back does the trick: +-- > step :: (Int -> Bool) -> (Int -> Bool) +-- > step current = \n -> current (n - 1) /= current (n + 1) -- --- > board'' :: Int -> Int -> Bool --- > board'' x y = board1 $ toZCurve (intToWord x) (intToWord y) --- > --- > board' :: Word -> Bool --- > board' z = let (x, y) = fromZCurve z in --- > board (wordToInt x) (wordToInt y) +-- Unfortunately, iterating @step@ would be extremely slow +-- because of branching recursion. One +-- could suggest to introduce a caching layer: -- --- Now we are ready to insert memoizing layer: +-- > step :: (Int -> Bool) -> (Int -> Bool) +-- > step current = \n -> current' (n - 1) /= current' (n + 1) +-- > where +-- > current' = memoize (current . fromIntegral) . fromIntegral -- --- > board'' :: Int -> Int -> Bool --- > board'' x y = index board' $ toZCurve (intToWord x) (intToWord y) --- > --- > board' :: Chimera --- > board' = tabulate $ --- > \z -> let (x, y) = fromZCurve z in --- > board (wordToInt x) (wordToInt y) +-- Unfortunately, it would not work well, +-- because 'fromIntegral' @::@ 'Int' @->@ 'Word' +-- maps @-1@ to 'maxBound' and it would take ages to memoize +-- everything up to 'maxBound'. +-- But continuous mappings 'intToWord' and 'wordToInt' avoid this issue: +-- +-- > step :: (Int -> Bool) -> (Int -> Bool) +-- > step current = \n -> current' (n - 1) /= current' (n + 1) +-- > where +-- > current' = memoize (current . wordToInt) . intToWord +-- +-- __Example 2__ +-- +-- What about another famous cellular automaton: +-- ? +-- It is two-dimensional, so its state can be represented as +-- a function 'Int' @->@ 'Int' @->@ 'Bool'. Following the approach above, +-- we would like to memoize such functions. +-- Namely, cast the state to 'Word' @->@ 'Bool', ready for memoization: +-- +-- > cast :: (Int -> Int -> Bool) -> (Word -> Bool) +-- > cast f = \n -> let (x, y) = fromZCurve n in +-- > f (word2int x) (word2int y) +-- +-- and then back: +-- +-- > uncast :: (Word -> Bool) -> (Int -> Int -> Bool) +-- > uncast g = \x y -> g (toZCurve (int2word x) (int2word y)) +-- -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} +#include "MachDeps.h" + module Data.Chimera.ContinuousMapping ( intToWord , wordToInt +#if WORD_SIZE_IN_BITS == 64 , toZCurve , fromZCurve , toZCurve3 , fromZCurve3 +#endif ) where import Data.Bits -import Data.Word import Unsafe.Coerce word2int :: Word -> Int @@ -65,14 +96,16 @@ int2word :: Int -> Word int2word = unsafeCoerce --- | Total map, which satisfies inequality --- abs ('intToWord' x - 'intToWord' y) ≤ 2 abs(x - y). +-- | Total map, which satisfies -- --- Note that this is not the case for 'fromIntegral' :: 'Int' -> 'Word', +-- prop> abs (intToWord x - intToWord y) <= 2 * abs (x - y) +-- +-- Note that usual 'fromIntegral' @::@ 'Int' @->@ 'Word' does not +-- satisfy this inequality, -- because it has a discontinuity between −1 and 0. -- --- > > map intToWord [-5..5] --- > [9,7,5,3,1,0,2,4,6,8,10] +-- >>> map intToWord [-5..5] +-- [9,7,5,3,1,0,2,4,6,8,10] intToWord :: Int -> Word intToWord i | i >= 0 = int2word i `shiftL` 1 @@ -80,8 +113,8 @@ -- | Inverse for 'intToWord'. -- --- > > map wordToInt [0..10] --- > [0,-1,1,-2,2,-3,3,-4,4,-5,5] +-- >>> map wordToInt [0..10] +-- [0,-1,1,-2,2,-3,3,-4,4,-5,5] wordToInt :: Word -> Int wordToInt w | even w = word2int (w `shiftR` 1) @@ -92,16 +125,16 @@ -- -- Only lower halfs of bits of arguments are used (32 bits on 64-bit architecture). -- --- > > [ toZCurve x y | x <- [0..3], y <- [0..3] ] --- > [0,2,8,10,1,3,9,11,4,6,12,14,5,7,13,15] +-- >>> [ toZCurve x y | x <- [0..3], y <- [0..3] ] +-- [0,2,8,10,1,3,9,11,4,6,12,14,5,7,13,15] toZCurve :: Word -> Word -> Word toZCurve x y = part1by1 y `shiftL` 1 .|. part1by1 x -- | Inverse for 'toZCurve'. -- See . -- --- > > map fromZCurve [0..15] --- > [(0,0),(1,0),(0,1),(1,1),(2,0),(3,0),(2,1),(3,1),(0,2),(1,2),(0,3),(1,3),(2,2),(3,2),(2,3),(3,3)] +-- >>> map fromZCurve [0..15] +-- [(0,0),(1,0),(0,1),(1,1),(2,0),(3,0),(2,1),(3,1),(0,2),(1,2),(0,3),(1,3),(2,2),(3,2),(2,3),(3,3)] fromZCurve :: Word -> (Word, Word) fromZCurve z = (compact1by1 z, compact1by1 (z `shiftR` 1)) @@ -110,20 +143,20 @@ -- -- Only lower thirds of bits of arguments are used (21 bits on 64-bit architecture). -- --- > > [ toZCurve3 x y z | x <- [0..3], y <- [0..3], z <- [0..3] ] --- > [0,4,32,36,2,6,34,38,16,20,48,52,18,22,50,54,1,5,33,37,3,7,35,39,17,21,49,53,19,23,51,55, --- > 8,12,40,44,10,14,42,46,24,28,56,60,26,30,58,62,9,13,41,45,11,15,43,47,25,29,57,61,27,31,59,63] +-- >>> [ toZCurve3 x y z | x <- [0..3], y <- [0..3], z <- [0..3] ] +-- [0,4,32,36,2,6,34,38,16,20,48,52,18,22,50,54,1,5,33,37,3,7,35,39,17,21,49,53,19,23,51,55, +-- 8,12,40,44,10,14,42,46,24,28,56,60,26,30,58,62,9,13,41,45,11,15,43,47,25,29,57,61,27,31,59,63] toZCurve3 :: Word -> Word -> Word -> Word toZCurve3 x y z = part1by2 z `shiftL` 2 .|. part1by2 y `shiftL` 1 .|. part1by2 x -- | Inverse for 'toZCurve3'. -- See . -- --- > > map fromZCurve3 [0..63] --- > [(0,0,0),(1,0,0),(0,1,0),(1,1,0),(0,0,1),(1,0,1),(0,1,1),(1,1,1),(2,0,0),(3,0,0),(2,1,0),(3,1,0),(2,0,1),(3,0,1),(2,1,1),(3,1,1), --- > (0,2,0),(1,2,0),(0,3,0),(1,3,0),(0,2,1),(1,2,1),(0,3,1),(1,3,1),(2,2,0),(3,2,0),(2,3,0),(3,3,0),(2,2,1),(3,2,1),(2,3,1),(3,3,1), --- > (0,0,2),(1,0,2),(0,1,2),(1,1,2),(0,0,3),(1,0,3),(0,1,3),(1,1,3),(2,0,2),(3,0,2),(2,1,2),(3,1,2),(2,0,3),(3,0,3),(2,1,3),(3,1,3), --- > (0,2,2),(1,2,2),(0,3,2),(1,3,2),(0,2,3),(1,2,3),(0,3,3),(1,3,3),(2,2,2),(3,2,2),(2,3,2),(3,3,2),(2,2,3),(3,2,3),(2,3,3),(3,3,3)] +-- >>> map fromZCurve3 [0..63] +-- [(0,0,0),(1,0,0),(0,1,0),(1,1,0),(0,0,1),(1,0,1),(0,1,1),(1,1,1),(2,0,0),(3,0,0),(2,1,0),(3,1,0),(2,0,1),(3,0,1),(2,1,1),(3,1,1), +-- (0,2,0),(1,2,0),(0,3,0),(1,3,0),(0,2,1),(1,2,1),(0,3,1),(1,3,1),(2,2,0),(3,2,0),(2,3,0),(3,3,0),(2,2,1),(3,2,1),(2,3,1),(3,3,1), +-- (0,0,2),(1,0,2),(0,1,2),(1,1,2),(0,0,3),(1,0,3),(0,1,3),(1,1,3),(2,0,2),(3,0,2),(2,1,2),(3,1,2),(2,0,3),(3,0,3),(2,1,3),(3,1,3), +-- (0,2,2),(1,2,2),(0,3,2),(1,3,2),(0,2,3),(1,2,3),(0,3,3),(1,3,3),(2,2,2),(3,2,2),(2,3,2),(3,3,2),(2,2,3),(3,2,3),(2,3,3),(3,3,3)] fromZCurve3 :: Word -> (Word, Word, Word) fromZCurve3 z = (compact1by2 z, compact1by2 (z `shiftR` 1), compact1by2 (z `shiftR` 2)) diff --git a/Data/Chimera/Unboxed.hs b/Data/Chimera/Unboxed.hs deleted file mode 100644 --- a/Data/Chimera/Unboxed.hs +++ /dev/null @@ -1,138 +0,0 @@ --- | --- Module: Data.Chimera --- Copyright: (c) 2018 Andrew Lelechenko --- Licence: MIT --- Maintainer: Andrew Lelechenko --- --- Semilazy, infinite stream with O(1) indexing. - -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Data.Chimera.Unboxed - ( Chimera - , index - , toList - - -- * Construction - , tabulate - , tabulateFix - , tabulateM - , tabulateFixM - - -- * Manipulation - , mapWithKey - , traverseWithKey - , zipWithKey - , zipWithKeyM - ) where - -import Prelude hiding ((^), (*), div, mod, fromIntegral, not, and, or, iterate) -import Data.Bits -import Data.Foldable hiding (and, or, toList) -import Data.Function (fix) -import Data.Functor.Identity -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import Data.Word - -import Data.Chimera.Compat -import Data.Chimera.FromIntegral - --- | Representation of an infinite stream, offering --- indexing via 'index' in constant time. --- --- This representation is less lazy than 'Data.Chimera.Chimera': --- Querying n-th element triggers computation --- of first @2 ^ ceiling (logBase 2 n)@ elements. -newtype Chimera a = Chimera { _unChimera :: V.Vector (U.Vector a) } - -bits :: Int -bits = fbs (0 :: Word) - --- | Create a stream from the function. -tabulate :: U.Unbox a => (Word -> a) -> Chimera a -tabulate f = runIdentity $ tabulateM (return . f) - --- | Create a stream from the monadic function. -tabulateM :: forall m a. (Monad m, U.Unbox a) => (Word -> m a) -> m (Chimera a) -tabulateM f = do - z <- f 0 - zs <- V.generateM bits tabulateU - return $ Chimera $ U.singleton z `V.cons` zs - where - tabulateU :: Int -> m (U.Vector a) - tabulateU i = U.generateM ii (\j -> f (int2word (ii + j))) - where - ii = 1 `shiftL` i -{-# SPECIALIZE tabulateM :: U.Unbox a => (Word -> Identity a) -> Identity (Chimera a) #-} - --- | Create a stream from the unfixed function. -tabulateFix :: U.Unbox a => ((Word -> a) -> Word -> a) -> Chimera a -tabulateFix uf = runIdentity $ tabulateFixM ((return .) . uf . (runIdentity .)) - --- | Create a stream from the unfixed monadic function. -tabulateFixM :: forall m a. (Monad m, U.Unbox a) => ((Word -> m a) -> Word -> m a) -> m (Chimera a) -tabulateFixM uf = bs - where - bs :: m (Chimera a) - bs = do - z <- fix uf 0 - zs <- V.generateM bits tabulateU - return $ Chimera $ U.singleton z `V.cons` zs - - tabulateU :: Int -> m (U.Vector a) - tabulateU i = U.generateM ii (\j -> uf f (int2word (ii + j))) - where - ii = 1 `shiftL` i - f k = do - bs' <- bs - if k < int2word ii then return (index bs' k) else uf f k -{-# SPECIALIZE tabulateFixM :: U.Unbox a => ((Word -> Identity a) -> Word -> Identity a) -> Identity (Chimera a) #-} - --- | Convert a stream back to a function. -index :: U.Unbox a => Chimera a -> Word -> a -index (Chimera vus) 0 = U.unsafeHead (V.unsafeHead vus) -index (Chimera vus) i = U.unsafeIndex (vus `V.unsafeIndex` (sgm + 1)) (word2int $ i - 1 `shiftL` sgm) - where - sgm :: Int - sgm = fbs i - 1 - word2int (clz i) - --- | Convert a stream to a list. -toList :: U.Unbox a => Chimera a -> [a] -toList (Chimera vus) = foldMap U.toList vus - --- | Map over all indices and respective elements in the stream. -mapWithKey :: (U.Unbox a, U.Unbox b) => (Word -> a -> b) -> Chimera a -> Chimera b -mapWithKey f = runIdentity . traverseWithKey ((return .) . f) - --- | Traverse over all indices and respective elements in the stream. -traverseWithKey :: forall m a b. (Monad m, U.Unbox a, U.Unbox b) => (Word -> a -> m b) -> Chimera a -> m (Chimera b) -traverseWithKey f (Chimera bs) = do - bs' <- V.imapM g bs - return $ Chimera bs' - where - g :: Int -> U.Vector a -> m (U.Vector b) - g 0 = U.imapM (f . int2word) - g logOffset = U.imapM (f . int2word . (+ offset)) - where - offset = 1 `shiftL` (logOffset - 1) -{-# SPECIALIZE traverseWithKey :: U.Unbox a => (Word -> a -> Identity a) -> Chimera a -> Identity (Chimera a) #-} - --- | Zip two streams with the function, which is provided with an index and respective elements of both streams. -zipWithKey :: (U.Unbox a, U.Unbox b, U.Unbox c) => (Word -> a -> b -> c) -> Chimera a -> Chimera b -> Chimera c -zipWithKey f = (runIdentity .) . zipWithKeyM (((return .) .) . f) - --- | Zip two streams with the monadic function, which is provided with an index and respective elements of both streams. -zipWithKeyM :: forall m a b c. (Monad m, U.Unbox a, U.Unbox b, U.Unbox c) => (Word -> a -> b -> m c) -> Chimera a -> Chimera b -> m (Chimera c) -zipWithKeyM f (Chimera bs1) (Chimera bs2) = do - bs' <- V.izipWithM g bs1 bs2 - return $ Chimera bs' - where - g :: Int -> U.Vector a -> U.Vector b -> m (U.Vector c) - g 0 = U.izipWithM (f . int2word) - g logOffset = U.izipWithM (f . int2word . (+ offset)) - where - offset = 1 `shiftL` (logOffset - 1) -{-# SPECIALIZE zipWithKeyM :: U.Unbox a => (Word -> a -> a -> Identity a) -> Chimera a -> Chimera a -> Identity (Chimera a) #-} diff --git a/Data/Chimera/WheelMapping.hs b/Data/Chimera/WheelMapping.hs --- a/Data/Chimera/WheelMapping.hs +++ b/Data/Chimera/WheelMapping.hs @@ -5,65 +5,70 @@ -- Maintainer: Andrew Lelechenko -- -- Helpers for mapping to --- and back. Mostly useful in number theory. +-- and back. This has various applications in number theory. -- -- __Example__ -- --- Let 'isPrime' be an expensive predicate, which checks whether its --- argument is a prime number. We can improve performance of repetitive reevaluation by memoization: +-- Let @isPrime@ be an expensive predicate, +-- which checks whether its argument is a prime number. +-- We can memoize it as usual: -- --- > isPrimeBS :: Chimera --- > isPrimeBS = tabulate isPrime +-- > isPrimeCache1 :: UChimera Bool +-- > isPrimeCache1 = tabulate isPrime -- > --- > isPrime' :: Word -> Bool --- > isPrime' = index isPrimeBS +-- > isPrime1 :: Word -> Bool +-- > isPrime1 = index isPrimeCache1 -- --- However, it is well-known that the only even prime is 2. --- So we can save half of space by memoizing the predicate for odd +-- But one may argue that since the only even prime number is 2, +-- it is quite wasteful to cache @isPrime@ for even arguments. +-- So we can save half the space by memoizing it for odd -- numbers only: -- --- > isPrimeBS2 :: Chimera --- > isPrimeBS2 = tabulate (\n -> isPrime (2 * n + 1)) +-- > isPrimeCache2 :: UChimera Bool +-- > isPrimeCache2 = tabulate (isPrime . (\n -> 2 * n + 1)) -- > --- > isPrime2' :: Word -> Bool --- > isPrime2' n +-- > isPrime2 :: Word -> Bool +-- > isPrime2 n -- > | n == 2 = True -- > | even n = False --- > | otherwise = index isPrimeBS2 ((n - 1) `quot` 2) +-- > | otherwise = index isPrimeCache2 ((n - 1) `quot` 2) -- --- or, using 'fromWheel2' and 'toWheel2', +-- Here @\\n -> 2 * n + 1@ maps n to the (n+1)-th odd number, +-- and @\\n -> (n - 1) \`quot\` 2@ takes it back. These functions +-- are available below as 'fromWheel2' and 'toWheel2'. -- --- > isPrimeBS2 :: Chimera --- > isPrimeBS2 = tabulate (isPrime . fromWheel2) --- > --- > isPrime2' :: Word -> Bool --- > isPrime2' n --- > | n == 2 = True --- > | even n = False --- > | otherwise = index isPrimeBS2 (toWheel2 n) +-- Odd numbers are the simplest example of numbers, lacking +-- small prime factors (so called +-- ). +-- Removing numbers, having small prime factors, is sometimes +-- called . -- --- Well, we also know that all primes, except 2 and 3, are coprime to 6; and all primes, except 2, 3 and 5, are coprime 30. So we can save even more space by writing +-- One can go further and exclude not only even numbers, +-- but also integers, divisible by 3. +-- To do this we need a function which maps n to the (n+1)-th number coprime with 2 and 3 +-- (thus, with 6) and its inverse: namely, 'fromWheel6' and 'toWheel6'. Then write -- --- > isPrimeBS6 :: Chimera --- > isPrimeBS6 = tabulate (isPrime . fromWheel6) +-- > isPrimeCache6 :: UChimera Bool +-- > isPrimeCache6 = tabulate (isPrime . fromWheel6) -- > --- > isPrime6' :: Word -> Bool --- > isPrime6' n +-- > isPrime6 :: Word -> Bool +-- > isPrime6 n -- > | n `elem` [2, 3] = True -- > | n `gcd` 6 /= 1 = False --- > | otherwise = index isPrimeBS6 (toWheel6 n) +-- > | otherwise = index isPrimeCache6 (toWheel6 n) -- --- or +-- Thus, the wheel of 6 saves more space, improving memory locality. -- --- > isPrimeBS30 :: Chimera --- > isPrimeBS30 = tabulate (isPrime . fromWheel30) --- > --- > isPrime30' :: Word -> Bool --- > isPrime30' n --- > | n `elem` [2, 3, 5] = True --- > | n `gcd` 30 /= 1 = False --- > | otherwise = index isPrimeBS30 (toWheel30 n) +-- (If you need to reduce memory consumption even further, +-- consider using 'Data.Bit.Bit' wrapper, +-- which provides an instance of unboxed vector, +-- packing one boolean per bit instead of one boolean per byte for 'Bool') +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + module Data.Chimera.WheelMapping ( fromWheel2 , toWheel2 @@ -76,11 +81,11 @@ ) where import Data.Bits -import qualified Data.Vector.Unboxed as U -import Data.Word +import Data.Chimera.Compat +import GHC.Exts -word2int :: Word -> Int -word2int = fromIntegral +bits :: Int +bits = fbs (0 :: Word) -- | Left inverse for 'fromWheel2'. Monotonically non-decreasing function. -- @@ -94,8 +99,8 @@ -- -- prop> map fromWheel2 [0..] == [ n | n <- [0..], n `gcd` 2 == 1 ] -- --- > > map fromWheel2 [0..9] --- > [1,3,5,7,9,11,13,15,17,19] +-- >>> map fromWheel2 [0..9] +-- [1,3,5,7,9,11,13,15,17,19] fromWheel2 :: Word -> Word fromWheel2 i = i `shiftL` 1 + 1 {-# INLINE fromWheel2 #-} @@ -104,7 +109,13 @@ -- -- prop> toWheel6 . fromWheel6 == id toWheel6 :: Word -> Word -toWheel6 i = i `quot` 3 +toWheel6 i@(W# i#) = case bits of + 64 -> W# z1# `shiftR` 1 + _ -> i `quot` 3 + where + m# = 12297829382473034411## -- (2^65+1) / 3 + !(# z1#, _ #) = timesWord2# m# i# + {-# INLINE toWheel6 #-} -- | 'fromWheel6' n is the (n+1)-th positive number, not divisible by 2 or 3. @@ -112,8 +123,8 @@ -- -- prop> map fromWheel6 [0..] == [ n | n <- [0..], n `gcd` 6 == 1 ] -- --- > > map fromWheel6 [0..9] --- > [1,5,7,11,13,17,19,23,25,29] +-- >>> map fromWheel6 [0..9] +-- [1,5,7,11,13,17,19,23,25,29] fromWheel6 :: Word -> Word fromWheel6 i = i `shiftL` 1 + i + (i .&. 1) + 1 {-# INLINE fromWheel6 #-} @@ -122,9 +133,17 @@ -- -- prop> toWheel30 . fromWheel30 == id toWheel30 :: Word -> Word -toWheel30 i = q `shiftL` 3 + (r + r `shiftR` 4) `shiftR` 2 +toWheel30 i@(W# i#) = q `shiftL` 3 + (r + r `shiftR` 4) `shiftR` 2 where - (q, r) = i `quotRem` 30 + (q, r) = case bits of + 64 -> (q64, r64) + _ -> i `quotRem` 30 + + m# = 9838263505978427529## -- (2^67+7) / 15 + !(# z1#, _ #) = timesWord2# m# i# + q64 = W# z1# `shiftR` 4 + r64 = i - q64 `shiftL` 5 + q64 `shiftL` 1 + {-# INLINE toWheel30 #-} -- | 'fromWheel30' n is the (n+1)-th positive number, not divisible by 2, 3 or 5. @@ -132,8 +151,8 @@ -- -- prop> map fromWheel30 [0..] == [ n | n <- [0..], n `gcd` 30 == 1 ] -- --- > > map fromWheel30 [0..9] --- > [1,7,11,13,17,19,23,29,31,37] +-- >>> map fromWheel30 [0..9] +-- [1,7,11,13,17,19,23,29,31,37] fromWheel30 :: Word -> Word fromWheel30 i = ((i `shiftL` 2 - i `shiftR` 2) .|. 1) + ((i `shiftL` 1 - i `shiftR` 1) .&. 2) @@ -143,26 +162,44 @@ -- -- prop> toWheel210 . fromWheel210 == id toWheel210 :: Word -> Word -toWheel210 i = q * 48 + fromIntegral (toWheel210Table `U.unsafeIndex` word2int r) +toWheel210 i@(W# i#) = q `shiftL` 5 + q `shiftL` 4 + W# (indexWord8OffAddr# table# (word2Int# r#)) where - (q, r) = i `quotRem` 210 -{-# INLINE toWheel210 #-} + !(q, W# r#) = case bits of + 64 -> (q64, r64) + _ -> i `quotRem` 210 -toWheel210Table :: U.Vector Word8 -toWheel210Table = U.fromList [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 2, 2, 2, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 9, 9, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 13, 13, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 19, 19, 19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 23, 23, 23, 23, 24, 24, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 30, 30, 31, 31, 31, 31, 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, 34, 34, 34, 34, 35, 35, 35, 35, 35, 35, 36, 36, 36, 36, 37, 37, 38, 38, 38, 38, 39, 39, 39, 39, 39, 39, 40, 40, 41, 41, 41, 41, 41, 41, 42, 42, 42, 42, 43, 43, 44, 44, 44, 44, 45, 45, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 47] + m# = 5621864860559101445## -- (2^69+13) / 105 + !(# z1#, _ #) = timesWord2# m# i# + q64 = W# z1# `shiftR` 6 + r64 = i - q64 * 210 + table# :: Addr# + table# = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\STX\STX\STX\STX\ETX\ETX\EOT\EOT\EOT\EOT\ENQ\ENQ\ENQ\ENQ\ENQ\ENQ\ACK\ACK\a\a\a\a\a\a\b\b\b\b\t\t\n\n\n\n\v\v\v\v\v\v\f\f\f\f\f\f\r\r\SO\SO\SO\SO\SO\SO\SI\SI\SI\SI\DLE\DLE\DC1\DC1\DC1\DC1\DC1\DC1\DC2\DC2\DC2\DC2\DC3\DC3\DC3\DC3\DC3\DC3\DC4\DC4\DC4\DC4\DC4\DC4\DC4\DC4\NAK\NAK\NAK\NAK\SYN\SYN\ETB\ETB\ETB\ETB\CAN\CAN\EM\EM\EM\EM\SUB\SUB\SUB\SUB\SUB\SUB\SUB\SUB\ESC\ESC\ESC\ESC\ESC\ESC\FS\FS\FS\FS\GS\GS\GS\GS\GS\GS\RS\RS\US\US\US\US !!\"\"\"\"\"\"######$$$$%%&&&&''''''(())))))****++,,,,--........../"# + -- map Data.Char.chr [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 2, 2, 2, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 9, 9, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 13, 13, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 19, 19, 19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 23, 23, 23, 23, 24, 24, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 30, 30, 31, 31, 31, 31, 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, 34, 34, 34, 34, 35, 35, 35, 35, 35, 35, 36, 36, 36, 36, 37, 37, 38, 38, 38, 38, 39, 39, 39, 39, 39, 39, 40, 40, 41, 41, 41, 41, 41, 41, 42, 42, 42, 42, 43, 43, 44, 44, 44, 44, 45, 45, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 47] + +{-# INLINE toWheel210 #-} + -- | 'fromWheel210' n is the (n+1)-th positive number, not divisible by 2, 3, 5 or 7. -- Sequence . -- -- prop> map fromWheel210 [0..] == [ n | n <- [0..], n `gcd` 210 == 1 ] -- --- > > map fromWheel210 [0..9] --- > [1,11,13,17,19,23,29,31,37,41] +-- >>> map fromWheel210 [0..9] +-- [1,11,13,17,19,23,29,31,37,41] fromWheel210 :: Word -> Word -fromWheel210 i = q * 210 + fromIntegral (fromWheel210Table `U.unsafeIndex` word2int r) +fromWheel210 i@(W# i#) = q * 210 + W# (indexWord8OffAddr# table# (word2Int# r#)) where - (q, r) = i `quotRem` 48 -{-# INLINE fromWheel210 #-} + !(q, W# r#) = case bits of + 64 -> (q64, r64) + _ -> i `quotRem` 48 -fromWheel210Table :: U.Vector Word8 -fromWheel210Table = U.fromList [1, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 121, 127, 131, 137, 139, 143, 149, 151, 157, 163, 167, 169, 173, 179, 181, 187, 191, 193, 197, 199, 209] + m# = 12297829382473034411## -- (2^65+1) / 3 + !(# z1#, _ #) = timesWord2# m# i# + q64 = W# z1# `shiftR` 5 + r64 = i - q64 `shiftL` 5 - q64 `shiftL` 4 + + table# :: Addr# + table# = "\SOH\v\r\DC1\DC3\ETB\GS\US%)+/5;=CGIOSYaegkmqy\DEL\131\137\139\143\149\151\157\163\167\169\173\179\181\187\191\193\197\199\209"# + -- map Data.Char.chr [1, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 121, 127, 131, 137, 139, 143, 149, 151, 157, 163, 167, 169, 173, 179, 181, 187, 191, 193, 197, 199, 209] + +{-# INLINE fromWheel210 #-} diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,81 +1,97 @@ # chimera -Lazy, infinite streams with O(1) indexing. -Most useful to memoize functions. +Lazy infinite compact streams with cache-friendly O(1) indexing +and applications for memoization. +---- + +Imagine having a function `f :: Word -> a`, +which is expensive to evaluate. We would like to _memoize_ it, +returning `g :: Word -> a`, which does effectively the same, +but transparently caches results to speed up repetitive +re-evaluation. + +There are plenty of memoizing libraries on Hackage, but they +usually fall into two categories: + +* Store cache as a flat array, enabling us + to obtain cached values in O(1) time, which is nice. + The drawback is that one must specify the size + of the array beforehand, + limiting an interval of inputs, + and actually allocate it at once. + +* Store cache as a lazy binary tree. + Thanks to laziness, one can freely use the full range of inputs. + The drawback is that obtaining values from a tree + takes logarithmic time and is unfriendly to CPU cache, + which kinda defeats the purpose. + +This package intends to tackle both issues, +providing a data type `Chimera` for +lazy infinite compact streams with cache-friendly O(1) indexing. + +Additional features include: + +* memoization of recursive functions and recurrent sequences, +* memoization of functions of several, possibly signed arguments, +* efficient memoization of boolean predicates. + ## Example 1 -Consider following predicate: +Consider the following predicate: ```haskell isOdd :: Word -> Bool -isOdd 0 = False -isOdd n = not (isOdd (n - 1)) +isOdd n = if n == 0 then False else not (isOdd (n - 1)) ``` -Its computation is expensive, so we'd like to memoize its values into -`Chimera` using `tabulate` and access this stream via `index` -instead of recalculation of `isOdd`: +Its computation is expensive, so we'd like to memoize it: ```haskell -isOddBS :: Chimera -isOddBS = tabulate isOdd - isOdd' :: Word -> Bool -isOdd' = index isOddBS +isOdd' = memoize isOdd ``` -We can do even better by replacing part of recursive calls to `isOdd` -by indexing memoized values. Write `isOddF` -such that `isOdd = fix isOddF`: +This is fine to avoid re-evaluation for the same arguments. +But `isOdd` does not use this cache internally, going all the way +of recursive calls to `n = 0`. We can do better, +if we rewrite `isOdd` as a `fix` point of `isOddF`: ```haskell isOddF :: (Word -> Bool) -> Word -> Bool -isOddF _ 0 = False -isOddF f n = not (f (n - 1)) +isOddF f n = if n == 0 then False else not (f (n - 1)) ``` -and use `tabulateFix`: +and invoke `tabulateFix` to pass cache into recursive calls as well: ```haskell -isOddBS :: Chimera -isOddBS = tabulateFix isOddF - isOdd' :: Word -> Bool -isOdd' = index isOddBS +isOdd' = memoizeFix isOddF ``` ## Example 2 Define a predicate, which checks whether its argument is -a prime number by trial division. +a prime number, using trial division. ```haskell isPrime :: Word -> Bool -isPrime n - | n < 2 = False - | n < 4 = True - | even n = False - | otherwise = and [ n `rem` d /= 0 | d <- [3, 5 .. ceiling (sqrt (fromIntegral n))], isPrime d] +isPrime n = n > 1 && and [ n `rem` d /= 0 | d <- [2 .. floor (sqrt (fromIntegral n))], isPrime d] ``` -Convert it to unfixed form: +This is certainly an expensive recursive computation and we would like +to speed up its evaluation by wrappping into a caching layer. +Convert the predicate to an unfixed form such that `isPrime = fix isPrimeF`: ```haskell isPrimeF :: (Word -> Bool) -> Word -> Bool -isPrimeF f n - | n < 2 = False - | n < 4 = True - | even n = False - | otherwise = and [ n `rem` d /= 0 | d <- [3, 5 .. ceiling (sqrt (fromIntegral n))], f d] +isPrimeF f n = n > 1 && and [ n `rem` d /= 0 | d <- [2 .. floor (sqrt (fromIntegral n))], f d] ``` -Create its memoized version for faster evaluation: +Now create its memoized version for rapid evaluation: ```haskell -isPrimeBS :: Chimera -isPrimeBS = tabulateFix isPrimeF - isPrime' :: Word -> Bool -isPrime' = index isPrimeBS +isPrime' = memoizeFix isPrimeF ``` diff --git a/app/find-foo.hs b/app/find-foo.hs deleted file mode 100644 --- a/app/find-foo.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE UndecidableInstances #-} - -module Main where - -import Data.Bits -import Data.Chimera.WheelMapping - -data Expr r - = Var - | Const !Int - | ShiftL !Int r - | ShiftR !Int r - | Add r r - | Sub r r - | And r r - | Or r r - | Xor r r - deriving (Eq, Ord, Functor) - -instance Show r => Show (Expr r) where - showsPrec d = \case - Var -> showString "i" - Const n -> showString (show n) - ShiftL k r -> showParen (d > 8) $ showsPrec 9 r . showString " `shiftL` " . showsPrec 9 k - ShiftR k r -> showParen (d > 8) $ showsPrec 9 r . showString " `shiftR` " . showsPrec 9 k - Add r s -> showParen (d > 6) $ showsPrec 7 r . showString " + " . showsPrec 7 s - Sub r s -> showParen (d > 6) $ showsPrec 7 r . showString " - " . showsPrec 7 s - And r s -> showParen (d > 7) $ showsPrec 8 r . showString " .&. " . showsPrec 8 s - Or r s -> showParen (d > 5) $ showsPrec 6 r . showString " .|. " . showsPrec 6 s - Xor r s -> showParen (d > 6) $ showsPrec 7 r . showString " `xor` " . showsPrec 7 s - -newtype Fix t = Fix { unFix :: t (Fix t) } - -instance Eq (t (Fix t)) => Eq (Fix t) where - (Fix r) == (Fix s) = r == s - -instance Ord (t (Fix t)) => Ord (Fix t) where - compare (Fix r) (Fix s) = compare r s - -instance Show (t (Fix t)) => Show (Fix t) where - showsPrec d (Fix t) = showsPrec d t - -exprs :: [Fix Expr] -exprs = concat bucket - where - seed :: [Fix Expr] - seed = Fix Var : [Fix $ Const 1, Fix $ Const 2] - - bucket = map f [0..] - - maxShift = 2 - - unaries :: Fix Expr -> [Fix Expr] - unaries e = case unFix e of - ShiftL{} -> [] - ShiftR k _ -> [ Fix (ShiftL l e) | l <- [k .. maxShift] ] - _ -> concat [ [Fix (ShiftL l e), Fix (ShiftR l e)] | l <- [1 .. maxShift] ] - - f :: Int -> [Fix Expr] - f 0 = [] - f 1 = seed - f n = concatMap unaries bucket1 - ++ concatMap (\(x, y) -> [Fix $ Add x y, Fix $ Sub x y, Fix $ And x y, Fix $ Or x y]) - [(x, y) | i <- [0..n-1], i <= n-1-i, x <- bucket !! i, y <- bucket !! (n-1-i), x /= y] - where - bucket1 = bucket !! (n - 1) - -cata :: Functor t => (t r -> r) -> Fix t -> r -cata f (Fix t) = f (fmap (cata f) t) - -eval :: Int -> Fix Expr -> Int -eval v = cata (evalF v) - -evalF :: Int -> Expr Int -> Int -evalF v = \case - Var -> v - Const i -> i - ShiftL k r -> r `shiftL` k - ShiftR k r -> r `shiftR` k - Add r s -> r + s - Sub r s -> r - s - And r s -> r .&. s - Or r s -> r .|. s - Xor r s -> r `xor` s - -toWheel30' :: Int -> Int -toWheel30' = fromIntegral . toWheel30 . fromIntegral - -fromWheel30' :: Int -> Int -fromWheel30' = fromIntegral . fromWheel30 . fromIntegral - -toWheel210' :: Int -> Int -toWheel210' = fromIntegral . toWheel210 . fromIntegral - -fromWheel210' :: Int -> Int -fromWheel210' = fromIntegral . fromWheel210 . fromIntegral - -functional :: Int -> Fix Expr -> Maybe Int -functional bestKnown e = alg (1000, -1000) diffs - where - ys = [0..47] -- map (fromIntegral . fromWheel210) [0..47] - diffs = zipWith (-) (map (flip eval e) ys) $ map fromWheel210' [0..47] -- (map fromWheel30' ys) - - alg :: (Int, Int) -> [Int] -> Maybe Int - alg (currMin, currMax) [] = Just $ currMax - currMin - alg (currMin, currMax) (x : xs) = if currMax - currMin > bestKnown - then Nothing - else alg (newMin, newMax) xs - where - newMin = currMin `min` x - newMax = currMax `max` x - -findFunctional :: [(Fix Expr, Int)] -findFunctional = f 1000 exprs - where - f _ [] = [] - f acc (e : exs) = case mx of - Nothing -> f acc exs - Just x -> if x <= acc then (e, x) : f x exs else f acc exs - where - mx = functional acc e - -main :: IO () -main = mapM_ (putStrLn . show) findFunctional diff --git a/bench/Bench.hs b/bench/Bench.hs deleted file mode 100644 --- a/bench/Bench.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module Main where - -import Gauge.Main - -import Data.Chimera.WheelMapping -import Data.Word - -doBench :: String -> (Word -> Word) -> Benchmark -doBench name fn = bench name $ nf (sum . (map fn)) [0..46409] - -main = defaultMain - [ bgroup "toWheel . fromWheel" - [ doBench "2" $ toWheel2 . fromWheel2 - , doBench "6" $ toWheel6 . fromWheel6 - , doBench "30" $ toWheel30 . fromWheel30 - , doBench "210" $ toWheel210 . fromWheel210 - ] - , bgroup "toWheel" - [ doBench "2" $ toWheel2 - , doBench "6" $ toWheel6 - , doBench "30" $ toWheel30 - , doBench "210" $ toWheel210 - ] - , bgroup "fromWheel" - [ doBench "2" $ fromWheel2 - , doBench "6" $ fromWheel6 - , doBench "30" $ fromWheel30 - , doBench "210" $ fromWheel210 - ] - ] diff --git a/chimera.cabal b/chimera.cabal --- a/chimera.cabal +++ b/chimera.cabal @@ -1,16 +1,43 @@ name: chimera -version: 0.2.0.0 +version: 0.3.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE -copyright: 2017-2018 Bodigrim +copyright: 2017-2019 Bodigrim maintainer: andrew.lelechenko@gmail.com homepage: https://github.com/Bodigrim/chimera#readme -synopsis: Lazy, infinite streams with O(1) indexing. +category: Data +synopsis: Lazy infinite streams with O(1) indexing author: Bodigrim extra-source-files: README.md +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 +description: + There are plenty of memoizing libraries on Hackage, but they + usually fall into two categories: + . + * Store cache as a flat array, enabling us + to obtain cached values in O(1) time, which is nice. + The drawback is that one must specify the size + of the array beforehand, + limiting an interval of inputs, + and actually allocate it at once. + * Store cache as a lazy binary tree. + Thanks to laziness, one can freely use the full range of inputs. + The drawback is that obtaining values from a tree + takes logarithmic time and is unfriendly to CPU cache, + which kinda defeats the purpose. + . + This package intends to tackle both issues, + providing a data type 'Chimera' for + lazy infinite compact streams with cache-friendly O(1) indexing. + . + Additional features include: + . + * memoization of recursive functions and recurrent sequences, + * memoization of functions of several, possibly signed arguments, + * efficient memoization of boolean predicates. source-repository head type: git @@ -18,58 +45,30 @@ library build-depends: - base >=4.5 && <5, - ghc-prim, + base >=4.9 && <5, vector - if impl(ghc <7.10) - build-depends: - transformers -any exposed-modules: Data.Chimera - Data.Chimera.Bool Data.Chimera.ContinuousMapping - Data.Chimera.Unboxed Data.Chimera.WheelMapping other-modules: Data.Chimera.Compat Data.Chimera.FromIntegral default-language: Haskell2010 - ghc-options: -Wall -O2 + ghc-options: -Wall test-suite test build-depends: base >=4.5 && <5, - chimera -any, + chimera, QuickCheck >=2.10, - tasty -any, - tasty-hunit -any, - tasty-quickcheck -any, - tasty-smallcheck -any, - vector -any + tasty, + tasty-hunit, + tasty-quickcheck, + tasty-smallcheck, + vector type: exitcode-stdio-1.0 main-is: Test.hs default-language: Haskell2010 hs-source-dirs: test - ghc-options: -Wall -O2 - -benchmark bench - build-depends: - base >=4.5 && <5, - chimera -any, - gauge -any - type: exitcode-stdio-1.0 - main-is: Bench.hs - default-language: Haskell2010 - hs-source-dirs: bench - ghc-options: -O2 - -executable find-foo - buildable: False - build-depends: - base >=4.5 && <5, - chimera -any, - vector -any - main-is: find-foo.hs - default-language: Haskell2010 - hs-source-dirs: app - ghc-options: -Wall -O2 + ghc-options: -Wall diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main where @@ -12,61 +12,26 @@ import Data.Bits import Data.Function (fix) import Data.List +import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U -import Data.Word -import qualified Data.Chimera.Bool as BS import Data.Chimera.ContinuousMapping import Data.Chimera.WheelMapping import qualified Data.Chimera as Ch -import qualified Data.Chimera.Unboxed as ChU -instance Arbitrary BS.Chimera where - arbitrary = BS.tabulateM (const arbitrary) - -instance Arbitrary a => Arbitrary (Ch.Chimera a) where +instance (G.Vector v a, Arbitrary a) => Arbitrary (Ch.Chimera v a) where arbitrary = Ch.tabulateM (const arbitrary) -instance (Arbitrary a, U.Unbox a) => Arbitrary (ChU.Chimera a) where - arbitrary = ChU.tabulateM (const arbitrary) - main :: IO () main = defaultMain $ testGroup "All" - [ bitStreamTests + [ contMapTests + , wheelMapTests , chimeraTests - , chimeraUnboxedTests ] -bitStreamTests :: TestTree -bitStreamTests = testGroup "BitStream" - [ QC.testProperty "index . tabulate = id" $ - \(Fun _ f) ix -> - let jx = ix `mod` 65536 in - f jx === BS.index (BS.tabulate f) jx - , QC.testProperty "index . tabulateFix = fix" $ - \(Fun _ g) ix -> - let jx = ix `mod` 65536 in - let f = mkUnfix g in - fix f jx === BS.index (BS.tabulateFix f) jx - - , QC.testProperty "trueIndices" $ - \(Fun _ f) -> - take 100 (BS.trueIndices $ BS.tabulate f) === take 100 (filter f [0..]) - , QC.testProperty "falseIndices" $ - \(Fun _ f) -> - take 100 (BS.falseIndices $ BS.tabulate f) === take 100 (filter (Prelude.not . f) [0..]) - - , QC.testProperty "mapWithKey" $ - \(Blind bs) (Fun _ g) ix -> - let jx = ix `mod` 65536 in - g (jx, BS.index bs jx) === BS.index (BS.mapWithKey (curry g) bs) jx - - , QC.testProperty "zipWithKey" $ - \(Blind bs1) (Blind bs2) (Fun _ g) ix -> - let jx = ix `mod` 65536 in - g (jx, BS.index bs1 jx, BS.index bs2 jx) === BS.index (BS.zipWithKey (\i b1 b2 -> g (i, b1, b2)) bs1 bs2) jx - - , testGroup "wordToInt . intToWord" +contMapTests :: TestTree +contMapTests = testGroup "ContinuousMapping" + [ testGroup "wordToInt . intToWord" [ QC.testProperty "random" $ \i -> w2i_i2w i === i , H.testCase "maxBound" $ assertEqual "should be equal" maxBound (w2i_i2w maxBound) , H.testCase "minBound" $ assertEqual "should be equal" minBound (w2i_i2w minBound) @@ -90,8 +55,11 @@ , testGroup "from . to Z-curve 3D" [ QC.testProperty "random" $ \x y z -> fromZCurve3 (toZCurve3 x y z) === (x `rem` (1 `shiftL` 21), y `rem` (1 `shiftL` 21), z `rem` (1 `shiftL` 21)) ] + ] - , testGroup "toWheel . fromWheel" +wheelMapTests :: TestTree +wheelMapTests = testGroup "WheelMapping" + [ testGroup "toWheel . fromWheel" [ QC.testProperty "2" $ \(Shrink2 x) -> x < maxBound `div` 2 ==> toWheel2 (fromWheel2 x) === x , QC.testProperty "6" $ \(Shrink2 x) -> x < maxBound `div` 3 ==> toWheel6 (fromWheel6 x) === x , QC.testProperty "30" $ \(Shrink2 x) -> x < maxBound `div` 4 ==> toWheel30 (fromWheel30 x) === x @@ -104,45 +72,33 @@ [ QC.testProperty "index . tabulate = id" $ \(Fun _ (f :: Word -> Bool)) ix -> let jx = ix `mod` 65536 in - f jx === Ch.index (Ch.tabulate f) jx + f jx === Ch.index (Ch.tabulate f :: Ch.Chimera U.Vector Bool) jx , QC.testProperty "index . tabulateFix = fix" $ \(Fun _ g) ix -> let jx = ix `mod` 65536 in let f = mkUnfix g in - fix f jx === Ch.index (Ch.tabulateFix f) jx - - , QC.testProperty "mapWithKey" $ - \(Blind bs) (Fun _ (g :: (Word, Bool) -> Bool)) ix -> - let jx = ix `mod` 65536 in - g (jx, Ch.index bs jx) === Ch.index (Ch.mapWithKey (curry g) bs) jx + fix f jx === Ch.index (Ch.tabulateFix f :: Ch.Chimera U.Vector Bool) jx - , QC.testProperty "zipWithKey" $ - \(Blind bs1) (Blind bs2) (Fun _ (g :: (Word, Bool, Bool) -> Bool)) ix -> + , QC.testProperty "iterate" $ + \(Fun _ (f :: Word -> Word)) seed ix -> let jx = ix `mod` 65536 in - g (jx, Ch.index bs1 jx, Ch.index bs2 jx) === Ch.index (Ch.zipWithKey (\i b1 b2 -> g (i, b1, b2)) bs1 bs2) jx - ] + iterate f seed !! fromIntegral jx === Ch.index (Ch.iterate f seed :: Ch.Chimera U.Vector Word) jx -chimeraUnboxedTests :: TestTree -chimeraUnboxedTests = testGroup "Chimera Unboxed" - [ QC.testProperty "index . tabulate = id" $ - \(Fun _ (f :: Word -> Bool)) ix -> - let jx = ix `mod` 65536 in - f jx === ChU.index (ChU.tabulate f) jx - , QC.testProperty "index . tabulateFix = fix" $ - \(Fun _ g) ix -> + , QC.testProperty "cycle" $ + \xs ix -> not (null xs) ==> let jx = ix `mod` 65536 in - let f = mkUnfix g in - fix f jx === ChU.index (ChU.tabulateFix f) jx + let vs = U.fromList xs :: U.Vector Bool in + vs U.! (fromIntegral jx `mod` U.length vs) === Ch.index (Ch.cycle vs) jx , QC.testProperty "mapWithKey" $ - \(Blind bs) (Fun _ (g :: (Word, Bool) -> Bool)) ix -> + \(Blind bs) (Fun _ (g :: Word -> Word)) ix -> let jx = ix `mod` 65536 in - g (jx, ChU.index bs jx) === ChU.index (ChU.mapWithKey (curry g) bs) jx + g (Ch.index bs jx) === Ch.index (Ch.mapSubvectors (G.map g) bs :: Ch.Chimera U.Vector Word) jx , QC.testProperty "zipWithKey" $ - \(Blind bs1) (Blind bs2) (Fun _ (g :: (Word, Bool, Bool) -> Bool)) ix -> + \(Blind bs1) (Blind bs2) (Fun _ (g :: (Word, Word) -> Word)) ix -> let jx = ix `mod` 65536 in - g (jx, ChU.index bs1 jx, ChU.index bs2 jx) === ChU.index (ChU.zipWithKey (\i b1 b2 -> g (i, b1, b2)) bs1 bs2) jx + g (Ch.index bs1 jx, Ch.index bs2 jx) === Ch.index (Ch.zipSubvectors (G.zipWith (curry g)) bs1 bs2 :: Ch.Chimera U.Vector Word) jx ] -------------------------------------------------------------------------------