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.ST
33 import Data.Bitstream.Generic (Bitstream)
34 import qualified Data.Bitstream.Generic as B
37 import qualified Data.Vector.Generic as GV
38 import qualified Data.Vector.Generic.Mutable as MV
39 import Data.Vector.Generic.New (New)
40 import qualified Data.Vector.Generic.New as New
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.
62 getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
63 ⇒ Bool -- ^ Is the stream monaural?
65 → bs -- ^ WV bitstream.
66 → Int -- ^ Number of samples to get.
67 → (# WordsData, bs, v Int32 #)
68 {-# INLINEABLE getWordsLossless #-}
69 getWordsLossless isMono w0 bs0 nSamples0
70 = let v0 = New.create $ MV.new nSamples
73 v2 = GV.new $ New.take n1 v1
82 go0 ∷ WordsData → bs → Int → New v Int32
83 → (# WordsData, bs, Int, New v Int32 #)
87 | edMedian0 (fst $ wdEntropyData w) < 2 ∧
88 wdHoldingZero w ≡ False ∧
90 edMedian1 (fst $ wdEntropyData w) < 2
91 = if wdZeroesAcc w > 0 then
92 let w' = w { wdZeroesAcc = wdZeroesAcc w - 1 }
94 if wdZeroesAcc w' > 0 then
95 let (# n', v' #) = appendWord 0 n v
101 let cBits = min 33 $ B.length (B.takeWhile id bs)
102 bs' = B.drop cBits bs
107 let (# w', bs'' #) = go0' cBits w bs'
109 if wdZeroesAcc w' > 0 then
112 ( clearMedian $ fst $ wdEntropyData w'
113 , clearMedian $ snd $ wdEntropyData w' )
124 go0' ∷ Word32 → WordsData → bs → (# WordsData, bs #)
127 = let w' = w { wdZeroesAcc = cBits }
131 = let w' = w { wdZeroesAcc = 0 }
135 go0'' ∷ Word32 → Word32 → WordsData → bs → (# WordsData, bs #)
136 go0'' mask cBits w bs
138 = let w' = w { wdZeroesAcc = wdZeroesAcc w .|. mask }
142 = let cBits' = cBits - 1
143 w' = if B.head bs then
144 w { wdZeroesAcc = wdZeroesAcc w .|. mask }
147 mask' = mask `shiftL` 1
150 go0'' mask' cBits' w' bs'
152 go1 ∷ WordsData → bs → Int → New v Int32
153 → (# WordsData, bs, Int, New v Int32 #)
156 = let w' = w { wdHoldingZero = False }
161 next8 = B.toBits (B.take (8 ∷ Int) bs)
168 go2 ∷ Word32 → WordsData → bs → Int → New v Int32
169 → (# WordsData, bs, Int, New v Int32 #)
171 = let ent = getEntropy n w
173 high = getMedian0 ent - 1
174 ent' = decMedian0 ent
175 w' = setEntropy ent' n w
177 go3 low high w' bs n v
179 = let ent = getEntropy n w
181 high = low + getMedian1 ent - 1
182 ent' = (incMedian0 ∘ decMedian1) ent
183 w' = setEntropy ent' n w
185 go3 low high w' bs n v
187 = let ent = getEntropy n w
188 low = getMedian0 ent + getMedian1 ent
189 high = low + getMedian2 ent - 1
190 ent' = (incMedian0 ∘ incMedian1 ∘ decMedian2) ent
191 w' = setEntropy ent' n w
193 go3 low high w' bs n v
194 go2 onesCount w bs n v
195 = let ent = getEntropy n w
196 low = getMedian0 ent + getMedian1 ent + (onesCount-2) ⋅ getMedian2 ent
197 high = low + getMedian2 ent - 1
198 ent' = (incMedian0 ∘ incMedian1 ∘ incMedian2) ent
199 w' = setEntropy ent' n w
201 go3 low high w' bs n v
203 go3 ∷ Word32 → Word32 → WordsData → bs → Int → New v Int32
204 → (# WordsData, bs, Int, New v Int32 #)
205 go3 low high w bs n v
206 = let (# code, bs' #)
207 = readCode bs (high - low)
209 word = if B.head bs' then
210 fromIntegral $ complement low'
215 = appendWord word n v
219 appendWord ∷ Int32 → Int → New v Int32 → (# Int, New v Int32 #)
221 = let v' = New.modify (\mv → MV.unsafeWrite mv n word) v
226 getEntropy ∷ Int → WordsData → EntropyData
228 | isMono = fst $ wdEntropyData w
229 | n `testBit` 0 = fst $ wdEntropyData w
230 | otherwise = snd $ wdEntropyData w
232 setEntropy ∷ EntropyData → Int → WordsData → WordsData
234 | isMono = w { wdEntropyData = (e, snd $ wdEntropyData w) }
235 | n `testBit` 0 = w { wdEntropyData = (e, snd $ wdEntropyData w) }
236 | otherwise = w { wdEntropyData = (fst $ wdEntropyData w, e) }
239 -- | Read a single unsigned value from the specified bitstream with a
240 -- value from 0 to maxCode. If there are exactly a power of two number
241 -- of possible codes then this will read a fixed number of bits;
242 -- otherwise it reads the minimum number of bits and then determines
243 -- whether another bit is needed to define the code.
244 readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32
245 {-# INLINEABLE readCode #-}
246 readCode bs 0 = return 0
247 readCode bs 1 = fmap b2n $ takeHead bs
249 = do let bitCount = countBits maxCode
250 extras = bit bitCount - maxCode - 1
251 code ← takeBits bs (bitCount - 1)
252 if code ≥ extras then
253 do nextBit ← takeHead bs
254 return $ (code `shiftL` 1) - extras + b2n nextBit
258 takeHead ∷ Bitstream bs ⇒ STRef s bs → ST s Bool
259 {-# INLINEABLE takeHead #-}
261 = do bs ← readSTRef bsr
262 writeSTRef bsr (B.tail bs)
265 takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ STRef s bs → n → ST s a
266 {-# INLINEABLE takeBits #-}
268 = do bs ← readSTRef bsr
269 writeSTRef bsr (B.drop n bs)
270 return (B.toBits (B.take n bs))