X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FBitString.hs;h=577e09f220114a978619cf2b40bffc945e03cdf5;hp=22e8a2849f4389b4cb105aefa7604315cdb8f5d1;hb=16211cdd0d7ebd32f10e224ab11bebc8be6fecb5;hpb=ce3c999ccb38fea048b8a619c23daeccffc8fcb1 diff --git a/Codec/Audio/WavPack/BitString.hs b/Codec/Audio/WavPack/BitString.hs index 22e8a28..577e09f 100644 --- a/Codec/Audio/WavPack/BitString.hs +++ b/Codec/Audio/WavPack/BitString.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - UnboxedTuples + BangPatterns + , UnboxedTuples , UnicodeSyntax #-} -- | Lazy bitstrings based on 'L.ByteString' which treats a byte @@ -10,6 +11,7 @@ module Codec.Audio.WavPack.BitString -- * Construction , (∅) + , empty , singleton -- * Basic Interface @@ -24,6 +26,11 @@ module Codec.Audio.WavPack.BitString -- * Conversion from/to 'L.ByteString' , fromByteString , toByteString + + -- * Substrings + , take + , drop + , splitAt ) where import qualified Data.ByteString.Lazy as L @@ -31,7 +38,7 @@ import Data.Bits import Data.Int import qualified Data.Strict as S import Data.Word -import Prelude hiding (head, length, null, tail) +import Prelude hiding (drop, head, length, null, splitAt, tail, take) import Prelude.Unicode -- | The BitString Type. @@ -43,13 +50,41 @@ data BitString , rightBytes ∷ !L.ByteString , rightRem ∷ !Remnant } - deriving (Eq, Show) + 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 + -- | current byte @(0 <= remByte <= (1 `'shiftL'` 'remLen') - 1)@ , remByte ∷ !Word8 } deriving (Eq, Show) @@ -88,7 +123,7 @@ consRem b r in (# r', S.Nothing #) where - w' = (remByte r `shiftR` 1) + w' = (remByte r `shiftL` 1) .|. if b then 1 else 0 @@ -109,7 +144,7 @@ snocRem r b unconsRem ∷ Remnant → (# S.Maybe Bool, Remnant #) unconsRem r | remNull r = (# S.Nothing, remEmpty #) - | otherwise = let !b = remByte r `testBit` 1 + | otherwise = let !b = remByte r `testBit` 0 !r' = Remnant { remLen = remLen r - 1 , remByte = remByte r `shiftR` 1 @@ -120,19 +155,45 @@ unconsRem r unconsBytes ∷ L.ByteString → (# S.Maybe Remnant, L.ByteString #) unconsBytes bs = case L.uncons bs of - Just (w, bs') + Just (!w, bs') → (# S.Just (byteToRem w), bs' #) Nothing → (# S.Nothing, L.empty #) --- | /O(1)/ The empty 'BitString'. +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 -(∅) = BitString { - leftRem = remEmpty - , leftBytes = L.empty - , rightBytes = L.empty - , rightRem = remEmpty - } +(∅) = 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 @@ -222,15 +283,16 @@ uncons bs -- | /O(1)/ Test whether a 'BitString' is empty. null ∷ BitString → Bool null bs - = remLen (leftRem bs) ≡ 0 + = remNull (leftRem bs) ∧ L.null (leftBytes bs) ∧ L.null (rightBytes bs) ∧ - remLen (rightRem bs) ≡ 0 + remNull (rightRem bs) --- | /O(n)/ Return the number of bits in a 'BitString'. +-- | /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) @@ -252,16 +314,18 @@ fromByteString bs = BitString { , rightRem = remEmpty } --- | /O(n)/ Convert a 'BitString' 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 --- 'BitString' isn't multiple of 8. +-- | /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 @@ -269,3 +333,100 @@ toByteString 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"