{-# LANGUAGE
BangPatterns
+ , DoAndIfThenElse
, FlexibleContexts
, ScopedTypeVariables
- , UnboxedTuples
, UnicodeSyntax
#-}
{-| This module provides entropy word encoding and decoding functions
where
import Codec.Audio.WavPack.Entropy
import Codec.Audio.WavPack.Internal
+import Control.Monad.Cont
+import Control.Monad.ST
import Data.Bits
import Data.Bitstream.Generic (Bitstream)
import qualified Data.Bitstream.Generic as B
import Data.Int
-import qualified Data.Vector.Generic as GV
+import Data.STRef
import qualified Data.Vector.Generic.Mutable as MV
-import Data.Vector.Generic.New (New)
-import qualified Data.Vector.Generic.New as New
+import qualified Data.Vector.Unboxed as UV
import Data.Word
+import Prelude hiding (break)
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)
+
+-- | 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. (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 #)
+getWordsLossless ∷ ∀bs v s. (Bitstream bs, MV.MVector v Int32)
+ ⇒ Bool -- ^ Is the stream monaural?
+ → WordsData s
+ → STRef s bs -- ^ WV bitstream
+ → Word32 -- ^ Number of samples to get
+ → ST s (v s 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 #)
+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
+ nSamples = fromIntegral $
+ if isMono
then nSamples0
else nSamples0 ⋅ 2
- 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'
+ -- Hey, this is way tooooo long...
+ 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) $ \_ 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) $ \_ 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
- 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 #)
+ do let oc = getOnesCount next8
+ lift $ writeSTRef onesCount oc
+ lift $ dropBits (oc + 1) bs
+
+ oc ← lift $ readSTRef onesCount
+ let hldOne' = oc .&. 1
+ lift $ writeSTRef (wdHoldingOne w) hldOne'
+ if hldOne > 0 then
+ lift $ writeSTRef onesCount ((oc `shiftR` 1) + 1)
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
- = 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
-
- setEntropy ∷ EntropyData → Int → WordsData → WordsData
- setEntropy e n w
- | isMono = w { wdEntropyData = (e, snd $ wdEntropyData w) }
- | n `testBit` 0 = w { wdEntropyData = (e, snd $ wdEntropyData w) }
- | otherwise = w { wdEntropyData = (fst $ wdEntropyData w, e) }
+ lift $ writeSTRef onesCount (oc `shiftR` 1)
+
+ lift $ writeSTRef (wdHoldingZero w)
+ $ ((complement hldOne') .&. 1) ≢ 0
+
+ oc ← lift $ readSTRef onesCount
+ (low, high)
+ ← if oc ≡ 0 then
+ do high ← fmap ((-) 1) $ lift $ getMedian0 c
+ lift $ decMedian0 c
+ return (0, high)
+ else
+ do low ← lift $ getMedian0 c
+ lift $ incMedian0 c
+
+ if oc ≡ 1 then
+ do high ← fmap (((-) 1) ∘ (+ low)) $ lift $ getMedian1 c
+ lift $ decMedian1 c
+ return (low, high)
+ else
+ do low' ← fmap (+ low) $ lift $ getMedian1 c
+ lift $ incMedian1 c
+
+ if oc ≡ 2 then
+ do high ← fmap (((-) 1) ∘ (+ low')) $ lift $ getMedian2 c
+ lift $ decMedian2 c
+ return (low', high)
+ else
+ do med2 ← lift $ getMedian2 c
+ let low'' = low' + (oc - 2) ⋅ med2
+ high = low'' + med2 - 1
+ lift $ incMedian2 c
+ return (low'', high)
+
+ code ← lift $ readCode bs (high - low)
+ b ← lift $ takeHead bs
+ let word = if b then
+ complement (low + code)
+ else
+ low + code
+ lift $ MV.unsafeWrite v n (fromIntegral word)
-- | 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 _ 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 #)
+ = do let bitCount = countBits maxCode
+ extras = bit bitCount - maxCode - 1
+ code ← takeBits (bitCount - 1) bs
+ 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)
+
+takeWhileLessThan ∷ (Integral n, Bitstream bs)
+ ⇒ (Bool → Bool)
+ → n
+ → STRef s bs
+ → ST s n
+{-# INLINEABLE takeWhileLessThan #-}
+takeWhileLessThan f n bsr = go 0
+ where
+ {-# INLINE go #-}
+ go i | i < n
+ = do b ← takeHead bsr
+ if f b then
+ go (i + 1)
else
- (# code, bitCount - 1 #)
- !bs' = B.drop bitCount' bs
- in
- (# code', bs' #)
+ return i
+ | otherwise
+ = return i
+
+readBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a
+{-# INLINEABLE readBits #-}
+readBits n bsr
+ = do bs ← readSTRef bsr
+ return (B.toBits (B.take n bs))
+
+takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a
+{-# INLINEABLE takeBits #-}
+takeBits n bsr
+ = do bs ← readSTRef bsr
+ writeSTRef bsr (B.drop n bs)
+ return (B.toBits (B.take n bs))
+
+dropBits ∷ (Integral n, Bitstream bs) ⇒ n → STRef s bs → ST s ()
+{-# INLINEABLE dropBits #-}
+dropBits n bsr
+ = do bs ← readSTRef bsr
+ writeSTRef bsr (B.drop n bs)
+
+-- | C style /for/ loop with /break/ and /continue/.
+for ∷ ∀m α. MonadCont m
+ ⇒ α -- ^ Initial state
+ → (α → Bool) -- ^ Continue-the-loop predicate
+ → (α → α) -- ^ State modifier
+ → (α → m () → m () → m ()) -- ^ Loop body taking breaker and
+ -- continuer
+ → m α -- ^ Final state
+for α0 contLoop next body
+ = callCC $ \break → loop break α0
+ where
+ loop ∷ (α → m ()) → α → m α
+ loop break α
+ | contLoop α
+ = do callCC $ \continue → body α (break α) (continue ())
+ loop break (next α)
+ | otherwise
+ = return α
projects / wavpack.git / blobdiff