Done implementing getWordsLossless but not tested
authorPHO <pho@cielonegro.org>
Fri, 15 Jul 2011 18:04:26 +0000 (03:04 +0900)
committerPHO <pho@cielonegro.org>
Fri, 15 Jul 2011 18:04:26 +0000 (03:04 +0900)
Codec/Audio/WavPack/Entropy.hs
Codec/Audio/WavPack/Words.hs

index 444fc17957b5b5b7f42fc1b50e4a4203ecb15a49..f031d118d112342b25bf005b2e13234a04d0a502 100644 (file)
@@ -4,18 +4,83 @@
 -- | FIXME
 module Codec.Audio.WavPack.Entropy
     ( EntropyData(..)
+
+    , clearMedian
+
+    , getMedian0
+    , getMedian1
+    , getMedian2
+
+    , incMedian0
+    , decMedian0
+    , incMedian1
+    , decMedian1
+    , incMedian2
+    , decMedian2
     )
     where
+import Data.Bits
 import Data.Word
+import Prelude.Unicode
 
 -- | FIXME
 data EntropyData
     = EntropyData {
         -- | Median log2 values for a channel.
-        edMedian     ∷ !(Word32, Word32, Word32)
+        edMedian0    ∷ !Word32
+      , edMedian1    ∷ !Word32
+      , edMedian2    ∷ !Word32
         -- | FIXME
       , edSlowLevel  ∷ !Word32
         -- | FIXME
       , edErrorLimit ∷ !Word32
       }
     deriving (Eq, Show)
+
+clearMedian ∷ EntropyData → EntropyData
+{-# INLINE clearMedian #-}
+clearMedian e = e {
+                  edMedian0 = 0
+                , edMedian1 = 0
+                , edMedian2 = 0
+                }
+
+-- | The time constant of the 3 median level breakpoints
+div0, div1, div2 ∷ Word32
+div0 = 128 --  5/  7 of samples
+div1 =  64 -- 10/ 49 of samples
+div2 =  32 -- 20/343 of samples
+
+-- | Retrieve the specified median breakpoint (without frac; min = 1)
+getMedian0, getMedian1, getMedian2 ∷ EntropyData → Word32
+{-# INLINE getMedian0 #-}
+{-# INLINE getMedian1 #-}
+{-# INLINE getMedian2 #-}
+getMedian0 e = (edMedian0 e `shiftR` 4) + 1
+getMedian1 e = (edMedian1 e `shiftR` 4) + 1
+getMedian2 e = (edMedian2 e `shiftR` 4) + 1
+
+-- | Update the specified median breakpoints. Note that the median is
+-- incremented when the sample is higher than the median, else
+-- decremented.  They are designed so that the median will never drop
+-- below 1 and the value is essentially stationary if there are 2
+-- increments for every 5 decrements.
+incMedian0, decMedian0, incMedian1, decMedian1, incMedian2, decMedian2 ∷ EntropyData → EntropyData
+incMedian0 e
+    = e { edMedian0 =
+              edMedian0 e + ((edMedian0 e +  div0   ) `div` div0) ⋅ 5 }
+decMedian0 e
+    = e { edMedian0 =
+              edMedian0 e - ((edMedian0 e + (div0-2)) `div` div0) ⋅ 2 }
+incMedian1 e
+    = e { edMedian1 =
+              edMedian1 e + ((edMedian1 e +  div1   ) `div` div1) ⋅ 5 }
+decMedian1 e
+    = e { edMedian1 =
+              edMedian1 e - ((edMedian1 e + (div1-2)) `div` div1) ⋅ 2 }
+incMedian2 e
+    = e { edMedian2 =
+              edMedian2 e + ((edMedian2 e +  div2   ) `div` div2) ⋅ 5 }
+decMedian2 e
+    = e { edMedian2 =
+              edMedian2 e - ((edMedian2 e + (div2-2)) `div` div2) ⋅ 2 }
index 08887186f39ee2ea841327e4b7296bcbba3f7726..a8677fe41437faefa335b69634a66cafa9420e53 100644 (file)
@@ -5,9 +5,25 @@
   , UnboxedTuples
   , UnicodeSyntax
   #-}
--- | FIXME
+{-| This module provides entropy word encoding and decoding functions
+using a variation on the Rice method.  This was introduced in wavpack
+3.93 because it allows splitting the data into a \"lossy\" stream and
+a \"correction\" stream in a very efficient manner and is therefore
+ideal for the "hybrid" mode.  For 4.0, the efficiency of this method
+was significantly improved by moving away from the normal Rice
+restriction of using powers of two for the modulus divisions and now
+the method can be used for both hybrid and pure lossless encoding.
+
+Samples are divided by median probabilities at 5\/7 (71.43%), 10\/49
+(20.41%), and 20\/343 (5.83%). Each zone has 3.5 times fewer samples
+than the previous. Using standard Rice coding on this data would
+result in 1.4 bits per sample average (not counting sign
+bit). However, there is a very simple encoding that is over 99%
+efficient with this data and results in about 1.22 bits per sample. -}
 module Codec.Audio.WavPack.Words
     ( WordsData(..)
+
+    , getWordsLossless
     )
     where
 import Codec.Audio.WavPack.Entropy
@@ -41,43 +57,169 @@ data WordsData
 -- 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 n v. (Bitstream bs, Integral n, GV.Vector v Int32)
+getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
                  ⇒ Bool -- ^ Is the stream monaural?
                  → WordsData
-                 → bs -- ^ WV bitstream.
-                 → n  -- ^ Number of samples to get.
+                 → 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 $ fromIntegral nSamples
+    = let v0  = New.create $ MV.new nSamples
           (# w1, bs1, n1, v1 #)
-              = go w0 bs0 0 v0
-          v2  = GV.new $ New.take (fromIntegral n1) v1
+              = go0 w0 bs0 0 v0
+          v2  = GV.new $ New.take n1 v1
       in
         (# w1, bs1, v2 #)
     where
-      nSamples ∷ n
-      {-# INLINE nSamples #-}
+      nSamples ∷ Int
       nSamples = if isMono
                  then nSamples0
                  else nSamples0 ⋅ 2
 
-      go ∷ WordsData
-         → bs
-         → n
-         → New v Int32
-         → (# WordsData, bs, n, New v Int32 #)
-      {-# INLINE go #-}
-      go w bs n v
-          | n ≥ nSamples = (# w, bs, n, v #)
+      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 v' = New.modify (\mv → MV.unsafeWrite mv n 0) v
+                              n' = n + 1
+                          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' )
+                                          }
+                                    v'  = New.modify (\mv → MV.unsafeWrite mv n 0) v
+                                    n'  = n + 1
+                                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"
-          where
-            entropy ∷ EntropyData
-            entropy
-                | isMono        = fst $ wdEntropyData w
-                | n `rem` 2 ≡ 0 = fst $ wdEntropyData w
-                | otherwise     = snd $ wdEntropyData w
+
+      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
+                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
+                a    = if B.head bs' then
+                           fromIntegral $ complement low'
+                       else
+                           fromIntegral low'
+                bs'' = B.tail bs'
+                v'   = New.modify (\mv → MV.unsafeWrite mv n a) v
+                n'   = n + 1
+            in
+              go0 w bs'' 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) }
 
 -- | 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