X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FWords.hs;h=4b81f840a21fc8fdf415c0ffce1c87a3620c7e7e;hp=e4775057d8242e325d1227940af709d11dd22c94;hb=281f6781b81e7b77876d4e218e347a914e3ac2a0;hpb=0b5cd80840940d7433fab49de9a9de237444ca2b

diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs
index e477505..4b81f84 100644
--- a/Codec/Audio/WavPack/Words.hs
+++ b/Codec/Audio/WavPack/Words.hs
@@ -2,7 +2,6 @@
     BangPatterns
   , FlexibleContexts
   , ScopedTypeVariables
-  , UnboxedTuples
   , UnicodeSyntax
   #-}
 {-| This module provides entropy word encoding and decoding functions
@@ -23,22 +22,23 @@ efficient with this data and results in about 1.22 bits per sample. -}
 module Codec.Audio.WavPack.Words
     ( WordsData(..)
 
---    , getWordsLossless
+    , getWordsLossless
     )
     where
 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
 import Data.Int
 import Data.STRef
-import qualified Data.Vector.Generic as GV
 import qualified Data.Vector.Generic.Mutable as MV
-import Data.Vector.Generic.New (New)
-import qualified Data.Vector.Generic.New as New
 import Data.Word
+import Prelude hiding (break)
 import Prelude.Unicode
 
 -- | FIXME
@@ -58,6 +58,55 @@ data WordsData s
 -- 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 v s. (Bitstream bs, MV.MVector v Int32)
+                 ⇒ Bool       -- ^ Is the stream monaural?
+                 → WordsData s
+                 → STRef s bs -- ^ WV bitstream
+                 → Int        -- ^ Number of samples to get
+                 → ST s (v s Int32)
+{-# INLINEABLE getWordsLossless #-}
+getWordsLossless isMono w bs nSamples0
+    = do v ← MV.new nSamples
+         n ← runContT (for 0 (< nSamples) (+ 1) (loop v)) return
+         return $ MV.take n v
+    where
+      nSamples ∷ Int
+      nSamples = if isMono
+                 then nSamples0
+                 else nSamples0 ⋅ 2
+
+      loop ∷ v s Int32
+           → Int
+           → ContT Int (ST s) ()
+           → ContT Int (ST s) ()
+           → ContT Int (ST s) ()
+      loop v n break continue
+          = do let c | isMono        = fst $ wdEntropyData w
+                     | n `testBit` 0 = fst $ wdEntropyData w
+                     | otherwise     = snd $ wdEntropyData w
+               med00   ← lift $ readSTRef (edMedian0 $ fst $ wdEntropyData w)
+               hldZero ← lift $ readSTRef (wdHoldingZero w)
+               hldOne  ← lift $ readSTRef (wdHoldingOne  w)
+               med10   ← lift $ readSTRef (edMedian0 $ snd $ wdEntropyData w)
+               when (med00 < 2 ∧ hldZero ≡ False ∧ hldOne ≡ 0 ∧ med10 < 2) $
+                    do zAcc ← lift $ readSTRef (wdZeroesAcc w)
+                       if zAcc > 0 then
+                           do lift $ modifySTRef (wdZeroesAcc w) ((-) 1)
+                              when (zAcc > 1) $
+                                   do lift $ MV.unsafeWrite v n 0
+                                      continue
+                         else
+                           do cBits ← lift $ takeWhileLessThan id 33 bs
+
+                              when (cBits ≡ 33) $
+                                   break
+
+                              if cBits < 2 then
+                                  lift $ writeSTRef (wdZeroesAcc w) cBits
+                                else
+                                  error "FIXME"
+               error "FIXME"
+
 {-
 getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
                  ⇒ Bool -- ^ Is the stream monaural?
@@ -74,11 +123,6 @@ getWordsLossless isMono w0 bs0 nSamples0
       in
         (# w1, bs1, v2 #)
     where
-      nSamples ∷ Int
-      nSamples = if isMono
-                 then nSamples0
-                 else nSamples0 ⋅ 2
-
       go0 ∷ WordsData → bs → Int → New v Int32
           → (# WordsData, bs, Int, New v Int32 #)
       go0 w bs n v
@@ -248,7 +292,7 @@ readCode bs 1       = fmap b2n $ takeHead bs
 readCode bs maxCode
     = do let bitCount = countBits maxCode
              extras   = bit bitCount - maxCode - 1
-         code ← takeBits bs (bitCount - 1)
+         code ← takeBits (bitCount - 1) bs
          if code ≥ extras then
              do nextBit ← takeHead bs
                 return $ (code `shiftL` 1) - extras + b2n nextBit
@@ -262,9 +306,46 @@ takeHead bsr
          writeSTRef bsr (B.tail bs)
          return (B.head bs)
 
-takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ STRef s bs → n → ST s a
+takeWhileLessThan ∷ (Integral n, Bitstream bs)
+                  ⇒ (Bool → Bool)
+                  → n
+                  → STRef s bs
+                  → ST s n
+{-# INLINEABLE takeWhileLessThan #-}
+takeWhileLessThan f n bsr = go 0
+    where
+      {-# INLINE go #-}
+      go i | i < n
+               = do b ← takeHead bsr
+                    if b then
+                        go (i + 1)
+                      else
+                        return i
+           | otherwise
+               = return i
+
+takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ n → STRef s bs → ST s a
 {-# INLINEABLE takeBits #-}
-takeBits bsr n
+takeBits n bsr
     = do bs ← readSTRef bsr
          writeSTRef bsr (B.drop n bs)
          return (B.toBits (B.take n bs))
+
+-- | C style /for/ loop with /break/ and /continue/.
+for ∷ ∀m α. MonadCont m
+    ⇒ α          -- ^ Initial state
+    → (α → Bool) -- ^ Continue-the-loop predicate
+    → (α → α)    -- ^ State modifier
+    → (α → m () → m () → m ()) -- ^ Loop body taking breaker and
+                               -- continuer
+    → m α        -- ^ Final state
+for α0 contLoop next body
+    = callCC $ \break → loop break α0
+    where
+      loop ∷ (α → m ()) → α → m α
+      loop break α
+          | contLoop α
+              = do callCC $ \continue → body α (break α) (continue ())
+                   loop break (next α)
+          | otherwise
+              = return α