diff --git a/hw-bits.cabal b/hw-bits.cabal --- a/hw-bits.cabal +++ b/hw-bits.cabal @@ -1,5 +1,5 @@ name: hw-bits -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-bits#readme @@ -42,9 +42,12 @@ , HaskellWorks.Data.Bits.ElemFixedBitSize , HaskellWorks.Data.Bits.FixedBitSize , HaskellWorks.Data.Bits.FromBitTextByteString + , HaskellWorks.Data.Bits.Log2 , HaskellWorks.Data.Bits.PopCount , HaskellWorks.Data.Bits.PopCount.PopCount0 , HaskellWorks.Data.Bits.PopCount.PopCount1 + , HaskellWorks.Data.Bits.SubWord64Vector + , HaskellWorks.Data.Bits.SubWord64Vector.Internal , HaskellWorks.Data.Bits.Types.Broadword , HaskellWorks.Data.Bits.Types.Builtin , HaskellWorks.Data.Bits.Unmatched @@ -53,6 +56,7 @@ , bytestring , hw-prim >= 0.1.0.0 , parsec + , safe , vector default-language: Haskell2010 @@ -65,7 +69,10 @@ other-modules: HaskellWorks.Data.Bits.BitReadSpec , HaskellWorks.Data.Bits.BitWiseSpec , HaskellWorks.Data.Bits.FromBitTextByteStringSpec + , HaskellWorks.Data.Bits.Log2Spec , HaskellWorks.Data.Bits.UnmatchedSpec + , HaskellWorks.Data.Bits.SubWord64VectorSpec + , HaskellWorks.Data.Bits.SubWord64Vector.InternalSpec build-depends: base >= 4 && < 5 , bytestring , hspec diff --git a/src/HaskellWorks/Data/Bits/AllExcess/AllExcess1.hs b/src/HaskellWorks/Data/Bits/AllExcess/AllExcess1.hs --- a/src/HaskellWorks/Data/Bits/AllExcess/AllExcess1.hs +++ b/src/HaskellWorks/Data/Bits/AllExcess/AllExcess1.hs @@ -3,7 +3,8 @@ module HaskellWorks.Data.Bits.AllExcess.AllExcess1 where import Data.Word -import qualified Data.Vector.Storable as DVS +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS import HaskellWorks.Data.Bits.PopCount.PopCount0 import HaskellWorks.Data.Bits.PopCount.PopCount1 @@ -31,6 +32,22 @@ {-# INLINE allExcess1 #-} instance AllExcess1 Word64 where + allExcess1 w = fromIntegral (popCount1 w) - fromIntegral (popCount0 w) + {-# INLINE allExcess1 #-} + +instance AllExcess1 (DV.Vector Word8) where + allExcess1 w = fromIntegral (popCount1 w) - fromIntegral (popCount0 w) + {-# INLINE allExcess1 #-} + +instance AllExcess1 (DV.Vector Word16) where + allExcess1 w = fromIntegral (popCount1 w) - fromIntegral (popCount0 w) + {-# INLINE allExcess1 #-} + +instance AllExcess1 (DV.Vector Word32) where + allExcess1 w = fromIntegral (popCount1 w) - fromIntegral (popCount0 w) + {-# INLINE allExcess1 #-} + +instance AllExcess1 (DV.Vector Word64) where allExcess1 w = fromIntegral (popCount1 w) - fromIntegral (popCount0 w) {-# INLINE allExcess1 #-} diff --git a/src/HaskellWorks/Data/Bits/BitLength.hs b/src/HaskellWorks/Data/Bits/BitLength.hs --- a/src/HaskellWorks/Data/Bits/BitLength.hs +++ b/src/HaskellWorks/Data/Bits/BitLength.hs @@ -17,9 +17,9 @@ import qualified Data.Vector as DV import qualified Data.Vector.Storable as DVS import Data.Word +import HaskellWorks.Data.IndexedSeq import HaskellWorks.Data.Naive import HaskellWorks.Data.Positioning -import HaskellWorks.Data.Vector.VectorLike import Prelude as P -- | Number of bits in a value including ones and zeros. @@ -33,11 +33,11 @@ -------------------------------------------------------------------------------- -- Functions -elemBitLength :: (VectorLike v, BitLength (Elem v)) => v -> Count +elemBitLength :: (IndexedSeq v, BitLength (Elem v)) => v -> Count elemBitLength v = bitLength (v !!! 0) {-# INLINE elemBitLength #-} -elemBitEnd :: (VectorLike v, BitLength (Elem v)) => v -> Position +elemBitEnd :: (IndexedSeq v, BitLength (Elem v)) => v -> Position elemBitEnd v = endPosition (v !!! 0) {-# INLINE elemBitEnd #-} diff --git a/src/HaskellWorks/Data/Bits/BitWise.hs b/src/HaskellWorks/Data/Bits/BitWise.hs --- a/src/HaskellWorks/Data/Bits/BitWise.hs +++ b/src/HaskellWorks/Data/Bits/BitWise.hs @@ -19,9 +19,9 @@ import qualified Data.Vector.Storable as DVS import Data.Word import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.IndexedSeq as IS import HaskellWorks.Data.Naive import HaskellWorks.Data.Positioning -import HaskellWorks.Data.Vector.VectorLike as VL import Prelude as P -- We pervasively use precedence to avoid excessive parentheses, and we use diff --git a/src/HaskellWorks/Data/Bits/Log2.hs b/src/HaskellWorks/Data/Bits/Log2.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/Log2.hs @@ -0,0 +1,48 @@ +module HaskellWorks.Data.Bits.Log2 + ( Log2(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.IndexedSeq + +class Log2 a where + log2 :: a -> Int + +log2_64_tab :: DVS.Vector Int +log2_64_tab = DVS.fromList [ + 63, 0, 58, 1, 59, 47, 53, 2, + 60, 39, 48, 27, 54, 33, 42, 3, + 61, 51, 37, 40, 49, 18, 28, 20, + 55, 30, 34, 11, 43, 14, 22, 4, + 62, 57, 46, 52, 38, 26, 32, 41, + 50, 36, 17, 19, 29, 10, 13, 21, + 56, 45, 25, 31, 35, 16, 9, 12, + 44, 24, 15, 8, 23, 7, 6, 5] + +log2_32_tab :: DVS.Vector Int +log2_32_tab = DVS.fromList [ + 0, 9, 1, 10, 13, 21, 2, 29, + 11, 14, 16, 18, 22, 25, 3, 30, + 8, 12, 20, 28, 15, 17, 24, 7, + 19, 27, 23, 6, 26, 5, 4, 31] + +instance Log2 Word64 where + log2 v0 = + let v1 = v0 .|. (v0 .>. 1) in + let v2 = v1 .|. (v1 .>. 2) in + let v3 = v2 .|. (v2 .>. 4) in + let v4 = v3 .|. (v3 .>. 8) in + let v5 = v4 .|. (v4 .>. 16) in + let v6 = v5 .|. (v5 .>. 32) in + log2_64_tab !!! fromIntegral (((v6 - (v6 .>. 1)) * 0x07EDD5E59A4E28C2) .>. 58) + +instance Log2 Word32 where + log2 v0 = + let v1 = v0 .|. (v0 .>. 1) in + let v2 = v1 .|. (v1 .>. 2) in + let v3 = v2 .|. (v2 .>. 4) in + let v4 = v3 .|. (v3 .>. 8) in + let v5 = v4 .|. (v4 .>. 16) in + log2_32_tab !!! fromIntegral ((v5 * 0x07C4ACDD) .>. 27) diff --git a/src/HaskellWorks/Data/Bits/SubWord64Vector.hs b/src/HaskellWorks/Data/Bits/SubWord64Vector.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/SubWord64Vector.hs @@ -0,0 +1,26 @@ +module HaskellWorks.Data.Bits.SubWord64Vector + ( SubWord64Vector(..) + , fromList + , toList + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.SubWord64Vector.Internal + +data SubWord64Vector = SubWord64Vector + { swBuffer :: !(DVS.Vector Word64) + , swSize :: !Word + , swBufferLen :: !Int + } deriving (Eq, Show) + +fromList :: Int -> [Word64] -> SubWord64Vector +fromList wl ws = + SubWord64Vector + { swBuffer = DVS.fromList (packBits wl ws) + , swBufferLen = fromIntegral (length ws) + , swSize = fromIntegral wl + } + +toList :: SubWord64Vector -> [Word64] +toList v = unpackBits (swBufferLen v) (fromIntegral (swSize v)) (DVS.toList (swBuffer v)) diff --git a/src/HaskellWorks/Data/Bits/SubWord64Vector/Internal.hs b/src/HaskellWorks/Data/Bits/SubWord64Vector/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/SubWord64Vector/Internal.hs @@ -0,0 +1,86 @@ +module HaskellWorks.Data.Bits.SubWord64Vector.Internal + ( loBitsSized + , packBits + , packBits' + , unpackBits + , unpackBits' + ) where + +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.FixedBitSize + +{-# ANN module ("HLint: Reduce duplication" :: String) #-} + +class LoBitsSized a where + loBitsSized :: Int -> a + +class Integral a => PackBits a where + packBits :: Int -> [a] -> [a] + packBits = packBits' 0 0 + + packBits' :: Int -> a -> Int -> [a] -> [a] + +class Integral a => UnpackBits a where + unpackBits :: Int -> Int -> [a] -> [a] + unpackBits = unpackBits' 0 0 + + unpackBits' :: Int -> a -> Int -> Int -> [a] -> [a] + +instance LoBitsSized Word64 where + loBitsSized n = let o = fromIntegral (64 - n) in 0xFFFFFFFFFFFFFFFF .<. o .>. o + +instance LoBitsSized Word32 where + loBitsSized n = let o = fromIntegral (32 - n) in 0xFFFFFFFF .<. o .>. o + +instance LoBitsSized Word16 where + loBitsSized n = let o = fromIntegral (16 - n) in 0xFFFF .<. o .>. o + +instance LoBitsSized Word8 where + loBitsSized n = let o = fromIntegral (8 - n) in 0xFF .<. o .>. o + +instance PackBits Word64 where + packBits' filled carry bitLen (w:ws) = if fillNeeded < fromIntegral (fixedBitSize carry) + then packBits' fillNeeded newV bitLen ws + else newV : packBits' fillLeft carryV bitLen ws + where fillNeeded = filled + bitLen + fillMet = fillNeeded `min` fromIntegral (fixedBitSize carry) + fillLeft = fillNeeded - fillMet + bitMet = fillMet - filled + newV = carry .|. ((w .&. loBitsSized bitMet) .<. fromIntegral filled) + carryV = w .>. fromIntegral bitMet + packBits' _ carry _ _ = [carry] + +instance UnpackBits Word64 where + unpackBits' _ _ 0 _ _ = [] + unpackBits' filled carry dataLen bitLen ws | filled >= bitLen = + let result = (carry .&. loBitsSized bitLen) : unpackBits' (filled - bitLen) (carry .>. fromIntegral bitLen) (dataLen - 1) bitLen ws in + result + unpackBits' filled carry dataLen bitLen (w:ws) = + let bitsNeeded = bitLen - filled in + let newValue = carry .|. ((w .&. loBitsSized bitsNeeded) .<. fromIntegral filled) in + newValue : unpackBits' (fromIntegral (fixedBitSize carry) - bitsNeeded) (w .>. fromIntegral bitsNeeded) (dataLen - 1) bitLen ws + unpackBits' _ _ _ _ _ = [] + +instance PackBits Word8 where + packBits' filled carry bitLen (w:ws) = if fillNeeded < fromIntegral (fixedBitSize carry) + then packBits' fillNeeded newV bitLen ws + else newV : packBits' fillLeft carryV bitLen ws + where fillNeeded = filled + bitLen + fillMet = fillNeeded `min` fromIntegral (fixedBitSize carry) + fillLeft = fillNeeded - fillMet + bitMet = fillMet - filled + newV = carry .|. ((w .&. loBitsSized bitMet) .<. fromIntegral filled) + carryV = w .>. fromIntegral bitMet + packBits' _ carry _ _ = [carry] + +instance UnpackBits Word8 where + unpackBits' _ _ 0 _ _ = [] + unpackBits' filled carry dataLen bitLen ws | filled >= bitLen = + (carry .&. loBitsSized bitLen) : unpackBits' (filled - bitLen) (carry .>. fromIntegral bitLen) (dataLen - 1) bitLen ws + unpackBits' filled carry dataLen bitLen (w:ws) = + let bitsNeeded = bitLen - filled in + let newValue = carry .|. ((w .&. loBitsSized bitsNeeded) .<. fromIntegral filled) in + let result = newValue : unpackBits' (8 - bitsNeeded) (w .>. fromIntegral bitsNeeded) (dataLen - 1) bitLen ws in + result + unpackBits' _ _ _ _ _ = [] diff --git a/test/HaskellWorks/Data/Bits/Log2Spec.hs b/test/HaskellWorks/Data/Bits/Log2Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/Log2Spec.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.Log2Spec (spec) where + +import Data.Word +import HaskellWorks.Data.Bits.Log2 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Bits.Log2Spec" $ do + it "Log2 Word64" $ property $ + \(NonZero (w :: Word64)) -> log2 w == floor (log (fromIntegral w) / log 2 :: Double) + it "Log2 Word32" $ property $ + \(NonZero (w :: Word32)) -> log2 w == floor (log (fromIntegral w) / log 2 :: Double) diff --git a/test/HaskellWorks/Data/Bits/SubWord64Vector/InternalSpec.hs b/test/HaskellWorks/Data/Bits/SubWord64Vector/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/SubWord64Vector/InternalSpec.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.SubWord64Vector.InternalSpec (spec) where + +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.SubWord64Vector.Internal +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +subWordSize :: Int -> Gen Int +subWordSize maxWordSize = choose (1, maxWordSize) + +word8OfSize :: Int -> Gen Word8 +word8OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) + +word64OfSize :: Int -> Gen Word64 +word64OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) + +listLen :: Gen Int +listLen = choose (1, 128) + +spec :: Spec +spec = describe "HaskellWorks.Data.Bits.SubWord64Vector.InternalSpec" $ do + it "SubWord64Vector Word8" $ + forAll (subWordSize 8) $ \wSize -> + forAll (choose (1, 3)) $ \len -> + forAll (vectorOf len (word8OfSize wSize)) $ \ws -> + unpackBits (length ws) wSize (packBits wSize ws) `shouldBe` ws + it "SubWord64Vector Word64" $ + forAll (subWordSize 64) $ \wSize -> + forAll listLen $ \len -> + forAll (vectorOf len (word64OfSize wSize)) $ \ws -> + unpackBits (length ws) wSize (packBits wSize ws) `shouldBe` ws diff --git a/test/HaskellWorks/Data/Bits/SubWord64VectorSpec.hs b/test/HaskellWorks/Data/Bits/SubWord64VectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/SubWord64VectorSpec.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.SubWord64VectorSpec (spec) where + +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.SubWord64Vector +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +subWordSize :: Int -> Gen Int +subWordSize maxWordSize = choose (1, maxWordSize) + +word64OfSize :: Int -> Gen Word64 +word64OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) + +listLen :: Gen Int +listLen = choose (1, 128) + +spec :: Spec +spec = describe "HaskellWorks.Data.Bits.SubWord64VectorSpec" $ do + it "SubWord64Vector Word64" $ + forAll (subWordSize 64) $ \wSize -> + forAll listLen $ \len -> + forAll (vectorOf len (word64OfSize wSize)) $ \ws -> + toList (fromList wSize ws) `shouldBe` ws