From: PHO Date: Sat, 19 Feb 2011 12:21:35 +0000 (+0900) Subject: Removed BitString X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=a35118daab8f022314c67b6d611b6ae0a7622fad;p=wavpack.git Removed BitString --- diff --git a/Codec/Audio/WavPack/BitString.hs b/Codec/Audio/WavPack/BitString.hs deleted file mode 100644 index 577e09f..0000000 --- a/Codec/Audio/WavPack/BitString.hs +++ /dev/null @@ -1,432 +0,0 @@ -{-# LANGUAGE - BangPatterns - , UnboxedTuples - , UnicodeSyntax - #-} --- | Lazy bitstrings based on 'L.ByteString' which treats a byte --- stream as a bit sequence in the same way as WavPack's manner. -module Codec.Audio.WavPack.BitString - ( -- * The BitString Type - BitString - - -- * Construction - , (∅) - , empty - , singleton - - -- * Basic Interface - , cons - , snoc - , head - , uncons - , tail - , null - , length - - -- * Conversion from/to 'L.ByteString' - , fromByteString - , toByteString - - -- * Substrings - , take - , drop - , splitAt - ) - where -import qualified Data.ByteString.Lazy as L -import Data.Bits -import Data.Int -import qualified Data.Strict as S -import Data.Word -import Prelude hiding (drop, head, length, null, splitAt, tail, take) -import Prelude.Unicode - --- | The BitString Type. -data BitString - = BitString { - leftRem ∷ !Remnant - , leftBytes ∷ !L.ByteString - -- | reversed - , rightBytes ∷ !L.ByteString - , rightRem ∷ !Remnant - } - deriving Show - --- | /O(n)/ The bitstrings must have finite lengths to test the --- equality. -instance Eq BitString where - a == b = leftRem a' ≡ leftRem b' ∧ - leftBytes a' ≡ leftBytes b' ∧ - rightRem a' ≡ rightRem b' - where - a' = normalise a - b' = normalise b - -normalise ∷ BitString → BitString -normalise bs - | remLen (leftRem bs) ≡ 8 - = normalise $ bs { - leftRem = remEmpty - , leftBytes = L.cons (remByte $ leftRem bs) $ leftBytes bs - } - | remLen (rightRem bs) ≡ 8 - = normalise $ bs { - rightBytes = L.cons (remByte $ rightRem bs) $ rightBytes bs - , rightRem = remEmpty - } - | otherwise - = bs { - leftBytes = leftBytes bs `L.append` (L.reverse $ rightBytes bs) - , rightBytes = L.empty - } - -data Remnant - = Remnant { - -- | bit length from 0 to 8 - remLen ∷ !Int - -- | current byte @(0 <= remByte <= (1 `'shiftL'` 'remLen') - 1)@ - , remByte ∷ !Word8 - } - deriving (Eq, Show) - -remEmpty ∷ Remnant -remEmpty = Remnant 0 0 - -remNull ∷ Remnant → Bool -remNull = (0 ≡) ∘ remLen - -remSingleton ∷ Bool -> Remnant -remSingleton b = Remnant { - remLen = 1 - , remByte = if b then 1 else 0 - } - -byteToRem ∷ Word8 → Remnant -byteToRem w = Remnant { - remLen = 8 - , remByte = w - } - -remToStr ∷ Remnant → L.ByteString -remToStr r - | remNull r = L.empty - | otherwise = L.singleton $ remByte r - -consRem ∷ Bool → Remnant → (# Remnant, S.Maybe Word8 #) -consRem b r - | remLen r ≡ 8 = (# remSingleton b, S.Just $ remByte r #) - | remLen r ≡ 7 = (# remEmpty, S.Just w' #) - | otherwise = let !r' = r { - remLen = remLen r + 1 - , remByte = w' - } - in - (# r', S.Nothing #) - where - w' = (remByte r `shiftL` 1) - .|. - if b then 1 else 0 - -snocRem ∷ Remnant → Bool → (# S.Maybe Word8, Remnant #) -snocRem r b - | remLen r ≡ 8 = (# S.Just $ remByte r, remSingleton b #) - | remLen r ≡ 7 = (# S.Just w', remEmpty #) - | otherwise = let !r' = r { - remLen = remLen r + 1 - , remByte = w' - } - in - (# S.Nothing, r' #) - where - w' | b = bit (remLen r) .|. remByte r - | otherwise = remByte r - -unconsRem ∷ Remnant → (# S.Maybe Bool, Remnant #) -unconsRem r - | remNull r = (# S.Nothing, remEmpty #) - | otherwise = let !b = remByte r `testBit` 0 - !r' = Remnant { - remLen = remLen r - 1 - , remByte = remByte r `shiftR` 1 - } - in - (# S.Just b, r' #) - -unconsBytes ∷ L.ByteString → (# S.Maybe Remnant, L.ByteString #) -unconsBytes bs - = case L.uncons bs of - Just (!w, bs') - → (# S.Just (byteToRem w), bs' #) - Nothing - → (# S.Nothing, L.empty #) - -appendRem ∷ Remnant → Remnant → Remnant -appendRem a b = Remnant { - remLen = remLen a + remLen b - , remByte = (remByte a `shiftL` remLen b) .|. remByte b - } - -splitRemAt ∷ Integral n ⇒ n → Remnant → (# S.Maybe Remnant, Remnant #) -splitRemAt n r - | remLen r ≥ fromIntegral n - = let !h = Remnant { - remLen = fromIntegral n - , remByte = remByte r .&. ((1 `shiftL` fromIntegral n) - 1) - } - !r' = Remnant { - remLen = remLen r - fromIntegral n - , remByte = remByte r `shiftR` fromIntegral n - } - in - (# S.Just h, r' #) - | otherwise - = (# S.Nothing, remEmpty #) - --- | /O(1)/ The same as 'empty'. -(∅) ∷ BitString -(∅) = empty - --- | /O(1)/ The empty 'BitString'. -empty ∷ BitString -empty = BitString { - leftRem = remEmpty - , leftBytes = L.empty - , rightBytes = L.empty - , rightRem = remEmpty - } - --- | /O(1)/ Convert a 'Bool' into a 'BitString'. -singleton ∷ Bool → BitString -singleton b = BitString { - leftRem = remSingleton b - , leftBytes = L.empty - , rightBytes = L.empty - , rightRem = remEmpty - } - --- | /O(1)/ Prepend a bit to the beginning of a 'BitString'. -cons ∷ Bool → BitString → BitString -cons b bs - = case consRem b $ leftRem bs of - (# lr', S.Just w #) - → bs { - leftRem = lr' - , leftBytes = L.cons' w $ leftBytes bs - } - - (# lr', S.Nothing #) - → bs { leftRem = lr' } - --- | /O(1)/ Append a bit to the end of a 'BitString'. -snoc ∷ BitString → Bool → BitString -snoc bs b - = case snocRem (rightRem bs) b of - (# S.Just w, rr' #) - → bs { - rightBytes = L.cons' w $ rightBytes bs - , rightRem = rr' - } - - (# S.Nothing, rr' #) - → bs { rightRem = rr' } - --- | /amortized O(1)/ Extract the first bit of a 'BitString', which --- must be non-empty. -head ∷ BitString → Bool -head bs = case uncons bs of - Just (b, _ ) - → b - Nothing - → error "head: empty BitString" - --- | /amortized O(1)/ Extract the bits after the head of a --- 'BitString', which must be non-empty. -tail ∷ BitString → BitString -tail bs = case uncons bs of - Just (_, bs') - → bs' - Nothing - → error "tail: empty BitString" - --- | /amortized O(1)/ Extract the the head and tail of a 'BitString', --- returning 'Nothing' if it's empty. -uncons ∷ BitString → Maybe (Bool, BitString) -uncons bs - = case unconsRem $ leftRem bs of - (# S.Just b, lr' #) - → Just (b, bs { leftRem = lr' }) - - (# S.Nothing, _ #) - → case unconsBytes $ leftBytes bs of - (# S.Just lr, lb' #) - → let !bs' = bs { leftRem = lr - , leftBytes = lb' - } - in - uncons bs' - - (# S.Nothing, _ #) - → if L.null $ rightBytes bs then - case unconsRem $ rightRem bs of - (# S.Just b, rr' #) - → Just (b, bs { rightRem = rr' }) - - (# S.Nothing, _ #) - → Nothing - else - let !bs' = bs { leftBytes = L.reverse - $ rightBytes bs - } - in - uncons bs' - --- | /O(1)/ Test whether a 'BitString' is empty. -null ∷ BitString → Bool -null bs - = remNull (leftRem bs) - ∧ - L.null (leftBytes bs) - ∧ - L.null (rightBytes bs) - ∧ - remNull (rightRem bs) - --- | /O(n)/ @'length' bs@ returns the number of bits in @bs@. @bs@ --- must have a finite length. -length ∷ Integral n ⇒ BitString → n -length bs - = fromIntegral $ ( fromIntegral (remLen $ leftRem bs) - + - L.length (leftBytes bs) ⋅ 8 - + - L.length (rightBytes bs) ⋅ 8 - + - fromIntegral (remLen $ rightRem bs) - ) -{-# SPECIALISE length ∷ BitString → Int64 #-} - --- | /O(1)/ Convert a 'L.ByteString' into a 'BitString'. -fromByteString ∷ L.ByteString → BitString -fromByteString bs = BitString { - leftRem = remEmpty - , leftBytes = bs - , rightBytes = L.empty - , rightRem = remEmpty - } - --- | /O(n)/ @'toByteString' bs@ converts @bs@ into 'L.ByteString', --- padding incomplete bytes to single bytes with necessary 0's at --- their MSB. Thus the following equation does not hold when the --- length of @bs@ isn't multiple of 8. --- --- > fromByteString . toByteString = id --- --- But the following always holds true. --- --- > toByteString . fromByteString = id --- --- Note that @bs@ must have a finite length. -toByteString ∷ BitString → L.ByteString -toByteString bs - = L.concat [ remToStr $ leftRem bs - , leftBytes bs - , L.reverse $ rightBytes bs - , remToStr $ rightRem bs - ] - --- | /O(n)/ @'take' n bs@ returns the prefix of @bs@ of length --- @n@. @bs@ must have at least @n@ bits. -take ∷ Integral n ⇒ n → BitString → BitString -take n xs = case splitAt n xs of - (taken, _) → taken - --- | /O(n)/ @'drop' n bs@ returns the suffix of @bs@ after the first --- @n@ bits. @bs@ must have at least @n@ bits. -drop ∷ Integral n ⇒ n → BitString → BitString -drop n xs = case splitAt n xs of - (_, dropped) → dropped - --- | /O(n)/ @'splitAt' n bs@ is equivalent to @('take' n bs, 'drop' n --- bs)@. -splitAt ∷ Integral n ⇒ n → BitString → (BitString, BitString) -splitAt n bs - = case splitRemAt n $ leftRem bs of - (# S.Just h, lr' #) - -- The leftRem has enough bits. - → let !h' = BitString { - leftRem = h - , leftBytes = L.empty - , rightBytes = L.empty - , rightRem = remEmpty - } - in - (h', bs { leftRem = lr' }) - - (# S.Nothing, _ #) - → let !bytesToTake = (n - fromIntegral (remLen $ leftRem bs)) `div` 8 - !amortised = leftBytes bs `L.append` (L.reverse $ rightBytes bs) - -- 0 ≤ bitsToTake < 8 - remLen (leftRem bs) - -- ∴ remLen (leftRem bs) + bitsToTake < 8 - !bitsToTake = n - bytesToTake ⋅ 8 - fromIntegral (remLen $ leftRem bs) - in - case (# bytesToTake, L.uncons amortised #) of - (#_, Just (!w, amor') #) - -- There is at least one byte in the byte pool - -- (amortised). - → let !h1 = leftRem bs - (# h2, lr' #) - = case splitRemAt bitsToTake $ byteToRem w of - (# S.Just h2', lr'' #) → (# h2', lr'' #) - (# S.Nothing , _ #) → error "internal error" - !h = h1 `appendRem` h2 - (bytes, lb') - = L.splitAt (fromIntegral bytesToTake) amor' - in - if L.length bytes ≡ fromIntegral bytesToTake then - -- The byte pool actuall has at least - -- bytesToTake bytes. - let !h' = BitString { - leftRem = h - , leftBytes = bytes - , rightBytes = L.empty - , rightRem = remEmpty - } - !bs' = BitString { - leftRem = lr' - , leftBytes = lb' - , rightBytes = L.empty - , rightRem = rightRem bs - } - in - (h', bs') - else - error "splitAt: not enough bits" - - (# 0, Nothing #) - -- No bytes are in the byte pool but the - -- rightRem may have enough bits. - → case splitRemAt bitsToTake $ rightRem bs of - (# S.Just h, rr' #) - → let !h' = BitString { - leftRem = leftRem bs - , leftBytes = L.empty - , rightBytes = L.empty - , rightRem = h - } - !bs' = BitString { - leftRem = remEmpty - , leftBytes = L.empty - , rightBytes = L.empty - , rightRem = rr' - } - in - (h', bs') - - (# S.Nothing, _ #) - → error "splitAt: not enough bits" - - (# _, Nothing #) - -- No bytes are in the byte pool but more than 8 - -- bits are requested. The rightRem can't have - -- that many bits. - → error "splitAt: not enough bits" diff --git a/Codec/Audio/WavPack/Metadata.hs b/Codec/Audio/WavPack/Metadata.hs index fcd873b..def1cb3 100644 --- a/Codec/Audio/WavPack/Metadata.hs +++ b/Codec/Audio/WavPack/Metadata.hs @@ -20,7 +20,6 @@ module Codec.Audio.WavPack.Metadata , Unknown(..) ) where -import qualified Codec.Audio.WavPack.BitString as B import Codec.Audio.WavPack.Internal import Control.Monad import Data.Binary @@ -275,17 +274,17 @@ instance Binary EntropyVars where -- | WV Bitstream data WVBitstream = WVBitstream { - wvStream ∷ !B.BitString + wvStream ∷ !L.ByteString } deriving (Eq, Show, Typeable) instance Metadata WVBitstream where metaID _ = 0x0A - metaSize = (`div` 8) ∘ B.length ∘ wvStream + metaSize = fromIntegral ∘ L.length ∘ wvStream instance Binary WVBitstream where - put = putLazyByteString ∘ B.toByteString ∘ wvStream - get = fmap (WVBitstream ∘ B.fromByteString) getRemainingLazyByteString + put = putLazyByteString ∘ wvStream + get = fmap WVBitstream getRemainingLazyByteString -- | RIFF header for .wav files (before audio) data RIFFHeader diff --git a/wavpack.cabal b/wavpack.cabal index 57927a0..06ebd95 100644 --- a/wavpack.cabal +++ b/wavpack.cabal @@ -35,13 +35,13 @@ Library base-unicode-symbols == 0.2.*, binary == 0.5.*, binary-strict == 0.4.*, + bitstream == 0.1.*, bytestring == 0.9.*, strict == 0.3.*, vector == 0.7.* Exposed-Modules: Codec.Audio.WavPack - Codec.Audio.WavPack.BitString Codec.Audio.WavPack.Block Codec.Audio.WavPack.Decorrelation Codec.Audio.WavPack.Internal