Codec/Audio/WavPack/Block.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 -- | WavPack blocks
   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 $ bfHybridBalance bf
 145                       putBit $ bfHybridBitrate bf
 146                       putBit $ bfExtendedInt   bf
 147                       putBit $ bfFloatData     bf
 148                       putBit $ bfHybridShape   bf
 149                       putBit $ bfCrossDecorr   bf
 150                       putBit $ bfJointStereo   bf
 151                       putBit $ bfHybrid        bf
 152                       putBit $ bfMono          bf
 153                       putNBits 2 $ bfBytesPerSample bf - 1
 154           in
 155             putLazyByteString (L.reverse bs)
 156
 157     get = do bs ← getBytes 4
 158              let Right bf
 159                      = runBitGet (S.reverse bs) $
 160                        do BG.skip 1 -- reserved
 161                           falseStereo    ← getBit
 162                           iirShaping     ← getBit
 163                           BG.skip 2 -- reserved
 164                           samplingRate   ← getAsWord8 4
 165                           maxMagnitude   ← getAsWord8 5
 166                           leftShift      ← getAsWord8 5
 167                           finalBlock     ← getBit
 168                           initialBlock   ← getBit
 169                           hybridBalance  ← getBit
 170                           hybridBitrate  ← getBit
 171                           extendedInt    ← getBit
 172                           floatData      ← getBit
 173                           hybridShape    ← getBit
 174                           crossDecorr    ← getBit
 175                           jointStereo    ← getBit
 176                           hybrid         ← getBit
 177                           mono           ← getBit
 178                           bytesPerSample ← getAsWord8 2
 179                           return BlockFlags {
 180                                        bfBytesPerSample = bytesPerSample + 1
 181                                      , bfMono           = mono
 182                                      , bfHybrid         = hybrid
 183                                      , bfJointStereo    = jointStereo
 184                                      , bfCrossDecorr    = crossDecorr
 185                                      , bfHybridShape    = hybridShape
 186                                      , bfFloatData      = floatData
 187                                      , bfExtendedInt    = extendedInt
 188                                      , bfHybridBitrate  = hybridBitrate
 189                                      , bfHybridBalance  = hybridBalance
 190                                      , bfInitialBlock   = initialBlock
 191                                      , bfFinalBlock     = finalBlock
 192                                      , bfLeftShift      = leftShift
 193                                      , bfMaxMagnitude   = maxMagnitude
 194                                      , bfSamplingRate   = decodeSamplingRate samplingRate
 195                                      , bfIIRShaping     = iirShaping
 196                                      , bfFalseStereo    = falseStereo
 197                                      }
 198              return bf
 199
 200 encodeSamplingRate ∷ Maybe Int → Word8
 201 encodeSamplingRate (Just   6000) = 0x00
 202 encodeSamplingRate (Just   8000) = 0x01
 203 encodeSamplingRate (Just   9600) = 0x02
 204 encodeSamplingRate (Just  11025) = 0x03
 205 encodeSamplingRate (Just  12000) = 0x04
 206 encodeSamplingRate (Just  16000) = 0x05
 207 encodeSamplingRate (Just  22050) = 0x06
 208 encodeSamplingRate (Just  24000) = 0x07
 209 encodeSamplingRate (Just  32000) = 0x08
 210 encodeSamplingRate (Just  44100) = 0x09
 211 encodeSamplingRate (Just  48000) = 0x0A
 212 encodeSamplingRate (Just  64000) = 0x0B
 213 encodeSamplingRate (Just  88200) = 0x0C
 214 encodeSamplingRate (Just  96000) = 0x0D
 215 encodeSamplingRate (Just 192000) = 0x0E
 216 encodeSamplingRate             _ = 0x0F
 217
 218 decodeSamplingRate ∷ Word8 → Maybe Int
 219 decodeSamplingRate 0x00 = Just   6000
 220 decodeSamplingRate 0x01 = Just   8000
 221 decodeSamplingRate 0x02 = Just   9600
 222 decodeSamplingRate 0x03 = Just  11025
 223 decodeSamplingRate 0x04 = Just  12000
 224 decodeSamplingRate 0x05 = Just  16000
 225 decodeSamplingRate 0x06 = Just  22025
 226 decodeSamplingRate 0x07 = Just  24000
 227 decodeSamplingRate 0x08 = Just  32000
 228 decodeSamplingRate 0x09 = Just  44100
 229 decodeSamplingRate 0x0A = Just  48000
 230 decodeSamplingRate 0x0B = Just  64000
 231 decodeSamplingRate 0x0C = Just  88200
 232 decodeSamplingRate 0x0D = Just  96000
 233 decodeSamplingRate 0x0E = Just 192000
 234 decodeSamplingRate    _ =     Nothing
 235
 236 -- | Find a WavPack header in a given stream. Returns 'Nothing' if no
 237 -- headers are found.
 238 findNextHeader ∷ L.ByteString -- ^ the input
 239                → Maybe (BlockHeader, L.ByteString) -- ^ a header and the rest of input
 240 findNextHeader src
 241     = case L.uncons src of
 242         Nothing
 243             → Nothing
 244         Just (119, src') -- 'w'
 245             → let (header, rest) = L.splitAt 32 src
 246                in
 247                  case L.length header ≡ 32 of
 248                    False
 249                        → Nothing
 250                    True
 251                        → let Just (magicW, header'  ) = L.uncons header
 252                              Just (magicV, header'' ) = L.uncons header'
 253                              Just (magicP, header''') = L.uncons header''
 254                              magicK = L.head header'''
 255                          in
 256                            if magicW ≡ 119 ∧ magicV ≡ 118 ∧ magicP ≡ 112 ∧ magicK ≡ 107 then
 257                                -- Found the magic 'wvpk'.
 258                                let bh = runGet get header
 259                                in
 260                                  Just (bh, rest)
 261                            else
 262                                findNextHeader src'
 263         Just (_, src')
 264             → findNextHeader src'