X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=e4775057d8242e325d1227940af709d11dd22c94;hp=a8677fe41437faefa335b69634a66cafa9420e53;hb=0b5cd80840940d7433fab49de9a9de237444ca2b;hpb=acbce2241afb82b8a21964284dc97f8014e63b42 diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index a8677fe..e477505 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -23,15 +23,17 @@ 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.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 as GV import qualified Data.Vector.Generic.Mutable as MV import Data.Vector.Generic.New (New) @@ -40,23 +42,23 @@ import Data.Word 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. (Bitstream bs, GV.Vector v Int32) ⇒ Bool -- ^ Is the stream monaural? → WordsData @@ -90,8 +92,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 +112,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 +157,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 +206,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 +234,37 @@ 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))