Codec/Audio/WavPack/Block.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 -- | Data types for WavPack codec.
   5 module Codec.Audio.WavPack.Block
   6     ( BlockHeader(..)
   7     , BlockFlags(..)
   8
   9     , findNextHeader
  10     )
  11     where
  12 import Data.Binary
  13 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
  14 import Data.Binary.Get
  15 import Data.Binary.Put
  16 import qualified Data.Binary.Strict.BitGet as BG
  17 import Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet)
  18 import qualified Data.ByteString as S
  19 import qualified Data.ByteString.Lazy as L
  20 import Prelude.Unicode
  21
  22 -- | The preamble to every block in both the .wv and .wvc files.
  23 data BlockHeader
  24     = BlockHeader {
  25       -- | size of entire block (excluding the header)
  26         bhSize         ∷ !Word32
  27       -- | 0x402 to 0x410 are currently valid for decode
  28       , bhVersion      ∷ !Word16
  29       -- | track number (0 if not used, like now)
  30       , bhTrackNo      ∷ !Word8
  31       -- | track sub-index (0 if not used, like now)
  32       , bhIndexNo      ∷ !Word8
  33       -- | total samples for entire file, but this is only valid if
  34       --   'bhBlockIndex' == 0 and a value of -1 indicates unknown
  35       --   length
  36       , bhTotalSamples ∷ !Word32
  37       -- | index of first sample in block relative to beginning of
  38       --   file (normally this would start at 0 for the first block)
  39       , bhBlockIndex   ∷ !Word32
  40       -- | number of samples in this block (0 = no audio)
  41       , bhBlockSamples ∷ !Word32
  42       -- | various flags for id and decoding
  43       , bhFlags        ∷ !BlockFlags
  44       -- | crc for actual decoded data
  45       , bhCRC          ∷ !Word32
  46       }
  47     deriving (Show, Eq)
  48
  49 instance Binary BlockHeader where
  50     put bh
  51         = do putWord8 119 -- 'w'
  52              putWord8 118 -- 'v'
  53              putWord8 112 -- 'p'
  54              putWord8 107 -- 'k'
  55              putWord32le $ bhSize         bh + 32 - 8
  56              putWord16le $ bhVersion      bh
  57              putWord8    $ bhTrackNo      bh
  58              putWord8    $ bhIndexNo      bh
  59              putWord32le $ bhTotalSamples bh
  60              putWord32le $ bhBlockIndex   bh
  61              putWord32le $ bhBlockSamples bh
  62              put         $ bhFlags        bh
  63              putWord32le $ bhCRC          bh
  64
  65     get = do skip 4 -- "wvpk"
  66              size         ← getWord32le
  67              version      ← getWord16le
  68              trackNo      ← getWord8
  69              indexNo      ← getWord8
  70              totalSamples ← getWord32le
  71              blockIndex   ← getWord32le
  72              blockSamples ← getWord32le
  73              flags        ← get
  74              crc          ← getWord32le
  75              return BlockHeader {
  76                               bhSize         = size + 8 - 32
  77                             , bhVersion      = version
  78                             , bhTrackNo      = trackNo
  79                             , bhIndexNo      = indexNo
  80                             , bhTotalSamples = totalSamples
  81                             , bhBlockIndex   = blockIndex
  82                             , bhBlockSamples = blockSamples
  83                             , bhFlags        = flags
  84                             , bhCRC          = crc
  85                             }
  86
  87 -- | Various flags for decoding blocks
  88 data BlockFlags
  89     = BlockFlags {
  90       -- | 1 <= n <= 4
  91         bfBytesPerSample ∷ !Word8
  92       -- | 'False' = stereo output; 'True' = mono output
  93       , bfMono           ∷ !Bool
  94       -- | 'False' = lossless mode; 'True' = hybrid mode
  95       , bfHybrid         ∷ !Bool
  96       -- | 'False' = true stereo; 'True' = joint stereo (mid/side)
  97       , bfJointStereo    ∷ !Bool
  98       -- | 'False' = independent channels; 'True' = cross-channel
  99       --   decorrelation
 100       , bfCrossDecorr    ∷ !Bool
 101       -- | 'False' = flat noise spectrum in hybrid; 'True' = hybrid
 102       --   noise shaping
 103       , bfHybridShape    ∷ !Bool
 104       -- | 'False' = integer data; 'True' = floating point data
 105       , bfFloatData      ∷ !Bool
 106       -- | 'True' = extended size integers (> 24-bit); 'False' =
 107       --   shifted integers
 108       , bfExtendedInt    ∷ !Bool
 109       -- | 'False' = hybrid mode parameters control noise level;
 110       --   'True' = hybrid mode parameters control bitrate
 111       , bfHybridBitrate  ∷ !Bool
 112       -- | 'True' = hybrid noise balanced between channels
 113       , bfHybridBalance  ∷ !Bool
 114       -- | 'True' = initial block in sequence (for multichannel)
 115       , bfInitialBlock   ∷ !Bool
 116       -- | 'True' = final block in sequence (for multichannel)
 117       , bfFinalBlock     ∷ !Bool
 118       -- | amount of data left-shift after decode (0-31 places)
 119       , bfLeftShift      ∷ !Word8
 120       -- | maximum magnitude of decoded data (number of bits integers
 121       --   require minus 1)
 122       , bfMaxMagnitude   ∷ !Word8
 123       -- | sampling rate ('Nothing' = unknown/custom)
 124       , bfSamplingRate   ∷ !(Maybe Int)
 125       -- | 'True' = use IIR for negative hybrid noise shaping
 126       , bfIIRShaping     ∷ !Bool
 127       -- | 'True' = false stereo (data is mono but output is stereo)
 128       , bfFalseStereo    ∷ !Bool
 129       }
 130     deriving (Show, Eq)
 131
 132 instance Binary BlockFlags where
 133     put bf
 134         = let bs = runBitPut $
 135                    do putBit False -- reserved
 136                       putBit $ bfFalseStereo bf
 137                       putBit $ bfIIRShaping  bf
 138                       putNBits 2 (0 ∷ Word8) -- reserved
 139                       putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf
 140                       putNBits 5 $ bfMaxMagnitude bf
 141                       putNBits 5 $ bfLeftShift    bf
 142                       putBit $ bfFinalBlock    bf
 143                       putBit $ bfInitialBlock  bf
 144                       putBit $ bfFinalBlock    bf
 145                       putBit $ bfHybridBalance bf
 146                       putBit $ bfHybridBitrate bf
 147                       putBit $ bfExtendedInt   bf
 148                       putBit $ bfFloatData     bf
 149                       putBit $ bfHybridShape   bf
 150                       putBit $ bfCrossDecorr   bf
 151                       putBit $ bfJointStereo   bf
 152                       putBit $ bfHybrid        bf
 153                       putBit $ bfMono          bf
 154                       putNBits 2 $ bfBytesPerSample bf - 1
 155           in
 156             putLazyByteString (L.reverse bs)
 157
 158     get = do bs ← getBytes 4
 159              let Right bf
 160                      = runBitGet (S.reverse bs) $
 161                        do BG.skip 1 -- reserved
 162                           falseStereo    ← getBit
 163                           iirShaping     ← getBit
 164                           BG.skip 2 -- reserved
 165                           samplingRate   ← getAsWord8 4
 166                           maxMagnitude   ← getAsWord8 5
 167                           leftShift      ← getAsWord8 5
 168                           finalBlock     ← getBit
 169                           initialBlock   ← getBit
 170                           hybridBalance  ← getBit
 171                           hybridBitrate  ← getBit
 172                           extendedInt    ← getBit
 173                           floatData      ← getBit
 174                           hybridShape    ← getBit
 175                           crossDecorr    ← getBit
 176                           jointStereo    ← getBit
 177                           hybrid         ← getBit
 178                           mono           ← getBit
 179                           bytesPerSample ← getAsWord8 2
 180                           return BlockFlags {
 181                                        bfBytesPerSample = bytesPerSample + 1
 182                                      , bfMono           = mono
 183                                      , bfHybrid         = hybrid
 184                                      , bfJointStereo    = jointStereo
 185                                      , bfCrossDecorr    = crossDecorr
 186                                      , bfHybridShape    = hybridShape
 187                                      , bfFloatData      = floatData
 188                                      , bfExtendedInt    = extendedInt
 189                                      , bfHybridBitrate  = hybridBitrate
 190                                      , bfHybridBalance  = hybridBalance
 191                                      , bfInitialBlock   = initialBlock
 192                                      , bfFinalBlock     = finalBlock
 193                                      , bfLeftShift      = leftShift
 194                                      , bfMaxMagnitude   = maxMagnitude
 195                                      , bfSamplingRate   = decodeSamplingRate samplingRate
 196                                      , bfIIRShaping     = iirShaping
 197                                      , bfFalseStereo    = falseStereo
 198                                      }
 199              return bf
 200
 201 encodeSamplingRate ∷ Maybe Int → Word8
 202 encodeSamplingRate (Just   6000) = 0x00
 203 encodeSamplingRate (Just   8000) = 0x01
 204 encodeSamplingRate (Just   9600) = 0x02
 205 encodeSamplingRate (Just  11025) = 0x03
 206 encodeSamplingRate (Just  12000) = 0x04
 207 encodeSamplingRate (Just  16000) = 0x05
 208 encodeSamplingRate (Just  22050) = 0x06
 209 encodeSamplingRate (Just  24000) = 0x07
 210 encodeSamplingRate (Just  32000) = 0x08
 211 encodeSamplingRate (Just  44100) = 0x09
 212 encodeSamplingRate (Just  48000) = 0x0A
 213 encodeSamplingRate (Just  64000) = 0x0B
 214 encodeSamplingRate (Just  88200) = 0x0C
 215 encodeSamplingRate (Just  96000) = 0x0D
 216 encodeSamplingRate (Just 192000) = 0x0E
 217 encodeSamplingRate             _ = 0x0F
 218
 219 decodeSamplingRate ∷ Word8 → Maybe Int
 220 decodeSamplingRate 0x00 = Just   6000
 221 decodeSamplingRate 0x01 = Just   8000
 222 decodeSamplingRate 0x02 = Just   9600
 223 decodeSamplingRate 0x03 = Just  11025
 224 decodeSamplingRate 0x04 = Just  12000
 225 decodeSamplingRate 0x05 = Just  16000
 226 decodeSamplingRate 0x06 = Just  22025
 227 decodeSamplingRate 0x07 = Just  24000
 228 decodeSamplingRate 0x08 = Just  32000
 229 decodeSamplingRate 0x09 = Just  44100
 230 decodeSamplingRate 0x0A = Just  48000
 231 decodeSamplingRate 0x0B = Just  64000
 232 decodeSamplingRate 0x0C = Just  88200
 233 decodeSamplingRate 0x0D = Just  96000
 234 decodeSamplingRate 0x0E = Just 192000
 235 decodeSamplingRate    _ =     Nothing
 236
 237 -- | Find a WavPack header in a given stream. Returns 'Nothing' if no
 238 -- headers are found.
 239 findNextHeader ∷ L.ByteString -- ^ the input
 240                → Maybe (BlockHeader, L.ByteString) -- ^ a header and the rest of input
 241 findNextHeader src
 242     = case L.uncons src of
 243         Nothing
 244             → Nothing
 245         Just (119, src') -- 'w'
 246             → let (header, rest) = L.splitAt 32 src
 247                in
 248                  case L.length header ≡ 32 of
 249                    False
 250                        → Nothing
 251                    True
 252                        → let Just (magicW, header'  ) = L.uncons header
 253                              Just (magicV, header'' ) = L.uncons header'
 254                              Just (magicP, header''') = L.uncons header''
 255                              magicK = L.head header'''
 256                          in
 257                            if magicW ≡ 119 ∧ magicV ≡ 118 ∧ magicP ≡ 112 ∧ magicK ≡ 107 then
 258                                -- Found the magic 'wvpk'.
 259                                let bh = runGet get header
 260                                in
 261                                  Just (bh, rest)
 262                            else
 263                                findNextHeader src'
 264         Just (_, src')
 265             → findNextHeader src'