bitvec 1.0.0.0 → 1.0.0.1
raw patch · 23 files changed
+1863/−1155 lines, 23 filesdep +containersdep +randomPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, random
API changes (from Hackage documentation)
Files
- README.md +118/−0
- bench/Bench.hs +17/−34
- bench/Bench/BitIndex.hs +47/−0
- bench/Bench/Intersection.hs +67/−0
- bench/Bench/Invert.hs +47/−0
- bench/Bench/RandomFlip.hs +88/−0
- bench/Bench/RandomRead.hs +77/−0
- bench/Bench/RandomWrite.hs +68/−0
- bench/Bench/Reverse.hs +47/−0
- bench/Bench/Union.hs +67/−0
- bitvec.cabal +34/−18
- changelog.md +4/−0
- src/Data/Bit.hs +30/−30
- src/Data/Bit/Immutable.hs +302/−73
- src/Data/Bit/Internal.hs +359/−421
- src/Data/Bit/Mutable.hs +110/−156
- src/Data/Bit/Select1.hs +2/−2
- src/Data/Bit/Utils.hs +68/−87
- test/Main.hs +8/−12
- test/Support.hs +52/−49
- test/Tests/MVector.hs +129/−115
- test/Tests/SetOps.hs +50/−70
- test/Tests/Vector.hs +72/−88
+ README.md view
@@ -0,0 +1,118 @@+# bitvec [](https://travis-ci.org/Bodigrim/bitvec) [](https://hackage.haskell.org/package/bitvec) [](https://matrix.hackage.haskell.org/package/bitvec) [](http://stackage.org/lts/package/bitvec) [](http://stackage.org/nightly/package/bitvec)++A newtype over `Bool` with a better `Vector` instance.++The [`vector`](https://hackage.haskell.org/package/vector)+package represents unboxed arrays of `Bool`+spending 1 byte (8 bits) per boolean.+This library provides a newtype wrapper `Bit` and a custom instance+of unboxed `Vector`, which packs bits densely,+achieving __8x less memory footprint.__+The performance stays mostly the same;+the most significant degradation happens for random writes+(up to 10% slower).+On the other hand, for certain bulk bit operations+`Vector Bit` is up to 64x faster than `Vector Bool`.++## Thread safety++* `Data.Bit` is faster, but writes and flips are thread-unsafe.+ This is because naive updates are not atomic:+ read the whole word from memory,+ then modify a bit, then write the whole word back.+* `Data.Bit.ThreadSafe` is slower (up to 20%),+ but writes and flips are thread-safe.++## Similar packages++* [`bv`](https://hackage.haskell.org/package/bv) and+ [`bv-little`](https://hackage.haskell.org/package/bv-little)+ do not offer mutable vectors.++* [`array`](https://hackage.haskell.org/package/array)+ is memory-efficient for `Bool`, but lacks+ a handy `Vector` interface and is not thread-safe.++## Quick start++Consider the following (very naive) implementation of+[the sieve of Eratosthenes](https://en.wikipedia.org/wiki/Sieve_of_Eratosthenes). It returns a vector with `True`+at prime indices and `False` at composite indices.++```haskell+import Control.Monad+import Control.Monad.ST+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++eratosthenes :: U.Vector Bool+eratosthenes = runST $ do+ let len = 100+ sieve <- MU.replicate len True+ MU.write sieve 0 False+ MU.write sieve 1 False+ forM_ [2 .. floor (sqrt (fromIntegral len))] $ \p -> do+ isPrime <- MU.read sieve p+ when isPrime $+ forM_ [2 * p, 3 * p .. len - 1] $ \i ->+ MU.write sieve i False+ U.unsafeFreeze sieve+```++We can switch from `Bool` to `Bit` just by adding newtype constructors:++```haskell+import Data.Bit++import Control.Monad+import Control.Monad.ST+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++eratosthenes :: U.Vector Bit+eratosthenes = runST $ do+ let len = 100+ sieve <- MU.replicate len (Bit True)+ MU.write sieve 0 (Bit False)+ MU.write sieve 1 (Bit False)+ forM_ [2 .. floor (sqrt (fromIntegral len))] $ \p -> do+ Bit isPrime <- MU.read sieve p+ when isPrime $+ forM_ [2 * p, 3 * p .. len - 1] $ \i ->+ MU.write sieve i (Bit False)+ U.unsafeFreeze sieve+```++`Bit`-based implementation requires 8x less memory to store+the vector. For large sizes it allows to crunch more data in RAM+without swapping. For smaller arrays it helps to fit into+CPU caches.++```haskell+> listBits eratosthenes+[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]+```++There are several high-level helpers, digesting bits in bulk,+which makes them up to 64x faster than respective counterparts+for `Vector Bool`. One can query population count (popcount)+of a vector (giving us [the prime-counting function](https://en.wikipedia.org/wiki/Prime-counting_function)):++```haskell+> countBits eratosthenes+25+```++And vice-versa, query an address of the _n_-th set bit+(which corresponds to the _n_-th prime number here):+```haskell+> nthBitIndex (Bit True) 10 eratosthenes+Just 29+```++One may notice that the order of the inner traversal by `i`+does not matter and get tempted to run it in several parallel threads.+In this case it is vital to switch from `Data.Bit` to `Data.Bit.ThreadSafe`,+because the former is thread-unsafe with regards to writes.+There is a moderate performance penalty (up to 20%)+for using the thread-safe interface.
bench/Bench.hs view
@@ -1,41 +1,24 @@ module Main where -import Control.Monad-import Control.Monad.ST-import Data.Bit-import qualified Data.Bit.ThreadSafe as TS-import Data.Bits-import qualified Data.Vector.Unboxed.Mutable as MU import Gauge.Main +import Bench.BitIndex+import Bench.Intersection+import Bench.Invert+import Bench.RandomFlip+import Bench.RandomRead+import Bench.RandomWrite+import Bench.Reverse+import Bench.Union+ main :: IO () main = defaultMain- [ bgroup "randomWrite" $ map benchRandomWrite [5..10]- , bgroup "randomWriteTS" $ map benchRandomWriteTS [5..10]+ [ bgroup "bitIndex" $ map benchBitIndex [5..10]+ , bgroup "invert" $ map benchInvert [5..10]+ , bgroup "intersection" $ map benchIntersection [5..10]+ , bgroup "randomWrite" $ map benchRandomWrite [5..10]+ , bgroup "randomFlip" $ map benchRandomFlip [5..10]+ , bgroup "randomRead" $ map benchRandomRead [5..10]+ , bgroup "reverse" $ map benchReverse [5..10]+ , bgroup "union" $ map benchUnion [5..10] ]--benchRandomWrite :: Int -> Benchmark-benchRandomWrite k = bench (show (2 ^ k)) $ nf doRandomWrite k--doRandomWrite :: Int -> Int-doRandomWrite k = runST $ do- let n = 2 ^ k- ixs = scanl xor 0 [0..n-1]- vals = take 100 $ cycle [Bit True, Bit False]- vec <- MU.new n- forM_ vals $ \v -> forM_ ixs $ \i -> MU.unsafeWrite vec i v- Bit i <- MU.unsafeRead vec 0- pure $ if i then 1 else 0--benchRandomWriteTS :: Int -> Benchmark-benchRandomWriteTS k = bench (show (2 ^ k)) $ nf doRandomWriteTS k--doRandomWriteTS :: Int -> Int-doRandomWriteTS k = runST $ do- let n = 2 ^ k- ixs = scanl xor 0 [0..n-1]- vals = take 100 $ cycle [TS.Bit True, TS.Bit False]- vec <- MU.new n- forM_ vals $ \v -> forM_ ixs $ \i -> MU.unsafeWrite vec i v- TS.Bit i <- MU.unsafeRead vec 0- pure $ if i then 1 else 0
+ bench/Bench/BitIndex.hs view
@@ -0,0 +1,47 @@+module Bench.BitIndex+ ( benchBitIndex+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec f k = U.generate n (\i -> f (i == n - 1))+ where+ n = 1 `shiftL` k++benchBitIndex :: Int -> Benchmark+benchBitIndex k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit/bitIndex" $ nf bitIndexBit (randomVec Bit k)+ , bench "Bit/nthBitIndex" $ nf nthBitIndexBit (randomVec Bit k)+ , bench "Bit/elemIndex" $ nf elemIndexBit (randomVec Bit k)+ , bench "Bit.TS/bitIndex" $ nf bitIndexBitTS (randomVec TS.Bit k)+ , bench "Bit.TS/nthBitIndex" $ nf nthBitIndexBitTS (randomVec TS.Bit k)+ , bench "Bit.TS/elemIndex" $ nf elemIndexBitTS (randomVec TS.Bit k)+ , bench "Vector" $ nf elemIndexVector (randomVec id k)+ ]++bitIndexBit :: U.Vector Bit -> Maybe Int+bitIndexBit = bitIndex (Bit True)++nthBitIndexBit :: U.Vector Bit -> Maybe Int+nthBitIndexBit = nthBitIndex (Bit True) 1++elemIndexBit :: U.Vector Bit -> Maybe Int+elemIndexBit = U.elemIndex (Bit True)++bitIndexBitTS :: U.Vector TS.Bit -> Maybe Int+bitIndexBitTS = TS.bitIndex (TS.Bit True)++nthBitIndexBitTS :: U.Vector TS.Bit -> Maybe Int+nthBitIndexBitTS = TS.nthBitIndex (TS.Bit True) 1++elemIndexBitTS :: U.Vector TS.Bit -> Maybe Int+elemIndexBitTS = U.elemIndex (TS.Bit True)++elemIndexVector :: U.Vector Bool -> Maybe Int+elemIndexVector = U.elemIndex True
+ bench/Bench/Intersection.hs view
@@ -0,0 +1,67 @@+module Bench.Intersection+ ( benchIntersection+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomBools :: [Bool]+randomBools+ = map (\i -> if i > (0 :: Int) then True else False)+ . randoms+ . mkStdGen+ $ 42++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec f k = U.fromList (map f (take n randomBools))+ where+ n = 1 `shiftL` k++randomVec2 :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec2 f k = U.fromList (map f (take n $ drop n randomBools))+ where+ n = 1 `shiftL` k++randomSet :: Int -> IS.IntSet+randomSet k = IS.fromAscList (map fst (filter snd (zip [0..] (take n randomBools))))+ where+ n = 1 `shiftL` k++randomSet2 :: Int -> IS.IntSet+randomSet2 k = IS.fromAscList (map fst (filter snd (zip [0..] (take n $ drop n randomBools))))+ where+ n = 1 `shiftL` k++benchIntersection :: Int -> Benchmark+benchIntersection k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit/zipBits" $ nf (intersectionBit (randomVec Bit k)) (randomVec2 Bit k)+ , bench "Bit/zipWith" $ nf (intersectionBit' (randomVec Bit k)) (randomVec2 Bit k)+ , bench "Bit.TS/zipBits" $ nf (intersectionBitTS (randomVec TS.Bit k)) (randomVec2 TS.Bit k)+ , bench "Bit.TS/zipWith" $ nf (intersectionBitTS' (randomVec TS.Bit k)) (randomVec2 TS.Bit k)+ , bench "Vector" $ nf (intersectionVector (randomVec id k)) (randomVec2 id k)+ , bench "IntSet" $ nf (intersectionIntSet (randomSet k)) (randomSet2 k)+ ]++intersectionBit :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+intersectionBit = zipBits (.&.)++intersectionBit' :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+intersectionBit' = U.zipWith (\(Bit x) (Bit y) -> Bit (x && y))++intersectionBitTS :: U.Vector TS.Bit -> U.Vector TS.Bit -> U.Vector TS.Bit+intersectionBitTS = TS.zipBits (.&.)++intersectionBitTS' :: U.Vector TS.Bit -> U.Vector TS.Bit -> U.Vector TS.Bit+intersectionBitTS' = U.zipWith (\(TS.Bit x) (TS.Bit y) -> TS.Bit (x && y))++intersectionVector :: U.Vector Bool -> U.Vector Bool -> U.Vector Bool+intersectionVector = U.zipWith (&&)++intersectionIntSet :: IS.IntSet -> IS.IntSet -> IS.IntSet+intersectionIntSet = IS.union
+ bench/Bench/Invert.hs view
@@ -0,0 +1,47 @@+module Bench.Invert+ ( benchInvert+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomBools :: [Bool]+randomBools+ = map (\i -> if i > (0 :: Int) then True else False)+ . randoms+ . mkStdGen+ $ 42++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec f k = U.fromList (map f (take n randomBools))+ where+ n = 1 `shiftL` k++benchInvert :: Int -> Benchmark+benchInvert k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit/invertInPlace" $ nf invertBit (randomVec Bit k)+ , bench "Bit/map-complement" $ nf invertBit' (randomVec Bit k)+ , bench "Bit.TS/invertInPlace" $ nf invertBitTS (randomVec TS.Bit k)+ , bench "Bit.TS/map-complement" $ nf invertBitTS' (randomVec TS.Bit k)+ , bench "Vector" $ nf invertVector (randomVec id k)+ ]++invertBit :: U.Vector Bit -> U.Vector Bit+invertBit = U.modify invertInPlace++invertBit' :: U.Vector Bit -> U.Vector Bit+invertBit' = U.map complement++invertBitTS :: U.Vector TS.Bit -> U.Vector TS.Bit+invertBitTS = U.modify TS.invertInPlace++invertBitTS' :: U.Vector TS.Bit -> U.Vector TS.Bit+invertBitTS' = U.map complement++invertVector :: U.Vector Bool -> U.Vector Bool+invertVector = U.map not
+ bench/Bench/RandomFlip.hs view
@@ -0,0 +1,88 @@+module Bench.RandomFlip+ ( benchRandomFlip+ ) where++import Control.Monad+import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.IntSet as IS+import Data.List+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomFlips :: [Int]+randomFlips+ = map abs+ . randoms+ . mkStdGen+ $ 42++benchRandomFlip :: Int -> Benchmark+benchRandomFlip k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit/flip" $ nf randomFlipBit k+ , bench "Bit/modify" $ nf randomFlipBit' k+ , bench "Bit.TS/flip" $ nf randomFlipBitTS k+ , bench "Bit.TS/modify" $ nf randomFlipBitTS' k+ , bench "Vector" $ nf randomFlipVector k+ , bench "IntSet" $ nf randomFlipIntSet k+ ]++randomFlipBit :: Int -> Int+randomFlipBit k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomFlips) $+ \i -> unsafeFlipBit vec (i .&. (1 `shiftL` k - 1))+ Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipBit' :: Int -> Int+randomFlipBit' k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomFlips) $+ \i -> MU.unsafeModify vec complement (i .&. (1 `shiftL` k - 1))+ Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipBitTS :: Int -> Int+randomFlipBitTS k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomFlips) $+ \i -> TS.unsafeFlipBit vec (i .&. (1 `shiftL` k - 1))+ TS.Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipBitTS' :: Int -> Int+randomFlipBitTS' k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomFlips) $+ \i -> MU.unsafeModify vec complement (i .&. (1 `shiftL` k - 1))+ TS.Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipVector :: Int -> Int+randomFlipVector k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomFlips) $+ \i -> MU.unsafeModify vec complement (i .&. (1 `shiftL` k - 1))+ i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipIntSet :: Int -> Int+randomFlipIntSet k = if IS.member 0 vec then 1 else 0+ where+ n = 1 `shiftL` k+ vec = foldl'+ (\acc i -> let j = i .&. (1 `shiftL` k - 1) in (if IS.member j acc then IS.delete else IS.insert) j acc)+ mempty+ (take (mult * n) randomFlips)++mult :: Int+mult = 100
+ bench/Bench/RandomRead.hs view
@@ -0,0 +1,77 @@+module Bench.RandomRead+ ( benchRandomRead+ ) where++import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+-- import qualified Data.IntSet as IS+-- import Data.List+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomVec :: [Bool]+randomVec+ = map (\i -> if i > (0 :: Int) then True else False)+ . randoms+ . mkStdGen+ $ 42++randomReads :: [Int]+randomReads+ = map abs+ . randoms+ . mkStdGen+ $ 42++benchRandomRead :: Int -> Benchmark+benchRandomRead k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit" $ nf randomReadBit k+ , bench "Bit.TS" $ nf randomReadBitTS k+ , bench "Vector" $ nf randomReadVector k+ -- , bench "IntSet" $ nf randomReadIntSet k+ ]++randomReadBit :: Int -> Int+randomReadBit k = runST $ do+ let n = 1 `shiftL` k+ vec <- U.unsafeThaw (U.fromList (map Bit $ take n randomVec))+ let go acc [] = pure acc+ go acc (i : is) = do+ Bit b <- MU.unsafeRead vec (i .&. (1 `shiftL` k - 1))+ go (acc + if b then 1 else 0) is+ go 0 (take (mult * n) randomReads)++randomReadBitTS :: Int -> Int+randomReadBitTS k = runST $ do+ let n = 1 `shiftL` k+ vec <- U.unsafeThaw (U.fromList (map TS.Bit $ take n randomVec))+ let go acc [] = pure acc+ go acc (i : is) = do+ TS.Bit b <- MU.unsafeRead vec (i .&. (1 `shiftL` k - 1))+ go (acc + if b then 1 else 0) is+ go 0 (take (mult * n) randomReads)++randomReadVector :: Int -> Int+randomReadVector k = runST $ do+ let n = 1 `shiftL` k+ vec <- U.unsafeThaw (U.fromList (take n randomVec))+ let go acc [] = pure acc+ go acc (i : is) = do+ b <- MU.unsafeRead vec (i .&. (1 `shiftL` k - 1))+ go (acc + if b then 1 else 0) is+ go 0 (take (mult * n) randomReads)++-- randomReadIntSet :: Int -> Int+-- randomReadIntSet k = foldl' (+) 0 [ doRead (c + i `shiftL` 1 - i - c) | c <- [0 .. mult - 1], i <- randomReads ]+-- where+-- n = 1 `shiftL` k+-- vec = IS.fromDistinctAscList $ map fst $ filter snd+-- $ zip [0..] $ take n randomVec+-- doRead i = if IS.member (i .&. (1 `shiftL` k - 1)) vec then 1 else 0++mult :: Int+mult = 100
+ bench/Bench/RandomWrite.hs view
@@ -0,0 +1,68 @@+module Bench.RandomWrite+ ( benchRandomWrite+ ) where++import Control.Monad+import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.IntSet as IS+import Data.List+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomWrites :: [(Int, Bool)]+randomWrites+ = map (\x -> if x > 0 then (x, True) else (negate x, False))+ . randoms+ . mkStdGen+ $ 42++benchRandomWrite :: Int -> Benchmark+benchRandomWrite k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit" $ nf randomWriteBit k+ , bench "Bit.TS" $ nf randomWriteBitTS k+ , bench "Vector" $ nf randomWriteVector k+ , bench "IntSet" $ nf randomWriteIntSet k+ ]++randomWriteBit :: Int -> Int+randomWriteBit k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomWrites) $+ \(i, b) -> MU.unsafeWrite vec (i .&. (1 `shiftL` k - 1)) (Bit b)+ Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomWriteBitTS :: Int -> Int+randomWriteBitTS k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomWrites) $+ \(i, b) -> MU.unsafeWrite vec (i .&. (1 `shiftL` k - 1)) (TS.Bit b)+ TS.Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomWriteVector :: Int -> Int+randomWriteVector k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomWrites) $+ \(i, b) -> MU.unsafeWrite vec (i .&. (1 `shiftL` k - 1)) b+ i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomWriteIntSet :: Int -> Int+randomWriteIntSet k = if IS.member 0 vec then 1 else 0+ where+ n = 1 `shiftL` k+ vec = foldl'+ (\acc (i, b) -> (if b then IS.insert else IS.delete) (i .&. (1 `shiftL` k - 1)) acc)+ mempty+ (take (mult * n) randomWrites)++mult :: Int+mult = 100
+ bench/Bench/Reverse.hs view
@@ -0,0 +1,47 @@+module Bench.Reverse+ ( benchReverse+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomBools :: [Bool]+randomBools+ = map (\i -> if i > (0 :: Int) then True else False)+ . randoms+ . mkStdGen+ $ 42++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec f k = U.fromList (map f (take n randomBools))+ where+ n = 1 `shiftL` k++benchReverse :: Int -> Benchmark+benchReverse k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit/reverseInPlace" $ nf reverseBit (randomVec Bit k)+ , bench "Bit/reverse" $ nf reverseBit' (randomVec Bit k)+ , bench "Bit.TS/reverseInPlace" $ nf reverseBitTS (randomVec TS.Bit k)+ , bench "Bit.TS/reverse" $ nf reverseBitTS' (randomVec TS.Bit k)+ , bench "Vector" $ nf reverseVector (randomVec id k)+ ]++reverseBit :: U.Vector Bit -> U.Vector Bit+reverseBit = U.modify reverseInPlace++reverseBit' :: U.Vector Bit -> U.Vector Bit+reverseBit' = U.reverse++reverseBitTS :: U.Vector TS.Bit -> U.Vector TS.Bit+reverseBitTS = U.modify TS.reverseInPlace++reverseBitTS' :: U.Vector TS.Bit -> U.Vector TS.Bit+reverseBitTS' = U.reverse++reverseVector :: U.Vector Bool -> U.Vector Bool+reverseVector = U.reverse
+ bench/Bench/Union.hs view
@@ -0,0 +1,67 @@+module Bench.Union+ ( benchUnion+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import System.Random++randomBools :: [Bool]+randomBools+ = map (\i -> if i > (0 :: Int) then True else False)+ . randoms+ . mkStdGen+ $ 42++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec f k = U.fromList (map f (take n randomBools))+ where+ n = 1 `shiftL` k++randomVec2 :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec2 f k = U.fromList (map f (take n $ drop n randomBools))+ where+ n = 1 `shiftL` k++randomSet :: Int -> IS.IntSet+randomSet k = IS.fromAscList (map fst (filter snd (zip [0..] (take n randomBools))))+ where+ n = 1 `shiftL` k++randomSet2 :: Int -> IS.IntSet+randomSet2 k = IS.fromAscList (map fst (filter snd (zip [0..] (take n $ drop n randomBools))))+ where+ n = 1 `shiftL` k++benchUnion :: Int -> Benchmark+benchUnion k = bgroup (show (1 `shiftL` k :: Int))+ [ bench "Bit/zipBits" $ nf (unionBit (randomVec Bit k)) (randomVec2 Bit k)+ , bench "Bit/zipWith" $ nf (unionBit' (randomVec Bit k)) (randomVec2 Bit k)+ , bench "Bit.TS/zipBits" $ nf (unionBitTS (randomVec TS.Bit k)) (randomVec2 TS.Bit k)+ , bench "Bit.TS/zipWith" $ nf (unionBitTS' (randomVec TS.Bit k)) (randomVec2 TS.Bit k)+ , bench "Vector" $ nf (unionVector (randomVec id k)) (randomVec2 id k)+ , bench "IntSet" $ nf (unionIntSet (randomSet k)) (randomSet2 k)+ ]++unionBit :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+unionBit = zipBits (.|.)++unionBit' :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+unionBit' = U.zipWith (\(Bit x) (Bit y) -> Bit (x || y))++unionBitTS :: U.Vector TS.Bit -> U.Vector TS.Bit -> U.Vector TS.Bit+unionBitTS = TS.zipBits (.|.)++unionBitTS' :: U.Vector TS.Bit -> U.Vector TS.Bit -> U.Vector TS.Bit+unionBitTS' = U.zipWith (\(TS.Bit x) (TS.Bit y) -> TS.Bit (x || y))++unionVector :: U.Vector Bool -> U.Vector Bool -> U.Vector Bool+unionVector = U.zipWith (||)++unionIntSet :: IS.IntSet -> IS.IntSet -> IS.IntSet+unionIntSet = IS.union
bitvec.cabal view
@@ -1,5 +1,5 @@ name: bitvec-version: 1.0.0.0+version: 1.0.0.1 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -7,31 +7,35 @@ copyright: 2019 Andrew Lelechenko, 2012-2016 James Cook maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> homepage: https://github.com/Bodigrim/bitvec-synopsis: Unboxed bit vectors+synopsis: Space-efficient bit vectors description:- Bit vectors library for Haskell.+ A newtype over 'Bool' with a better 'Vector' instance. .- The current [vector](https://hackage.haskell.org/package/vector)+ The [vector](https://hackage.haskell.org/package/vector) package represents unboxed arrays of 'Bool'- allocating one byte per boolean, which might be considered wasteful.- This library provides a newtype wrapper 'Data.Bit.Bit' and a custom instance- of unboxed 'Data.Vector.Unboxed.Vector', which packs booleans densely.- It is a time-memory tradeoff: 8x less memory footprint- at the price of moderate performance penalty- (mostly, for random writes).+ This library provides a newtype wrapper 'Bit' and a custom instance+ of unboxed 'Vector', which packs bits densely,+ achieving __8x less memory footprint.__+ The performance stays mostly the same;+ the most significant degradation happens for random writes+ (up to 10% slower).+ On the other hand, for certain bulk bit operations+ 'Vector Bit' is up to 64x faster than 'Vector Bool'. . === Thread safety- * "Data.Bit" is faster, but thread-unsafe. This is because- naive updates are not atomic operations: read the whole word from memory,- modify a bit, write the whole word back.- * "Data.Bit.ThreadSafe" is slower (up to 2x), but thread-safe. .+ * "Data.Bit" is faster, but writes and flips are thread-unsafe.+ This is because naive updates are not atomic:+ read the whole word from memory,+ then modify a bit, then write the whole word back.+ * "Data.Bit.ThreadSafe" is slower (up to 20%),+ but writes and flips are thread-safe.+ . === Similar packages .- * [bv](https://hackage.haskell.org/package/bv)- and [bv-little](https://hackage.haskell.org/package/bv-little)- offer only immutable size-polymorphic bit vectors.- @bitvec@ provides an interface to mutable vectors as well.+ * [bv](https://hackage.haskell.org/package/bv) and+ [bv-little](https://hackage.haskell.org/package/bv-little)+ do not offer mutable vectors. . * [array](https://hackage.haskell.org/package/array) is memory-efficient for 'Bool', but lacks@@ -44,6 +48,7 @@ tested-with: GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 extra-source-files: changelog.md+ README.md source-repository head type: git@@ -116,10 +121,21 @@ build-depends: base, bitvec,+ containers, gauge,+ random, vector type: exitcode-stdio-1.0 main-is: Bench.hs default-language: Haskell2010 hs-source-dirs: bench+ other-modules:+ Bench.BitIndex+ Bench.Invert+ Bench.Intersection+ Bench.RandomFlip+ Bench.RandomRead+ Bench.RandomWrite+ Bench.Reverse+ Bench.Union ghc-options: -O2 -Wall
changelog.md view
@@ -1,3 +1,7 @@+# 1.0.0.1++* Performance improvements.+ # 1.0.0.0 * Redesign API from the scratch.
src/Data/Bit.hs view
@@ -7,8 +7,8 @@ -- Licence: BSD3 -- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> ----- This module exposes a faster, but thread-unsafe implementation.--- Consider using "Data.Bit.ThreadSafe", which is thread-safe, but slower (up to 2x).+-- This module exposes an interface with thread-unsafe writes and flips.+-- Consider using "Data.Bit.ThreadSafe", which is thread-safe, but slower (up to 20%). module Data.Bit #else -- |@@ -17,41 +17,41 @@ -- Licence: BSD3 -- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> ----- This module exposes a slower (up to 2x), but thread-safe implementation.--- Consider using "Data.Bit", which is faster, but thread-unsafe.+-- This module exposes an interface with thread-safe writes and flips.+-- Consider using "Data.Bit", which is faster (up to 20%), but thread-unsafe. module Data.Bit.ThreadSafe #endif- ( Bit(..)+ ( Bit(..) - , unsafeFlipBit- , flipBit+ , unsafeFlipBit+ , flipBit - -- * Immutable conversions- , castFromWords- , castToWords- , cloneToWords+ -- * Immutable conversions+ , castFromWords+ , castToWords+ , cloneToWords - -- * Immutable operations- , zipBits- , bitIndex- , nthBitIndex- , countBits- , listBits- , selectBits- , excludeBits+ -- * Immutable operations+ , zipBits+ , bitIndex+ , nthBitIndex+ , countBits+ , listBits+ , selectBits+ , excludeBits - -- * Mutable conversions- , castFromWordsM- , castToWordsM- , cloneToWordsM+ -- * Mutable conversions+ , castFromWordsM+ , castToWordsM+ , cloneToWordsM - -- * Mutable operations- , invertInPlace- , zipInPlace- , selectBitsInPlace- , excludeBitsInPlace- , reverseInPlace- ) where+ -- * Mutable operations+ , invertInPlace+ , zipInPlace+ , selectBitsInPlace+ , excludeBitsInPlace+ , reverseInPlace+ ) where import Prelude hiding (and, or)
src/Data/Bit/Immutable.hs view
@@ -9,46 +9,46 @@ #else module Data.Bit.ImmutableTS #endif- ( castFromWords- , castToWords- , cloneToWords+ ( castFromWords+ , castToWords+ , cloneToWords - , zipBits+ , zipBits - , selectBits- , excludeBits- , bitIndex- ) where+ , selectBits+ , excludeBits+ , bitIndex -import Control.Monad-import Control.Monad.ST-import Data.Bits+ , nthBitIndex+ , countBits+ , listBits+ ) where++import Control.Monad.ST+import Data.Bits #ifndef BITVEC_THREADSAFE-import Data.Bit.Internal-import qualified Data.Bit.Mutable as B+import Data.Bit.Internal+import Data.Bit.Mutable #else-import Data.Bit.InternalTS-import qualified Data.Bit.MutableTS as B+import Data.Bit.InternalTS+import Data.Bit.MutableTS #endif-import Data.Bit.Utils-import qualified Data.Vector.Generic.Mutable as MV-import qualified Data.Vector.Generic as V-import Data.Vector.Unboxed as U- hiding (and, or, any, all, reverse, findIndex)-import qualified Data.Vector.Unboxed as Unsafe-import Data.Word-import Prelude as P- hiding (and, or, any, all, reverse)+import Data.Bit.Select1+import Data.Bit.Utils+import Data.Primitive.ByteArray+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Unsafe.Coerce -- | Cast a vector of words to a vector of bits. -- Cf. 'Data.Bit.castFromWordsM'. -- -- >>> castFromWords (Data.Vector.Unboxed.singleton 123) -- [1,1,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]-castFromWords- :: U.Vector Word- -> U.Vector Bit-castFromWords ws = BitVec 0 (nBits (V.length ws)) ws+castFromWords :: U.Vector Word -> U.Vector Bit+castFromWords ws = BitVec (mulWordSize off) (mulWordSize len) arr+ where P.Vector off len arr = unsafeCoerce ws -- | Try to cast a vector of bits to a vector of words. -- It succeeds if a vector of bits is aligned.@@ -56,15 +56,12 @@ -- Cf. 'Data.Bit.castToWordsM'. -- -- prop> castToWords (castFromWords v) == Just v-castToWords- :: U.Vector Bit- -> Maybe (U.Vector Word)+castToWords :: U.Vector Bit -> Maybe (U.Vector Word) castToWords (BitVec s n ws)- | aligned s- , aligned n- = Just $ V.slice (divWordSize s) (nWords n) ws- | otherwise- = Nothing+ | aligned s, aligned n = Just $ unsafeCoerce $ P.Vector (divWordSize s)+ (divWordSize n)+ ws+ | otherwise = Nothing -- | Clone a vector of bits to a new unboxed vector of words. -- If the bits don't completely fill the words, the last word will be zero-padded.@@ -72,22 +69,15 @@ -- -- >>> cloneToWords (read "[1,1,0,1,1,1,1,0]") -- [123]-cloneToWords- :: U.Vector Bit- -> U.Vector Word-cloneToWords v@(BitVec _ n _) = runST $ do- ws <- MV.new (nWords n)- let loop !i !j- | i >= n = return ()- | otherwise = do- MV.write ws j (indexWord v i)- loop (i + wordSize) (j + 1)- loop 0 0- V.unsafeFreeze ws+cloneToWords :: U.Vector Bit -> U.Vector Word+cloneToWords v = runST $ do+ v' <- U.unsafeThaw v+ w <- cloneToWordsM v'+ U.unsafeFreeze w {-# INLINE cloneToWords #-} -- | Zip two vectors with the given function.--- Similar to 'Data.Vector.Unboxed.zipWith', but much faster.+-- Similar to 'Data.Vector.Unboxed.zipWith', but up to 16x faster. -- -- >>> import Data.Bits -- >>> zipBits (.&.) (read "[1,1,0]") (read "[0,1,1]") -- intersection@@ -99,15 +89,14 @@ -- >>> zipBits xor (read "[1,1,0]") (read "[0,1,1]") -- symmetric difference -- [1,0,1] zipBits- :: (forall a. Bits a => a -> a -> a)- -> U.Vector Bit- -> U.Vector Bit- -> U.Vector Bit-zipBits f xs ys- | U.length xs >= U.length ys = zs- | otherwise = U.slice 0 (U.length xs) zs- where- zs = U.modify (B.zipInPlace f xs) ys+ :: (forall a . Bits a => a -> a -> a)+ -> U.Vector Bit+ -> U.Vector Bit+ -> U.Vector Bit+zipBits f xs ys | U.length xs >= U.length ys = zs+ | otherwise = U.slice 0 (U.length xs) zs+ where zs = U.modify (zipInPlace f xs) ys+{-# INLINE zipBits #-} -- | For each set bit of the first argument, deposit -- the corresponding bit of the second argument@@ -122,9 +111,9 @@ -- > selectBits mask ws == U.map snd (U.filter (unBit . fst) (U.zip mask ws)) selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit selectBits is xs = runST $ do- xs1 <- U.thaw xs- n <- B.selectBitsInPlace is xs1- Unsafe.unsafeFreeze (MV.take n xs1)+ xs1 <- U.thaw xs+ n <- selectBitsInPlace is xs1+ U.unsafeFreeze (MU.take n xs1) -- | For each unset bit of the first argument, deposit -- the corresponding bit of the second argument@@ -139,13 +128,21 @@ -- > excludeBits mask ws == U.map snd (U.filter (not . unBit . fst) (U.zip mask ws)) excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit excludeBits is xs = runST $ do- xs1 <- U.thaw xs- n <- B.excludeBitsInPlace is xs1- Unsafe.unsafeFreeze (MV.take n xs1)+ xs1 <- U.thaw xs+ n <- excludeBitsInPlace is xs1+ U.unsafeFreeze (MU.take n xs1) +clipLoBits :: Bit -> Int -> Word -> Word+clipLoBits (Bit True ) k w = w `unsafeShiftR` k+clipLoBits (Bit False) k w = (w `unsafeShiftR` k) .|. hiMask (wordSize - k)++clipHiBits :: Bit -> Int -> Word -> Word+clipHiBits (Bit True ) k w = w .&. loMask k+clipHiBits (Bit False) k w = w .|. hiMask k+ -- | Return the index of the first bit in the vector -- with the specified value, if any.--- Similar to 'Data.Vector.Unboxed.elemIndex', but much faster.+-- Similar to 'Data.Vector.Unboxed.elemIndex', but up to 64x faster. -- -- >>> bitIndex (Bit True) (read "[0,0,1,0,1]") -- Just 2@@ -160,12 +157,244 @@ -- >>> isAnyBitSet = isJust . bitIndex (Bit True) -- >>> areAllBitsSet = isNothing . bitIndex (Bit False) bitIndex :: Bit -> U.Vector Bit -> Maybe Int-bitIndex b xs = mfilter (< n) (loop 0)- where- !n = V.length xs- !ff | unBit b = ffs- | otherwise = ffs . complement+bitIndex b (BitVec off len arr)+ | len == 0 = Nothing+ | offBits == 0 = case modWordSize len of+ 0 -> bitIndexInWords b offWords lWords arr+ nMod -> case bitIndexInWords b offWords (lWords - 1) arr of+ r@Just{} -> r+ Nothing -> (+ mulWordSize (lWords - 1)) <$> bitIndexInWord+ b+ (clipHiBits b nMod (indexByteArray arr (offWords + lWords - 1)))+ | otherwise = case modWordSize (off + len) of+ 0 ->+ case+ bitIndexInWord b (clipLoBits b offBits (indexByteArray arr offWords))+ of+ r@Just{} -> r+ Nothing ->+ (+ (wordSize - offBits))+ <$> bitIndexInWords b (offWords + 1) (lWords - 1) arr+ nMod -> case lWords of+ 1 -> bitIndexInWord+ b+ (clipHiBits b len (clipLoBits b offBits (indexByteArray arr offWords)))+ _ ->+ case+ bitIndexInWord+ b+ (clipLoBits b offBits (indexByteArray arr offWords))+ of+ r@Just{} -> r+ Nothing ->+ (+ (wordSize - offBits))+ <$> case bitIndexInWords b (offWords + 1) (lWords - 2) arr of+ r@Just{} -> r+ Nothing ->+ (+ mulWordSize (lWords - 2)) <$> bitIndexInWord+ b+ (clipHiBits+ b+ nMod+ (indexByteArray arr (offWords + lWords - 1))+ )+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len) - loop !i- | i >= n = Nothing- | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize)+bitIndexInWord :: Bit -> Word -> Maybe Int+bitIndexInWord (Bit True ) = ffs+bitIndexInWord (Bit False) = ffs . complement++bitIndexInWords :: Bit -> Int -> Int -> ByteArray -> Maybe Int+bitIndexInWords (Bit True) !off !len !arr = go off+ where+ go !n+ | n >= off + len = Nothing+ | otherwise = case ffs (indexByteArray arr n) of+ Nothing -> go (n + 1)+ r@Just{} -> r+bitIndexInWords (Bit False) !off !len !arr = go off+ where+ go !n+ | n >= off + len = Nothing+ | otherwise = case ffs (complement (indexByteArray arr n)) of+ Nothing -> go (n + 1)+ r@Just{} -> r++-- | Return the index of the @n@-th bit in the vector+-- with the specified value, if any.+-- Here @n@ is 1-based and the index is 0-based.+-- Non-positive @n@ results in an error.+--+-- >>> nthBitIndex (Bit True) 2 (read "[0,1,0,1,1,1,0]")+-- Just 3+-- >>> nthBitIndex (Bit True) 5 (read "[0,1,0,1,1,1,0]")+-- Nothing+--+-- One can use 'nthBitIndex' to implement+-- to implement @select{0,1}@ queries+-- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.+nthBitIndex :: Bit -> Int -> U.Vector Bit -> Maybe Int+nthBitIndex _ k _ | k <= 0 = error "nthBitIndex: n must be positive"+nthBitIndex b k (BitVec off len arr)+ | len == 0 = Nothing+ | offBits == 0 = either (const Nothing) Just $ case modWordSize len of+ 0 -> nthInWords b k offWords lWords arr+ nMod -> case nthInWords b k offWords (lWords - 1) arr of+ r@Right{} -> r+ Left k' -> (+ mulWordSize (lWords - 1)) <$> nthInWord+ b+ k'+ (clipHiBits b nMod (indexByteArray arr (offWords + lWords - 1)))+ | otherwise = either (const Nothing) Just $ case modWordSize (off + len) of+ 0 ->+ case nthInWord b k (clipLoBits b offBits (indexByteArray arr offWords)) of+ r@Right{} -> r+ Left k' ->+ (+ (wordSize - offBits))+ <$> nthInWords b k' (offWords + 1) (lWords - 1) arr+ nMod -> case lWords of+ 1 -> nthInWord+ b+ k+ (clipHiBits b len (clipLoBits b offBits (indexByteArray arr offWords)))+ _ ->+ case+ nthInWord b k (clipLoBits b offBits (indexByteArray arr offWords))+ of+ r@Right{} -> r+ Left k' ->+ (+ (wordSize - offBits))+ <$> case nthInWords b k' (offWords + 1) (lWords - 2) arr of+ r@Right{} -> r+ Left k'' -> (+ mulWordSize (lWords - 2)) <$> nthInWord+ b+ k''+ (clipHiBits+ b+ nMod+ (indexByteArray arr (offWords + lWords - 1))+ )+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)++nthInWord :: Bit -> Int -> Word -> Either Int Int+nthInWord (Bit b) k v = if k > c then Left (k - c) else Right (select1 w k - 1)+ where+ w = if b then v else complement v+ c = popCount w++nthInWords :: Bit -> Int -> Int -> Int -> ByteArray -> Either Int Int+nthInWords (Bit True) !k !off !len !arr = go off k+ where+ go !n !l+ | n >= off + len = Left l+ | otherwise = if l > c+ then go (n + 1) (l - c)+ else Right (mulWordSize (n - off) + select1 w l - 1)+ where+ w = indexByteArray arr n+ c = popCount w+nthInWords (Bit False) !k !off !len !arr = go off k+ where+ go !n !l+ | n >= off + len = Left l+ | otherwise = if l > c+ then go (n + 1) (l - c)+ else Right (mulWordSize (n - off) + select1 w l - 1)+ where+ w = complement (indexByteArray arr n)+ c = popCount w++-- | Return the number of set bits in a vector (population count, popcount).+--+-- >>> countBits (read "[1,1,0,1,0,1]")+-- 4+--+-- One can combine 'countBits' with 'Data.Vector.Unboxed.take'+-- to implement @rank{0,1}@ queries+-- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.+countBits :: U.Vector Bit -> Int+countBits (BitVec _ 0 _) = 0+countBits (BitVec off len arr) | offBits == 0 = case modWordSize len of+ 0 -> countBitsInWords (P.Vector offWords lWords arr)+ nMod -> countBitsInWords (P.Vector offWords (lWords - 1) arr)+ + popCount (indexByteArray arr (offWords + lWords - 1) .&. loMask nMod)+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)+countBits (BitVec off len arr) = case modWordSize (off + len) of+ 0 -> popCount (indexByteArray arr offWords `unsafeShiftR` offBits :: Word)+ + countBitsInWords (P.Vector (offWords + 1) (lWords - 1) arr)+ nMod -> case lWords of+ 1 -> popCount+ ((indexByteArray arr offWords `unsafeShiftR` offBits) .&. loMask len)+ _ ->+ popCount (indexByteArray arr offWords `unsafeShiftR` offBits :: Word)+ + countBitsInWords (P.Vector (offWords + 1) (lWords - 2) arr)+ + popCount (indexByteArray arr (offWords + lWords - 1) .&. loMask nMod)+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)++countBitsInWords :: P.Vector Word -> Int+countBitsInWords = P.foldl' (\acc word -> popCount word + acc) 0++-- | Return the indices of set bits in a vector.+--+-- >>> listBits (read "[1,1,0,1,0,1]")+-- [0,1,3,5]+listBits :: U.Vector Bit -> [Int]+listBits (BitVec _ 0 _) = []+listBits (BitVec off len arr) | offBits == 0 = case modWordSize len of+ 0 -> listBitsInWords 0 (P.Vector offWords lWords arr) []+ nMod ->+ listBitsInWords 0 (P.Vector offWords (lWords - 1) arr)+ $ map (+ mulWordSize (lWords - 1))+ $ filter (testBit (indexByteArray arr (offWords + lWords - 1) :: Word))+ [0 .. nMod - 1]+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)+listBits (BitVec off len arr) = case modWordSize (off + len) of+ 0 ->+ filter+ (testBit (indexByteArray arr offWords `unsafeShiftR` offBits :: Word))+ [0 .. wordSize - offBits - 1]+ ++ listBitsInWords (wordSize - offBits)+ (P.Vector (offWords + 1) (lWords - 1) arr)+ []+ nMod -> case lWords of+ 1 -> filter+ (testBit (indexByteArray arr offWords `unsafeShiftR` offBits :: Word))+ [0 .. len - 1]+ _ ->+ filter+ (testBit (indexByteArray arr offWords `unsafeShiftR` offBits :: Word))+ [0 .. wordSize - offBits - 1]+ ++ ( listBitsInWords (wordSize - offBits)+ (P.Vector (offWords + 1) (lWords - 2) arr)+ $ map (+ (mulWordSize (lWords - 1) - offBits))+ $ filter+ (testBit (indexByteArray arr (offWords + lWords - 1) :: Word))+ [0 .. nMod - 1]+ )+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)++listBitsInWord :: Int -> Word -> [Int]+listBitsInWord offset word =+ map (+ offset) $ filter (testBit word) $ [0 .. wordSize - 1]++listBitsInWords :: Int -> P.Vector Word -> [Int] -> [Int]+listBitsInWords offset = flip $ P.ifoldr+ (\i word acc -> listBitsInWord (offset + mulWordSize i) word ++ acc)
src/Data/Bit/Internal.hs view
@@ -15,290 +15,400 @@ #else module Data.Bit.InternalTS #endif- ( Bit(..)- , U.Vector(BitVec)- , U.MVector(BitMVec)- , indexWord- , readWord- , writeWord-- , unsafeFlipBit- , flipBit-- , nthBitIndex- , countBits- , listBits- ) where+ ( Bit(..)+ , U.Vector(BitVec)+ , U.MVector(BitMVec)+ , indexWord+ , readWord+ , writeWord+ , unsafeFlipBit+ , flipBit+ , WithInternals(..)+ ) where #include "vector.h" import Control.Monad import Control.Monad.Primitive-import Data.Bit.Select1-import Data.Bit.Utils import Data.Bits+import Data.Bit.Utils+import Data.Primitive.ByteArray import Data.Typeable-import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as MV-import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed as U #ifdef BITVEC_THREADSAFE-import Data.Primitive.ByteArray-import qualified Data.Vector.Primitive as P import GHC.Exts #endif +#ifndef BITVEC_THREADSAFE -- | A newtype wrapper with a custom instance -- of "Data.Vector.Unboxed", which packs booleans -- as efficient as possible (8 values per byte). -- Vectors of `Bit` use 8x less memory--- than vectors of 'Bool' (which stores one value per byte),--- but random writes--- are slightly slower.+-- than vectors of 'Bool' (which stores one value per byte).+-- but random writes are up to 10% slower. newtype Bit = Bit { unBit :: Bool }- deriving (Bounded, Enum, Eq, Ord, FiniteBits, Bits, Typeable)+ deriving (Bounded, Enum, Eq, Ord, FiniteBits, Bits, Typeable)+#else+-- | A newtype wrapper with a custom instance+-- of "Data.Vector.Unboxed", which packs booleans+-- as efficient as possible (8 values per byte).+-- Vectors of `Bit` use 8x less memory+-- than vectors of 'Bool' (which stores one value per byte).+-- but random writes are up to 20% slower.+newtype Bit = Bit { unBit :: Bool }+ deriving (Bounded, Enum, Eq, Ord, FiniteBits, Bits, Typeable)+#endif instance Show Bit where- showsPrec _ (Bit False) = showString "0"- showsPrec _ (Bit True ) = showString "1"+ showsPrec _ (Bit False) = showString "0"+ showsPrec _ (Bit True ) = showString "1" instance Read Bit where- readsPrec p (' ':rest) = readsPrec p rest- readsPrec _ ('0':rest) = [(Bit False, rest)]- readsPrec _ ('1':rest) = [(Bit True, rest)]- readsPrec _ _ = []+ readsPrec p (' ' : rest) = readsPrec p rest+ readsPrec _ ('0' : rest) = [(Bit False, rest)]+ readsPrec _ ('1' : rest) = [(Bit True, rest)]+ readsPrec _ _ = [] instance U.Unbox Bit -- Ints are offset and length in bits-data instance U.MVector s Bit = BitMVec !Int !Int !(U.MVector s Word)-data instance U.Vector Bit = BitVec !Int !Int !(U.Vector Word)+data instance U.MVector s Bit = BitMVec !Int !Int !(MutableByteArray s)+data instance U.Vector Bit = BitVec !Int !Int !ByteArray +newtype WithInternals = WithInternals (U.Vector Bit)++#if MIN_VERSION_primitive(0,6,3)+instance Show WithInternals where+ show (WithInternals v@(BitVec off len ba)) = show (off, len, ba, v)+#endif+ readBit :: Int -> Word -> Bit readBit i w = Bit (w .&. (1 `unsafeShiftL` i) /= 0) {-# INLINE readBit #-} extendToWord :: Bit -> Word extendToWord (Bit False) = 0-extendToWord (Bit True) = complement 0+extendToWord (Bit True ) = complement 0 -- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the result is zero-padded. indexWord :: U.Vector Bit -> Int -> Word-indexWord (BitVec 0 n v) i- | aligned i = masked b lo- | j + 1 == nWords n = masked b (extractWord k lo 0 )- | otherwise = masked b (extractWord k lo hi)- where- b = n - i- j = divWordSize i- k = modWordSize i- lo = v V.! j- hi = v V.! (j+1)-indexWord (BitVec s n v) i = indexWord (BitVec 0 (n + s) v) (i + s)+indexWord (BitVec off len' arr) i' = word .&. msk+ where+ len = off + len'+ i = off + i'+ nMod = modWordSize i+ loIx = divWordSize i+ msk = if len - i >= wordSize then complement 0 else loMask (len - i)+ loWord = indexByteArray arr loIx+ hiWord = indexByteArray arr (loIx + 1) + word = if nMod == 0+ then loWord+ else if loIx == divWordSize (len - 1)+ then (loWord `unsafeShiftR` nMod)+ else+ (loWord `unsafeShiftR` nMod)+ .|. (hiWord `unsafeShiftL` (wordSize - nMod))+ -- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the result is zero-padded. readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word-readWord (BitMVec 0 n v) i- | aligned i = liftM (masked b) lo- | j + 1 == nWords n = liftM (masked b) (liftM2 (extractWord k) lo (return 0))- | otherwise = liftM (masked b) (liftM2 (extractWord k) lo hi)- where- b = n - i- j = divWordSize i- k = modWordSize i- lo = MV.read v j- hi = MV.read v (j+1)-readWord (BitMVec s n v) i = readWord (BitMVec 0 (n + s) v) (i + s)+readWord (BitMVec off len' arr) i' = do+ let len = off + len'+ i = off + i'+ nMod = modWordSize i+ loIx = divWordSize i+ msk = if len - i >= wordSize then complement 0 else loMask (len - i)+ loWord <- readByteArray arr loIx + word <- if nMod == 0+ then pure loWord+ else if loIx == divWordSize (len - 1)+ then pure (loWord `unsafeShiftR` nMod)+ else do+ hiWord <- readByteArray arr (loIx + 1)+ pure+ $ (loWord `unsafeShiftR` nMod)+ .|. (hiWord `unsafeShiftL` (wordSize - nMod))++ pure $ word .&. msk+ -- | write a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the word is truncated and as many low-order bits as possible are written. writeWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> Word -> m ()-writeWord (BitMVec 0 n v) i x- | aligned i =- if b < wordSize- then do- y <- MV.read v j- MV.write v j (meld b x y)- else MV.write v j x- | j + 1 == nWords n = do- lo <- MV.read v j- let x' = if b < wordSize- then meld b x (extractWord k lo 0)- else x- (lo', _hi) = spliceWord k lo 0 x'- MV.write v j lo'- | otherwise = do- lo <- MV.read v j- hi <- if j + 1 == nWords n- then return 0- else MV.read v (j+1)- let x' = if b < wordSize- then meld b x (extractWord k lo hi)- else x- (lo', hi') = spliceWord k lo hi x'- MV.write v j lo'- MV.write v (j+1) hi'- where- b = n - i- j = divWordSize i- k = modWordSize i-writeWord (BitMVec s n v) i x = writeWord (BitMVec 0 (n + s) v) (i + s) x+writeWord (BitMVec off len' arr) i' x = do+ let len = off + len'+ lenMod = modWordSize len+ i = off + i'+ nMod = modWordSize i+ loIx = divWordSize i + if nMod == 0+ then if len >= i + wordSize+ then writeByteArray arr loIx x+ else do+ loWord <- readByteArray arr loIx+ writeByteArray arr loIx+ $ (loWord .&. hiMask lenMod)+ .|. (x .&. loMask lenMod)+ else if loIx == divWordSize (len - 1)+ then do+ loWord <- readByteArray arr loIx+ if lenMod == 0+ then+ writeByteArray arr loIx+ $ (loWord .&. loMask nMod)+ .|. (x `unsafeShiftL` nMod)+ else+ writeByteArray arr loIx+ $ (loWord .&. (loMask nMod .|. hiMask lenMod))+ .|. ((x `unsafeShiftL` nMod) .&. loMask lenMod)+ else do+ loWord <- readByteArray arr loIx+ writeByteArray arr loIx+ $ (loWord .&. loMask nMod)+ .|. (x `unsafeShiftL` nMod)+ hiWord <- readByteArray arr (loIx + 1)+ writeByteArray arr (loIx + 1)+ $ (hiWord .&. hiMask nMod)+ .|. (x `unsafeShiftR` (wordSize - nMod))+ instance MV.MVector U.MVector Bit where- {-# INLINE basicInitialize #-}- basicInitialize (BitMVec _ 0 _) = pure ()- basicInitialize (BitMVec 0 n v) = case modWordSize n of- 0 -> MV.basicInitialize v- nMod -> do- let vLen = MV.basicLength v- MV.basicInitialize (MV.slice 0 (vLen - 1) v)- MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)- basicInitialize (BitMVec s n v) = case modWordSize (s + n) of- 0 -> do- let vLen = MV.basicLength v- MV.basicInitialize (MV.slice 1 (vLen - 1) v)- MV.modify v (\val -> val .&. loMask s) 0- nMod -> do- let vLen = MV.basicLength v- lohiMask = loMask s .|. hiMask nMod- if vLen == 1- then MV.modify v (\val -> val .&. lohiMask) 0- else do- MV.basicInitialize (MV.slice 1 (vLen - 2) v)- MV.modify v (\val -> val .&. loMask s) 0- MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)+ {-# INLINE basicInitialize #-}+ basicInitialize vec = MV.basicSet vec (Bit False) - {-# INLINE basicUnsafeNew #-}- basicUnsafeNew n = liftM (BitMVec 0 n) (MV.basicUnsafeNew (nWords n))+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n+ | n < 0 = error $ "Data.Bit.basicUnsafeNew: negative length: " ++ show n+ | otherwise = do+ arr <- newByteArray (wordsToBytes $ nWords n)+ pure $ BitMVec 0 n arr - {-# INLINE basicUnsafeReplicate #-}- basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x))+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeReplicate n x+ | n < 0 = error+ $ "Data.Bit.basicUnsafeReplicate: negative length: "+ ++ show n+ | otherwise = do+ arr <- newByteArray (wordsToBytes $ nWords n)+ setByteArray arr 0 (nWords n) (extendToWord x :: Word)+ pure $ BitMVec 0 n arr - {-# INLINE basicOverlaps #-}- basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2+ {-# INLINE basicOverlaps #-}+ basicOverlaps (BitMVec i' m' arr1) (BitMVec j' n' arr2) =+ sameMutableByteArray arr1 arr2+ && (between i j (j + n) || between j i (i + m))+ where+ i = divWordSize i'+ m = nWords (i' + m') - i+ j = divWordSize j'+ n = nWords (j' + n') - j+ between x y z = x >= y && x < z - {-# INLINE basicLength #-}- basicLength (BitMVec _ n _) = n+ {-# INLINE basicLength #-}+ basicLength (BitMVec _ n _) = n - {-# INLINE basicUnsafeRead #-}- basicUnsafeRead (BitMVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i))+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (BitMVec off _ arr) !i' = do+ let i = off + i'+ word <- readByteArray arr (divWordSize i)+ pure $ readBit (modWordSize i) word - {-# INLINE basicUnsafeWrite #-}+ {-# INLINE basicUnsafeWrite #-} #ifndef BITVEC_THREADSAFE- basicUnsafeWrite (BitMVec s _ v) !i' !x = do- let i = s + i'- let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k- w <- MV.basicUnsafeRead v j- when (Bit (w .&. kk /= 0) /= x) $- MV.basicUnsafeWrite v j (w `xor` kk)+ basicUnsafeWrite (BitMVec off _ arr) !i' !x = do+ let i = off + i'+ j = divWordSize i+ k = modWordSize i+ kk = 1 `unsafeShiftL` k :: Word+ word <- readByteArray arr j+ writeByteArray arr j (if unBit x then word .|. kk else word .&. complement kk) #else- basicUnsafeWrite (BitMVec s _ (U.MV_Word (P.MVector o _ (MutableByteArray mba)))) !i' (Bit b) = do- let i = s + i'- !(I# j) = o + divWordSize i- !(I# k) = 1 `unsafeShiftL` modWordSize i- primitive $ \state ->- let !(# state', _ #) = (if b then fetchOrIntArray# mba j k state else fetchAndIntArray# mba j (notI# k) state) in- (# state', () #)+ basicUnsafeWrite (BitMVec off _ (MutableByteArray mba)) !i' (Bit b) = do+ let i = off + i'+ !(I# j) = divWordSize i+ !(I# k) = 1 `unsafeShiftL` modWordSize i+ primitive $ \state ->+ let !(# state', _ #) =+ (if b+ then fetchOrIntArray# mba j k state+ else fetchAndIntArray# mba j (notI# k) state+ )+ in (# state', () #) #endif - {-# INLINE basicClear #-}- basicClear _ = pure ()+ {-# INLINE basicClear #-}+ basicClear _ = pure () - {-# INLINE basicSet #-}- basicSet (BitMVec _ 0 _) _ = pure ()- basicSet (BitMVec 0 n v) (extendToWord -> x) = case modWordSize n of- 0 -> MV.basicSet v x- nMod -> do- let vLen = MV.basicLength v- MV.basicSet (MV.slice 0 (vLen - 1) v) x- MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)- basicSet (BitMVec s n v) (extendToWord -> x) = case modWordSize (s + n) of- 0 -> do- let vLen = MV.basicLength v- MV.basicSet (MV.slice 1 (vLen - 1) v) x- MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0- nMod -> do- let vLen = MV.basicLength v- lohiMask = loMask s .|. hiMask nMod- if vLen == 1- then MV.modify v (\val -> val .&. lohiMask .|. x .&. complement lohiMask) 0- else do- MV.basicSet (MV.slice 1 (vLen - 2) v) x- MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0- MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)+ {-# INLINE basicSet #-}+ basicSet (BitMVec _ 0 _) _ = pure ()+ basicSet (BitMVec off len arr) (extendToWord -> x) | offBits == 0 =+ case modWordSize len of+ 0 -> setByteArray arr offWords lWords (x :: Word)+ nMod -> do+ setByteArray arr offWords (lWords - 1) (x :: Word)+ lastWord <- readByteArray arr (offWords + lWords - 1)+ let lastWord' = lastWord .&. hiMask nMod .|. x .&. loMask nMod+ writeByteArray arr (offWords + lWords - 1) lastWord'+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)+ basicSet (BitMVec off len arr) (extendToWord -> x) =+ case modWordSize (off + len) of+ 0 -> do+ firstWord <- readByteArray arr offWords+ let firstWord' = firstWord .&. loMask offBits .|. x .&. hiMask offBits+ writeByteArray arr offWords firstWord'+ setByteArray arr (offWords + 1) (lWords - 1) (x :: Word)+ nMod -> if lWords == 1+ then do+ theOnlyWord <- readByteArray arr offWords+ let lohiMask = loMask offBits .|. hiMask nMod+ theOnlyWord' =+ theOnlyWord .&. lohiMask .|. x .&. complement lohiMask+ writeByteArray arr offWords theOnlyWord'+ else do+ firstWord <- readByteArray arr offWords+ let firstWord' = firstWord .&. loMask offBits .|. x .&. hiMask offBits+ writeByteArray arr offWords firstWord' - {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy _ (BitMVec _ 0 _) = pure ()- basicUnsafeCopy (BitMVec 0 _ dst) (BitMVec 0 n src) = case modWordSize n of- 0 -> MV.basicUnsafeCopy dst src- nMod -> do- let vLen = MV.basicLength src- MV.basicUnsafeCopy (MV.slice 0 (vLen - 1) dst) (MV.slice 0 (vLen - 1) src)- valSrc <- MV.basicUnsafeRead src (vLen - 1)- MV.modify dst (\val -> val .&. hiMask nMod .|. valSrc .&. loMask nMod) (vLen - 1)- basicUnsafeCopy (BitMVec dstShift _ dst) (BitMVec s n src)- | dstShift == s = case modWordSize (s + n) of- 0 -> do- let vLen = MV.basicLength src- MV.basicUnsafeCopy (MV.slice 1 (vLen - 1) dst) (MV.slice 1 (vLen - 1) src)- valSrc <- MV.basicUnsafeRead src 0- MV.modify dst (\val -> val .&. loMask s .|. valSrc .&. hiMask s) 0- nMod -> do- let vLen = MV.basicLength src- lohiMask = loMask s .|. hiMask nMod- if vLen == 1- then do- valSrc <- MV.basicUnsafeRead src 0- MV.modify dst (\val -> val .&. lohiMask .|. valSrc .&. complement lohiMask) 0- else do- MV.basicUnsafeCopy (MV.slice 1 (vLen - 2) dst) (MV.slice 1 (vLen - 2) src)- valSrcFirst <- MV.basicUnsafeRead src 0- MV.modify dst (\val -> val .&. loMask s .|. valSrcFirst .&. hiMask s) 0- valSrcLast <- MV.basicUnsafeRead src (vLen - 1)- MV.modify dst (\val -> val .&. hiMask nMod .|. valSrcLast .&. loMask nMod) (vLen - 1)+ setByteArray arr (offWords + 1) (lWords - 2) (x :: Word) - basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0- where- n = alignUp len+ lastWord <- readByteArray arr (offWords + lWords - 1)+ let lastWord' = lastWord .&. hiMask nMod .|. x .&. loMask nMod+ writeByteArray arr (offWords + lWords - 1) lastWord'+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len) - do_copy i- | i < n = do- x <- readWord src i- writeWord dst i x- do_copy (i+wordSize)- | otherwise = return ()+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeCopy _ (BitMVec _ 0 _) = pure ()+ basicUnsafeCopy (BitMVec offDst lenDst dst) (BitMVec offSrc _ src)+ | offDstBits == 0, offSrcBits == 0 = case modWordSize lenDst of+ 0 -> copyMutableByteArray dst+ (wordsToBytes offDstWords)+ src+ (wordsToBytes offSrcWords)+ (wordsToBytes lDstWords)+ nMod -> do+ copyMutableByteArray dst+ (wordsToBytes offDstWords)+ src+ (wordsToBytes offSrcWords)+ (wordsToBytes $ lDstWords - 1) - {-# INLINE basicUnsafeMove #-}- basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _)- | MV.basicOverlaps dst src = do- -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src- -- TODO write tests on copy and move inside array- srcCopy <- BitMVec srcShift srcLen <$> MV.basicUnsafeNew (nWords (srcShift + srcLen))- MV.basicUnsafeCopy srcCopy src- MV.basicUnsafeCopy dst srcCopy- | otherwise = MV.basicUnsafeCopy dst src+ lastWordSrc <- readByteArray src (offSrcWords + lDstWords - 1)+ lastWordDst <- readByteArray dst (offDstWords + lDstWords - 1)+ let lastWordDst' =+ lastWordDst .&. hiMask nMod .|. lastWordSrc .&. loMask nMod+ writeByteArray dst (offDstWords + lDstWords - 1) lastWordDst'+ where+ offDstBits = modWordSize offDst+ offDstWords = divWordSize offDst+ lDstWords = nWords (offDstBits + lenDst)+ offSrcBits = modWordSize offSrc+ offSrcWords = divWordSize offSrc+ basicUnsafeCopy (BitMVec offDst lenDst dst) (BitMVec offSrc _ src)+ | offDstBits == offSrcBits = case modWordSize (offSrc + lenDst) of+ 0 -> do+ firstWordSrc <- readByteArray src offSrcWords+ firstWordDst <- readByteArray dst offDstWords+ let firstWordDst' =+ firstWordDst+ .&. loMask offSrcBits+ .|. firstWordSrc+ .&. hiMask offSrcBits+ writeByteArray dst offDstWords firstWordDst' - {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice offset n (BitMVec s _ v) =- BitMVec relStartBit n (MV.basicUnsafeSlice startWord (endWord - startWord) v)- where- absStartBit = s + offset- relStartBit = modWordSize absStartBit- absEndBit = absStartBit + n- endWord = nWords absEndBit- startWord = divWordSize absStartBit+ copyMutableByteArray dst+ (wordsToBytes $ offDstWords + 1)+ src+ (wordsToBytes $ offSrcWords + 1)+ (wordsToBytes $ lDstWords - 1)+ nMod -> if lDstWords == 1+ then do+ let lohiMask = loMask offSrcBits .|. hiMask nMod+ theOnlyWordSrc <- readByteArray src offSrcWords+ theOnlyWordDst <- readByteArray dst offDstWords+ let theOnlyWordDst' =+ theOnlyWordDst+ .&. lohiMask+ .|. theOnlyWordSrc+ .&. complement lohiMask+ writeByteArray dst offDstWords theOnlyWordDst'+ else do+ firstWordSrc <- readByteArray src offSrcWords+ firstWordDst <- readByteArray dst offDstWords+ let firstWordDst' =+ firstWordDst+ .&. loMask offSrcBits+ .|. firstWordSrc+ .&. hiMask offSrcBits+ writeByteArray dst offDstWords firstWordDst' - {-# INLINE basicUnsafeGrow #-}- basicUnsafeGrow (BitMVec s n v) by =- BitMVec s (n + by) <$> if delta == 0 then pure v else MV.basicUnsafeGrow v delta- where- delta = nWords (s + n + by) - nWords (s + n)+ copyMutableByteArray dst+ (wordsToBytes $ offDstWords + 1)+ src+ (wordsToBytes $ offSrcWords + 1)+ (wordsToBytes $ lDstWords - 2) + lastWordSrc <- readByteArray src (offSrcWords + lDstWords - 1)+ lastWordDst <- readByteArray dst (offDstWords + lDstWords - 1)+ let lastWordDst' =+ lastWordDst .&. hiMask nMod .|. lastWordSrc .&. loMask nMod+ writeByteArray dst (offDstWords + lDstWords - 1) lastWordDst'+ where+ offDstBits = modWordSize offDst+ offDstWords = divWordSize offDst+ lDstWords = nWords (offDstBits + lenDst)+ offSrcBits = modWordSize offSrc+ offSrcWords = divWordSize offSrc++ basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0+ where+ n = alignUp len++ do_copy i+ | i < n = do+ x <- readWord src i+ writeWord dst i x+ do_copy (i + wordSize)+ | otherwise = return ()++ {-# INLINE basicUnsafeMove #-}+ basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _)+ | MV.basicOverlaps dst src = do+ -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src+ srcCopy <- MV.drop (modWordSize srcShift)+ <$> MV.basicUnsafeNew (modWordSize srcShift + srcLen)+ MV.basicUnsafeCopy srcCopy src+ MV.basicUnsafeCopy dst srcCopy+ | otherwise = MV.basicUnsafeCopy dst src++ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice offset n (BitMVec off _ arr) = BitMVec (off + offset) n arr++ {-# INLINE basicUnsafeGrow #-}+ basicUnsafeGrow (BitMVec off len src) byBits+ | byWords == 0 = pure $ BitMVec off (len + byBits) src+ | otherwise = do+ dst <- newByteArray (wordsToBytes newWords)+ copyMutableByteArray dst 0 src 0 (wordsToBytes oldWords)+ pure $ BitMVec off (len + byBits) dst+ where+ oldWords = nWords (off + len)+ newWords = nWords (off + len + byBits)+ byWords = newWords - oldWords+ #ifndef BITVEC_THREADSAFE -- | Flip the bit at the given position. -- No bounds checks are performed. -- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement',--- but slightly faster.+-- but up to 2x faster. -- -- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors: -- either you modify it with 'id' (which is 'id' altogether)@@ -307,16 +417,18 @@ -- >>> Data.Vector.Unboxed.modify (\v -> unsafeFlipBit v 1) (read "[1,1,1]") -- [1,0,1] unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()-unsafeFlipBit (BitMVec s _ v) !i' = do- let i = s + i'- let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k- w <- MV.basicUnsafeRead v j- MV.basicUnsafeWrite v j (w `xor` kk)+unsafeFlipBit (BitMVec off _ arr) !i' = do+ let i = off + i'+ j = divWordSize i+ k = modWordSize i+ kk = 1 `unsafeShiftL` k :: Word+ word <- readByteArray arr j+ writeByteArray arr j (word `xor` kk) {-# INLINE unsafeFlipBit #-} -- | Flip the bit at the given position. -- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement',--- but slightly faster.+-- but up to 2x faster. -- -- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors: -- either you modify it with 'id' (which is 'id' altogether)@@ -325,7 +437,8 @@ -- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]") -- [1,0,1] flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()-flipBit v i = BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i+flipBit v i =+ BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i {-# INLINE flipBit #-} #else@@ -333,7 +446,7 @@ -- | Flip the bit at the given position. -- No bounds checks are performed. -- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement',--- but slightly faster and atomic.+-- but up to 33% faster and atomic. -- -- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors: -- either you modify it with 'id' (which is 'id' altogether)@@ -342,18 +455,17 @@ -- >>> Data.Vector.Unboxed.modify (\v -> unsafeFlipBit v 1) (read "[1,1,1]") -- [1,0,1] unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()-unsafeFlipBit (BitMVec s _ (U.MV_Word (P.MVector o _ (MutableByteArray mba)))) !i' = do- let i = s + i'- !(I# j) = o + divWordSize i- !(I# k) = 1 `unsafeShiftL` modWordSize i- primitive $ \state ->- let !(# state', _ #) = fetchXorIntArray# mba j k state in- (# state', () #)+unsafeFlipBit (BitMVec off _ (MutableByteArray mba)) !i' = do+ let i = off + i'+ !(I# j) = divWordSize i+ !(I# k) = 1 `unsafeShiftL` modWordSize i+ primitive $ \state ->+ let !(# state', _ #) = fetchXorIntArray# mba j k state in (# state', () #) {-# INLINE unsafeFlipBit #-} -- | Flip the bit at the given position. -- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement',--- but slightly faster and atomic+-- but up to 33% faster and atomic. -- -- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors: -- either you modify it with 'id' (which is 'id' altogether)@@ -362,199 +474,25 @@ -- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]") -- [1,0,1] flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()-flipBit v i = BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i+flipBit v i =+ BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i {-# INLINE flipBit #-} #endif instance V.Vector U.Vector Bit where- basicUnsafeFreeze (BitMVec s n v) = liftM (BitVec s n) (V.basicUnsafeFreeze v)- basicUnsafeThaw (BitVec s n v) = liftM (BitMVec s n) (V.basicUnsafeThaw v)- basicLength (BitVec _ n _) = n-- basicUnsafeIndexM (BitVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i))-- basicUnsafeCopy dst src = do- src1 <- V.basicUnsafeThaw src- MV.basicUnsafeCopy dst src1-- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice offset n (BitVec s _ v) =- BitVec relStartBit n (V.basicUnsafeSlice startWord (endWord - startWord) v)- where- absStartBit = s + offset- relStartBit = modWordSize absStartBit- absEndBit = absStartBit + n- endWord = nWords absEndBit- startWord = divWordSize absStartBit---- | Return the index of the @n@-th bit in the vector--- with the specified value, if any.--- Here @n@ is 1-based and the index is 0-based.--- Non-positive @n@ results in an error.------ >>> nthBitIndex (Bit True) 2 (read "[0,1,0,1,1,1,0]")--- Just 3--- >>> nthBitIndex (Bit True) 5 (read "[0,1,0,1,1,1,0]")--- Nothing------ One can use 'nthBitIndex' to implement--- to implement @select{0,1}@ queries--- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.-nthBitIndex :: Bit -> Int -> U.Vector Bit -> Maybe Int-nthBitIndex _ k- | k <= 0 = error "nthBitIndex: n must be positive"-nthBitIndex (Bit True) k = \case- BitVec _ 0 _ -> Nothing- BitVec 0 n v -> let l = V.basicLength v in case modWordSize n of- 0 -> case nth1InWords k v of- Right x -> Just x- Left{} -> Nothing- nMod -> case nth1InWords k (V.slice 0 (l - 1) v) of- Right x -> Just x- Left k' -> case nth1 k' (V.last v .&. loMask nMod) of- Right x -> Just $ mulWordSize (l - 1) + x- Left{} -> Nothing- BitVec s n v -> let l = V.basicLength v in case modWordSize (s + n) of- 0 -> case nth1 k (V.head v `unsafeShiftR` s) of- Right x -> Just x- Left k' -> case nth1InWords k' (V.slice 1 (l - 1) v) of- Right x -> Just $ wordSize - s + x- Left {} -> Nothing- nMod -> case l of- 1 -> case nth1 k ((V.head v `unsafeShiftR` s) .&. loMask n) of- Right x -> Just x- Left{} -> Nothing- _ -> case nth1 k (V.head v `unsafeShiftR` s) of- Right x -> Just x- Left k' -> case nth1InWords k' (V.slice 1 (l - 2) v) of- Right x -> Just $ wordSize - s + x- Left k'' -> case nth1 k'' (V.last v .&. loMask nMod) of- Right x -> Just $ mulWordSize (l - 1) - s + x- Left{} -> Nothing-nthBitIndex (Bit False) k = \case- BitVec _ 0 _ -> Nothing- BitVec 0 n v -> let l = V.basicLength v in case modWordSize n of- 0 -> case nth0InWords k v of- Right x -> Just x- Left{} -> Nothing- nMod -> case nth0InWords k (V.slice 0 (l - 1) v) of- Right x -> Just x- Left k' -> case nth0 k' (V.last v .|. hiMask nMod) of- Right x -> Just $ mulWordSize (l - 1) + x- Left{} -> Nothing- BitVec s n v -> let l = V.basicLength v in case modWordSize (s + n) of- 0 -> case nth0 k (V.head v `unsafeShiftR` s .|. hiMask (wordSize - s)) of- Right x -> Just x- Left k' -> case nth0InWords k' (V.slice 1 (l - 1) v) of- Right x -> Just $ wordSize - s + x- Left {} -> Nothing- nMod -> case l of- 1 -> case nth0 k ((V.head v `unsafeShiftR` s) .|. hiMask n) of- Right x -> Just x- Left{} -> Nothing- _ -> case nth0 k ((V.head v `unsafeShiftR` s) .|. hiMask (wordSize - s)) of- Right x -> Just x- Left k' -> case nth0InWords k' (V.slice 1 (l - 2) v) of- Right x -> Just $ wordSize - s + x- Left k'' -> case nth0 k'' (V.last v .|. hiMask nMod) of- Right x -> Just $ mulWordSize (l - 1) - s + x- Left{} -> Nothing--nth0 :: Int -> Word -> Either Int Int-nth0 k v = if k > c then Left (k - c) else Right (select1 w k - 1)- where- w = complement v- c = popCount w--nth1 :: Int -> Word -> Either Int Int-nth1 k w = if k > c then Left (k - c) else Right (select1 w k - 1)- where- c = popCount w--nth0InWords :: Int -> U.Vector Word -> Either Int Int-nth0InWords k vec = go 0 k- where- go n l- | n >= U.length vec = Left l- | otherwise = if l > c then go (n + 1) (l - c) else Right (mulWordSize n + select1 w l - 1)- where- w = complement (vec U.! n)- c = popCount w--nth1InWords :: Int -> U.Vector Word -> Either Int Int-nth1InWords k vec = go 0 k- where- go n l- | n >= U.length vec = Left l- | otherwise = if l > c then go (n + 1) (l - c) else Right (mulWordSize n + select1 w l - 1)- where- w = vec U.! n- c = popCount w---- | Return the number of set bits in a vector (population count, popcount).------ >>> countBits (read "[1,1,0,1,0,1]")--- 4------ One can combine 'countBits' with 'Data.Vector.Unboxed.take'--- to implement @rank{0,1}@ queries--- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.-countBits :: U.Vector Bit -> Int-countBits (BitVec _ 0 _) = 0-countBits (BitVec 0 n v) = case modWordSize n of- 0 -> countBitsInWords v- nMod -> countBitsInWords (V.slice 0 (l - 1) v) +- popCount (V.last v .&. loMask nMod)- where- l = V.basicLength v-countBits (BitVec s n v) = case modWordSize (s + n) of- 0 -> popCount (V.head v `unsafeShiftR` s) +- countBitsInWords (V.slice 1 (l - 1) v)- nMod -> case l of- 1 -> popCount ((V.head v `unsafeShiftR` s) .&. loMask n)- _ ->- popCount (V.head v `unsafeShiftR` s) +- countBitsInWords (V.slice 1 (l - 2) v) +- popCount (V.last v .&. loMask nMod)- where- l = V.basicLength v--countBitsInWords :: U.Vector Word -> Int-countBitsInWords = U.foldl' (\acc word -> popCount word + acc) 0+ basicUnsafeFreeze (BitMVec s n v) =+ liftM (BitVec s n) (unsafeFreezeByteArray v)+ basicUnsafeThaw (BitVec s n v) = liftM (BitMVec s n) (unsafeThawByteArray v)+ basicLength (BitVec _ n _) = n --- | Return the indices of set bits in a vector.------ >>> listBits (read "[1,1,0,1,0,1]")--- [0,1,3,5]-listBits :: U.Vector Bit -> [Int]-listBits (BitVec _ 0 _) = []-listBits (BitVec 0 n v) = case modWordSize n of- 0 -> listBitsInWords 0 v []- nMod -> listBitsInWords 0 (V.slice 0 (l - 1) v) $- map (+ mulWordSize (l - 1)) $- filter (testBit $ V.last v) [0 .. nMod - 1]- where- l = V.basicLength v-listBits (BitVec s n v) = case modWordSize (s + n) of- 0 -> filter (testBit $ V.head v `unsafeShiftR` s) [0 .. wordSize - s - 1] ++- listBitsInWords (wordSize - s) (V.slice 1 (l - 1) v) []- nMod -> case l of- 1 -> filter (testBit $ V.head v `unsafeShiftR` s) [0 .. n - 1]- _ ->- filter (testBit $ V.head v `unsafeShiftR` s) [0 .. wordSize - s - 1] ++- (listBitsInWords (wordSize - s) (V.slice 1 (l - 2) v) $- map (+ (mulWordSize (l - 1) - s)) $- filter (testBit $ V.last v) [0 .. nMod - 1])- where- l = V.basicLength v+ basicUnsafeIndexM (BitVec off _ arr) !i' = do+ let i = off + i'+ pure $! readBit (modWordSize i) (indexByteArray arr (divWordSize i)) -listBitsInWord :: Int -> Word -> [Int]-listBitsInWord offset word- = map (+ offset)- $ filter (testBit word)- $ [0 .. wordSize - 1]+ basicUnsafeCopy dst src = do+ src1 <- V.basicUnsafeThaw src+ MV.basicUnsafeCopy dst src1 -listBitsInWords :: Int -> U.Vector Word -> [Int] -> [Int]-listBitsInWords offset = flip $ U.ifoldr- (\i word acc -> listBitsInWord (offset + mulWordSize i) word ++ acc)+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice offset n (BitVec off _ arr) = BitVec (off + offset) n arr
src/Data/Bit/Mutable.hs view
@@ -9,114 +9,62 @@ #else module Data.Bit.MutableTS #endif- ( castFromWordsM- , castToWordsM- , cloneToWordsM+ ( castFromWordsM+ , castToWordsM+ , cloneToWordsM - , zipInPlace+ , zipInPlace - , invertInPlace- , selectBitsInPlace- , excludeBitsInPlace+ , invertInPlace+ , selectBitsInPlace+ , excludeBitsInPlace - , reverseInPlace- ) where+ , reverseInPlace+ ) where -import Control.Monad-import Control.Monad.Primitive+import Control.Monad.Primitive #ifndef BITVEC_THREADSAFE-import Data.Bit.Internal+import Data.Bit.Internal #else-import Data.Bit.InternalTS+import Data.Bit.InternalTS #endif-import Data.Bit.Utils-import Data.Bits-import qualified Data.Vector.Generic.Mutable as MV-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Unboxed as U (Vector)-import Data.Vector.Unboxed.Mutable as U-import Data.Word-import Prelude as P- hiding (and, or, any, all, reverse)+import Data.Bit.Utils+import Data.Bits+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU -- | Cast a vector of words to a vector of bits. -- Cf. 'Data.Bit.castFromWords'.-castFromWordsM- :: U.MVector s Word- -> U.MVector s Bit-castFromWordsM ws = BitMVec 0 (nBits (MV.length ws)) ws+castFromWordsM :: MVector s Word -> MVector s Bit+castFromWordsM (MU.MV_Word (P.MVector off len ws)) =+ BitMVec (mulWordSize off) (mulWordSize len) ws -- | Try to cast a vector of bits to a vector of words. -- It succeeds if a vector of bits is aligned. -- Use 'cloneToWordsM' otherwise. -- Cf. 'Data.Bit.castToWords'.-castToWordsM- :: U.MVector s Bit- -> Maybe (U.MVector s Word)+castToWordsM :: MVector s Bit -> Maybe (MVector s Word) castToWordsM (BitMVec s n ws)- | aligned s- , aligned n- = Just $ MV.slice (divWordSize s) (nWords n) ws- | otherwise- = Nothing+ | aligned s, aligned n = Just $ MU.MV_Word $ P.MVector (divWordSize s)+ (divWordSize n)+ ws+ | otherwise = Nothing -- | Clone a vector of bits to a new unboxed vector of words. -- If the bits don't completely fill the words, the last word will be zero-padded. -- Cf. 'Data.Bit.cloneToWords'. cloneToWordsM- :: PrimMonad m- => U.MVector (PrimState m) Bit- -> m (U.MVector (PrimState m) Word)-cloneToWordsM v@(BitMVec _ n _) = do- ws <- MV.new (nWords n)- let loop !i !j- | i >= n = return ()- | otherwise = do- readWord v i >>= MV.write ws j- loop (i + wordSize) (j + 1)- loop 0 0- return ws+ :: PrimMonad m => MVector (PrimState m) Bit -> m (MVector (PrimState m) Word)+cloneToWordsM v = do+ let lenBits = MU.length v+ lenWords = nWords lenBits+ w@(BitMVec _ _ arr) <- MU.unsafeNew (mulWordSize lenWords)+ MU.unsafeCopy (MU.slice 0 lenBits w) v+ MU.set (MU.slice lenBits (mulWordSize lenWords - lenBits) w) (Bit False)+ pure $ MU.MV_Word $ P.MVector 0 lenWords arr {-# INLINE cloneToWordsM #-} --- |Map a function over a bit vector one 'Word' at a time ('wordSize' bits at a time). The function will be passed the bit index (which will always be 'wordSize'-aligned) and the current value of the corresponding word. The returned word will be written back to the vector. If there is a partial word at the end of the vector, it will be zero-padded when passed to the function and truncated when the result is written back to the array.-{-# INLINE mapMInPlaceWithIndex #-}-mapMInPlaceWithIndex ::- PrimMonad m =>- (Int -> Word -> m Word)- -> U.MVector (PrimState m) Bit -> m ()-mapMInPlaceWithIndex f xs@(BitMVec 0 _ v) = loop 0 0- where- !n_ = alignDown (MV.length xs)- loop !i !j- | i >= n_ = when (n_ /= MV.length xs) $ do- readWord xs i >>= f i >>= writeWord xs i-- | otherwise = do- MV.read v j >>= f i >>= MV.write v j- loop (i + wordSize) (j + 1)-mapMInPlaceWithIndex f xs = loop 0- where- !n = MV.length xs- loop !i- | i >= n = return ()- | otherwise = do- readWord xs i >>= f i >>= writeWord xs i- loop (i + wordSize)--{-# INLINE mapInPlaceWithIndex #-}-mapInPlaceWithIndex ::- PrimMonad m =>- (Int -> Word -> Word)- -> U.MVector (PrimState m) Bit -> m ()-mapInPlaceWithIndex f = mapMInPlaceWithIndex g- where- {-# INLINE g #-}- g i x = return $! f i x--{-# INLINE mapInPlace #-}-mapInPlace :: PrimMonad m => (Word -> Word) -> U.MVector (PrimState m) Bit -> m ()-mapInPlace f = mapMInPlaceWithIndex (\_ x -> return (f x))- -- | Zip two vectors with the given function. -- rewriting contents of the second argument. -- Cf. 'Data.Bit.zipBits'.@@ -132,108 +80,114 @@ -- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1,1,1,1]") -- [0,1,0,1,1,1] -- note trailing garbage zipInPlace- :: PrimMonad m- => (forall a. Bits a => a -> a -> a)- -> U.Vector Bit- -> U.MVector (PrimState m) Bit- -> m ()-zipInPlace f ys@(BitVec 0 n2 v) xs =- mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)- where- -- WARNING: relies on guarantee by mapMInPlaceWithIndex that index will always be aligned!- !n = min (MV.length xs) (V.length ys)- {-# INLINE g #-}- g !i !x =- let !w = masked (n2 - i) (v V.! divWordSize i)- in f w x-zipInPlace f ys xs =- mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)- where- !n = min (MV.length xs) (V.length ys)- {-# INLINE g #-}- g !i !x =- let !w = indexWord ys i- in f w x+ :: PrimMonad m+ => (forall a . Bits a => a -> a -> a)+ -> Vector Bit+ -> MVector (PrimState m) Bit+ -> m ()+zipInPlace f xs ys = loop 0+ where+ !n = min (U.length xs) (MU.length ys)+ loop !i+ | i >= n = pure ()+ | otherwise = do+ let x = indexWord xs i+ y <- readWord ys i+ writeWord ys i (f x y)+ loop (i + wordSize) {-# INLINE zipInPlace #-} -- | Invert (flip) all bits in-place. -- -- Combine with 'Data.Vector.Unboxed.modify'+-- or simply resort to 'Data.Vector.Unboxed.map' 'Data.Bits.complement' -- to operate on immutable vectors. -- -- >>> Data.Vector.Unboxed.modify invertInPlace (read "[0,1,0,1,0]") -- [1,0,1,0,1] invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-invertInPlace = mapInPlace complement+invertInPlace xs = loop 0+ where+ !n = MU.length xs+ loop !i+ | i >= n = pure ()+ | otherwise = do+ x <- readWord xs i+ writeWord xs i (complement x)+ loop (i + wordSize)+{-# INLINE invertInPlace #-} -- | Same as 'Data.Bit.selectBits', but deposit -- selected bits in-place. Returns a number of selected bits. -- It is caller's resposibility to trim the result to this number. selectBitsInPlace- :: PrimMonad m- => U.Vector Bit- -> U.MVector (PrimState m) Bit- -> m Int+ :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int selectBitsInPlace is xs = loop 0 0- where- !n = min (V.length is) (MV.length xs)- loop !i !ct- | i >= n = return ct- | otherwise = do- x <- readWord xs i- let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x- writeWord xs ct x'- loop (i + wordSize) (ct + nSet)+ where+ !n = min (U.length is) (MU.length xs)+ loop !i !ct+ | i >= n = return ct+ | otherwise = do+ x <- readWord xs i+ let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x+ writeWord xs ct x'+ loop (i + wordSize) (ct + nSet) -- | Same as 'Data.Bit.excludeBits', but deposit -- excluded bits in-place. Returns a number of excluded bits. -- It is caller's resposibility to trim the result to this number.-excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int+excludeBitsInPlace+ :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int excludeBitsInPlace is xs = loop 0 0- where- !n = min (V.length is) (MV.length xs)- loop !i !ct- | i >= n = return ct- | otherwise = do- x <- readWord xs i- let !(nSet, x') = selectWord (masked (n - i) (complement (indexWord is i))) x- writeWord xs ct x'- loop (i + wordSize) (ct + nSet)+ where+ !n = min (U.length is) (MU.length xs)+ loop !i !ct+ | i >= n = return ct+ | otherwise = do+ x <- readWord xs i+ let !(nSet, x') =+ selectWord (masked (n - i) (complement (indexWord is i))) x+ writeWord xs ct x'+ loop (i + wordSize) (ct + nSet) -- | Reverse the order of bits in-place. -- -- Combine with 'Data.Vector.Unboxed.modify'+-- or simply resort to 'Data.Vector.Unboxed.reverse' -- to operate on immutable vectors. -- -- >>> Data.Vector.Unboxed.modify reverseInPlace (read "[1,1,0,1,0]") -- [0,1,0,1,1] reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-reverseInPlace xs = loop 0 (MV.length xs)- where- loop !i !j- | i' <= j' = do- x <- readWord xs i- y <- readWord xs j'+reverseInPlace xs | len == 0 = pure ()+ | otherwise = loop 0+ where+ len = MU.length xs - writeWord xs i (reverseWord y)- writeWord xs j' (reverseWord x)+ loop !i+ | i' <= j' = do+ x <- readWord xs i+ y <- readWord xs j' - loop i' j'- | i' < j = do- let w = (j - i) `shiftR` 1- k = j - w- x <- readWord xs i- y <- readWord xs k+ writeWord xs i (reverseWord y)+ writeWord xs j' (reverseWord x) - writeWord xs i (meld w (reversePartialWord w y) x)- writeWord xs k (meld w (reversePartialWord w x) y)+ loop i'+ | i' < j = do+ let w = (j - i) `shiftR` 1+ k = j - w+ x <- readWord xs i+ y <- readWord xs k - loop i' j'- | i < j = do- let w = j - i- x <- readWord xs i- writeWord xs i (meld w (reversePartialWord w x) x)- | otherwise = return ()- where- !i' = i + wordSize- !j' = j - wordSize+ writeWord xs i (meld w (reversePartialWord w y) x)+ writeWord xs k (meld w (reversePartialWord w x) y)++ loop i'+ | otherwise = do+ let w = j - i+ x <- readWord xs i+ writeWord xs i (meld w (reversePartialWord w x) x)+ where+ !j = len - i+ !i' = i + wordSize+ !j' = j - wordSize
src/Data/Bit/Select1.hs view
@@ -13,8 +13,8 @@ #endif module Data.Bit.Select1- ( select1- ) where+ ( select1+ ) where #include "MachDeps.h"
src/Data/Bit/Utils.hs view
@@ -1,16 +1,28 @@ {-# LANGUAGE BangPatterns #-}--module Data.Bit.Utils where--import Data.Bits-import Data.List+{-# LANGUAGE CPP #-} --- various internal utility functions and constants+module Data.Bit.Utils+ ( modWordSize+ , divWordSize+ , mulWordSize+ , wordSize+ , wordsToBytes+ , nWords+ , aligned+ , alignUp+ , selectWord+ , reverseWord+ , reversePartialWord+ , masked+ , meld+ , ffs+ , loMask+ , hiMask+ ) where -lg2 :: Int -> Int-lg2 n = i- where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1)+#include "MachDeps.h" +import Data.Bits -- |The number of bits in a 'Word'. A handy constant to have around when defining 'Word'-based bulk operations on bit vectors. wordSize :: Int@@ -18,9 +30,9 @@ lgWordSize, wordSizeMask, wordSizeMaskC :: Int lgWordSize = case wordSize of- 32 -> 5- 64 -> 6- _ -> lg2 wordSize+ 32 -> 5+ 64 -> 6+ _ -> error "wordsToBytes: unknown architecture" wordSizeMask = wordSize - 1 wordSizeMaskC = complement wordSizeMask@@ -40,22 +52,20 @@ nWords :: Int -> Int nWords ns = divWordSize (ns + wordSize - 1) --- number of bits storable in n words-nBits :: Bits a => a -> a-nBits ns = mulWordSize ns+wordsToBytes :: Int -> Int+wordsToBytes ns = case wordSize of+ 32 -> ns `unsafeShiftL` 2+ 64 -> ns `unsafeShiftL` 3+ _ -> error "wordsToBytes: unknown architecture" aligned :: Int -> Bool-aligned x = (x .&. wordSizeMask == 0)--notAligned :: Int -> Bool-notAligned x = x /= alignDown x+aligned x = x .&. wordSizeMask == 0 -- round a number of bits up to the nearest multiple of word size alignUp :: Int -> Int-alignUp x- | x == x' = x'- | otherwise = x' + wordSize- where x' = alignDown x+alignUp x | x == x' = x'+ | otherwise = x' + wordSize+ where x' = alignDown x -- round a number of bits down to the nearest multiple of word size alignDown :: Int -> Int@@ -64,87 +74,58 @@ -- create a mask consisting of the lower n bits mask :: Int -> Word mask b = m- where- m | b >= finiteBitSize m = complement 0- | b < 0 = 0- | otherwise = bit b - 1+ where+ m | b >= finiteBitSize m = complement 0+ | b < 0 = 0+ | otherwise = bit b - 1 masked :: Int -> Word -> Word masked b x = x .&. mask b -isMasked :: Int -> Word -> Bool-isMasked b x = (masked b x == x)- -- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi' meld :: Int -> Word -> Word -> Word-meld b lo hi = (lo .&. m) .|. (hi .&. complement m)- where m = mask b---- given a bit offset 'k' and 2 words, extract a word by taking the 'k' highest bits of the first word and the 'wordSize - k' lowest bits of the second word.-{-# INLINE extractWord #-}-extractWord :: Int -> Word -> Word -> Word-extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k))---- given a bit offset 'k', 2 words 'lo' and 'hi' and a word 'x', overlay 'x' onto 'lo' and 'hi' at the position such that (k `elem` [0..wordSize] ==> uncurry (extractWord k) (spliceWord k lo hi x) == x) and (k `elem` [0..wordSize] ==> spliceWord k lo hi (extractWord k lo hi) == (lo,hi))-{-# INLINE spliceWord #-}-spliceWord :: Int -> Word -> Word -> Word -> (Word, Word)-spliceWord k lo hi x =- ( meld k lo (x `shiftL` k)- , meld k (x `shiftR` (wordSize - k)) hi- )+meld b lo hi = (lo .&. m) .|. (hi .&. complement m) where m = mask b+{-# INLINE meld #-} --- this could be given a more general type, but it would be wrong; it works for any fixed word size, but only for unsigned types+#if WORD_SIZE_IN_BITS == 64 reverseWord :: Word -> Word-reverseWord xx = foldr swap xx masks- where- nextMask (d, x) = (d', x `xor` shift x d')- where !d' = d `shiftR` 1-- !(_:masks) =- takeWhile ((0 /=) . snd)- (iterate nextMask (finiteBitSize xx, maxBound))-- swap (n, m) x = ((x .&. m) `shiftL` n) .|. ((x .&. complement m) `shiftR` n)-- -- TODO: is an unrolled version like "loop lgWordSize" faster than the generic implementation above? If so, can that be fixed?- -- loop 0 x = x- -- loop 1 x = loop 0 (((x .&. 0x5555555555555555) `shiftL` 1) .|. ((x .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1))- -- loop 2 x = loop 1 (((x .&. 0x3333333333333333) `shiftL` 2) .|. ((x .&. 0xCCCCCCCCCCCCCCCC) `shiftR` 2))- -- loop 3 x = loop 2 (((x .&. 0x0F0F0F0F0F0F0F0F) `shiftL` 4) .|. ((x .&. 0xF0F0F0F0F0F0F0F0) `shiftR` 4))- -- loop 4 x = loop 3 (((x .&. 0x00FF00FF00FF00FF) `shiftL` 8) .|. ((x .&. 0xFF00FF00FF00FF00) `shiftR` 8))- -- loop 5 x = loop 4 (((x .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x .&. 0xFFFF0000FFFF0000) `shiftR` 16))- -- loop 6 x = loop 5 (((x .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x .&. 0xFFFFFFFF00000000) `shiftR` 32))- -- loop _ _ = error "reverseWord only implemented for up to 64 bit words!"+reverseWord x0 = x6+ where+ x1 = ((x0 .&. 0x5555555555555555) `shiftL` 1) .|. ((x0 .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1)+ x2 = ((x1 .&. 0x3333333333333333) `shiftL` 2) .|. ((x1 .&. 0xCCCCCCCCCCCCCCCC) `shiftR` 2)+ x3 = ((x2 .&. 0x0F0F0F0F0F0F0F0F) `shiftL` 4) .|. ((x2 .&. 0xF0F0F0F0F0F0F0F0) `shiftR` 4)+ x4 = ((x3 .&. 0x00FF00FF00FF00FF) `shiftL` 8) .|. ((x3 .&. 0xFF00FF00FF00FF00) `shiftR` 8)+ x5 = ((x4 .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x4 .&. 0xFFFF0000FFFF0000) `shiftR` 16)+ x6 = ((x5 .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x5 .&. 0xFFFFFFFF00000000) `shiftR` 32)+#else+reverseWord :: Word -> Word+reverseWord x0 = x5+ where+ x1 = ((x0 .&. 0x5555555555555555) `shiftL` 1) .|. ((x0 .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1)+ x2 = ((x1 .&. 0x3333333333333333) `shiftL` 2) .|. ((x1 .&. 0xCCCCCCCCCCCCCCCC) `shiftR` 2)+ x3 = ((x2 .&. 0x0F0F0F0F0F0F0F0F) `shiftL` 4) .|. ((x2 .&. 0xF0F0F0F0F0F0F0F0) `shiftR` 4)+ x4 = ((x3 .&. 0x00FF00FF00FF00FF) `shiftL` 8) .|. ((x3 .&. 0xFF00FF00FF00FF00) `shiftR` 8)+ x5 = ((x4 .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x4 .&. 0xFFFF0000FFFF0000) `shiftR` 16)+#endif reversePartialWord :: Int -> Word -> Word-reversePartialWord n w- | n >= wordSize = reverseWord w- | otherwise = reverseWord w `shiftR` (wordSize - n)--diff :: Bits a => a -> a -> a-diff w1 w2 = w1 .&. complement w2+reversePartialWord n w | n >= wordSize = reverseWord w+ | otherwise = reverseWord w `shiftR` (wordSize - n) ffs :: Word -> Maybe Int ffs 0 = Nothing ffs x = Just $! (popCount (x `xor` complement (-x)) - 1)---- TODO: this can probably be faster--- the interface is very specialized here; 'j' is an offset to add to every bit index and the result is a difference list-bitsInWord :: Int -> Word -> [Int] -> [Int]-bitsInWord j = loop id- where- loop is !w = case ffs w of- Nothing -> is- Just i -> loop (is . (j + i :)) (clearBit w i)+{-# INLINE ffs #-} --- TODO: faster! selectWord :: Word -> Word -> (Int, Word) selectWord m x = loop 0 0 0- where- loop !i !ct !y- | i >= wordSize = (ct, y)- | testBit m i = loop (i+1) (ct+1) (if testBit x i then setBit y ct else y)- | otherwise = loop (i+1) ct y+ where+ loop !i !ct !y+ | i >= wordSize = (ct, y)+ | testBit m i = loop (i + 1)+ (ct + 1)+ (if testBit x i then setBit y ct else y)+ | otherwise = loop (i + 1) ct y loMask :: Int -> Word loMask n = 1 `shiftL` n - 1
test/Main.hs view
@@ -12,17 +12,13 @@ import Tests.Vector (vectorTests) main :: IO ()-main = defaultMain $ testGroup "All"- [ showReadTests- , mvectorTests- , TS.mvectorTests- , setOpTests- , vectorTests- ]+main = defaultMain $ testGroup+ "All"+ [showReadTests, mvectorTests, TS.mvectorTests, setOpTests, vectorTests] showReadTests :: TestTree-showReadTests- = testGroup "Show/Read"- $ map (uncurry testProperty)- $ lawsProperties- $ showReadLaws (Proxy :: Proxy Bit)+showReadTests =+ testGroup "Show/Read"+ $ map (uncurry testProperty)+ $ lawsProperties+ $ showReadLaws (Proxy :: Proxy Bit)
test/Support.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,60 +11,67 @@ import Data.Bit import qualified Data.Bit.ThreadSafe as TS import Data.Bits-import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Generic.New as N-import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Generic.New as N+import qualified Data.Vector.Unboxed as U import Test.Tasty.QuickCheck instance Arbitrary Bit where- arbitrary = Bit <$> arbitrary- shrink = fmap Bit . shrink . unBit+ arbitrary = Bit <$> arbitrary+ shrink = fmap Bit . shrink . unBit instance CoArbitrary Bit where- coarbitrary = coarbitrary . unBit+ coarbitrary = coarbitrary . unBit instance Function Bit where- function f = functionMap unBit Bit f+ function f = functionMap unBit Bit f instance Arbitrary TS.Bit where- arbitrary = TS.Bit <$> arbitrary- shrink = fmap TS.Bit . shrink . TS.unBit+ arbitrary = TS.Bit <$> arbitrary+ shrink = fmap TS.Bit . shrink . TS.unBit instance CoArbitrary TS.Bit where- coarbitrary = coarbitrary . TS.unBit+ coarbitrary = coarbitrary . TS.unBit instance Function TS.Bit where- function f = functionMap TS.unBit TS.Bit f+ function f = functionMap TS.unBit TS.Bit f instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where- arbitrary = V.new <$> arbitrary+ arbitrary = V.new <$> arbitrary instance (Show (v a), V.Vector v a) => Show (N.New v a) where- showsPrec p = showsPrec p . V.new+ showsPrec p = showsPrec p . V.new -newFromList :: forall a v. V.Vector v a => [a] -> N.New v a+newFromList :: forall a v . V.Vector v a => [a] -> N.New v a newFromList xs = N.create (V.thaw (V.fromList xs :: v a)) -- this instance is designed to make sure that the arbitrary vectors we work with are not all nicely aligned; we need to deal with cases where the vector is a weird slice of some other vector. instance (V.Vector v a, Arbitrary a) => Arbitrary (N.New v a) where- arbitrary = frequency- [ (10, newFromList <$> arbitrary)- , (1, N.drop <$> arbitrary <*> arbitrary)- , (1, N.take <$> arbitrary <*> arbitrary)- , (1, slice <$> arbitrary <*> arbitrary <*> arbitrary)- ]- where slice s n = N.apply $ \v ->- let (s', n') = trimSlice s n (M.length v)- in M.slice s' n' v+ arbitrary = frequency+ [ (10, newFromList <$> arbitrary)+ , (1 , N.drop <$> arbitrary <*> arbitrary)+ , (1 , N.take <$> arbitrary <*> arbitrary)+ , (1 , slice <$> arbitrary <*> arbitrary <*> arbitrary)+ ]+ where+ slice s n = N.apply+ $ \v -> let (s', n') = trimSlice s n (M.length v) in M.slice s' n' v+ shrink v =+ [ N.slice s l v+ | s <- [0 .. len - 1]+ , l <- [0 .. len - s]+ , (s, l) /= (0, len)+ ]+ where len = runST (M.length <$> N.run v) trimSlice :: Integral a => a -> a -> a -> (a, a) trimSlice s n l = (s', n')- where- s' | l == 0 = 0- | otherwise = s `mod` l- n' | s' == 0 = 0- | otherwise = n `mod` (l - s')+ where+ s' | l == 0 = 0+ | otherwise = s `mod` l+ n' | s' == 0 = 0+ | otherwise = n `mod` (l - s') sliceList :: Int -> Int -> [a] -> [a] sliceList s n = take n . drop s@@ -73,11 +81,11 @@ packBitsToWord :: [Bit] -> (Word, [Bit]) packBitsToWord = loop 0 0- where- loop _ w [] = (w, [])- loop i w (x:xs)- | i >= wordSize = (w, x:xs)- | otherwise = loop (i+1) (if unBit x then setBit w i else w) xs+ where+ loop _ w [] = (w, [])+ loop i w (x : xs)+ | i >= wordSize = (w, x : xs)+ | otherwise = loop (i + 1) (if unBit x then setBit w i else w) xs readWordL :: [Bit] -> Int -> Word readWordL xs 0 = fst (packBitsToWord xs)@@ -89,32 +97,27 @@ writeWordL :: [Bit] -> Int -> Word -> [Bit] writeWordL xs 0 w = zipWith const (wordToBitList w) xs ++ drop wordSize xs writeWordL xs n w = pre ++ writeWordL post 0 w- where (pre, post) = splitAt n xs+ where (pre, post) = splitAt n xs prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_length xs (NonNegative n) w =- length (writeWordL xs n w) === length xs+ length (writeWordL xs n w) === length xs prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_prefix xs (NonNegative n) w =- take n (writeWordL xs n w) === take n xs+ take n (writeWordL xs n w) === take n xs prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_suffix xs (NonNegative n) w =- drop (n + wordSize) (writeWordL xs n w) === drop (n + wordSize) xs+ drop (n + wordSize) (writeWordL xs n w) === drop (n + wordSize) xs prop_writeWordL_readWordL :: [Bit] -> Int -> Property-prop_writeWordL_readWordL xs n =- writeWordL xs n (readWordL xs n) === xs---- the opposite is more work to state, but these tests together with the simplicity of the definitions makes me reasonably confident in these as a reference implementation.+prop_writeWordL_readWordL xs n = writeWordL xs n (readWordL xs n) === xs withNonEmptyMVec- :: (Eq t, Show t)- => (U.Vector Bit -> t)- -> (forall s. U.MVector s Bit -> ST s t)- -> Property+ :: (Eq t, Show t)+ => (U.Vector Bit -> t)+ -> (forall s . U.MVector s Bit -> ST s t)+ -> Property withNonEmptyMVec f g = forAll arbitrary $ \xs ->- let xs' = V.new xs in- not (U.null xs') ==> f xs' === runST (N.run xs >>= g)-+ let xs' = V.new xs in not (U.null xs') ==> f xs' === runST (N.run xs >>= g)
test/Tests/MVector.hs view
@@ -16,70 +16,75 @@ #endif import Data.Bits import Data.Proxy-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as M (basicInitialize, basicSet)-import qualified Data.Vector.Generic.New as N-import qualified Data.Vector.Unboxed as B-import qualified Data.Vector.Unboxed.Mutable as M+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as M (basicInitialize, basicSet)+import qualified Data.Vector.Generic.New as N+import qualified Data.Vector.Unboxed as B+import qualified Data.Vector.Unboxed.Mutable as M import Test.QuickCheck.Classes import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck mvectorTests :: TestTree-mvectorTests = testGroup "Data.Vector.Unboxed.Mutable.Bit"- [ testGroup "Data.Vector.Unboxed.Mutable functions"- [ testProperty "slice" prop_slice_def- , testProperty "grow" prop_grow_def- ]- , testGroup "Read/write Words"- [ testProperty "cloneFromWords" prop_cloneFromWords_def- , testProperty "cloneToWords" prop_cloneToWords_def- ]- , testProperty "reverseInPlace" prop_reverseInPlace_def- , testGroup "MVector laws" $ map (uncurry testProperty) $ lawsProperties $ muvectorLaws (Proxy :: Proxy Bit)- , testCase "basicInitialize 1" case_write_init_read1- , testCase "basicInitialize 2" case_write_init_read2- , testCase "basicInitialize 3" case_write_init_read3- , testCase "basicInitialize 4" case_write_init_read4- , testCase "basicSet 1" case_write_set_read1- , testCase "basicSet 2" case_write_set_read2- , testCase "basicSet 3" case_write_set_read3- , testCase "basicSet 4" case_write_set_read4- , testCase "basicSet 5" case_set_read1- , testCase "basicSet 6" case_set_read2- , testCase "basicSet 7" case_set_read3- , testCase "basicUnsafeCopy1" case_write_copy_read1- , testCase "basicUnsafeCopy2" case_write_copy_read2- , testCase "basicUnsafeCopy3" case_write_copy_read3- , testCase "basicUnsafeCopy4" case_write_copy_read4- , testCase "basicUnsafeCopy5" case_write_copy_read5-- , testProperty "flipBit" prop_flipBit+mvectorTests = testGroup+ "Data.Vector.Unboxed.Mutable.Bit"+ [ testGroup+ "Data.Vector.Unboxed.Mutable functions"+ [testProperty "slice" prop_slice_def, testProperty "grow" prop_grow_def]+ , testGroup+ "Read/write Words"+ [ testProperty "cloneFromWords" prop_cloneFromWords_def+ , testProperty "cloneToWords" prop_cloneToWords_def ]+ , testProperty "reverseInPlace" prop_reverseInPlace_def+ , testGroup "MVector laws"+ $ map (uncurry testProperty)+ $ lawsProperties+ $ muvectorLaws (Proxy :: Proxy Bit)+ , testCase "basicInitialize 1" case_write_init_read1+ , testCase "basicInitialize 2" case_write_init_read2+ , testCase "basicInitialize 3" case_write_init_read3+ , testCase "basicInitialize 4" case_write_init_read4+ , testCase "basicSet 1" case_write_set_read1+ , testCase "basicSet 2" case_write_set_read2+ , testCase "basicSet 3" case_write_set_read3+ , testCase "basicSet 4" case_write_set_read4+ , testCase "basicSet 5" case_set_read1+ , testCase "basicSet 6" case_set_read2+ , testCase "basicSet 7" case_set_read3+ , testCase "basicSet 8" case_set_read4+ , testCase "basicUnsafeCopy1" case_write_copy_read1+ , testCase "basicUnsafeCopy2" case_write_copy_read2+ , testCase "basicUnsafeCopy3" case_write_copy_read3+ , testCase "basicUnsafeCopy4" case_write_copy_read4+ , testCase "basicUnsafeCopy5" case_write_copy_read5+ , testProperty "flipBit" prop_flipBit+ ] prop_flipBit :: B.Vector Bit -> NonNegative Int -> Property prop_flipBit xs (NonNegative k) = k < B.length xs ==> ys === ys'- where- ys = B.modify (\v -> M.modify v complement k) xs- ys' = B.modify (\v -> flipBit v k) xs+ where+ ys = B.modify (\v -> M.modify v complement k) xs+ ys' = B.modify (\v -> flipBit v k) xs case_write_init_read1 :: IO () case_write_init_read1 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 2- M.write arr 0 (Bit True)- M.basicInitialize (M.slice 1 1 arr)- M.read arr 0+ arr <- M.new 2+ M.write arr 0 (Bit True)+ M.basicInitialize (M.slice 1 1 arr)+ M.read arr 0 case_write_init_read2 :: IO () case_write_init_read2 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 2- M.write arr 1 (Bit True)- M.basicInitialize (M.slice 0 1 arr)- M.read arr 1+ arr <- M.new 2+ M.write arr 1 (Bit True)+ M.basicInitialize (M.slice 0 1 arr)+ M.read arr 1 case_write_init_read3 :: IO ()-case_write_init_read3 = assertEqual "should be equal" (Bit True, Bit True) $ runST $ do+case_write_init_read3 =+ assertEqual "should be equal" (Bit True, Bit True) $ runST $ do arr <- M.new 2 M.write arr 0 (Bit True) M.write arr 1 (Bit True)@@ -87,7 +92,8 @@ (,) <$> M.read arr 0 <*> M.read arr 1 case_write_init_read4 :: IO ()-case_write_init_read4 = assertEqual "should be equal" (Bit True, Bit True) $ runST $ do+case_write_init_read4 =+ assertEqual "should be equal" (Bit True, Bit True) $ runST $ do arr <- M.new 3 M.write arr 0 (Bit True) M.write arr 2 (Bit True)@@ -96,20 +102,21 @@ case_write_set_read1 :: IO () case_write_set_read1 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 2- M.write arr 0 (Bit True)- M.basicSet (M.slice 1 1 arr) (Bit False)- M.read arr 0+ arr <- M.new 2+ M.write arr 0 (Bit True)+ M.basicSet (M.slice 1 1 arr) (Bit False)+ M.read arr 0 case_write_set_read2 :: IO () case_write_set_read2 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 2- M.write arr 1 (Bit True)- M.basicSet (M.slice 0 1 arr) (Bit False)- M.read arr 1+ arr <- M.new 2+ M.write arr 1 (Bit True)+ M.basicSet (M.slice 0 1 arr) (Bit False)+ M.read arr 1 case_write_set_read3 :: IO ()-case_write_set_read3 = assertEqual "should be equal" (Bit True, Bit True) $ runST $ do+case_write_set_read3 =+ assertEqual "should be equal" (Bit True, Bit True) $ runST $ do arr <- M.new 2 M.write arr 0 (Bit True) M.write arr 1 (Bit True)@@ -117,7 +124,8 @@ (,) <$> M.read arr 0 <*> M.read arr 1 case_write_set_read4 :: IO ()-case_write_set_read4 = assertEqual "should be equal" (Bit True, Bit True) $ runST $ do+case_write_set_read4 =+ assertEqual "should be equal" (Bit True, Bit True) $ runST $ do arr <- M.new 3 M.write arr 0 (Bit True) M.write arr 2 (Bit True)@@ -126,92 +134,98 @@ case_set_read1 :: IO () case_set_read1 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 1- M.basicSet arr (Bit True)- M.read arr 0+ arr <- M.new 1+ M.basicSet arr (Bit True)+ M.read arr 0 case_set_read2 :: IO () case_set_read2 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 2- M.basicSet (M.slice 1 1 arr) (Bit True)- M.read arr 1+ arr <- M.new 2+ M.basicSet (M.slice 1 1 arr) (Bit True)+ M.read arr 1 case_set_read3 :: IO () case_set_read3 = assertEqual "should be equal" (Bit True) $ runST $ do- arr <- M.new 192- M.basicSet (M.slice 71 121 arr) (Bit True)- M.read arr 145+ arr <- M.new 192+ M.basicSet (M.slice 71 121 arr) (Bit True)+ M.read arr 145 +case_set_read4 :: IO ()+case_set_read4 = assertEqual "should be equal" (Bit True) $ runST $ do+ arr <- M.slice 27 38 <$> M.new 65+ M.basicSet arr (Bit True)+ M.read arr 21+ case_write_copy_read1 :: IO () case_write_copy_read1 = assertEqual "should be equal" (Bit True) $ runST $ do- src <- M.slice 37 28 <$> M.new 65- M.write src 27 (Bit True)- dst <- M.slice 37 28 <$> M.new 65- M.copy dst src- M.read dst 27+ src <- M.slice 37 28 <$> M.new 65+ M.write src 27 (Bit True)+ dst <- M.slice 37 28 <$> M.new 65+ M.copy dst src+ M.read dst 27 case_write_copy_read2 :: IO () case_write_copy_read2 = assertEqual "should be equal" (Bit True) $ runST $ do- src <- M.slice 32 33 <$> M.new 65- M.write src 0 (Bit True)- dst <- M.slice 32 33 <$> M.new 65- M.copy dst src- M.read dst 0+ src <- M.slice 32 33 <$> M.new 65+ M.write src 0 (Bit True)+ dst <- M.slice 32 33 <$> M.new 65+ M.copy dst src+ M.read dst 0 case_write_copy_read3 :: IO () case_write_copy_read3 = assertEqual "should be equal" (Bit True) $ runST $ do- src <- M.slice 1 1 <$> M.new 2- M.write src 0 (Bit True)- dst <- M.slice 1 1 <$> M.new 2- M.copy dst src- M.read dst 0+ src <- M.slice 1 1 <$> M.new 2+ M.write src 0 (Bit True)+ dst <- M.slice 1 1 <$> M.new 2+ M.copy dst src+ M.read dst 0 case_write_copy_read4 :: IO () case_write_copy_read4 = assertEqual "should be equal" (Bit True) $ runST $ do- src <- M.slice 12 52 <$> M.new 64- M.write src 22 (Bit True)- dst <- M.slice 12 52 <$> M.new 64- M.copy dst src- M.read dst 22+ src <- M.slice 12 52 <$> M.new 64+ M.write src 22 (Bit True)+ dst <- M.slice 12 52 <$> M.new 64+ M.copy dst src+ M.read dst 22 case_write_copy_read5 :: IO () case_write_copy_read5 = assertEqual "should be equal" (Bit True) $ runST $ do- src <- M.slice 48 80 <$> M.new 128- M.write src 46 (Bit True)- dst <- M.slice 48 80 <$> M.new 128- M.copy dst src- M.read dst 46+ src <- M.slice 48 80 <$> M.new 128+ M.write src 46 (Bit True)+ dst <- M.slice 48 80 <$> M.new 128+ M.copy dst src+ M.read dst 46 -prop_slice_def :: Int -> Int -> N.New B.Vector Bit -> Bool-prop_slice_def s n xs = runST $ do+prop_slice_def+ :: NonNegative Int -> NonNegative Int -> N.New B.Vector Bit -> Property+prop_slice_def (NonNegative s) (NonNegative n) xs =+ s + n < V.length (V.new xs) ==> runST $ do let xs' = V.new xs- (s', n') = trimSlice s n (V.length xs') xs1 <- N.run xs- xs2 <- V.unsafeFreeze (M.slice s' n' xs1)-- return (B.toList xs2 == sliceList s' n' (B.toList xs'))+ xs2 <- V.unsafeFreeze (M.slice s n xs1)+ return (B.toList xs2 === sliceList s n (B.toList xs')) prop_grow_def :: B.Vector Bit -> NonNegative Int -> Bool prop_grow_def xs (NonNegative m) = runST $ do- let n = B.length xs- v0 <- B.thaw xs- v1 <- M.grow v0 m- fv0 <- B.freeze v0- fv1 <- B.freeze v1- return (fv0 == B.take n fv1)+ let n = B.length xs+ v0 <- B.thaw xs+ v1 <- M.grow v0 m+ fv0 <- B.freeze v0+ fv1 <- B.freeze v1+ return (fv0 == B.take n fv1) -prop_cloneFromWords_def :: N.New B.Vector Word -> Bool-prop_cloneFromWords_def ws- = runST (N.run ws >>= pure . castFromWordsM >>= V.unsafeFreeze)- == castFromWords (V.new ws)+prop_cloneFromWords_def :: N.New B.Vector Word -> Property+prop_cloneFromWords_def ws =+ runST (N.run ws >>= pure . castFromWordsM >>= V.unsafeFreeze)+ === castFromWords (V.new ws) -prop_cloneToWords_def :: N.New B.Vector Bit -> Bool-prop_cloneToWords_def xs- = runST (N.run xs >>= cloneToWordsM >>= V.unsafeFreeze)- == cloneToWords (V.new xs)+prop_cloneToWords_def :: N.New B.Vector Bit -> Property+prop_cloneToWords_def xs =+ runST (N.run xs >>= cloneToWordsM >>= V.unsafeFreeze)+ === cloneToWords (V.new xs) -prop_reverseInPlace_def :: N.New B.Vector Bit -> Bool-prop_reverseInPlace_def xs- = runST (N.run xs >>= \v -> reverseInPlace v >> V.unsafeFreeze v)- == B.reverse (V.new xs)+prop_reverseInPlace_def :: N.New B.Vector Bit -> Property+prop_reverseInPlace_def xs =+ runST (N.run xs >>= \v -> reverseInPlace v >> V.unsafeFreeze v)+ === B.reverse (V.new xs)
test/Tests/SetOps.hs view
@@ -10,120 +10,100 @@ import Test.Tasty.QuickCheck hiding ((.&.)) setOpTests :: TestTree-setOpTests = testGroup "Set operations"- [ testProperty "union" prop_union_def- , testProperty "intersection" prop_intersection_def- , testProperty "difference" prop_difference_def- , testProperty "symDiff" prop_symDiff_def-- , testProperty "unions" prop_unions_def- , testProperty "intersections" prop_unions_def-- , testProperty "invert" prop_invert_def-- , testProperty "select" prop_select_def- , testProperty "exclude" prop_exclude_def-- , testProperty "selectBits" prop_selectBits_def- , testProperty "excludeBits" prop_excludeBits_def-- , testProperty "countBits" prop_countBits_def- ]+setOpTests = testGroup+ "Set operations"+ [ testProperty "union" prop_union_def+ , testProperty "intersection" prop_intersection_def+ , testProperty "difference" prop_difference_def+ , testProperty "symDiff" prop_symDiff_def+ -- , testProperty "unions" prop_unions_def+ -- , testProperty "intersections" prop_unions_def+ , testProperty "invert" prop_invert_def+ , testProperty "select" prop_select_def+ , testProperty "exclude" prop_exclude_def+ , testProperty "selectBits" prop_selectBits_def+ , testProperty "excludeBits" prop_excludeBits_def+ , testProperty "countBits" prop_countBits_def+ ] union :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit union = zipBits (.|.) prop_union_def :: U.Vector Bit -> U.Vector Bit -> Property-prop_union_def xs ys- = U.toList (union xs ys)- === zipWith (.|.) (U.toList xs) (U.toList ys)+prop_union_def xs ys =+ U.toList (union xs ys) === zipWith (.|.) (U.toList xs) (U.toList ys) intersection :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit intersection = zipBits (.&.) prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Property-prop_intersection_def xs ys- = U.toList (intersection xs ys)- === zipWith (.&.) (U.toList xs) (U.toList ys)+prop_intersection_def xs ys =+ U.toList (intersection xs ys) === zipWith (.&.) (U.toList xs) (U.toList ys) difference :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit difference = zipBits (\a b -> a .&. complement b) prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Property-prop_difference_def xs ys- = U.toList (difference xs ys)- === zipWith diff (U.toList xs) (U.toList ys)- where- diff x y = x .&. complement y+prop_difference_def xs ys = U.toList (difference xs ys)+ === zipWith diff (U.toList xs) (U.toList ys)+ where diff x y = x .&. complement y symDiff :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit symDiff = zipBits xor prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Property-prop_symDiff_def xs ys- = U.toList (symDiff xs ys)- === zipWith xor (U.toList xs) (U.toList ys)+prop_symDiff_def xs ys =+ U.toList (symDiff xs ys) === zipWith xor (U.toList xs) (U.toList ys) unions :: NonEmpty (U.Vector Bit) -> U.Vector Bit unions (x :| xs) = U.slice 0 l $ U.modify (go xs) x- where- l = minimum $ fmap U.length (x :| xs)- go [] _ = pure ()- go (y : ys) acc = do- zipInPlace (.|.) y acc- go ys acc+ where+ l = minimum $ fmap U.length (x :| xs)+ go [] _ = pure ()+ go (y : ys) acc = do+ zipInPlace (.|.) y acc+ go ys acc prop_unions_def :: U.Vector Bit -> [U.Vector Bit] -> Property-prop_unions_def xs xss- = unions (xs :| xss)- === foldr union xs xss+prop_unions_def xs xss = unions (xs :| xss) === foldr union xs xss intersections :: NonEmpty (U.Vector Bit) -> U.Vector Bit intersections (x :| xs) = U.slice 0 l $ U.modify (go xs) x- where- l = minimum $ fmap U.length (x :| xs)- go [] _ = pure ()- go (y : ys) acc = do- zipInPlace (.&.) y acc- go ys acc+ where+ l = minimum $ fmap U.length (x :| xs)+ go [] _ = pure ()+ go (y : ys) acc = do+ zipInPlace (.&.) y acc+ go ys acc prop_intersections_def :: U.Vector Bit -> [U.Vector Bit] -> Property-prop_intersections_def xs xss- = intersections (xs :| xss)- === foldr intersection xs xss+prop_intersections_def xs xss =+ intersections (xs :| xss) === foldr intersection xs xss prop_invert_def :: U.Vector Bit -> Bool-prop_invert_def xs- = U.toList (U.modify invertInPlace xs)- == map complement (U.toList xs)+prop_invert_def xs =+ U.toList (U.modify invertInPlace xs) == map complement (U.toList xs) select :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a] select mask ws = U.toList (U.map snd (U.filter (unBit . fst) (U.zip mask ws))) prop_select_def :: U.Vector Bit -> U.Vector Word -> Bool-prop_select_def xs ys- = select xs ys- == [ x | (Bit True, x) <- zip (U.toList xs) (U.toList ys)]+prop_select_def xs ys =+ select xs ys == [ x | (Bit True, x) <- zip (U.toList xs) (U.toList ys) ] exclude :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a]-exclude mask ws = U.toList (U.map snd (U.filter (not . unBit . fst) (U.zip mask ws)))+exclude mask ws =+ U.toList (U.map snd (U.filter (not . unBit . fst) (U.zip mask ws))) prop_exclude_def :: U.Vector Bit -> U.Vector Word -> Bool-prop_exclude_def xs ys- = exclude xs ys- == [ x | (Bit False, x) <- zip (U.toList xs) (U.toList ys)]+prop_exclude_def xs ys =+ exclude xs ys == [ x | (Bit False, x) <- zip (U.toList xs) (U.toList ys) ] prop_selectBits_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_selectBits_def xs ys- = selectBits xs ys- == U.fromList (select xs ys)+prop_selectBits_def xs ys = selectBits xs ys == U.fromList (select xs ys) prop_excludeBits_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_excludeBits_def xs ys- = excludeBits xs ys- == U.fromList (exclude xs ys)+prop_excludeBits_def xs ys = excludeBits xs ys == U.fromList (exclude xs ys) prop_countBits_def :: U.Vector Bit -> Bool-prop_countBits_def xs- = countBits xs- == U.length (selectBits xs xs)+prop_countBits_def xs = countBits xs == U.length (selectBits xs xs)
test/Tests/Vector.hs view
@@ -11,103 +11,84 @@ import Test.Tasty.QuickCheck vectorTests :: TestTree-vectorTests = testGroup "Data.Vector.Unboxed.Bit"- [ testGroup "Data.Vector.Unboxed functions"- [ testProperty "toList . fromList == id" prop_toList_fromList- , testProperty "fromList . toList == id" prop_fromList_toList- , testProperty "slice" prop_slice_def- ]- , testProperty "cloneFromWords" prop_cloneFromWords_def- , testProperty "cloneToWords" prop_cloneToWords_def- , testProperty "reverse" prop_reverse_def- , testProperty "countBits" prop_countBits_def- , testProperty "listBits" prop_listBits_def- , testGroup "Boolean operations"- [ testProperty "and" prop_and_def- , testProperty "or" prop_or_def- ]- , testGroup "Search operations"- [ testProperty "first" prop_first_def- ]- , testGroup "nthBitIndex"- [ testCase "special case 1" case_nthBit_1-- , testProperty "matches bitIndex True" prop_nthBit_1- , testProperty "matches bitIndex False" prop_nthBit_2- , testProperty "matches sequence of bitIndex True" prop_nthBit_3- , testProperty "matches sequence of bitIndex False" prop_nthBit_4- , testProperty "matches countBits" prop_nthBit_5- ]+vectorTests = testGroup+ "Data.Vector.Unboxed.Bit"+ [ testGroup+ "Data.Vector.Unboxed functions"+ [ testProperty "toList . fromList == id" prop_toList_fromList+ , testProperty "fromList . toList == id" prop_fromList_toList+ , testProperty "slice" prop_slice_def ]+ , testProperty "cloneFromWords" prop_cloneFromWords_def+ , testProperty "cloneToWords" prop_cloneToWords_def+ , testProperty "reverse" prop_reverse_def+ , testProperty "countBits" prop_countBits_def+ , testProperty "listBits" prop_listBits_def+ , testGroup "Boolean operations"+ [testProperty "and" prop_and_def, testProperty "or" prop_or_def]+ , testGroup "Search operations" [testProperty "first" prop_first_def]+ , testGroup+ "nthBitIndex"+ [ testCase "special case 1" case_nthBit_1+ , testProperty "matches bitIndex True" prop_nthBit_1+ , testProperty "matches bitIndex False" prop_nthBit_2+ , testProperty "matches sequence of bitIndex True" prop_nthBit_3+ , testProperty "matches sequence of bitIndex False" prop_nthBit_4+ , testProperty "matches countBits" prop_nthBit_5+ ]+ ] prop_toList_fromList :: [Bit] -> Bool-prop_toList_fromList xs =- U.toList (U.fromList xs) == xs+prop_toList_fromList xs = U.toList (U.fromList xs) == xs prop_fromList_toList :: U.Vector Bit -> Bool-prop_fromList_toList xs =- U.fromList (U.toList xs) == xs+prop_fromList_toList xs = U.fromList (U.toList xs) == xs prop_slice_def :: Int -> Int -> U.Vector Bit -> Bool-prop_slice_def s n xs- = sliceList s' n' (U.toList xs)- == U.toList (U.slice s' n' xs)- where- (s', n') = trimSlice s n (U.length xs)+prop_slice_def s n xs = sliceList s' n' (U.toList xs)+ == U.toList (U.slice s' n' xs)+ where (s', n') = trimSlice s n (U.length xs) prop_cloneFromWords_def :: U.Vector Word -> Property-prop_cloneFromWords_def ws- = U.toList (castFromWords ws)- === concatMap wordToBitList (U.toList ws)+prop_cloneFromWords_def ws =+ U.toList (castFromWords ws) === concatMap wordToBitList (U.toList ws) prop_cloneToWords_def :: U.Vector Bit -> Bool-prop_cloneToWords_def xs- = U.toList (cloneToWords xs)- == loop (U.toList xs)- where- loop [] = []- loop bs = case packBitsToWord bs of- (w, bs') -> w : loop bs'+prop_cloneToWords_def xs = U.toList (cloneToWords xs) == loop (U.toList xs)+ where+ loop [] = []+ loop bs = case packBitsToWord bs of+ (w, bs') -> w : loop bs' prop_reverse_def :: U.Vector Bit -> Bool-prop_reverse_def xs- = reverse (U.toList xs)- == U.toList (U.modify reverseInPlace xs)+prop_reverse_def xs =+ reverse (U.toList xs) == U.toList (U.modify reverseInPlace xs) prop_countBits_def :: U.Vector Bit -> Bool-prop_countBits_def xs- = countBits xs- == length (filter unBit (U.toList xs))+prop_countBits_def xs = countBits xs == length (filter unBit (U.toList xs)) prop_listBits_def :: U.Vector Bit -> Property-prop_listBits_def xs- = listBits xs- === [ i | (i,x) <- zip [0..] (U.toList xs), unBit x]+prop_listBits_def xs =+ listBits xs === [ i | (i, x) <- zip [0 ..] (U.toList xs), unBit x ] and :: U.Vector Bit -> Bool and xs = case bitIndex (Bit False) xs of- Nothing -> True- Just{} -> False+ Nothing -> True+ Just{} -> False -prop_and_def :: U.Vector Bit -> Bool-prop_and_def xs- = and xs- == all unBit (U.toList xs)+prop_and_def :: U.Vector Bit -> Property+prop_and_def xs = and xs === all unBit (U.toList xs) or :: U.Vector Bit -> Bool or xs = case bitIndex (Bit True) xs of- Nothing -> False- Just{} -> True+ Nothing -> False+ Just{} -> True -prop_or_def :: U.Vector Bit -> Bool-prop_or_def xs- = or xs- == any unBit (U.toList xs)+prop_or_def :: U.Vector Bit -> Property+prop_or_def xs = or xs === any unBit (U.toList xs) prop_first_def :: Bit -> U.Vector Bit -> Bool-prop_first_def b xs- = bitIndex b xs- == findIndex (b ==) (U.toList xs)+prop_first_def b xs = bitIndex b xs == findIndex (b ==) (U.toList xs) prop_nthBit_1 :: U.Vector Bit -> Property prop_nthBit_1 xs = bitIndex (Bit True) xs === nthBitIndex (Bit True) 1 xs@@ -117,28 +98,31 @@ prop_nthBit_3 :: Positive Int -> U.Vector Bit -> Property prop_nthBit_3 (Positive n) xs = case nthBitIndex (Bit True) (n + 1) xs of- Nothing -> property True- Just i -> case bitIndex (Bit True) xs of- Nothing -> property False- Just j -> case nthBitIndex (Bit True) n (U.drop (j + 1) xs) of- Nothing -> property False- Just k -> i === j + k + 1+ Nothing -> property True+ Just i -> case bitIndex (Bit True) xs of+ Nothing -> property False+ Just j -> case nthBitIndex (Bit True) n (U.drop (j + 1) xs) of+ Nothing -> property False+ Just k -> i === j + k + 1 prop_nthBit_4 :: Positive Int -> U.Vector Bit -> Property prop_nthBit_4 (Positive n) xs = case nthBitIndex (Bit False) (n + 1) xs of- Nothing -> property True- Just i -> case bitIndex (Bit False) xs of- Nothing -> property False- Just j -> case nthBitIndex (Bit False) n (U.drop (j + 1) xs) of- Nothing -> property False- Just k -> i === j + k + 1+ Nothing -> property True+ Just i -> case bitIndex (Bit False) xs of+ Nothing -> property False+ Just j -> case nthBitIndex (Bit False) n (U.drop (j + 1) xs) of+ Nothing -> property False+ Just k -> i === j + k + 1 prop_nthBit_5 :: Positive Int -> U.Vector Bit -> Property-prop_nthBit_5 (Positive n) xs = n <= countBits xs ==>- case nthBitIndex (Bit True) n xs of- Nothing -> property False- Just i -> countBits (U.take (i + 1) xs) === n+prop_nthBit_5 (Positive n) xs =+ n <= countBits xs ==> case nthBitIndex (Bit True) n xs of+ Nothing -> property False+ Just i -> countBits (U.take (i + 1) xs) === n case_nthBit_1 :: IO ()-case_nthBit_1 = assertEqual "should be equal" Nothing $- nthBitIndex (Bit True) 1 $ U.slice 61 4 $ U.replicate 100 (Bit False)+case_nthBit_1 =+ assertEqual "should be equal" Nothing+ $ nthBitIndex (Bit True) 1+ $ U.slice 61 4+ $ U.replicate 100 (Bit False)