X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=83c0897b1f4c25aa2ea5372f82b8ced574bcc9ed;hp=fb08b5e68875d280f93dfca55ef2b08e1be2576d;hb=905f72f65d6a6b2b5f068f17a901f56f793209f7;hpb=880fbc6589f134369f5a3cbbcfa140da32c9a71c diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index fb08b5e..83c0897 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -1,103 +1,329 @@ {-# LANGUAGE BangPatterns + , DoAndIfThenElse , FlexibleContexts , ScopedTypeVariables - , 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 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 n v. (Bitstream bs, Integral n, GV.Vector v Int32) - ⇒ Bool -- ^ Is the stream monaural? - → WordsData - → bs -- ^ WV bitstream. - → n -- ^ 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 $ fromIntegral nSamples - (# w1, bs1, n1, v1 #) - = go w0 bs0 0 v0 - v2 = GV.new $ New.take (fromIntegral 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 ∷ n - {-# INLINE nSamples #-} - nSamples = if isMono + nSamples ∷ Int + nSamples = fromIntegral $ + 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 #) - | otherwise - = error "FIXME" - where - c ∷ EntropyData - c | n `rem` 2 ≡ 0 = fst $ wdEntropyData w - | otherwise = snd $ wdEntropyData w + -- 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 + + when (cBits ≡ 33) $ + break + + 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) + + 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 + + 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 + + when (oc ≡ limitOnes + 1) $ + break + + when (oc ≡ limitOnes) $ + do cBits ← for 0 (< 33) (+ 1) $ \_ break' _ → + do h ← lift $ takeHead bs + unless h $ + break' + + when (cBits ≡ 33) $ + break + + 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) + + 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 α