From acbce2241afb82b8a21964284dc97f8014e63b42 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 16 Jul 2011 03:04:26 +0900 Subject: [PATCH] Done implementing getWordsLossless but not tested --- Codec/Audio/WavPack/Entropy.hs | 67 +++++++++++- Codec/Audio/WavPack/Words.hs | 188 +++++++++++++++++++++++++++++---- 2 files changed, 231 insertions(+), 24 deletions(-) diff --git a/Codec/Audio/WavPack/Entropy.hs b/Codec/Audio/WavPack/Entropy.hs index 444fc17..f031d11 100644 --- a/Codec/Audio/WavPack/Entropy.hs +++ b/Codec/Audio/WavPack/Entropy.hs @@ -4,18 +4,83 @@ -- | FIXME module Codec.Audio.WavPack.Entropy ( EntropyData(..) + + , clearMedian + + , getMedian0 + , getMedian1 + , getMedian2 + + , incMedian0 + , decMedian0 + , incMedian1 + , decMedian1 + , incMedian2 + , decMedian2 ) where +import Data.Bits import Data.Word +import Prelude.Unicode -- | FIXME data EntropyData = EntropyData { -- | Median log2 values for a channel. - edMedian ∷ !(Word32, Word32, Word32) + edMedian0 ∷ !Word32 + , edMedian1 ∷ !Word32 + , edMedian2 ∷ !Word32 -- | FIXME , edSlowLevel ∷ !Word32 -- | FIXME , edErrorLimit ∷ !Word32 } deriving (Eq, Show) + +clearMedian ∷ EntropyData → EntropyData +{-# INLINE clearMedian #-} +clearMedian e = e { + edMedian0 = 0 + , edMedian1 = 0 + , edMedian2 = 0 + } + +-- | The time constant of the 3 median level breakpoints +div0, div1, div2 ∷ Word32 +div0 = 128 -- 5/ 7 of samples +div1 = 64 -- 10/ 49 of samples +div2 = 32 -- 20/343 of samples + +-- | Retrieve the specified median breakpoint (without frac; min = 1) +getMedian0, getMedian1, getMedian2 ∷ EntropyData → Word32 +{-# INLINE getMedian0 #-} +{-# INLINE getMedian1 #-} +{-# INLINE getMedian2 #-} +getMedian0 e = (edMedian0 e `shiftR` 4) + 1 +getMedian1 e = (edMedian1 e `shiftR` 4) + 1 +getMedian2 e = (edMedian2 e `shiftR` 4) + 1 + +-- | Update the specified median breakpoints. Note that the median is +-- incremented when the sample is higher than the median, else +-- decremented. They are designed so that the median will never drop +-- below 1 and the value is essentially stationary if there are 2 +-- increments for every 5 decrements. +incMedian0, decMedian0, incMedian1, decMedian1, incMedian2, decMedian2 ∷ EntropyData → EntropyData +incMedian0 e + = e { edMedian0 = + edMedian0 e + ((edMedian0 e + div0 ) `div` div0) ⋅ 5 } +decMedian0 e + = e { edMedian0 = + edMedian0 e - ((edMedian0 e + (div0-2)) `div` div0) ⋅ 2 } +incMedian1 e + = e { edMedian1 = + edMedian1 e + ((edMedian1 e + div1 ) `div` div1) ⋅ 5 } +decMedian1 e + = e { edMedian1 = + edMedian1 e - ((edMedian1 e + (div1-2)) `div` div1) ⋅ 2 } +incMedian2 e + = e { edMedian2 = + edMedian2 e + ((edMedian2 e + div2 ) `div` div2) ⋅ 5 } +decMedian2 e + = e { edMedian2 = + edMedian2 e - ((edMedian2 e + (div2-2)) `div` div2) ⋅ 2 } 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 -- 2.40.0