8 {-| This module provides entropy word encoding and decoding functions
9 using a variation on the Rice method. This was introduced in wavpack
10 3.93 because it allows splitting the data into a \"lossy\" stream and
11 a \"correction\" stream in a very efficient manner and is therefore
12 ideal for the "hybrid" mode. For 4.0, the efficiency of this method
13 was significantly improved by moving away from the normal Rice
14 restriction of using powers of two for the modulus divisions and now
15 the method can be used for both hybrid and pure lossless encoding.
17 Samples are divided by median probabilities at 5\/7 (71.43%), 10\/49
18 (20.41%), and 20\/343 (5.83%). Each zone has 3.5 times fewer samples
19 than the previous. Using standard Rice coding on this data would
20 result in 1.4 bits per sample average (not counting sign
21 bit). However, there is a very simple encoding that is over 99%
22 efficient with this data and results in about 1.22 bits per sample. -}
23 module Codec.Audio.WavPack.Words
29 import Codec.Audio.WavPack.Entropy
30 import Codec.Audio.WavPack.Internal
31 import Control.Monad.Cont
32 import Control.Monad.ST
33 import Control.Monad.Trans
34 import Control.Monad.Unicode
36 import Data.Bitstream.Generic (Bitstream)
37 import qualified Data.Bitstream.Generic as B
40 import qualified Data.Vector.Generic.Mutable as MV
41 import qualified Data.Vector.Unboxed as UV
43 import Prelude hiding (break)
44 import Prelude.Unicode
49 wdBitrateDelta ∷ !(STRef s (Word32, Word32))
50 , wdBitrateAcc ∷ !(STRef s (Word32, Word32))
51 , wdPendingData ∷ !(STRef s Word32)
52 , wdHoldingOne ∷ !(STRef s Word32)
53 , wdZeroesAcc ∷ !(STRef s Word32)
54 , wdHoldingZero ∷ !(STRef s Bool)
55 , wdPendingCount ∷ !(STRef s Int)
56 , wdEntropyData ∷ !(EntropyData s, EntropyData s)
59 -- | Maximum consecutive 1s sent for /div/ data.
61 {-# INLINE limitOnes #-}
64 getOnesCount ∷ Num a ⇒ Word8 → a
65 {-# INLINE getOnesCount #-}
66 getOnesCount = fromIntegral ∘ UV.unsafeIndex oct ∘ fromIntegral
71 [ 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 0 - 15
72 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 16 - 31
73 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 32 - 47
74 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6 -- 48 - 63
75 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 64 - 79
76 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 80 - 95
77 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 96 - 111
78 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7 -- 112 - 127
79 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 128 - 143
80 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 144 - 159
81 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 160 - 175
82 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6 -- 176 - 191
83 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 192 - 207
84 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 208 - 223
85 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 124 - 239
86 , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8 -- 240 - 255
89 -- | This is an optimized version of 'getWord' that is used for
90 -- lossless only ('edErrorLimit' ≡ 0). Also, rather than obtaining a
91 -- single sample, it can be used to obtain an entire buffer of either
92 -- mono or stereo samples.
93 getWordsLossless ∷ ∀bs v s. (Bitstream bs, MV.MVector v Int32)
94 ⇒ Bool -- ^ Is the stream monaural?
96 → STRef s bs -- ^ WV bitstream
97 → Int -- ^ Number of samples to get
99 {-# INLINEABLE getWordsLossless #-}
100 getWordsLossless isMono w bs nSamples0
101 = do v ← MV.new nSamples
102 n ← runContT (for 0 (< nSamples) (+ 1) (loop v)) return
112 → ContT Int (ST s) ()
113 → ContT Int (ST s) ()
114 → ContT Int (ST s) ()
115 loop v n break continue
116 = do let c | isMono = fst $ wdEntropyData w
117 | n `testBit` 0 = fst $ wdEntropyData w
118 | otherwise = snd $ wdEntropyData w
119 med00 ← lift $ readSTRef (edMedian0 $ fst $ wdEntropyData w)
120 hldZero ← lift $ readSTRef (wdHoldingZero w)
121 hldOne ← lift $ readSTRef (wdHoldingOne w)
122 med10 ← lift $ readSTRef (edMedian0 $ snd $ wdEntropyData w)
123 when (med00 < 2 ∧ hldZero ≡ False ∧ hldOne ≡ 0 ∧ med10 < 2) $
124 do zAcc ← lift $ readSTRef (wdZeroesAcc w)
126 do lift $ modifySTRef (wdZeroesAcc w) ((-) 1)
128 do lift $ MV.unsafeWrite v n 0
131 do cBits ← lift $ takeWhileLessThan id 33 bs
137 lift $ writeSTRef (wdZeroesAcc w) cBits
139 do lift $ writeSTRef (wdZeroesAcc w) 0
143 (\(m, cb) → (m `shiftL` 1, cb - 1)) $ \(mask, _) _ _ →
144 do b ← lift $ takeHead bs
146 lift $ modifySTRef (wdZeroesAcc w) (.|. mask)
147 lift $ modifySTRef (wdZeroesAcc w) (.|. mask)
149 zAcc' ← lift$ readSTRef (wdZeroesAcc w)
151 do lift $ clearMedians $ fst $ wdEntropyData w
152 lift $ clearMedians $ snd $ wdEntropyData w
153 lift $ MV.unsafeWrite v n 0
156 onesCount ← lift $ newSTRef (⊥)
158 do lift $ writeSTRef onesCount 0
159 lift $ writeSTRef (wdHoldingZero w) False
161 do next8 ← lift $ readBits (8 ∷ Word8) bs
163 do lift $ dropBits (8 ∷ Word8) bs
164 oc ← for 8 (< limitOnes + 1) (+ 1) $ \oc break' _ →
165 do h ← lift $ takeHead bs
168 lift $ writeSTRef onesCount oc
170 when (oc ≡ limitOnes + 1) $
173 when (oc ≡ limitOnes) $
174 do cBits ← for 0 (< 33) (+ 1) $ \cBits break' _ →
175 do h ← lift $ takeHead bs
183 lift $ writeSTRef onesCount cBits
185 do lift $ writeSTRef onesCount 0
189 (\(m, cb) → (m `shiftL` 1, cb - 1)) $ \(mask, _) _ _ →
190 do b ← lift $ takeHead bs
192 lift $ modifySTRef onesCount (.|. mask)
193 lift $ modifySTRef onesCount (.|. mask)
195 lift $ modifySTRef onesCount (+ limitOnes)
198 oc = getOnesCount next8
199 lift $ writeSTRef onesCount oc
200 lift $ dropBits (oc + 1) bs
208 getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
209 ⇒ Bool -- ^ Is the stream monaural?
211 → bs -- ^ WV bitstream.
212 → Int -- ^ Number of samples to get.
213 → (# WordsData, bs, v Int32 #)
214 {-# INLINEABLE getWordsLossless #-}
215 getWordsLossless isMono w0 bs0 nSamples0
216 = let v0 = New.create $ MV.new nSamples
217 (# w1, bs1, n1, v1 #)
219 v2 = GV.new $ New.take n1 v1
223 go0 ∷ WordsData → bs → Int → New v Int32
224 → (# WordsData, bs, Int, New v Int32 #)
228 | edMedian0 (fst $ wdEntropyData w) < 2 ∧
229 wdHoldingZero w ≡ False ∧
231 edMedian1 (fst $ wdEntropyData w) < 2
232 = if wdZeroesAcc w > 0 then
233 let w' = w { wdZeroesAcc = wdZeroesAcc w - 1 }
235 if wdZeroesAcc w' > 0 then
236 let (# n', v' #) = appendWord 0 n v
242 let cBits = min 33 $ B.length (B.takeWhile id bs)
243 bs' = B.drop cBits bs
248 let (# w', bs'' #) = go0' cBits w bs'
250 if wdZeroesAcc w' > 0 then
253 ( clearMedian $ fst $ wdEntropyData w'
254 , clearMedian $ snd $ wdEntropyData w' )
265 go0' ∷ Word32 → WordsData → bs → (# WordsData, bs #)
268 = let w' = w { wdZeroesAcc = cBits }
272 = let w' = w { wdZeroesAcc = 0 }
276 go0'' ∷ Word32 → Word32 → WordsData → bs → (# WordsData, bs #)
277 go0'' mask cBits w bs
279 = let w' = w { wdZeroesAcc = wdZeroesAcc w .|. mask }
283 = let cBits' = cBits - 1
284 w' = if B.head bs then
285 w { wdZeroesAcc = wdZeroesAcc w .|. mask }
288 mask' = mask `shiftL` 1
291 go0'' mask' cBits' w' bs'
293 go1 ∷ WordsData → bs → Int → New v Int32
294 → (# WordsData, bs, Int, New v Int32 #)
297 = let w' = w { wdHoldingZero = False }
302 next8 = B.toBits (B.take (8 ∷ Int) bs)
309 go2 ∷ Word32 → WordsData → bs → Int → New v Int32
310 → (# WordsData, bs, Int, New v Int32 #)
312 = let ent = getEntropy n w
314 high = getMedian0 ent - 1
315 ent' = decMedian0 ent
316 w' = setEntropy ent' n w
318 go3 low high w' bs n v
320 = let ent = getEntropy n w
322 high = low + getMedian1 ent - 1
323 ent' = (incMedian0 ∘ decMedian1) ent
324 w' = setEntropy ent' n w
326 go3 low high w' bs n v
328 = let ent = getEntropy n w
329 low = getMedian0 ent + getMedian1 ent
330 high = low + getMedian2 ent - 1
331 ent' = (incMedian0 ∘ incMedian1 ∘ decMedian2) ent
332 w' = setEntropy ent' n w
334 go3 low high w' bs n v
335 go2 onesCount w bs n v
336 = let ent = getEntropy n w
337 low = getMedian0 ent + getMedian1 ent + (onesCount-2) ⋅ getMedian2 ent
338 high = low + getMedian2 ent - 1
339 ent' = (incMedian0 ∘ incMedian1 ∘ incMedian2) ent
340 w' = setEntropy ent' n w
342 go3 low high w' bs n v
344 go3 ∷ Word32 → Word32 → WordsData → bs → Int → New v Int32
345 → (# WordsData, bs, Int, New v Int32 #)
346 go3 low high w bs n v
347 = let (# code, bs' #)
348 = readCode bs (high - low)
350 word = if B.head bs' then
351 fromIntegral $ complement low'
356 = appendWord word n v
360 appendWord ∷ Int32 → Int → New v Int32 → (# Int, New v Int32 #)
362 = let v' = New.modify (\mv → MV.unsafeWrite mv n word) v
367 getEntropy ∷ Int → WordsData → EntropyData
369 | isMono = fst $ wdEntropyData w
370 | n `testBit` 0 = fst $ wdEntropyData w
371 | otherwise = snd $ wdEntropyData w
373 setEntropy ∷ EntropyData → Int → WordsData → WordsData
375 | isMono = w { wdEntropyData = (e, snd $ wdEntropyData w) }
376 | n `testBit` 0 = w { wdEntropyData = (e, snd $ wdEntropyData w) }
377 | otherwise = w { wdEntropyData = (fst $ wdEntropyData w, e) }
380 -- | Read a single unsigned value from the specified bitstream with a
381 -- value from 0 to maxCode. If there are exactly a power of two number
382 -- of possible codes then this will read a fixed number of bits;
383 -- otherwise it reads the minimum number of bits and then determines
384 -- whether another bit is needed to define the code.
385 readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32
386 {-# INLINEABLE readCode #-}
387 readCode bs 0 = return 0
388 readCode bs 1 = fmap b2n $ takeHead bs
390 = do let bitCount = countBits maxCode
391 extras = bit bitCount - maxCode - 1
392 code ← takeBits (bitCount - 1) bs
393 if code ≥ extras then
394 do nextBit ← takeHead bs
395 return $ (code `shiftL` 1) - extras + b2n nextBit
399 takeHead ∷ Bitstream bs ⇒ STRef s bs → ST s Bool
400 {-# INLINEABLE takeHead #-}
402 = do bs ← readSTRef bsr
403 writeSTRef bsr (B.tail bs)
406 takeWhileLessThan ∷ (Integral n, Bitstream bs)
411 {-# INLINEABLE takeWhileLessThan #-}
412 takeWhileLessThan f n bsr = go 0
416 = do b ← takeHead bsr
424 readBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a
425 {-# INLINEABLE readBits #-}
427 = do bs ← readSTRef bsr
428 return (B.toBits (B.take n bs))
430 takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a
431 {-# INLINEABLE takeBits #-}
433 = do bs ← readSTRef bsr
434 writeSTRef bsr (B.drop n bs)
435 return (B.toBits (B.take n bs))
437 dropBits ∷ (Integral n, Bitstream bs) ⇒ n → STRef s bs → ST s ()
438 {-# INLINEABLE dropBits #-}
440 = do bs ← readSTRef bsr
441 writeSTRef bsr (B.drop n bs)
443 -- | C style /for/ loop with /break/ and /continue/.
444 for ∷ ∀m α. MonadCont m
445 ⇒ α -- ^ Initial state
446 → (α → Bool) -- ^ Continue-the-loop predicate
447 → (α → α) -- ^ State modifier
448 → (α → m () → m () → m ()) -- ^ Loop body taking breaker and
450 → m α -- ^ Final state
451 for α0 contLoop next body
452 = callCC $ \break → loop break α0
454 loop ∷ (α → m ()) → α → m α
457 = do callCC $ \continue → body α (break α) (continue ())