+-- | Maximum consecutive 1s sent for /div/ data.
+limitOnes ∷ Num n ⇒ n
+{-# INLINE limitOnes #-}
+limitOnes = 16
+
+getOnesCount ∷ Num a ⇒ Word8 → a
+{-# INLINE getOnesCount #-}
+getOnesCount = fromIntegral ∘ UV.unsafeIndex oct ∘ fromIntegral
+ where
+ oct ∷ UV.Vector Word8
+ {-# NOINLINE oct #-}
+ oct = UV.fromList
+ [ 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 0 - 15
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 16 - 31
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 32 - 47
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6 -- 48 - 63
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 64 - 79
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 80 - 95
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 96 - 111
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7 -- 112 - 127
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 128 - 143
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 144 - 159
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 160 - 175
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6 -- 176 - 191
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 192 - 207
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5 -- 208 - 223
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4 -- 124 - 239
+ , 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8 -- 240 - 255
+ ]
+
+-- | 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
+ do cBits ← lift $ takeWhileLessThan id 33 bs
+
+ when (cBits ≡ 33) $
+ break
+
+ if cBits < 2 then
+ lift $ writeSTRef (wdZeroesAcc w) cBits
+ else
+ do lift $ writeSTRef (wdZeroesAcc w) 0
+ (mask, _)
+ ← for (1, cBits)
+ ((> 1) ∘ snd)
+ (\(m, cb) → (m `shiftL` 1, cb - 1)) $ \(mask, _) _ _ →
+ do b ← lift $ takeHead bs
+ when b $
+ lift $ modifySTRef (wdZeroesAcc w) (.|. mask)
+ lift $ modifySTRef (wdZeroesAcc w) (.|. mask)
+
+ zAcc' ← lift$ readSTRef (wdZeroesAcc w)
+ when (zAcc' > 0) $
+ do lift $ clearMedians $ fst $ wdEntropyData w
+ lift $ clearMedians $ snd $ wdEntropyData w
+ lift $ MV.unsafeWrite v n 0
+ continue
+
+ onesCount ← lift $ newSTRef (⊥)
+ if hldZero then
+ do lift $ writeSTRef onesCount 0
+ lift $ writeSTRef (wdHoldingZero w) False
+ else
+ do next8 ← lift $ readBits (8 ∷ Word8) bs
+ if next8 ≡ 0xFF then
+ do lift $ dropBits (8 ∷ Word8) bs
+ oc ← for 8 (< limitOnes + 1) (+ 1) $ \oc break' _ →
+ do h ← lift $ takeHead bs
+ unless h $
+ break'
+ lift $ writeSTRef onesCount oc
+
+ when (oc ≡ limitOnes + 1) $
+ break
+
+ when (oc ≡ limitOnes) $
+ do cBits ← for 0 (< 33) (+ 1) $ \cBits break' _ →
+ do h ← lift $ takeHead bs
+ unless h $
+ break'
+
+ when (cBits ≡ 33) $
+ break
+
+ if cBits < 2 then
+ lift $ writeSTRef onesCount cBits
+ else
+ do lift $ writeSTRef onesCount 0
+ (mask, _)
+ ← for (1, cBits)
+ ((> 1) ∘ snd)
+ (\(m, cb) → (m `shiftL` 1, cb - 1)) $ \(mask, _) _ _ →
+ do b ← lift $ takeHead bs
+ when b $
+ lift $ modifySTRef onesCount (.|. mask)
+ lift $ modifySTRef onesCount (.|. mask)
+
+ lift $ modifySTRef onesCount (+ limitOnes)
+ else
+ do let oc ∷ Word32
+ oc = getOnesCount next8
+ lift $ writeSTRef onesCount oc
+ lift $ dropBits (oc + 1) bs
+
+ if hldOne > 0 then
+ error "FIXME"
+ else
+ error "FIXME"
+
+{-
+getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
+ ⇒ Bool -- ^ Is the stream monaural?
+ → WordsData
+ → bs -- ^ WV bitstream.
+ → Int -- ^ Number of samples to get.
+ → (# WordsData, bs, v Int32 #)
+{-# INLINEABLE getWordsLossless #-}
+getWordsLossless isMono w0 bs0 nSamples0
+ = let v0 = New.create $ MV.new nSamples
+ (# w1, bs1, n1, v1 #)
+ = go0 w0 bs0 0 v0
+ v2 = GV.new $ New.take n1 v1
+ in
+ (# w1, bs1, v2 #)
+ where
+ go0 ∷ WordsData → bs → Int → New v Int32
+ → (# WordsData, bs, Int, New v Int32 #)
+ go0 w bs n v
+ | n ≥ nSamples
+ = (# w, bs, n, v #)
+ | edMedian0 (fst $ wdEntropyData w) < 2 ∧
+ wdHoldingZero w ≡ False ∧
+ wdHoldingOne w ≡ 0 ∧
+ edMedian1 (fst $ wdEntropyData w) < 2
+ = if wdZeroesAcc w > 0 then
+ let w' = w { wdZeroesAcc = wdZeroesAcc w - 1 }
+ in
+ if wdZeroesAcc w' > 0 then
+ let (# n', v' #) = appendWord 0 n v
+ in
+ go0 w' bs n' v'
+ else
+ go1 w' bs n v
+ else
+ let cBits = min 33 $ B.length (B.takeWhile id bs)
+ bs' = B.drop cBits bs
+ in
+ if cBits ≡ 33 then
+ (# w, bs', n, v #)
+ else
+ let (# w', bs'' #) = go0' cBits w bs'
+ in
+ if wdZeroesAcc w' > 0 then
+ let w'' = w' {
+ wdEntropyData =
+ ( clearMedian $ fst $ wdEntropyData w'
+ , clearMedian $ snd $ wdEntropyData w' )
+ }
+ (# n', v' #)
+ = appendWord 0 n v
+ in
+ go0 w'' bs'' n' v'
+ else
+ go1 w' bs'' n v
+ | otherwise
+ = go1 w bs n v
+
+ go0' ∷ Word32 → WordsData → bs → (# WordsData, bs #)
+ go0' cBits w bs
+ | cBits < 2
+ = let w' = w { wdZeroesAcc = cBits }
+ in
+ (# w', bs #)
+ | otherwise
+ = let w' = w { wdZeroesAcc = 0 }
+ in
+ go0'' 1 cBits w' bs
+
+ go0'' ∷ Word32 → Word32 → WordsData → bs → (# WordsData, bs #)
+ go0'' mask cBits w bs
+ | cBits ≡ 1
+ = let w' = w { wdZeroesAcc = wdZeroesAcc w .|. mask }
+ in
+ (# w', bs #)
+ | otherwise
+ = let cBits' = cBits - 1
+ w' = if B.head bs then
+ w { wdZeroesAcc = wdZeroesAcc w .|. mask }
+ else
+ w
+ mask' = mask `shiftL` 1
+ bs' = B.tail bs
+ in
+ go0'' mask' cBits' w' bs'
+
+ go1 ∷ WordsData → bs → Int → New v Int32
+ → (# WordsData, bs, Int, New v Int32 #)
+ go1 w bs n v
+ | wdHoldingZero w
+ = let w' = w { wdHoldingZero = False }
+ in
+ go2 0 w' bs n v
+ | otherwise
+ = 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 - 1
+ ent' = decMedian0 ent
+ w' = setEntropy ent' n w
+ in
+ go3 low high w' bs n v
+ go2 1 w bs n v
+ = let ent = getEntropy n w
+ low = getMedian0 ent
+ high = low + getMedian1 ent - 1
+ ent' = (incMedian0 ∘ decMedian1) ent
+ w' = setEntropy ent' n w
+ in
+ go3 low high w' bs n v
+ go2 2 w bs n v
+ = let ent = getEntropy n w
+ low = getMedian0 ent + getMedian1 ent
+ high = low + getMedian2 ent - 1
+ ent' = (incMedian0 ∘ incMedian1 ∘ decMedian2) ent
+ w' = setEntropy ent' n w
+ in
+ go3 low high w' bs n v
+ go2 onesCount w bs n v
+ = let ent = getEntropy n w
+ low = getMedian0 ent + getMedian1 ent + (onesCount-2) ⋅ getMedian2 ent
+ high = low + getMedian2 ent - 1
+ ent' = (incMedian0 ∘ incMedian1 ∘ incMedian2) ent
+ w' = setEntropy ent' n w
+ in
+ go3 low high w' bs n v
+
+ go3 ∷ Word32 → Word32 → WordsData → bs → Int → New v Int32
+ → (# WordsData, bs, Int, New v Int32 #)
+ go3 low high w bs n v
+ = let (# code, bs' #)
+ = readCode bs (high - low)
+ low' = low + code
+ word = if B.head bs' then
+ fromIntegral $ complement low'
+ else
+ fromIntegral low'
+ bs'' = B.tail bs'
+ (# 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
+ | n `testBit` 0 = fst $ wdEntropyData w
+ | otherwise = snd $ wdEntropyData w