From: PHO Date: Sat, 23 Jul 2011 15:58:19 +0000 (+0900) Subject: Hey... getWordsLossless is done... Not tested at all...... Hope it works... or...... X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=commitdiff_plain;h=0f10248deec85fcaf04b2f2c714b0655afecf00f Hey... getWordsLossless is done... Not tested at all...... Hope it works... or...... --- diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index 058980d..4bb1191 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -30,8 +30,6 @@ import Codec.Audio.WavPack.Entropy 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 @@ -107,6 +105,7 @@ getWordsLossless isMono w bs nSamples0 then nSamples0 else nSamples0 ⋅ 2 + -- Hey, this is way tooooo long... loop ∷ v s Int32 → Int → ContT Int (ST s) () @@ -161,7 +160,7 @@ getWordsLossless isMono w bs nSamples0 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' @@ -171,7 +170,7 @@ getWordsLossless isMono w bs nSamples0 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' @@ -194,188 +193,57 @@ getWordsLossless isMono w bs nSamples0 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 @@ -384,7 +252,7 @@ getWordsLossless isMono w0 bs0 nSamples0 -- 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 @@ -414,7 +282,7 @@ takeWhileLessThan f n bsr = go 0 {-# INLINE go #-} go i | i < n = do b ← takeHead bsr - if b then + if f b then go (i + 1) else return i