bitvec (empty) → 0.1
raw patch · 14 files changed
+1586/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, primitive, test-framework, test-framework-hunit, test-framework-quickcheck2, vector
Files
- LICENSE +5/−0
- Setup.lhs +5/−0
- bitvec.cabal +56/−0
- src/Data/Bit.hs +89/−0
- src/Data/Bit/Internal.hs +168/−0
- src/Data/Vector/Unboxed/Bit.hs +251/−0
- src/Data/Vector/Unboxed/Bit/Internal.hs +192/−0
- src/Data/Vector/Unboxed/Mutable/Bit.hs +299/−0
- test/Main.hs +16/−0
- test/Support.hs +103/−0
- test/Tests/Bit.hs +46/−0
- test/Tests/MVector.hs +111/−0
- test/Tests/SetOps.hs +94/−0
- test/Tests/Vector.hs +151/−0
+ LICENSE view
@@ -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).
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ bitvec.cabal view
@@ -0,0 +1,56 @@+name: bitvec+version: 0.1+stability: experimental++cabal-version: >= 1.9.2+build-type: Simple++author: James Cook <mokus@deepbondi.net>+maintainer: James Cook <mokus@deepbondi.net>+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
+ src/Data/Bit.hs view
@@ -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
+ src/Data/Bit/Internal.hs view
@@ -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
+ src/Data/Vector/Unboxed/Bit.hs view
@@ -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
+ src/Data/Vector/Unboxed/Bit/Internal.hs view
@@ -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)
+ src/Data/Vector/Unboxed/Mutable/Bit.hs view
@@ -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
+ test/Main.hs view
@@ -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+ ]
+ test/Support.hs view
@@ -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)+
+ test/Tests/Bit.hs view
@@ -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)
+ test/Tests/MVector.hs view
@@ -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)+
+ test/Tests/SetOps.hs view
@@ -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)
+ test/Tests/Vector.hs view
@@ -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'