bit-stream (empty) → 0.1.0.0
raw patch · 10 files changed
+1023/−0 lines, 10 filesdep +QuickCheckdep +basedep +bit-streamsetup-changed
Dependencies added: QuickCheck, base, bit-stream, criterion, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, vector
Files
- Data/BitStream.hs +265/−0
- Data/BitStream/ContinuousMapping.hs +171/−0
- Data/BitStream/WheelMapping.hs +168/−0
- LICENSE +30/−0
- README.md +81/−0
- Setup.hs +2/−0
- app/find-foo.hs +126/−0
- bench/Bench.hs +30/−0
- bit-stream.cabal +60/−0
- test/Test.hs +90/−0
+ Data/BitStream.hs view
@@ -0,0 +1,265 @@+-- |+-- Module: Data.BitStream+-- Copyright: (c) 2017 Andrew Lelechenko+-- Licence: MIT+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Lazy, 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+-- 'BitStream' using 'tabulate' and access this stream via 'index'+-- instead of recalculation of @isOdd@:+--+-- > isOddBS :: BitStream+-- > 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 :: BitStream+-- > 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 :: BitStream+-- > isPrimeBS = tabulateFix isPrimeF+-- >+-- > isPrime' :: Word -> Bool+-- > isPrime' = index isPrimeBS++{-# LANGUAGE ScopedTypeVariables #-}++module Data.BitStream+ ( BitStream+ , tabulate+ , tabulateFix+ , tabulateM+ , tabulateFixM+ , index++ , 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 Unsafe.Coerce++-- | Compact representation of infinite stream of 'Bool'.+--+-- 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@.+--+-- It also offers indexing in constant time.+-- Compare it to linear time for lists and logarithmic time for sets.+--+-- Moreover, it is lazy: querying n-th element triggers computation+-- of first @max(64, 2 ^ ceiling (logBase 2 n))@ elements only. On contrary,+-- sets and unboxed vectors are completely strict.+newtype BitStream = BitStream { _unBitStream :: V.Vector (U.Vector Word) }++word2int :: Word -> Int+word2int = unsafeCoerce++int2word :: Int -> Word+int2word = unsafeCoerce++bits :: Int+bits = finiteBitSize (0 :: Word)++bitsLog :: Int+bitsLog = bits - 1 - countLeadingZeros (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) -> BitStream+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 BitStream+tabulateM f = do+ z <- tabulateW 0+ zs <- V.generateM (bits - bitsLog) tabulateU+ return $ BitStream $ 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 zeroBits [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 BitStream #-}++-- | 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) -> BitStream+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 BitStream+tabulateFixM uf = bs+ where+ bs :: m BitStream+ bs = do+ z <- tabulateW (fix uf) 0+ zs <- V.generateM (bits - bitsLog) tabulateU+ return $ BitStream $ 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 zeroBits [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 BitStream #-}++-- | 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 :: BitStream -> Word -> Bool+index (BitStream 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 = finiteBitSize i - 1 - bitsLog - countLeadingZeros 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)++-- | Element-wise 'not'.+not :: BitStream -> BitStream+not (BitStream vus) = BitStream $ V.map (U.map (maxBound -)) vus++-- | Map over all indices and respective elements in the stream.+mapWithKey :: (Word -> Bool -> Bool) -> BitStream -> BitStream+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) -> BitStream -> m BitStream+traverseWithKey f (BitStream bs) = BitStream <$> V.imapM g 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 zeroBits [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) -> BitStream -> Identity BitStream #-}++-- | Element-wise 'and'.+and :: BitStream -> BitStream -> BitStream+and (BitStream vus) (BitStream wus) = BitStream $ V.zipWith (U.zipWith (.&.)) vus wus++-- | Element-wise 'or'.+or :: BitStream -> BitStream -> BitStream+or (BitStream vus) (BitStream wus) = BitStream $ 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) -> BitStream -> BitStream -> BitStream+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) -> BitStream -> BitStream -> m BitStream+zipWithKeyM f (BitStream bs1) (BitStream bs2) = BitStream <$> V.izipWithM g bs1 bs2+ 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 zeroBits [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) -> BitStream -> BitStream -> Identity BitStream #-}
+ Data/BitStream/ContinuousMapping.hs view
@@ -0,0 +1,171 @@+-- |+-- Module: Data.BitStream.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.BitStream.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' :: BitStream+-- > board' = tabulate $+-- > \z -> let (x, y) = fromZCurve z in+-- > board (wordToInt x) (wordToInt y)++{-# LANGUAGE BinaryLiterals #-}++module Data.BitStream.ContinuousMapping+ ( intToWord+ , wordToInt+ , toZCurve+ , fromZCurve+ , toZCurve3+ , fromZCurve3+ ) where++import Data.Bits+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 .&. 0b0000000000000000000000000000000011111111111111111111111111111111+ x1 = (x0 `xor` (x0 `shiftL` 16)) .&. 0b0000000000000000111111111111111100000000000000001111111111111111+ x2 = (x1 `xor` (x1 `shiftL` 8)) .&. 0b0000000011111111000000001111111100000000111111110000000011111111+ x3 = (x2 `xor` (x2 `shiftL` 4)) .&. 0b0000111100001111000011110000111100001111000011110000111100001111+ x4 = (x3 `xor` (x3 `shiftL` 2)) .&. 0b0011001100110011001100110011001100110011001100110011001100110011+ x5 = (x4 `xor` (x4 `shiftL` 1)) .&. 0b0101010101010101010101010101010101010101010101010101010101010101++-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/+part1by2 :: Word -> Word+part1by2 x = x5+ where+ x0 = x .&. 0b0000000000000000000000000000000011111111111111111111111111111111+ x1 = (x0 `xor` (x0 `shiftL` 32)) .&. 0b1111111111111111000000000000000000000000000000001111111111111111+ x2 = (x1 `xor` (x1 `shiftL` 16)) .&. 0b0000000011111111000000000000000011111111000000000000000011111111+ x3 = (x2 `xor` (x2 `shiftL` 8)) .&. 0b1111000000001111000000001111000000001111000000001111000000001111+ x4 = (x3 `xor` (x3 `shiftL` 4)) .&. 0b0011000011000011000011000011000011000011000011000011000011000011+ x5 = (x4 `xor` (x4 `shiftL` 2)) .&. 0b0001001001001001001001001001001001001001001001001001001001001001++-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/+compact1by1 :: Word -> Word+compact1by1 x = x5+ where+ x0 = x .&. 0b0101010101010101010101010101010101010101010101010101010101010101+ x1 = (x0 `xor` (x0 `shiftR` 1)) .&. 0b0011001100110011001100110011001100110011001100110011001100110011+ x2 = (x1 `xor` (x1 `shiftR` 2)) .&. 0b0000111100001111000011110000111100001111000011110000111100001111+ x3 = (x2 `xor` (x2 `shiftR` 4)) .&. 0b0000000011111111000000001111111100000000111111110000000011111111+ x4 = (x3 `xor` (x3 `shiftR` 8)) .&. 0b0000000000000000111111111111111100000000000000001111111111111111+ x5 = (x4 `xor` (x4 `shiftR` 16)) .&. 0b0000000000000000000000000000000011111111111111111111111111111111++-- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/+compact1by2 :: Word -> Word+compact1by2 x = x5+ where+ x0 = x .&. 0b0001001001001001001001001001001001001001001001001001001001001001+ x1 = (x0 `xor` (x0 `shiftR` 2)) .&. 0b0011000011000011000011000011000011000011000011000011000011000011+ x2 = (x1 `xor` (x1 `shiftR` 4)) .&. 0b1111000000001111000000001111000000001111000000001111000000001111+ x3 = (x2 `xor` (x2 `shiftR` 8)) .&. 0b0000000011111111000000000000000011111111000000000000000011111111+ x4 = (x3 `xor` (x3 `shiftR` 16)) .&. 0b1111111111111111000000000000000000000000000000001111111111111111+ x5 = (x4 `xor` (x4 `shiftR` 32)) .&. 0b0000000000000000000000000000000011111111111111111111111111111111
+ Data/BitStream/WheelMapping.hs view
@@ -0,0 +1,168 @@+-- |+-- Module: Data.BitStream.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 :: BitStream+-- > 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 :: BitStream+-- > 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 :: BitStream+-- > 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 :: BitStream+-- > 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 :: BitStream+-- > 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.BitStream.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 @@+# bit-stream++Lazy, infinite, compact stream of `Bool` with O(1) indexing.+Most useful for memoization of predicates.++## 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+`BitStream` using `tabulate` and access this stream via `index`+instead of recalculation of `isOdd`:++```haskell+isOddBS :: BitStream+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 :: BitStream+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 :: BitStream+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.BitStream.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,30 @@+module Main where++import Criterion.Main++import Data.BitStream.WheelMapping++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+ ]+ , doBench "toIdx" $ toIdx+ , bgroup "fromWheel"+ [ doBench "2" $ fromWheel2+ , doBench "6" $ fromWheel6+ , doBench "30" $ fromWheel30+ , doBench "210" $ fromWheel210+ ]+ ]
+ bit-stream.cabal view
@@ -0,0 +1,60 @@+name: bit-stream+version: 0.1.0.0+homepage: https://github.com/Bodigrim/bit-stream#readme+license: BSD3+license-file: LICENSE+author: Bodigrim+maintainer: andrew.lelechenko@gmail.com+copyright: 2017 Bodigrim+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10+synopsis: Lazy, infinite, compact stream of 'Bool' with O(1) indexing.++library+ exposed-modules: Data.BitStream+ Data.BitStream.ContinuousMapping+ Data.BitStream.WheelMapping+ build-depends: base >= 4.8 && < 5+ , vector+ default-language: Haskell2010+ ghc-options: -Wall -O2++source-repository head+ type: git+ location: https://github.com/Bodigrim/bit-stream++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ ghc-options: -Wall -O2+ main-is: Test.hs+ default-language: Haskell2010+ build-depends: base >= 4.8 && < 5+ , bit-stream+ , QuickCheck >= 2.10+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , tasty-smallcheck+ , vector++executable find-foo+ buildable: False+ main-is: find-foo.hs+ hs-source-dirs: app+ build-depends: base >= 4.8 && < 5+ , bit-stream+ , vector+ default-language: Haskell2010+ ghc-options: -Wall -O2++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: bench+ build-depends: base >= 4.8 && < 5+ , bit-stream+ , criterion+ default-language: Haskell2010+ ghc-options: -O2
+ test/Test.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++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 Data.BitStream as BS+import Data.BitStream.ContinuousMapping+import Data.BitStream.WheelMapping++instance Arbitrary BitStream where+ arbitrary = tabulateM (const arbitrary)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "All"+ [ QC.testProperty "index . tabulate = id" $+ \(Fun _ f) ix ->+ let jx = ix `mod` 65536 in+ f jx === index (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 === index (tabulateFix f) jx++ , QC.testProperty "mapWithKey" $+ \(Blind bs) (Fun _ g) ix ->+ let jx = ix `mod` 65536 in+ g (jx, index bs jx) === 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, index bs1 jx, index bs2 jx) === 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+ ]+ ]++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