import Codec.Audio.WavPack.Internal
import Control.Monad.Cont
import Control.Monad.ST
-import Control.Monad.Trans
-import Control.Monad.Unicode
import Data.Bits
import Data.Bitstream.Generic (Bitstream)
import qualified Data.Bitstream.Generic as B
then nSamples0
else nSamples0 ⋅ 2
+ -- Hey, this is way tooooo long...
loop ∷ v s Int32
→ Int
→ ContT Int (ST s) ()
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' _ →
+ oc ← for 8 (< limitOnes + 1) (+ 1) $ \_ break' _ →
do h ← lift $ takeHead bs
unless h $
break'
break
when (oc ≡ limitOnes) $
- do cBits ← for 0 (< 33) (+ 1) $ \cBits break' _ →
+ do cBits ← for 0 (< 33) (+ 1) $ \_ break' _ →
do h ← lift $ takeHead bs
unless h $
break'
lift $ modifySTRef onesCount (+ limitOnes)
else
- do let oc ∷ Word32
- oc = getOnesCount next8
+ 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
- error "FIXME"
+ lift $ writeSTRef onesCount ((oc `shiftR` 1) + 1)
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
-
- 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
-- whether another bit is needed to define the code.
readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32
{-# INLINEABLE readCode #-}
-readCode bs 0 = return 0
+readCode _ 0 = return 0
readCode bs 1 = fmap b2n $ takeHead bs
readCode bs maxCode
= do let bitCount = countBits maxCode
{-# INLINE go #-}
go i | i < n
= do b ← takeHead bsr
- if b then
+ if f b then
go (i + 1)
else
return i
projects / wavpack.git / commitdiff