7 {-| This module provides entropy word encoding and decoding functions
8 using a variation on the Rice method. This was introduced in wavpack
9 3.93 because it allows splitting the data into a \"lossy\" stream and
10 a \"correction\" stream in a very efficient manner and is therefore
11 ideal for the "hybrid" mode. For 4.0, the efficiency of this method
12 was significantly improved by moving away from the normal Rice
13 restriction of using powers of two for the modulus divisions and now
14 the method can be used for both hybrid and pure lossless encoding.
16 Samples are divided by median probabilities at 5\/7 (71.43%), 10\/49
17 (20.41%), and 20\/343 (5.83%). Each zone has 3.5 times fewer samples
18 than the previous. Using standard Rice coding on this data would
19 result in 1.4 bits per sample average (not counting sign
20 bit). However, there is a very simple encoding that is over 99%
21 efficient with this data and results in about 1.22 bits per sample. -}
22 module Codec.Audio.WavPack.Words
28 import Codec.Audio.WavPack.Entropy
29 import Codec.Audio.WavPack.Internal
30 import Control.Monad.Cont
31 import Control.Monad.ST
32 import Control.Monad.Trans
33 import Control.Monad.Unicode
35 import Data.Bitstream.Generic (Bitstream)
36 import qualified Data.Bitstream.Generic as B
39 import qualified Data.Vector.Generic.Mutable as MV
41 import Prelude hiding (break)
42 import Prelude.Unicode
47 wdBitrateDelta ∷ !(STRef s (Word32, Word32))
48 , wdBitrateAcc ∷ !(STRef s (Word32, Word32))
49 , wdPendingData ∷ !(STRef s Word32)
50 , wdHoldingOne ∷ !(STRef s Word32)
51 , wdZeroesAcc ∷ !(STRef s Word32)
52 , wdHoldingZero ∷ !(STRef s Bool)
53 , wdPendingCount ∷ !(STRef s Int)
54 , wdEntropyData ∷ !(EntropyData s, EntropyData s)
57 -- | This is an optimized version of 'getWord' that is used for
58 -- lossless only ('edErrorLimit' ≡ 0). Also, rather than obtaining a
59 -- single sample, it can be used to obtain an entire buffer of either
60 -- mono or stereo samples.
61 getWordsLossless ∷ ∀bs v s. (Bitstream bs, MV.MVector v Int32)
62 ⇒ Bool -- ^ Is the stream monaural?
64 → STRef s bs -- ^ WV bitstream
65 → Int -- ^ Number of samples to get
67 {-# INLINEABLE getWordsLossless #-}
68 getWordsLossless isMono w bs nSamples0
69 = do v ← MV.new nSamples
70 n ← runContT (for 0 (< nSamples) (+ 1) (loop v)) return
83 loop v n break continue
84 = do let c | isMono = fst $ wdEntropyData w
85 | n `testBit` 0 = fst $ wdEntropyData w
86 | otherwise = snd $ wdEntropyData w
87 med00 ← lift $ readSTRef (edMedian0 $ fst $ wdEntropyData w)
88 hldZero ← lift $ readSTRef (wdHoldingZero w)
89 hldOne ← lift $ readSTRef (wdHoldingOne w)
90 med10 ← lift $ readSTRef (edMedian0 $ snd $ wdEntropyData w)
91 when (med00 < 2 ∧ hldZero ≡ False ∧ hldOne ≡ 0 ∧ med10 < 2) $
92 do zAcc ← lift $ readSTRef (wdZeroesAcc w)
94 do lift $ modifySTRef (wdZeroesAcc w) ((-) 1)
96 do lift $ MV.unsafeWrite v n 0
103 getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
104 ⇒ Bool -- ^ Is the stream monaural?
106 → bs -- ^ WV bitstream.
107 → Int -- ^ Number of samples to get.
108 → (# WordsData, bs, v Int32 #)
109 {-# INLINEABLE getWordsLossless #-}
110 getWordsLossless isMono w0 bs0 nSamples0
111 = let v0 = New.create $ MV.new nSamples
112 (# w1, bs1, n1, v1 #)
114 v2 = GV.new $ New.take n1 v1
118 go0 ∷ WordsData → bs → Int → New v Int32
119 → (# WordsData, bs, Int, New v Int32 #)
123 | edMedian0 (fst $ wdEntropyData w) < 2 ∧
124 wdHoldingZero w ≡ False ∧
126 edMedian1 (fst $ wdEntropyData w) < 2
127 = if wdZeroesAcc w > 0 then
128 let w' = w { wdZeroesAcc = wdZeroesAcc w - 1 }
130 if wdZeroesAcc w' > 0 then
131 let (# n', v' #) = appendWord 0 n v
137 let cBits = min 33 $ B.length (B.takeWhile id bs)
138 bs' = B.drop cBits bs
143 let (# w', bs'' #) = go0' cBits w bs'
145 if wdZeroesAcc w' > 0 then
148 ( clearMedian $ fst $ wdEntropyData w'
149 , clearMedian $ snd $ wdEntropyData w' )
160 go0' ∷ Word32 → WordsData → bs → (# WordsData, bs #)
163 = let w' = w { wdZeroesAcc = cBits }
167 = let w' = w { wdZeroesAcc = 0 }
171 go0'' ∷ Word32 → Word32 → WordsData → bs → (# WordsData, bs #)
172 go0'' mask cBits w bs
174 = let w' = w { wdZeroesAcc = wdZeroesAcc w .|. mask }
178 = let cBits' = cBits - 1
179 w' = if B.head bs then
180 w { wdZeroesAcc = wdZeroesAcc w .|. mask }
183 mask' = mask `shiftL` 1
186 go0'' mask' cBits' w' bs'
188 go1 ∷ WordsData → bs → Int → New v Int32
189 → (# WordsData, bs, Int, New v Int32 #)
192 = let w' = w { wdHoldingZero = False }
197 next8 = B.toBits (B.take (8 ∷ Int) bs)
204 go2 ∷ Word32 → WordsData → bs → Int → New v Int32
205 → (# WordsData, bs, Int, New v Int32 #)
207 = let ent = getEntropy n w
209 high = getMedian0 ent - 1
210 ent' = decMedian0 ent
211 w' = setEntropy ent' n w
213 go3 low high w' bs n v
215 = let ent = getEntropy n w
217 high = low + getMedian1 ent - 1
218 ent' = (incMedian0 ∘ decMedian1) ent
219 w' = setEntropy ent' n w
221 go3 low high w' bs n v
223 = let ent = getEntropy n w
224 low = getMedian0 ent + getMedian1 ent
225 high = low + getMedian2 ent - 1
226 ent' = (incMedian0 ∘ incMedian1 ∘ decMedian2) ent
227 w' = setEntropy ent' n w
229 go3 low high w' bs n v
230 go2 onesCount w bs n v
231 = let ent = getEntropy n w
232 low = getMedian0 ent + getMedian1 ent + (onesCount-2) ⋅ getMedian2 ent
233 high = low + getMedian2 ent - 1
234 ent' = (incMedian0 ∘ incMedian1 ∘ incMedian2) ent
235 w' = setEntropy ent' n w
237 go3 low high w' bs n v
239 go3 ∷ Word32 → Word32 → WordsData → bs → Int → New v Int32
240 → (# WordsData, bs, Int, New v Int32 #)
241 go3 low high w bs n v
242 = let (# code, bs' #)
243 = readCode bs (high - low)
245 word = if B.head bs' then
246 fromIntegral $ complement low'
251 = appendWord word n v
255 appendWord ∷ Int32 → Int → New v Int32 → (# Int, New v Int32 #)
257 = let v' = New.modify (\mv → MV.unsafeWrite mv n word) v
262 getEntropy ∷ Int → WordsData → EntropyData
264 | isMono = fst $ wdEntropyData w
265 | n `testBit` 0 = fst $ wdEntropyData w
266 | otherwise = snd $ wdEntropyData w
268 setEntropy ∷ EntropyData → Int → WordsData → WordsData
270 | isMono = w { wdEntropyData = (e, snd $ wdEntropyData w) }
271 | n `testBit` 0 = w { wdEntropyData = (e, snd $ wdEntropyData w) }
272 | otherwise = w { wdEntropyData = (fst $ wdEntropyData w, e) }
275 -- | Read a single unsigned value from the specified bitstream with a
276 -- value from 0 to maxCode. If there are exactly a power of two number
277 -- of possible codes then this will read a fixed number of bits;
278 -- otherwise it reads the minimum number of bits and then determines
279 -- whether another bit is needed to define the code.
280 readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32
281 {-# INLINEABLE readCode #-}
282 readCode bs 0 = return 0
283 readCode bs 1 = fmap b2n $ takeHead bs
285 = do let bitCount = countBits maxCode
286 extras = bit bitCount - maxCode - 1
287 code ← takeBits bs (bitCount - 1)
288 if code ≥ extras then
289 do nextBit ← takeHead bs
290 return $ (code `shiftL` 1) - extras + b2n nextBit
294 takeHead ∷ Bitstream bs ⇒ STRef s bs → ST s Bool
295 {-# INLINEABLE takeHead #-}
297 = do bs ← readSTRef bsr
298 writeSTRef bsr (B.tail bs)
301 takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ STRef s bs → n → ST s a
302 {-# INLINEABLE takeBits #-}
304 = do bs ← readSTRef bsr
305 writeSTRef bsr (B.drop n bs)
306 return (B.toBits (B.take n bs))
308 -- | C style /for/ loop with /break/ and /continue/.
309 for ∷ ∀m α. MonadCont m
310 ⇒ α -- ^ Initial state
311 → (α → Bool) -- ^ Continue-the-loop predicate
312 → (α → α) -- ^ State modifier
313 → (α → m () → m () → m ()) -- ^ Loop body taking breaker and
315 → m α -- ^ Final state
316 for α0 contLoop next body
317 = callCC $ \break → loop break α0
319 loop ∷ (α → m ()) → α → m α
322 = do callCC $ \continue → body α (break α) (continue ())