bitvec 1.0.3.0 → 1.1.0.0
raw patch · 27 files changed
+903/−497 lines, 27 filesdep +bytestringdep +ghc-bignumdep −semigroupsPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, ghc-bignum
Dependencies removed: semigroups
API changes (from Hackage documentation)
+ Data.Bit: cloneFromByteString :: ByteString -> Vector Bit
+ Data.Bit: cloneToByteString :: Vector Bit -> ByteString
+ Data.Bit: mapBits :: (forall a. Bits a => a -> a) -> Vector Bit -> Vector Bit
+ Data.Bit: mapInPlace :: PrimMonad m => (forall a. Bits a => a -> a) -> MVector (PrimState m) Bit -> m ()
+ Data.Bit.ThreadSafe: cloneFromByteString :: ByteString -> Vector Bit
+ Data.Bit.ThreadSafe: cloneToByteString :: Vector Bit -> ByteString
+ Data.Bit.ThreadSafe: mapBits :: (forall a. Bits a => a -> a) -> Vector Bit -> Vector Bit
+ Data.Bit.ThreadSafe: mapInPlace :: PrimMonad m => (forall a. Bits a => a -> a) -> MVector (PrimState m) Bit -> m ()
Files
- LICENSE +1/−1
- README.md +17/−16
- bench/Bench/GCD.hs +3/−3
- bench/Bench/Intersection.hs +1/−1
- bench/Bench/Invert.hs +1/−1
- bench/Bench/Product.hs +1/−1
- bench/Bench/RandomRead.hs +1/−1
- bench/Bench/Remainder.hs +10/−1
- bench/Bench/Reverse.hs +1/−1
- bench/Bench/Sum.hs +1/−1
- bench/Bench/Union.hs +1/−1
- bitvec.cabal +25/−19
- changelog.md +9/−0
- src/Data/Bit.hs +7/−2
- src/Data/Bit/F2Poly.hs +68/−65
- src/Data/Bit/Gmp.hs +0/−36
- src/Data/Bit/Immutable.hs +106/−40
- src/Data/Bit/Internal.hs +13/−42
- src/Data/Bit/Mutable.hs +76/−42
- src/Data/Bit/Utils.hs +11/−8
- test/Main.hs +10/−72
- test/Support.hs +32/−14
- test/Tests/Conc.hs +3/−1
- test/Tests/F2Poly.hs +122/−0
- test/Tests/MVector.hs +75/−33
- test/Tests/SetOps.hs +109/−51
- test/Tests/Vector.hs +199/−44
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2019 Andrew Lelechenko, 2012-2016 James Cook+Copyright (c) 2019-2020 Andrew Lelechenko, 2012-2016 James Cook All rights reserved.
README.md view
@@ -1,4 +1,4 @@-# bitvec [](https://travis-ci.org/Bodigrim/bitvec) [](https://hackage.haskell.org/package/bitvec) [](https://matrix.hackage.haskell.org/package/bitvec) [](http://stackage.org/lts/package/bitvec) [](http://stackage.org/nightly/package/bitvec)+# bitvec [](https://github.com/Bodigrim/bitvec/actions?query=workflow%3Aci) [](https://travis-ci.com/Bodigrim/bitvec) [](https://hackage.haskell.org/package/bitvec) [](https://matrix.hackage.haskell.org/package/bitvec) [](http://stackage.org/lts/package/bitvec) [](http://stackage.org/nightly/package/bitvec) [](https://coveralls.io/github/Bodigrim/bitvec) A newtype over `Bool` with a better `Vector` instance: 8x less memory, up to 1000x faster. @@ -120,8 +120,10 @@ * As a 64k-long unboxed `Vector Bool`, implementing union as `zipWith (||)`. * As a 64k-long unboxed `Vector Bit`, implementing union as `zipBits (.|.)`. -In our benchmarks (see `bench` folder) for not-too-sparse sets-the union of `Vector Bit` evaluates 24x-36x faster than the union of `IntSet`+When flag `libgmp` is enabled,+according to our benchmarks (see `bench` folder)+the union of `Vector Bit` evaluates 24x-36x faster+than the union of not-too-sparse `IntSet` and stunningly outperforms `Vector Bool` 500x-1000x. ## Binary polynomials@@ -145,21 +147,15 @@ ## Package flags -This package supports the following flags to facilitate dependency management.-Disabling them does not diminish `bitvec`'s capabilities, but makes certain operations slower.--* Flag `integer-gmp`, enabled by default.-- Depend on `integer-gmp` package and use it to speed up operations on binary polynomials.- Normally `integer-gmp` is shipped with core libraries anyways, so there is little to gain- from disabling it, unless you use a custom build of GHC.--* Flag `libgmp`, enabled by default.+* Flag `libgmp`, disabled by default. - Link against [GMP](https://gmplib.org/) library and use it to for ultimate performance of+ Link against [GMP](https://gmplib.org/) library for the ultimate performance of `zipBits`, `invertBits` and `countBits`. GMP is readily available on most machines- (`brew install gmp` on macOS), but you may find useful to disable this flag working- with exotic setup.+ ([`apt-get install libgmp-dev`](https://packages.ubuntu.com/focal/libgmp-dev) on Ubuntu,+ [`brew install gmp`](https://formulae.brew.sh/formula/gmp)+ or [`port install gmp`](https://ports.macports.org/port/gmp/summary) on macOS,+ [`pacman -S mingw-w64-x86_64-gmp`](https://packages.msys2.org/package/mingw-w64-x86_64-gmp) on MinGW),+ so users are strongly encouraged to enable it whenever possible. ## Similar packages @@ -170,3 +166,8 @@ * [`array`](https://hackage.haskell.org/package/array) is memory-efficient for `Bool`, but lacks a handy `Vector` interface and is not thread-safe.++## Additional resources++* __Bit vectors without compromises__, Haskell Love, 31.07.2020:+ [slides](https://github.com/Bodigrim/my-talks/raw/master/haskelllove2020/slides.pdf), [video](https://youtu.be/HhpH8DKFBls).
bench/Bench/GCD.hs view
@@ -11,15 +11,15 @@ import System.Random randomBools :: [Bool]-randomBools = map (> (0 :: Int)) $ randoms $ mkStdGen $ 42+randomBools = map (> (0 :: Int)) $ randoms $ mkStdGen 42 randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a-randomVec f k = U.fromList $ map f $ take n $ randomBools+randomVec f k = U.fromList $ map f $ take n randomBools where n = 1 `shiftL` k randomVec' :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a-randomVec' f k = U.fromList $ map f $ take n $ drop n $ randomBools+randomVec' f k = U.fromList $ map f $ take n $ drop n randomBools where n = 1 `shiftL` k
bench/Bench/Intersection.hs view
@@ -13,7 +13,7 @@ randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bench/Bench/Invert.hs view
@@ -12,7 +12,7 @@ randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bench/Bench/Product.hs view
@@ -12,7 +12,7 @@ randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bench/Bench/RandomRead.hs view
@@ -15,7 +15,7 @@ randomVec :: [Bool] randomVec- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bench/Bench/Remainder.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} module Bench.Remainder@@ -11,12 +12,16 @@ import qualified Data.Vector.Unboxed.Mutable as MU import Gauge.Main import GHC.Exts+#ifdef MIN_VERSION_ghc_bignum+import GHC.Num.Integer+#else import GHC.Integer.Logarithms+#endif import System.Random randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42@@ -47,7 +52,11 @@ binRem :: Integer -> Integer -> Integer binRem x y = go x where+#ifdef MIN_VERSION_ghc_bignum+ binLog n = I# (word2Int# (integerLog2# n))+#else binLog n = I# (integerLog2# n)+#endif ly = binLog y go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))
bench/Bench/Reverse.hs view
@@ -12,7 +12,7 @@ randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bench/Bench/Sum.hs view
@@ -13,7 +13,7 @@ randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bench/Bench/Union.hs view
@@ -13,7 +13,7 @@ randomBools :: [Bool] randomBools- = map (\i -> if i > (0 :: Int) then True else False)+ = map (> (0 :: Int)) . randoms . mkStdGen $ 42
bitvec.cabal view
@@ -1,10 +1,10 @@ name: bitvec-version: 1.0.3.0+version: 1.1.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE-copyright: 2019 Andrew Lelechenko, 2012-2016 James Cook+copyright: 2019-2020 Andrew Lelechenko, 2012-2016 James Cook maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> homepage: https://github.com/Bodigrim/bitvec synopsis: Space-efficient bit vectors@@ -46,7 +46,7 @@ author: Andrew Lelechenko <andrew.lelechenko@gmail.com>, James Cook <mokus@deepbondi.net> -tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 GHC ==8.8.2 GHC ==8.8.3 GHC ==8.10.1+tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 GHC ==8.8.2 GHC ==8.8.4 GHC ==8.10.2 extra-source-files: changelog.md README.md@@ -55,13 +55,12 @@ type: git location: git://github.com/Bodigrim/bitvec.git -flag integer-gmp- description: Use integer-gmp package for binary polynomials- default: True- flag libgmp- description: Link against GMP library- default: True+ description:+ Link against GMP library for the ultimate performance of+ `zipBits`, `invertBits` and `countBits`. Users are strongly encouraged+ to enable this flag whenever possible.+ default: False library exposed-modules:@@ -69,13 +68,11 @@ Data.Bit.ThreadSafe build-depends: base >=4.9 && <5,+ bytestring >=0.10, deepseq, ghc-prim, primitive >=0.5, vector >=0.11- if impl(ghc <8.0)- build-depends:- semigroups >=0.8 default-language: Haskell2010 hs-source-dirs: src other-modules:@@ -92,9 +89,12 @@ Data.Bit.Utils ghc-options: -O2 -Wall include-dirs: src- if flag(integer-gmp) && impl(ghc >=8.0.1)++ if impl(ghc <9.0) build-depends: integer-gmp- cpp-options: -DUseIntegerGmp+ else+ build-depends: ghc-bignum+ if flag(libgmp) extra-libraries: gmp cpp-options: -DUseLibGmp@@ -105,21 +105,18 @@ build-depends: base, bitvec,- integer-gmp, primitive >=0.5, quickcheck-classes >=0.6.1, vector >=0.11, tasty, tasty-hunit, tasty-quickcheck- if impl(ghc <8.0)- build-depends:- semigroups >=0.8 default-language: Haskell2010 hs-source-dirs: test other-modules: Support Tests.Conc+ Tests.F2Poly Tests.MVector Tests.MVectorTS Tests.SetOps@@ -128,13 +125,17 @@ ghc-options: -Wall -threaded -rtsopts include-dirs: test + if impl(ghc <9.0)+ build-depends: integer-gmp+ else+ build-depends: ghc-bignum+ benchmark gauge build-depends: base, bitvec, containers, gauge,- integer-gmp, random, vector type: exitcode-stdio-1.0@@ -155,3 +156,8 @@ Bench.Sum Bench.Union ghc-options: -O2 -Wall++ if impl(ghc <9.0)+ build-depends: integer-gmp+ else+ build-depends: ghc-bignum
changelog.md view
@@ -1,3 +1,12 @@+# 1.1.0.0++* Fix a grave bug in `bitIndex`.+* Remove `integer-gmp` flag.+* Make `libgmp` flag disabled by default.+ Users are strongly encouraged to enable it whenever possible.+* Add `mapBits` and `mapInPlace` functions.+* Add `cloneToByteString` and `cloneFromByteString` functions.+ # 1.0.3.0 * Add `Bits (Vector Bit)` instance.
src/Data/Bit.hs view
@@ -3,7 +3,7 @@ #ifndef BITVEC_THREADSAFE -- | -- Module: Data.Bit--- Copyright: (c) 2019 Andrew Lelechenko, 2012-2016 James Cook+-- Copyright: (c) 2019-2020 Andrew Lelechenko, 2012-2016 James Cook -- Licence: BSD3 -- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> --@@ -13,7 +13,7 @@ #else -- | -- Module: Data.Bit.ThreadSafe--- Copyright: (c) 2019 Andrew Lelechenko, 2012-2016 James Cook+-- Copyright: (c) 2019-2020 Andrew Lelechenko, 2012-2016 James Cook -- Licence: BSD3 -- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> --@@ -35,8 +35,12 @@ , castToWords8 , cloneToWords8 + , cloneFromByteString+ , cloneToByteString+ -- * Immutable operations , zipBits+ , mapBits , invertBits , reverseBits , bitIndex@@ -53,6 +57,7 @@ -- * Mutable operations , zipInPlace+ , mapInPlace , invertInPlace , reverseInPlace , selectBitsInPlace
src/Data/Bit/F2Poly.hs view
@@ -38,17 +38,19 @@ import Data.Coerce import Data.Primitive.ByteArray import Data.Typeable+import qualified Data.Vector.Primitive as P import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU+import GHC.Exts import GHC.Generics import Numeric -#if UseIntegerGmp-import qualified Data.Vector.Primitive as P-import GHC.Exts+#ifdef MIN_VERSION_ghc_bignum+import GHC.Num.BigNat+import GHC.Num.Integer+#else import GHC.Integer.GMP.Internals import GHC.Integer.Logarithms-import Unsafe.Coerce #endif -- | Binary polynomials of one variable, backed@@ -67,19 +69,27 @@ unF2Poly :: U.Vector Bit -- ^ Convert 'F2Poly' to a vector of coefficients -- (first element corresponds to a constant term).+ --+ -- >>> :set -XBinaryLiterals+ -- >>> unF2Poly 0b1101+ -- [1,0,1,1] } deriving (Eq, Ord, Typeable, Generic, NFData) -- | Make 'F2Poly' from a list of coefficients -- (first element corresponds to a constant term).+--+-- >>> :set -XOverloadedLists+-- >>> toF2Poly [1,0,1,1,0,0]+-- 0b1101 toF2Poly :: U.Vector Bit -> F2Poly toF2Poly xs = F2Poly $ dropWhileEnd $ castFromWords $ cloneToWords xs --- | Valid 'F2Poly' has offset 0 and no trailing garbage.-_isValid :: F2Poly -> Bool-_isValid (F2Poly (BitVec o l arr)) = o == 0 && l == l'- where- l' = U.length $ dropWhileEnd $ BitVec 0 (sizeofByteArray arr `shiftL` 3) arr+-- -- | Valid 'F2Poly' has offset 0 and no trailing garbage.+-- _isValid :: F2Poly -> Bool+-- _isValid (F2Poly (BitVec o l arr)) = o == 0 && l == l'+-- where+-- l' = U.length $ dropWhileEnd $ BitVec 0 (sizeofByteArray arr `shiftL` 3) arr -- | Addition and multiplication are evaluated modulo 2. --@@ -94,14 +104,24 @@ abs = id signum = const (F2Poly (U.singleton (Bit True))) (*) = coerce ((dropWhileEnd .) . karatsuba)-#if UseIntegerGmp+#ifdef MIN_VERSION_ghc_bignum fromInteger !n = case n of- S# i# -> F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#))))+ IS i#+ | n < 0 -> throw Underflow+ | otherwise -> F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#))))+ $ ByteArray (bigNatFromWord# (int2Word# i#))+ IP bn# -> F2Poly $ BitVec 0 (I# (word2Int# (integerLog2# n)) + 1) $ ByteArray bn#+ IN{} -> throw Underflow+ {-# INLINE fromInteger #-}+#else+ fromInteger !n = case n of+ S# i#+ | n < 0 -> throw Underflow+ | otherwise -> F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#)))) $ fromBigNat $ wordToBigNat (int2Word# i#) Jp# bn# -> F2Poly $ BitVec 0 (I# (integerLog2# n) + 1) $ fromBigNat bn#- Jn#{} -> error "F2Poly.fromInteger: argument must be non-negative"-#else- fromInteger = F2Poly . dropWhileEnd . integerToBits+ Jn#{} -> throw Underflow+ {-# INLINE fromInteger #-} #endif {-# INLINE (+) #-}@@ -110,15 +130,15 @@ {-# INLINE abs #-} {-# INLINE signum #-} {-# INLINE (*) #-}- {-# INLINE fromInteger #-} instance Enum F2Poly where fromEnum = fromIntegral-#if UseIntegerGmp+#ifdef MIN_VERSION_ghc_bignum toEnum !(I# i#) = F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#))))- $ fromBigNat $ wordToBigNat (int2Word# i#)+ $ ByteArray (bigNatFromWord# (int2Word# i#)) #else- toEnum = fromIntegral+ toEnum !(I# i#) = F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#))))+ $ fromBigNat $ wordToBigNat (int2Word# i#) #endif instance Real F2Poly where@@ -127,7 +147,11 @@ -- | 'toInteger' converts a binary polynomial, encoded as 'F2Poly', -- to 'Integer' encoding. instance Integral F2Poly where- toInteger = bitsToInteger . unF2Poly+#ifdef MIN_VERSION_ghc_bignum+ toInteger xs = integerFromBigNat# (bitsToByteArray (unF2Poly xs))+#else+ toInteger xs = bigNatToInteger (BN# (bitsToByteArray (unF2Poly xs)))+#endif quotRem (F2Poly xs) (F2Poly ys) = (F2Poly (dropWhileEnd qs), F2Poly (dropWhileEnd rs)) where (qs, rs) = quotRemBits xs ys@@ -144,9 +168,16 @@ -> U.Vector Bit xorBits (BitVec _ 0 _) ys = ys xorBits xs (BitVec _ 0 _) = xs-#if UseIntegerGmp -- GMP has platform-dependent ASM implementations for mpn_xor_n, -- which are impossible to beat by native Haskell.+#ifdef MIN_VERSION_ghc_bignum+xorBits (BitVec 0 lx (ByteArray xarr)) (BitVec 0 ly (ByteArray yarr)) = case lx `compare` ly of+ LT -> BitVec 0 ly zs+ EQ -> dropWhileEnd $ BitVec 0 (lx `min` (sizeofByteArray zs `shiftL` 3)) zs+ GT -> BitVec 0 lx zs+ where+ zs = ByteArray (xarr `bigNatXor` yarr)+#else xorBits (BitVec 0 lx xarr) (BitVec 0 ly yarr) = case lx `compare` ly of LT -> BitVec 0 ly zs EQ -> dropWhileEnd $ BitVec 0 (lx `min` (sizeofByteArray zs `shiftL` 3)) zs@@ -170,33 +201,31 @@ karatsuba :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit karatsuba xs ys- | karatsubaThreshold < 2 * wordSize- = error $ "karatsubaThreshold must be >= " ++ show (2 * wordSize) | xs == ys = sqrBits xs | lenXs <= karatsubaThreshold || lenYs <= karatsubaThreshold = mulBits xs ys | otherwise = runST $ do zs <- MU.unsafeNew lenZs- forM_ [0, wordSize .. lenZs - 1] $ \k -> do+ forM_ [0 .. divWordSize (lenZs - 1)] $ \k -> do let z0 = indexWord0 zs0 k z11 = indexWord0 zs11 (k - m) z10 = indexWord0 zs0 (k - m) z12 = indexWord0 zs2 (k - m) z2 = indexWord0 zs2 (k - 2 * m)- writeWord zs k (z0 `xor` z11 `xor` z10 `xor` z12 `xor` z2)+ writeWord zs (mulWordSize k) (z0 `xor` z11 `xor` z10 `xor` z12 `xor` z2) U.unsafeFreeze zs where lenXs = U.length xs lenYs = U.length ys lenZs = lenXs + lenYs - 1 - m' = ((lenXs `min` lenYs) + 1) `quot` 2- m = m' - modWordSize m'+ m = (min lenXs lenYs + 1) `unsafeShiftR` (lgWordSize + 1)+ m' = mulWordSize m - xs0 = U.unsafeSlice 0 m xs- xs1 = U.unsafeSlice m (lenXs - m) xs- ys0 = U.unsafeSlice 0 m ys- ys1 = U.unsafeSlice m (lenYs - m) ys+ xs0 = U.unsafeSlice 0 m' xs+ xs1 = U.unsafeSlice m' (lenXs - m') xs+ ys0 = U.unsafeSlice 0 m' ys+ ys1 = U.unsafeSlice m' (lenYs - m') ys xs01 = xorBits xs0 xs1 ys01 = xorBits ys0 ys1@@ -205,17 +234,14 @@ zs11 = karatsuba xs01 ys01 indexWord0 :: U.Vector Bit -> Int -> Word-indexWord0 bv i- | i <= - wordSize = 0- | lenI <= 0 = 0- | i < 0, lenI >= wordSize = word0- | i < 0 = word0 .&. loMask lenI- | lenI >= wordSize = word- | otherwise = word .&. loMask lenI+indexWord0 bv i'+ | i < 0 || lenI <= 0 = 0+ | lenI >= wordSize = word+ | otherwise = word .&. loMask lenI where+ i = mulWordSize i' lenI = U.length bv - i word = indexWord bv i- word0 = indexWord bv 0 `unsafeShiftL` (- i) mulBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit mulBits xs ys@@ -278,42 +304,19 @@ 0 -> go (n - wordSize) w -> n - countLeadingZeros w -#if UseIntegerGmp- bitsToByteArray :: U.Vector Bit -> ByteArray# bitsToByteArray xs = arr where ys = if U.null xs then U.singleton 0 else cloneToWords xs !(P.Vector _ _ (ByteArray arr)) = toPrimVector ys +#ifdef MIN_VERSION_ghc_bignum+#else fromBigNat :: BigNat -> ByteArray-fromBigNat = unsafeCoerce--- fromBigNat (BN# arr) = ByteArray arr+fromBigNat (BN# arr) = ByteArray arr toBigNat :: ByteArray -> BigNat-toBigNat = unsafeCoerce--- toBigNat (ByteArray arr) = BN# arr--bitsToInteger :: U.Vector Bit -> Integer-bitsToInteger xs = bigNatToInteger (BN# (bitsToByteArray xs))--#else--integerToBits :: Integer -> U.Vector Bit-integerToBits x = U.generate (bitLen x) (Bit . testBit x)--bitLen :: Integer -> Int-bitLen x- = fst- $ head- $ dropWhile (\(_, b) -> x >= b)- $ map (\a -> (a, 1 `shiftL` a))- $ map (1 `shiftL`)- $ [lgWordSize..]--bitsToInteger :: U.Vector Bit -> Integer-bitsToInteger = U.ifoldl' (\acc i (Bit b) -> if b then acc `setBit` i else acc) 0-+toBigNat (ByteArray arr) = BN# arr #endif -- | Execute the extended Euclidean algorithm.
src/Data/Bit/Gmp.hs view
@@ -6,10 +6,6 @@ module Data.Bit.Gmp ( mpnCom- , mpnLshift- , mpnRshift- , mpnScan0- , mpnScan1 , mpnPopcount , mpnAndN , mpnIorN@@ -34,38 +30,6 @@ mpnCom (MutableByteArray res#) (ByteArray arg#) (I# limbs#) = unsafeIOToST (mpn_com res# arg# limbs#) {-# INLINE mpnCom #-}--foreign import ccall unsafe "__gmpn_lshift"- mpn_lshift :: MutableByteArray# s -> ByteArray# -> Int# -> Word# -> IO Word--mpnLshift :: MutableByteArray s -> ByteArray -> Int -> Word -> ST s Word-mpnLshift (MutableByteArray res#) (ByteArray arg#) (I# limbs#) (W# count#) =- unsafeIOToST (mpn_lshift res# arg# limbs# count#)-{-# INLINE mpnLshift #-}--foreign import ccall unsafe "__gmpn_rshift"- mpn_rshift :: MutableByteArray# s -> ByteArray# -> Int# -> Word# -> IO Word--mpnRshift :: MutableByteArray s -> ByteArray -> Int -> Word -> ST s Word-mpnRshift (MutableByteArray res#) (ByteArray arg#) (I# limbs#) (W# count#) =- unsafeIOToST (mpn_rshift res# arg# limbs# count#)-{-# INLINE mpnRshift #-}--foreign import ccall unsafe "__gmpn_scan0"- mpn_scan0 :: ByteArray# -> Word# -> IO Word--mpnScan0 :: ByteArray -> Word -> Word-mpnScan0 (ByteArray arg#) (W# bit#) =- unsafeDupablePerformIO (mpn_scan0 arg# bit#)-{-# INLINE mpnScan0 #-}--foreign import ccall unsafe "__gmpn_scan1"- mpn_scan1 :: ByteArray# -> Word# -> IO Word--mpnScan1 :: ByteArray -> Word -> Word-mpnScan1 (ByteArray arg#) (W# bit#) =- unsafeDupablePerformIO (mpn_scan1 arg# bit#)-{-# INLINE mpnScan1 #-} foreign import ccall unsafe "__gmpn_popcount" mpn_popcount :: ByteArray# -> Int# -> IO Word
src/Data/Bit/Immutable.hs view
@@ -21,7 +21,11 @@ , castToWords8 , cloneToWords8 + , cloneFromByteString+ , cloneToByteString+ , zipBits+ , mapBits , invertBits , selectBits , excludeBits@@ -48,8 +52,10 @@ #endif import Data.Bit.PdepPext import Data.Bit.Utils+import qualified Data.ByteString.Internal as BS import Data.Primitive.ByteArray import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Storable as S import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU import Data.Word@@ -118,7 +124,8 @@ -- to an unboxed vector of bits. -- Cf. 'Data.Bit.castFromWordsM'. ----- >>> castFromWords (Data.Vector.Unboxed.singleton 123)+-- >>> :set -XOverloadedLists+-- >>> castFromWords [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 (mulWordSize off) (mulWordSize len) arr@@ -131,7 +138,7 @@ -- Use 'cloneToWords' otherwise. -- Cf. 'Data.Bit.castToWordsM'. ----- prop> castToWords (castFromWords v) == Just v+-- > castToWords (castFromWords v) == Just v castToWords :: U.Vector Bit -> Maybe (U.Vector Word) castToWords (BitVec s n ws) | aligned s, aligned n =@@ -145,7 +152,8 @@ -- the last word will be zero-padded. -- Cf. 'Data.Bit.cloneToWordsM'. ----- >>> cloneToWords (read "[1,1,0,1,1,1,1,0]")+-- >>> :set -XOverloadedLists+-- >>> cloneToWords [1,1,0,1,1,1,1] -- [123] cloneToWords :: U.Vector Bit -> U.Vector Word cloneToWords v = runST $ do@@ -156,14 +164,10 @@ -- | Cast a unboxed vector of 'Word8' -- to an unboxed vector of bits.--- This can be used in conjunction--- with @bytestring-to-vector@ package--- to convert from 'Data.ByteString.ByteString': ----- >>> :set -XOverloadedStrings--- >>> import Data.Vector.Storable.ByteString--- >>> castFromWords8 (Data.Vector.convert (byteStringToVector "abc"))--- [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1,1,0]+-- >>> :set -XOverloadedLists+-- >>> castFromWords8 [123]+-- [1,1,0,1,1,1,1,0] castFromWords8 :: U.Vector Word8 -> U.Vector Bit castFromWords8 ws = BitVec (off `shiftL` 3) (len `shiftL` 3) arr where@@ -174,7 +178,7 @@ -- It succeeds if a vector of bits is aligned. -- Use 'Data.Bit.cloneToWords8' otherwise. ----- prop> castToWords8 (castFromWords8 v) == Just v+-- > castToWords8 (castFromWords8 v) == Just v castToWords8 :: U.Vector Bit -> Maybe (U.Vector Word8) castToWords8 (BitVec s n ws) | s .&. 7 == 0, n .&. 7 == 0 =@@ -183,16 +187,12 @@ -- | Clone an unboxed vector of bits -- to a new unboxed vector of 'Word8'.--- If the bits don't completely fill the words,+-- If the bits don't completely fill the bytes, -- the last 'Word8' will be zero-padded.--- This can be used in conjunction--- with @bytestring-to-vector@ package--- to convert to 'Data.ByteString.ByteString': -- -- >>> :set -XOverloadedLists--- >>> import Data.Vector.Storable.ByteString--- >>> vectorToByteString (Data.Vector.convert (Data.Bit.cloneToWords8 [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1]))--- "ab#"+-- >>> cloneToWords8 [1,1,0,1,1,1,1]+-- [123] cloneToWords8 :: U.Vector Bit -> U.Vector Word8 cloneToWords8 v = runST $ do v' <- U.unsafeThaw v@@ -200,6 +200,35 @@ U.unsafeFreeze w {-# INLINE cloneToWords8 #-} +-- | Clone a 'BS.ByteString' to a new unboxed vector of bits.+--+-- >>> :set -XOverloadedStrings+-- >>> cloneFromByteString "abc"+-- [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1,1,0]+cloneFromByteString :: BS.ByteString -> U.Vector Bit+cloneFromByteString+ = castFromWords8+ . U.convert+ . uncurry3 S.unsafeFromForeignPtr+ . BS.toForeignPtr++-- | Clone an unboxed vector of bits to a new 'BS.ByteString'.+-- If the bits don't completely fill the bytes,+-- the last character will be zero-padded.+--+-- >>> :set -XOverloadedLists+-- >>> cloneToByteString [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1]+-- "ab#"+cloneToByteString :: U.Vector Bit -> BS.ByteString+cloneToByteString+ = uncurry3 BS.fromForeignPtr+ . S.unsafeToForeignPtr+ . U.convert+ . cloneToWords8++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z+ -- | Zip two vectors with the given function. -- Similar to 'Data.Vector.Unboxed.zipWith', -- but up to 1000x (!) faster.@@ -208,14 +237,18 @@ -- 'zipBits' is up to 32x faster than -- 'Data.IntSet.union', 'Data.IntSet.intersection', etc. --+-- Users are strongly encouraged to enable+-- flag @libgmp@ for the ultimate performance of 'zipBits'.+--+-- >>> :set -XOverloadedLists -- >>> import Data.Bits--- >>> zipBits (.&.) (read "[1,1,0]") (read "[0,1,1]") -- intersection+-- >>> zipBits (.&.) [1,1,0] [0,1,1] -- intersection -- [0,1,0]--- >>> zipBits (.|.) (read "[1,1,0]") (read "[0,1,1]") -- union+-- >>> zipBits (.|.) [1,1,0] [0,1,1] -- union -- [1,1,1]--- >>> zipBits (\x y -> x .&. complement y) (read "[1,1,0]") (read "[0,1,1]") -- difference+-- >>> zipBits (\x y -> x .&. complement y) [1,1,0] [0,1,1] -- difference -- [1,0,0]--- >>> zipBits xor (read "[1,1,0]") (read "[0,1,1]") -- symmetric difference+-- >>> zipBits xor [1,1,0] [0,1,1] -- symmetric difference -- [1,0,1] zipBits :: (forall a . Bits a => a -> a -> a)@@ -261,9 +294,32 @@ U.unsafeFreeze zs {-# INLINE zipBits #-} +-- | Map a vectors with the given function.+-- Similar to 'Data.Vector.Unboxed.map',+-- but faster.+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> mapBits complement [0,1,1]+-- [1,0,0]+mapBits+ :: (forall a . Bits a => a -> a)+ -> U.Vector Bit+ -> U.Vector Bit+mapBits f xs = case (unBit (f (Bit False)), unBit (f (Bit True))) of+ (False, False) -> U.replicate (U.length xs) (Bit False)+ (False, True) -> xs+ (True, False) -> invertBits xs+ (True, True) -> U.replicate (U.length xs) (Bit True)+{-# INLINE mapBits #-}+ -- | Invert (flip) all bits. ----- >>> invertBits (read "[0,1,0,1,0]")+-- Users are strongly encouraged to enable+-- flag @libgmp@ for the ultimate performance of 'invertBits'.+--+-- >>> :set -XOverloadedLists+-- >>> invertBits [0,1,0,1,0] -- [1,0,1,0,1] invertBits :: U.Vector Bit@@ -287,7 +343,8 @@ -- the corresponding bit of the second argument -- to the result. Similar to the parallel deposit instruction (PDEP). ----- >>> selectBits (read "[0,1,0,1,1]") (read "[1,1,0,0,1]")+-- >>> :set -XOverloadedLists+-- >>> selectBits [0,1,0,1,1] [1,1,0,0,1] -- [1,0,1] -- -- Here is a reference (but slow) implementation:@@ -304,7 +361,8 @@ -- the corresponding bit of the second argument -- to the result. ----- >>> excludeBits (read "[0,1,0,1,1]") (read "[1,1,0,0,1]")+-- >>> :set -XOverloadedLists+-- >>> excludeBits [0,1,0,1,1] [1,1,0,0,1] -- [1,0] -- -- Here is a reference (but slow) implementation:@@ -319,7 +377,8 @@ -- | Reverse the order of bits. ----- >>> reverseBits (read "[1,1,0,1,0]")+-- >>> :set -XOverloadedLists+-- >>> reverseBits [1,1,0,1,0] -- [0,1,0,1,1] -- -- Consider using @vector-rotcev@ package@@ -352,18 +411,19 @@ -- with the specified value, if any. -- Similar to 'Data.Vector.Unboxed.elemIndex', but up to 64x faster. ----- >>> bitIndex (Bit True) (read "[0,0,1,0,1]")+-- >>> :set -XOverloadedLists+-- >>> bitIndex 1 [0,0,1,0,1] -- Just 2--- >>> bitIndex (Bit True) (read "[0,0,0,0,0]")+-- >>> bitIndex 1 [0,0,0,0,0] -- Nothing ----- prop> bitIndex bit == nthBitIndex bit 1+-- > bitIndex bit == nthBitIndex bit 1 -- -- One can also use it to reduce a vector with disjunction or conjunction: ----- >>> import Data.Maybe--- >>> isAnyBitSet = isJust . bitIndex (Bit True)--- >>> areAllBitsSet = isNothing . bitIndex (Bit False)+-- > import Data.Maybe+-- > isAnyBitSet = isJust . bitIndex 1+-- > areAllBitsSet = isNothing . bitIndex 0 bitIndex :: Bit -> U.Vector Bit -> Maybe Int bitIndex b (BitVec off len arr) | len == 0 = Nothing@@ -422,23 +482,24 @@ | n >= off + len = Nothing | otherwise = case ffs (indexByteArray arr n) of Nothing -> go (n + 1)- r@Just{} -> r+ Just r -> Just $ mulWordSize (n - off) + 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+ Nothing -> go (n + 1)+ Just r -> Just $ mulWordSize (n - off) + 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]")+-- >>> :set -XOverloadedLists+-- >>> nthBitIndex 1 2 [0,1,0,1,1,1,0] -- 2nd occurence of 1 -- Just 3--- >>> nthBitIndex (Bit True) 5 (read "[0,1,0,1,1,1,0]")+-- >>> nthBitIndex 1 5 [0,1,0,1,1,1,0] -- 5th occurence of 1 -- Nothing -- -- One can use 'nthBitIndex' to implement@@ -523,7 +584,11 @@ -- | Return the number of set bits in a vector (population count, popcount). ----- >>> countBits (read "[1,1,0,1,0,1]")+-- Users are strongly encouraged to enable+-- flag @libgmp@ for the ultimate performance of 'countBits'.+--+-- >>> :set -XOverloadedLists+-- >>> countBits [1,1,0,1,0,1] -- 4 -- -- One can combine 'countBits' with 'Data.Vector.Unboxed.take'@@ -561,9 +626,10 @@ countBitsInWords :: P.Vector Word -> Int countBitsInWords = P.foldl' (\acc word -> popCount word + acc) 0 --- | Return the indices of set bits in a vector.+-- | Return 0-based indices of set bits in a vector. ----- >>> listBits (read "[1,1,0,1,0,1]")+-- >>> :set -XOverloadedLists+-- >>> listBits [1,1,0,1,0,1] -- [0,1,3,5] listBits :: U.Vector Bit -> [Int] listBits (BitVec _ 0 _) = []
src/Data/Bit/Internal.hs view
@@ -24,7 +24,6 @@ , writeWord , unsafeFlipBit , flipBit- , WithInternals(..) , modifyByteArray ) where @@ -82,30 +81,17 @@ fromInteger = Bit . odd instance Real Bit where- toRational (Bit False) = 0- toRational (Bit True) = 1+ toRational = fromIntegral instance Integral Bit where quotRem _ (Bit False) = throw DivideByZero quotRem x (Bit True) = (x, Bit False)- quot _ (Bit False) = throw DivideByZero- quot x (Bit True) = x- rem _ (Bit False) = throw DivideByZero- rem _ (Bit True) = Bit False-- divMod = quotRem- div = quot- mod = rem- toInteger (Bit False) = 0 toInteger (Bit True) = 1 instance Fractional Bit where- fromRational x = fromInteger (numerator x) `quot` fromInteger (denominator x)- _ / Bit False = throw DivideByZero- x / Bit True = x- recip (Bit False) = throw DivideByZero- recip (Bit True) = Bit True+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)+ (/) = quot instance Show Bit where showsPrec _ (Bit False) = showString "0"@@ -123,13 +109,6 @@ 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 #-}@@ -178,9 +157,7 @@ pure $ (loWord `unsafeShiftR` nMod) .|. (hiWord `unsafeShiftL` (wordSize - nMod))-#if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE readWord :: U.MVector s Bit -> Int -> ST s Word #-}-#endif {-# INLINE readWord #-} modifyByteArray@@ -240,9 +217,7 @@ iMod = modWordSize i iDiv = divWordSize i -#if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE writeWord :: U.MVector s Bit -> Int -> Word -> ST s () #-}-#endif {-# INLINE writeWord #-} instance MV.MVector U.MVector Bit where@@ -258,9 +233,7 @@ {-# INLINE basicUnsafeReplicate #-} basicUnsafeReplicate n x- | n < 0 = error- $ "Data.Bit.basicUnsafeReplicate: negative length: "- ++ show n+ | 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)@@ -309,11 +282,7 @@ in (# state', () #) #endif - {-# INLINE basicClear #-}- basicClear _ = pure ()- {-# 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)@@ -343,7 +312,6 @@ lWords = nWords (offBits + len) {-# 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@@ -407,7 +375,7 @@ x <- readWord src i writeWord dst i x do_copy (i + wordSize)- | otherwise = return ()+ | otherwise = pure () {-# INLINE basicUnsafeMove #-} basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _)@@ -445,8 +413,9 @@ -- either you modify it with 'id' (which is 'id' altogether) -- or with 'Data.Bits.complement' (which is 'unsafeFlipBit'). ----- >>> Data.Vector.Unboxed.modify (\v -> unsafeFlipBit v 1) (read "[1,1,1]")--- [1,0,1]+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify (`unsafeFlipBit` 2) [1,1,1,1]+-- [1,1,0,1] unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m () unsafeFlipBit (BitMVec off _ arr) !i' = do let i = off + i'@@ -465,11 +434,13 @@ -- either you modify it with 'id' (which is 'id' altogether) -- or with 'Data.Bits.complement' (which is 'flipBit'). ----- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]")--- [1,0,1]+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify (`flipBit` 2) [1,1,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+ BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $+ unsafeFlipBit v i {-# INLINE flipBit #-} #else
src/Data/Bit/Mutable.hs view
@@ -17,6 +17,7 @@ , cloneToWords8M , zipInPlace+ , mapInPlace , invertInPlace , selectBitsInPlace@@ -53,9 +54,8 @@ -- Cf. 'Data.Bit.castToWords'. castToWordsM :: MVector s Bit -> Maybe (MVector s Word) castToWordsM (BitMVec s n ws)- | aligned s, aligned n = Just $ MU.MV_Word $ P.MVector (divWordSize s)- (divWordSize n)- ws+ | 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.@@ -94,15 +94,17 @@ -- rewriting contents of the second argument. -- Cf. 'Data.Bit.zipBits'. --+-- >>> :set -XOverloadedLists -- >>> import Data.Bits--- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1]")+-- >>> Data.Vector.Unboxed.modify (zipInPlace (.&.) [1,1,0]) [0,1,1] -- [0,1,0] -- -- __Warning__: if the immutable vector is shorter than the mutable one, -- it is a caller's responsibility to trim the result: --+-- >>> :set -XOverloadedLists -- >>> import Data.Bits--- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1,1,1,1]")+-- >>> Data.Vector.Unboxed.modify (zipInPlace (.&.) [1,1,0]) [0,1,1,1,1,1] -- [0,1,0,1,1,1] -- note trailing garbage zipInPlace :: forall m.@@ -173,14 +175,34 @@ writeByteArray ys i (f x y) loop (i + 1) accNew -#if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE zipInPlace :: (forall a. Bits a => a -> a -> a) -> Vector Bit -> MVector s Bit -> ST s () #-}-#endif {-# INLINE zipInPlace #-} +-- | Apply a function to a mutable vector bitwise,+-- rewriting its contents.+-- Cf. 'Data.Bit.mapBits'.+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> Data.Vector.Unboxed.modify (mapInPlace complement) [0,1,1]+-- [1,0,0]+mapInPlace+ :: PrimMonad m+ => (forall a . Bits a => a -> a)+ -> U.MVector (PrimState m) Bit+ -> m ()+mapInPlace f xs = case (unBit (f (Bit False)), unBit (f (Bit True))) of+ (False, False) -> MU.set xs (Bit False)+ (False, True) -> pure ()+ (True, False) -> invertInPlace xs+ (True, True) -> MU.set xs (Bit True)+{-# SPECIALIZE mapInPlace :: (forall a. Bits a => a -> a) -> MVector s Bit -> ST s () #-}+{-# INLINE mapInPlace #-}+ -- | Invert (flip) all bits in-place. ----- >>> Data.Vector.Unboxed.modify invertInPlace (read "[0,1,0,1,0]")+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify invertInPlace [0,1,0,1,0] -- [1,0,1,0,1] invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m () invertInPlace xs = do@@ -188,20 +210,25 @@ forM_ [0, wordSize .. n - 1] $ \i -> do x <- readWord xs i writeWord xs i (complement x)-#if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE invertInPlace :: U.MVector s Bit -> ST s () #-}-#endif -- | Same as 'Data.Bit.selectBits', but deposit -- selected bits in-place. Returns a number of selected bits. -- It is caller's responsibility to trim the result to this number.+--+-- >>> :set -XOverloadedLists+-- >>> import Control.Monad.ST (runST)+-- >>> import qualified Data.Vector.Unboxed as U+-- >>> runST $ do { vec <- U.unsafeThaw [1,1,0,0,1]; n <- selectBitsInPlace [0,1,0,1,1] vec; U.take n <$> U.unsafeFreeze vec }+-- [1,0,1]+-- selectBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int selectBitsInPlace is xs = loop 0 0 where !n = min (U.length is) (MU.length xs) loop !i !ct- | i >= n = return ct+ | i >= n = pure ct | otherwise = do x <- readWord xs i let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x@@ -211,13 +238,20 @@ -- | Same as 'Data.Bit.excludeBits', but deposit -- excluded bits in-place. Returns a number of excluded bits. -- It is caller's responsibility to trim the result to this number.+--+-- >>> :set -XOverloadedLists+-- >>> import Control.Monad.ST (runST)+-- >>> import qualified Data.Vector.Unboxed as U+-- >>> runST $ do { vec <- U.unsafeThaw [1,1,0,0,1]; n <- excludeBitsInPlace [0,1,0,1,1] vec; U.take n <$> U.unsafeFreeze vec }+-- [1,0]+-- excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int excludeBitsInPlace is xs = loop 0 0 where !n = min (U.length is) (MU.length xs) loop !i !ct- | i >= n = return ct+ | i >= n = pure ct | otherwise = do x <- readWord xs i let !(nSet, x') =@@ -227,44 +261,44 @@ -- | Reverse the order of bits in-place. ----- >>> Data.Vector.Unboxed.modify reverseInPlace (read "[1,1,0,1,0]")+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify reverseInPlace [1,1,0,1,0] -- [0,1,0,1,1] -- -- Consider using @vector-rotcev@ package -- to reverse vectors in O(1) time. reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-reverseInPlace xs | len == 0 = pure ()- | otherwise = loop 0- where- len = MU.length xs+reverseInPlace xs+ | len == 0 = pure ()+ | otherwise = loop 0+ where+ len = MU.length xs - loop !i- | i' <= j' = do- x <- readWord xs i- y <- readWord xs j'+ loop !i+ | i' <= j' = do+ x <- readWord xs i+ y <- readWord xs j' - writeWord xs i (reverseWord y)- writeWord xs j' (reverseWord x)+ writeWord xs i (reverseWord y)+ writeWord xs j' (reverseWord x) - loop i'- | i' < j = do- let w = (j - i) `shiftR` 1- k = j - w- x <- readWord xs i- y <- readWord xs k+ loop i'+ | i' < j = do+ let w = (j - i) `shiftR` 1+ k = j - w+ x <- readWord xs i+ y <- readWord xs k - writeWord xs i (meld w (reversePartialWord w y) x)- writeWord xs k (meld w (reversePartialWord w x) y)+ 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-#if __GLASGOW_HASKELL__ >= 800+ 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 {-# SPECIALIZE reverseInPlace :: U.MVector s Bit -> ST s () #-}-#endif
src/Data/Bit/Utils.hs view
@@ -41,13 +41,16 @@ wordSize :: Int wordSize = finiteBitSize (0 :: Word) -lgWordSize, wordSizeMask, wordSizeMaskC :: Int+lgWordSize :: Int lgWordSize = case wordSize of 32 -> 5 64 -> 6 _ -> error "lgWordSize: unknown architecture" +wordSizeMask :: Int wordSizeMask = wordSize - 1++wordSizeMaskC :: Int wordSizeMaskC = complement wordSizeMask divWordSize :: Bits a => a -> a@@ -87,11 +90,10 @@ -- 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+mask b+ | b >= wordSize = complement 0+ | b < 0 = 0+ | otherwise = bit b - 1 masked :: Int -> Word -> Word masked b x = x .&. mask b@@ -128,8 +130,9 @@ #endif reversePartialWord :: Int -> Word -> Word-reversePartialWord n w | n >= wordSize = reverseWord w- | otherwise = reverseWord w `shiftR` (wordSize - n)+reversePartialWord n w+ | n >= wordSize = reverseWord w+ | otherwise = reverseWord w `shiftR` (wordSize - n) ffs :: Word -> Maybe Int ffs 0 = Nothing
test/Main.hs view
@@ -3,18 +3,16 @@ module Main where +import Control.Exception import Data.Bit-import Data.Bits import Data.Proxy-import qualified Data.Vector.Unboxed as U-import GHC.Exts-import GHC.Integer.Logarithms import Test.QuickCheck.Classes import Test.Tasty import Test.Tasty.QuickCheck import Support import Tests.Conc (concTests)+import Tests.F2Poly (f2polyTests) import Tests.MVector (mvectorTests) import qualified Tests.MVectorTS as TS (mvectorTests) import Tests.SetOps (setOpTests)@@ -47,74 +45,14 @@ , numLaws (Proxy :: Proxy Bit) #endif , integralLaws (Proxy :: Proxy Bit)- ]--f2polyTests :: TestTree-f2polyTests = testGroup "F2Poly"- [ testProperty "Addition" prop_f2polyAdd- , testProperty "Multiplication" prop_f2polyMul- , testProperty "Square" prop_f2polySqr- , tenTimesLess $ testProperty "Multiplication long" prop_f2polyMulLong- , tenTimesLess $ testProperty "Square long" prop_f2polySqrLong- , testProperty "Remainder" prop_f2polyRem- , testProperty "GCD" prop_f2polyGCD- , tenTimesLess $ lawsToTest $- showLaws (Proxy :: Proxy F2Poly)-#if MIN_VERSION_quickcheck_classes(0,6,3)- , lawsToTest $- numLaws (Proxy :: Proxy F2Poly)-#endif- , lawsToTest $- integralLaws (Proxy :: Proxy F2Poly)+ ] +++ [ testProperty "divideByZero" prop_bitDivideByZero+ , testProperty "toRational" prop_bitToRational ] -prop_f2polyAdd :: F2Poly -> F2Poly -> Property-prop_f2polyAdd x y = x + y === fromInteger (toInteger x `xor` toInteger y)--prop_f2polyMul :: F2Poly -> F2Poly -> Property-prop_f2polyMul x y = x * y === fromInteger (toInteger x `binMul` toInteger y)--prop_f2polySqr :: F2Poly -> Property-prop_f2polySqr x = x * x === fromInteger (toInteger x `binMul` toInteger x)--prop_f2polyMulLong :: U.Vector Word -> U.Vector Word -> Property-prop_f2polyMulLong xs ys = x * y === fromInteger (toInteger x `binMul` toInteger y)- where- x = toF2Poly $ castFromWords xs- y = toF2Poly $ castFromWords ys--prop_f2polySqrLong :: U.Vector Word -> Property-prop_f2polySqrLong xs = x * x === fromInteger (toInteger x `binMul` toInteger x)- where- x = toF2Poly $ castFromWords xs--prop_f2polyRem :: F2Poly -> F2Poly -> Property-prop_f2polyRem x y = y /= 0 ==> x `rem` y === fromInteger (toInteger x `binRem` toInteger y)---- For polynomials @x@ and @y@, @gcdExt@ computes their unique greatest common--- divisor @g@ and the unique coefficient polynomial @s@ satisfying @xs + yt = g@.------ Thus it is sufficient to check @gcd == fst . gcdExt@ and @xs == g (mod y)@,--- except if @y@ divides @x@, then @gcdExt x y@ is @(y, 0)@ and @xs `rem` y@ is zero,--- so that it is then necessary to check @xs `rem` y == g `rem` y == 0@.-prop_f2polyGCD :: F2Poly -> F2Poly -> Property-prop_f2polyGCD x y = g === x `gcd` y .&&. (y /= 0 ==> (x * s) `rem` y === g `rem` y)- where- (g, s) = x `gcdExt` y--binMul :: Integer -> Integer -> Integer-binMul = go 0- where- go :: Integer -> Integer -> Integer -> Integer- go acc _ 0 = acc- go acc x y = go (if odd y then acc `xor` x else acc) (x `shiftL` 1) (y `shiftR` 1)--binRem :: Integer -> Integer -> Integer-binRem x y = go x- where- binLog n = I# (integerLog2# n)- ly = binLog y+prop_bitToRational :: Bit -> Property+prop_bitToRational x = fromRational (toRational x) === x - go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))- where- lz = binLog z+prop_bitDivideByZero :: Bit -> Property+prop_bitDivideByZero x =+ ioProperty ((=== Left DivideByZero) <$> try (evaluate (x / 0)))
test/Support.hs view
@@ -40,18 +40,35 @@ function f = functionMap TS.unBit TS.Bit f instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where- arbitrary = (\v -> runST (N.run (v :: N.New U.Vector a) >>= U.freeze)) <$> arbitrary- shrink v = let len = U.length v in- [ U.slice s l v- | s <- [0 .. len - 1]- , l <- [0 .. len - s]- , (s, l) /= (0, len)+ arbitrary = frequency+ [ (10, U.fromList <$> arbitrary)+ , (2 , U.drop <$> arbitrary <*> arbitrary)+ , (2 , U.take <$> arbitrary <*> arbitrary)+ , (2 , slice <$> arbitrary <*> arbitrary <*> arbitrary) ]+ where+ slice s n v = let (s', n') = trimSlice s n (U.length v) in U.slice s' n' v+ shrink v = let len = U.length v in+ [ U.take (len - s) v | s <- [1 .. len] ] +++ [ U.drop s v | s <- [1 .. len] ] +++ [ v U.// [(i, x)] | i <- [0 .. len - 1], x <- shrink (v U.! i) ] +instance {-# OVERLAPPING #-} Arbitrary (Large (U.Vector Bit)) where+ arbitrary = Large . castFromWords <$> arbitrary+ shrink (Large v) = Large <$> shrink v++instance {-# OVERLAPPING #-} Arbitrary (Large (U.Vector TS.Bit)) where+ arbitrary = Large . TS.castFromWords <$> arbitrary+ shrink (Large v) = Large <$> shrink v+ instance Arbitrary F2Poly where arbitrary = toF2Poly <$> arbitrary shrink v = toF2Poly <$> shrink (unF2Poly v) +instance {-# OVERLAPPING #-} Arbitrary (Large F2Poly) where+ arbitrary = Large . toF2Poly . castFromWords <$> arbitrary+ shrink (Large v) = Large . toF2Poly <$> shrink (unF2Poly v)+ instance (Show (v a), V.Vector v a) => Show (N.New v a) where showsPrec p = showsPrec p . V.new @@ -62,19 +79,16 @@ 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)+ , (2 , N.drop <$> arbitrary <*> arbitrary)+ , (2 , N.take <$> arbitrary <*> arbitrary)+ , (2 , 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)- ]+ [ N.take s v | s <- [0 .. len - 1] ] +++ [ N.drop s v | s <- [1 .. len] ] where len = runST (M.length <$> N.run v) trimSlice :: Integral a => a -> a -> a -> (a, a)@@ -137,6 +151,10 @@ tenTimesLess :: TestTree -> TestTree tenTimesLess = adjustOption $ \(QuickCheckTests n) -> QuickCheckTests (max 100 (n `div` 10))++twoTimesMore :: TestTree -> TestTree+twoTimesMore = adjustOption $+ \(QuickCheckTests n) -> QuickCheckTests (n * 2) lawsToTest :: Laws -> TestTree lawsToTest (Laws name props) =
test/Tests/Conc.hs view
@@ -1,4 +1,6 @@-module Tests.Conc where+module Tests.Conc+ ( concTests+ ) where import Control.Concurrent import Control.Monad
+ test/Tests/F2Poly.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++module Tests.F2Poly+ ( f2polyTests+ ) where++import Control.Exception+import Data.Bit+import Data.Bits+import Data.Proxy+import Data.Ratio+import GHC.Exts+#ifdef MIN_VERSION_ghc_bignum+import GHC.Num.Integer+#else+import GHC.Integer.Logarithms+#endif+import Test.QuickCheck.Classes+import Test.Tasty+import Test.Tasty.QuickCheck++import Support++f2polyTests :: TestTree+f2polyTests = testGroup "F2Poly"+ [ testProperty "Addition" prop_f2polyAdd+ , testProperty "Multiplication" prop_f2polyMul+ , testProperty "Square" prop_f2polySqr+ , tenTimesLess+ $ testProperty "Multiplication long" prop_f2polyMulLong+ , testProperty "Multiplication 1" prop_f2polyMul1+ , tenTimesLess+ $ testProperty "Square long" prop_f2polySqrLong+ , testProperty "Remainder" prop_f2polyRem+ , testProperty "GCD" prop_f2polyGCD+ , testProperty "Enum" $+ \n -> let x = toEnum n in toEnum (fromEnum x) === (x :: F2Poly)+ , tenTimesLess $ lawsToTest $+ showLaws (Proxy :: Proxy F2Poly)+#if MIN_VERSION_quickcheck_classes(0,6,3)+ , lawsToTest $+ numLaws (Proxy :: Proxy F2Poly)+#endif+ , lawsToTest $+ integralLaws (Proxy :: Proxy F2Poly)+ , testProperty "fromNegative" prop_f2polyFromNegative+ , testProperty "divideByZero" prop_f2polyDivideByZero+ , testProperty "toRational" prop_f2polyToRational+ ]++prop_f2polyAdd :: F2Poly -> F2Poly -> Property+prop_f2polyAdd x y = x + y === fromInteger (toInteger x `xor` toInteger y)++prop_f2polyMul :: F2Poly -> F2Poly -> Property+prop_f2polyMul x y = x * y === fromInteger (toInteger x `binMul` toInteger y)++prop_f2polySqr :: F2Poly -> Property+prop_f2polySqr x = x * x === fromInteger (toInteger x `binMul` toInteger x)++prop_f2polyMulLong :: Large F2Poly -> Large F2Poly -> Property+prop_f2polyMulLong (Large x) (Large y) = prop_f2polyMul x y++prop_f2polyMul1 :: Property+prop_f2polyMul1 = prop_f2polyMul x y+ where+ x = fromInteger (1 `shiftL` 4358)+ y = fromInteger (1 `shiftL` 4932 + 1 `shiftL` 2116)++prop_f2polySqrLong :: Large F2Poly -> Property+prop_f2polySqrLong (Large x) = prop_f2polySqr x++prop_f2polyRem :: F2Poly -> F2Poly -> Property+prop_f2polyRem x y = y /= 0 ==> x `rem` y === fromInteger (toInteger x `binRem` toInteger y)++-- For polynomials @x@ and @y@, @gcdExt@ computes their unique greatest common+-- divisor @g@ and the unique coefficient polynomial @s@ satisfying @xs + yt = g@.+--+-- Thus it is sufficient to check @gcd == fst . gcdExt@ and @xs == g (mod y)@,+-- except if @y@ divides @x@, then @gcdExt x y@ is @(y, 0)@ and @xs `rem` y@ is zero,+-- so that it is then necessary to check @xs `rem` y == g `rem` y == 0@.+prop_f2polyGCD :: F2Poly -> F2Poly -> Property+prop_f2polyGCD x y = g === x `gcd` y .&&. (y /= 0 ==> (x * s) `rem` y === g `rem` y)+ where+ (g, s) = x `gcdExt` y++binMul :: Integer -> Integer -> Integer+binMul = go 0+ where+ go :: Integer -> Integer -> Integer -> Integer+ go acc _ 0 = acc+ go acc x y = go (if odd y then acc `xor` x else acc) (x `shiftL` 1) (y `shiftR` 1)++binRem :: Integer -> Integer -> Integer+binRem x y = go x+ where+#ifdef MIN_VERSION_ghc_bignum+ binLog n = I# (word2Int# (integerLog2# n))+#else+ binLog n = I# (integerLog2# n)+#endif+ ly = binLog y++ go 0 = 0+ go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))+ where+ lz = binLog z++prop_f2polyFromNegative :: Large Int -> Property+prop_f2polyFromNegative (Large m) =+ ioProperty ((=== Left Underflow) <$> try (evaluate (fromInteger neg :: F2Poly)))+ where+ neg = negate (1 + toInteger m * toInteger m)++prop_f2polyToRational :: F2Poly -> Property+prop_f2polyToRational x = denominator y === 1 .&&. fromInteger (numerator y) === x+ where+ y = toRational x++prop_f2polyDivideByZero :: F2Poly -> Property+prop_f2polyDivideByZero x =+ ioProperty ((=== Left DivideByZero) <$> try (evaluate (x `quot` 0)))
test/Tests/MVector.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE CPP #-} #ifndef BITVEC_THREADSAFE-module Tests.MVector where+module Tests.MVector (mvectorTests) where #else-module Tests.MVectorTS where+module Tests.MVectorTS (mvectorTests) where #endif import Support +import Control.Exception import Control.Monad.ST #ifndef BITVEC_THREADSAFE import Data.Bit@@ -17,9 +18,9 @@ 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.Mutable as MG import qualified Data.Vector.Generic.New as N-import qualified Data.Vector.Unboxed as B+import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as M import Test.QuickCheck.Classes import Test.Tasty@@ -35,8 +36,12 @@ ] , testGroup "Read/write Words" [ tenTimesLess $- testProperty "cloneFromWords" prop_cloneFromWords_def+ testProperty "castFromWords" prop_castFromWords_def , testProperty "cloneToWords" prop_cloneToWords_def+ , tenTimesLess $+ testProperty "castToWords_1" prop_castToWords_1+ , tenTimesLess $+ testProperty "castToWords_2" prop_castToWords_2 ] , lawsToTest $ muvectorLaws (Proxy :: Proxy Bit) , testCase "basicInitialize 1" case_write_init_read1@@ -58,27 +63,29 @@ , testCase "basicUnsafeCopy5" case_write_copy_read5 , tenTimesLess $ testProperty "flipBit" prop_flipBit+ , testProperty "new negative" prop_new_neg+ , testProperty "replicate negative" prop_replicate_neg ] -prop_flipBit :: B.Vector Bit -> NonNegative Int -> Property-prop_flipBit xs (NonNegative k) = B.length xs > 0 ==> ys === ys'+prop_flipBit :: U.Vector Bit -> NonNegative Int -> Property+prop_flipBit xs (NonNegative k) = U.length xs > 0 ==> ys === ys' where- k' = k `mod` B.length xs- ys = B.modify (\v -> M.modify v complement k') xs- ys' = B.modify (\v -> flipBit v k') xs+ k' = k `mod` U.length xs+ ys = U.modify (\v -> M.modify v complement k') xs+ ys' = U.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)+ MG.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)+ MG.basicInitialize (M.slice 0 1 arr) M.read arr 1 case_write_init_read3 :: IO ()@@ -87,7 +94,7 @@ arr <- M.new 2 M.write arr 0 (Bit True) M.write arr 1 (Bit True)- M.basicInitialize (M.slice 1 0 arr)+ MG.basicInitialize (M.slice 1 0 arr) (,) <$> M.read arr 0 <*> M.read arr 1 case_write_init_read4 :: IO ()@@ -96,21 +103,21 @@ arr <- M.new 3 M.write arr 0 (Bit True) M.write arr 2 (Bit True)- M.basicInitialize (M.slice 1 1 arr)+ MG.basicInitialize (M.slice 1 1 arr) (,) <$> M.read arr 0 <*> M.read arr 2 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)+ MG.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)+ MG.basicSet (M.slice 0 1 arr) (Bit False) M.read arr 1 case_write_set_read3 :: IO ()@@ -119,7 +126,7 @@ arr <- M.new 2 M.write arr 0 (Bit True) M.write arr 1 (Bit True)- M.basicSet (M.slice 1 0 arr) (Bit False)+ MG.basicSet (M.slice 1 0 arr) (Bit False) (,) <$> M.read arr 0 <*> M.read arr 1 case_write_set_read4 :: IO ()@@ -128,31 +135,31 @@ arr <- M.new 3 M.write arr 0 (Bit True) M.write arr 2 (Bit True)- M.basicSet (M.slice 1 1 arr) (Bit False)+ MG.basicSet (M.slice 1 1 arr) (Bit False) (,) <$> M.read arr 0 <*> M.read arr 2 case_set_read1 :: IO () case_set_read1 = assertEqual "should be equal" (Bit True) $ runST $ do arr <- M.new 1- M.basicSet arr (Bit True)+ MG.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)+ MG.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)+ MG.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)+ MG.basicSet arr (Bit True) M.read arr 21 case_write_copy_read1 :: IO ()@@ -198,34 +205,69 @@ prop_slice_def :: NonNegative Int -> NonNegative Int- -> N.New B.Vector Bit+ -> N.New U.Vector Bit -> Property prop_slice_def (NonNegative s) (NonNegative n) xs = l > 0 ==> runST $ do let xs' = V.new xs xs1 <- N.run xs xs2 <- V.unsafeFreeze (M.slice s' n' xs1)- return (B.toList xs2 === sliceList s' n' (B.toList xs'))+ return (U.toList xs2 === sliceList s' n' (U.toList xs')) where l = V.length (V.new xs) s' = s `mod` l n' = n `mod` (l - s') -prop_grow_def :: B.Vector Bit -> NonNegative Int -> Bool+prop_grow_def :: U.Vector Bit -> NonNegative Int -> Bool prop_grow_def xs (NonNegative m) = runST $ do- let n = B.length xs- v0 <- B.thaw xs+ let n = U.length xs+ v0 <- U.thaw xs v1 <- M.grow v0 m- fv0 <- B.freeze v0- fv1 <- B.freeze v1- return (fv0 == B.take n fv1)+ fv0 <- U.freeze v0+ fv1 <- U.freeze v1+ return (fv0 == U.take n fv1) -prop_cloneFromWords_def :: N.New B.Vector Word -> Property-prop_cloneFromWords_def ws =+prop_castFromWords_def :: N.New U.Vector Word -> Property+prop_castFromWords_def ws = runST (N.run ws >>= pure . castFromWordsM >>= V.unsafeFreeze) === castFromWords (V.new ws) -prop_cloneToWords_def :: N.New B.Vector Bit -> Property+prop_cloneToWords_def :: N.New U.Vector Bit -> Property prop_cloneToWords_def xs = runST (N.run xs >>= cloneToWordsM >>= V.unsafeFreeze) === cloneToWords (V.new xs)++prop_castToWords_1 :: N.New U.Vector Word -> Property+prop_castToWords_1 xs = runST $ do+ vs <- N.run xs+ vs' <- cloneToWordsM (castFromWordsM vs)+ case castToWordsM (castFromWordsM vs) of+ Nothing -> pure $ property False+ Just vs'' -> do+ ws' <- V.unsafeFreeze vs'+ ws'' <- V.unsafeFreeze vs''+ pure $ ws' === ws''++prop_castToWords_2 :: N.New U.Vector Bit -> Property+prop_castToWords_2 xs = runST $ do+ vs <- N.run xs+ case castToWordsM vs of+ Nothing -> pure $ property True+ Just ws -> do+ ws' <- V.unsafeFreeze (castFromWordsM ws)+ ws'' <- V.unsafeFreeze vs+ pure $ ws' === ws''++prop_replicate_neg :: Positive Int -> Bit -> Property+prop_replicate_neg (Positive n) x = ioProperty $ do+ ret <- try (evaluate (runST $ MG.basicUnsafeReplicate (-n) x >>= U.unsafeFreeze))+ pure $ property $ case ret of+ Left ErrorCallWithLocation{} -> True+ _ -> False++prop_new_neg :: Positive Int -> Property+prop_new_neg (Positive n) = ioProperty $ do+ ret <- try (evaluate (runST $ MG.basicUnsafeNew (-n) >>= U.unsafeFreeze :: U.Vector Bit))+ pure $ property $ case ret of+ Left ErrorCallWithLocation{} -> True+ _ -> False
test/Tests/SetOps.hs view
@@ -2,12 +2,12 @@ {-# LANGUAGE RankNTypes #-} #ifndef BITVEC_THREADSAFE-module Tests.SetOps where+module Tests.SetOps (setOpTests) where #else-module Tests.SetOpsTS where+module Tests.SetOpsTS (setOpTests) where #endif -import Support ()+import Support (twoTimesMore) import Control.Monad import Control.Monad.ST@@ -19,34 +19,71 @@ import Test.Tasty.QuickCheck hiding ((.&.)) setOpTests :: TestTree-setOpTests = testGroup- "Set operations"- [ testProperty "generalize" prop_generalize- , testProperty "zipBits" prop_zipBits- , testProperty "zipInPlace" prop_zipInPlace- , testProperty "invertBits" prop_invertBits- , testProperty "invertBitsWords" prop_invertBitsWords- , testProperty "invertInPlace" prop_invertInPlace- , testProperty "invertInPlace middle" prop_invertInPlace_middle- , testProperty "reverseBits" prop_reverseBits- , testProperty "reverseBitsWords" prop_reverseBitsWords- , testProperty "reverseInPlace" prop_reverseInPlace- , testProperty "reverseInPlace middle" prop_reverseInPlace_middle- , testProperty "selectBits" prop_selectBits_def- , testProperty "excludeBits" prop_excludeBits_def- , testProperty "countBits" prop_countBits_def+setOpTests = testGroup "Set operations"+ [ testProperty "generalize1" prop_generalize1+ , testProperty "generalize2" prop_generalize2+ , twoTimesMore+ $ testProperty "zipBits" prop_zipBits+ , testProperty "zipInPlace" prop_zipInPlace++ , testProperty "mapBits" prop_mapBits+ , testProperty "mapInPlace" prop_mapInPlace++ , testProperty "union" prop_union_def+ , testProperty "intersection" prop_intersection_def+ , testProperty "difference" prop_difference_def+ , testProperty "symDiff" prop_symDiff_def++ , mkGroup "invertBits" prop_invertBits++ , testProperty "invertInPlace" prop_invertInPlace+ , testProperty "invertInPlaceWords" prop_invertInPlaceWords+ , testProperty "invertInPlace middle" prop_invertInPlace_middle+ , testProperty "invertInPlaceLong middle" prop_invertInPlaceLong_middle++ , mkGroup "reverseBits" prop_reverseBits++ , testProperty "reverseInPlace" prop_reverseInPlace+ , testProperty "reverseInPlaceWords" prop_reverseInPlaceWords+ , testProperty "reverseInPlace middle" prop_reverseInPlace_middle+ , testProperty "reverseInPlaceLong middle" prop_reverseInPlaceLong_middle++ , testProperty "selectBits" prop_selectBits_def+ , testProperty "excludeBits" prop_excludeBits_def++ , mkGroup "countBits" prop_countBits_def ] -prop_generalize :: Fun (Bit, Bit) Bit -> Bit -> Bit -> Property-prop_generalize fun x y = curry (applyFun fun) x y === generalize (curry (applyFun fun)) x y+mkGroup :: String -> (U.Vector Bit -> Property) -> TestTree+mkGroup name prop = testGroup name+ [ testProperty "simple" prop+ , testProperty "simple_long" (prop . getLarge)+ , testProperty "middle" propMiddle+ , testProperty "middle_long" propMiddleLong+ ]+ where+ f m = let n = fromIntegral m :: Double in+ odd (truncate (exp (abs (sin n) * 10)) :: Integer)+ propMiddle (NonNegative from) (NonNegative len) (NonNegative excess) =+ prop (U.slice from len (U.generate (from + len + excess) (Bit . f)))+ propMiddleLong (NonNegative x) (NonNegative y) (NonNegative z) =+ propMiddle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29) +prop_generalize1 :: Fun Bit Bit -> Bit -> Property+prop_generalize1 fun x =+ applyFun fun x === generalize1 (applyFun fun) x++prop_generalize2 :: Fun (Bit, Bit) Bit -> Bit -> Bit -> Property+prop_generalize2 fun x y =+ curry (applyFun fun) x y === generalize2 (curry (applyFun fun)) x y+ prop_union_def :: U.Vector Bit -> U.Vector Bit -> Property prop_union_def xs ys =- zipBits (.|.) xs ys === U.zipWith (.|.) xs ys+ xs .|. ys === U.zipWith (.|.) xs ys prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Property prop_intersection_def xs ys =- zipBits (.&.) xs ys === U.zipWith (.&.) xs ys+ xs .&. ys === U.zipWith (.&.) xs ys prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Property prop_difference_def xs ys =@@ -56,34 +93,39 @@ prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Property prop_symDiff_def xs ys =- zipBits xor xs ys === U.zipWith xor xs ys+ xs `xor` ys === U.zipWith xor xs ys prop_zipBits :: Fun (Bit, Bit) Bit -> U.Vector Bit -> U.Vector Bit -> Property prop_zipBits fun xs ys =- U.zipWith f xs ys === zipBits (generalize f) xs ys+ U.zipWith f xs ys === zipBits (generalize2 f) xs ys where f = curry $ applyFun fun prop_zipInPlace :: Fun (Bit, Bit) Bit -> U.Vector Bit -> U.Vector Bit -> Property prop_zipInPlace fun xs ys =- U.zipWith f xs ys === U.take (min (U.length xs) (U.length ys)) (U.modify (zipInPlace (generalize f) xs) ys)+ U.zipWith f xs ys === U.take (min (U.length xs) (U.length ys)) (U.modify (zipInPlace (generalize2 f) xs) ys) where f = curry $ applyFun fun +prop_mapBits :: Fun Bit Bit -> U.Vector Bit -> Property+prop_mapBits fun xs =+ U.map (applyFun fun) xs === mapBits (generalize1 (applyFun fun)) xs++prop_mapInPlace :: Fun Bit Bit -> U.Vector Bit -> Property+prop_mapInPlace fun xs =+ U.map (applyFun fun) xs === U.modify (mapInPlace (generalize1 (applyFun fun))) xs+ prop_invertBits :: U.Vector Bit -> Property prop_invertBits xs =- U.map complement xs === invertBits xs--prop_invertBitsWords :: U.Vector Word -> Property-prop_invertBitsWords ws =- U.map complement xs === invertBits xs- where- xs = castFromWords ws+ U.map complement xs === complement xs prop_invertInPlace :: U.Vector Bit -> Property prop_invertInPlace xs = U.map complement xs === U.modify invertInPlace xs +prop_invertInPlaceWords :: Large (U.Vector Bit) -> Property+prop_invertInPlaceWords = prop_invertInPlace . getLarge+ prop_invertInPlace_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_invertInPlace_middle (NonNegative from) (NonNegative len) (NonNegative excess) = runST $ do let totalLen = from + len + excess@@ -96,26 +138,29 @@ invertInPlace middle wec <- U.unsafeFreeze vec - let refLeft = U.take from ref- wecLeft = U.take from wec- refRight = U.drop (from + len) ref- wecRight = U.drop (from + len) wec- pure $ refLeft === wecLeft .&&. refRight === wecRight+ let refLeft = U.take from ref+ wecLeft = U.take from wec+ refRight = U.drop (from + len) ref+ wecRight = U.drop (from + len) wec+ refMiddle = U.map complement (U.take len (U.drop from ref))+ wecMiddle = U.take len (U.drop from wec)+ pure $ refLeft === wecLeft .&&. refRight === wecRight .&&. refMiddle === wecMiddle +prop_invertInPlaceLong_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property+prop_invertInPlaceLong_middle (NonNegative x) (NonNegative y) (NonNegative z) =+ prop_invertInPlace_middle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29)+ prop_reverseBits :: U.Vector Bit -> Property prop_reverseBits xs = U.reverse xs === reverseBits xs -prop_reverseBitsWords :: U.Vector Word -> Property-prop_reverseBitsWords ws =- U.reverse xs === reverseBits xs- where- xs = castFromWords ws- prop_reverseInPlace :: U.Vector Bit -> Property prop_reverseInPlace xs = U.reverse xs === U.modify reverseInPlace xs +prop_reverseInPlaceWords :: Large (U.Vector Bit) -> Property+prop_reverseInPlaceWords = prop_reverseInPlace . getLarge+ prop_reverseInPlace_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property prop_reverseInPlace_middle (NonNegative from) (NonNegative len) (NonNegative excess) = runST $ do let totalLen = from + len + excess@@ -128,12 +173,18 @@ reverseInPlace middle wec <- U.unsafeFreeze vec - let refLeft = U.take from ref- wecLeft = U.take from wec- refRight = U.drop (from + len) ref- wecRight = U.drop (from + len) wec- pure $ refLeft === wecLeft .&&. refRight === wecRight+ let refLeft = U.take from ref+ wecLeft = U.take from wec+ refRight = U.drop (from + len) ref+ wecRight = U.drop (from + len) wec+ refMiddle = U.reverse (U.take len (U.drop from ref))+ wecMiddle = U.take len (U.drop from wec)+ pure $ refLeft === wecLeft .&&. refRight === wecRight .&&. refMiddle === wecMiddle +prop_reverseInPlaceLong_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property+prop_reverseInPlaceLong_middle (NonNegative x) (NonNegative y) (NonNegative z) =+ prop_reverseInPlace_middle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29)+ select :: U.Unbox a => U.Vector Bit -> U.Vector a -> U.Vector a select mask ws = U.map snd (U.filter (unBit . fst) (U.zip mask ws)) @@ -151,8 +202,15 @@ ------------------------------------------------------------------------------- -generalize :: (Bit -> Bit -> Bit) -> (forall a. Bits a => a -> a -> a)-generalize f = case (f (Bit False) (Bit False), f (Bit False) (Bit True), f (Bit True) (Bit False), f (Bit True) (Bit True)) of+generalize1 :: (Bit -> Bit) -> (forall a. Bits a => a -> a)+generalize1 f = case (f (Bit False), f (Bit True)) of+ (Bit False, Bit False) -> const zeroBits+ (Bit False, Bit True) -> id+ (Bit True, Bit False) -> complement+ (Bit True, Bit True) -> const $ complement zeroBits++generalize2 :: (Bit -> Bit -> Bit) -> (forall a. Bits a => a -> a -> a)+generalize2 f = case (f (Bit False) (Bit False), f (Bit False) (Bit True), f (Bit True) (Bit False), f (Bit True) (Bit True)) of (Bit False, Bit False, Bit False, Bit False) -> \_ _ -> zeroBits (Bit False, Bit False, Bit False, Bit True) -> \x y -> x .&. y (Bit False, Bit False, Bit True, Bit False) -> \x y -> x .&. complement y
test/Tests/Vector.hs view
@@ -1,100 +1,180 @@-module Tests.Vector where+module Tests.Vector+ ( vectorTests+ ) where import Support import Prelude hiding (and, or)+import Control.Exception import Data.Bit import Data.Bits-import Data.List hiding (and, or)-import qualified Data.Vector.Unboxed as U hiding (reverse, and, or, any, all, findIndex)+import Data.List (findIndex)+import qualified Data.Vector.Unboxed as U import Data.Word import Test.Tasty-import Test.Tasty.HUnit 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+ , mkGroup "fromList . toList == id" prop_fromList_toList , testProperty "slice" prop_slice_def ] , tenTimesLess $ testProperty "cloneFromWords" prop_cloneFromWords_def- , testProperty "cloneToWords" prop_cloneToWords_def+ , mkGroup "cloneToWords" prop_cloneToWords_def , tenTimesLess $+ testProperty "castToWords_1" prop_castToWords_1+ , tenTimesLess $+ testProperty "castToWords_2" prop_castToWords_2+ , tenTimesLess $ testProperty "cloneFromWords8" prop_cloneFromWords8_def- , testProperty "cloneToWords8" prop_cloneToWords8_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+ , mkGroup "cloneToWords8" prop_cloneToWords8_def+ , tenTimesLess $+ testProperty "castToWords8_1" prop_castToWords8_1+ , tenTimesLess $+ testProperty "castToWords8_2" prop_castToWords8_2+ , testProperty "cloneToByteString" prop_cloneToByteString+ , mkGroup "reverse" prop_reverse_def+ , testGroup "countBits"+ [ testProperty "special case 1" case_countBits_1+ , mkGroup "matches definition" prop_countBits_def ]- , testGroup "Search operations"- [ testProperty "first" prop_first_def+ , testGroup "listBits"+ [ testProperty "special case 1" case_listBits_1+ , testProperty "special case 2" case_listBits_2+ , mkGroup "matches definition" prop_listBits_def ]+ , mkGroup "and" prop_and_def+ , mkGroup "or" prop_or_def+ , testGroup "bitIndex"+ [ testProperty "special case 1" case_bitIndex_1+ , testProperty "special case 2" case_bitIndex_2+ , testProperty "special case 3" case_bitIndex_3+ , testProperty "special case 4" case_bitIndex_4+ , testProperty "special case 5" case_bitIndex_5+ , testProperty "special case 6" case_bitIndex_6+ , testProperty "special case 7" case_bitIndex_7+ , mkGroup "True" (prop_bitIndex_1 (Bit True))+ , mkGroup "False" (prop_bitIndex_1 (Bit False))+ ] , testGroup "nthBitIndex"- [ testCase "special case 1" case_nthBit_1- , testProperty "matches bitIndex True" prop_nthBit_1- , testProperty "matches bitIndex False" prop_nthBit_2+ [ testProperty "special case 1" case_nthBit_1+ , testProperty "special case 2" case_nthBit_2+ , testProperty "special case 3" case_nthBit_3+ , testProperty "special case 4" case_nthBit_4+ , testProperty "special case 5" case_nthBit_5+ , testProperty "special case 6" case_nthBit_6+ , testProperty "special case 7" case_nthBit_7+ , mkGroup "matches bitIndex True" prop_nthBit_1+ , mkGroup "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+ , testProperty "negative argument" prop_nthBit_6 ] , testGroup "Bits instance" [ testProperty "rotate is reversible" prop_rotate , testProperty "bit" prop_bit , testProperty "shiftL" prop_shiftL , testProperty "shiftR" prop_shiftR+ , testProperty "zeroBits" prop_zeroBits+ , testProperty "bitSize" prop_bitSize+ , testProperty "isSigned" prop_isSigned ] ] -prop_toList_fromList :: [Bit] -> Bool-prop_toList_fromList xs = U.toList (U.fromList xs) == xs+mkGroup :: String -> (U.Vector Bit -> Property) -> TestTree+mkGroup name prop = testGroup name+ [ testProperty "simple" prop+ , testProperty "simple_long" (prop . getLarge)+ , testProperty "middle" propMiddle+ , testProperty "middle_long" propMiddleLong+ ]+ where+ f m = let n = fromIntegral m :: Double in+ odd (truncate (exp (abs (sin n) * 10)) :: Integer)+ propMiddle (NonNegative from) (NonNegative len) (NonNegative excess) =+ prop (U.slice from len (U.generate (from + len + excess) (Bit . f)))+ propMiddleLong (NonNegative x) (NonNegative y) (NonNegative z) =+ propMiddle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29) -prop_fromList_toList :: U.Vector Bit -> Bool-prop_fromList_toList xs = U.fromList (U.toList xs) == xs+prop_toList_fromList :: [Bit] -> Property+prop_toList_fromList xs = U.toList (U.fromList 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_fromList_toList :: U.Vector Bit -> Property+prop_fromList_toList xs = U.fromList (U.toList xs) === xs +prop_slice_def :: Int -> Int -> U.Vector Bit -> Property+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_cloneToWords_def :: U.Vector Bit -> Bool-prop_cloneToWords_def xs = U.toList (cloneToWords xs) == loop (U.toList xs)+prop_cloneToWords_def :: U.Vector Bit -> Property+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_castToWords_1 :: U.Vector Word -> Property+prop_castToWords_1 ws =+ Just ws === castToWords (castFromWords ws)++prop_castToWords_2 :: U.Vector Bit -> Property+prop_castToWords_2 xs = case castToWords xs of+ Nothing -> property True+ Just ws -> castFromWords ws === xs+ prop_cloneFromWords8_def :: U.Vector Word8 -> Property prop_cloneFromWords8_def ws = U.toList (castFromWords8 ws) === concatMap wordToBitList (U.toList ws) -prop_cloneToWords8_def :: U.Vector Bit -> Bool-prop_cloneToWords8_def xs = U.toList (cloneToWords8 xs) == loop (U.toList xs)+prop_cloneToWords8_def :: U.Vector Bit -> Property+prop_cloneToWords8_def xs = U.toList (cloneToWords8 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_castToWords8_1 :: U.Vector Word8 -> Property+prop_castToWords8_1 ws =+ Just ws === castToWords8 (castFromWords8 ws)++prop_castToWords8_2 :: U.Vector Bit -> Property+prop_castToWords8_2 xs = case castToWords8 xs of+ Nothing -> property True+ Just ws -> castFromWords8 ws === xs++prop_reverse_def :: U.Vector Bit -> Property prop_reverse_def xs =- reverse (U.toList xs) == U.toList (U.modify reverseInPlace 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 :: U.Vector Bit -> Property+prop_countBits_def xs = countBits xs === length (filter unBit (U.toList xs)) +case_countBits_1 :: Property+case_countBits_1 = once $+ countBits (U.drop 64 (U.replicate 128 (Bit False))) === 0+ prop_listBits_def :: U.Vector Bit -> Property prop_listBits_def xs = listBits xs === [ i | (i, x) <- zip [0 ..] (U.toList xs), unBit x ] +case_listBits_1 :: Property+case_listBits_1 = once $+ listBits (U.drop 24 (U.replicate 64 (Bit False))) === []++case_listBits_2 :: Property+case_listBits_2 = once $+ listBits (U.drop 24 (U.replicate 128 (Bit True))) === [0..103]+ and :: U.Vector Bit -> Bool and xs = case bitIndex (Bit False) xs of Nothing -> True@@ -111,9 +191,37 @@ 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)+case_bitIndex_1 :: Property+case_bitIndex_1 = once $+ bitIndex (Bit True) (U.generate 128 (Bit . (== 64))) === Just 64 +case_bitIndex_2 :: Property+case_bitIndex_2 = once $+ bitIndex (Bit False) (U.generate 128 (Bit . (/= 64))) === Just 64++case_bitIndex_3 :: Property+case_bitIndex_3 = once $+ bitIndex (Bit True) (U.drop 63 (U.generate 128 (Bit . (== 64)))) === Just 1++case_bitIndex_4 :: Property+case_bitIndex_4 = once $+ bitIndex (Bit False) (U.drop 63 (U.generate 128 (Bit . (/= 64)))) === Just 1++case_bitIndex_5 :: Property+case_bitIndex_5 = once $+ bitIndex (Bit False) (U.drop 63 (U.replicate 65 (Bit True))) === Nothing++case_bitIndex_6 :: Property+case_bitIndex_6 = once $+ bitIndex (Bit False) (U.drop 63 (U.generate 66 (Bit . (== 63)))) === Just 1++case_bitIndex_7 :: Property+case_bitIndex_7 = once $+ bitIndex (Bit False) (U.drop 1023 (U.generate 1097 (Bit . (/= 1086)))) === Just 63++prop_bitIndex_1 :: Bit -> U.Vector Bit -> Property+prop_bitIndex_1 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 @@ -147,18 +255,50 @@ count = countBits xs n' = n `mod` count + 1 -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)+prop_nthBit_6 :: NonNegative Int -> U.Vector Bit -> Property+prop_nthBit_6 (NonNegative n) xs = ioProperty $ do+ ret <- try (evaluate (nthBitIndex (Bit True) (-n) xs))+ pure $ property $ case ret of+ Left ErrorCallWithLocation{} -> True+ _ -> False +case_nthBit_1 :: Property+case_nthBit_1 = once $+ nthBitIndex (Bit True) 1 (U.slice 61 4 (U.replicate 100 (Bit False))) === Nothing++case_nthBit_2 :: Property+case_nthBit_2 = once $+ nthBitIndex (Bit False) 1 (U.slice 61 4 (U.replicate 100 (Bit True))) === Nothing++case_nthBit_3 :: Property+case_nthBit_3 = once $+ nthBitIndex (Bit True) 1 (U.drop 63 (U.generate 128 (Bit . (== 64)))) === Just 1++case_nthBit_4 :: Property+case_nthBit_4 = once $+ nthBitIndex (Bit False) 1 (U.drop 63 (U.generate 128 (Bit . (/= 64)))) === Just 1++case_nthBit_5 :: Property+case_nthBit_5 = once $+ nthBitIndex (Bit False) 1 (U.drop 63 (U.replicate 65 (Bit True))) === Nothing++case_nthBit_6 :: Property+case_nthBit_6 = once $+ nthBitIndex (Bit False) 1 (U.drop 63 (U.generate 66 (Bit . (== 63)))) === Just 1++case_nthBit_7 :: Property+case_nthBit_7 = once $+ nthBitIndex (Bit False) 1 (U.drop 1023 (U.generate 1097 (Bit . (/= 1086)))) === Just 63+ prop_rotate :: Int -> U.Vector Bit -> Property prop_rotate n v = v === (v `rotate` n) `rotate` (-n) -prop_bit :: NonNegative Int -> Property-prop_bit (NonNegative n) = testBit v n .&&. popCount v === 1 .&&. U.length v == n + 1+prop_bit :: Int -> Property+prop_bit n+ | n >= 0+ = testBit v n .&&. popCount v === 1 .&&. U.length v === n + 1+ | otherwise+ = not (testBit v n) .&&. popCount v === 0 .&&. U.length v === 0 where v :: U.Vector Bit v = bit n@@ -172,3 +312,18 @@ prop_shiftR (NonNegative n) v = U.drop n v === U.drop n u .&&. popCount (U.take n u) === 0 where u = (v `shiftR` n) `shiftL` n++prop_zeroBits :: Property+prop_zeroBits = once $+ U.length (zeroBits :: U.Vector Bit) === 0++prop_bitSize :: U.Vector Bit -> Property+prop_bitSize v = bitSizeMaybe v === Nothing++prop_isSigned :: U.Vector Bit -> Property+prop_isSigned v = isSigned v === False++prop_cloneToByteString :: U.Vector Bit -> Property+prop_cloneToByteString v = cloneToByteString (cloneFromByteString bs) === bs+ where+ bs = cloneToByteString v