diff --git a/Data/Chimera.hs b/Data/Chimera.hs new file mode 100644 --- /dev/null +++ b/Data/Chimera.hs @@ -0,0 +1,146 @@ +-- | +-- Module: Data.Chimera +-- Copyright: (c) 2018 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- +-- Lazy, infinite stream with O(1) indexing. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Data.Chimera + ( Chimera + , index + + -- * Construction + , tabulate + , tabulateFix + , tabulateM + , tabulateFixM + + -- * Manipulation + , mapWithKey + , traverseWithKey + , zipWithKey + , zipWithKeyM + ) where + +import Prelude hiding ((^), (*), div, mod, fromIntegral, not, and, or) +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 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) } + deriving (Functor, Foldable, Traversable) + +-- | Similar to 'ZipList'. +instance Applicative Chimera where + pure = tabulate . const + (<*>) = zipWithKey (const ($)) +#if __GLASGOW_HASKELL__ > 801 + liftA2 = zipWithKey . const +#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 from the monadic function. +tabulateM :: forall m a. Monad m => (Word -> m a) -> m (Chimera a) +tabulateM f = do + z <- f 0 + zs <- V.generateM bits tabulateU + return $ Chimera $ V.singleton z `V.cons` zs + where + tabulateU :: Int -> m (V.Vector a) + tabulateU i = V.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 .)) + +-- | 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 + where + bs :: m (Chimera a) + bs = do + z <- fix uf 0 + zs <- V.generateM bits tabulateU + return $ Chimera $ V.singleton z `V.cons` zs + + tabulateU :: Int -> m (V.Vector a) + tabulateU i = vs + where + vs = V.generateM ii (\j -> uf f (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) #-} + +-- | 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) + 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) + +-- | 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' + 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) #-} + +-- | 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) + +-- | 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) #-} diff --git a/Data/Chimera/Bool.hs b/Data/Chimera/Bool.hs new file mode 100644 --- /dev/null +++ b/Data/Chimera/Bool.hs @@ -0,0 +1,297 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/Chimera/Compat.hs @@ -0,0 +1,57 @@ +-- | +-- Module: Data.Chimera.Compat +-- Copyright: (c) 2017 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK hide #-} + +module Data.Chimera.Compat + ( clz + , fbs + ) where + +import Data.Bits +import GHC.Exts +import GHC.Prim +import Unsafe.Coerce + +#if __GLASGOW_HASKELL__ > 709 + +clz :: Word -> Word +clz (W# w#) = W# (clz# w#) +{-# INLINE clz #-} + +#else + +int2word :: Int -> Word +int2word = unsafeCoerce + +clz :: Word -> Word +clz w = int2word $ case setBits of + [] -> sz + (s : _) -> sz - s - 1 + where + sz = fbs w + setBits = map fst $ filter snd $ map (\i -> (i, testBit w i)) [sz - 1, sz - 2 .. 0] +{-# INLINE clz #-} + +#endif + +#if __GLASGOW_HASKELL__ > 707 + +fbs :: Word -> Int +fbs = finiteBitSize +{-# INLINE fbs #-} + +#else + +fbs :: Word -> Int +fbs = bitSize +{-# INLINE fbs #-} + +#endif diff --git a/Data/Chimera/ContinuousMapping.hs b/Data/Chimera/ContinuousMapping.hs new file mode 100644 --- /dev/null +++ b/Data/Chimera/ContinuousMapping.hs @@ -0,0 +1,172 @@ +-- | +-- Module: Data.Chimera.ContinuousMapping +-- Copyright: (c) 2017 Andrew Lelechenko +-- Licence: MIT +-- 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. +-- +-- __ Example__ +-- +-- 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. +-- +-- The first step is to define: +-- +-- > board'' :: Int -> Int -> Bool +-- > board'' x y = board' (intToWord x) (intToWord y) +-- > +-- > board' :: Word -> Word -> Bool +-- > board' x y = board (wordToInt x) (wordToInt y) +-- +-- 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: +-- +-- > 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) +-- +-- Now we are ready to insert memoizing layer: +-- +-- > 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) + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Data.Chimera.ContinuousMapping + ( intToWord + , wordToInt + , toZCurve + , fromZCurve + , toZCurve3 + , fromZCurve3 + ) where + +import Data.Bits +import Data.Word +import Unsafe.Coerce + +word2int :: Word -> Int +word2int = unsafeCoerce + +int2word :: Int -> Word +int2word = unsafeCoerce + +-- | Total map, which satisfies inequality +-- abs ('intToWord' x - 'intToWord' y) ≤ 2 abs(x - y). +-- +-- Note that this is not the case for 'fromIntegral' :: 'Int' -> 'Word', +-- because it has a discontinuity between −1 and 0. +-- +-- > > 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 + | otherwise = int2word (-1 - i) `shiftL` 1 + 1 + +-- | Inverse for 'intToWord'. +-- +-- > > 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) + | otherwise = negate (word2int (w `shiftR` 1)) - 1 + +-- | Total map from plain to line, continuous almost everywhere. +-- See . +-- +-- 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 :: 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)] +fromZCurve :: Word -> (Word, Word) +fromZCurve z = (compact1by1 z, compact1by1 (z `shiftR` 1)) + +-- | Total map from space to line, continuous almost everywhere. +-- See . +-- +-- 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 :: 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)] +fromZCurve3 :: Word -> (Word, Word, Word) +fromZCurve3 z = (compact1by2 z, compact1by2 (z `shiftR` 1), compact1by2 (z `shiftR` 2)) + +-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ +part1by1 :: Word -> Word +part1by1 x = x5 + where + x0 = x .&. 0x00000000ffffffff + x1 = (x0 `xor` (x0 `shiftL` 16)) .&. 0x0000ffff0000ffff + x2 = (x1 `xor` (x1 `shiftL` 8)) .&. 0x00ff00ff00ff00ff + x3 = (x2 `xor` (x2 `shiftL` 4)) .&. 0x0f0f0f0f0f0f0f0f + x4 = (x3 `xor` (x3 `shiftL` 2)) .&. 0x3333333333333333 + x5 = (x4 `xor` (x4 `shiftL` 1)) .&. 0x5555555555555555 + +-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ +part1by2 :: Word -> Word +part1by2 x = x5 + where + x0 = x .&. 0x00000000ffffffff + x1 = (x0 `xor` (x0 `shiftL` 32)) .&. 0xffff00000000ffff + x2 = (x1 `xor` (x1 `shiftL` 16)) .&. 0x00ff0000ff0000ff + x3 = (x2 `xor` (x2 `shiftL` 8)) .&. 0xf00f00f00f00f00f + x4 = (x3 `xor` (x3 `shiftL` 4)) .&. 0x30c30c30c30c30c3 + x5 = (x4 `xor` (x4 `shiftL` 2)) .&. 0x1249249249249249 + +-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ +compact1by1 :: Word -> Word +compact1by1 x = x5 + where + x0 = x .&. 0x5555555555555555 + x1 = (x0 `xor` (x0 `shiftR` 1)) .&. 0x3333333333333333 + x2 = (x1 `xor` (x1 `shiftR` 2)) .&. 0x0f0f0f0f0f0f0f0f + x3 = (x2 `xor` (x2 `shiftR` 4)) .&. 0x00ff00ff00ff00ff + x4 = (x3 `xor` (x3 `shiftR` 8)) .&. 0x0000ffff0000ffff + x5 = (x4 `xor` (x4 `shiftR` 16)) .&. 0x00000000ffffffff + +-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ +compact1by2 :: Word -> Word +compact1by2 x = x5 + where + x0 = x .&. 0x1249249249249249 + x1 = (x0 `xor` (x0 `shiftR` 2)) .&. 0x30c30c30c30c30c3 + x2 = (x1 `xor` (x1 `shiftR` 4)) .&. 0xf00f00f00f00f00f + x3 = (x2 `xor` (x2 `shiftR` 8)) .&. 0x00ff0000ff0000ff + x4 = (x3 `xor` (x3 `shiftR` 16)) .&. 0xffff00000000ffff + x5 = (x4 `xor` (x4 `shiftR` 32)) .&. 0x00000000ffffffff diff --git a/Data/Chimera/FromIntegral.hs b/Data/Chimera/FromIntegral.hs new file mode 100644 --- /dev/null +++ b/Data/Chimera/FromIntegral.hs @@ -0,0 +1,21 @@ +-- | +-- Module: Data.Chimera.FromIntegral +-- Copyright: (c) 2018 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK hide #-} + +module Data.Chimera.FromIntegral + ( word2int + , int2word + ) where + +import Unsafe.Coerce + +word2int :: Word -> Int +word2int = unsafeCoerce + +int2word :: Int -> Word +int2word = unsafeCoerce diff --git a/Data/Chimera/Unboxed.hs b/Data/Chimera/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/Chimera/Unboxed.hs @@ -0,0 +1,138 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Data/Chimera/WheelMapping.hs @@ -0,0 +1,168 @@ +-- | +-- Module: Data.Chimera.WheelMapping +-- Copyright: (c) 2017 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko +-- +-- Helpers for mapping to +-- and back. Mostly useful 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: +-- +-- > isPrimeBS :: Chimera +-- > isPrimeBS = tabulate isPrime +-- > +-- > isPrime' :: Word -> Bool +-- > isPrime' = index isPrimeBS +-- +-- 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 +-- numbers only: +-- +-- > isPrimeBS2 :: Chimera +-- > isPrimeBS2 = tabulate (\n -> isPrime (2 * n + 1)) +-- > +-- > isPrime2' :: Word -> Bool +-- > isPrime2' n +-- > | n == 2 = True +-- > | even n = False +-- > | otherwise = index isPrimeBS2 ((n - 1) `quot` 2) +-- +-- or, using '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) +-- +-- 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 +-- +-- > isPrimeBS6 :: Chimera +-- > isPrimeBS6 = tabulate (isPrime . fromWheel6) +-- > +-- > isPrime6' :: Word -> Bool +-- > isPrime6' n +-- > | n `elem` [2, 3] = True +-- > | n `gcd` 6 /= 1 = False +-- > | otherwise = index isPrimeBS6 (toWheel6 n) +-- +-- or +-- +-- > 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) + +module Data.Chimera.WheelMapping + ( fromWheel2 + , toWheel2 + , fromWheel6 + , toWheel6 + , fromWheel30 + , toWheel30 + , fromWheel210 + , toWheel210 + ) where + +import Data.Bits +import qualified Data.Vector.Unboxed as U +import Data.Word + +word2int :: Word -> Int +word2int = fromIntegral + +-- | Left inverse for 'fromWheel2'. Monotonically non-decreasing function. +-- +-- prop> toWheel2 . fromWheel2 == id +toWheel2 :: Word -> Word +toWheel2 i = i `shiftR` 1 +{-# INLINE toWheel2 #-} + +-- | 'fromWheel2' n is the (n+1)-th positive odd number. +-- Sequence . +-- +-- 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] +fromWheel2 :: Word -> Word +fromWheel2 i = i `shiftL` 1 + 1 +{-# INLINE fromWheel2 #-} + +-- | Left inverse for 'fromWheel6'. Monotonically non-decreasing function. +-- +-- prop> toWheel6 . fromWheel6 == id +toWheel6 :: Word -> Word +toWheel6 i = i `quot` 3 +{-# INLINE toWheel6 #-} + +-- | 'fromWheel6' n is the (n+1)-th positive number, not divisible by 2 or 3. +-- Sequence . +-- +-- 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] +fromWheel6 :: Word -> Word +fromWheel6 i = i `shiftL` 1 + i + (i .&. 1) + 1 +{-# INLINE fromWheel6 #-} + +-- | Left inverse for 'fromWheel30'. Monotonically non-decreasing function. +-- +-- prop> toWheel30 . fromWheel30 == id +toWheel30 :: Word -> Word +toWheel30 i = q `shiftL` 3 + (r + r `shiftR` 4) `shiftR` 2 + where + (q, r) = i `quotRem` 30 +{-# INLINE toWheel30 #-} + +-- | 'fromWheel30' n is the (n+1)-th positive number, not divisible by 2, 3 or 5. +-- Sequence . +-- +-- 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] +fromWheel30 :: Word -> Word +fromWheel30 i = ((i `shiftL` 2 - i `shiftR` 2) .|. 1) + + ((i `shiftL` 1 - i `shiftR` 1) .&. 2) +{-# INLINE fromWheel30 #-} + +-- | Left inverse for 'fromWheel210'. Monotonically non-decreasing function. +-- +-- prop> toWheel210 . fromWheel210 == id +toWheel210 :: Word -> Word +toWheel210 i = q * 48 + fromIntegral (toWheel210Table `U.unsafeIndex` word2int r) + where + (q, r) = i `quotRem` 210 +{-# INLINE toWheel210 #-} + +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] + +-- | '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] +fromWheel210 :: Word -> Word +fromWheel210 i = q * 210 + fromIntegral (fromWheel210Table `U.unsafeIndex` word2int r) + where + (q, r) = i `quotRem` 48 +{-# INLINE fromWheel210 #-} + +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] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Bodigrim (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Bodigrim nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER OR CONTRIBUTORS 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,81 @@ +# chimera + +Lazy, infinite streams with O(1) indexing. +Most useful to memoize functions. + +## Example 1 + +Consider following predicate: + +```haskell +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`: + +```haskell +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`: + +```haskell +isOddF :: (Word -> Bool) -> Word -> Bool +isOddF _ 0 = False +isOddF f n = not (f (n - 1)) +``` + +and use `tabulateFix`: + +```haskell +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. + +```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] +``` + +Convert it to unfixed form: + +```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] +``` + +Create its memoized version for faster evaluation: + +```haskell +isPrimeBS :: Chimera +isPrimeBS = tabulateFix isPrimeF + +isPrime' :: Word -> Bool +isPrime' = index isPrimeBS +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/find-foo.hs b/app/find-foo.hs new file mode 100644 --- /dev/null +++ b/app/find-foo.hs @@ -0,0 +1,126 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,32 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/chimera.cabal @@ -0,0 +1,75 @@ +name: chimera +version: 0.2.0.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: 2017-2018 Bodigrim +maintainer: andrew.lelechenko@gmail.com +homepage: https://github.com/Bodigrim/chimera#readme +synopsis: Lazy, infinite streams with O(1) indexing. +author: Bodigrim +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/Bodigrim/chimera + +library + build-depends: + base >=4.5 && <5, + ghc-prim, + 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 + +test-suite test + build-depends: + base >=4.5 && <5, + chimera -any, + QuickCheck >=2.10, + tasty -any, + tasty-hunit -any, + tasty-quickcheck -any, + tasty-smallcheck -any, + vector -any + 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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} + +module Main where + +import Test.QuickCheck.Function +import Test.Tasty +import Test.Tasty.HUnit as H +import Test.Tasty.QuickCheck as QC + +import Data.Bits +import Data.Function (fix) +import Data.List +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 + 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 + , 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" + [ 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) + ] + , testGroup "intToWord . wordToInt" + [ QC.testProperty "random" $ \i -> i2w_w2i i === i + , H.testCase "maxBound" $ assertEqual "should be equal" maxBound (i2w_w2i maxBound) + , H.testCase "minBound" $ assertEqual "should be equal" minBound (i2w_w2i minBound) + ] + + , testGroup "to . from Z-curve 2D" + [ QC.testProperty "random" $ \z -> (\(x, y) -> toZCurve x y) (fromZCurve z) === z + ] + , testGroup "from . to Z-curve 2D" + [ QC.testProperty "random" $ \x y -> fromZCurve (toZCurve x y) === (x `rem` (1 `shiftL` 32), y `rem` (1 `shiftL` 32)) + ] + + , testGroup "to . from Z-curve 3D" + [ QC.testProperty "random" $ \t -> (\(x, y, z) -> toZCurve3 x y z) (fromZCurve3 t) === t `rem` (1 `shiftL` 63) + ] + , 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" + [ 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 + , QC.testProperty "210" $ \(Shrink2 x) -> x < maxBound `div` 5 ==> toWheel210 (fromWheel210 x) === x + ] + ] + +chimeraTests :: TestTree +chimeraTests = testGroup "Chimera" + [ QC.testProperty "index . tabulate = id" $ + \(Fun _ (f :: Word -> Bool)) ix -> + let jx = ix `mod` 65536 in + f jx === Ch.index (Ch.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 === 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 + + , QC.testProperty "zipWithKey" $ + \(Blind bs1) (Blind bs2) (Fun _ (g :: (Word, Bool, Bool) -> Bool)) 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 + ] + +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 -> + let jx = ix `mod` 65536 in + let f = mkUnfix g in + fix f jx === ChU.index (ChU.tabulateFix f) jx + + , QC.testProperty "mapWithKey" $ + \(Blind bs) (Fun _ (g :: (Word, Bool) -> Bool)) ix -> + let jx = ix `mod` 65536 in + g (jx, ChU.index bs jx) === ChU.index (ChU.mapWithKey (curry g) bs) jx + + , QC.testProperty "zipWithKey" $ + \(Blind bs1) (Blind bs2) (Fun _ (g :: (Word, Bool, Bool) -> Bool)) 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 + ] + +------------------------------------------------------------------------------- +-- Utils + +w2i_i2w :: Int -> Int +w2i_i2w = wordToInt . intToWord + +i2w_w2i :: Word -> Word +i2w_w2i = intToWord . wordToInt + +mkUnfix :: (Word -> [Word]) -> (Word -> Bool) -> Word -> Bool +mkUnfix splt f x + = foldl' (==) True + $ map f + $ takeWhile (\y -> 0 <= y && y < x) + $ splt x