{-# LANGUAGE
BangPatterns
+ , DoAndIfThenElse
, FlexibleContexts
, ScopedTypeVariables
, UnicodeSyntax
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
, 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
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)
| 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
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
projects / wavpack.git / blobdiff