still working on getWordsLossless

diff --git a/Codec/Audio/WavPack/Entropy.hs b/Codec/Audio/WavPack/Entropy.hs
index e7468017de69f6662b3932ce9b6ad7c1a36e566a..fc9b96d1709da9056a69172f8a4e8a56b887a146 100644 (file)
--- 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 4b81f840a21fc8fdf415c0ffce1c87a3620c7e7e..058980dcbc0e7549b4d7f63a52c14653b917c4dd 100644 (file)
--- 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