X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=182c23ce4e03b8b59fee8211d57951a93c7780dc;hp=a8677fe41437faefa335b69634a66cafa9420e53;hb=e70043673023f33823bd9617c52a84c5aef4b419;hpb=acbce2241afb82b8a21964284dc97f8014e63b42 diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index a8677fe..182c23c 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -2,7 +2,6 @@ BangPatterns , FlexibleContexts , ScopedTypeVariables - , UnboxedTuples , UnicodeSyntax #-} {-| This module provides entropy word encoding and decoding functions @@ -28,35 +27,79 @@ module Codec.Audio.WavPack.Words 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 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 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) -- | 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 + error "FIXME" + error "FIXME" + +{- getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32) ⇒ Bool -- ^ Is the stream monaural? → WordsData @@ -72,11 +115,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 @@ -90,8 +128,7 @@ getWordsLossless isMono w0 bs0 nSamples0 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 + let (# n', v' #) = appendWord 0 n v in go0 w' bs n' v' else @@ -111,8 +148,8 @@ getWordsLossless isMono w0 bs0 nSamples0 ( clearMedian $ fst $ wdEntropyData w' , clearMedian $ snd $ wdEntropyData w' ) } - v' = New.modify (\mv → MV.unsafeWrite mv n 0) v - n' = n + 1 + (# n', v' #) + = appendWord 0 n v in go0 w'' bs'' n' v' else @@ -156,14 +193,20 @@ getWordsLossless isMono w0 bs0 nSamples0 in go2 0 w' bs n v | otherwise - = error "FIXME" + = let next8 ∷ Word8 + next8 = B.toBits (B.take (8 ∷ Int) bs) + in + if next8 ≡ 0xFF then + error "FIXME" + else + error "FIXME" 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 + high = getMedian0 ent - 1 ent' = decMedian0 ent w' = setEntropy ent' n w in @@ -199,16 +242,23 @@ getWordsLossless isMono w0 bs0 nSamples0 = let (# code, bs' #) = readCode bs (high - low) low' = low + code - a = if B.head bs' then + word = 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 + (# n', v' #) + = appendWord word n v in go0 w bs'' n' v' + appendWord ∷ Int32 → Int → New v Int32 → (# Int, New v Int32 #) + appendWord word n v + = let v' = New.modify (\mv → MV.unsafeWrite mv n word) v + n' = n + 1 + in + (# n', v' #) + getEntropy ∷ Int → WordsData → EntropyData getEntropy n w | isMono = fst $ wdEntropyData w @@ -220,28 +270,56 @@ getWordsLossless isMono w0 bs0 nSamples0 | 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 -- 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 bs 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 #) - else - (# code, bitCount - 1 #) - !bs' = B.drop bitCount' bs - in - (# code', bs' #) + = do let bitCount = countBits maxCode + extras = bit bitCount - maxCode - 1 + code ← takeBits bs (bitCount - 1) + 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) + +takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ STRef s bs → n → ST s a +{-# INLINEABLE takeBits #-} +takeBits bsr n + = do bs ← readSTRef bsr + writeSTRef bsr (B.drop n bs) + return (B.toBits (B.take 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 α