X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=a8677fe41437faefa335b69634a66cafa9420e53;hp=08887186f39ee2ea841327e4b7296bcbba3f7726;hb=acbce2241afb82b8a21964284dc97f8014e63b42;hpb=a6664b7d7116febf16a1f8ec9ce6938ae80a5283 diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index 0888718..a8677fe 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -5,9 +5,25 @@ , UnboxedTuples , UnicodeSyntax #-} --- | FIXME +{-| This module provides entropy word encoding and decoding functions +using a variation on the Rice method. This was introduced in wavpack +3.93 because it allows splitting the data into a \"lossy\" stream and +a \"correction\" stream in a very efficient manner and is therefore +ideal for the "hybrid" mode. For 4.0, the efficiency of this method +was significantly improved by moving away from the normal Rice +restriction of using powers of two for the modulus divisions and now +the method can be used for both hybrid and pure lossless encoding. + +Samples are divided by median probabilities at 5\/7 (71.43%), 10\/49 +(20.41%), and 20\/343 (5.83%). Each zone has 3.5 times fewer samples +than the previous. Using standard Rice coding on this data would +result in 1.4 bits per sample average (not counting sign +bit). However, there is a very simple encoding that is over 99% +efficient with this data and results in about 1.22 bits per sample. -} module Codec.Audio.WavPack.Words ( WordsData(..) + + , getWordsLossless ) where import Codec.Audio.WavPack.Entropy @@ -41,43 +57,169 @@ data WordsData -- 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 n v. (Bitstream bs, Integral n, GV.Vector v Int32) +getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32) ⇒ Bool -- ^ Is the stream monaural? → WordsData - → bs -- ^ WV bitstream. - → n -- ^ Number of samples to get. + → bs -- ^ WV bitstream. + → Int -- ^ Number of samples to get. → (# WordsData, bs, v Int32 #) {-# INLINEABLE getWordsLossless #-} getWordsLossless isMono w0 bs0 nSamples0 - = let v0 = New.create $ MV.new $ fromIntegral nSamples + = let v0 = New.create $ MV.new nSamples (# w1, bs1, n1, v1 #) - = go w0 bs0 0 v0 - v2 = GV.new $ New.take (fromIntegral n1) v1 + = go0 w0 bs0 0 v0 + v2 = GV.new $ New.take n1 v1 in (# w1, bs1, v2 #) where - nSamples ∷ n - {-# INLINE nSamples #-} + nSamples ∷ Int nSamples = if isMono then nSamples0 else nSamples0 ⋅ 2 - go ∷ WordsData - → bs - → n - → New v Int32 - → (# WordsData, bs, n, New v Int32 #) - {-# INLINE go #-} - go w bs n v - | n ≥ nSamples = (# w, bs, n, v #) + 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 v' = New.modify (\mv → MV.unsafeWrite mv n 0) v + n' = n + 1 + 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' ) + } + v' = New.modify (\mv → MV.unsafeWrite mv n 0) v + n' = n + 1 + in + go0 w'' bs'' n' v' + else + go1 w' bs'' n v + | otherwise + = go1 w bs n v + + 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 + + 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' + + 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 = error "FIXME" - where - entropy ∷ EntropyData - entropy - | isMono = fst $ wdEntropyData w - | n `rem` 2 ≡ 0 = fst $ wdEntropyData w - | otherwise = snd $ wdEntropyData w + + 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 + 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 + + 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 + a = if B.head bs' then + fromIntegral $ complement low' + else + fromIntegral low' + bs'' = B.tail bs' + v' = New.modify (\mv → MV.unsafeWrite mv n a) v + n' = n + 1 + in + go0 w bs'' n' v' + + getEntropy ∷ Int → WordsData → EntropyData + getEntropy n w + | isMono = fst $ wdEntropyData w + | n `testBit` 0 = fst $ wdEntropyData w + | otherwise = snd $ wdEntropyData w + + 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) } -- | 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