diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# 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) +# bitvec [![GitHub Build Status](https://github.com/Bodigrim/bitvec/workflows/ci/badge.svg)](https://github.com/Bodigrim/bitvec/actions?query=workflow%3Aci) [![Travis Build Status](https://travis-ci.com/Bodigrim/bitvec.svg)](https://travis-ci.com/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) [![Coverage Status](https://coveralls.io/repos/github/Bodigrim/bitvec/badge.svg)](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). diff --git a/bench/Bench/GCD.hs b/bench/Bench/GCD.hs --- a/bench/Bench/GCD.hs +++ b/bench/Bench/GCD.hs @@ -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 diff --git a/bench/Bench/Intersection.hs b/bench/Bench/Intersection.hs --- a/bench/Bench/Intersection.hs +++ b/bench/Bench/Intersection.hs @@ -13,7 +13,7 @@ randomBools :: [Bool] randomBools - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bench/Bench/Invert.hs b/bench/Bench/Invert.hs --- a/bench/Bench/Invert.hs +++ b/bench/Bench/Invert.hs @@ -12,7 +12,7 @@ randomBools :: [Bool] randomBools - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bench/Bench/Product.hs b/bench/Bench/Product.hs --- a/bench/Bench/Product.hs +++ b/bench/Bench/Product.hs @@ -12,7 +12,7 @@ randomBools :: [Bool] randomBools - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bench/Bench/RandomRead.hs b/bench/Bench/RandomRead.hs --- a/bench/Bench/RandomRead.hs +++ b/bench/Bench/RandomRead.hs @@ -15,7 +15,7 @@ randomVec :: [Bool] randomVec - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bench/Bench/Remainder.hs b/bench/Bench/Remainder.hs --- a/bench/Bench/Remainder.hs +++ b/bench/Bench/Remainder.hs @@ -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))) diff --git a/bench/Bench/Reverse.hs b/bench/Bench/Reverse.hs --- a/bench/Bench/Reverse.hs +++ b/bench/Bench/Reverse.hs @@ -12,7 +12,7 @@ randomBools :: [Bool] randomBools - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bench/Bench/Sum.hs b/bench/Bench/Sum.hs --- a/bench/Bench/Sum.hs +++ b/bench/Bench/Sum.hs @@ -13,7 +13,7 @@ randomBools :: [Bool] randomBools - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bench/Bench/Union.hs b/bench/Bench/Union.hs --- a/bench/Bench/Union.hs +++ b/bench/Bench/Union.hs @@ -13,7 +13,7 @@ randomBools :: [Bool] randomBools - = map (\i -> if i > (0 :: Int) then True else False) + = map (> (0 :: Int)) . randoms . mkStdGen $ 42 diff --git a/bitvec.cabal b/bitvec.cabal --- a/bitvec.cabal +++ b/bitvec.cabal @@ -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 homepage: https://github.com/Bodigrim/bitvec synopsis: Space-efficient bit vectors @@ -46,7 +46,7 @@ author: Andrew Lelechenko , James Cook -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs --- a/src/Data/Bit.hs +++ b/src/Data/Bit.hs @@ -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 -- @@ -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 -- @@ -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 diff --git a/src/Data/Bit/F2Poly.hs b/src/Data/Bit/F2Poly.hs --- a/src/Data/Bit/F2Poly.hs +++ b/src/Data/Bit/F2Poly.hs @@ -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. diff --git a/src/Data/Bit/Gmp.hs b/src/Data/Bit/Gmp.hs --- a/src/Data/Bit/Gmp.hs +++ b/src/Data/Bit/Gmp.hs @@ -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 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 @@ -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 _) = [] 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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))) diff --git a/test/Support.hs b/test/Support.hs --- a/test/Support.hs +++ b/test/Support.hs @@ -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) = diff --git a/test/Tests/Conc.hs b/test/Tests/Conc.hs --- a/test/Tests/Conc.hs +++ b/test/Tests/Conc.hs @@ -1,4 +1,6 @@ -module Tests.Conc where +module Tests.Conc + ( concTests + ) where import Control.Concurrent import Control.Monad diff --git a/test/Tests/F2Poly.hs b/test/Tests/F2Poly.hs new file mode 100644 --- /dev/null +++ b/test/Tests/F2Poly.hs @@ -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))) diff --git a/test/Tests/MVector.hs b/test/Tests/MVector.hs --- a/test/Tests/MVector.hs +++ b/test/Tests/MVector.hs @@ -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 diff --git a/test/Tests/SetOps.hs b/test/Tests/SetOps.hs --- a/test/Tests/SetOps.hs +++ b/test/Tests/SetOps.hs @@ -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 diff --git a/test/Tests/Vector.hs b/test/Tests/Vector.hs --- a/test/Tests/Vector.hs +++ b/test/Tests/Vector.hs @@ -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