EntropyData s

[wavpack.git] / Codec / Audio / WavPack / Words.hs

diff --git a/Codec/Audio/WavPack/Words.hs b/Codec/Audio/WavPack/Words.hs
index 1321c0725808b340aea6e490ebd1817c627cc021..e4775057d8242e325d1227940af709d11dd22c94 100644 (file)
--- a/Codec/Audio/WavPack/Words.hs
+++ b/Codec/Audio/WavPack/Words.hs
@@ -23,15 +23,17 @@ 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.ST
 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)
@@ -40,23 +42,23 @@ import Data.Word
 import Prelude.Unicode
 
 -- | FIXME
-data WordsData
+data WordsData s
     = WordsData {
-        wdBitrateDelta ∷ !(Word32, Word32)
-      , wdBitrateAcc   ∷ !(Word32, Word32)
-      , wdPendingData  ∷ !Word32
-      , wdHoldingOne   ∷ !Word32
-      , wdZeroesAcc    ∷ !Word32
-      , wdHoldingZero  ∷ !Bool
-      , wdPendingCount ∷ !Int
-      , wdEntropyData  ∷ !(EntropyData, EntropyData)
+        wdBitrateDelta ∷ !(STRef s (Word32, Word32))
+      , wdBitrateAcc   ∷ !(STRef s (Word32, Word32))
+      , wdPendingData  ∷ !(STRef s Word32)
+      , wdHoldingOne   ∷ !(STRef s Word32)
+      , wdZeroesAcc    ∷ !(STRef s Word32)
+      , wdHoldingZero  ∷ !(STRef s Bool)
+      , wdPendingCount ∷ !(STRef s Int)
+      , wdEntropyData  ∷ !(EntropyData s, EntropyData s)
       }
-    deriving (Eq, Show)
 
 -- | 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
 -- mono or stereo samples.
+{-
 getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
                  ⇒ Bool -- ^ Is the stream monaural?
                  → WordsData
@@ -232,28 +234,37 @@ getWordsLossless isMono w0 bs0 nSamples0
           | 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
 -- of possible codes then this will read a fixed number of bits;
 -- otherwise it reads the minimum number of bits and then determines
 -- whether another bit is needed to define the code.
-readCode ∷ Bitstream bs ⇒ bs → Word32 → (# Word32, bs #)
+readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32
 {-# INLINEABLE readCode #-}
-readCode bs 0       = (# 0, bs #)
-readCode bs 1       = (# b2n (B.head bs), B.tail bs #)
+readCode bs 0       = return 0
+readCode bs 1       = fmap b2n $ takeHead bs
 readCode bs maxCode
-    = let !bitCount = countBits maxCode
-          !extras   = bit bitCount - maxCode - 1
-          !code     = B.toBits (B.take (bitCount - 1) bs)
-          (# code', bitCount' #)
-                    = if code ≥ extras then
-                          (# (code `shiftL` 1)
-                             - extras
-                             + b2n (bs B.!! bitCount)
-                           , bitCount #)
-                      else
-                          (# code, bitCount - 1 #)
-          !bs'      = B.drop bitCount' bs
-      in
-        (# code', bs' #)
+    = do let bitCount = countBits maxCode
+             extras   = bit bitCount - maxCode - 1
+         code ← takeBits bs (bitCount - 1)
+         if code ≥ extras then
+             do nextBit ← takeHead bs
+                return $ (code `shiftL` 1) - extras + b2n nextBit
+           else
+             return code
+
+takeHead ∷ Bitstream bs ⇒ STRef s bs → ST s Bool
+{-# INLINEABLE takeHead #-}
+takeHead bsr
+    = do bs ← readSTRef bsr
+         writeSTRef bsr (B.tail bs)
+         return (B.head bs)
+
+takeBits ∷ (Integral n, Bitstream bs, Bits a) ⇒ STRef s bs → n → ST s a
+{-# INLINEABLE takeBits #-}
+takeBits bsr n
+    = do bs ← readSTRef bsr
+         writeSTRef bsr (B.drop n bs)
+         return (B.toBits (B.take n bs))