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