summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBodigrim <>2017-08-05 20:56:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-08-05 20:56:00 (GMT)
commit4ce53820685d4388f4a1370b6080ee3f2cc7ca36 (patch)
tree12322abef5930e71fb24948ad9e2c9089af3425a
parentee978d3f2424b40f391b46b6a858ec86b672f227 (diff)
version 0.1.0.10.1.0.1
-rw-r--r--Data/BitStream.hs27
-rw-r--r--Data/BitStream/Compat.hs57
-rw-r--r--Data/BitStream/ContinuousMapping.hs51
-rw-r--r--bench/Bench.hs3
-rw-r--r--bit-stream.cabal16
-rw-r--r--test/Test.hs3
6 files changed, 116 insertions, 41 deletions
diff --git a/Data/BitStream.hs b/Data/BitStream.hs
index b92c34a..84a893c 100644
--- a/Data/BitStream.hs
+++ b/Data/BitStream.hs
@@ -72,6 +72,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
module Data.BitStream
( BitStream
, tabulate
@@ -97,8 +99,11 @@ 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 Unsafe.Coerce
+import Data.BitStream.Compat
+
-- | Compact representation of infinite stream of 'Bool'.
--
-- It spends one bit (1/8 byte) for one 'Bool' in store.
@@ -121,10 +126,10 @@ int2word :: Int -> Word
int2word = unsafeCoerce
bits :: Int
-bits = finiteBitSize (0 :: Word)
+bits = fbs (0 :: Word)
bitsLog :: Int
-bitsLog = bits - 1 - countLeadingZeros (int2word bits)
+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
@@ -147,7 +152,7 @@ tabulateM f = do
ii = 1 `shiftL` i
tabulateW :: Int -> m Word
- tabulateW j = foldlM go zeroBits [0 .. bits - 1]
+ tabulateW j = foldlM go 0 [0 .. bits - 1]
where
jj = j `shiftL` bitsLog
go acc k = do
@@ -183,7 +188,7 @@ tabulateFixM uf = 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]
+ tabulateW f j = foldlM go 0 [0 .. bits - 1]
where
jj = j `shiftL` bitsLog
go acc k = do
@@ -200,7 +205,7 @@ index (BitStream vus) i =
else indexU (vus `V.unsafeIndex` (sgm + 1)) (word2int $ i - int2word bits `shiftL` sgm)
where
sgm :: Int
- sgm = finiteBitSize i - 1 - bitsLog - countLeadingZeros i
+ sgm = fbs i - 1 - bitsLog - word2int (clz i)
indexU :: U.Vector Word -> Int -> Bool
indexU vec j = testBit (vec `U.unsafeIndex` jHi) jLo
@@ -218,7 +223,9 @@ 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
+traverseWithKey f (BitStream bs) = do
+ bs' <- V.imapM g bs
+ return $ BitStream bs'
where
g :: Int -> U.Vector Word -> m (U.Vector Word)
g 0 = U.imapM h
@@ -227,7 +234,7 @@ traverseWithKey f (BitStream bs) = BitStream <$> V.imapM g bs
offset = 1 `shiftL` (logOffset - 1)
h :: Int -> Word -> m Word
- h offset w = foldlM go zeroBits [0 .. bits - 1]
+ h offset w = foldlM go 0 [0 .. bits - 1]
where
go acc k = do
b <- f (int2word $ offset + k) (testBit w k)
@@ -248,7 +255,9 @@ 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
+zipWithKeyM f (BitStream bs1) (BitStream bs2) = do
+ bs' <- V.izipWithM g bs1 bs2
+ return $ BitStream bs'
where
g :: Int -> U.Vector Word -> U.Vector Word -> m (U.Vector Word)
g 0 = U.izipWithM h
@@ -257,7 +266,7 @@ zipWithKeyM f (BitStream bs1) (BitStream bs2) = BitStream <$> V.izipWithM g bs1
offset = 1 `shiftL` (logOffset - 1)
h :: Int -> Word -> Word -> m Word
- h offset w1 w2 = foldlM go zeroBits [0 .. bits - 1]
+ 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)
diff --git a/Data/BitStream/Compat.hs b/Data/BitStream/Compat.hs
new file mode 100644
index 0000000..b06549f
--- /dev/null
+++ b/Data/BitStream/Compat.hs
@@ -0,0 +1,57 @@
+-- |
+-- Module: Data.BitStream.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.BitStream.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/BitStream/ContinuousMapping.hs b/Data/BitStream/ContinuousMapping.hs
index f3ff4c6..dc23297 100644
--- a/Data/BitStream/ContinuousMapping.hs
+++ b/Data/BitStream/ContinuousMapping.hs
@@ -44,7 +44,7 @@
-- > \z -> let (x, y) = fromZCurve z in
-- > board (wordToInt x) (wordToInt y)
-{-# LANGUAGE BinaryLiterals #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Data.BitStream.ContinuousMapping
( intToWord
@@ -56,6 +56,7 @@ module Data.BitStream.ContinuousMapping
) where
import Data.Bits
+import Data.Word
import Unsafe.Coerce
word2int :: Word -> Int
@@ -130,42 +131,42 @@ fromZCurve3 z = (compact1by2 z, compact1by2 (z `shiftR` 1), compact1by2 (z `shif
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
+ 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 .&. 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
+ 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 .&. 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
+ 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 .&. 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
+ 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/bench/Bench.hs b/bench/Bench.hs
index c9a43aa..231102c 100644
--- a/bench/Bench.hs
+++ b/bench/Bench.hs
@@ -1,8 +1,11 @@
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
module Main where
import Criterion.Main
import Data.BitStream.WheelMapping
+import Data.Word
doBench :: String -> (Word -> Word) -> Benchmark
doBench name fn = bench name $ nf (sum . (map fn)) [0..46409]
diff --git a/bit-stream.cabal b/bit-stream.cabal
index e0d2b60..a5b11df 100644
--- a/bit-stream.cabal
+++ b/bit-stream.cabal
@@ -1,5 +1,5 @@
name: bit-stream
-version: 0.1.0.0
+version: 0.1.0.1
homepage: https://github.com/Bodigrim/bit-stream#readme
license: BSD3
license-file: LICENSE
@@ -9,14 +9,18 @@ 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.
+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
+ other-modules: Data.BitStream.Compat
+ build-depends: base >= 4.5 && < 5
+ , ghc-prim
, vector
+ if impl(ghc < 7.10)
+ build-depends: transformers
default-language: Haskell2010
ghc-options: -Wall -O2
@@ -30,7 +34,7 @@ test-suite test
ghc-options: -Wall -O2
main-is: Test.hs
default-language: Haskell2010
- build-depends: base >= 4.8 && < 5
+ build-depends: base >= 4.5 && < 5
, bit-stream
, QuickCheck >= 2.10
, tasty
@@ -43,7 +47,7 @@ executable find-foo
buildable: False
main-is: find-foo.hs
hs-source-dirs: app
- build-depends: base >= 4.8 && < 5
+ build-depends: base >= 4.5 && < 5
, bit-stream
, vector
default-language: Haskell2010
@@ -53,7 +57,7 @@ benchmark bench
type: exitcode-stdio-1.0
main-is: Bench.hs
hs-source-dirs: bench
- build-depends: base >= 4.8 && < 5
+ build-depends: base >= 4.5 && < 5
, bit-stream
, criterion
default-language: Haskell2010
diff --git a/test/Test.hs b/test/Test.hs
index bef612f..cea2d74 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}
module Main where
@@ -10,6 +10,7 @@ import Test.Tasty.QuickCheck as QC
import Data.Bits
import Data.Function (fix)
import Data.List
+import Data.Word
import Data.BitStream as BS
import Data.BitStream.ContinuousMapping