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