diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,118 @@ +# bitvec [![Build Status](https://travis-ci.org/Bodigrim/bitvec.svg)](https://travis-ci.org/Bodigrim/bitvec) [![Hackage](http://img.shields.io/hackage/v/bitvec.svg)](https://hackage.haskell.org/package/bitvec) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/bitvec/badge)](https://matrix.hackage.haskell.org/package/bitvec) [![Stackage LTS](http://stackage.org/package/bitvec/badge/lts)](http://stackage.org/lts/package/bitvec) [![Stackage Nightly](http://stackage.org/package/bitvec/badge/nightly)](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. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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 diff --git a/bench/Bench/BitIndex.hs b/bench/Bench/BitIndex.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/BitIndex.hs @@ -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 diff --git a/bench/Bench/Intersection.hs b/bench/Bench/Intersection.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Intersection.hs @@ -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 diff --git a/bench/Bench/Invert.hs b/bench/Bench/Invert.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Invert.hs @@ -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 diff --git a/bench/Bench/RandomFlip.hs b/bench/Bench/RandomFlip.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/RandomFlip.hs @@ -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 diff --git a/bench/Bench/RandomRead.hs b/bench/Bench/RandomRead.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/RandomRead.hs @@ -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 diff --git a/bench/Bench/RandomWrite.hs b/bench/Bench/RandomWrite.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/RandomWrite.hs @@ -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 diff --git a/bench/Bench/Reverse.hs b/bench/Bench/Reverse.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Reverse.hs @@ -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 diff --git a/bench/Bench/Union.hs b/bench/Bench/Union.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Union.hs @@ -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 diff --git a/bitvec.cabal b/bitvec.cabal --- a/bitvec.cabal +++ b/bitvec.cabal @@ -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 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +# 1.0.0.1 + +* Performance improvements. + # 1.0.0.0 * Redesign API from the scratch. diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs --- a/src/Data/Bit.hs +++ b/src/Data/Bit.hs @@ -7,8 +7,8 @@ -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- --- 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 -- --- 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) diff --git a/src/Data/Bit/Immutable.hs b/src/Data/Bit/Immutable.hs --- a/src/Data/Bit/Immutable.hs +++ b/src/Data/Bit/Immutable.hs @@ -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 . +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 . +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) diff --git a/src/Data/Bit/Internal.hs b/src/Data/Bit/Internal.hs --- a/src/Data/Bit/Internal.hs +++ b/src/Data/Bit/Internal.hs @@ -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 . -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 . -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 diff --git a/src/Data/Bit/Mutable.hs b/src/Data/Bit/Mutable.hs --- a/src/Data/Bit/Mutable.hs +++ b/src/Data/Bit/Mutable.hs @@ -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 diff --git a/src/Data/Bit/Select1.hs b/src/Data/Bit/Select1.hs --- a/src/Data/Bit/Select1.hs +++ b/src/Data/Bit/Select1.hs @@ -13,8 +13,8 @@ #endif module Data.Bit.Select1 - ( select1 - ) where + ( select1 + ) where #include "MachDeps.h" diff --git a/src/Data/Bit/Utils.hs b/src/Data/Bit/Utils.hs --- a/src/Data/Bit/Utils.hs +++ b/src/Data/Bit/Utils.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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) diff --git a/test/Support.hs b/test/Support.hs --- a/test/Support.hs +++ b/test/Support.hs @@ -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) diff --git a/test/Tests/MVector.hs b/test/Tests/MVector.hs --- a/test/Tests/MVector.hs +++ b/test/Tests/MVector.hs @@ -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) diff --git a/test/Tests/SetOps.hs b/test/Tests/SetOps.hs --- a/test/Tests/SetOps.hs +++ b/test/Tests/SetOps.hs @@ -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) diff --git a/test/Tests/Vector.hs b/test/Tests/Vector.hs --- a/test/Tests/Vector.hs +++ b/test/Tests/Vector.hs @@ -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)