Hey... getWordsLossless is done... Not tested at all...... Hope it works... or......
authorPHO <pho@cielonegro.org>
Sat, 23 Jul 2011 15:58:19 +0000 (00:58 +0900)
committerPHO <pho@cielonegro.org>
Sat, 23 Jul 2011 15:58:19 +0000 (00:58 +0900)
Codec/Audio/WavPack/Words.hs

index 058980dcbc0e7549b4d7f63a52c14653b917c4dd..4bb1191a09bf95388ac7621e15c6034300a71b5c 100644 (file)
@@ -30,8 +30,6 @@ 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
@@ -107,6 +105,7 @@ getWordsLossless isMono w bs nSamples0
                  then nSamples0
                  else nSamples0 ⋅ 2
 
+      -- Hey, this is way tooooo long...
       loop ∷ v s Int32
            → Int
            → ContT Int (ST s) ()
@@ -161,7 +160,7 @@ getWordsLossless isMono w bs nSamples0
                    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' _ →
+                             oc ← for 8 (< limitOnes + 1) (+ 1) $ \_ break' _ →
                                       do h ← lift $ takeHead bs
                                          unless h $
                                              break'
@@ -171,7 +170,7 @@ getWordsLossless isMono w bs nSamples0
                                  break
 
                              when (oc ≡ limitOnes) $
-                                 do cBits ← for 0 (< 33) (+ 1) $ \cBits break' _ →
+                                 do cBits ← for 0 (< 33) (+ 1) $ \_ break' _ →
                                                 do h ← lift $ takeHead bs
                                                    unless h $
                                                        break'
@@ -194,188 +193,57 @@ getWordsLossless isMono w bs nSamples0
 
                                     lift $ modifySTRef onesCount (+ limitOnes)
                       else
-                          do let oc ∷ Word32
-                                 oc = getOnesCount next8
+                          do let oc = getOnesCount next8
                              lift $ writeSTRef onesCount oc
                              lift $ dropBits (oc + 1) bs
 
+                      oc ← lift $ readSTRef onesCount
+                      let hldOne' = oc .&. 1
+                      lift $ writeSTRef (wdHoldingOne w) hldOne'
                       if hldOne > 0 then
-                          error "FIXME"
+                          lift $ writeSTRef onesCount ((oc `shiftR` 1) + 1)
                       else
-                          error "FIXME"
-
-{-
-getWordsLossless ∷ ∀bs v. (Bitstream bs, GV.Vector v Int32)
-                 ⇒ Bool -- ^ Is the stream monaural?
-                 → WordsData
-                 → 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 nSamples
-          (# w1, bs1, n1, v1 #)
-              = go0 w0 bs0 0 v0
-          v2  = GV.new $ New.take n1 v1
-      in
-        (# w1, bs1, v2 #)
-    where
-      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 (# n', v' #) = appendWord 0 n v
-                          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' )
-                                          }
-                                    (# n', v' #)
-                                        = appendWord 0 n v
-                                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
-              = let next8 ∷ Word8
-                    next8 = B.toBits (B.take (8 ∷ Int) bs)
-                in
-                  if next8 ≡ 0xFF then
-                      error "FIXME"
-                  else
-                      error "FIXME"
-
-      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 - 1
-                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
-                word = if B.head bs' then
-                           fromIntegral $ complement low'
-                       else
-                           fromIntegral low'
-                bs'' = B.tail bs'
-                (# n', v' #)
-                     = appendWord word n v
-            in
-              go0 w bs'' n' v'
-
-      appendWord ∷ Int32 → Int → New v Int32 → (# Int, New v Int32 #)
-      appendWord word n v
-          = let v' = New.modify (\mv → MV.unsafeWrite mv n word) v
-                n' = n + 1
-            in
-              (# 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) }
--}
+                          lift $ writeSTRef onesCount  (oc `shiftR` 1)
+
+                      lift $ writeSTRef (wdHoldingZero w)
+                           $ ((complement hldOne') .&. 1) ≢ 0
+
+               oc ← lift $ readSTRef onesCount
+               (low, high)
+                  ← if oc ≡ 0 then
+                        do high ← fmap ((-) 1) $ lift $ getMedian0 c
+                           lift $ decMedian0 c
+                           return (0, high)
+                    else
+                        do low ← lift $ getMedian0 c
+                           lift $ incMedian0 c
+
+                           if oc ≡ 1 then
+                               do high ← fmap (((-) 1) ∘ (+ low)) $ lift $ getMedian1 c
+                                  lift $ decMedian1 c
+                                  return (low, high)
+                           else
+                               do low' ← fmap (+ low) $ lift $ getMedian1 c
+                                  lift $ incMedian1 c
+
+                                  if oc ≡ 2 then
+                                      do high ← fmap (((-) 1) ∘ (+ low')) $ lift $ getMedian2 c
+                                         lift $ decMedian2 c
+                                         return (low', high)
+                                  else
+                                      do med2 ← lift $ getMedian2 c
+                                         let low'' = low' + (oc - 2) ⋅ med2
+                                             high  = low'' + med2 - 1
+                                         lift $ incMedian2 c
+                                         return (low'', high)
+
+               code ← lift $ readCode bs (high - low)
+               b    ← lift $ takeHead bs
+               let word = if b then
+                              complement (low + code)
+                          else
+                              low + code
+               lift $ MV.unsafeWrite v n (fromIntegral word)
 
 -- | 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
@@ -384,7 +252,7 @@ getWordsLossless isMono w0 bs0 nSamples0
 -- whether another bit is needed to define the code.
 readCode ∷ Bitstream bs ⇒ STRef s bs → Word32 → ST s Word32
 {-# INLINEABLE readCode #-}
-readCode bs 0       = return 0
+readCode  0       = return 0
 readCode bs 1       = fmap b2n $ takeHead bs
 readCode bs maxCode
     = do let bitCount = countBits maxCode
@@ -414,7 +282,7 @@ takeWhileLessThan f n bsr = go 0
       {-# INLINE go #-}
       go i | i < n
                = do b ← takeHead bsr
-                    if b then
+                    if b then
                         go (i + 1)
                       else
                         return i