X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=83c0897b1f4c25aa2ea5372f82b8ced574bcc9ed;hp=1321c0725808b340aea6e490ebd1817c627cc021;hb=905f72f65d6a6b2b5f068f17a901f56f793209f7;hpb=8637d2f2dc3fcd383d8304160a87a3cf1141e467 diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index 1321c07..83c0897 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns + , DoAndIfThenElse , FlexibleContexts , ScopedTypeVariables - , UnboxedTuples , UnicodeSyntax #-} {-| This module provides entropy word encoding and decoding functions @@ -28,232 +28,302 @@ module Codec.Audio.WavPack.Words where import Codec.Audio.WavPack.Entropy import Codec.Audio.WavPack.Internal +import Control.Monad.Cont +import Control.Monad.ST import Data.Bits import Data.Bitstream.Generic (Bitstream) import qualified Data.Bitstream.Generic as B import Data.Int -import qualified Data.Vector.Generic as GV +import Data.STRef import qualified Data.Vector.Generic.Mutable as MV -import Data.Vector.Generic.New (New) -import qualified Data.Vector.Generic.New as New +import qualified Data.Vector.Unboxed as UV import Data.Word +import Prelude hiding (break) import Prelude.Unicode -- | FIXME -data WordsData +data WordsData s = WordsData { - wdBitrateDelta ∷ !(Word32, Word32) - , wdBitrateAcc ∷ !(Word32, Word32) - , wdPendingData ∷ !Word32 - , wdHoldingOne ∷ !Word32 - , wdZeroesAcc ∷ !Word32 - , wdHoldingZero ∷ !Bool - , wdPendingCount ∷ !Int - , wdEntropyData ∷ !(EntropyData, EntropyData) + wdBitrateDelta ∷ !(STRef s (Word32, Word32)) + , wdBitrateAcc ∷ !(STRef s (Word32, Word32)) + , wdPendingData ∷ !(STRef s Word32) + , wdHoldingOne ∷ !(STRef s Word32) + , wdZeroesAcc ∷ !(STRef s Word32) + , wdHoldingZero ∷ !(STRef s Bool) + , wdPendingCount ∷ !(STRef s Int) + , wdEntropyData ∷ !(EntropyData s, EntropyData s) } - deriving (Eq, Show) + +-- | Maximum consecutive 1s sent for /div/ data. +limitOnes ∷ Num n ⇒ n +{-# INLINE limitOnes #-} +limitOnes = 16 + +getOnesCount ∷ Num a ⇒ Word8 → a +{-# INLINE getOnesCount #-} +getOnesCount = fromIntegral ∘ UV.unsafeIndex oct ∘ fromIntegral + where + oct ∷ UV.Vector Word8 + {-# NOINLINE oct #-} + oct = UV.fromList + [ 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 0 - 15 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 16 - 31 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 32 - 47 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6 -- 48 - 63 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 64 - 79 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 80 - 95 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 96 - 111 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7 -- 112 - 127 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 128 - 143 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 144 - 159 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 160 - 175 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6 -- 176 - 191 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 192 - 207 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 208 - 223 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 124 - 239 + , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8 -- 240 - 255 + ] -- | This is an optimized version of 'getWord' that is used for -- lossless only ('edErrorLimit' ≡ 0). Also, rather than obtaining a -- single sample, it can be used to obtain an entire buffer of either -- mono or stereo samples. -getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32) - ⇒ Bool -- ^ Is the stream monaural? - → WordsData - → bs -- ^ WV bitstream. - → Int -- ^ Number of samples to get. - → (# WordsData, bs, v Int32 #) +getWordsLossless ∷ ∀bs v s. (Bitstream bs, MV.MVector v Int32) + ⇒ Bool -- ^ Is the stream monaural? + → WordsData s + → STRef s bs -- ^ WV bitstream + → Word32 -- ^ Number of samples to get + → ST s (v s Int32) {-# INLINEABLE getWordsLossless #-} -getWordsLossless isMono w0 bs0 nSamples0 - = let v0 = New.create $ MV.new nSamples - (# w1, bs1, n1, v1 #) - = go0 w0 bs0 0 v0 - v2 = GV.new $ New.take n1 v1 - in - (# w1, bs1, v2 #) +getWordsLossless isMono w bs nSamples0 + = do v ← MV.new nSamples + n ← runContT (for 0 (< nSamples) (+ 1) (loop v)) return + return $ MV.take n v where nSamples ∷ Int - nSamples = if isMono + nSamples = fromIntegral $ + if isMono then nSamples0 else nSamples0 ⋅ 2 - go0 ∷ WordsData → bs → Int → New v Int32 - → (# WordsData, bs, Int, New v Int32 #) - go0 w bs n v - | n ≥ nSamples - = (# w, bs, n, v #) - | edMedian0 (fst $ wdEntropyData w) < 2 ∧ - wdHoldingZero w ≡ False ∧ - wdHoldingOne w ≡ 0 ∧ - edMedian1 (fst $ wdEntropyData w) < 2 - = if wdZeroesAcc w > 0 then - let w' = w { wdZeroesAcc = wdZeroesAcc w - 1 } - in - if wdZeroesAcc w' > 0 then - let (# n', v' #) = appendWord 0 n v - in - go0 w' bs n' v' - else - go1 w' bs n v - else - let cBits = min 33 $ B.length (B.takeWhile id bs) - bs' = B.drop cBits bs - in - if cBits ≡ 33 then - (# w, bs', n, v #) - else - let (# w', bs'' #) = go0' cBits w bs' - in - if wdZeroesAcc w' > 0 then - let w'' = w' { - wdEntropyData = - ( clearMedian $ fst $ wdEntropyData w' - , clearMedian $ snd $ wdEntropyData w' ) - } - (# n', v' #) - = appendWord 0 n v - in - go0 w'' bs'' n' v' - else - go1 w' bs'' n v - | otherwise - = go1 w bs n v + -- Hey, this is way tooooo long... + loop ∷ v s Int32 + → Int + → ContT Int (ST s) () + → ContT Int (ST s) () + → ContT Int (ST s) () + loop v n break continue + = do let c | isMono = fst $ wdEntropyData w + | n `testBit` 0 = fst $ wdEntropyData w + | otherwise = snd $ wdEntropyData w + med00 ← lift $ readSTRef (edMedian0 $ fst $ wdEntropyData w) + hldZero ← lift $ readSTRef (wdHoldingZero w) + hldOne ← lift $ readSTRef (wdHoldingOne w) + med10 ← lift $ readSTRef (edMedian0 $ snd $ wdEntropyData w) + when (med00 < 2 ∧ hldZero ≡ False ∧ hldOne ≡ 0 ∧ med10 < 2) $ + do zAcc ← lift $ readSTRef (wdZeroesAcc w) + if zAcc > 0 then + do lift $ modifySTRef (wdZeroesAcc w) ((-) 1) + when (zAcc > 1) $ + do lift $ MV.unsafeWrite v n 0 + continue + else + do cBits ← lift $ takeWhileLessThan id 33 bs - go0' ∷ Word32 → WordsData → bs → (# WordsData, bs #) - go0' cBits w bs - | cBits < 2 - = let w' = w { wdZeroesAcc = cBits } - in - (# w', bs #) - | otherwise - = let w' = w { wdZeroesAcc = 0 } - in - go0'' 1 cBits w' bs + when (cBits ≡ 33) $ + break - go0'' ∷ Word32 → Word32 → WordsData → bs → (# WordsData, bs #) - go0'' mask cBits w bs - | cBits ≡ 1 - = let w' = w { wdZeroesAcc = wdZeroesAcc w .|. mask } - in - (# w', bs #) - | otherwise - = let cBits' = cBits - 1 - w' = if B.head bs then - w { wdZeroesAcc = wdZeroesAcc w .|. mask } - else - w - mask' = mask `shiftL` 1 - bs' = B.tail bs - in - go0'' mask' cBits' w' bs' + if cBits < 2 then + lift $ writeSTRef (wdZeroesAcc w) cBits + else + do lift $ writeSTRef (wdZeroesAcc w) 0 + (mask, _) + ← for (1, cBits) + ((> 1) ∘ snd) + (\(m, cb) → (m `shiftL` 1, cb - 1)) $ \(mask, _) _ _ → + do b ← lift $ takeHead bs + when b $ + lift $ modifySTRef (wdZeroesAcc w) (.|. mask) + lift $ modifySTRef (wdZeroesAcc w) (.|. mask) - go1 ∷ WordsData → bs → Int → New v Int32 - → (# WordsData, bs, Int, New v Int32 #) - go1 w bs n v - | wdHoldingZero w - = let w' = w { wdHoldingZero = False } - in - go2 0 w' bs n v - | otherwise - = let next8 ∷ Word8 - next8 = B.toBits (B.take (8 ∷ Int) bs) - in - if next8 ≡ 0xFF then - error "FIXME" - else - error "FIXME" + zAcc' ← lift$ readSTRef (wdZeroesAcc w) + when (zAcc' > 0) $ + do lift $ clearMedians $ fst $ wdEntropyData w + lift $ clearMedians $ snd $ wdEntropyData w + lift $ MV.unsafeWrite v n 0 + continue - go2 ∷ Word32 → WordsData → bs → Int → New v Int32 - → (# WordsData, bs, Int, New v Int32 #) - go2 0 w bs n v - = let ent = getEntropy n w - low = 0 - high = getMedian0 ent - 1 - ent' = decMedian0 ent - w' = setEntropy ent' n w - in - go3 low high w' bs n v - go2 1 w bs n v - = let ent = getEntropy n w - low = getMedian0 ent - high = low + getMedian1 ent - 1 - ent' = (incMedian0 ∘ decMedian1) ent - w' = setEntropy ent' n w - in - go3 low high w' bs n v - go2 2 w bs n v - = let ent = getEntropy n w - low = getMedian0 ent + getMedian1 ent - high = low + getMedian2 ent - 1 - ent' = (incMedian0 ∘ incMedian1 ∘ decMedian2) ent - w' = setEntropy ent' n w - in - go3 low high w' bs n v - go2 onesCount w bs n v - = let ent = getEntropy n w - low = getMedian0 ent + getMedian1 ent + (onesCount-2) ⋅ getMedian2 ent - high = low + getMedian2 ent - 1 - ent' = (incMedian0 ∘ incMedian1 ∘ incMedian2) ent - w' = setEntropy ent' n w - in - go3 low high w' bs n v + onesCount ← lift $ newSTRef (⊥) + if hldZero then + do lift $ writeSTRef onesCount 0 + lift $ writeSTRef (wdHoldingZero w) False + else + do next8 ← lift $ readBits (8 ∷ Word8) bs + if next8 ≡ 0xFF then + do lift $ dropBits (8 ∷ Word8) bs + oc ← for 8 (< limitOnes + 1) (+ 1) $ \_ break' _ → + do h ← lift $ takeHead bs + unless h $ + break' + lift $ writeSTRef onesCount oc - go3 ∷ Word32 → Word32 → WordsData → bs → Int → New v Int32 - → (# WordsData, bs, Int, New v Int32 #) - go3 low high w bs n v - = let (# code, bs' #) - = readCode bs (high - low) - low' = low + code - word = if B.head bs' then - fromIntegral $ complement low' - else - fromIntegral low' - bs'' = B.tail bs' - (# n', v' #) - = appendWord word n v - in - go0 w bs'' n' v' + when (oc ≡ limitOnes + 1) $ + break + + when (oc ≡ limitOnes) $ + do cBits ← for 0 (< 33) (+ 1) $ \_ break' _ → + do h ← lift $ takeHead bs + unless h $ + break' - appendWord ∷ Int32 → Int → New v Int32 → (# Int, New v Int32 #) - appendWord word n v - = let v' = New.modify (\mv → MV.unsafeWrite mv n word) v - n' = n + 1 - in - (# n', v' #) + when (cBits ≡ 33) $ + break - getEntropy ∷ Int → WordsData → EntropyData - getEntropy n w - | isMono = fst $ wdEntropyData w - | n `testBit` 0 = fst $ wdEntropyData w - | otherwise = snd $ wdEntropyData w + if cBits < 2 then + lift $ writeSTRef onesCount cBits + else + do lift $ writeSTRef onesCount 0 + (mask, _) + ← for (1, cBits) + ((> 1) ∘ snd) + (\(m, cb) → (m `shiftL` 1, cb - 1)) $ \(mask, _) _ _ → + do b ← lift $ takeHead bs + when b $ + lift $ modifySTRef onesCount (.|. mask) + lift $ modifySTRef onesCount (.|. mask) - setEntropy ∷ EntropyData → Int → WordsData → WordsData - setEntropy e n w - | isMono = w { wdEntropyData = (e, snd $ wdEntropyData w) } - | n `testBit` 0 = w { wdEntropyData = (e, snd $ wdEntropyData w) } - | otherwise = w { wdEntropyData = (fst $ wdEntropyData w, e) } + lift $ modifySTRef onesCount (+ limitOnes) + else + do let oc = getOnesCount next8 + lift $ writeSTRef onesCount oc + lift $ dropBits (oc + 1) bs + + oc ← lift $ readSTRef onesCount + let hldOne' = oc .&. 1 + lift $ writeSTRef (wdHoldingOne w) hldOne' + if hldOne > 0 then + lift $ writeSTRef onesCount ((oc `shiftR` 1) + 1) + else + lift $ writeSTRef onesCount (oc `shiftR` 1) + + lift $ writeSTRef (wdHoldingZero w) + $ ((complement hldOne') .&. 1) ≢ 0 + + oc ← lift $ readSTRef onesCount + (low, high) + ← if oc ≡ 0 then + do high ← fmap ((-) 1) $ lift $ getMedian0 c + lift $ decMedian0 c + return (0, high) + else + do low ← lift $ getMedian0 c + lift $ incMedian0 c + + if oc ≡ 1 then + do high ← fmap (((-) 1) ∘ (+ low)) $ lift $ getMedian1 c + lift $ decMedian1 c + return (low, high) + else + do low' ← fmap (+ low) $ lift $ getMedian1 c + lift $ incMedian1 c + + if oc ≡ 2 then + do high ← fmap (((-) 1) ∘ (+ low')) $ lift $ getMedian2 c + lift $ decMedian2 c + return (low', high) + else + do med2 ← lift $ getMedian2 c + let low'' = low' + (oc - 2) ⋅ med2 + high = low'' + med2 - 1 + lift $ incMedian2 c + return (low'', high) + + code ← lift $ readCode bs (high - low) + b ← lift $ takeHead bs + let word = if b then + complement (low + code) + else + low + code + lift $ MV.unsafeWrite v n (fromIntegral word) -- | Read a single unsigned value from the specified bitstream with a -- value from 0 to maxCode. If there are exactly a power of two number -- of possible codes then this will read a fixed number of bits; -- otherwise it reads the minimum number of bits and then determines -- whether another bit is needed to define the code. -readCode ∷ Bitstream bs ⇒ bs → Word32 → (# Word32, bs #) +readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32 {-# INLINEABLE readCode #-} -readCode bs 0 = (# 0, bs #) -readCode bs 1 = (# b2n (B.head bs), B.tail bs #) +readCode _ 0 = return 0 +readCode bs 1 = fmap b2n $ takeHead bs readCode bs maxCode - = let !bitCount = countBits maxCode - !extras = bit bitCount - maxCode - 1 - !code = B.toBits (B.take (bitCount - 1) bs) - (# code', bitCount' #) - = if code ≥ extras then - (# (code `shiftL` 1) - - extras - + b2n (bs B.!! bitCount) - , bitCount #) + = do let bitCount = countBits maxCode + extras = bit bitCount - maxCode - 1 + code ← takeBits (bitCount - 1) bs + if code ≥ extras then + do nextBit ← takeHead bs + return $ (code `shiftL` 1) - extras + b2n nextBit + else + return code + +takeHead ∷ Bitstream bs ⇒ STRef s bs → ST s Bool +{-# INLINEABLE takeHead #-} +takeHead bsr + = do bs ← readSTRef bsr + writeSTRef bsr (B.tail bs) + return (B.head bs) + +takeWhileLessThan ∷ (Integral n, Bitstream bs) + ⇒ (Bool → Bool) + → n + → STRef s bs + → ST s n +{-# INLINEABLE takeWhileLessThan #-} +takeWhileLessThan f n bsr = go 0 + where + {-# INLINE go #-} + go i | i < n + = do b ← takeHead bsr + if f b then + go (i + 1) else - (# code, bitCount - 1 #) - !bs' = B.drop bitCount' bs - in - (# code', bs' #) + return i + | otherwise + = return i + +readBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a +{-# INLINEABLE readBits #-} +readBits n bsr + = do bs ← readSTRef bsr + return (B.toBits (B.take n bs)) + +takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a +{-# INLINEABLE takeBits #-} +takeBits n bsr + = do bs ← readSTRef bsr + writeSTRef bsr (B.drop n bs) + return (B.toBits (B.take n bs)) + +dropBits ∷ (Integral n, Bitstream bs) ⇒ n → STRef s bs → ST s () +{-# INLINEABLE dropBits #-} +dropBits n bsr + = do bs ← readSTRef bsr + writeSTRef bsr (B.drop n bs) + +-- | C style /for/ loop with /break/ and /continue/. +for ∷ ∀m α. MonadCont m + ⇒ α -- ^ Initial state + → (α → Bool) -- ^ Continue-the-loop predicate + → (α → α) -- ^ State modifier + → (α → m () → m () → m ()) -- ^ Loop body taking breaker and + -- continuer + → m α -- ^ Final state +for α0 contLoop next body + = callCC $ \break → loop break α0 + where + loop ∷ (α → m ()) → α → m α + loop break α + | contLoop α + = do callCC $ \continue → body α (break α) (continue ()) + loop break (next α) + | otherwise + = return α