fe3238163e3badbb9693f2eb5f9f6289f3dff280
[wavpack.git] / 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'