]> gitweb @ CieloNegro.org - wavpack.git/blob - Codec/Audio/WavPack/Metadata.hs
WVBitstream
[wavpack.git] / Codec / Audio / WavPack / Metadata.hs
1 {-# LANGUAGE
2     DeriveDataTypeable
3   , ExistentialQuantification
4   , UnicodeSyntax
5   #-}
6 -- | WavPack metadata sub-blocks
7 module Codec.Audio.WavPack.Metadata
8     ( Metadata(..)
9     , SubBlock
10
11     , Dummy(..)
12     , DecorrTerms(..)
13     , DecorrWeights(..)
14     , DecorrSamples(..)
15     , EntropyVars(..)
16     , WVBitstream(..)
17     , RIFFHeader(..)
18     , RIFFTrailer(..)
19     , ConfigInfo(..)
20     , Unknown(..)
21     )
22     where
23 import Codec.Audio.WavPack.Internal
24 import Control.Monad
25 import Data.Binary
26 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
27 import Data.Binary.Get
28 import Data.Binary.Put
29 import Data.Binary.Strict.BitGet (getBit, runBitGet)
30 import qualified Data.Binary.Strict.BitGet as BG
31 import Data.Bits
32 import qualified Data.ByteString as S
33 import qualified Data.ByteString.Lazy as L
34 import Data.Int
35 import qualified Data.Strict as S
36 import Data.Typeable
37 import qualified Data.Vector.Unboxed as UV
38 import Prelude.Unicode
39
40 -- | Type class for every metadata sub-blocks.
41 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
42     -- | Get the metadata ID without odd-size bit nor large-block bit
43     -- (mandatory).
44     metaID   ∷ α → Word8
45     -- | Get the size of metadata, excluding the metadata header
46     -- (optional).
47     metaSize ∷ α → Word32
48     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
49     -- | Cast a 'SubBlock' to this type of metadata (optional).
50     fromSubBlock ∷ SubBlock → Maybe α
51     fromSubBlock (SubBlock a) = cast a
52     -- | Wrap the metadata into 'SubBlock' (optional).
53     toSubBlock ∷ α → SubBlock
54     toSubBlock = SubBlock
55
56 -- | An opaque sub-block container.
57 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
58                 deriving Typeable
59
60 instance Metadata SubBlock where
61     metaID   (SubBlock a) = metaID a
62     metaSize (SubBlock a) = metaSize a
63     fromSubBlock = Just
64     toSubBlock   = id
65
66 instance Binary SubBlock where
67     put (SubBlock a)
68         = let size     = metaSize a
69               size'    = size + 1
70               oddBit   = if odd size     then 0x40 else 0
71               largeBit = if size > 0x1FE then 0x80 else 0
72               idWord   = metaID a .|. oddBit .|. largeBit
73           in
74             do putWord8 idWord
75                if size > 0x1FE then
76                    -- Don't forget about the endianness.
77                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
78                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
79                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
80                  else
81                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
82                put a
83                when (odd size) $ putWord8 0
84
85     get = do idWord ← getWord8
86              let isOdd   = idWord .&. 0x40 ≢ 0
87                  isLarge = idWord .&. 0x80 ≢ 0
88                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
89                  adj     = if isOdd then -1 else 0
90              size ← if isLarge then
91                          do sz0 ← getWord8
92                             sz1 ← getWord8
93                             sz2 ← getWord8
94                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
95                                        (fromIntegral sz1 `shiftL`  9) .|.
96                                        (fromIntegral sz0 `shiftL`  1)
97                                      ) + adj
98                      else
99                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
100              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
101              return $ runGet (getSubBlock rawID) subb
102         where
103           getSubBlock ∷ Word8 → Get SubBlock
104           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy        )
105           getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms  )
106           getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
107           getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
108           getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars  )
109           getSubBlock 0x0A = fmap SubBlock (get ∷ Get WVBitstream  )
110           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader   )
111           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer  )
112           getSubBlock 0x25 = fmap SubBlock (get ∷ Get ConfigInfo   )
113           getSubBlock unknownID
114               = if unknownID .&. 0x20 ≡ 0 then
115                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
116                 else
117                     -- It's unknown but optional. We can safely ignore it.
118                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
119
120 instance Eq SubBlock where
121     (SubBlock a) == (SubBlock b)
122         = Just a ≡ cast b
123
124 instance Show SubBlock where
125     show (SubBlock a) = show a
126
127 -- | Dummy metadata to pad WavPack blocks.
128 data Dummy
129     = Dummy {
130         -- | Must be less than 2^25 bytes long due to the limitation
131         -- of WavPack specification.
132         dumSize ∷ !Word32
133       }
134     deriving (Eq, Show, Typeable)
135
136 instance Metadata Dummy where
137     metaID _ = 0x00
138     metaSize = dumSize
139
140 instance Binary Dummy where
141     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
142     get = fmap (Dummy ∘ fromIntegral) remaining
143
144 -- | Decorrelation terms and deltas.
145 data DecorrTerms
146     = DecorrTerms {
147         -- | @[ (term, delta) ]@
148         dectVec ∷ !(UV.Vector (Int8, Int8))
149       }
150     deriving (Eq, Show, Typeable)
151
152 instance Metadata DecorrTerms where
153     metaID _ = 0x02
154     metaSize = fromIntegral ∘ UV.length ∘ dectVec
155
156 instance Binary DecorrTerms where
157     put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
158         where
159           packDT ∷ (Int8, Int8) → Word8
160           packDT (term, δ)
161               = fromIntegral ( (term + 5 .&. 0x1F)
162                                .|.
163                                ((δ `shiftL` 5) .&. 0xE0)
164                              )
165     get = do n   ← remaining
166              vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
167              -- THINKME: unpack.c(read_decorr_terms) reverses the
168              -- order only when they are decoding. I don't know why so
169              -- I leave it unreversed for now.
170              return $ DecorrTerms vec
171         where
172           unpackDT ∷ Word8 → (Int8, Int8)
173           unpackDT w
174               = let term = (fromIntegral $ w .&. 0x1F) - 5
175                     δ    = fromIntegral $ (w `shiftR` 5) .&. 0x07
176                 in
177                   (term, δ)
178
179 -- | Decorrelation weights.
180 data DecorrWeights
181     = DecorrWeights {
182       -- | For mono blocks, this is a weight vector for the single
183       --   channel. For stereo blocks, it's interleaved as A, B, A, B,
184       --   ...
185         decwVec ∷ !(UV.Vector Int16)
186       }
187     deriving (Eq, Show, Typeable)
188
189 instance Metadata DecorrWeights where
190     metaID _ = 0x03
191     metaSize = fromIntegral ∘ UV.length ∘ decwVec
192
193 instance Binary DecorrWeights where
194     put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
195     get = do n   ← remaining
196              vec ← UV.replicateM (fromIntegral n)
197                     $ fmap unpackWeight getWord8
198              -- THINKME: the same caution as DecorrTerms, but never
199              -- try to simply reverse the vector. Think about the
200              -- interleaving.
201              return $ DecorrWeights vec
202
203 -- | Decorrelation samples
204 data DecorrSamples
205     = DecorrSamples {
206       -- | The decorrelation sample vector stored in the metadata
207       --   as-is. Actual interpretation of the vector depends on the
208       --   number of channels and each corresponding decorrelation
209       --   terms.
210         decsVec ∷ !(UV.Vector Int32)
211       }
212     deriving (Eq, Show, Typeable)
213
214 instance Metadata DecorrSamples where
215     metaID _ = 0x04
216     metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
217
218 instance Binary DecorrSamples where
219     put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
220     get = do n   ← remaining
221              vec ← UV.replicateM (fromIntegral $ n `div` 2)
222                     $ fmap (exp2s ∘ fromIntegral) getWord16le
223              return $ DecorrSamples vec
224
225 -- | Median log2 values.
226 data EntropyVars
227     = EntropyVars {
228       -- | Median log2 values for channel A, which always exists.
229         entVarA ∷ !(Word32, Word32, Word32)
230       -- | Median log2 values for channel B, which is absent when it's
231       --   mono.
232       , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
233       }
234     deriving (Eq, Show, Typeable)
235
236 instance Metadata EntropyVars where
237     metaID _ = 0x05
238     metaSize ev
239         | S.isNothing $ entVarB ev =  6
240         | otherwise                = 12
241
242 instance Binary EntropyVars where
243     put ev
244         = do putMedians $ entVarA ev
245              case entVarB ev of
246                S.Nothing    → return ()
247                S.Just medsB → putMedians medsB
248         where
249           -- THINKME: words.c(write_entropy_vars) is a destructive
250           -- subroutine. It calls read_entropy_vars() to read the
251           -- values back to compensate for the loss through the log
252           -- function.
253           putMedians ∷ (Word32, Word32, Word32) → Put
254           putMedians (med0, med1, med2)
255               = do putWord16le $ log2 med0
256                    putWord16le $ log2 med1
257                    putWord16le $ log2 med2
258
259     get = do medsA ← getMedians
260              medsB ← do isMono ← isEmpty
261                         if isMono then
262                             return S.Nothing
263                           else
264                             fmap S.Just getMedians
265              return $! EntropyVars medsA medsB
266         where
267           getMedians ∷ Get (Word32, Word32, Word32)
268           getMedians
269               = do med0 ← fmap exp2 getWord16le
270                    med1 ← fmap exp2 getWord16le
271                    med2 ← fmap exp2 getWord16le
272                    return (med0, med1, med2)
273
274 -- | WV Bitstream
275 data WVBitstream
276     = WVBitstream {
277         wvStream ∷ !L.ByteString
278       }
279     deriving (Eq, Show, Typeable)
280
281 instance Metadata WVBitstream where
282     metaID _ = 0x0A
283     metaSize = fromIntegral ∘ L.length ∘ wvStream
284
285 instance Binary WVBitstream where
286     put = putLazyByteString ∘ wvStream
287     get = fmap WVBitstream getRemainingLazyByteString
288
289 -- | RIFF header for .wav files (before audio)
290 data RIFFHeader
291     = RIFFHeader {
292         riffHeader ∷ !L.ByteString
293       }
294     deriving (Eq, Show, Typeable)
295
296 instance Metadata RIFFHeader where
297     metaID _ = 0x21
298     metaSize = fromIntegral ∘ L.length ∘ riffHeader
299
300 instance Binary RIFFHeader where
301     put = putLazyByteString ∘ riffHeader
302     get = fmap RIFFHeader getRemainingLazyByteString
303
304 -- | RIFF trailer for .wav files (after audio)
305 data RIFFTrailer
306     = RIFFTrailer {
307         riffTrailer ∷ !L.ByteString
308       }
309     deriving (Eq, Show, Typeable)
310
311 instance Metadata RIFFTrailer where
312     metaID _ = 0x22
313     metaSize = fromIntegral ∘ L.length ∘ riffTrailer
314
315 instance Binary RIFFTrailer where
316     put = putLazyByteString ∘ riffTrailer
317     get = fmap RIFFTrailer getRemainingLazyByteString
318
319 -- | Configuration information.
320 data ConfigInfo
321     = ConfigInfo {
322       -- | fast mode
323         cfgFast           ∷ !Bool
324       -- | high quality mode
325       , cfgHigh           ∷ !Bool
326       -- | very high
327       , cfgVeryHigh       ∷ !Bool
328       -- | bitrate is kbps, not bits / sample
329       , cfgBitrateKbps    ∷ !Bool
330       -- | automatic noise shaping
331       , cfgAutoShaping    ∷ !Bool
332       -- | shaping mode specified
333       , cfgShapeOverride  ∷ !Bool
334       -- | joint-stereo mode specified
335       , cfgJointOverride  ∷ !Bool
336       -- | dynamic noise shaping
337       , cfgDynamicShaping ∷ !Bool
338       -- | create executable
339       , cfgCreateEXE      ∷ !Bool
340       -- | create correction file
341       , cfgCreateWVC      ∷ !Bool
342       -- | maximize hybrid compression
343       , cfgOptimizeWVC    ∷ !Bool
344       -- | calc noise in hybrid mode
345       , cfgCalcNoise      ∷ !Bool
346       -- | obsolete (for information)
347       , cfgLossyMode      ∷ !Bool
348       -- | extra processing mode level (1-6)
349       , cfgExtraModeLevel ∷ !(S.Maybe Word8)
350       -- | no wvx stream w/ floats & big ints
351       , cfgSkipWVX        ∷ !Bool
352       -- | compute & store MD5 signature
353       , cfgMD5Checksum    ∷ !Bool
354       -- | merge blocks of equal redundancy
355       , cfgMergeBlocks    ∷ !Bool
356       -- | optimize for mono streams posing
357       , cfgOptimizeMono   ∷ !Bool
358       }
359     deriving (Eq, Show, Typeable)
360
361 instance Metadata ConfigInfo where
362     metaID _ = 0x25
363     metaSize ci
364         | S.isJust $ cfgExtraModeLevel ci
365             = 4
366         | otherwise
367             = 3
368
369 instance Binary ConfigInfo where
370     put ci
371         = let !bs = runBitPut $
372                     do putBit $ cfgOptimizeMono   ci
373                        putNBits 2 (0 ∷ Word8) -- unused
374                        putBit $ cfgMergeBlocks    ci
375                        putBit $ cfgMD5Checksum    ci
376                        putBit $ cfgSkipWVX        ci
377                        putBit $ S.isJust $ cfgExtraModeLevel ci
378                        putBit $ cfgLossyMode      ci
379                        putBit $ cfgCalcNoise      ci
380                        putNBits 2 (0 ∷ Word8) -- unused
381                        putBit $ cfgOptimizeWVC    ci
382                        putBit $ cfgCreateWVC      ci
383                        putBit $ cfgCreateEXE      ci
384                        putBit $ cfgDynamicShaping ci
385                        putBit $ cfgJointOverride  ci
386                        putBit $ cfgShapeOverride  ci
387                        putBit $ cfgAutoShaping    ci
388                        putBit $ cfgBitrateKbps    ci
389                        putBit $ cfgVeryHigh       ci
390                        putBit $ cfgHigh           ci
391                        putBit False -- unused
392                        putBit $ cfgFast           ci
393                        putBit False -- unused
394           in
395             do putLazyByteString (L.reverse bs)
396                case cfgExtraModeLevel ci of
397                  S.Nothing  → return ()
398                  S.Just eml → putWord8 eml
399
400     get = do bs  ← getBytes 3
401              eml ← do xmode ← fmap (¬) isEmpty
402                       if xmode then
403                           fmap S.Just getWord8
404                         else
405                           return S.Nothing
406              let r = runBitGet (S.reverse bs) $
407                      do optimizeMono   ← getBit
408                         BG.skip 2 -- unused
409                         mergeBlocks    ← getBit
410                         md5Checksum    ← getBit
411                         skipWVX        ← getBit
412                         extraMode      ← getBit
413                         lossyMode      ← getBit
414                         calcNoise      ← getBit
415                         BG.skip 2 -- unused
416                         optimizeWVC    ← getBit
417                         createWVC      ← getBit
418                         createEXE      ← getBit
419                         dynamicShaping ← getBit
420                         jointOverride  ← getBit
421                         shapeOverride  ← getBit
422                         autoShaping    ← getBit
423                         bitrateKbps    ← getBit
424                         veryHigh       ← getBit
425                         high           ← getBit
426                         BG.skip 1 -- unused
427                         fast           ← getBit
428                         BG.skip 1 -- unused
429                         return ConfigInfo {
430                                      cfgFast           = fast
431                                    , cfgHigh           = high
432                                    , cfgVeryHigh       = veryHigh
433                                    , cfgBitrateKbps    = bitrateKbps
434                                    , cfgAutoShaping    = autoShaping
435                                    , cfgShapeOverride  = shapeOverride
436                                    , cfgJointOverride  = jointOverride
437                                    , cfgDynamicShaping = dynamicShaping
438                                    , cfgCreateEXE      = createEXE
439                                    , cfgCreateWVC      = createWVC
440                                    , cfgOptimizeWVC    = optimizeWVC
441                                    , cfgCalcNoise      = calcNoise
442                                    , cfgLossyMode      = lossyMode
443                                    , cfgExtraModeLevel = if extraMode then
444                                                              eml
445                                                          else
446                                                              S.Nothing
447                                    , cfgSkipWVX        = skipWVX
448                                    , cfgMD5Checksum    = md5Checksum
449                                    , cfgMergeBlocks    = mergeBlocks
450                                    , cfgOptimizeMono   = optimizeMono
451                                    }
452                          
453              case r of
454                Left err → fail err
455                Right ci → return ci
456
457 -- | Unknown but optional metadata found in the WavPack block.
458 data Unknown
459     = Unknown {
460         -- | The ID of this unknown metadata without odd-size bit nor
461         -- large-block bit.
462         unkID   ∷ Word8
463         -- | Raw data; must be less than 2^25 bytes long.
464       , unkData ∷ L.ByteString
465       }
466     deriving (Eq, Show, Typeable)
467
468 instance Metadata Unknown where
469     metaID   = unkID
470
471 instance Binary Unknown where
472     put = putLazyByteString ∘ unkData
473     get = error "unsupported operation"