X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=058980dcbc0e7549b4d7f63a52c14653b917c4dd;hp=6406d3e91f40b85ef29c7443c31a8d482cd64d89;hb=fdf0906148007ee7b0cfe2b0665b4601143b169e;hpb=cef5d71977963aba55fc3a3d8ab313f497fb1acf diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index 6406d3e..058980d 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 @@ -23,42 +23,187 @@ efficient with this data and results in about 1.22 bits per sample. -} module Codec.Audio.WavPack.Words ( WordsData(..) --- , getWordsLossless + , getWordsLossless ) where import Codec.Audio.WavPack.Entropy import Codec.Audio.WavPack.Internal +import Control.Monad.Cont import Control.Monad.ST +import Control.Monad.Trans +import Control.Monad.Unicode 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 as GV 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 s. (Bitstream bs, MV.MVector v Int32) + ⇒ Bool -- ^ Is the stream monaural? + → WordsData s + → STRef s bs -- ^ WV bitstream + → Int -- ^ 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 = if isMono + then nSamples0 + else nSamples0 ⋅ 2 + + 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) $ \oc 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) $ \cBits 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 ∷ Word32 + oc = getOnesCount next8 + lift $ writeSTRef onesCount oc + lift $ dropBits (oc + 1) bs + + if hldOne > 0 then + error "FIXME" + else + error "FIXME" + {- getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32) ⇒ Bool -- ^ Is the stream monaural? @@ -75,11 +220,6 @@ getWordsLossless isMono w0 bs0 nSamples0 in (# w1, bs1, v2 #) where - nSamples ∷ Int - nSamples = 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 @@ -249,7 +389,7 @@ readCode bs 1 = fmap b2n $ takeHead bs readCode bs maxCode = do let bitCount = countBits maxCode extras = bit bitCount - maxCode - 1 - code ← takeBits bs (bitCount - 1) + code ← takeBits (bitCount - 1) bs if code ≥ extras then do nextBit ← takeHead bs return $ (code `shiftL` 1) - extras + b2n nextBit @@ -263,9 +403,58 @@ takeHead bsr writeSTRef bsr (B.tail bs) return (B.head bs) -takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ STRef s bs → n → ST s a +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 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 bsr n +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 α