From: PHO Date: Sat, 23 Jul 2011 15:14:26 +0000 (+0900) Subject: still working on getWordsLossless X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=commitdiff_plain;h=fdf0906148007ee7b0cfe2b0665b4601143b169e still working on getWordsLossless --- diff --git a/Codec/Audio/WavPack/Entropy.hs b/Codec/Audio/WavPack/Entropy.hs index e746801..fc9b96d 100644 --- a/Codec/Audio/WavPack/Entropy.hs +++ b/Codec/Audio/WavPack/Entropy.hs @@ -5,7 +5,7 @@ module Codec.Audio.WavPack.Entropy ( EntropyData(..) - , clearMedian + , clearMedians , getMedian0 , getMedian1 @@ -39,8 +39,8 @@ data EntropyData s , edErrorLimit ∷ !(STRef s Word32) } -clearMedian ∷ EntropyData s → ST s () -clearMedian e +clearMedians ∷ EntropyData s → ST s () +clearMedians e = writeSTRef (edMedian0 e) 0 ≫ writeSTRef (edMedian1 e) 0 ≫ writeSTRef (edMedian2 e) 0 diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs index 4b81f84..058980d 100644 --- a/Codec/Audio/WavPack/Words.hs +++ b/Codec/Audio/WavPack/Words.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , DoAndIfThenElse , FlexibleContexts , ScopedTypeVariables , UnicodeSyntax @@ -37,6 +38,7 @@ import qualified Data.Bitstream.Generic as B import Data.Int import Data.STRef import qualified Data.Vector.Generic.Mutable as MV +import qualified Data.Vector.Unboxed as UV import Data.Word import Prelude hiding (break) import Prelude.Unicode @@ -54,6 +56,36 @@ data WordsData s , wdEntropyData ∷ !(EntropyData s, EntropyData s) } +-- | 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 @@ -95,17 +127,82 @@ getWordsLossless isMono w bs nSamples0 when (zAcc > 1) $ do lift $ MV.unsafeWrite v n 0 continue - else + else do cBits ← lift $ takeWhileLessThan id 33 bs when (cBits ≡ 33) $ - break + break if cBits < 2 then lift $ writeSTRef (wdZeroesAcc w) cBits - else - error "FIXME" - error "FIXME" + 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) @@ -324,6 +421,12 @@ takeWhileLessThan f n bsr = go 0 | 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 @@ -331,6 +434,12 @@ takeBits n 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