diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,30 @@ -I hereby release this code to the public domain. +Copyright (c) 2019 Andrew Lelechenko, 2012-2016 James Cook -If for some reason that's not possible or somehow gets revoked (the expected reason being the insanity of our lawyerocracy), I retain or immediately reclaim all rights and explicitly grant an unlimited, eternal and irrevocable license to everyone else, whether or not they are legally recognized as a sentient person, to do absolutely anything they want to do with this code, at no charge. +All rights reserved. -Furthermore, this code is provided as-is. I explicitly decline to offer any warrantee, either express or implied, not even the so-called "implied warantees" of merchantability, fitness for a particular purpose, or any other crazy ideas the aforementioned lawyers have created in their unholy quest for ever-more money and/or power. For that matter, I don't even warrant that the use of this code won't start a global thermonuclear war or runaway nanotechnology event (though if you're worried about such things, I can tell you off-the-record that it probably won't do either). +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of the contributors may not be used to endorse may be + used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,41 @@ +module Main where + +import Control.Monad +import Control.Monad.ST +import Data.Bit +import qualified Data.Bit.ThreadSafe as TS +import Data.Bits +import qualified Data.Vector.Unboxed.Mutable as MU +import Gauge.Main + +main :: IO () +main = defaultMain + [ bgroup "randomWrite" $ map benchRandomWrite [5..10] + , bgroup "randomWriteTS" $ map benchRandomWriteTS [5..10] + ] + +benchRandomWrite :: Int -> Benchmark +benchRandomWrite k = bench (show (2 ^ k)) $ nf doRandomWrite k + +doRandomWrite :: Int -> Int +doRandomWrite k = runST $ do + let n = 2 ^ k + ixs = scanl xor 0 [0..n-1] + vals = take 100 $ cycle [Bit True, Bit False] + vec <- MU.new n + forM_ vals $ \v -> forM_ ixs $ \i -> MU.unsafeWrite vec i v + Bit i <- MU.unsafeRead vec 0 + pure $ if i then 1 else 0 + +benchRandomWriteTS :: Int -> Benchmark +benchRandomWriteTS k = bench (show (2 ^ k)) $ nf doRandomWriteTS k + +doRandomWriteTS :: Int -> Int +doRandomWriteTS k = runST $ do + let n = 2 ^ k + ixs = scanl xor 0 [0..n-1] + vals = take 100 $ cycle [TS.Bit True, TS.Bit False] + vec <- MU.new n + forM_ vals $ \v -> forM_ ixs $ \i -> MU.unsafeWrite vec i v + TS.Bit i <- MU.unsafeRead vec 0 + pure $ if i then 1 else 0 diff --git a/bitvec.cabal b/bitvec.cabal --- a/bitvec.cabal +++ b/bitvec.cabal @@ -1,26 +1,47 @@ name: bitvec -version: 0.2.0.1 +version: 1.0.0.0 cabal-version: >=1.10 build-type: Simple -license: PublicDomain +license: BSD3 license-file: LICENSE +copyright: 2019 Andrew Lelechenko, 2012-2016 James Cook maintainer: Andrew Lelechenko homepage: https://github.com/Bodigrim/bitvec synopsis: Unboxed bit vectors description: Bit vectors library for Haskell. - - The current @vector@ package represents unboxed arrays of @Bool@ + . + The current [vector](https://hackage.haskell.org/package/vector) + package represents unboxed arrays of 'Bool' allocating one byte per boolean, which might be considered wasteful. - This library provides a newtype wrapper @Bit@ and a custom instance - of unboxed @Vector@, which packs booleans densely. + This library provides a newtype wrapper 'Data.Bit.Bit' and a custom instance + of unboxed 'Data.Vector.Unboxed.Vector', which packs booleans densely. It is a time-memory tradeoff: 8x less memory footprint at the price of moderate performance penalty (mostly, for random writes). + . + === Thread safety + * "Data.Bit" is faster, but thread-unsafe. This is because + naive updates are not atomic operations: read the whole word from memory, + modify a bit, write the whole word back. + * "Data.Bit.ThreadSafe" is slower (up to 2x), but thread-safe. + . + === Similar packages + . + * [bv](https://hackage.haskell.org/package/bv) + and [bv-little](https://hackage.haskell.org/package/bv-little) + offer only immutable size-polymorphic bit vectors. + @bitvec@ provides an interface to mutable vectors as well. + . + * [array](https://hackage.haskell.org/package/array) + is memory-efficient for 'Bool', but lacks + a handy 'Vector' interface and is not thread-safe. + category: Data, Bit Vectors -author: James Cook , - Andrew Lelechenko -tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.3 GHC ==8.6.3 +author: Andrew Lelechenko , + James Cook + +tested-with: GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 extra-source-files: changelog.md @@ -28,41 +49,77 @@ type: git location: git://github.com/Bodigrim/bitvec.git +flag bmi2 + description: Enable bmi2 instruction set + manual: False + default: False + library exposed-modules: Data.Bit - Data.Vector.Unboxed.Bit - Data.Vector.Unboxed.Mutable.Bit + Data.Bit.ThreadSafe build-depends: base >=4.8 && <5, - primitive -any, - vector >=0.8 + ghc-prim, + primitive >=0.5, + vector >=0.11 + if (flag(bmi2)) && (impl(ghc >=8.4.1)) + build-depends: + bits-extra >=0.0.0.4 && <0.1 + if impl(ghc <8.0) + build-depends: + semigroups >=0.8 default-language: Haskell2010 hs-source-dirs: src other-modules: + Data.Bit.Immutable + Data.Bit.ImmutableTS Data.Bit.Internal - Data.Vector.Unboxed.Bit.Internal - ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-type-defaults + Data.Bit.InternalTS + Data.Bit.Mutable + Data.Bit.MutableTS + Data.Bit.Select1 + Data.Bit.Utils + ghc-options: -O2 -Wall + include-dirs: src + if (flag(bmi2)) && (impl(ghc >=8.4.1)) + ghc-options: -mbmi2 -msse4.2 + cpp-options: -DBMI2_ENABLED test-suite bitvec-tests type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >=4.8 && <5, - bitvec -any, - HUnit -any, - primitive -any, - vector >=0.8, - test-framework -any, - test-framework-hunit -any, - test-framework-quickcheck2 -any, - QuickCheck >=2.10, - quickcheck-classes >=0.6.1 + bitvec, + 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.MVector + Tests.MVectorTS Tests.SetOps Tests.Vector - ghc-options: -threaded -fwarn-unused-imports -fwarn-unused-binds + ghc-options: -Wall + include-dirs: test + +benchmark gauge + build-depends: + base, + bitvec, + gauge, + vector + type: exitcode-stdio-1.0 + main-is: Bench.hs + default-language: Haskell2010 + hs-source-dirs: bench + ghc-options: -O2 -Wall diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +# 1.0.0.0 + +* Redesign API from the scratch. +* Add a thread-safe implementation. +* Add 'nthBitIndex' function. + # 0.2.0.1 * Fix 'Read' instance. diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs --- a/src/Data/Bit.hs +++ b/src/Data/Bit.hs @@ -1,6 +1,66 @@ +{-# LANGUAGE CPP #-} + +#ifndef BITVEC_THREADSAFE +-- | +-- Module: Data.Bit +-- Copyright: (c) 2019 Andrew Lelechenko, 2012-2016 James Cook +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko +-- +-- This module exposes a faster, but thread-unsafe implementation. +-- Consider using "Data.Bit.ThreadSafe", which is thread-safe, but slower (up to 2x). module Data.Bit - ( Bit(..) +#else +-- | +-- Module: Data.Bit.ThreadSafe +-- Copyright: (c) 2019 Andrew Lelechenko, 2012-2016 James Cook +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko +-- +-- This module exposes a slower (up to 2x), but thread-safe implementation. +-- Consider using "Data.Bit", which is faster, but thread-unsafe. +module Data.Bit.ThreadSafe +#endif + ( Bit(..) + + , unsafeFlipBit + , flipBit + + -- * Immutable conversions + , castFromWords + , castToWords + , cloneToWords + + -- * Immutable operations + , zipBits + , bitIndex + , nthBitIndex + , countBits + , listBits + , selectBits + , excludeBits + + -- * Mutable conversions + , castFromWordsM + , castToWordsM + , cloneToWordsM + + -- * Mutable operations + , invertInPlace + , zipInPlace + , selectBitsInPlace + , excludeBitsInPlace + , reverseInPlace ) where +import Prelude hiding (and, or) + +#ifndef BITVEC_THREADSAFE +import Data.Bit.Immutable import Data.Bit.Internal -import Data.Vector.Unboxed.Bit.Internal ({- instance Unbox Bit -}) +import Data.Bit.Mutable +#else +import Data.Bit.ImmutableTS +import Data.Bit.InternalTS +import Data.Bit.MutableTS +#endif diff --git a/src/Data/Bit/Immutable.hs b/src/Data/Bit/Immutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Immutable.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +#ifndef BITVEC_THREADSAFE +module Data.Bit.Immutable +#else +module Data.Bit.ImmutableTS +#endif + ( castFromWords + , castToWords + , cloneToWords + + , zipBits + + , selectBits + , excludeBits + , bitIndex + ) where + +import Control.Monad +import Control.Monad.ST +import Data.Bits +#ifndef BITVEC_THREADSAFE +import Data.Bit.Internal +import qualified Data.Bit.Mutable as B +#else +import Data.Bit.InternalTS +import qualified Data.Bit.MutableTS as B +#endif +import Data.Bit.Utils +import qualified Data.Vector.Generic.Mutable as MV +import qualified Data.Vector.Generic as V +import Data.Vector.Unboxed as U + hiding (and, or, any, all, reverse, findIndex) +import qualified Data.Vector.Unboxed as Unsafe +import Data.Word +import Prelude as P + hiding (and, or, any, all, reverse) + +-- | Cast a vector of words to a vector of bits. +-- Cf. 'Data.Bit.castFromWordsM'. +-- +-- >>> castFromWords (Data.Vector.Unboxed.singleton 123) +-- [1,1,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] +castFromWords + :: U.Vector Word + -> U.Vector Bit +castFromWords ws = BitVec 0 (nBits (V.length ws)) ws + +-- | Try to cast a vector of bits to a vector of words. +-- It succeeds if a vector of bits is aligned. +-- Use 'cloneToWords' otherwise. +-- Cf. 'Data.Bit.castToWordsM'. +-- +-- prop> castToWords (castFromWords v) == Just v +castToWords + :: U.Vector Bit + -> Maybe (U.Vector Word) +castToWords (BitVec s n ws) + | aligned s + , aligned n + = Just $ V.slice (divWordSize s) (nWords n) ws + | otherwise + = Nothing + +-- | Clone a vector of bits to a new unboxed vector of words. +-- If the bits don't completely fill the words, the last word will be zero-padded. +-- Cf. 'Data.Bit.cloneToWordsM'. +-- +-- >>> cloneToWords (read "[1,1,0,1,1,1,1,0]") +-- [123] +cloneToWords + :: U.Vector Bit + -> U.Vector Word +cloneToWords v@(BitVec _ n _) = runST $ do + ws <- MV.new (nWords n) + let loop !i !j + | i >= n = return () + | otherwise = do + MV.write ws j (indexWord v i) + loop (i + wordSize) (j + 1) + loop 0 0 + V.unsafeFreeze ws +{-# INLINE cloneToWords #-} + +-- | Zip two vectors with the given function. +-- Similar to 'Data.Vector.Unboxed.zipWith', but much faster. +-- +-- >>> import Data.Bits +-- >>> zipBits (.&.) (read "[1,1,0]") (read "[0,1,1]") -- intersection +-- [0,1,0] +-- >>> zipBits (.|.) (read "[1,1,0]") (read "[0,1,1]") -- union +-- [1,1,1] +-- >>> zipBits (\x y -> x .&. complement y) (read "[1,1,0]") (read "[0,1,1]") -- difference +-- [1,0,0] +-- >>> zipBits xor (read "[1,1,0]") (read "[0,1,1]") -- symmetric difference +-- [1,0,1] +zipBits + :: (forall a. Bits a => a -> a -> a) + -> U.Vector Bit + -> U.Vector Bit + -> U.Vector Bit +zipBits f xs ys + | U.length xs >= U.length ys = zs + | otherwise = U.slice 0 (U.length xs) zs + where + zs = U.modify (B.zipInPlace f xs) ys + +-- | For each set bit of the first argument, deposit +-- 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]") +-- [1,0,1] +-- +-- Here is a reference (but slow) implementation: +-- +-- > import qualified Data.Vector.Unboxed as U +-- > selectBits mask ws == U.map snd (U.filter (unBit . fst) (U.zip mask ws)) +selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +selectBits is xs = runST $ do + xs1 <- U.thaw xs + n <- B.selectBitsInPlace is xs1 + Unsafe.unsafeFreeze (MV.take n xs1) + +-- | For each unset bit of the first argument, deposit +-- the corresponding bit of the second argument +-- to the result. +-- +-- >>> excludeBits (read "[0,1,0,1,1]") (read "[1,1,0,0,1]") +-- [1,0] +-- +-- Here is a reference (but slow) implementation: +-- +-- > import qualified Data.Vector.Unboxed as U +-- > excludeBits mask ws == U.map snd (U.filter (not . unBit . fst) (U.zip mask ws)) +excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +excludeBits is xs = runST $ do + xs1 <- U.thaw xs + n <- B.excludeBitsInPlace is xs1 + Unsafe.unsafeFreeze (MV.take n xs1) + +-- | Return the index of the first bit in the vector +-- with the specified value, if any. +-- Similar to 'Data.Vector.Unboxed.elemIndex', but much faster. +-- +-- >>> bitIndex (Bit True) (read "[0,0,1,0,1]") +-- Just 2 +-- >>> bitIndex (Bit True) (read "[0,0,0,0,0]") +-- Nothing +-- +-- prop> 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) +bitIndex :: Bit -> U.Vector Bit -> Maybe Int +bitIndex b xs = mfilter (< n) (loop 0) + where + !n = V.length xs + !ff | unBit b = ffs + | otherwise = ffs . complement + + loop !i + | i >= n = Nothing + | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize) diff --git a/src/Data/Bit/ImmutableTS.hs b/src/Data/Bit/ImmutableTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/ImmutableTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/Immutable.hs" 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 @@ -1,13 +1,53 @@ +{-# LANGUAGE CPP #-} + {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} -module Data.Bit.Internal where +#ifndef BITVEC_THREADSAFE +module Data.Bit.Internal +#else +module Data.Bit.InternalTS +#endif + ( Bit(..) + , U.Vector(BitVec) + , U.MVector(BitMVec) + , indexWord + , readWord + , writeWord + , unsafeFlipBit + , flipBit + + , nthBitIndex + , countBits + , listBits + ) where + +#include "vector.h" + +import Control.Monad +import Control.Monad.Primitive +import Data.Bit.Select1 +import Data.Bit.Utils import Data.Bits -import Data.List import Data.Typeable +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as MV +import qualified Data.Vector.Unboxed as U +#ifdef BITVEC_THREADSAFE +import Data.Primitive.ByteArray +import qualified Data.Vector.Primitive as P +import GHC.Exts +#endif + -- | A newtype wrapper with a custom instance -- of "Data.Vector.Unboxed", which packs booleans -- as efficient as possible (8 values per byte). @@ -15,17 +55,9 @@ -- than vectors of 'Bool' (which stores one value per byte), -- but random writes -- are slightly slower. --- --- In addition to "Data.Vector.Unboxed" interface, --- one can also find assorted utilities --- from "Data.Vector.Unboxed.Bit" --- and "Data.Vector.Unboxed.Mutable.Bit". newtype Bit = Bit { unBit :: Bool } deriving (Bounded, Enum, Eq, Ord, FiniteBits, Bits, Typeable) -fromBool :: Bool -> Bit -fromBool b = Bit b - instance Show Bit where showsPrec _ (Bit False) = showString "0" showsPrec _ (Bit True ) = showString "1" @@ -36,148 +68,493 @@ readsPrec _ ('1':rest) = [(Bit True, rest)] readsPrec _ _ = [] --- various internal utility functions and constants +instance U.Unbox Bit -lg2 :: Int -> Int -lg2 n = i - where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1) +-- Ints are offset and length in bits +data instance U.MVector s Bit = BitMVec !Int !Int !(U.MVector s Word) +data instance U.Vector Bit = BitVec !Int !Int !(U.Vector Word) +readBit :: Int -> Word -> Bit +readBit i w = Bit (w .&. (1 `unsafeShiftL` i) /= 0) +{-# INLINE readBit #-} --- |The number of 'Bit's in a 'Word'. A handy constant to have around when defining 'Word'-based bulk operations on bit vectors. -wordSize :: Int -wordSize = finiteBitSize (0 :: Word) +extendToWord :: Bit -> Word +extendToWord (Bit False) = 0 +extendToWord (Bit True) = complement 0 -lgWordSize, wordSizeMask, wordSizeMaskC :: Int -lgWordSize = case wordSize of - 32 -> 5 - 64 -> 6 - _ -> lg2 wordSize +-- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the result is zero-padded. +indexWord :: U.Vector Bit -> Int -> Word +indexWord (BitVec 0 n v) i + | aligned i = masked b lo + | j + 1 == nWords n = masked b (extractWord k lo 0 ) + | otherwise = masked b (extractWord k lo hi) + where + b = n - i + j = divWordSize i + k = modWordSize i + lo = v V.! j + hi = v V.! (j+1) +indexWord (BitVec s n v) i = indexWord (BitVec 0 (n + s) v) (i + s) -wordSizeMask = wordSize - 1 -wordSizeMaskC = complement wordSizeMask +-- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the result is zero-padded. +readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word +readWord (BitMVec 0 n v) i + | aligned i = liftM (masked b) lo + | j + 1 == nWords n = liftM (masked b) (liftM2 (extractWord k) lo (return 0)) + | otherwise = liftM (masked b) (liftM2 (extractWord k) lo hi) + where + b = n - i + j = divWordSize i + k = modWordSize i + lo = MV.read v j + hi = MV.read v (j+1) +readWord (BitMVec s n v) i = readWord (BitMVec 0 (n + s) v) (i + s) -divWordSize :: Bits a => a -> a -divWordSize x = shiftR x lgWordSize +-- | write a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the word is truncated and as many low-order bits as possible are written. +writeWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> Word -> m () +writeWord (BitMVec 0 n v) i x + | aligned i = + if b < wordSize + then do + y <- MV.read v j + MV.write v j (meld b x y) + else MV.write v j x + | j + 1 == nWords n = do + lo <- MV.read v j + let x' = if b < wordSize + then meld b x (extractWord k lo 0) + else x + (lo', _hi) = spliceWord k lo 0 x' + MV.write v j lo' + | otherwise = do + lo <- MV.read v j + hi <- if j + 1 == nWords n + then return 0 + else MV.read v (j+1) + let x' = if b < wordSize + then meld b x (extractWord k lo hi) + else x + (lo', hi') = spliceWord k lo hi x' + MV.write v j lo' + MV.write v (j+1) hi' + where + b = n - i + j = divWordSize i + k = modWordSize i +writeWord (BitMVec s n v) i x = writeWord (BitMVec 0 (n + s) v) (i + s) x -modWordSize :: Int -> Int -modWordSize x = x .&. (wordSize - 1) +instance MV.MVector U.MVector Bit where + {-# INLINE basicInitialize #-} + basicInitialize (BitMVec _ 0 _) = pure () + basicInitialize (BitMVec 0 n v) = case modWordSize n of + 0 -> MV.basicInitialize v + nMod -> do + let vLen = MV.basicLength v + MV.basicInitialize (MV.slice 0 (vLen - 1) v) + MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1) + basicInitialize (BitMVec s n v) = case modWordSize (s + n) of + 0 -> do + let vLen = MV.basicLength v + MV.basicInitialize (MV.slice 1 (vLen - 1) v) + MV.modify v (\val -> val .&. loMask s) 0 + nMod -> do + let vLen = MV.basicLength v + lohiMask = loMask s .|. hiMask nMod + if vLen == 1 + then MV.modify v (\val -> val .&. lohiMask) 0 + else do + MV.basicInitialize (MV.slice 1 (vLen - 2) v) + MV.modify v (\val -> val .&. loMask s) 0 + MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1) -mulWordSize :: Bits a => a -> a -mulWordSize x = shiftL x lgWordSize + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n = liftM (BitMVec 0 n) (MV.basicUnsafeNew (nWords n)) --- number of words needed to store n bits -nWords :: Int -> Int -nWords ns = divWordSize (ns + wordSize - 1) + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x)) --- number of bits storable in n words -nBits :: Bits a => a -> a -nBits ns = mulWordSize ns + {-# INLINE basicOverlaps #-} + basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2 -aligned :: Int -> Bool -aligned x = (x .&. wordSizeMask == 0) + {-# INLINE basicLength #-} + basicLength (BitMVec _ n _) = n -notAligned :: Int -> Bool -notAligned x = x /= alignDown x + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (BitMVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i)) --- round a number of bits up to the nearest multiple of word size -alignUp :: Int -> Int -alignUp x - | x == x' = x' - | otherwise = x' + wordSize - where x' = alignDown x + {-# INLINE basicUnsafeWrite #-} +#ifndef BITVEC_THREADSAFE + basicUnsafeWrite (BitMVec s _ v) !i' !x = do + let i = s + i' + let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k + w <- MV.basicUnsafeRead v j + when (Bit (w .&. kk /= 0) /= x) $ + MV.basicUnsafeWrite v j (w `xor` kk) +#else + basicUnsafeWrite (BitMVec s _ (U.MV_Word (P.MVector o _ (MutableByteArray mba)))) !i' (Bit b) = do + let i = s + i' + !(I# j) = o + divWordSize i + !(I# k) = 1 `unsafeShiftL` modWordSize i + primitive $ \state -> + let !(# state', _ #) = (if b then fetchOrIntArray# mba j k state else fetchAndIntArray# mba j (notI# k) state) in + (# state', () #) +#endif --- round a number of bits down to the nearest multiple of word size -alignDown :: Int -> Int -alignDown x = x .&. wordSizeMaskC + {-# INLINE basicClear #-} + basicClear _ = pure () -readBit :: Int -> Word -> Bit -readBit i w = fromBool (w .&. (1 `unsafeShiftL` i) /= 0) + {-# INLINE basicSet #-} + basicSet (BitMVec _ 0 _) _ = pure () + basicSet (BitMVec 0 n v) (extendToWord -> x) = case modWordSize n of + 0 -> MV.basicSet v x + nMod -> do + let vLen = MV.basicLength v + MV.basicSet (MV.slice 0 (vLen - 1) v) x + MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1) + basicSet (BitMVec s n v) (extendToWord -> x) = case modWordSize (s + n) of + 0 -> do + let vLen = MV.basicLength v + MV.basicSet (MV.slice 1 (vLen - 1) v) x + MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0 + nMod -> do + let vLen = MV.basicLength v + lohiMask = loMask s .|. hiMask nMod + if vLen == 1 + then MV.modify v (\val -> val .&. lohiMask .|. x .&. complement lohiMask) 0 + else do + MV.basicSet (MV.slice 1 (vLen - 2) v) x + MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0 + MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1) -extendToWord :: Bit -> Word -extendToWord (Bit False) = 0 -extendToWord (Bit True) = complement 0 + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy _ (BitMVec _ 0 _) = pure () + basicUnsafeCopy (BitMVec 0 _ dst) (BitMVec 0 n src) = case modWordSize n of + 0 -> MV.basicUnsafeCopy dst src + nMod -> do + let vLen = MV.basicLength src + MV.basicUnsafeCopy (MV.slice 0 (vLen - 1) dst) (MV.slice 0 (vLen - 1) src) + valSrc <- MV.basicUnsafeRead src (vLen - 1) + MV.modify dst (\val -> val .&. hiMask nMod .|. valSrc .&. loMask nMod) (vLen - 1) + basicUnsafeCopy (BitMVec dstShift _ dst) (BitMVec s n src) + | dstShift == s = case modWordSize (s + n) of + 0 -> do + let vLen = MV.basicLength src + MV.basicUnsafeCopy (MV.slice 1 (vLen - 1) dst) (MV.slice 1 (vLen - 1) src) + valSrc <- MV.basicUnsafeRead src 0 + MV.modify dst (\val -> val .&. loMask s .|. valSrc .&. hiMask s) 0 + nMod -> do + let vLen = MV.basicLength src + lohiMask = loMask s .|. hiMask nMod + if vLen == 1 + then do + valSrc <- MV.basicUnsafeRead src 0 + MV.modify dst (\val -> val .&. lohiMask .|. valSrc .&. complement lohiMask) 0 + else do + MV.basicUnsafeCopy (MV.slice 1 (vLen - 2) dst) (MV.slice 1 (vLen - 2) src) + valSrcFirst <- MV.basicUnsafeRead src 0 + MV.modify dst (\val -> val .&. loMask s .|. valSrcFirst .&. hiMask s) 0 + valSrcLast <- MV.basicUnsafeRead src (vLen - 1) + MV.modify dst (\val -> val .&. hiMask nMod .|. valSrcLast .&. loMask nMod) (vLen - 1) --- 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 + basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0 + where + n = alignUp len -masked :: Int -> Word -> Word -masked b x = x .&. mask b + do_copy i + | i < n = do + x <- readWord src i + writeWord dst i x + do_copy (i+wordSize) + | otherwise = return () -isMasked :: Int -> Word -> Bool -isMasked b x = (masked b x == x) + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _) + | MV.basicOverlaps dst src = do + -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src + -- TODO write tests on copy and move inside array + srcCopy <- BitMVec srcShift srcLen <$> MV.basicUnsafeNew (nWords (srcShift + srcLen)) + MV.basicUnsafeCopy srcCopy src + MV.basicUnsafeCopy dst srcCopy + | otherwise = MV.basicUnsafeCopy dst src --- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi' -meld :: Int -> Word -> Word -> Word -meld b lo hi = (lo .&. m) .|. (hi .&. complement m) - where m = mask b + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice offset n (BitMVec s _ v) = + BitMVec relStartBit n (MV.basicUnsafeSlice startWord (endWord - startWord) v) + where + absStartBit = s + offset + relStartBit = modWordSize absStartBit + absEndBit = absStartBit + n + endWord = nWords absEndBit + startWord = divWordSize absStartBit --- given a bit offset 'k' and 2 words, extract a word by taking the 'k' highest bits of the first word and the 'wordSize - k' lowest bits of the second word. -{-# INLINE extractWord #-} -extractWord :: Int -> Word -> Word -> Word -extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k)) + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (BitMVec s n v) by = + BitMVec s (n + by) <$> if delta == 0 then pure v else MV.basicUnsafeGrow v delta + where + delta = nWords (s + n + by) - nWords (s + n) --- given a bit offset 'k', 2 words 'lo' and 'hi' and a word 'x', overlay 'x' onto 'lo' and 'hi' at the position such that (k `elem` [0..wordSize] ==> uncurry (extractWord k) (spliceWord k lo hi x) == x) and (k `elem` [0..wordSize] ==> spliceWord k lo hi (extractWord k lo hi) == (lo,hi)) -{-# INLINE spliceWord #-} -spliceWord :: Int -> Word -> Word -> Word -> (Word, Word) -spliceWord k lo hi x = - ( meld k lo (x `shiftL` k) - , meld k (x `shiftR` (wordSize - k)) hi - ) +#ifndef BITVEC_THREADSAFE --- this could be given a more general type, but it would be wrong; it works for any fixed word size, but only for unsigned types -reverseWord :: Word -> Word -reverseWord xx = foldr swap xx masks - where - nextMask (d, x) = (d', x `xor` shift x d') - where !d' = d `shiftR` 1 +-- | Flip the bit at the given position. +-- No bounds checks are performed. +-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement', +-- but slightly faster. +-- +-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors: +-- 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] +unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m () +unsafeFlipBit (BitMVec s _ v) !i' = do + let i = s + i' + let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k + w <- MV.basicUnsafeRead v j + MV.basicUnsafeWrite v j (w `xor` kk) +{-# INLINE unsafeFlipBit #-} - !(_:masks) = - takeWhile ((0 /=) . snd) - (iterate nextMask (finiteBitSize xx, maxBound)) +-- | Flip the bit at the given position. +-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement', +-- but slightly faster. +-- +-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors: +-- either you modify it with 'id' (which is 'id' altogether) +-- or with 'Data.Bits.complement' (which is 'flipBit'). +-- +-- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]") +-- [1,0,1] +flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m () +flipBit v i = BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i +{-# INLINE flipBit #-} - swap (n, m) x = ((x .&. m) `shiftL` n) .|. ((x .&. complement m) `shiftR` n) +#else - -- TODO: is an unrolled version like "loop lgWordSize" faster than the generic implementation above? If so, can that be fixed? - -- loop 0 x = x - -- loop 1 x = loop 0 (((x .&. 0x5555555555555555) `shiftL` 1) .|. ((x .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1)) - -- loop 2 x = loop 1 (((x .&. 0x3333333333333333) `shiftL` 2) .|. ((x .&. 0xCCCCCCCCCCCCCCCC) `shiftR` 2)) - -- loop 3 x = loop 2 (((x .&. 0x0F0F0F0F0F0F0F0F) `shiftL` 4) .|. ((x .&. 0xF0F0F0F0F0F0F0F0) `shiftR` 4)) - -- loop 4 x = loop 3 (((x .&. 0x00FF00FF00FF00FF) `shiftL` 8) .|. ((x .&. 0xFF00FF00FF00FF00) `shiftR` 8)) - -- loop 5 x = loop 4 (((x .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x .&. 0xFFFF0000FFFF0000) `shiftR` 16)) - -- loop 6 x = loop 5 (((x .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x .&. 0xFFFFFFFF00000000) `shiftR` 32)) - -- loop _ _ = error "reverseWord only implemented for up to 64 bit words!" +-- | Flip the bit at the given position. +-- No bounds checks are performed. +-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement', +-- but slightly faster and atomic. +-- +-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors: +-- 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] +unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m () +unsafeFlipBit (BitMVec s _ (U.MV_Word (P.MVector o _ (MutableByteArray mba)))) !i' = do + let i = s + i' + !(I# j) = o + divWordSize i + !(I# k) = 1 `unsafeShiftL` modWordSize i + primitive $ \state -> + let !(# state', _ #) = fetchXorIntArray# mba j k state in + (# state', () #) +{-# INLINE unsafeFlipBit #-} -reversePartialWord :: Int -> Word -> Word -reversePartialWord n w - | n >= wordSize = reverseWord w - | otherwise = reverseWord w `shiftR` (wordSize - n) +-- | Flip the bit at the given position. +-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement', +-- but slightly faster and atomic +-- +-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors: +-- either you modify it with 'id' (which is 'id' altogether) +-- or with 'Data.Bits.complement' (which is 'flipBit'). +-- +-- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]") +-- [1,0,1] +flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m () +flipBit v i = BOUNDS_CHECK(checkIndex) "flipBit" i (MV.length v) $ unsafeFlipBit v i +{-# INLINE flipBit #-} -diff :: Word -> Word -> Word -diff w1 w2 = w1 .&. complement w2 +#endif -ffs :: Word -> Maybe Int -ffs 0 = Nothing -ffs x = Just $! (popCount (x `xor` complement (-x)) - 1) +instance V.Vector U.Vector Bit where + basicUnsafeFreeze (BitMVec s n v) = liftM (BitVec s n) (V.basicUnsafeFreeze v) + basicUnsafeThaw (BitVec s n v) = liftM (BitMVec s n) (V.basicUnsafeThaw v) + basicLength (BitVec _ n _) = n --- TODO: this can probably be faster --- the interface is very specialized here; 'j' is an offset to add to every bit index and the result is a difference list -bitsInWord :: Int -> Word -> [Int] -> [Int] -bitsInWord j = loop id + basicUnsafeIndexM (BitVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i)) + + basicUnsafeCopy dst src = do + src1 <- V.basicUnsafeThaw src + MV.basicUnsafeCopy dst src1 + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice offset n (BitVec s _ v) = + BitVec relStartBit n (V.basicUnsafeSlice startWord (endWord - startWord) v) + where + absStartBit = s + offset + relStartBit = modWordSize absStartBit + absEndBit = absStartBit + n + endWord = nWords absEndBit + startWord = divWordSize absStartBit + +-- | Return the index of the @n@-th bit in the vector +-- with the specified value, if any. +-- Here @n@ is 1-based and the index is 0-based. +-- Non-positive @n@ results in an error. +-- +-- >>> nthBitIndex (Bit True) 2 (read "[0,1,0,1,1,1,0]") +-- Just 3 +-- >>> nthBitIndex (Bit True) 5 (read "[0,1,0,1,1,1,0]") +-- Nothing +-- +-- One can use 'nthBitIndex' to implement +-- to implement @select{0,1}@ queries +-- for . +nthBitIndex :: Bit -> Int -> U.Vector Bit -> Maybe Int +nthBitIndex _ k + | k <= 0 = error "nthBitIndex: n must be positive" +nthBitIndex (Bit True) k = \case + BitVec _ 0 _ -> Nothing + BitVec 0 n v -> let l = V.basicLength v in case modWordSize n of + 0 -> case nth1InWords k v of + Right x -> Just x + Left{} -> Nothing + nMod -> case nth1InWords k (V.slice 0 (l - 1) v) of + Right x -> Just x + Left k' -> case nth1 k' (V.last v .&. loMask nMod) of + Right x -> Just $ mulWordSize (l - 1) + x + Left{} -> Nothing + BitVec s n v -> let l = V.basicLength v in case modWordSize (s + n) of + 0 -> case nth1 k (V.head v `unsafeShiftR` s) of + Right x -> Just x + Left k' -> case nth1InWords k' (V.slice 1 (l - 1) v) of + Right x -> Just $ wordSize - s + x + Left {} -> Nothing + nMod -> case l of + 1 -> case nth1 k ((V.head v `unsafeShiftR` s) .&. loMask n) of + Right x -> Just x + Left{} -> Nothing + _ -> case nth1 k (V.head v `unsafeShiftR` s) of + Right x -> Just x + Left k' -> case nth1InWords k' (V.slice 1 (l - 2) v) of + Right x -> Just $ wordSize - s + x + Left k'' -> case nth1 k'' (V.last v .&. loMask nMod) of + Right x -> Just $ mulWordSize (l - 1) - s + x + Left{} -> Nothing +nthBitIndex (Bit False) k = \case + BitVec _ 0 _ -> Nothing + BitVec 0 n v -> let l = V.basicLength v in case modWordSize n of + 0 -> case nth0InWords k v of + Right x -> Just x + Left{} -> Nothing + nMod -> case nth0InWords k (V.slice 0 (l - 1) v) of + Right x -> Just x + Left k' -> case nth0 k' (V.last v .|. hiMask nMod) of + Right x -> Just $ mulWordSize (l - 1) + x + Left{} -> Nothing + BitVec s n v -> let l = V.basicLength v in case modWordSize (s + n) of + 0 -> case nth0 k (V.head v `unsafeShiftR` s .|. hiMask (wordSize - s)) of + Right x -> Just x + Left k' -> case nth0InWords k' (V.slice 1 (l - 1) v) of + Right x -> Just $ wordSize - s + x + Left {} -> Nothing + nMod -> case l of + 1 -> case nth0 k ((V.head v `unsafeShiftR` s) .|. hiMask n) of + Right x -> Just x + Left{} -> Nothing + _ -> case nth0 k ((V.head v `unsafeShiftR` s) .|. hiMask (wordSize - s)) of + Right x -> Just x + Left k' -> case nth0InWords k' (V.slice 1 (l - 2) v) of + Right x -> Just $ wordSize - s + x + Left k'' -> case nth0 k'' (V.last v .|. hiMask nMod) of + Right x -> Just $ mulWordSize (l - 1) - s + x + Left{} -> Nothing + +nth0 :: Int -> Word -> Either Int Int +nth0 k v = if k > c then Left (k - c) else Right (select1 w k - 1) where - loop is !w = case ffs w of - Nothing -> is - Just i -> loop (is . (j + i :)) (clearBit w i) + w = complement v + c = popCount w --- TODO: faster! -selectWord :: Word -> Word -> (Int, Word) -selectWord m x = loop 0 0 0 +nth1 :: Int -> Word -> Either Int Int +nth1 k w = if k > c then Left (k - c) else Right (select1 w k - 1) where - loop !i !ct !y - | i >= wordSize = (ct, y) - | testBit m i = loop (i+1) (ct+1) (if testBit x i then setBit y ct else y) - | otherwise = loop (i+1) ct y + c = popCount w + +nth0InWords :: Int -> U.Vector Word -> Either Int Int +nth0InWords k vec = go 0 k + where + go n l + | n >= U.length vec = Left l + | otherwise = if l > c then go (n + 1) (l - c) else Right (mulWordSize n + select1 w l - 1) + where + w = complement (vec U.! n) + c = popCount w + +nth1InWords :: Int -> U.Vector Word -> Either Int Int +nth1InWords k vec = go 0 k + where + go n l + | n >= U.length vec = Left l + | otherwise = if l > c then go (n + 1) (l - c) else Right (mulWordSize n + select1 w l - 1) + where + w = vec U.! n + c = popCount w + +-- | Return the number of set bits in a vector (population count, popcount). +-- +-- >>> countBits (read "[1,1,0,1,0,1]") +-- 4 +-- +-- One can combine 'countBits' with 'Data.Vector.Unboxed.take' +-- to implement @rank{0,1}@ queries +-- for . +countBits :: U.Vector Bit -> Int +countBits (BitVec _ 0 _) = 0 +countBits (BitVec 0 n v) = case modWordSize n of + 0 -> countBitsInWords v + nMod -> countBitsInWords (V.slice 0 (l - 1) v) + + popCount (V.last v .&. loMask nMod) + where + l = V.basicLength v +countBits (BitVec s n v) = case modWordSize (s + n) of + 0 -> popCount (V.head v `unsafeShiftR` s) + + countBitsInWords (V.slice 1 (l - 1) v) + nMod -> case l of + 1 -> popCount ((V.head v `unsafeShiftR` s) .&. loMask n) + _ -> + popCount (V.head v `unsafeShiftR` s) + + countBitsInWords (V.slice 1 (l - 2) v) + + popCount (V.last v .&. loMask nMod) + where + l = V.basicLength v + +countBitsInWords :: U.Vector Word -> Int +countBitsInWords = U.foldl' (\acc word -> popCount word + acc) 0 + +-- | Return the indices of set bits in a vector. +-- +-- >>> listBits (read "[1,1,0,1,0,1]") +-- [0,1,3,5] +listBits :: U.Vector Bit -> [Int] +listBits (BitVec _ 0 _) = [] +listBits (BitVec 0 n v) = case modWordSize n of + 0 -> listBitsInWords 0 v [] + nMod -> listBitsInWords 0 (V.slice 0 (l - 1) v) $ + map (+ mulWordSize (l - 1)) $ + filter (testBit $ V.last v) [0 .. nMod - 1] + where + l = V.basicLength v +listBits (BitVec s n v) = case modWordSize (s + n) of + 0 -> filter (testBit $ V.head v `unsafeShiftR` s) [0 .. wordSize - s - 1] ++ + listBitsInWords (wordSize - s) (V.slice 1 (l - 1) v) [] + nMod -> case l of + 1 -> filter (testBit $ V.head v `unsafeShiftR` s) [0 .. n - 1] + _ -> + filter (testBit $ V.head v `unsafeShiftR` s) [0 .. wordSize - s - 1] ++ + (listBitsInWords (wordSize - s) (V.slice 1 (l - 2) v) $ + map (+ (mulWordSize (l - 1) - s)) $ + filter (testBit $ V.last v) [0 .. nMod - 1]) + where + l = V.basicLength v + +listBitsInWord :: Int -> Word -> [Int] +listBitsInWord offset word + = map (+ offset) + $ filter (testBit word) + $ [0 .. wordSize - 1] + +listBitsInWords :: Int -> U.Vector Word -> [Int] -> [Int] +listBitsInWords offset = flip $ U.ifoldr + (\i word acc -> listBitsInWord (offset + mulWordSize i) word ++ acc) diff --git a/src/Data/Bit/InternalTS.hs b/src/Data/Bit/InternalTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/InternalTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/Internal.hs" diff --git a/src/Data/Bit/Mutable.hs b/src/Data/Bit/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Mutable.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +#ifndef BITVEC_THREADSAFE +module Data.Bit.Mutable +#else +module Data.Bit.MutableTS +#endif + ( castFromWordsM + , castToWordsM + , cloneToWordsM + + , zipInPlace + + , invertInPlace + , selectBitsInPlace + , excludeBitsInPlace + + , reverseInPlace + ) where + +import Control.Monad +import Control.Monad.Primitive +#ifndef BITVEC_THREADSAFE +import Data.Bit.Internal +#else +import Data.Bit.InternalTS +#endif +import Data.Bit.Utils +import Data.Bits +import qualified Data.Vector.Generic.Mutable as MV +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Unboxed as U (Vector) +import Data.Vector.Unboxed.Mutable as U +import Data.Word +import Prelude as P + hiding (and, or, any, all, reverse) + +-- | Cast a vector of words to a vector of bits. +-- Cf. 'Data.Bit.castFromWords'. +castFromWordsM + :: U.MVector s Word + -> U.MVector s Bit +castFromWordsM ws = BitMVec 0 (nBits (MV.length ws)) ws + +-- | Try to cast a vector of bits to a vector of words. +-- It succeeds if a vector of bits is aligned. +-- Use 'cloneToWordsM' otherwise. +-- Cf. 'Data.Bit.castToWords'. +castToWordsM + :: U.MVector s Bit + -> Maybe (U.MVector s Word) +castToWordsM (BitMVec s n ws) + | aligned s + , aligned n + = Just $ MV.slice (divWordSize s) (nWords n) ws + | otherwise + = Nothing + +-- | Clone a vector of bits to a new unboxed vector of words. +-- If the bits don't completely fill the words, the last word will be zero-padded. +-- Cf. 'Data.Bit.cloneToWords'. +cloneToWordsM + :: PrimMonad m + => U.MVector (PrimState m) Bit + -> m (U.MVector (PrimState m) Word) +cloneToWordsM v@(BitMVec _ n _) = do + ws <- MV.new (nWords n) + let loop !i !j + | i >= n = return () + | otherwise = do + readWord v i >>= MV.write ws j + loop (i + wordSize) (j + 1) + loop 0 0 + return ws +{-# INLINE cloneToWordsM #-} + +-- |Map a function over a bit vector one 'Word' at a time ('wordSize' bits at a time). The function will be passed the bit index (which will always be 'wordSize'-aligned) and the current value of the corresponding word. The returned word will be written back to the vector. If there is a partial word at the end of the vector, it will be zero-padded when passed to the function and truncated when the result is written back to the array. +{-# INLINE mapMInPlaceWithIndex #-} +mapMInPlaceWithIndex :: + PrimMonad m => + (Int -> Word -> m Word) + -> U.MVector (PrimState m) Bit -> m () +mapMInPlaceWithIndex f xs@(BitMVec 0 _ v) = loop 0 0 + where + !n_ = alignDown (MV.length xs) + loop !i !j + | i >= n_ = when (n_ /= MV.length xs) $ do + readWord xs i >>= f i >>= writeWord xs i + + | otherwise = do + MV.read v j >>= f i >>= MV.write v j + loop (i + wordSize) (j + 1) +mapMInPlaceWithIndex f xs = loop 0 + where + !n = MV.length xs + loop !i + | i >= n = return () + | otherwise = do + readWord xs i >>= f i >>= writeWord xs i + loop (i + wordSize) + +{-# INLINE mapInPlaceWithIndex #-} +mapInPlaceWithIndex :: + PrimMonad m => + (Int -> Word -> Word) + -> U.MVector (PrimState m) Bit -> m () +mapInPlaceWithIndex f = mapMInPlaceWithIndex g + where + {-# INLINE g #-} + g i x = return $! f i x + +{-# INLINE mapInPlace #-} +mapInPlace :: PrimMonad m => (Word -> Word) -> U.MVector (PrimState m) Bit -> m () +mapInPlace f = mapMInPlaceWithIndex (\_ x -> return (f x)) + +-- | Zip two vectors with the given function. +-- rewriting contents of the second argument. +-- Cf. 'Data.Bit.zipBits'. +-- +-- >>> import Data.Bits +-- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[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: +-- +-- >>> import Data.Bits +-- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1,1,1,1]") +-- [0,1,0,1,1,1] -- note trailing garbage +zipInPlace + :: PrimMonad m + => (forall a. Bits a => a -> a -> a) + -> U.Vector Bit + -> U.MVector (PrimState m) Bit + -> m () +zipInPlace f ys@(BitVec 0 n2 v) xs = + mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs) + where + -- WARNING: relies on guarantee by mapMInPlaceWithIndex that index will always be aligned! + !n = min (MV.length xs) (V.length ys) + {-# INLINE g #-} + g !i !x = + let !w = masked (n2 - i) (v V.! divWordSize i) + in f w x +zipInPlace f ys xs = + mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs) + where + !n = min (MV.length xs) (V.length ys) + {-# INLINE g #-} + g !i !x = + let !w = indexWord ys i + in f w x +{-# INLINE zipInPlace #-} + +-- | Invert (flip) all bits in-place. +-- +-- Combine with 'Data.Vector.Unboxed.modify' +-- to operate on immutable vectors. +-- +-- >>> Data.Vector.Unboxed.modify invertInPlace (read "[0,1,0,1,0]") +-- [1,0,1,0,1] +invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m () +invertInPlace = mapInPlace complement + +-- | Same as 'Data.Bit.selectBits', but deposit +-- selected bits in-place. Returns a number of selected bits. +-- It is caller's resposibility to trim the result to this number. +selectBitsInPlace + :: PrimMonad m + => U.Vector Bit + -> U.MVector (PrimState m) Bit + -> m Int +selectBitsInPlace is xs = loop 0 0 + where + !n = min (V.length is) (MV.length xs) + loop !i !ct + | i >= n = return ct + | otherwise = do + x <- readWord xs i + let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x + writeWord xs ct x' + loop (i + wordSize) (ct + nSet) + +-- | Same as 'Data.Bit.excludeBits', but deposit +-- excluded bits in-place. Returns a number of excluded bits. +-- It is caller's resposibility to trim the result to this number. +excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int +excludeBitsInPlace is xs = loop 0 0 + where + !n = min (V.length is) (MV.length xs) + loop !i !ct + | i >= n = return ct + | otherwise = do + x <- readWord xs i + let !(nSet, x') = selectWord (masked (n - i) (complement (indexWord is i))) x + writeWord xs ct x' + loop (i + wordSize) (ct + nSet) + +-- | Reverse the order of bits in-place. +-- +-- Combine with 'Data.Vector.Unboxed.modify' +-- to operate on immutable vectors. +-- +-- >>> Data.Vector.Unboxed.modify reverseInPlace (read "[1,1,0,1,0]") +-- [0,1,0,1,1] +reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m () +reverseInPlace xs = loop 0 (MV.length xs) + where + loop !i !j + | i' <= j' = do + x <- readWord xs i + y <- readWord xs j' + + writeWord xs i (reverseWord y) + writeWord xs j' (reverseWord x) + + loop i' j' + | i' < j = do + let w = (j - i) `shiftR` 1 + k = j - w + x <- readWord xs i + y <- readWord xs k + + writeWord xs i (meld w (reversePartialWord w y) x) + writeWord xs k (meld w (reversePartialWord w x) y) + + loop i' j' + | i < j = do + let w = j - i + x <- readWord xs i + writeWord xs i (meld w (reversePartialWord w x) x) + | otherwise = return () + where + !i' = i + wordSize + !j' = j - wordSize diff --git a/src/Data/Bit/MutableTS.hs b/src/Data/Bit/MutableTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/MutableTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/Mutable.hs" diff --git a/src/Data/Bit/Select1.hs b/src/Data/Bit/Select1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Select1.hs @@ -0,0 +1,147 @@ +-- | +-- Module: Data.Bit.Select1 +-- Copyright: (c) 2016 John Ky +-- Licence: BSD3 +-- +-- This is a modification of "HaskellWorks.Data.RankSelect.Base.Internal" +-- from hw-rankselect-base package. + +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +#endif + +module Data.Bit.Select1 + ( select1 + ) where + +#include "MachDeps.h" + +import Data.Bits +#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) +import Data.Bits.Pdep +import Data.Int +#endif +import Data.Word + +infixl 8 .>. +(.>.) :: Bits a => a -> Int -> a +(.>.) = shiftR + +infixl 8 .<. +(.<.) :: Bits a => a -> Int -> a +(.<.) = shiftL + +#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) + +select1Word64Bmi2Base0 :: Word64 -> Word64 -> Word64 +select1Word64Bmi2Base0 w r = fromIntegral (countTrailingZeros (pdep (1 .<. fromIntegral r) w)) +{-# INLINE select1Word64Bmi2Base0 #-} + +select1Word64Bmi2 :: Word64 -> Word64 -> Word64 +select1Word64Bmi2 w r = + let zeros = countTrailingZeros (pdep (1 .<. fromIntegral (r - 1)) w) :: Int + mask = fromIntegral ((fromIntegral (zeros .<. 57) :: Int64) `shiftR` 63) :: Word64 + in (fromIntegral zeros .|. mask) + 1 +{-# INLINE select1Word64Bmi2 #-} + +select1Word32Bmi2 :: Word32 -> Word64 -> Word64 +select1Word32Bmi2 w r = + let zeros = countTrailingZeros (pdep (1 .<. fromIntegral (r - 1)) w) :: Int + mask = fromIntegral ((fromIntegral (zeros .<. 58) :: Int64) `shiftR` 63) :: Word64 + in (fromIntegral zeros .|. mask) + 1 +{-# INLINE select1Word32Bmi2 #-} + +#endif + +select1Word64Broadword :: Word64 -> Word64 -> Word64 +select1Word64Broadword _ 0 = 0 +select1Word64Broadword v rn = + -- Do a normal parallel bit count for a 64-bit integer, + -- but store all intermediate steps. + let a = (v .&. 0x5555555555555555) + ((v .>. 1) .&. 0x5555555555555555) in + let b = (a .&. 0x3333333333333333) + ((a .>. 2) .&. 0x3333333333333333) in + let c = (b .&. 0x0f0f0f0f0f0f0f0f) + ((b .>. 4) .&. 0x0f0f0f0f0f0f0f0f) in + let d = (c .&. 0x00ff00ff00ff00ff) + ((c .>. 8) .&. 0x00ff00ff00ff00ff) in + let e = (d .&. 0x0000ffff0000ffff) + ((d .>. 16) .&. 0x0000ffff0000ffff) in + let f = (e .&. 0x00000000ffffffff) + ((e .>. 32) .&. 0x00000000ffffffff) in + -- Now do branchless select! + let r0 = f + 1 - fromIntegral rn in + let s0 = 64 :: Word64 in + let t0 = (d .>. 32) + (d .>. 48) in + let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in + let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in + let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in + let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in + let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in + let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in + let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in + let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in + let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in + let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in + let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in + let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in + let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in + let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in + let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in + let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in + fromIntegral s6 +{-# INLINE select1Word64Broadword #-} + +select1Word32Broadword :: Word32 -> Word64 -> Word64 +select1Word32Broadword _ 0 = 0 +select1Word32Broadword v rn = + -- Do a normal parallel bit count for a 64-bit integer, + -- but store all intermediate steps. + let a = (v .&. 0x55555555) + ((v .>. 1) .&. 0x55555555) in + let b = (a .&. 0x33333333) + ((a .>. 2) .&. 0x33333333) in + let c = (b .&. 0x0f0f0f0f) + ((b .>. 4) .&. 0x0f0f0f0f) in + let d = (c .&. 0x00ff00ff) + ((c .>. 8) .&. 0x00ff00ff) in + let e = (d .&. 0x000000ff) + ((d .>. 16) .&. 0x000000ff) in + -- Now do branchless select! + let r0 = e + 1 - fromIntegral rn in + let s0 = 64 :: Word32 in + let t0 = (d .>. 32) + (d .>. 48) in + let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in + let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in + let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in + let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in + let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in + let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in + let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in + let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in + let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in + let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in + let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in + let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in + let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in + let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in + let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in + let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in + fromIntegral s6 +{-# INLINE select1Word32Broadword #-} + +select1Word64 :: Word64 -> Word64 -> Word64 +#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) +select1Word64 = select1Word64Bmi2 +#else +select1Word64 = select1Word64Broadword +#endif +{-# INLINE select1Word64 #-} + +select1Word32 :: Word32 -> Word64 -> Word64 +#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) +select1Word32 = select1Word32Bmi2 +#else +select1Word32 = select1Word32Broadword +#endif +{-# INLINE select1Word32 #-} + +select1 :: Word -> Int -> Int +#if WORD_SIZE_IN_BITS == 64 +select1 w i = fromIntegral $ select1Word64 (fromIntegral w) (fromIntegral i) +#else +select1 w i = fromIntegral $ select1Word32 (fromIntegral w) (fromIntegral i) +#endif +{-# INLINE select1 #-} diff --git a/src/Data/Bit/ThreadSafe.hs b/src/Data/Bit/ThreadSafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/ThreadSafe.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit.hs" diff --git a/src/Data/Bit/Utils.hs b/src/Data/Bit/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Utils.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.Bit.Utils where + +import Data.Bits +import Data.List + +-- various internal utility functions and constants + +lg2 :: Int -> Int +lg2 n = i + where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1) + + +-- |The number of bits in a 'Word'. A handy constant to have around when defining 'Word'-based bulk operations on bit vectors. +wordSize :: Int +wordSize = finiteBitSize (0 :: Word) + +lgWordSize, wordSizeMask, wordSizeMaskC :: Int +lgWordSize = case wordSize of + 32 -> 5 + 64 -> 6 + _ -> lg2 wordSize + +wordSizeMask = wordSize - 1 +wordSizeMaskC = complement wordSizeMask + +divWordSize :: Bits a => a -> a +divWordSize x = unsafeShiftR x lgWordSize +{-# INLINE divWordSize #-} + +modWordSize :: Int -> Int +modWordSize x = x .&. (wordSize - 1) +{-# INLINE modWordSize #-} + +mulWordSize :: Bits a => a -> a +mulWordSize x = unsafeShiftL x lgWordSize + +-- number of words needed to store n bits +nWords :: Int -> Int +nWords ns = divWordSize (ns + wordSize - 1) + +-- number of bits storable in n words +nBits :: Bits a => a -> a +nBits ns = mulWordSize ns + +aligned :: Int -> Bool +aligned x = (x .&. wordSizeMask == 0) + +notAligned :: Int -> Bool +notAligned x = x /= alignDown x + +-- round a number of bits up to the nearest multiple of word size +alignUp :: Int -> Int +alignUp x + | x == x' = x' + | otherwise = x' + wordSize + where x' = alignDown x + +-- round a number of bits down to the nearest multiple of word size +alignDown :: Int -> Int +alignDown x = x .&. wordSizeMaskC + +-- 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 + +masked :: Int -> Word -> Word +masked b x = x .&. mask b + +isMasked :: Int -> Word -> Bool +isMasked b x = (masked b x == x) + +-- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi' +meld :: Int -> Word -> Word -> Word +meld b lo hi = (lo .&. m) .|. (hi .&. complement m) + where m = mask b + +-- given a bit offset 'k' and 2 words, extract a word by taking the 'k' highest bits of the first word and the 'wordSize - k' lowest bits of the second word. +{-# INLINE extractWord #-} +extractWord :: Int -> Word -> Word -> Word +extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k)) + +-- given a bit offset 'k', 2 words 'lo' and 'hi' and a word 'x', overlay 'x' onto 'lo' and 'hi' at the position such that (k `elem` [0..wordSize] ==> uncurry (extractWord k) (spliceWord k lo hi x) == x) and (k `elem` [0..wordSize] ==> spliceWord k lo hi (extractWord k lo hi) == (lo,hi)) +{-# INLINE spliceWord #-} +spliceWord :: Int -> Word -> Word -> Word -> (Word, Word) +spliceWord k lo hi x = + ( meld k lo (x `shiftL` k) + , meld k (x `shiftR` (wordSize - k)) hi + ) + +-- this could be given a more general type, but it would be wrong; it works for any fixed word size, but only for unsigned types +reverseWord :: Word -> Word +reverseWord xx = foldr swap xx masks + where + nextMask (d, x) = (d', x `xor` shift x d') + where !d' = d `shiftR` 1 + + !(_:masks) = + takeWhile ((0 /=) . snd) + (iterate nextMask (finiteBitSize xx, maxBound)) + + swap (n, m) x = ((x .&. m) `shiftL` n) .|. ((x .&. complement m) `shiftR` n) + + -- TODO: is an unrolled version like "loop lgWordSize" faster than the generic implementation above? If so, can that be fixed? + -- loop 0 x = x + -- loop 1 x = loop 0 (((x .&. 0x5555555555555555) `shiftL` 1) .|. ((x .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1)) + -- loop 2 x = loop 1 (((x .&. 0x3333333333333333) `shiftL` 2) .|. ((x .&. 0xCCCCCCCCCCCCCCCC) `shiftR` 2)) + -- loop 3 x = loop 2 (((x .&. 0x0F0F0F0F0F0F0F0F) `shiftL` 4) .|. ((x .&. 0xF0F0F0F0F0F0F0F0) `shiftR` 4)) + -- loop 4 x = loop 3 (((x .&. 0x00FF00FF00FF00FF) `shiftL` 8) .|. ((x .&. 0xFF00FF00FF00FF00) `shiftR` 8)) + -- loop 5 x = loop 4 (((x .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x .&. 0xFFFF0000FFFF0000) `shiftR` 16)) + -- loop 6 x = loop 5 (((x .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x .&. 0xFFFFFFFF00000000) `shiftR` 32)) + -- loop _ _ = error "reverseWord only implemented for up to 64 bit words!" + +reversePartialWord :: Int -> Word -> Word +reversePartialWord n w + | n >= wordSize = reverseWord w + | otherwise = reverseWord w `shiftR` (wordSize - n) + +diff :: Bits a => a -> a -> a +diff w1 w2 = w1 .&. complement w2 + +ffs :: Word -> Maybe Int +ffs 0 = Nothing +ffs x = Just $! (popCount (x `xor` complement (-x)) - 1) + +-- TODO: this can probably be faster +-- the interface is very specialized here; 'j' is an offset to add to every bit index and the result is a difference list +bitsInWord :: Int -> Word -> [Int] -> [Int] +bitsInWord j = loop id + where + loop is !w = case ffs w of + Nothing -> is + Just i -> loop (is . (j + i :)) (clearBit w i) + +-- TODO: faster! +selectWord :: Word -> Word -> (Int, Word) +selectWord m x = loop 0 0 0 + where + loop !i !ct !y + | i >= wordSize = (ct, y) + | testBit m i = loop (i+1) (ct+1) (if testBit x i then setBit y ct else y) + | otherwise = loop (i+1) ct y + +loMask :: Int -> Word +loMask n = 1 `shiftL` n - 1 + +hiMask :: Int -> Word +hiMask n = complement (1 `shiftL` n - 1) diff --git a/src/Data/Vector/Unboxed/Bit.hs b/src/Data/Vector/Unboxed/Bit.hs deleted file mode 100644 --- a/src/Data/Vector/Unboxed/Bit.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE BangPatterns #-} - -module Data.Vector.Unboxed.Bit - ( wordSize - , wordLength - , fromWords - , toWords - , indexWord - - , pad - , padWith - - , zipWords - - , union - , unions - - , intersection - , intersections - , difference - , symDiff - - , invert - - , select - , selectBits - - , exclude - , excludeBits - - , countBits - , listBits - - , and - , or - - , any - , anyBits - , all - , allBits - - , reverse - - , first - , findIndex - ) where - -import Control.Monad -import Control.Monad.ST -import Data.Bit.Internal -import Data.Bits -import qualified Data.List as L -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as MV -import Data.Vector.Unboxed as U - hiding (and, or, any, all, reverse, findIndex) -import qualified Data.Vector.Unboxed as Unsafe -import qualified Data.Vector.Unboxed.Mutable.Bit as B -import Data.Vector.Unboxed.Bit.Internal -import Data.Word -import Prelude as P - hiding (and, or, any, all, reverse) - -wordLength :: U.Vector Bit -> Int -wordLength = nWords . U.length - --- |Given a number of bits and a vector of words, concatenate them to a vector of bits (interpreting the words in little-endian order, as described at 'indexWord'). If there are not enough words for the number of bits requested, the vector will be zero-padded. -fromWords :: Int -> U.Vector Word -> U.Vector Bit -fromWords n ws - | n <= m = BitVec 0 n (V.take (nWords n) ws) - | otherwise = pad n (BitVec 0 m ws) - where - m = nBits (V.length ws) - --- |Given a vector of bits, extract an unboxed vector of words. If the bits don't completely fill the words, the last word will be zero-padded. -toWords :: U.Vector Bit -> U.Vector Word -toWords v@(BitVec s n ws) - | aligned s && (aligned n || isMasked (modWordSize n) (ws V.! divWordSize n)) - = V.slice (divWordSize s) (nWords n) ws - | otherwise = runST (Unsafe.unsafeThaw v >>= cloneWords >>= Unsafe.unsafeFreeze) - --- | @zipWords f xs ys@ = @fromWords (min (length xs) (length ys)) (zipWith f (toWords xs) (toWords ys))@ -{-# INLINE zipWords #-} -zipWords :: (Word -> Word -> Word) -> U.Vector Bit -> U.Vector Bit -> U.Vector Bit -zipWords op xs ys - | V.length xs > V.length ys = - zipWords (flip op) ys xs - | otherwise = runST $ do - -- TODO: eliminate this extra traversal - xs1 <- V.thaw xs - B.zipInPlace op xs1 ys - Unsafe.unsafeFreeze xs1 - --- |(internal) N-ary 'zipWords' with specified output length. Makes all kinds of assumptions; mainly only valid for union and intersection. -{-# INLINE zipMany #-} -zipMany :: Word -> (Word -> Word -> Word) -> Int -> [U.Vector Bit] -> U.Vector Bit -zipMany z op n xss = runST $ do - ys <- MV.new n - B.mapInPlace (const z) ys - P.mapM_ (B.zipInPlace op ys) xss - Unsafe.unsafeFreeze ys - -union :: Vector Bit -> Vector Bit -> Vector Bit -union = zipWords (.|.) - -intersection :: Vector Bit -> Vector Bit -> Vector Bit -intersection = zipWords (.&.) - -difference :: Vector Bit -> Vector Bit -> Vector Bit -difference = zipWords diff - -symDiff :: Vector Bit -> Vector Bit -> Vector Bit -symDiff = zipWords xor - -unions :: Int -> [U.Vector Bit] -> U.Vector Bit -unions = zipMany 0 (.|.) - -intersections :: Int -> [U.Vector Bit] -> U.Vector Bit -intersections = zipMany (complement 0) (.&.) - --- |Flip every bit in the given vector -invert :: U.Vector Bit -> U.Vector Bit -invert xs = runST $ do - ys <- MV.new (V.length xs) - let f i _ = complement (indexWord xs i) - B.mapInPlaceWithIndex f ys - Unsafe.unsafeFreeze ys - --- | Given a vector of bits and a vector of things, extract those things for which the corresponding bit is set. --- --- For example, @select (V.map (fromBool . p) x) x == V.filter p x@. -select :: (V.Vector v1 Bit, V.Vector v2 t) => v1 Bit -> v2 t -> [t] -select is xs = L.unfoldr next 0 - where - n = min (V.length is) (V.length xs) - - next j - | j >= n = Nothing - | unBit (is V.! j) = Just (xs V.! j, j + 1) - | otherwise = next (j + 1) - --- | Given a vector of bits and a vector of things, extract those things for which the corresponding bit is unset. --- --- For example, @exclude (V.map (fromBool . p) x) x == V.filter (not . p) x@. -exclude :: (V.Vector v1 Bit, V.Vector v2 t) => v1 Bit -> v2 t -> [t] -exclude is xs = L.unfoldr next 0 - where - n = min (V.length is) (V.length xs) - - next j - | j >= n = Nothing - | unBit (is V.! j) = next (j + 1) - | otherwise = Just (xs V.! j, j + 1) - -selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit -selectBits is xs = runST $ do - xs1 <- U.thaw xs - n <- B.selectBitsInPlace is xs1 - Unsafe.unsafeFreeze (MV.take n xs1) - -excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit -excludeBits is xs = runST $ do - xs1 <- U.thaw xs - n <- B.excludeBitsInPlace is xs1 - Unsafe.unsafeFreeze (MV.take n xs1) - --- |return the number of ones in a bit vector -countBits :: U.Vector Bit -> Int -countBits v = loop 0 0 - where - !n = alignUp (V.length v) - loop !s !i - | i >= n = s - | otherwise = loop (s + popCount (indexWord v i)) (i + wordSize) - -listBits :: U.Vector Bit -> [Int] -listBits v = loop id 0 - where - !n = V.length v - loop bs !i - | i >= n = bs [] - | otherwise = - loop (bs . bitsInWord i (indexWord v i)) (i + wordSize) - --- | 'True' if all bits in the vector are set -and :: U.Vector Bit -> Bool -and v = loop 0 - where - !n = V.length v - loop !i - | i >= n = True - | otherwise = (indexWord v i == mask (n-i)) - && loop (i + wordSize) - --- | 'True' if any bit in the vector is set -or :: U.Vector Bit -> Bool -or v = loop 0 - where - !n = V.length v - loop !i - | i >= n = False - | otherwise = (indexWord v i /= 0) - || loop (i + wordSize) - -all :: (Bit -> Bool) -> Vector Bit -> Bool -all p = case (p (Bit False), p (Bit True)) of - (False, False) -> U.null - (False, True) -> allBits (Bit True) - (True, False) -> allBits (Bit False) - (True, True) -> flip seq True - -any :: (Bit -> Bool) -> Vector Bit -> Bool -any p = case (p (Bit False), p (Bit True)) of - (False, False) -> flip seq False - (False, True) -> anyBits (Bit True) - (True, False) -> anyBits (Bit False) - (True, True) -> not . U.null - -allBits, anyBits :: Bit -> U.Vector Bit -> Bool -allBits (Bit False) = not . or -allBits (Bit True) = and - -anyBits (Bit False) = not . and -anyBits (Bit True) = or - -reverse :: U.Vector Bit -> U.Vector Bit -reverse xs = runST $ do - let !n = V.length xs - f i _ = reversePartialWord (n - i) (indexWord xs (max 0 (n - i - wordSize))) - ys <- MV.new n - B.mapInPlaceWithIndex f ys - Unsafe.unsafeFreeze ys - --- |Return the address of the first bit in the vector with the specified value, if any -first :: Bit -> U.Vector Bit -> Maybe Int -first b xs = mfilter (< n) (loop 0) - where - !n = V.length xs - !ff | unBit b = ffs - | otherwise = ffs . complement - - loop !i - | i >= n = Nothing - | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize) - -findIndex :: (Bit -> Bool) -> Vector Bit -> Maybe Int -findIndex p xs = case (p (Bit False), p (Bit True)) of - (False, False) -> Nothing - (False, True) -> first (Bit True) xs - (True, False) -> first (Bit False) xs - (True, True) -> if V.null xs then Nothing else Just 0 diff --git a/src/Data/Vector/Unboxed/Bit/Internal.hs b/src/Data/Vector/Unboxed/Bit/Internal.hs deleted file mode 100644 --- a/src/Data/Vector/Unboxed/Bit/Internal.hs +++ /dev/null @@ -1,299 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Vector.Unboxed.Bit.Internal - ( Bit - , U.Vector(BitVec) - , U.MVector(BitMVec) - - , padWith - , pad - - , indexWord - , readWord - , writeWord - , cloneWords - ) where - -import Control.Monad -import Control.Monad.ST -import Control.Monad.Primitive -import Data.Bit.Internal -import Data.Bits -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as MV -import qualified Data.Vector.Unboxed as U - --- Ints are offset and length in bits -data instance U.MVector s Bit = BitMVec !Int !Int !(U.MVector s Word) -data instance U.Vector Bit = BitVec !Int !Int !(U.Vector Word) - --- TODO: allow partial words to be read/written at beginning? - --- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the result is zero-padded. -indexWord :: U.Vector Bit -> Int -> Word -indexWord (BitVec 0 n v) i - | aligned i = masked b lo - | j + 1 == nWords n = masked b (extractWord k lo 0 ) - | otherwise = masked b (extractWord k lo hi) - where - b = n - i - j = divWordSize i - k = modWordSize i - lo = v V.! j - hi = v V.! (j+1) -indexWord (BitVec s n v) i = indexWord (BitVec 0 (n + s) v) (i + s) - --- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the result is zero-padded. -readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word -readWord (BitMVec 0 n v) i - | aligned i = liftM (masked b) lo - | j + 1 == nWords n = liftM (masked b) (liftM2 (extractWord k) lo (return 0)) - | otherwise = liftM (masked b) (liftM2 (extractWord k) lo hi) - where - b = n - i - j = divWordSize i - k = modWordSize i - lo = MV.read v j - hi = MV.read v (j+1) -readWord (BitMVec s n v) i = readWord (BitMVec 0 (n + s) v) (i + s) - --- | write a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.). If the offset is such that the word extends past the end of the vector, the word is truncated and as many low-order bits as possible are written. -writeWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> Word -> m () -writeWord (BitMVec 0 n v) i x - | aligned i = - if b < wordSize - then do - y <- MV.read v j - MV.write v j (meld b x y) - else MV.write v j x - | j + 1 == nWords n = do - lo <- MV.read v j - let x' = if b < wordSize - then meld b x (extractWord k lo 0) - else x - (lo', _hi) = spliceWord k lo 0 x' - MV.write v j lo' - | otherwise = do - lo <- MV.read v j - hi <- if j + 1 == nWords n - then return 0 - else MV.read v (j+1) - let x' = if b < wordSize - then meld b x (extractWord k lo hi) - else x - (lo', hi') = spliceWord k lo hi x' - MV.write v j lo' - MV.write v (j+1) hi' - where - b = n - i - j = divWordSize i - k = modWordSize i -writeWord (BitMVec s n v) i x = writeWord (BitMVec 0 (n + s) v) (i + s) x - --- clone words from a bit-array into a new word array, without attempting any shortcuts (such as recognizing that they are already aligned, etc.) -{-# INLINE cloneWords #-} -cloneWords :: PrimMonad m => U.MVector (PrimState m) Bit -> m (U.MVector (PrimState m) Word) -cloneWords v@(BitMVec _ n _) = do - ws <- MV.new (nWords n) - let loop !i !j - | i >= n = return () - | otherwise = do - readWord v i >>= MV.write ws j - loop (i + wordSize) (j + 1) - loop 0 0 - return ws - -instance U.Unbox Bit - -loMask :: Int -> Word -loMask n = 1 `shiftL` n - 1 - -hiMask :: Int -> Word -hiMask n = complement (1 `shiftL` n - 1) - -instance MV.MVector U.MVector Bit where - {-# INLINE basicInitialize #-} - basicInitialize (BitMVec _ 0 _) = pure () - basicInitialize (BitMVec 0 n v) = case modWordSize n of - 0 -> MV.basicInitialize v - nMod -> do - let vLen = MV.basicLength v - MV.basicInitialize (MV.slice 0 (vLen - 1) v) - MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1) - basicInitialize (BitMVec s n v) = case modWordSize (s + n) of - 0 -> do - let vLen = MV.basicLength v - MV.basicInitialize (MV.slice 1 (vLen - 1) v) - MV.modify v (\val -> val .&. loMask s) 0 - nMod -> do - let vLen = MV.basicLength v - lohiMask = loMask s .|. hiMask nMod - if vLen == 1 - then MV.modify v (\val -> val .&. lohiMask) 0 - else do - MV.basicInitialize (MV.slice 1 (vLen - 2) v) - MV.modify v (\val -> val .&. loMask s) 0 - MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1) - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n = liftM (BitMVec 0 n) (MV.basicUnsafeNew (nWords n)) - - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x)) - - {-# INLINE basicOverlaps #-} - basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2 - - {-# INLINE basicLength #-} - basicLength (BitMVec _ n _) = n - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (BitMVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i)) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (BitMVec s _ v) !i' !x = do - let i = s + i' - let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k - w <- MV.basicUnsafeRead v j - when (fromBool (w .&. kk /= 0) /= x) $ - MV.basicUnsafeWrite v j (w `xor` kk) - - {-# INLINE basicClear #-} - basicClear _ = pure () - - {-# INLINE basicSet #-} - basicSet (BitMVec _ 0 _) _ = pure () - basicSet (BitMVec 0 n v) (extendToWord -> x) = case modWordSize n of - 0 -> MV.basicSet v x - nMod -> do - let vLen = MV.basicLength v - MV.basicSet (MV.slice 0 (vLen - 1) v) x - MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1) - basicSet (BitMVec s n v) (extendToWord -> x) = case modWordSize (s + n) of - 0 -> do - let vLen = MV.basicLength v - MV.basicSet (MV.slice 1 (vLen - 1) v) x - MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0 - nMod -> do - let vLen = MV.basicLength v - lohiMask = loMask s .|. hiMask nMod - if vLen == 1 - then MV.modify v (\val -> val .&. lohiMask .|. x .&. complement lohiMask) 0 - else do - MV.basicSet (MV.slice 1 (vLen - 2) v) x - MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0 - MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1) - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy _ (BitMVec _ 0 _) = pure () - basicUnsafeCopy (BitMVec 0 _ dst) (BitMVec 0 n src) = case modWordSize n of - 0 -> MV.basicUnsafeCopy dst src - nMod -> do - let vLen = MV.basicLength src - MV.basicUnsafeCopy (MV.slice 0 (vLen - 1) dst) (MV.slice 0 (vLen - 1) src) - valSrc <- MV.basicUnsafeRead src (vLen - 1) - MV.modify dst (\val -> val .&. hiMask nMod .|. valSrc .&. loMask nMod) (vLen - 1) - basicUnsafeCopy (BitMVec dstShift _ dst) (BitMVec s n src) - | dstShift == s = case modWordSize (s + n) of - 0 -> do - let vLen = MV.basicLength src - MV.basicUnsafeCopy (MV.slice 1 (vLen - 1) dst) (MV.slice 1 (vLen - 1) src) - valSrc <- MV.basicUnsafeRead src 0 - MV.modify dst (\val -> val .&. loMask s .|. valSrc .&. hiMask s) 0 - nMod -> do - let vLen = MV.basicLength src - lohiMask = loMask s .|. hiMask nMod - if vLen == 1 - then do - valSrc <- MV.basicUnsafeRead src 0 - MV.modify dst (\val -> val .&. lohiMask .|. valSrc .&. complement lohiMask) 0 - else do - MV.basicUnsafeCopy (MV.slice 1 (vLen - 2) dst) (MV.slice 1 (vLen - 2) src) - valSrcFirst <- MV.basicUnsafeRead src 0 - MV.modify dst (\val -> val .&. loMask s .|. valSrcFirst .&. hiMask s) 0 - valSrcLast <- MV.basicUnsafeRead src (vLen - 1) - MV.modify dst (\val -> val .&. hiMask nMod .|. valSrcLast .&. loMask nMod) (vLen - 1) - - basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0 - where - n = alignUp len - - do_copy i - | i < n = do - x <- readWord src i - writeWord dst i x - do_copy (i+wordSize) - | otherwise = return () - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _) - | MV.basicOverlaps dst src = do - -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src - -- TODO write tests on copy and move inside array - srcCopy <- BitMVec srcShift srcLen <$> MV.basicUnsafeNew (nWords (srcShift + srcLen)) - MV.basicUnsafeCopy srcCopy src - MV.basicUnsafeCopy dst srcCopy - | otherwise = MV.basicUnsafeCopy dst src - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice offset n (BitMVec s _ v) = - BitMVec relStartBit n (MV.basicUnsafeSlice startWord (endWord - startWord) v) - where - absStartBit = s + offset - relStartBit = modWordSize absStartBit - absEndBit = absStartBit + n - endWord = nWords absEndBit - startWord = divWordSize absStartBit - - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (BitMVec s n v) by = - BitMVec s (n + by) <$> if delta == 0 then pure v else MV.basicUnsafeGrow v delta - where - delta = nWords (s + n + by) - nWords (s + n) - - -instance V.Vector U.Vector Bit where - basicUnsafeFreeze (BitMVec s n v) = liftM (BitVec s n) (V.basicUnsafeFreeze v) - basicUnsafeThaw (BitVec s n v) = liftM (BitMVec s n) (V.basicUnsafeThaw v) - basicLength (BitVec _ n _) = n - - basicUnsafeIndexM (BitVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i)) - - basicUnsafeCopy dst src = do - src1 <- V.basicUnsafeThaw src - MV.basicUnsafeCopy dst src1 - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice offset n (BitVec s _ v) = - BitVec relStartBit n (V.basicUnsafeSlice startWord (endWord - startWord) v) - where - absStartBit = s + offset - relStartBit = modWordSize absStartBit - absEndBit = absStartBit + n - endWord = nWords absEndBit - startWord = divWordSize absStartBit - -padWith :: Bit -> Int -> U.Vector Bit -> U.Vector Bit -padWith b n' bitvec@(BitVec _ n _) - | n' <= n = bitvec - | otherwise = runST $ do - mv@(BitMVec mvStart _ ws) <- MV.replicate n' b - when (mvStart /= 0) (fail "assertion failed: offset /= 0 after MV.new") - - V.copy (MV.basicUnsafeSlice 0 n mv) bitvec - - when (notAligned n) $ do - let i = divWordSize n - j = modWordSize n - x <- MV.read ws i - MV.write ws i (meld j x (extendToWord b)) - - V.unsafeFreeze mv - -pad :: Int -> U.Vector Bit -> U.Vector Bit -pad = padWith (fromBool False) diff --git a/src/Data/Vector/Unboxed/Mutable/Bit.hs b/src/Data/Vector/Unboxed/Mutable/Bit.hs deleted file mode 100644 --- a/src/Data/Vector/Unboxed/Mutable/Bit.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE BangPatterns #-} - -module Data.Vector.Unboxed.Mutable.Bit - ( wordSize - , wordLength - , cloneFromWords - , cloneToWords - , readWord - , writeWord - - , mapMInPlaceWithIndex - , mapInPlaceWithIndex - , mapMInPlace - , mapInPlace - - , zipInPlace - - , unionInPlace - , intersectionInPlace - , differenceInPlace - , symDiffInPlace - , invertInPlace - , selectBitsInPlace - , excludeBitsInPlace - - , countBits - , listBits - - , and - , or - - , any - , anyBits - , all - , allBits - - , reverseInPlace - ) where - -import Control.Monad -import Control.Monad.Primitive -import Data.Bit.Internal -import Data.Bits -import qualified Data.Vector.Generic.Mutable as MV -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Unboxed as U (Vector) -import Data.Vector.Unboxed.Mutable as U -import Data.Vector.Unboxed.Bit.Internal -import Data.Word -import Prelude as P - hiding (and, or, any, all, reverse) - - --- TODO: this interface needs more work. - --- |Get the length of the vector that would be created by 'cloneToWords' -wordLength :: U.MVector s Bit -> Int -wordLength = nWords . MV.length - --- |Clone a specified number of bits from a vector of words into a new vector of bits (interpreting the words in little-endian order, as described at 'indexWord'). If there are not enough words for the number of bits requested, the vector will be zero-padded. -cloneFromWords :: PrimMonad m => Int -> U.MVector (PrimState m) Word -> m (U.MVector (PrimState m) Bit) -cloneFromWords n ws = do - let wordsNeeded = nWords n - wordsGiven = MV.length ws - fillNeeded = wordsNeeded - wordsGiven - - v <- MV.new wordsNeeded - - if fillNeeded > 0 - then do - MV.copy (MV.slice 0 wordsGiven v) ws - MV.set (MV.slice wordsGiven fillNeeded v) 0 - else do - MV.copy v (MV.slice 0 wordsNeeded ws) - - return (BitMVec 0 n v) - --- |clone a vector of bits to a new unboxed vector of words. If the bits don't completely fill the words, the last word will be zero-padded. -cloneToWords :: PrimMonad m => U.MVector (PrimState m) Bit -> m (U.MVector (PrimState m) Word) -cloneToWords v@(BitMVec s n ws) - | aligned s = do - ws1 <- MV.clone (MV.slice (divWordSize s) (nWords n) ws) - when (not (aligned n)) $ do - readWord v (alignDown n) >>= MV.write ws1 (divWordSize n) - return ws1 - | otherwise = cloneWords v - --- |Map a function over a bit vector one 'Word' at a time ('wordSize' bits at a time). The function will be passed the bit index (which will always be 'wordSize'-aligned) and the current value of the corresponding word. The returned word will be written back to the vector. If there is a partial word at the end of the vector, it will be zero-padded when passed to the function and truncated when the result is written back to the array. -{-# INLINE mapMInPlaceWithIndex #-} -mapMInPlaceWithIndex :: - PrimMonad m => - (Int -> Word -> m Word) - -> U.MVector (PrimState m) Bit -> m () -mapMInPlaceWithIndex f xs@(BitMVec 0 _ v) = loop 0 0 - where - !n_ = alignDown (MV.length xs) - loop !i !j - | i >= n_ = when (n_ /= MV.length xs) $ do - readWord xs i >>= f i >>= writeWord xs i - - | otherwise = do - MV.read v j >>= f i >>= MV.write v j - loop (i + wordSize) (j + 1) -mapMInPlaceWithIndex f xs = loop 0 - where - !n = MV.length xs - loop !i - | i >= n = return () - | otherwise = do - readWord xs i >>= f i >>= writeWord xs i - loop (i + wordSize) - -{-# INLINE mapInPlaceWithIndex #-} -mapInPlaceWithIndex :: - PrimMonad m => - (Int -> Word -> Word) - -> U.MVector (PrimState m) Bit -> m () -mapInPlaceWithIndex f = mapMInPlaceWithIndex g - where - {-# INLINE g #-} - g i x = return $! f i x - --- |Same as 'mapMInPlaceWithIndex' but without the index. -{-# INLINE mapMInPlace #-} -mapMInPlace :: PrimMonad m => (Word -> m Word) -> U.MVector (PrimState m) Bit -> m () -mapMInPlace f = mapMInPlaceWithIndex (const f) - -{-# INLINE mapInPlace #-} -mapInPlace :: PrimMonad m => (Word -> Word) -> U.MVector (PrimState m) Bit -> m () -mapInPlace f = mapMInPlaceWithIndex (\_ x -> return (f x)) - -{-# INLINE zipInPlace #-} -zipInPlace :: PrimMonad m => (Word -> Word -> Word) -> U.MVector (PrimState m) Bit -> U.Vector Bit -> m () -zipInPlace f xs ys@(BitVec 0 n2 v) = - mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs) - where - -- WARNING: relies on guarantee by mapMInPlaceWithIndex that index will always be aligned! - !n = min (MV.length xs) (V.length ys) - {-# INLINE g #-} - g !i !x = - let !w = masked (n2 - i) (v V.! divWordSize i) - in f x w -zipInPlace f xs ys = - mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs) - where - !n = min (MV.length xs) (V.length ys) - {-# INLINE g #-} - g !i !x = - let !w = indexWord ys i - in f x w - -unionInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m () -unionInPlace = zipInPlace (.|.) - -intersectionInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m () -intersectionInPlace = zipInPlace (.&.) - -differenceInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m () -differenceInPlace = zipInPlace diff - -symDiffInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m () -symDiffInPlace = zipInPlace xor - --- |Flip every bit in the given vector -invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m () -invertInPlace = mapInPlace complement - -selectBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int -selectBitsInPlace is xs = loop 0 0 - where - !n = min (V.length is) (MV.length xs) - loop !i !ct - | i >= n = return ct - | otherwise = do - x <- readWord xs i - let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x - writeWord xs ct x' - loop (i + wordSize) (ct + nSet) - -excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int -excludeBitsInPlace is xs = loop 0 0 - where - !n = min (V.length is) (MV.length xs) - loop !i !ct - | i >= n = return ct - | otherwise = do - x <- readWord xs i - let !(nSet, x') = selectWord (masked (n - i) (complement (indexWord is i))) x - writeWord xs ct x' - loop (i + wordSize) (ct + nSet) - --- |return the number of ones in a bit vector -countBits :: PrimMonad m => U.MVector (PrimState m) Bit -> m Int -countBits v = loop 0 0 - where - !n = alignUp (MV.length v) - loop !s !i - | i >= n = return s - | otherwise = do - x <- readWord v i - loop (s + popCount x) (i + wordSize) - -listBits :: PrimMonad m => U.MVector (PrimState m) Bit -> m [Int] -listBits v = loop id 0 - where - !n = MV.length v - loop bs !i - | i >= n = return $! bs [] - | otherwise = do - w <- readWord v i - loop (bs . bitsInWord i w) (i + wordSize) - --- | Returns 'True' if all bits in the vector are set -and :: PrimMonad m => U.MVector (PrimState m) Bit -> m Bool -and v = loop 0 - where - !n = MV.length v - loop !i - | i >= n = return True - | otherwise = do - y <- readWord v i - if y == mask (n - i) - then loop (i + wordSize) - else return False - --- | Returns 'True' if any bit in the vector is set -or :: PrimMonad m => U.MVector (PrimState m) Bit -> m Bool -or v = loop 0 - where - !n = MV.length v - loop !i - | i >= n = return False - | otherwise = do - y <- readWord v i - if y /= 0 - then return True - else loop (i + wordSize) - -all :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool -all p = case (p (Bit False), p (Bit True)) of - (False, False) -> return . MV.null - (False, True) -> allBits (Bit True) - (True, False) -> allBits (Bit False) - (True, True) -> flip seq (return True) - -any :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool -any p = case (p (Bit False), p (Bit True)) of - (False, False) -> flip seq (return False) - (False, True) -> anyBits (Bit True) - (True, False) -> anyBits (Bit False) - (True, True) -> return . not . MV.null - -allBits, anyBits :: PrimMonad m => Bit -> U.MVector (PrimState m) Bit -> m Bool -allBits (Bit False) = liftM not . or -allBits (Bit True) = and - -anyBits (Bit False) = liftM not . and -anyBits (Bit True) = or - -reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m () -reverseInPlace xs = loop 0 (MV.length xs) - where - loop !i !j - | i' <= j' = do - x <- readWord xs i - y <- readWord xs j' - - writeWord xs i (reverseWord y) - writeWord xs j' (reverseWord x) - - loop i' j' - | i' < j = do - let w = (j - i) `shiftR` 1 - k = j - w - x <- readWord xs i - y <- readWord xs k - - writeWord xs i (meld w (reversePartialWord w y) x) - writeWord xs k (meld w (reversePartialWord w x) y) - - loop i' j' - | i < j = do - let w = j - i - x <- readWord xs i - writeWord xs i (meld w (reversePartialWord w x) x) - | otherwise = return () - where - !i' = i + wordSize - !j' = j - wordSize diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,24 +1,26 @@ -#!/usr/bin/env runhaskell module Main where import Data.Bit import Data.Proxy -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck.Classes +import Test.Tasty +import Test.Tasty.QuickCheck + import Tests.MVector (mvectorTests) +import qualified Tests.MVectorTS as TS (mvectorTests) import Tests.SetOps (setOpTests) import Tests.Vector (vectorTests) main :: IO () -main = defaultMain +main = defaultMain $ testGroup "All" [ showReadTests , mvectorTests + , TS.mvectorTests , setOpTests , vectorTests ] -showReadTests :: Test +showReadTests :: TestTree showReadTests = testGroup "Show/Read" $ map (uncurry testProperty) diff --git a/test/Support.hs b/test/Support.hs --- a/test/Support.hs +++ b/test/Support.hs @@ -8,13 +8,13 @@ import Control.Monad.ST import Data.Bit +import qualified Data.Bit.ThreadSafe as TS import Data.Bits import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic.New as N import qualified Data.Vector.Unboxed as U -import Data.Vector.Unboxed.Bit (wordSize) -import Test.QuickCheck +import Test.Tasty.QuickCheck instance Arbitrary Bit where arbitrary = Bit <$> arbitrary @@ -26,6 +26,16 @@ instance Function Bit where function f = functionMap unBit Bit f +instance Arbitrary TS.Bit where + arbitrary = TS.Bit <$> arbitrary + shrink = fmap TS.Bit . shrink . TS.unBit + +instance CoArbitrary TS.Bit where + coarbitrary = coarbitrary . TS.unBit + +instance Function TS.Bit where + function f = functionMap TS.unBit TS.Bit f + instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where arbitrary = V.new <$> arbitrary @@ -58,6 +68,9 @@ sliceList :: Int -> Int -> [a] -> [a] sliceList s n = take n . drop s +wordSize :: Int +wordSize = finiteBitSize (0 :: Word) + packBitsToWord :: [Bit] -> (Word, [Bit]) packBitsToWord = loop 0 0 where @@ -78,29 +91,30 @@ writeWordL xs n w = pre ++ writeWordL post 0 w where (pre, post) = splitAt n xs -prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Bool +prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_length xs (NonNegative n) w = - length (writeWordL xs n w) == length xs + length (writeWordL xs n w) === length xs -prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Bool +prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_prefix xs (NonNegative n) w = - take n (writeWordL xs n w) == take n xs + take n (writeWordL xs n w) === take n xs -prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Bool +prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_suffix xs (NonNegative n) w = - drop (n + wordSize) (writeWordL xs n w) == drop (n + wordSize) xs + drop (n + wordSize) (writeWordL xs n w) === drop (n + wordSize) xs -prop_writeWordL_readWordL :: [Bit] -> Int -> Bool +prop_writeWordL_readWordL :: [Bit] -> Int -> Property prop_writeWordL_readWordL xs n = - writeWordL xs n (readWordL xs n) == xs + writeWordL xs n (readWordL xs n) === xs -- the opposite is more work to state, but these tests together with the simplicity of the definitions makes me reasonably confident in these as a reference implementation. -withNonEmptyMVec :: Eq t => - (U.Vector Bit -> t) +withNonEmptyMVec + :: (Eq t, Show t) + => (U.Vector Bit -> t) -> (forall s. U.MVector s Bit -> ST s t) -> Property withNonEmptyMVec f g = forAll arbitrary $ \xs -> - let xs' = V.new xs - in not (U.null xs') ==> f xs' == runST (N.run xs >>= g) + let xs' = V.new xs in + not (U.null xs') ==> f xs' === runST (N.run xs >>= g) diff --git a/test/Tests/MVector.hs b/test/Tests/MVector.hs --- a/test/Tests/MVector.hs +++ b/test/Tests/MVector.hs @@ -1,45 +1,41 @@ +{-# LANGUAGE CPP #-} + +#ifndef BITVEC_THREADSAFE module Tests.MVector where +#else +module Tests.MVectorTS where +#endif import Support -import Control.Monad import Control.Monad.ST +#ifndef BITVEC_THREADSAFE import Data.Bit +#else +import Data.Bit.ThreadSafe +#endif +import Data.Bits import Data.Proxy -import Data.STRef import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M (basicInitialize, basicSet) import qualified Data.Vector.Generic.New as N -import qualified Data.Vector.Unboxed.Bit as B hiding (reverse) import qualified Data.Vector.Unboxed as B -import qualified Data.Vector.Unboxed.Mutable.Bit as U import qualified Data.Vector.Unboxed.Mutable as M -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (assertEqual) -import Test.QuickCheck import Test.QuickCheck.Classes +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -mvectorTests :: Test +mvectorTests :: TestTree mvectorTests = testGroup "Data.Vector.Unboxed.Mutable.Bit" [ testGroup "Data.Vector.Unboxed.Mutable functions" [ testProperty "slice" prop_slice_def , testProperty "grow" prop_grow_def ] - , testProperty "wordLength" prop_wordLength_def , testGroup "Read/write Words" - [ testProperty "readWord" prop_readWord_def - , testProperty "writeWord" prop_writeWord_def - , testProperty "cloneFromWords" (prop_cloneFromWords_def 10000) + [ testProperty "cloneFromWords" prop_cloneFromWords_def , testProperty "cloneToWords" prop_cloneToWords_def ] - , testGroup "mapMInPlaceWithIndex" - [ testProperty "maps left to right" prop_mapMInPlaceWithIndex_leftToRight - , testProperty "wordSize-aligned" prop_mapMInPlaceWithIndex_aligned - ] - , testProperty "countBits" prop_countBits_def - , testProperty "listBits" prop_listBits_def , testProperty "reverseInPlace" prop_reverseInPlace_def , testGroup "MVector laws" $ map (uncurry testProperty) $ lawsProperties $ muvectorLaws (Proxy :: Proxy Bit) , testCase "basicInitialize 1" case_write_init_read1 @@ -58,8 +54,16 @@ , testCase "basicUnsafeCopy3" case_write_copy_read3 , testCase "basicUnsafeCopy4" case_write_copy_read4 , testCase "basicUnsafeCopy5" case_write_copy_read5 + + , testProperty "flipBit" prop_flipBit ] +prop_flipBit :: B.Vector Bit -> NonNegative Int -> Property +prop_flipBit xs (NonNegative k) = k < B.length xs ==> ys === ys' + where + ys = B.modify (\v -> M.modify v complement k) xs + ys' = B.modify (\v -> flipBit v k) xs + case_write_init_read1 :: IO () case_write_init_read1 = assertEqual "should be equal" (Bit True) $ runST $ do arr <- M.new 2 @@ -196,70 +200,18 @@ fv1 <- B.freeze v1 return (fv0 == B.take n fv1) -prop_readWord_def :: Int -> Property -prop_readWord_def n = withNonEmptyMVec - (\xs -> readWordL (B.toList xs) (n `mod` V.length xs)) - (\xs -> U.readWord xs (n `mod` M.length xs)) - -prop_writeWord_def :: Int -> Word -> Property -prop_writeWord_def n w = withNonEmptyMVec - (\xs -> B.fromList - $ writeWordL (B.toList xs) (n `mod` V.length xs) w) - (\xs -> do U.writeWord xs (n `mod` M.length xs) w - V.unsafeFreeze xs) - -prop_wordLength_def :: N.New B.Vector Bit -> Bool -prop_wordLength_def xs - = runST (fmap U.wordLength (N.run xs)) - == runST (fmap M.length (N.run xs >>= U.cloneToWords)) - -prop_cloneFromWords_def :: Int -> Int -> N.New B.Vector Word -> Bool -prop_cloneFromWords_def maxN n' ws - = runST (N.run ws >>= U.cloneFromWords n >>= V.unsafeFreeze) - == B.fromWords n (V.new ws) - where n = n' `mod` maxN +prop_cloneFromWords_def :: N.New B.Vector Word -> Bool +prop_cloneFromWords_def ws + = runST (N.run ws >>= pure . castFromWordsM >>= V.unsafeFreeze) + == castFromWords (V.new ws) prop_cloneToWords_def :: N.New B.Vector Bit -> Bool prop_cloneToWords_def xs - = runST (N.run xs >>= U.cloneToWords >>= V.unsafeFreeze) - == B.toWords (V.new xs) - -prop_mapMInPlaceWithIndex_leftToRight :: N.New B.Vector Bit -> Bool -prop_mapMInPlaceWithIndex_leftToRight xs - = runST $ do - x <- newSTRef (-1) - xs1 <- N.run xs - let f i _ = do - j <- readSTRef x - writeSTRef x i - return (if i > j then maxBound else 0) - U.mapMInPlaceWithIndex f xs1 - xs2 <- V.unsafeFreeze xs1 - return (all unBit (B.toList xs2)) - -prop_mapMInPlaceWithIndex_aligned :: N.New B.Vector Bit -> Bool -prop_mapMInPlaceWithIndex_aligned xs = runST $ do - ok <- newSTRef True - xs1 <- N.run xs - let aligned i = i `mod` U.wordSize == 0 - f i x = do - when (not (aligned i)) (writeSTRef ok False) - return x - U.mapMInPlaceWithIndex f xs1 - readSTRef ok - -prop_countBits_def :: N.New B.Vector Bit -> Bool -prop_countBits_def xs - = runST (N.run xs >>= U.countBits) - == B.countBits (V.new xs) - -prop_listBits_def :: N.New B.Vector Bit -> Bool -prop_listBits_def xs - = runST (N.run xs >>= U.listBits) - == B.listBits (V.new xs) + = runST (N.run xs >>= cloneToWordsM >>= V.unsafeFreeze) + == cloneToWords (V.new xs) prop_reverseInPlace_def :: N.New B.Vector Bit -> Bool prop_reverseInPlace_def xs - = runST (N.run xs >>= \v -> U.reverseInPlace v >> V.unsafeFreeze v) + = runST (N.run xs >>= \v -> reverseInPlace v >> V.unsafeFreeze v) == B.reverse (V.new xs) diff --git a/test/Tests/MVectorTS.hs b/test/Tests/MVectorTS.hs new file mode 100644 --- /dev/null +++ b/test/Tests/MVectorTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Tests/MVector.hs" diff --git a/test/Tests/SetOps.hs b/test/Tests/SetOps.hs --- a/test/Tests/SetOps.hs +++ b/test/Tests/SetOps.hs @@ -4,20 +4,20 @@ import Data.Bit import Data.Bits +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Bit as U -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Tasty +import Test.Tasty.QuickCheck hiding ((.&.)) -setOpTests :: Test +setOpTests :: TestTree setOpTests = testGroup "Set operations" [ testProperty "union" prop_union_def , testProperty "intersection" prop_intersection_def , testProperty "difference" prop_difference_def , testProperty "symDiff" prop_symDiff_def - , testProperty "unions" (prop_unions_def 1000) - , testProperty "intersections" (prop_unions_def 1000) + , testProperty "unions" prop_unions_def + , testProperty "intersections" prop_unions_def , testProperty "invert" prop_invert_def @@ -30,66 +30,100 @@ , testProperty "countBits" prop_countBits_def ] -prop_union_def :: U.Vector Bit -> U.Vector Bit -> Bool +union :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +union = zipBits (.|.) + +prop_union_def :: U.Vector Bit -> U.Vector Bit -> Property prop_union_def xs ys - = U.toList (U.union xs ys) - == zipWith (.|.) (U.toList xs) (U.toList ys) + = U.toList (union xs ys) + === zipWith (.|.) (U.toList xs) (U.toList ys) -prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Bool +intersection :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +intersection = zipBits (.&.) + +prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Property prop_intersection_def xs ys - = U.toList (U.intersection xs ys) - == zipWith (.&.) (U.toList xs) (U.toList ys) + = U.toList (intersection xs ys) + === zipWith (.&.) (U.toList xs) (U.toList ys) -prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Bool +difference :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +difference = zipBits (\a b -> a .&. complement b) + +prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Property prop_difference_def xs ys - = U.toList (U.difference xs ys) - == zipWith diff (U.toList xs) (U.toList ys) + = U.toList (difference xs ys) + === zipWith diff (U.toList xs) (U.toList ys) where diff x y = x .&. complement y -prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Bool +symDiff :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +symDiff = zipBits xor + +prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Property prop_symDiff_def xs ys - = U.toList (U.symDiff xs ys) - == zipWith xor (U.toList xs) (U.toList ys) + = U.toList (symDiff xs ys) + === zipWith xor (U.toList xs) (U.toList ys) -prop_unions_def :: Int -> Int -> [U.Vector Bit] -> Bool -prop_unions_def maxN n' xss - = U.unions n xss - == U.take n (foldr U.union (U.replicate n (Bit False)) (map (U.pad n) xss)) - where n = n' `mod` maxN +unions :: NonEmpty (U.Vector Bit) -> U.Vector Bit +unions (x :| xs) = U.slice 0 l $ U.modify (go xs) x + where + l = minimum $ fmap U.length (x :| xs) + go [] _ = pure () + go (y : ys) acc = do + zipInPlace (.|.) y acc + go ys acc -prop_intersections_def :: Int -> Int -> [U.Vector Bit] -> Bool -prop_intersections_def maxN n' xss - = U.intersections n xss - == U.take n (foldr U.intersection (U.replicate n (Bit True)) (map (U.padWith (Bit True) n) xss)) - where n = n' `mod` maxN +prop_unions_def :: U.Vector Bit -> [U.Vector Bit] -> Property +prop_unions_def xs xss + = unions (xs :| xss) + === foldr union xs xss +intersections :: NonEmpty (U.Vector Bit) -> U.Vector Bit +intersections (x :| xs) = U.slice 0 l $ U.modify (go xs) x + where + l = minimum $ fmap U.length (x :| xs) + go [] _ = pure () + go (y : ys) acc = do + zipInPlace (.&.) y acc + go ys acc + +prop_intersections_def :: U.Vector Bit -> [U.Vector Bit] -> Property +prop_intersections_def xs xss + = intersections (xs :| xss) + === foldr intersection xs xss + prop_invert_def :: U.Vector Bit -> Bool prop_invert_def xs - = U.toList (U.invert xs) + = U.toList (U.modify invertInPlace xs) == map complement (U.toList xs) +select :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a] +select mask ws = U.toList (U.map snd (U.filter (unBit . fst) (U.zip mask ws))) + prop_select_def :: U.Vector Bit -> U.Vector Word -> Bool prop_select_def xs ys - = U.select xs ys + = select xs ys == [ x | (Bit True, x) <- zip (U.toList xs) (U.toList ys)] +exclude :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a] +exclude mask ws = U.toList (U.map snd (U.filter (not . unBit . fst) (U.zip mask ws))) + prop_exclude_def :: U.Vector Bit -> U.Vector Word -> Bool prop_exclude_def xs ys - = U.exclude xs ys + = exclude xs ys == [ x | (Bit False, x) <- zip (U.toList xs) (U.toList ys)] prop_selectBits_def :: U.Vector Bit -> U.Vector Bit -> Bool prop_selectBits_def xs ys - = U.selectBits xs ys - == U.fromList (U.select xs ys) + = selectBits xs ys + == U.fromList (select xs ys) prop_excludeBits_def :: U.Vector Bit -> U.Vector Bit -> Bool prop_excludeBits_def xs ys - = U.excludeBits xs ys - == U.fromList (U.exclude xs ys) + = excludeBits xs ys + == U.fromList (exclude xs ys) prop_countBits_def :: U.Vector Bit -> Bool prop_countBits_def xs - = U.countBits xs - == U.length (U.selectBits xs xs) + = countBits xs + == U.length (selectBits xs xs) diff --git a/test/Tests/Vector.hs b/test/Tests/Vector.hs --- a/test/Tests/Vector.hs +++ b/test/Tests/Vector.hs @@ -2,31 +2,23 @@ import Support +import Prelude hiding (and, or) import Data.Bit -import Data.Bits -import Data.List +import Data.List hiding (and, or) import qualified Data.Vector.Unboxed as U hiding (reverse, and, or, any, all, findIndex) -import qualified Data.Vector.Unboxed.Bit as U -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit ((@?=)) -import Test.QuickCheck -import Test.QuickCheck.Function +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -vectorTests :: Test +vectorTests :: TestTree vectorTests = testGroup "Data.Vector.Unboxed.Bit" - [ testCase "wordSize correct" (U.wordSize @?= finiteBitSize (0 :: Word)) - , testGroup "Data.Vector.Unboxed functions" + [ testGroup "Data.Vector.Unboxed functions" [ testProperty "toList . fromList == id" prop_toList_fromList , testProperty "fromList . toList == id" prop_fromList_toList , testProperty "slice" prop_slice_def ] - , testProperty "wordLength" prop_wordLength_def - , testProperty "fromWords" (prop_fromWords_def 10000) - , testProperty "toWords" prop_toWords_def - , testProperty "indexWord" prop_indexWord_def - , testProperty "zipWords" prop_zipWords_def + , testProperty "cloneFromWords" prop_cloneFromWords_def + , testProperty "cloneToWords" prop_cloneToWords_def , testProperty "reverse" prop_reverse_def , testProperty "countBits" prop_countBits_def , testProperty "listBits" prop_listBits_def @@ -35,13 +27,17 @@ , testProperty "or" prop_or_def ] , testGroup "Search operations" - [ testProperty "any" prop_any_def - , testProperty "all" prop_all_def - , testProperty "anyBits" prop_anyBits_def - , testProperty "allBits" prop_allBits_def - , testProperty "first" prop_first_def - , testProperty "findIndex" prop_findIndex_def + [ testProperty "first" prop_first_def ] + , testGroup "nthBitIndex" + [ testCase "special case 1" case_nthBit_1 + + , testProperty "matches bitIndex True" prop_nthBit_1 + , testProperty "matches bitIndex False" prop_nthBit_2 + , testProperty "matches sequence of bitIndex True" prop_nthBit_3 + , testProperty "matches sequence of bitIndex False" prop_nthBit_4 + , testProperty "matches countBits" prop_nthBit_5 + ] ] prop_toList_fromList :: [Bit] -> Bool @@ -59,94 +55,90 @@ where (s', n') = trimSlice s n (U.length xs) -prop_wordLength_def :: U.Vector Bit -> Bool -prop_wordLength_def xs - = U.wordLength xs - == U.length (U.toWords xs) - -prop_fromWords_def :: Int -> Int -> U.Vector Word -> Bool -prop_fromWords_def maxN n ws - = U.toList (U.fromWords n' ws) - == take n' (concatMap wordToBitList (U.toList ws) ++ repeat (Bit False)) - where n' = n `mod` maxN +prop_cloneFromWords_def :: U.Vector Word -> Property +prop_cloneFromWords_def ws + = U.toList (castFromWords ws) + === concatMap wordToBitList (U.toList ws) -prop_toWords_def :: U.Vector Bit -> Bool -prop_toWords_def xs - = U.toList (U.toWords xs) +prop_cloneToWords_def :: U.Vector Bit -> Bool +prop_cloneToWords_def xs + = U.toList (cloneToWords xs) == loop (U.toList xs) where loop [] = [] loop bs = case packBitsToWord bs of (w, bs') -> w : loop bs' -prop_indexWord_def :: Int -> U.Vector Bit -> Property -prop_indexWord_def n xs - = not (U.null xs) - ==> readWordL (U.toList xs) n' - == U.indexWord xs n' - where - n' = n `mod` U.length xs - -prop_zipWords_def :: Fun (Word, Word) Word -> U.Vector Bit -> U.Vector Bit -> Bool -prop_zipWords_def f' xs ys - = U.zipWords f xs ys - == U.fromWords (min (U.length xs) (U.length ys)) (U.zipWith f (U.toWords xs) (U.toWords ys)) - where f = curry (apply f') - prop_reverse_def :: U.Vector Bit -> Bool prop_reverse_def xs = reverse (U.toList xs) - == U.toList (U.reverse xs) + == U.toList (U.modify reverseInPlace xs) prop_countBits_def :: U.Vector Bit -> Bool prop_countBits_def xs - = U.countBits xs + = countBits xs == length (filter unBit (U.toList xs)) -prop_listBits_def :: U.Vector Bit -> Bool +prop_listBits_def :: U.Vector Bit -> Property prop_listBits_def xs - = U.listBits xs - == [ i | (i,x) <- zip [0..] (U.toList xs), unBit x] + = listBits xs + === [ i | (i,x) <- zip [0..] (U.toList xs), unBit x] +and :: U.Vector Bit -> Bool +and xs = case bitIndex (Bit False) xs of + Nothing -> True + Just{} -> False + prop_and_def :: U.Vector Bit -> Bool prop_and_def xs - = U.and xs + = and xs == all unBit (U.toList xs) +or :: U.Vector Bit -> Bool +or xs = case bitIndex (Bit True) xs of + Nothing -> False + Just{} -> True + prop_or_def :: U.Vector Bit -> Bool prop_or_def xs - = U.or xs + = or xs == any unBit (U.toList xs) -prop_any_def :: Fun Bit Bool -> U.Vector Bit -> Bool -prop_any_def f' xs - = U.any f xs - == any f (U.toList xs) - where f = apply f' +prop_first_def :: Bit -> U.Vector Bit -> Bool +prop_first_def b xs + = bitIndex b xs + == findIndex (b ==) (U.toList xs) -prop_all_def :: Fun Bit Bool -> U.Vector Bit -> Bool -prop_all_def f' xs - = U.all f xs - == all f (U.toList xs) - where f = apply f' +prop_nthBit_1 :: U.Vector Bit -> Property +prop_nthBit_1 xs = bitIndex (Bit True) xs === nthBitIndex (Bit True) 1 xs -prop_anyBits_def :: Bit -> U.Vector Bit -> Bool -prop_anyBits_def b xs - = U.anyBits b xs - == U.any (b ==) xs +prop_nthBit_2 :: U.Vector Bit -> Property +prop_nthBit_2 xs = bitIndex (Bit False) xs === nthBitIndex (Bit False) 1 xs -prop_allBits_def :: Bit -> U.Vector Bit -> Bool -prop_allBits_def b xs - = U.allBits b xs - == U.all (b ==) xs +prop_nthBit_3 :: Positive Int -> U.Vector Bit -> Property +prop_nthBit_3 (Positive n) xs = case nthBitIndex (Bit True) (n + 1) xs of + Nothing -> property True + Just i -> case bitIndex (Bit True) xs of + Nothing -> property False + Just j -> case nthBitIndex (Bit True) n (U.drop (j + 1) xs) of + Nothing -> property False + Just k -> i === j + k + 1 -prop_first_def :: Bit -> U.Vector Bit -> Bool -prop_first_def b xs - = U.first b xs - == findIndex (b ==) (U.toList xs) +prop_nthBit_4 :: Positive Int -> U.Vector Bit -> Property +prop_nthBit_4 (Positive n) xs = case nthBitIndex (Bit False) (n + 1) xs of + Nothing -> property True + Just i -> case bitIndex (Bit False) xs of + Nothing -> property False + Just j -> case nthBitIndex (Bit False) n (U.drop (j + 1) xs) of + Nothing -> property False + Just k -> i === j + k + 1 -prop_findIndex_def :: Fun Bit Bool -> U.Vector Bit -> Bool -prop_findIndex_def f' xs - = U.findIndex f xs - == findIndex f (U.toList xs) - where f = apply f' +prop_nthBit_5 :: Positive Int -> U.Vector Bit -> Property +prop_nthBit_5 (Positive n) xs = n <= countBits xs ==> + case nthBitIndex (Bit True) n xs of + Nothing -> property False + Just i -> countBits (U.take (i + 1) xs) === n + +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)