chimera (empty) → 0.2.0.0
raw patch · 14 files changed
+1507/−0 lines, 14 filesdep +QuickCheckdep +basedep +chimerasetup-changed
Dependencies added: QuickCheck, base, chimera, gauge, ghc-prim, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, transformers, vector
Files
- Data/Chimera.hs +146/−0
- Data/Chimera/Bool.hs +297/−0
- Data/Chimera/Compat.hs +57/−0
- Data/Chimera/ContinuousMapping.hs +172/−0
- Data/Chimera/FromIntegral.hs +21/−0
- Data/Chimera/Unboxed.hs +138/−0
- Data/Chimera/WheelMapping.hs +168/−0
- LICENSE +30/−0
- README.md +81/−0
- Setup.hs +2/−0
- app/find-foo.hs +126/−0
- bench/Bench.hs +32/−0
- chimera.cabal +75/−0
- test/Test.hs +162/−0
+ Data/Chimera.hs view
@@ -0,0 +1,146 @@+-- |+-- Module: Data.Chimera+-- Copyright: (c) 2018 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- 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) #-}
+ Data/Chimera/Bool.hs view
@@ -0,0 +1,297 @@+-- |+-- Module: Data.Chimera.Bool+-- Copyright: (c) 2017 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- 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 #-}
+ Data/Chimera/Compat.hs view
@@ -0,0 +1,57 @@+-- |+-- Module: Data.Chimera.Compat+-- Copyright: (c) 2017 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>++{-# 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
+ Data/Chimera/ContinuousMapping.hs view
@@ -0,0 +1,172 @@+-- |+-- Module: Data.Chimera.ContinuousMapping+-- Copyright: (c) 2017 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- 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., <https://en.wikipedia.org/wiki/Conway%27s_Game_of_Life Conway's Game of Life>)+-- 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 <https://en.wikipedia.org/wiki/Z-order_curve Z-order curve>.+--+-- 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 <https://en.wikipedia.org/wiki/Z-order_curve Z-order curve>.+--+-- > > 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 <https://en.wikipedia.org/wiki/Z-order_curve Z-order curve>.+--+-- 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 <https://en.wikipedia.org/wiki/Z-order_curve Z-order curve>.+--+-- > > 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
+ Data/Chimera/FromIntegral.hs view
@@ -0,0 +1,21 @@+-- |+-- Module: Data.Chimera.FromIntegral+-- Copyright: (c) 2018 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>++{-# 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
+ Data/Chimera/Unboxed.hs view
@@ -0,0 +1,138 @@+-- |+-- Module: Data.Chimera+-- Copyright: (c) 2018 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- 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) #-}
+ Data/Chimera/WheelMapping.hs view
@@ -0,0 +1,168 @@+-- |+-- Module: Data.Chimera.WheelMapping+-- Copyright: (c) 2017 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Helpers for mapping to <http://mathworld.wolfram.com/RoughNumber.html rough numbers>+-- 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 <https://oeis.org/A005408 A005408>.+--+-- 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 <https://oeis.org/A007310 A007310>.+--+-- 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 <https://oeis.org/A007775 A007775>.+--+-- 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 <https://oeis.org/A008364 A008364>.+--+-- 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]
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/find-foo.hs view
@@ -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
+ bench/Bench.hs view
@@ -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+ ]+ ]
+ chimera.cabal view
@@ -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
+ test/Test.hs view
@@ -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