1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE CPP #-}
4module Codec.Picture.Jpg.Internal.Types( MutableMacroBlock
5                              , createEmptyMutableMacroBlock
6                              , printMacroBlock
7                              , printPureMacroBlock
8                              , DcCoefficient
9                              , JpgImage( .. )
10                              , JpgComponent( .. )
11                              , JpgFrameHeader( .. )
12                              , JpgFrame( .. )
13                              , JpgFrameKind( .. )
14                              , JpgScanHeader( .. )
15                              , JpgQuantTableSpec( .. )
16                              , JpgHuffmanTableSpec( .. )
17                              , JpgImageKind( .. )
18                              , JpgScanSpecification( .. )
19                              , JpgColorSpace( .. )
20                              , AdobeTransform( .. )
21                              , JpgAdobeApp14( .. )
22                              , JpgJFIFApp0( .. )
23                              , JFifUnit( .. )
24                              , calculateSize
25                              , dctBlockSize
26                              ) where
27
28
29#if !MIN_VERSION_base(4,8,0)
30import Control.Applicative( pure, (<*>), (<$>) )
31#endif
32
33import Control.Monad( when, replicateM, forM, forM_, unless )
34import Control.Monad.ST( ST )
35import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
36import Data.List( partition )
37
38#if !MIN_VERSION_base(4,11,0)
39import Data.Monoid( (<>) )
40#endif
41
42import Foreign.Storable ( Storable )
43import Data.Vector.Unboxed( (!) )
44import qualified Data.Vector as V
45import qualified Data.Vector.Unboxed as VU
46import qualified Data.Vector.Storable as VS
47import qualified Data.Vector.Storable.Mutable as M
48import qualified Data.ByteString as B
49import qualified Data.ByteString.Char8 as BC
50import qualified Data.ByteString.Lazy as L
51
52import Data.Int( Int16 )
53import Data.Word(Word8, Word16 )
54import Data.Binary( Binary(..) )
55
56import Data.Binary.Get( Get
57                      , getWord8
58                      , getWord16be
59                      , getByteString
60                      , skip
61                      , bytesRead
62                      )
63
64import Data.Binary.Put( Put
65                      , putWord8
66                      , putWord16be
67                      , putLazyByteString
68                      , putByteString
69                      , runPut
70                      )
71
72import Codec.Picture.InternalHelper
73import Codec.Picture.Jpg.Internal.DefaultTable
74import Codec.Picture.Tiff.Internal.Types
75import Codec.Picture.Tiff.Internal.Metadata( exifOffsetIfd )
76import Codec.Picture.Metadata.Exif
77
78{-import Debug.Trace-}
79import Text.Printf
80
81-- | Type only used to make clear what kind of integer we are carrying
82-- Might be transformed into newtype in the future
83type DcCoefficient = Int16
84
85-- | Macroblock that can be transformed.
86type MutableMacroBlock s a = M.STVector s a
87
88data JpgFrameKind =
89      JpgBaselineDCTHuffman
90    | JpgExtendedSequentialDCTHuffman
91    | JpgProgressiveDCTHuffman
92    | JpgLosslessHuffman
93    | JpgDifferentialSequentialDCTHuffman
94    | JpgDifferentialProgressiveDCTHuffman
95    | JpgDifferentialLosslessHuffman
96    | JpgExtendedSequentialArithmetic
97    | JpgProgressiveDCTArithmetic
98    | JpgLosslessArithmetic
99    | JpgDifferentialSequentialDCTArithmetic
100    | JpgDifferentialProgressiveDCTArithmetic
101    | JpgDifferentialLosslessArithmetic
102    | JpgQuantizationTable
103    | JpgHuffmanTableMarker
104    | JpgStartOfScan
105    | JpgEndOfImage
106    | JpgAppSegment Word8
107    | JpgExtensionSegment Word8
108
109    | JpgRestartInterval
110    | JpgRestartIntervalEnd Word8
111    deriving (Eq, Show)
112
113data JpgFrame =
114      JpgAppFrame        !Word8 B.ByteString
115    | JpgAdobeAPP14      !JpgAdobeApp14
116    | JpgJFIF            !JpgJFIFApp0
117    | JpgExif            ![ImageFileDirectory]
118    | JpgExtension       !Word8 B.ByteString
119    | JpgQuantTable      ![JpgQuantTableSpec]
120    | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanPackedTree)]
121    | JpgScanBlob        !JpgScanHeader !L.ByteString
122    | JpgScans           !JpgFrameKind !JpgFrameHeader
123    | JpgIntervalRestart !Word16
124    deriving Show
125
126data JpgColorSpace
127  = JpgColorSpaceYCbCr
128  | JpgColorSpaceYCC
129  | JpgColorSpaceY
130  | JpgColorSpaceYA
131  | JpgColorSpaceYCCA
132  | JpgColorSpaceYCCK
133  | JpgColorSpaceCMYK
134  | JpgColorSpaceRGB
135  | JpgColorSpaceRGBA
136  deriving Show
137
138data AdobeTransform
139  = AdobeUnknown    -- ^ Value 0
140  | AdobeYCbCr      -- ^ value 1
141  | AdobeYCck       -- ^ value 2
142  deriving Show
143
144data JpgAdobeApp14 = JpgAdobeApp14
145  { _adobeDctVersion :: !Word16
146  , _adobeFlag0      :: !Word16
147  , _adobeFlag1      :: !Word16
148  , _adobeTransform  :: !AdobeTransform
149  }
150  deriving Show
151
152-- | Size: 1
153data JFifUnit
154  = JFifUnitUnknown   -- ^ 0
155  | JFifPixelsPerInch -- ^ 1
156  | JFifPixelsPerCentimeter -- ^ 2
157  deriving Show
158
159instance Binary JFifUnit where
160  put v = putWord8 $ case v of
161    JFifUnitUnknown -> 0
162    JFifPixelsPerInch -> 1
163    JFifPixelsPerCentimeter -> 2
164  get = do
165    v <- getWord8
166    pure $ case v of
167      0 -> JFifUnitUnknown
168      1 -> JFifPixelsPerInch
169      2 -> JFifPixelsPerCentimeter
170      _ -> JFifUnitUnknown
171
172data JpgJFIFApp0 = JpgJFIFApp0
173  { _jfifUnit      :: !JFifUnit
174  , _jfifDpiX      :: !Word16
175  , _jfifDpiY      :: !Word16
176  , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int)
177  }
178  deriving Show
179
180instance Binary JpgJFIFApp0 where
181  get = do
182    sig <- getByteString 5
183    when (sig /= BC.pack "JFIF\0") $
184        fail "Invalid JFIF signature"
185    major <- getWord8
186    minor <- getWord8
187    when (major /= 1 && minor > 2) $
188        fail "Unrecognize JFIF version"
189    unit <- get
190    dpiX <- getWord16be
191    dpiY <- getWord16be
192    w <- getWord8
193    h <- getWord8
194    let pxCount = 3 * w * h
195    img <- case pxCount of
196      0 -> return Nothing
197      _ -> return Nothing
198    return $ JpgJFIFApp0
199        { _jfifUnit      = unit
200        , _jfifDpiX      = dpiX
201        , _jfifDpiY      = dpiY
202        , _jfifThumbnail = img
203        }
204
205
206  put jfif = do
207    putByteString $ BC.pack "JFIF\0" -- 5
208    putWord8 1                       -- 1 6
209    putWord8 2                       -- 1 7
210    put $ _jfifUnit jfif             -- 1 8
211    putWord16be $ _jfifDpiX jfif     -- 2 10
212    putWord16be $ _jfifDpiY jfif     -- 2 12
213    putWord8 0                       -- 1 13
214    putWord8 0                       -- 1 14
215
216{-Thumbnail width (tw) 	1 	Horizontal size of embedded JFIF thumbnail in pixels-}
217{-Thumbnail height (th) 	1 	Vertical size of embedded JFIF thumbnail in pixels-}
218{-Thumbnail data 	3 × tw × th 	Uncompressed 24 bit RGB raster thumbnail-}
219
220instance Binary AdobeTransform where
221  put v = case v of
222    AdobeUnknown -> putWord8 0
223    AdobeYCbCr -> putWord8 1
224    AdobeYCck -> putWord8 2
225
226  get = do
227    v <- getWord8
228    pure $ case v of
229      0 -> AdobeUnknown
230      1 -> AdobeYCbCr
231      2 -> AdobeYCck
232      _ -> AdobeUnknown
233
234instance Binary JpgAdobeApp14 where
235  get = do
236    let sig = BC.pack "Adobe"
237    fileSig <- getByteString 5
238    when (fileSig /= sig) $
239       fail "Invalid Adobe APP14 marker"
240    version <- getWord16be
241    when (version /= 100) $
242       fail $ "Invalid Adobe APP14 version " ++ show version
243    JpgAdobeApp14 version
244                  <$> getWord16be
245                  <*> getWord16be <*> get
246
247  put (JpgAdobeApp14 v f0 f1 t) = do
248    putByteString $ BC.pack "Adobe"
249    putWord16be v
250    putWord16be f0
251    putWord16be f1
252    put t
253
254
255data JpgFrameHeader = JpgFrameHeader
256    { jpgFrameHeaderLength   :: !Word16
257    , jpgSamplePrecision     :: !Word8
258    , jpgHeight              :: !Word16
259    , jpgWidth               :: !Word16
260    , jpgImageComponentCount :: !Word8
261    , jpgComponents          :: ![JpgComponent]
262    }
263    deriving Show
264
265
266instance SizeCalculable JpgFrameHeader where
267    calculateSize hdr = 2 + 1 + 2 + 2 + 1
268                      + sum [calculateSize c | c <- jpgComponents hdr]
269
270data JpgComponent = JpgComponent
271    { componentIdentifier       :: !Word8
272      -- | Stored with 4 bits
273    , horizontalSamplingFactor  :: !Word8
274      -- | Stored with 4 bits
275    , verticalSamplingFactor    :: !Word8
276    , quantizationTableDest     :: !Word8
277    }
278    deriving Show
279
280instance SizeCalculable JpgComponent where
281    calculateSize _ = 3
282
283data JpgImage = JpgImage { jpgFrame :: [JpgFrame] }
284    deriving Show
285
286data JpgScanSpecification = JpgScanSpecification
287    { componentSelector :: !Word8
288      -- | Encoded as 4 bits
289    , dcEntropyCodingTable :: !Word8
290      -- | Encoded as 4 bits
291    , acEntropyCodingTable :: !Word8
292
293    }
294    deriving Show
295
296instance SizeCalculable JpgScanSpecification where
297    calculateSize _ = 2
298
299data JpgScanHeader = JpgScanHeader
300    { scanLength :: !Word16
301    , scanComponentCount :: !Word8
302    , scans :: [JpgScanSpecification]
303
304      -- | (begin, end)
305    , spectralSelection    :: (Word8, Word8)
306
307      -- | Encoded as 4 bits
308    , successiveApproxHigh :: !Word8
309
310      -- | Encoded as 4 bits
311    , successiveApproxLow :: !Word8
312    }
313    deriving Show
314
315instance SizeCalculable JpgScanHeader where
316    calculateSize hdr = 2 + 1
317                      + sum [calculateSize c | c <- scans hdr]
318                      + 2
319                      + 1
320
321data JpgQuantTableSpec = JpgQuantTableSpec
322    { -- | Stored on 4 bits
323      quantPrecision     :: !Word8
324
325      -- | Stored on 4 bits
326    , quantDestination   :: !Word8
327
328    , quantTable         :: MacroBlock Int16
329    }
330    deriving Show
331
332class SizeCalculable a where
333    calculateSize :: a -> Int
334
335-- | Type introduced only to avoid some typeclass overlapping
336-- problem
337newtype TableList a = TableList [a]
338
339instance (SizeCalculable a, Binary a) => Binary (TableList a) where
340    put (TableList lst) = do
341        putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2
342        mapM_ put lst
343
344    get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2))
345      where innerParse :: Int -> Get [a]
346            innerParse 0    = return []
347            innerParse size = do
348                onStart <- fromIntegral <$> bytesRead
349                table <- get
350                onEnd <- fromIntegral <$> bytesRead
351                (table :) <$> innerParse (size - (onEnd - onStart))
352
353instance SizeCalculable JpgQuantTableSpec where
354    calculateSize table =
355        1 + (fromIntegral (quantPrecision table) + 1) * 64
356
357instance Binary JpgQuantTableSpec where
358    put table = do
359        let precision = quantPrecision table
360        put4BitsOfEach precision (quantDestination table)
361        forM_ (VS.toList $ quantTable table) $ \coeff ->
362            if precision == 0 then putWord8 $ fromIntegral coeff
363                             else putWord16be $ fromIntegral coeff
364
365    get = do
366        (precision, dest) <- get4BitOfEach
367        coeffs <- replicateM 64 $ if precision == 0
368                then fromIntegral <$> getWord8
369                else fromIntegral <$> getWord16be
370        return JpgQuantTableSpec
371            { quantPrecision = precision
372            , quantDestination = dest
373            , quantTable = VS.fromListN 64 coeffs
374            }
375
376data JpgHuffmanTableSpec = JpgHuffmanTableSpec
377    { -- | 0 : DC, 1 : AC, stored on 4 bits
378      huffmanTableClass       :: !DctComponent
379      -- | Stored on 4 bits
380    , huffmanTableDest        :: !Word8
381
382    , huffSizes :: !(VU.Vector Word8)
383    , huffCodes :: !(V.Vector (VU.Vector Word8))
384    }
385    deriving Show
386
387instance SizeCalculable JpgHuffmanTableSpec where
388    calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table]
389
390instance Binary JpgHuffmanTableSpec where
391    put table = do
392        let classVal = if huffmanTableClass table == DcComponent
393                          then 0 else 1
394        put4BitsOfEach classVal $ huffmanTableDest table
395        mapM_ put . VU.toList $ huffSizes table
396        forM_ [0 .. 15] $ \i ->
397            when (huffSizes table ! i /= 0)
398                 (let elements = VU.toList $ huffCodes table V.! i
399                  in mapM_ put elements)
400
401    get = do
402        (huffClass, huffDest) <- get4BitOfEach
403        sizes <- replicateM 16 getWord8
404        codes <- forM sizes $ \s ->
405            VU.replicateM (fromIntegral s) getWord8
406        return JpgHuffmanTableSpec
407            { huffmanTableClass =
408                if huffClass == 0 then DcComponent else AcComponent
409            , huffmanTableDest = huffDest
410            , huffSizes = VU.fromListN 16 sizes
411            , huffCodes = V.fromListN 16 codes
412            }
413
414instance Binary JpgImage where
415    put (JpgImage { jpgFrame = frames }) =
416        putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames
417            >> putWord8 0xFF >> putWord8 0xD9
418
419    get = do
420        let startOfImageMarker = 0xD8
421            -- endOfImageMarker = 0xD9
422        checkMarker commonMarkerFirstByte startOfImageMarker
423        eatUntilCode
424        frames <- parseFrames
425        {-checkMarker commonMarkerFirstByte endOfImageMarker-}
426        return JpgImage { jpgFrame = frames }
427
428eatUntilCode :: Get ()
429eatUntilCode = do
430    code <- getWord8
431    unless (code == 0xFF) eatUntilCode
432
433takeCurrentFrame :: Get B.ByteString
434takeCurrentFrame = do
435    size <- getWord16be
436    getByteString (fromIntegral size - 2)
437
438putFrame :: JpgFrame -> Put
439putFrame (JpgAdobeAPP14 adobe) =
440    put (JpgAppSegment 14) >> putWord16be 14 >> put adobe
441putFrame (JpgJFIF jfif) =
442    put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif
443putFrame (JpgExif exif) = putExif exif
444putFrame (JpgAppFrame appCode str) =
445    put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
446putFrame (JpgExtension appCode str) =
447    put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
448putFrame (JpgQuantTable tables) =
449    put JpgQuantizationTable >> put (TableList tables)
450putFrame (JpgHuffmanTable tables) =
451    put JpgHuffmanTableMarker >> put (TableList $ map fst tables)
452putFrame (JpgIntervalRestart size) =
453    put JpgRestartInterval >> put (RestartInterval size)
454putFrame (JpgScanBlob hdr blob) =
455    put JpgStartOfScan >> put hdr >> putLazyByteString blob
456putFrame (JpgScans kind hdr) =
457    put kind >> put hdr
458
459--------------------------------------------------
460----            Serialization instances
461--------------------------------------------------
462commonMarkerFirstByte :: Word8
463commonMarkerFirstByte = 0xFF
464
465checkMarker :: Word8 -> Word8 -> Get ()
466checkMarker b1 b2 = do
467    rb1 <- getWord8
468    rb2 <- getWord8
469    when (rb1 /= b1 || rb2 /= b2)
470         (fail "Invalid marker used")
471
472extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString)
473extractScanContent str = aux 0
474  where maxi = fromIntegral $ L.length str - 1
475
476        aux n | n >= maxi = (str, L.empty)
477              | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str
478              | otherwise = aux (n + 1)
479            where v = str `L.index` n
480                  vNext = str `L.index` (n + 1)
481                  isReset = 0xD0 <= vNext && vNext <= 0xD7
482
483parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame]
484parseAdobe14 str lst = go where
485  go = case runGetStrict get str of
486    Left _err -> lst
487    Right app14 -> JpgAdobeAPP14 app14 : lst
488
489-- | Parse JFIF or JFXX information. Right now only JFIF.
490parseJF__  :: B.ByteString -> [JpgFrame] -> [JpgFrame]
491parseJF__  str lst = go where
492  go = case runGetStrict get str of
493    Left _err -> lst
494    Right jfif -> JpgJFIF jfif : lst
495
496parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame]
497parseExif str lst
498  | exifHeader `B.isPrefixOf` str = go
499  | otherwise = lst
500  where
501    exifHeader = BC.pack "Exif\0\0"
502    tiff = B.drop (B.length exifHeader) str
503    go = case runGetStrict (getP tiff) tiff of
504      Left _err -> lst
505      Right (_hdr :: TiffHeader, []) -> lst
506      Right (_hdr :: TiffHeader, ifds : _) -> JpgExif ifds : lst
507
508putExif :: [ImageFileDirectory] -> Put
509putExif ifds = putAll where
510  hdr = TiffHeader
511    { hdrEndianness = EndianBig
512    , hdrOffset = 8
513    }
514
515  ifdList = case partition (isInIFD0 . ifdIdentifier) ifds of
516    (ifd0, []) -> [ifd0]
517    (ifd0, ifdExif) -> [ifd0 <> pure exifOffsetIfd, ifdExif]
518
519  exifBlob = runPut $ do
520    putByteString $ BC.pack "Exif\0\0"
521    putP BC.empty (hdr, ifdList)
522
523  putAll = do
524    put (JpgAppSegment 1)
525    putWord16be . fromIntegral $ L.length exifBlob + 2
526    putLazyByteString exifBlob
527
528parseFrames :: Get [JpgFrame]
529parseFrames = do
530    kind <- get
531    let parseNextFrame = do
532            word <- getWord8
533            when (word /= 0xFF) $ do
534                readedData <- bytesRead
535                fail $ "Invalid Frame marker (" ++ show word
536                     ++ ", bytes read : " ++ show readedData ++ ")"
537            parseFrames
538
539    case kind of
540        JpgEndOfImage -> return []
541        JpgAppSegment 0 ->
542            parseJF__ <$> takeCurrentFrame <*> parseNextFrame
543        JpgAppSegment 1 ->
544            parseExif <$> takeCurrentFrame <*> parseNextFrame
545        JpgAppSegment 14 ->
546            parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame
547        JpgAppSegment c ->
548            (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame
549        JpgExtensionSegment c ->
550            (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame
551        JpgQuantizationTable ->
552            (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame
553        JpgRestartInterval ->
554            (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame
555        JpgHuffmanTableMarker ->
556            (\(TableList huffTables) lst ->
557                    JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst)
558                    <$> get <*> parseNextFrame
559        JpgStartOfScan ->
560            (\frm imgData ->
561                let (d, other) = extractScanContent imgData
562                in
563                case runGet parseFrames (L.drop 1 other) of
564                  Left _ -> [JpgScanBlob frm d]
565                  Right lst -> JpgScanBlob frm d : lst
566            ) <$> get <*> getRemainingLazyBytes
567
568        _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame
569
570buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree
571buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList
572
573secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8
574secondStartOfFrameByteOfKind = aux
575  where
576    aux JpgBaselineDCTHuffman = 0xC0
577    aux JpgExtendedSequentialDCTHuffman = 0xC1
578    aux JpgProgressiveDCTHuffman = 0xC2
579    aux JpgLosslessHuffman = 0xC3
580    aux JpgDifferentialSequentialDCTHuffman = 0xC5
581    aux JpgDifferentialProgressiveDCTHuffman = 0xC6
582    aux JpgDifferentialLosslessHuffman = 0xC7
583    aux JpgExtendedSequentialArithmetic = 0xC9
584    aux JpgProgressiveDCTArithmetic = 0xCA
585    aux JpgLosslessArithmetic = 0xCB
586    aux JpgHuffmanTableMarker = 0xC4
587    aux JpgDifferentialSequentialDCTArithmetic = 0xCD
588    aux JpgDifferentialProgressiveDCTArithmetic = 0xCE
589    aux JpgDifferentialLosslessArithmetic = 0xCF
590    aux JpgEndOfImage = 0xD9
591    aux JpgQuantizationTable = 0xDB
592    aux JpgStartOfScan = 0xDA
593    aux JpgRestartInterval = 0xDD
594    aux (JpgRestartIntervalEnd v) = v
595    aux (JpgAppSegment a) = (a + 0xE0)
596    aux (JpgExtensionSegment a) = a
597
598data JpgImageKind = BaseLineDCT | ProgressiveDCT
599
600instance Binary JpgFrameKind where
601    put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v)
602    get = do
603        -- no lookahead :(
604        {-word <- getWord8-}
605        word2 <- getWord8
606        return $ case word2 of
607            0xC0 -> JpgBaselineDCTHuffman
608            0xC1 -> JpgExtendedSequentialDCTHuffman
609            0xC2 -> JpgProgressiveDCTHuffman
610            0xC3 -> JpgLosslessHuffman
611            0xC4 -> JpgHuffmanTableMarker
612            0xC5 -> JpgDifferentialSequentialDCTHuffman
613            0xC6 -> JpgDifferentialProgressiveDCTHuffman
614            0xC7 -> JpgDifferentialLosslessHuffman
615            0xC9 -> JpgExtendedSequentialArithmetic
616            0xCA -> JpgProgressiveDCTArithmetic
617            0xCB -> JpgLosslessArithmetic
618            0xCD -> JpgDifferentialSequentialDCTArithmetic
619            0xCE -> JpgDifferentialProgressiveDCTArithmetic
620            0xCF -> JpgDifferentialLosslessArithmetic
621            0xD9 -> JpgEndOfImage
622            0xDA -> JpgStartOfScan
623            0xDB -> JpgQuantizationTable
624            0xDD -> JpgRestartInterval
625            a | a >= 0xF0 -> JpgExtensionSegment a
626              | a >= 0xE0 -> JpgAppSegment (a - 0xE0)
627              | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a
628              | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")")
629
630put4BitsOfEach :: Word8 -> Word8 -> Put
631put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b
632
633get4BitOfEach :: Get (Word8, Word8)
634get4BitOfEach = do
635    val <- get
636    return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF)
637
638newtype RestartInterval = RestartInterval Word16
639
640instance Binary RestartInterval where
641    put (RestartInterval i) = putWord16be 4 >> putWord16be i
642    get = do
643        size <- getWord16be
644        when (size /= 4) (fail "Invalid jpeg restart interval size")
645        RestartInterval <$> getWord16be
646
647instance Binary JpgComponent where
648    get = do
649        ident <- getWord8
650        (horiz, vert) <- get4BitOfEach
651        quantTableIndex <- getWord8
652        return JpgComponent
653            { componentIdentifier = ident
654            , horizontalSamplingFactor = horiz
655            , verticalSamplingFactor = vert
656            , quantizationTableDest = quantTableIndex
657            }
658    put v = do
659        put $ componentIdentifier v
660        put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v
661        put $ quantizationTableDest v
662
663instance Binary JpgFrameHeader where
664    get = do
665        beginOffset <- fromIntegral <$> bytesRead
666        frmHLength <- getWord16be
667        samplePrec <- getWord8
668        h <- getWord16be
669        w <- getWord16be
670        compCount <- getWord8
671        components <- replicateM (fromIntegral compCount) get
672        endOffset <- fromIntegral <$> bytesRead
673        when (beginOffset - endOffset < fromIntegral frmHLength)
674             (skip $ fromIntegral frmHLength - (endOffset - beginOffset))
675        return JpgFrameHeader
676            { jpgFrameHeaderLength = frmHLength
677            , jpgSamplePrecision = samplePrec
678            , jpgHeight = h
679            , jpgWidth = w
680            , jpgImageComponentCount = compCount
681            , jpgComponents = components
682            }
683
684    put v = do
685        putWord16be $ jpgFrameHeaderLength v
686        putWord8    $ jpgSamplePrecision v
687        putWord16be $ jpgHeight v
688        putWord16be $ jpgWidth v
689        putWord8    $ jpgImageComponentCount v
690        mapM_ put   $ jpgComponents v
691
692instance Binary JpgScanSpecification where
693    put v = do
694        put $ componentSelector v
695        put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v
696
697    get = do
698        compSel <- get
699        (dc, ac) <- get4BitOfEach
700        return JpgScanSpecification {
701            componentSelector = compSel
702          , dcEntropyCodingTable = dc
703          , acEntropyCodingTable = ac
704          }
705
706instance Binary JpgScanHeader where
707    get = do
708        thisScanLength <- getWord16be
709        compCount <- getWord8
710        comp <- replicateM (fromIntegral compCount) get
711        specBeg <- get
712        specEnd <- get
713        (approxHigh, approxLow) <- get4BitOfEach
714
715        return JpgScanHeader {
716            scanLength = thisScanLength,
717            scanComponentCount = compCount,
718            scans = comp,
719            spectralSelection = (specBeg, specEnd),
720            successiveApproxHigh = approxHigh,
721            successiveApproxLow = approxLow
722        }
723
724    put v = do
725        putWord16be $ scanLength v
726        putWord8 $ scanComponentCount v
727        mapM_ put $ scans v
728        putWord8 . fst $ spectralSelection v
729        putWord8 . snd $ spectralSelection v
730        put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v
731
732{-# INLINE createEmptyMutableMacroBlock #-}
733-- | Create a new macroblock with the good array size
734createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a)
735createEmptyMutableMacroBlock = M.replicate 64 0
736
737printMacroBlock :: (Storable a, PrintfArg a)
738                => MutableMacroBlock s a -> ST s String
739printMacroBlock block = pLn 0
740    where pLn 64 = return "===============================\n"
741          pLn i = do
742              v <- block `M.unsafeRead` i
743              vn <- pLn (i+1)
744              return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn
745
746printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String
747printPureMacroBlock block = pLn 0
748    where pLn 64 = "===============================\n"
749          pLn i = str ++ pLn (i + 1)
750            where str | i `mod` 8 == 0 = printf "\n%5d " v
751                      | otherwise = printf "%5d" v
752                  v = block VS.! i
753
754
755{-# INLINE dctBlockSize #-}
756dctBlockSize :: Num a => a
757dctBlockSize = 8
758