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 (0x1111 = unknown/custom) (THINKME)
 124       , bfSamplingRate   ∷ !Word8
 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 $ 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   = samplingRate
 196                                      , bfIIRShaping     = iirShaping
 197                                      , bfFalseStereo    = falseStereo
 198                                      }
 199              return bf
 200
 201 findNextHeader ∷ L.ByteString → (Maybe BlockHeader, L.ByteString)
 202 findNextHeader src
 203     = case L.uncons src of
 204         Nothing
 205             → (Nothing, L.empty)
 206
 207         Just (119, src') -- 'w'
 208             → let (header, rest) = L.splitAt 32 src
 209                in
 210                  case L.length header ≡ 32 of
 211                    False
 212                        → (Nothing, L.empty)
 213
 214                    True
 215                        → let Just (magicW, header'  ) = L.uncons header
 216                              Just (magicV, header'' ) = L.uncons header'
 217                              Just (magicP, header''') = L.uncons header''
 218                              magicK = L.head header'''
 219                          in
 220                            if magicW ≡ 119 ∧ magicV ≡ 118 ∧ magicP ≡ 112 ∧ magicK ≡ 107 then
 221                                -- Found the magic 'wvpk'.
 222                                let bh = runGet get header
 223                                in
 224                                  (Just bh, rest)
 225                            else
 226                                findNextHeader src'
 227
 228         Just (_, src')
 229             → findNextHeader src'