{-# LANGUAGE BangPatterns , DoAndIfThenElse , FlexibleContexts , ScopedTypeVariables , UnicodeSyntax #-} {-| 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 Data.STRef import qualified Data.Vector.Generic.Mutable as MV import qualified Data.Vector.Unboxed as UV import Data.Word import Prelude hiding (break) import Prelude.Unicode -- | FIXME data WordsData s = WordsData { 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) } -- | 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 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 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 = fromIntegral $ if isMono then nSamples0 else nSamples0 ⋅ 2 -- 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 ⇒ STRef s bs → Word32 → ST s Word32 {-# INLINEABLE readCode #-} readCode _ 0 = return 0 readCode bs 1 = fmap b2n $ takeHead bs readCode bs maxCode = 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 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 α