diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,5 @@ +I hereby release this code to the public domain. + +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. + +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). diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/bitvec.cabal b/bitvec.cabal new file mode 100644 --- /dev/null +++ b/bitvec.cabal @@ -0,0 +1,56 @@ +name: bitvec +version: 0.1 +stability: experimental + +cabal-version: >= 1.9.2 +build-type: Simple + +author: James Cook +maintainer: James Cook +license: PublicDomain +license-file: LICENSE +homepage: https://github.com/mokus0/bitvec + +category: Data, Bit Vectors +synopsis: Unboxed vectors of bits / dense IntSets +description: Unboxed vectors of bits / dense IntSets + +tested-with: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, + GHC == 7.2.1, GHC == 7.2.2, GHC == 7.4.1 + +source-repository head + type: git + location: git://github.com/mokus0/bitvec.git + +Test-Suite bitvec-tests + type: exitcode-stdio-1.0 + hs-source-dirs: src test + ghc-options: -threaded -fwarn-unused-imports -fwarn-unused-binds + main-is: Main.hs + other-modules: Support + Tests.Bit + Tests.MVector + Tests.SetOps + Tests.Vector + build-depends: base >= 3, + HUnit, + primitive, + vector >= 0.8, + test-framework, + test-framework-hunit, + test-framework-quickcheck2, + QuickCheck + +Library + hs-source-dirs: src + ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-type-defaults + exposed-modules: Data.Bit + Data.Vector.Unboxed.Bit + Data.Vector.Unboxed.Mutable.Bit + other-modules: Data.Bit.Internal + Data.Vector.Unboxed.Bit.Internal + build-depends: base >= 3 && < 5, + primitive, + vector >= 0.8 + if impl(ghc == 7.2.1) + ghc-options: -trust vector diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#else +#define safe +#endif +module Data.Bit + ( Bit + , fromBool + , toBool + ) where + +import safe Data.Bit.Internal +import safe Data.Bits +import Data.Vector.Unboxed.Bit.Internal ({- instance Unbox Bit -}) + +instance Show Bit where + showsPrec _ (Bit False) = showString "0" + showsPrec _ (Bit True ) = showString "1" +instance Read Bit where + readsPrec _ ('0':rest) = [(0, rest)] + readsPrec _ ('1':rest) = [(1, rest)] + readsPrec _ _ = [] + + +liftBool2 :: (Bool -> Bool -> Bool) -> (Bit -> Bit -> Bit) +liftBool2 op x y = fromBool (toBool x `op` toBool y) +liftInt2 :: (Int -> Int -> Int) -> (Bit -> Bit -> Bit) +liftInt2 op x y = fromIntegral (fromIntegral x `op` fromIntegral y) + +-- | The 'Num' instance is currently based on integers mod 2, so (+) and (-) are +-- XOR, (*) is AND, and all the unary operations are identities. Saturating +-- operations would also be a sensible alternative. +instance Num Bit where + fromInteger = fromBool . odd + (+) = liftInt2 (+) + (-) = liftInt2 (-) + (*) = liftInt2 (*) + abs = id + signum = id + +instance Real Bit where + toRational (Bit False) = 0 + toRational (Bit True ) = 1 + +instance Integral Bit where + quotRem _ 0 = error "divide by zero" + quotRem x 1 = (x, 0) + + divMod = quotRem + toInteger (Bit False) = 0 + toInteger (Bit True ) = 1 + +instance Bits Bit where + (.&.) = liftBool2 (&&) + (.|.) = liftBool2 (||) + xor = liftBool2 (/=) + + complement (Bit x) = Bit (not x) + + shift b 0 = b + shift b _ = 0 + + rotate = const + + bit 0 = 1 + bit _ = 0 + + setBit _ 0 = 1 + setBit b _ = b + + clearBit _ 0 = 0 + clearBit b _ = b + + complementBit b 0 = complement b + complementBit b _ = b + + testBit b 0 = toBool b + testBit _ _ = False + + bitSize _ = 1 + + isSigned _ = False + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 + + popCount = fromEnum + +#endif diff --git a/src/Data/Bit/Internal.hs b/src/Data/Bit/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Internal.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#else +#define safe +#endif +module Data.Bit.Internal where + +import safe Data.Bits +import safe Data.List +import safe Data.Typeable +import safe Data.Word + +#if !MIN_VERSION_base(4,3,0) +import safe Control.Monad + +mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a +mfilter p xs = do x <- xs; guard (p x); return x + +#endif + + +newtype Bit = Bit Bool + deriving (Bounded, Eq, Ord, Typeable) + +fromBool b = Bit b +toBool (Bit b) = b + +instance Enum Bit where + toEnum = fromBool . toEnum + fromEnum = fromEnum . toBool + +-- 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 'Bit's in a 'Word'. A handy constant to have around when defining 'Word'-based bulk operations on bit vectors. +wordSize :: Int +wordSize = bitSize (0 :: Word) + +lgWordSize, wordSizeMask, wordSizeMaskC :: Int +lgWordSize = lg2 wordSize +wordSizeMask = wordSize - 1 +wordSizeMaskC = complement wordSizeMask + +divWordSize x = shiftR x lgWordSize +modWordSize x = x .&. (wordSize - 1) + +mulWordSize x = shiftL x lgWordSize + +-- number of words needed to store n bits +nWords nBits = divWordSize (nBits + wordSize - 1) + +-- number of bits storable in n words +nBits nWords = mulWordSize nWords + +aligned x = (x .&. wordSizeMask == 0) +notAligned x = x /= alignDown x + +-- round a number of bits up to the nearest multiple of word size +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 x = x .&. wordSizeMaskC + +readBit :: Int -> Word -> Bit +readBit i w = fromBool (testBit w i) + +extendToWord :: Bit -> Word +extendToWord (Bit False) = 0 +extendToWord (Bit True) = complement 0 + +-- create a mask consisting of the lower n bits +mask :: Int -> Word +mask b = m + where + m | b >= bitSize m = complement 0 + | b < 0 = 0 + | otherwise = bit b - 1 + +masked b x = x .&. mask b +isMasked b x = (masked b x == x) + +-- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi' +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 x = foldr swap x masks + where + nextMask (d, x) = (d', x `xor` shift x d') + where !d' = d `shiftR` 1 + + !(_:masks) = + takeWhile ((0 /=) . snd) + (iterate nextMask (bitSize x, 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 n w + | n >= wordSize = reverseWord w + | otherwise = reverseWord w `shiftR` (wordSize - n) + +diff :: Word -> Word -> Word +diff w1 w2 = w1 .&. complement w2 + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 704 + +popCount :: Bits a => a -> Int +popCount = loop 0 + where + loop !n 0 = n + loop !n x = loop (n+1) (x .&. (x - 1)) + +#endif + +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 diff --git a/src/Data/Vector/Unboxed/Bit.hs b/src/Data/Vector/Unboxed/Bit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Unboxed/Bit.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#else +#define safe +#endif +module Data.Vector.Unboxed.Bit + ( module Data.Bit + , module U + + , 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 safe Control.Monad +import Control.Monad.ST +import safe Data.Bit +import safe Data.Bit.Internal +import safe Data.Bits +import safe qualified Data.List as L +import safe qualified Data.Vector.Generic.Safe as V +import safe qualified Data.Vector.Generic.Mutable.Safe as MV +import safe Data.Vector.Unboxed.Safe as U + hiding (and, or, any, all, reverse, findIndex) +import qualified Data.Vector.Unboxed as Unsafe +import safe qualified Data.Vector.Unboxed.Mutable.Bit as B +import Data.Vector.Unboxed.Bit.Internal +import safe Data.Word +import safe 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 + xs <- V.thaw xs + B.zipInPlace op xs ys + Unsafe.unsafeFreeze xs + +-- |(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 = zipWords (.|.) +intersection = zipWords (.&.) +difference = zipWords diff +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 + | toBool (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 + | toBool (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 + xs <- U.thaw xs + n <- B.selectBitsInPlace is xs + Unsafe.unsafeFreeze (MV.take n xs) + +excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit +excludeBits is xs = runST $ do + xs <- U.thaw xs + n <- B.excludeBitsInPlace is xs + Unsafe.unsafeFreeze (MV.take n xs) + +-- |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 p = case (p 0, p 1) of + (False, False) -> U.null + (False, True) -> allBits 1 + (True, False) -> allBits 0 + (True, True) -> flip seq True + +any p = case (p 0, p 1) of + (False, False) -> flip seq False + (False, True) -> anyBits 1 + (True, False) -> anyBits 0 + (True, True) -> not . U.null + +allBits, anyBits :: Bit -> U.Vector Bit -> Bool +allBits 0 = not . or +allBits 1 = and + +anyBits 0 = not . and +anyBits 1 = 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 | toBool b = ffs + | otherwise = ffs . complement + + loop !i + | i >= n = Nothing + | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize) + +findIndex p xs = case (p 0, p 1) of + (False, False) -> Nothing + (False, True) -> first 1 xs + (True, False) -> first 0 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 new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Unboxed/Bit/Internal.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns #-} +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 +import Data.Word + +-- 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 + +instance MV.MVector U.MVector Bit where + basicUnsafeNew n = liftM (BitMVec 0 n) (MV.basicUnsafeNew (nWords n)) + basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x)) + + basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2 + + basicLength (BitMVec _ n _) = n + basicUnsafeRead (BitMVec 0 _ v) i = liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i)) + basicUnsafeRead (BitMVec s n v) i = MV.basicUnsafeRead (BitMVec 0 (n + s) v) (i + s) + basicUnsafeWrite (BitMVec 0 _ v) i x = do + let j = divWordSize i; k = modWordSize i + w <- MV.basicUnsafeRead v j + MV.basicUnsafeWrite v j $ if toBool x + then setBit w k + else clearBit w k + + basicUnsafeWrite (BitMVec s n v) i x = + MV.basicUnsafeWrite (BitMVec 0 (n + s) v) (i + s) x + basicSet (BitMVec _ _ v) x = MV.basicSet v (extendToWord x) + + {-# INLINE basicUnsafeCopy #-} + 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 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 + +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 0 _ v) i = liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i)) + basicUnsafeIndexM (BitVec s n v) i = V.basicUnsafeIndexM (BitVec 0 (n + s) v) (i + s) + + basicUnsafeCopy dst src = do + src <- V.basicUnsafeThaw src + MV.basicUnsafeCopy dst src + + {-# 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 s n v) + | 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 new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Unboxed/Mutable/Bit.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#else +#define safe +#endif +module Data.Vector.Unboxed.Mutable.Bit + ( module Data.Bit + , module U + + , 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 safe Control.Monad +import Control.Monad.Primitive +import safe Data.Bit +import safe Data.Bit.Internal +import safe Data.Bits +import qualified Data.Vector.Generic.Mutable as MV +import safe qualified Data.Vector.Generic.Safe as V +import safe qualified Data.Vector.Unboxed.Safe as U (Vector) +import safe Data.Vector.Unboxed.Mutable.Safe as U +import Data.Vector.Unboxed.Bit.Internal +import safe Data.Word +import safe 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 + ws <- MV.clone (MV.slice (divWordSize s) (nWords n) ws) + when (not (aligned n)) $ do + readWord v (alignDown n) >>= MV.write ws (divWordSize n) + return ws + | 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 n 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 0, p 1) of + (False, False) -> return . MV.null + (False, True) -> allBits 1 + (True, False) -> allBits 0 + (True, True) -> flip seq (return True) + +any :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool +any p = case (p 0, p 1) of + (False, False) -> flip seq (return False) + (False, True) -> anyBits 1 + (True, False) -> anyBits 0 + (True, True) -> return . not . MV.null + +allBits, anyBits :: PrimMonad m => Bit -> U.MVector (PrimState m) Bit -> m Bool +allBits 0 = liftM not . or +allBits 1 = and + +anyBits 0 = liftM not . and +anyBits 1 = 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 new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,16 @@ +#!/usr/bin/env runhaskell +module Main where + +import Test.Framework (defaultMain) + +import Tests.Bit (bitTests) +import Tests.SetOps (setOpTests) +import Tests.MVector (mvectorTests) +import Tests.Vector (vectorTests) + +main = defaultMain + [ bitTests + , mvectorTests + , setOpTests + , vectorTests + ] diff --git a/test/Support.hs b/test/Support.hs new file mode 100644 --- /dev/null +++ b/test/Support.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +module Support where + +import Control.Applicative +import Control.Monad.ST +import Data.Bit +import Data.Bits +import Data.Word +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.QuickCheck.Function + +instance Arbitrary Bit where + arbitrary = fromBool <$> arbitrary + shrink = fmap fromBool . shrink . toBool + +instance CoArbitrary Bit where + coarbitrary = coarbitrary . toBool + +instance Function Bit where + function f = functionMap toBool fromBool f + +instance Function Word where + function f = functionMap (fromIntegral :: Word -> Int) fromIntegral f + +instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where + arbitrary = V.new <$> arbitrary + +instance (Show (v a), V.Vector v a) => Show (N.New v a) where + showsPrec p = showsPrec p . V.new + +newFromList :: forall a v. V.Vector v a => [a] -> N.New v a +newFromList xs = N.create (V.thaw (V.fromList xs :: v a)) + +-- this instance is designed to make sure that the arbitrary vectors we work with are not all nicely aligned; we need to deal with cases where the vector is a weird slice of some other vector. +instance (V.Vector v a, Arbitrary a) => Arbitrary (N.New v a) where + arbitrary = frequency + [ (10, newFromList <$> arbitrary) + , (1, N.drop <$> arbitrary <*> arbitrary) + , (1, N.take <$> arbitrary <*> arbitrary) + , (1, slice <$> arbitrary <*> arbitrary <*> arbitrary) + ] + where slice s n = N.apply $ \v -> + let (s', n') = trimSlice s n (M.length v) + in M.slice s' n' v + +trimSlice s n l = (s', n') + where + s' | l == 0 = 0 + | otherwise = s `mod` l + n' | s' == 0 = 0 + | otherwise = n `mod` (l - s') + +sliceList s n = take n . drop s + +packBitsToWord :: [Bit] -> (Word, [Bit]) +packBitsToWord = loop 0 0 + where + loop _ w [] = (w, []) + loop i w (x:xs) + | i >= wordSize = (w, x:xs) + | otherwise = loop (i+1) (if toBool x then setBit w i else w) xs + +readWordL :: [Bit] -> Int -> Word +readWordL xs 0 = fst (packBitsToWord xs) +readWordL xs n = readWordL (drop n xs) 0 + +wordToBitList :: Word -> [Bit] +wordToBitList w = [ fromBool (testBit w i) | i <- [0 .. wordSize - 1] ] + +writeWordL :: [Bit] -> Int -> Word -> [Bit] +writeWordL xs 0 w = zipWith const (wordToBitList w) xs ++ drop wordSize xs +writeWordL xs n w = pre ++ writeWordL post 0 w + where (pre, post) = splitAt n xs + +prop_writeWordL_preserves_length xs (NonNegative n) w = + length (writeWordL xs n w) == length xs + +prop_writeWordL_preserves_prefix xs (NonNegative n) w = + take n (writeWordL xs n w) == take n xs + +prop_writeWordL_preserves_suffix xs (NonNegative n) w = + drop (n + wordSize) (writeWordL xs n w) == drop (n + wordSize) xs + +prop_writeWordL_readWordL xs n w = + 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) + -> (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) + diff --git a/test/Tests/Bit.hs b/test/Tests/Bit.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Bit.hs @@ -0,0 +1,46 @@ +module Tests.Bit where + +import Data.Bit +import Data.Bits +import Test.HUnit +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +b0 = 0 :: Bit +b1 = 1 :: Bit + +testOp opName op rOp = + [ testCase (unwords [opName, show x]) + (op x @?= rOp x) + | x <- [0, 1 :: Bit] + ] + +testBinop opName op rOp = + [ testCase (unwords [show x, opName, show y]) + (op x y @?= rOp x y) + | x <- [0, 1 :: Bit] + , y <- [0, 1 :: Bit] + ] + +bitTests = testGroup "Data.Bit" + [ testGroup "basic assertions" + [ testCase "toBool 0" (toBool 0 @?= False) + , testCase "toBool 1" (toBool 1 @?= True) + , testCase "fromBool False" (fromBool False @?= 0) + , testCase "fromBool True" (fromBool True @?= 1) + , testCase "fromInteger 0" (fromInteger 0 @?= (0 :: Bit)) + , testCase "fromInteger 1" (fromInteger 1 @?= (1 :: Bit)) + ] + , testGroup "Num instance forms ℤ/2" $ concat + [ [ testProperty "fromInteger == odd" prop_fromInteger ] + , testBinop "+" (+) xor + , testBinop "*" (*) (.&.) + , testBinop "-" (+) xor + , testOp "negate" negate id + , testOp "abs" abs id + , testOp "signum" signum id + ] + ] + +prop_fromInteger x = fromInteger x == fromBool (odd x) diff --git a/test/Tests/MVector.hs b/test/Tests/MVector.hs new file mode 100644 --- /dev/null +++ b/test/Tests/MVector.hs @@ -0,0 +1,111 @@ +module Tests.MVector where + +import Support + +import Control.Monad +import Control.Monad.ST +import Data.Bit +import Data.STRef +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.New as N +import qualified Data.Vector.Unboxed.Bit as B +import qualified Data.Vector.Unboxed.Mutable.Bit as U +import qualified Data.Vector.Unboxed.Mutable as M +import Data.Word +import Test.Framework (testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +mvectorTests = testGroup "Data.Vector.Unboxed.Mutable.Bit" + [ testGroup "Data.Vector.Unboxed.Mutable functions" + [ testProperty "slice" prop_slice_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 "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 + ] + +prop_slice_def :: Int -> Int -> N.New U.Vector Bit -> Bool +prop_slice_def s n xs = runST $ do + let xs' = V.new xs + (s', n') = trimSlice s n (V.length xs') + xs <- N.run xs + xs <- V.unsafeFreeze (M.slice s' n' xs) + + return (B.toList xs == sliceList s' n' (B.toList xs')) + +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 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 U.Vector Bit -> Bool +prop_wordLength_def xs + = runST (fmap U.wordLength (N.run xs)) + == runST (fmap U.length (N.run xs >>= U.cloneToWords)) + +prop_cloneFromWords_def :: Int -> Int -> N.New U.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_cloneToWords_def :: N.New U.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 U.Vector Bit -> Bool +prop_mapMInPlaceWithIndex_leftToRight xs + = runST $ do + x <- newSTRef (-1) + xs <- N.run xs + let f i _ = do + j <- readSTRef x + writeSTRef x i + return (if i > j then maxBound else 0) + U.mapMInPlaceWithIndex f xs + xs <- V.unsafeFreeze xs + return (all toBool (B.toList xs)) + +prop_mapMInPlaceWithIndex_aligned :: N.New U.Vector Bit -> Bool +prop_mapMInPlaceWithIndex_aligned xs = runST $ do + ok <- newSTRef True + xs <- 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 xs + readSTRef ok + +prop_countBits_def :: N.New U.Vector Bit -> Bool +prop_countBits_def xs + = runST (N.run xs >>= U.countBits) + == B.countBits (V.new xs) + +prop_listBits_def :: N.New U.Vector Bit -> Bool +prop_listBits_def xs + = runST (N.run xs >>= U.listBits) + == B.listBits (V.new xs) + +prop_reverseInPlace_def :: N.New U.Vector Bit -> Bool +prop_reverseInPlace_def xs + = runST (N.run xs >>= \v -> U.reverseInPlace v >> V.unsafeFreeze v) + == B.reverse (V.new xs) + diff --git a/test/Tests/SetOps.hs b/test/Tests/SetOps.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SetOps.hs @@ -0,0 +1,94 @@ +module Tests.SetOps where + +import Support () + +import Data.Bit +import Data.Bits +import qualified Data.Vector.Unboxed.Bit as U +import Data.Word +import Test.Framework (testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +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 "invert" prop_invert_def + + , testProperty "select" prop_select_def + , testProperty "exclude" prop_exclude_def + + , testProperty "selectBits" prop_selectBits_def + , testProperty "excludeBits" prop_excludeBits_def + + , testProperty "countBits" prop_countBits_def + ] + +prop_union_def :: U.Vector Bit -> U.Vector Bit -> Bool +prop_union_def xs ys + = U.toList (U.union xs ys) + == zipWith (.|.) (U.toList xs) (U.toList ys) + +prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Bool +prop_intersection_def xs ys + = U.toList (U.intersection xs ys) + == zipWith (.&.) (U.toList xs) (U.toList ys) + +prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Bool +prop_difference_def xs ys + = U.toList (U.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 +prop_symDiff_def xs ys + = U.toList (U.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 0) (map (U.pad n) xss)) + where n = n' `mod` maxN + +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 1) (map (U.padWith 1 n) xss)) + where n = n' `mod` maxN + +prop_invert_def :: U.Vector Bit -> Bool +prop_invert_def xs + = U.toList (U.invert xs) + == map complement (U.toList xs) + +prop_select_def :: U.Vector Bit -> U.Vector Word -> Bool +prop_select_def xs ys + = U.select xs ys + == [ x | (1, x) <- zip (U.toList xs) (U.toList ys)] + +prop_exclude_def :: U.Vector Bit -> U.Vector Word -> Bool +prop_exclude_def xs ys + = U.exclude xs ys + == [ x | (0, 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) + +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) + +prop_countBits_def :: U.Vector Bit -> Bool +prop_countBits_def xs + = U.countBits xs + == U.length (U.selectBits xs xs) diff --git a/test/Tests/Vector.hs b/test/Tests/Vector.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Vector.hs @@ -0,0 +1,151 @@ +module Tests.Vector where + +import Support + +import Data.Bit +import Data.Bits +import Data.List +import qualified Data.Vector.Unboxed.Bit as U +import Data.Word +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.QuickCheck +import Test.QuickCheck.Function + +vectorTests = testGroup "Data.Vector.Unboxed.Bit" + [ testCase "wordSize correct" (U.wordSize @?= bitSize (0 :: Word)) + , 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 "reverse" prop_reverse_def + , testProperty "countBits" prop_countBits_def + , testProperty "listBits" prop_listBits_def + , testGroup "Boolean operations" + [ testProperty "and" prop_and_def + , testProperty "or" prop_or_def + ] + , testGroup "Search operations" + [ testProperty "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 + ] + ] + +prop_toList_fromList :: [Bit] -> Bool +prop_toList_fromList xs = + U.toList (U.fromList xs) == xs + +prop_fromList_toList :: U.Vector Bit -> Bool +prop_fromList_toList xs = + U.fromList (U.toList xs) == xs + +prop_slice_def :: Int -> Int -> U.Vector Bit -> Bool +prop_slice_def s n xs + = sliceList s' n' (U.toList xs) + == U.toList (U.slice s' n' xs) + where + (s', n') = trimSlice s n (U.length xs) + +prop_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 0) + where n' = n `mod` maxN + +prop_toWords_def :: U.Vector Bit -> Bool +prop_toWords_def xs + = U.toList (U.toWords 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) + +prop_countBits_def :: U.Vector Bit -> Bool +prop_countBits_def xs + = U.countBits xs + == length (filter toBool (U.toList xs)) + +prop_listBits_def :: U.Vector Bit -> Bool +prop_listBits_def xs + = U.listBits xs + == [ i | (i,x) <- zip [0..] (U.toList xs), toBool x] + +prop_and_def :: U.Vector Bit -> Bool +prop_and_def xs + = U.and xs + == all toBool (U.toList xs) + +prop_or_def :: U.Vector Bit -> Bool +prop_or_def xs + = U.or xs + == any toBool (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_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_anyBits_def :: Bit -> U.Vector Bit -> Bool +prop_anyBits_def b xs + = U.anyBits b xs + == U.any (b ==) xs + +prop_allBits_def :: Bit -> U.Vector Bit -> Bool +prop_allBits_def b xs + = U.allBits b xs + == U.all (b ==) xs + +prop_first_def :: Bit -> U.Vector Bit -> Bool +prop_first_def b xs + = U.first b xs + == findIndex (b ==) (U.toList xs) + +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'