diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,91 +1,91 @@ -Name: JuicyPixels -Version: 3.2.8 -Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) -Description: - <> - . - This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and Gif images. - -homepage: https://github.com/Twinside/Juicy.Pixels -License: BSD3 -License-file: LICENSE -Author: Vincent Berthoux -Maintainer: vincent.berthoux@gmail.com -Category: Codec, Graphics, Image -Stability: Stable -Build-type: Simple - --- Constraint on the version of Cabal needed to build this package. -Cabal-version: >= 1.10 - -extra-source-files: changelog, docimages/*.png, docimages/*.svg, README.md -extra-doc-files: docimages/*.png, docimages/*.svg - -Source-Repository head - Type: git - Location: git://github.com/Twinside/Juicy.Pixels.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.8 - -Flag Mmap - Description: Enable the file loading via mmap (memory map) - Default: False - -Library - hs-source-dirs: src - Default-Language: Haskell2010 - Exposed-modules: Codec.Picture, - Codec.Picture.Bitmap, - Codec.Picture.Gif, - Codec.Picture.Png, - Codec.Picture.Jpg, - Codec.Picture.HDR, - Codec.Picture.Tga, - Codec.Picture.Tiff, - Codec.Picture.Metadata, - Codec.Picture.Metadata.Exif, - Codec.Picture.Saving, - Codec.Picture.Types, - Codec.Picture.ColorQuant - - Ghc-options: -O3 -Wall - Build-depends: base >= 4.5 && < 5, - bytestring >= 0.9 && < 0.11, - mtl >= 1.1 && < 2.3, - binary >= 0.5 && < 0.9, - zlib >= 0.5.3.1 && < 0.7, - transformers >= 0.2, - vector >= 0.10 && < 0.12, - primitive >= 0.4 && < 0.7, - deepseq >= 1.1 && < 1.5, - containers >= 0.4.2 && < 0.6 - - if flag(Mmap) - Build-depends: mmap - CC-Options: "-DWITH_MMAP_BYTESTRING" - - -- Modules not exported by this package. - Other-modules: Codec.Picture.Jpg.DefaultTable, - Codec.Picture.Jpg.Metadata, - Codec.Picture.Jpg.FastIdct, - Codec.Picture.Jpg.FastDct, - Codec.Picture.Jpg.Types, - Codec.Picture.Jpg.Common, - Codec.Picture.Jpg.Progressive, - Codec.Picture.Gif.LZW, - Codec.Picture.Gif.LZWEncoding, - Codec.Picture.Png.Export, - Codec.Picture.Png.Type, - Codec.Picture.Png.Metadata, - Codec.Picture.Tiff.Metadata, - Codec.Picture.Tiff.Types, - Codec.Picture.BitWriter, - Codec.Picture.InternalHelper, - Codec.Picture.VectorByteConversion - - Install-Includes: src/Codec/Picture/ConvGraph.hs - Include-Dirs: src/Codec/Picture - +Name: JuicyPixels +Version: 3.2.8.1 +Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) +Description: + <> + . + This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and Gif images. + +homepage: https://github.com/Twinside/Juicy.Pixels +License: BSD3 +License-file: LICENSE +Author: Vincent Berthoux +Maintainer: vincent.berthoux@gmail.com +Category: Codec, Graphics, Image +Stability: Stable +Build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >= 1.10 + +extra-source-files: changelog, docimages/*.png, docimages/*.svg, README.md +extra-doc-files: docimages/*.png, docimages/*.svg + +Source-Repository head + Type: git + Location: git://github.com/Twinside/Juicy.Pixels.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/Juicy.Pixels.git + Tag: v3.2.8.1 + +Flag Mmap + Description: Enable the file loading via mmap (memory map) + Default: False + +Library + hs-source-dirs: src + Default-Language: Haskell2010 + Exposed-modules: Codec.Picture, + Codec.Picture.Bitmap, + Codec.Picture.Gif, + Codec.Picture.Png, + Codec.Picture.Jpg, + Codec.Picture.HDR, + Codec.Picture.Tga, + Codec.Picture.Tiff, + Codec.Picture.Metadata, + Codec.Picture.Metadata.Exif, + Codec.Picture.Saving, + Codec.Picture.Types, + Codec.Picture.ColorQuant + + Ghc-options: -O3 -Wall + Build-depends: base >= 4.5 && < 5, + bytestring >= 0.9 && < 0.11, + mtl >= 1.1 && < 2.3, + binary >= 0.5 && < 0.9, + zlib >= 0.5.3.1 && < 0.7, + transformers >= 0.2, + vector >= 0.10 && < 0.13, + primitive >= 0.4 && < 0.7, + deepseq >= 1.1 && < 1.5, + containers >= 0.4.2 && < 0.6 + + if flag(Mmap) + Build-depends: mmap + CC-Options: "-DWITH_MMAP_BYTESTRING" + + -- Modules not exported by this package. + Other-modules: Codec.Picture.Jpg.DefaultTable, + Codec.Picture.Jpg.Metadata, + Codec.Picture.Jpg.FastIdct, + Codec.Picture.Jpg.FastDct, + Codec.Picture.Jpg.Types, + Codec.Picture.Jpg.Common, + Codec.Picture.Jpg.Progressive, + Codec.Picture.Gif.LZW, + Codec.Picture.Gif.LZWEncoding, + Codec.Picture.Png.Export, + Codec.Picture.Png.Type, + Codec.Picture.Png.Metadata, + Codec.Picture.Tiff.Metadata, + Codec.Picture.Tiff.Types, + Codec.Picture.BitWriter, + Codec.Picture.InternalHelper, + Codec.Picture.VectorByteConversion + + Install-Includes: src/Codec/Picture/ConvGraph.hs + Include-Dirs: src/Codec/Picture + diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,323 +1,331 @@ -Change log -========== - -v3.2.8 September 2016 ---------------------- - * Added: possibility to retrieve the parsed palette. - * Fix: Fixing problem of progressive Jpeg decoding when - block height is different of block width (#) - -v3.2.7.2 June 2016 ------------------- - * Fix: no more libjpeg warning when decoding Juicy.Pixels encoded images. - -v3.2.7.1 May 2016 ------------------ - * Fix: some wrongly infinitely looping JPEG decoding - -v3.2.7 January 2016 -------------------- - * Addition: convertRGB8 and convertRGBA8 helper functions - * Addition: new output colorspace for JPEG format: Y, RGB & CMYK - * Addition: RGBA8 bitmap reading (thanks to mtolly) - * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck) - * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck) - * Fix: GHC 8.0 compilation (thanks to phadej) - -v3.2.6.5 December 2015 ----------------------- - * Fix: Compilation on GHC 7.6/7.8 - -v3.2.6.4 December 2015 ----------------------- - * Fix: previous broken bugfix. - -v3.2.6.3 November 2015 ----------------------- - * Fix: Fixing unwanted sharing with createMutableImage due to - wrongly used INLINE pragma - -v3.2.6.2 November 2015 ----------------------- - * Fix: Using minimal GIF version if outputing a single image. - -v3.2.6.1 August 2015 --------------------- - * Fix: handling of negative height & width in bitmap format. - * Fix: regression on Tiff parsing. - -V3.2.6 August 2015 --------------------- - - * Added: imageToTga saving helper function. - * Fix: don't invert TGA alpha channel. - * Fix: various typo in documentation. - -V3.2.5.3 July 2015 ------------------- - - * Fix: bumping vector upper bounds. - -V3.2.5.2 June 2015 ------------------- - - * Adding: Width & Height metdata to help querying image information - without decompressing the whole. - * Adding: Source format metadata. - -v3.2.5.1 May 2015 ---------------- - - * Fixing: utf-8 encoding of Jpg/Types causing problems with Haddock. - -v3.2.5 May 2015 ---------------- - - * Adding: Metadata extraction for various file format. - * Adding: Metadata writing for various file format. - * Adding: light EXIF mapping. - * Fix: handling of Tiff with predictors (thanks to Patrick Pelletier) - -v3.2.4 April 2015 ------------------ - - * Adding: Traversals compatible with the lens library. - -v3.2.3.2 April 2015 -------------------- - - * Bumping: zlib max bound - -v3.2.3.1 March 2015 -------------------- - - * Bumping: primitive to allow 0.6 - * Fix: BMP output generated wrong size (thanks to mtolly). - * Fix: 7.10.1 warning free - -v3.2.3 March 2015 ------------------ - - * Adding: Support for RGB in jpeg (yeah, that exist...) - * Adding: Support of CMYK & YCrCbK color space in jpeg files. - * Addinng: a pixelFoldMap functions analog to the `foldMap` function - of the Foldable type class. - * Fix: better performances for the pixelFold* functions - -v3.2.2 January 2015 -------------------- - - * Fix: Squashing GHC 7.10 warnings - -v3.2.1 December 2014 --------------------- - * Fix: Bumping deepseq dependencies preparing for GHC 7.10 - release. - -v3.2 December 2014 ------------------- - -*BREAKING CHANGES*: the Codec.Picture.Gif functions has changed interfaces. - - * Adding: TGA reading. - * Adding: TGA writing. - * Adding: Packeable pixel unpack. - * Fix: Returning gif with transparency (breaking Codec.Picture.Gif interface) - -v3.1.7.1 August 2014 --------------------- - - * Previous gif fix was not working withing the readImage - function, only in specialized gif images. Correcting - miscorection - -v3.1.7 August 2014 ------------------- - - * Making Juicy.Pixels compatible with GHC 7.9 HEAD (ggreif) - * Adding writing to uncompressed radiance file, due to - problems with Mac OS X "preview" application - * Fixing problem of gif parsing without global palette - * Some inlining annotations on some functions - -v3.1.6.1 August 2014 --------------------- - - * Fix of Gif palette creation (jeffreyrosenbluth) - * Restoring transformers 0.3.* compat - -v3.1.6 August 2014 ------------------- - - * Fix bad disposal handling in GIF animations. - * Added ColorConvertible instance for PixelRGB8 -> PixelRGBA16 (KaiHa) - * Fixing a bad handling of tRNS causing bad transprency decoding in - some circonstances. - * Adding the concept of Packeable pixel for faster pixel filling - using mutable array. - -v3.1.5.2 May 2014 ------------------ - - * Bumping the transformers dependency - -v3.1.5.1 May 2014 ------------------ - - * Adding some INLINE annotations for some pixel functions - -v3.1.5 March 2014 ------------------ - - * Typos and documentation proof reading fixes - (pull request from iger). - * Fix of progressive jpeg loading with more than two - huffman tables (4 allowed). - * Fix of progressive jpeg rendering (was too noisy before) - * Added loading of paletted bitmap files. - * Function to load gif images with frame duration - information (pull request from bit-shift) - * Fixing bug showing when loading JPEG with component - ID starting at 0. - * Adding reading for YA8 et YA16 Tiff images (pull - request from iger) - * Adding a mixWithAlpha method, to help work on transparent - pixel types - - -v3.1.4.1 February 2014 ----------------------- - - * Putting back data URI logo for cabal description, it's - apparently not supported by Hackage :-( - -v3.1.4 February 2014 --------------------- - - * Adding a pixelOpacity method to the pixel type class. - * Adding handling greyscale BMP files (phischu) - * Fixing promotePixel for Pixel8 -> Pixel16 - * Some type fixes in the documentation - * Updating the pixel conversion graph - * Removed URI-encoded images, now using clean cabal embedding - -v3.1.3.3 February 2014 ----------------------- - - * Lowering cabal version limit to be compiled with older GHCs - -v3.1.3.2 January 2014 ---------------------- - - * Hacking around Binary to accept old version of it, down to version 0.5 - allowing Juicy.Pixels to be compiled with GHC 6.3 - -v3.1.3.1 January 2014 ---------------------- - - * Fixing color counting function in color quantisation. - * Adding missing documentation for foreign pointer import. - -v3.1.3 January 2014 -------------------- - - * Adding palette creation (color Quantization) by Jeffrey Rosenbluth. - * Adding support for Gif writing - * Adding support for Gif animation writing - * Fixing some progressive Jpeg decoding problems (#39) - -v3.1.2 December 2013 --------------------- - - * Adding support for progressive jpeg. - * Adding support for plane separated MCU jpeg. - * Adding support for grayscale 32bit decoding (with reduced precision to - 16bits). - * Fixing erroneous bitmap decoding in case of excessive padding (#31). - -v3.1.1.1 October 2013 ---------------------- - - * Fixing some spurious crash while decoding some JPEG image (#30). - -v3.1.1 October 2013 --------------------- - - * Adding uncompresed TIFF saving. - * Adding error message to avoid loading progressive loading. - * Made MMAP optional, controled by a cabal flag. - * adding dynamicPixelMap helper function. - * Handling png transparency using color key (#26). - -v3.1 June 2013 --------------- - - * Adding basic handling of 16bits pixel types. - * Addition of Tiff reading: - - 2, 4, 8, 16 bit depth reading (planar and contiguous for each). - - CMYK, YCbCr, RGB, Paletted, Greyscale. - - Uncompressed, PackBits, LZW. - * Some new tiny helper functions (nothing too fancy). - * Huge performances improvement. - -v3.0 January 2013 ------------------ - - * Simplification of the 'Pixel' typeclass, removed many unused part. - * Removal of some Storable instances for pixel types. - * Amelioration of the documentation. - * Support for High Dynamic range images, opening support for different pixel - base component. - * Support for the Radiance file format (or RGBE, file extension .pic and .hdr). - * Dropped the cereal library in favor of the last version of Binary, present - in the Haskell platform. Every dependencies are now present in the platform. - -v2.0.2 October 2012 -------------------- - - * Decoding of interleaved gif image. - * Decoding delta coded gif animation. - * Bumping dependencies. - -v2.0.1 September 2012 ---------------------- - - * Documentation enhancements. - * Fixing some huge gif file loading. - * Fixing performance problem of Bitmap and Jpeg savings. - -v2.0 September 2012 -------------------- - - * New extractComponent version with type safe plane extraction. - * Gif file reading. - -v1.3 June 2012 --------------- - - * Fix extractComponent function. - * Adding saving for YA8 functions. - -v1.2.1 April 2012 ------------------ - - * Dependencies version bump. - * Dropping array dependency. - -v1.2 March 2012 ---------------- - - * Adding a generateImage helper function. - * Adding NFData instances for image. - * Adding JPEG writing. - -v1.1 February 2012 ------------------- - - * Switching to vector for arrays, big performance improvement. - -v1.0 January 2012 ------------------ - - * Initial release - +Change log +========== + +v3.2.8.1 March 2016 +------------------- + + * Fix: proper flushing of jpeg writing, avoiding warning from libjpeg. + * Fix: RGB jpeg get an Adobe's APP14 block to help MacOS & Photoshop reading + +v3.2.8 September 2016 +--------------------- + + * Added: possibility to retrieve the parsed palette. + * Fix: Fixing problem of progressive Jpeg decoding when + block height is different of block width (#) + +v3.2.7.2 June 2016 +------------------ + + * Fix: no more libjpeg warning when decoding Juicy.Pixels encoded images. + +v3.2.7.1 May 2016 +----------------- + * Fix: some wrongly infinitely looping JPEG decoding + +v3.2.7 January 2016 +------------------- + * Addition: convertRGB8 and convertRGBA8 helper functions + * Addition: new output colorspace for JPEG format: Y, RGB & CMYK + * Addition: RGBA8 bitmap reading (thanks to mtolly) + * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck) + * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck) + * Fix: GHC 8.0 compilation (thanks to phadej) + +v3.2.6.5 December 2015 +---------------------- + * Fix: Compilation on GHC 7.6/7.8 + +v3.2.6.4 December 2015 +---------------------- + * Fix: previous broken bugfix. + +v3.2.6.3 November 2015 +---------------------- + * Fix: Fixing unwanted sharing with createMutableImage due to + wrongly used INLINE pragma + +v3.2.6.2 November 2015 +---------------------- + * Fix: Using minimal GIF version if outputing a single image. + +v3.2.6.1 August 2015 +-------------------- + * Fix: handling of negative height & width in bitmap format. + * Fix: regression on Tiff parsing. + +V3.2.6 August 2015 +-------------------- + + * Added: imageToTga saving helper function. + * Fix: don't invert TGA alpha channel. + * Fix: various typo in documentation. + +V3.2.5.3 July 2015 +------------------ + + * Fix: bumping vector upper bounds. + +V3.2.5.2 June 2015 +------------------ + + * Adding: Width & Height metdata to help querying image information + without decompressing the whole. + * Adding: Source format metadata. + +v3.2.5.1 May 2015 +--------------- + + * Fixing: utf-8 encoding of Jpg/Types causing problems with Haddock. + +v3.2.5 May 2015 +--------------- + + * Adding: Metadata extraction for various file format. + * Adding: Metadata writing for various file format. + * Adding: light EXIF mapping. + * Fix: handling of Tiff with predictors (thanks to Patrick Pelletier) + +v3.2.4 April 2015 +----------------- + + * Adding: Traversals compatible with the lens library. + +v3.2.3.2 April 2015 +------------------- + + * Bumping: zlib max bound + +v3.2.3.1 March 2015 +------------------- + + * Bumping: primitive to allow 0.6 + * Fix: BMP output generated wrong size (thanks to mtolly). + * Fix: 7.10.1 warning free + +v3.2.3 March 2015 +----------------- + + * Adding: Support for RGB in jpeg (yeah, that exist...) + * Adding: Support of CMYK & YCrCbK color space in jpeg files. + * Addinng: a pixelFoldMap functions analog to the `foldMap` function + of the Foldable type class. + * Fix: better performances for the pixelFold* functions + +v3.2.2 January 2015 +------------------- + + * Fix: Squashing GHC 7.10 warnings + +v3.2.1 December 2014 +-------------------- + * Fix: Bumping deepseq dependencies preparing for GHC 7.10 + release. + +v3.2 December 2014 +------------------ + +*BREAKING CHANGES*: the Codec.Picture.Gif functions has changed interfaces. + + * Adding: TGA reading. + * Adding: TGA writing. + * Adding: Packeable pixel unpack. + * Fix: Returning gif with transparency (breaking Codec.Picture.Gif interface) + +v3.1.7.1 August 2014 +-------------------- + + * Previous gif fix was not working withing the readImage + function, only in specialized gif images. Correcting + miscorection + +v3.1.7 August 2014 +------------------ + + * Making Juicy.Pixels compatible with GHC 7.9 HEAD (ggreif) + * Adding writing to uncompressed radiance file, due to + problems with Mac OS X "preview" application + * Fixing problem of gif parsing without global palette + * Some inlining annotations on some functions + +v3.1.6.1 August 2014 +-------------------- + + * Fix of Gif palette creation (jeffreyrosenbluth) + * Restoring transformers 0.3.* compat + +v3.1.6 August 2014 +------------------ + + * Fix bad disposal handling in GIF animations. + * Added ColorConvertible instance for PixelRGB8 -> PixelRGBA16 (KaiHa) + * Fixing a bad handling of tRNS causing bad transprency decoding in + some circonstances. + * Adding the concept of Packeable pixel for faster pixel filling + using mutable array. + +v3.1.5.2 May 2014 +----------------- + + * Bumping the transformers dependency + +v3.1.5.1 May 2014 +----------------- + + * Adding some INLINE annotations for some pixel functions + +v3.1.5 March 2014 +----------------- + + * Typos and documentation proof reading fixes + (pull request from iger). + * Fix of progressive jpeg loading with more than two + huffman tables (4 allowed). + * Fix of progressive jpeg rendering (was too noisy before) + * Added loading of paletted bitmap files. + * Function to load gif images with frame duration + information (pull request from bit-shift) + * Fixing bug showing when loading JPEG with component + ID starting at 0. + * Adding reading for YA8 et YA16 Tiff images (pull + request from iger) + * Adding a mixWithAlpha method, to help work on transparent + pixel types + + +v3.1.4.1 February 2014 +---------------------- + + * Putting back data URI logo for cabal description, it's + apparently not supported by Hackage :-( + +v3.1.4 February 2014 +-------------------- + + * Adding a pixelOpacity method to the pixel type class. + * Adding handling greyscale BMP files (phischu) + * Fixing promotePixel for Pixel8 -> Pixel16 + * Some type fixes in the documentation + * Updating the pixel conversion graph + * Removed URI-encoded images, now using clean cabal embedding + +v3.1.3.3 February 2014 +---------------------- + + * Lowering cabal version limit to be compiled with older GHCs + +v3.1.3.2 January 2014 +--------------------- + + * Hacking around Binary to accept old version of it, down to version 0.5 + allowing Juicy.Pixels to be compiled with GHC 6.3 + +v3.1.3.1 January 2014 +--------------------- + + * Fixing color counting function in color quantisation. + * Adding missing documentation for foreign pointer import. + +v3.1.3 January 2014 +------------------- + + * Adding palette creation (color Quantization) by Jeffrey Rosenbluth. + * Adding support for Gif writing + * Adding support for Gif animation writing + * Fixing some progressive Jpeg decoding problems (#39) + +v3.1.2 December 2013 +-------------------- + + * Adding support for progressive jpeg. + * Adding support for plane separated MCU jpeg. + * Adding support for grayscale 32bit decoding (with reduced precision to + 16bits). + * Fixing erroneous bitmap decoding in case of excessive padding (#31). + +v3.1.1.1 October 2013 +--------------------- + + * Fixing some spurious crash while decoding some JPEG image (#30). + +v3.1.1 October 2013 +-------------------- + + * Adding uncompresed TIFF saving. + * Adding error message to avoid loading progressive loading. + * Made MMAP optional, controled by a cabal flag. + * adding dynamicPixelMap helper function. + * Handling png transparency using color key (#26). + +v3.1 June 2013 +-------------- + + * Adding basic handling of 16bits pixel types. + * Addition of Tiff reading: + - 2, 4, 8, 16 bit depth reading (planar and contiguous for each). + - CMYK, YCbCr, RGB, Paletted, Greyscale. + - Uncompressed, PackBits, LZW. + * Some new tiny helper functions (nothing too fancy). + * Huge performances improvement. + +v3.0 January 2013 +----------------- + + * Simplification of the 'Pixel' typeclass, removed many unused part. + * Removal of some Storable instances for pixel types. + * Amelioration of the documentation. + * Support for High Dynamic range images, opening support for different pixel + base component. + * Support for the Radiance file format (or RGBE, file extension .pic and .hdr). + * Dropped the cereal library in favor of the last version of Binary, present + in the Haskell platform. Every dependencies are now present in the platform. + +v2.0.2 October 2012 +------------------- + + * Decoding of interleaved gif image. + * Decoding delta coded gif animation. + * Bumping dependencies. + +v2.0.1 September 2012 +--------------------- + + * Documentation enhancements. + * Fixing some huge gif file loading. + * Fixing performance problem of Bitmap and Jpeg savings. + +v2.0 September 2012 +------------------- + + * New extractComponent version with type safe plane extraction. + * Gif file reading. + +v1.3 June 2012 +-------------- + + * Fix extractComponent function. + * Adding saving for YA8 functions. + +v1.2.1 April 2012 +----------------- + + * Dependencies version bump. + * Dropping array dependency. + +v1.2 March 2012 +--------------- + + * Adding a generateImage helper function. + * Adding NFData instances for image. + * Adding JPEG writing. + +v1.1 February 2012 +------------------ + + * Switching to vector for arrays, big performance improvement. + +v1.0 January 2012 +----------------- + + * Initial release + diff --git a/src/Codec/Picture/BitWriter.hs b/src/Codec/Picture/BitWriter.hs --- a/src/Codec/Picture/BitWriter.hs +++ b/src/Codec/Picture/BitWriter.hs @@ -1,336 +1,344 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | This module implement helper functions to read & write data --- at bits level. -module Codec.Picture.BitWriter( BoolReader - , emptyBoolState - , BoolState - , byteAlignJpg - , getNextBitsLSBFirst - , getNextBitsMSBFirst - , getNextBitJpg - , getNextIntJpg - , setDecodedString - , setDecodedStringMSB - , setDecodedStringJpg - , runBoolReader - - , BoolWriteStateRef - , newWriteStateRef - , finalizeBoolWriter - , writeBits' - , writeBitsGif - - , initBoolState - , initBoolStateJpg - , execBoolReader - , runBoolReaderWith - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Data.STRef -import Control.Monad( when ) -import Control.Monad.ST( ST ) -import qualified Control.Monad.Trans.State.Strict as S -import Data.Int ( Int32 ) -import Data.Word( Word8, Word32 ) -import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL ) - -import Codec.Picture.VectorByteConversion( blitVector ) -import qualified Data.Vector.Storable.Mutable as M -import qualified Data.Vector.Storable as VS -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - - --------------------------------------------------- ----- Reader --------------------------------------------------- --- | Current bit index, current value, string -data BoolState = BoolState {-# UNPACK #-} !Int - {-# UNPACK #-} !Word8 - !B.ByteString - -emptyBoolState :: BoolState -emptyBoolState = BoolState (-1) 0 B.empty - --- | Type used to read bits -type BoolReader s a = S.StateT BoolState (ST s) a - -runBoolReader :: BoolReader s a -> ST s a -runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty - -runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState) -runBoolReaderWith st action = S.runStateT action st - -execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState -execBoolReader st reader = S.execStateT reader st - -initBoolState :: B.ByteString -> BoolState -initBoolState str = case B.uncons str of - Nothing -> BoolState 0 0 B.empty - Just (v, rest) -> BoolState 0 v rest - -initBoolStateJpg :: B.ByteString -> BoolState -initBoolStateJpg str = - case B.uncons str of - Nothing -> BoolState 0 0 B.empty - Just (0xFF, rest) -> case B.uncons rest of - Nothing -> BoolState 7 0 B.empty - Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker - Just (_ , afterMarker) -> initBoolStateJpg afterMarker - Just (v, rest) -> BoolState 7 v rest - --- | Bitify a list of things to decode. -setDecodedString :: B.ByteString -> BoolReader s () -setDecodedString str = case B.uncons str of - Nothing -> S.put $ BoolState 0 0 B.empty - Just (v, rest) -> S.put $ BoolState 0 v rest - --- | Drop all bit until the bit of indice 0, usefull to parse restart --- marker, as they are byte aligned, but Huffman might not. -byteAlignJpg :: BoolReader s () -byteAlignJpg = do - BoolState idx _ chain <- S.get - when (idx /= 7) (setDecodedStringJpg chain) - -getNextBitJpg :: BoolReader s Bool -{-# INLINE getNextBitJpg #-} -getNextBitJpg = do - BoolState idx v chain <- S.get - let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 - if idx == 0 - then setDecodedStringJpg chain - else S.put $ BoolState (idx - 1) v chain - return val - -getNextIntJpg :: Int -> BoolReader s Int32 -{-# INLINE getNextIntJpg #-} -getNextIntJpg = go 0 where - go !acc !0 = return acc - go !acc !n = do - BoolState idx v chain <- S.get - let !leftBits = 1 + fromIntegral idx - if n >= leftBits then do - setDecodedStringJpg chain - let !remaining = n - leftBits - !mask = (1 `unsafeShiftL` leftBits) - 1 - !finalV = fromIntegral v .&. mask - !theseBits = finalV `unsafeShiftL` remaining - go (acc .|. theseBits) remaining - else do - let !remaining = leftBits - n - !mask = (1 `unsafeShiftL` n) - 1 - !finalV = fromIntegral v `unsafeShiftR` remaining - S.put $ BoolState (fromIntegral remaining - 1) v chain - return $ (finalV .&. mask) .|. acc - - -setDecodedStringMSB :: B.ByteString -> BoolReader s () -setDecodedStringMSB str = case B.uncons str of - Nothing -> S.put $ BoolState 8 0 B.empty - Just (v, rest) -> S.put $ BoolState 8 v rest - - -{-# INLINE getNextBitsMSBFirst #-} -getNextBitsMSBFirst :: Int -> BoolReader s Word32 -getNextBitsMSBFirst requested = go 0 requested where - go :: Word32 -> Int -> BoolReader s Word32 - go !acc !0 = return acc - go !acc !n = do - BoolState idx v chain <- S.get - let !leftBits = fromIntegral idx - if n >= leftBits then do - setDecodedStringMSB chain - let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits) - go (acc .|. theseBits) (n - leftBits) - else do - let !remaining = leftBits - n - !mask = (1 `unsafeShiftL` remaining) - 1 - S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain - return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc - -{-# INLINE getNextBitsLSBFirst #-} -getNextBitsLSBFirst :: Int -> BoolReader s Word32 -getNextBitsLSBFirst count = aux 0 count - where aux acc 0 = return acc - aux acc n = do - bit <- getNextBit - let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n)) - | otherwise = acc - aux nextVal (n - 1) - -{-# INLINE getNextBit #-} -getNextBit :: BoolReader s Bool -getNextBit = do - BoolState idx v chain <- S.get - let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 - if idx == 7 - then setDecodedString chain - else S.put $ BoolState (idx + 1) v chain - return val - --- | Bitify a list of things to decode. Handle Jpeg escape --- code (0xFF 0x00), thus should be only used in JPEG decoding. -setDecodedStringJpg :: B.ByteString -> BoolReader s () -setDecodedStringJpg str = case B.uncons str of - Nothing -> S.put $ BoolState 7 0 B.empty - Just (0xFF, rest) -> case B.uncons rest of - Nothing -> S.put $ BoolState 7 0 B.empty - Just (0x00, afterMarker) -> -- trace "00" $ - S.put $ BoolState 7 0xFF afterMarker - Just (_ , afterMarker) -> setDecodedStringJpg afterMarker - Just (v, rest) -> - S.put $ BoolState 7 v rest - --------------------------------------------------- ----- Writer --------------------------------------------------- -defaultBufferSize :: Int -defaultBufferSize = 256 * 1024 - -data BoolWriteStateRef s = BoolWriteStateRef - { bwsCurrBuffer :: STRef s (M.MVector s Word8) - , bwsBufferList :: STRef s [B.ByteString] - , bwsWrittenWords :: STRef s Int - , bwsBitAcc :: STRef s Word8 - , bwsBitReaded :: STRef s Int - } - -newWriteStateRef :: ST s (BoolWriteStateRef s) -newWriteStateRef = do - origMv <- M.new defaultBufferSize - BoolWriteStateRef <$> newSTRef origMv - <*> newSTRef [] - <*> newSTRef 0 - <*> newSTRef 0 - <*> newSTRef 0 - -finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString -finalizeBoolWriter st = do - forceBufferFlushing' st - L.fromChunks <$> readSTRef (bwsBufferList st) - -forceBufferFlushing' :: BoolWriteStateRef s -> ST s () -forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef - , bwsWrittenWords = countRef - , bwsBufferList = lstRef - }) = do - vec <- readSTRef vecRef - count <- readSTRef countRef - lst <- readSTRef lstRef - - nmv <- M.new defaultBufferSize - str <- byteStringFromVector vec count - - writeSTRef vecRef nmv - writeSTRef lstRef $ lst ++ [str] - writeSTRef countRef 0 - -flushCurrentBuffer' :: BoolWriteStateRef s -> ST s () -flushCurrentBuffer' st = do - count <- readSTRef $ bwsWrittenWords st - when (count >= defaultBufferSize) - (forceBufferFlushing' st) - -byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString -byteStringFromVector vec size = do - frozen <- VS.unsafeFreeze vec - return $ blitVector frozen 0 size - -setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s () -{-# INLINE setBitCount' #-} -setBitCount' st acc count = do - writeSTRef (bwsBitAcc st) acc - writeSTRef (bwsBitReaded st) count - -resetBitCount' :: BoolWriteStateRef s -> ST s () -{-# INLINE resetBitCount' #-} -resetBitCount' st = setBitCount' st 0 0 - -pushByte' :: BoolWriteStateRef s -> Word8 -> ST s () -{-# INLINE pushByte' #-} -pushByte' st v = do - flushCurrentBuffer' st - idx <- readSTRef (bwsWrittenWords st) - vec <- readSTRef (bwsCurrBuffer st) - M.write vec idx v - writeSTRef (bwsWrittenWords st) $ idx + 1 - --- | Append some data bits to a Put monad. -writeBits' :: BoolWriteStateRef s - -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB - -> Int -- ^ Number of bit to write from 1 to 32 - -> ST s () -{-# INLINE writeBits' #-} -writeBits' st d c = do - currWord <- readSTRef $ bwsBitAcc st - currCount <- readSTRef $ bwsBitReaded st - serialize d c currWord currCount - where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00 - dumpByte i = pushByte' st i - - serialize bitData bitCount currentWord count - | bitCount + count == 8 = do - resetBitCount' st - dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|. - fromIntegral cleanData) - - | bitCount + count < 8 = - let newVal = currentWord `unsafeShiftL` bitCount - in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount - - | otherwise = - let leftBitCount = 8 - count :: Int - highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32 - prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32 - - nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32 - newData = cleanData .&. nextMask :: Word32 - newCount = bitCount - leftBitCount :: Int - - toWrite = fromIntegral $ prevPart .|. highPart :: Word8 - in dumpByte toWrite >> serialize newData newCount 0 0 - - where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 - cleanData = bitData .&. cleanMask :: Word32 - --- | Append some data bits to a Put monad. -writeBitsGif :: BoolWriteStateRef s - -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB - -> Int -- ^ Number of bit to write from 1 to 32 - -> ST s () -{-# INLINE writeBitsGif #-} -writeBitsGif st d c = do - currWord <- readSTRef $ bwsBitAcc st - currCount <- readSTRef $ bwsBitReaded st - serialize d c currWord currCount - where dumpByte = pushByte' st - - serialize bitData bitCount currentWord count - | bitCount + count == 8 = do - resetBitCount' st - dumpByte (fromIntegral $ currentWord .|. - (fromIntegral cleanData `unsafeShiftL` count)) - - | bitCount + count < 8 = - let newVal = fromIntegral cleanData `unsafeShiftL` count - in setBitCount' st (newVal .|. currentWord) $ count + bitCount - - | otherwise = - let leftBitCount = 8 - count :: Int - newData = cleanData `unsafeShiftR` leftBitCount :: Word32 - newCount = bitCount - leftBitCount :: Int - toWrite = fromIntegral $ fromIntegral currentWord - .|. (cleanData `unsafeShiftL` count) :: Word8 - in dumpByte toWrite >> serialize newData newCount 0 0 - - where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 - cleanData = bitData .&. cleanMask :: Word32 - -{-# ANN module "HLint: ignore Reduce duplication" #-} - +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- | This module implement helper functions to read & write data +-- at bits level. +module Codec.Picture.BitWriter( BoolReader + , emptyBoolState + , BoolState + , byteAlignJpg + , getNextBitsLSBFirst + , getNextBitsMSBFirst + , getNextBitJpg + , getNextIntJpg + , setDecodedString + , setDecodedStringMSB + , setDecodedStringJpg + , runBoolReader + + , BoolWriteStateRef + , newWriteStateRef + , finalizeBoolWriter + , writeBits' + , writeBitsGif + + , initBoolState + , initBoolStateJpg + , execBoolReader + , runBoolReaderWith + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Data.STRef +import Control.Monad( when ) +import Control.Monad.ST( ST ) +import qualified Control.Monad.Trans.State.Strict as S +import Data.Int ( Int32 ) +import Data.Word( Word8, Word32 ) +import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL ) + +import Codec.Picture.VectorByteConversion( blitVector ) +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.Vector.Storable as VS +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + + +-------------------------------------------------- +---- Reader +-------------------------------------------------- +-- | Current bit index, current value, string +data BoolState = BoolState {-# UNPACK #-} !Int + {-# UNPACK #-} !Word8 + !B.ByteString + +emptyBoolState :: BoolState +emptyBoolState = BoolState (-1) 0 B.empty + +-- | Type used to read bits +type BoolReader s a = S.StateT BoolState (ST s) a + +runBoolReader :: BoolReader s a -> ST s a +runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty + +runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState) +runBoolReaderWith st action = S.runStateT action st + +execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState +execBoolReader st reader = S.execStateT reader st + +initBoolState :: B.ByteString -> BoolState +initBoolState str = case B.uncons str of + Nothing -> BoolState 0 0 B.empty + Just (v, rest) -> BoolState 0 v rest + +initBoolStateJpg :: B.ByteString -> BoolState +initBoolStateJpg str = + case B.uncons str of + Nothing -> BoolState 0 0 B.empty + Just (0xFF, rest) -> case B.uncons rest of + Nothing -> BoolState 7 0 B.empty + Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker + Just (_ , afterMarker) -> initBoolStateJpg afterMarker + Just (v, rest) -> BoolState 7 v rest + +-- | Bitify a list of things to decode. +setDecodedString :: B.ByteString -> BoolReader s () +setDecodedString str = case B.uncons str of + Nothing -> S.put $ BoolState 0 0 B.empty + Just (v, rest) -> S.put $ BoolState 0 v rest + +-- | Drop all bit until the bit of indice 0, usefull to parse restart +-- marker, as they are byte aligned, but Huffman might not. +byteAlignJpg :: BoolReader s () +byteAlignJpg = do + BoolState idx _ chain <- S.get + when (idx /= 7) (setDecodedStringJpg chain) + +getNextBitJpg :: BoolReader s Bool +{-# INLINE getNextBitJpg #-} +getNextBitJpg = do + BoolState idx v chain <- S.get + let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 + if idx == 0 + then setDecodedStringJpg chain + else S.put $ BoolState (idx - 1) v chain + return val + +getNextIntJpg :: Int -> BoolReader s Int32 +{-# INLINE getNextIntJpg #-} +getNextIntJpg = go 0 where + go !acc !0 = return acc + go !acc !n = do + BoolState idx v chain <- S.get + let !leftBits = 1 + fromIntegral idx + if n >= leftBits then do + setDecodedStringJpg chain + let !remaining = n - leftBits + !mask = (1 `unsafeShiftL` leftBits) - 1 + !finalV = fromIntegral v .&. mask + !theseBits = finalV `unsafeShiftL` remaining + go (acc .|. theseBits) remaining + else do + let !remaining = leftBits - n + !mask = (1 `unsafeShiftL` n) - 1 + !finalV = fromIntegral v `unsafeShiftR` remaining + S.put $ BoolState (fromIntegral remaining - 1) v chain + return $ (finalV .&. mask) .|. acc + + +setDecodedStringMSB :: B.ByteString -> BoolReader s () +setDecodedStringMSB str = case B.uncons str of + Nothing -> S.put $ BoolState 8 0 B.empty + Just (v, rest) -> S.put $ BoolState 8 v rest + + +{-# INLINE getNextBitsMSBFirst #-} +getNextBitsMSBFirst :: Int -> BoolReader s Word32 +getNextBitsMSBFirst requested = go 0 requested where + go :: Word32 -> Int -> BoolReader s Word32 + go !acc !0 = return acc + go !acc !n = do + BoolState idx v chain <- S.get + let !leftBits = fromIntegral idx + if n >= leftBits then do + setDecodedStringMSB chain + let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits) + go (acc .|. theseBits) (n - leftBits) + else do + let !remaining = leftBits - n + !mask = (1 `unsafeShiftL` remaining) - 1 + S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain + return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc + +{-# INLINE getNextBitsLSBFirst #-} +getNextBitsLSBFirst :: Int -> BoolReader s Word32 +getNextBitsLSBFirst count = aux 0 count + where aux acc 0 = return acc + aux acc n = do + bit <- getNextBit + let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n)) + | otherwise = acc + aux nextVal (n - 1) + +{-# INLINE getNextBit #-} +getNextBit :: BoolReader s Bool +getNextBit = do + BoolState idx v chain <- S.get + let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 + if idx == 7 + then setDecodedString chain + else S.put $ BoolState (idx + 1) v chain + return val + +-- | Bitify a list of things to decode. Handle Jpeg escape +-- code (0xFF 0x00), thus should be only used in JPEG decoding. +setDecodedStringJpg :: B.ByteString -> BoolReader s () +setDecodedStringJpg str = case B.uncons str of + Nothing -> S.put $ BoolState 7 0 B.empty + Just (0xFF, rest) -> case B.uncons rest of + Nothing -> S.put $ BoolState 7 0 B.empty + Just (0x00, afterMarker) -> -- trace "00" $ + S.put $ BoolState 7 0xFF afterMarker + Just (_ , afterMarker) -> setDecodedStringJpg afterMarker + Just (v, rest) -> + S.put $ BoolState 7 v rest + +-------------------------------------------------- +---- Writer +-------------------------------------------------- +defaultBufferSize :: Int +defaultBufferSize = 256 * 1024 + +data BoolWriteStateRef s = BoolWriteStateRef + { bwsCurrBuffer :: STRef s (M.MVector s Word8) + , bwsBufferList :: STRef s [B.ByteString] + , bwsWrittenWords :: STRef s Int + , bwsBitAcc :: STRef s Word8 + , bwsBitReaded :: STRef s Int + } + +newWriteStateRef :: ST s (BoolWriteStateRef s) +newWriteStateRef = do + origMv <- M.new defaultBufferSize + BoolWriteStateRef <$> newSTRef origMv + <*> newSTRef [] + <*> newSTRef 0 + <*> newSTRef 0 + <*> newSTRef 0 + +finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString +finalizeBoolWriter st = do + flushLeftBits' st + forceBufferFlushing' st + L.fromChunks <$> readSTRef (bwsBufferList st) + +forceBufferFlushing' :: BoolWriteStateRef s -> ST s () +forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef + , bwsWrittenWords = countRef + , bwsBufferList = lstRef + }) = do + vec <- readSTRef vecRef + count <- readSTRef countRef + lst <- readSTRef lstRef + + nmv <- M.new defaultBufferSize + str <- byteStringFromVector vec count + + writeSTRef vecRef nmv + writeSTRef lstRef $ lst ++ [str] + writeSTRef countRef 0 + +flushCurrentBuffer' :: BoolWriteStateRef s -> ST s () +flushCurrentBuffer' st = do + count <- readSTRef $ bwsWrittenWords st + when (count >= defaultBufferSize) + (forceBufferFlushing' st) + +byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString +byteStringFromVector vec size = do + frozen <- VS.unsafeFreeze vec + return $ blitVector frozen 0 size + +setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s () +{-# INLINE setBitCount' #-} +setBitCount' st acc count = do + writeSTRef (bwsBitAcc st) acc + writeSTRef (bwsBitReaded st) count + +resetBitCount' :: BoolWriteStateRef s -> ST s () +{-# INLINE resetBitCount' #-} +resetBitCount' st = setBitCount' st 0 0 + +pushByte' :: BoolWriteStateRef s -> Word8 -> ST s () +{-# INLINE pushByte' #-} +pushByte' st v = do + flushCurrentBuffer' st + idx <- readSTRef (bwsWrittenWords st) + vec <- readSTRef (bwsCurrBuffer st) + M.write vec idx v + writeSTRef (bwsWrittenWords st) $ idx + 1 + +flushLeftBits' :: BoolWriteStateRef s -> ST s () +flushLeftBits' st = do + currCount <- readSTRef $ bwsBitReaded st + when (currCount > 0) $ do + currWord <- readSTRef $ bwsBitAcc st + pushByte' st $ currWord `unsafeShiftL` (8 - currCount) + +-- | Append some data bits to a Put monad. +writeBits' :: BoolWriteStateRef s + -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB + -> Int -- ^ Number of bit to write from 1 to 32 + -> ST s () +{-# INLINE writeBits' #-} +writeBits' st d c = do + currWord <- readSTRef $ bwsBitAcc st + currCount <- readSTRef $ bwsBitReaded st + serialize d c currWord currCount + where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00 + dumpByte i = pushByte' st i + + serialize bitData bitCount currentWord count + | bitCount + count == 8 = do + resetBitCount' st + dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|. + fromIntegral cleanData) + + | bitCount + count < 8 = + let newVal = currentWord `unsafeShiftL` bitCount + in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount + + | otherwise = + let leftBitCount = 8 - count :: Int + highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32 + prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32 + + nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32 + newData = cleanData .&. nextMask :: Word32 + newCount = bitCount - leftBitCount :: Int + + toWrite = fromIntegral $ prevPart .|. highPart :: Word8 + in dumpByte toWrite >> serialize newData newCount 0 0 + + where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 + cleanData = bitData .&. cleanMask :: Word32 + +-- | Append some data bits to a Put monad. +writeBitsGif :: BoolWriteStateRef s + -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB + -> Int -- ^ Number of bit to write from 1 to 32 + -> ST s () +{-# INLINE writeBitsGif #-} +writeBitsGif st d c = do + currWord <- readSTRef $ bwsBitAcc st + currCount <- readSTRef $ bwsBitReaded st + serialize d c currWord currCount + where dumpByte = pushByte' st + + serialize bitData bitCount currentWord count + | bitCount + count == 8 = do + resetBitCount' st + dumpByte (fromIntegral $ currentWord .|. + (fromIntegral cleanData `unsafeShiftL` count)) + + | bitCount + count < 8 = + let newVal = fromIntegral cleanData `unsafeShiftL` count + in setBitCount' st (newVal .|. currentWord) $ count + bitCount + + | otherwise = + let leftBitCount = 8 - count :: Int + newData = cleanData `unsafeShiftR` leftBitCount :: Word32 + newCount = bitCount - leftBitCount :: Int + toWrite = fromIntegral $ fromIntegral currentWord + .|. (cleanData `unsafeShiftL` count) :: Word8 + in dumpByte toWrite >> serialize newData newCount 0 0 + + where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 + cleanData = bitData .&. cleanMask :: Word32 + +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -888,8 +888,8 @@ } instance JpgEncodable PixelRGB8 where - additionalBlocks _ = [] where - _adobe14 = JpgAdobeApp14 + additionalBlocks _ = [JpgAdobeAPP14 adobe14] where + adobe14 = JpgAdobeApp14 { _adobeDctVersion = 100 , _adobeFlag0 = 0 , _adobeFlag1 = 0 diff --git a/src/Codec/Picture/Jpg/Types.hs b/src/Codec/Picture/Jpg/Types.hs --- a/src/Codec/Picture/Jpg/Types.hs +++ b/src/Codec/Picture/Jpg/Types.hs @@ -1,737 +1,729 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Types( MutableMacroBlock - , createEmptyMutableMacroBlock - , printMacroBlock - , printPureMacroBlock - , DcCoefficient - , JpgImage( .. ) - , JpgComponent( .. ) - , JpgFrameHeader( .. ) - , JpgFrame( .. ) - , JpgFrameKind( .. ) - , JpgScanHeader( .. ) - , JpgQuantTableSpec( .. ) - , JpgHuffmanTableSpec( .. ) - , JpgImageKind( .. ) - , JpgScanSpecification( .. ) - , JpgColorSpace( .. ) - , AdobeTransform( .. ) - , JpgAdobeApp14( .. ) - , JpgJFIFApp0( .. ) - , JFifUnit( .. ) - , calculateSize - , dctBlockSize - ) where - - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<*>), (<$>) ) -#endif - -import Control.Monad( when, replicateM, forM, forM_, unless ) -import Control.Monad.ST( ST ) -import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) -import Foreign.Storable ( Storable ) -import Data.Vector.Unboxed( (!) ) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L - -import Data.Int( Int16 ) -import Data.Word(Word8, Word16 ) -import Data.Binary( Binary(..) ) - -import Data.Binary.Get( Get - , getWord8 - , getWord16be - , getByteString - , skip - , bytesRead - ) - -import Data.Binary.Put( Put - , putWord8 - , putWord16be - , putLazyByteString - , putByteString - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Jpg.DefaultTable -import Codec.Picture.Tiff.Types - -{-import Debug.Trace-} -import Text.Printf - --- | Type only used to make clear what kind of integer we are carrying --- Might be transformed into newtype in the future -type DcCoefficient = Int16 - --- | Macroblock that can be transformed. -type MutableMacroBlock s a = M.STVector s a - -data JpgFrameKind = - JpgBaselineDCTHuffman - | JpgExtendedSequentialDCTHuffman - | JpgProgressiveDCTHuffman - | JpgLosslessHuffman - | JpgDifferentialSequentialDCTHuffman - | JpgDifferentialProgressiveDCTHuffman - | JpgDifferentialLosslessHuffman - | JpgExtendedSequentialArithmetic - | JpgProgressiveDCTArithmetic - | JpgLosslessArithmetic - | JpgDifferentialSequentialDCTArithmetic - | JpgDifferentialProgressiveDCTArithmetic - | JpgDifferentialLosslessArithmetic - | JpgQuantizationTable - | JpgHuffmanTableMarker - | JpgStartOfScan - | JpgEndOfImage - | JpgAppSegment Word8 - | JpgExtensionSegment Word8 - - | JpgRestartInterval - | JpgRestartIntervalEnd Word8 - deriving (Eq, Show) - -data JpgFrame = - JpgAppFrame !Word8 B.ByteString - | JpgAdobeAPP14 !JpgAdobeApp14 - | JpgJFIF !JpgJFIFApp0 - | JpgExif ![ImageFileDirectory] - | JpgExtension !Word8 B.ByteString - | JpgQuantTable ![JpgQuantTableSpec] - | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] - | JpgScanBlob !JpgScanHeader !L.ByteString - | JpgScans !JpgFrameKind !JpgFrameHeader - | JpgIntervalRestart !Word16 - deriving Show - -data JpgColorSpace - = JpgColorSpaceYCbCr - | JpgColorSpaceYCC - | JpgColorSpaceY - | JpgColorSpaceYA - | JpgColorSpaceYCCA - | JpgColorSpaceYCCK - | JpgColorSpaceCMYK - | JpgColorSpaceRGB - | JpgColorSpaceRGBA - deriving Show - -data AdobeTransform - = AdobeUnknown -- ^ Value 0 - | AdobeYCbCr -- ^ value 1 - | AdobeYCck -- ^ value 2 - deriving Show - -data JpgAdobeApp14 = JpgAdobeApp14 - { _adobeDctVersion :: !Word16 - , _adobeFlag0 :: !Word16 - , _adobeFlag1 :: !Word16 - , _adobeTransform :: !AdobeTransform - } - deriving Show - --- | Size: 1 -data JFifUnit - = JFifUnitUnknown -- ^ 0 - | JFifPixelsPerInch -- ^ 1 - | JFifPixelsPerCentimeter -- ^ 2 - deriving Show - -instance Binary JFifUnit where - put v = putWord8 $ case v of - JFifUnitUnknown -> 0 - JFifPixelsPerInch -> 1 - JFifPixelsPerCentimeter -> 2 - get = do - v <- getWord8 - pure $ case v of - 0 -> JFifUnitUnknown - 1 -> JFifPixelsPerInch - 2 -> JFifPixelsPerCentimeter - _ -> JFifUnitUnknown - -data JpgJFIFApp0 = JpgJFIFApp0 - { _jfifUnit :: !JFifUnit - , _jfifDpiX :: !Word16 - , _jfifDpiY :: !Word16 - , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int) - } - deriving Show - -instance Binary JpgJFIFApp0 where - get = do - sig <- getByteString 5 - when (sig /= BC.pack "JFIF\0") $ - fail "Invalid JFIF signature" - major <- getWord8 - minor <- getWord8 - when (major /= 1 && minor > 2) $ - fail "Unrecognize JFIF version" - unit <- get - dpiX <- getWord16be - dpiY <- getWord16be - w <- getWord8 - h <- getWord8 - let pxCount = 3 * w * h - img <- case pxCount of - 0 -> return Nothing - _ -> return Nothing - return $ JpgJFIFApp0 - { _jfifUnit = unit - , _jfifDpiX = dpiX - , _jfifDpiY = dpiY - , _jfifThumbnail = img - } - - - put jfif = do - putByteString $ BC.pack "JFIF\0" -- 5 - putWord8 1 -- 1 6 - putWord8 2 -- 1 7 - put $ _jfifUnit jfif -- 1 8 - putWord16be $ _jfifDpiX jfif -- 2 10 - putWord16be $ _jfifDpiY jfif -- 2 12 - putWord8 0 -- 1 13 - putWord8 0 -- 1 14 - -{-Thumbnail width (tw) 1 Horizontal size of embedded JFIF thumbnail in pixels-} -{-Thumbnail height (th) 1 Vertical size of embedded JFIF thumbnail in pixels-} -{-Thumbnail data 3 × tw × th Uncompressed 24 bit RGB raster thumbnail-} - -instance Binary AdobeTransform where - put v = case v of - AdobeUnknown -> putWord8 0 - AdobeYCbCr -> putWord8 1 - AdobeYCck -> putWord8 2 - - get = do - v <- getWord8 - pure $ case v of - 0 -> AdobeUnknown - 1 -> AdobeYCbCr - 2 -> AdobeYCck - _ -> AdobeUnknown - -instance Binary JpgAdobeApp14 where - get = do - let sig = BC.pack "Adobe" - fileSig <- getByteString 5 - when (fileSig /= sig) $ - fail "Invalid Adobe APP14 marker" - version <- getWord16be - when (version /= 100) $ - fail $ "Invalid Adobe APP14 version " ++ show version - JpgAdobeApp14 version - <$> getWord16be - <*> getWord16be <*> get - - put (JpgAdobeApp14 v f0 f1 t) = do - putByteString $ BC.pack "Adobe" - putWord16be v - putWord16be f0 - putWord16be f1 - put t - - -data JpgFrameHeader = JpgFrameHeader - { jpgFrameHeaderLength :: !Word16 - , jpgSamplePrecision :: !Word8 - , jpgHeight :: !Word16 - , jpgWidth :: !Word16 - , jpgImageComponentCount :: !Word8 - , jpgComponents :: ![JpgComponent] - } - deriving Show - - -instance SizeCalculable JpgFrameHeader where - calculateSize hdr = 2 + 1 + 2 + 2 + 1 - + sum [calculateSize c | c <- jpgComponents hdr] - -data JpgComponent = JpgComponent - { componentIdentifier :: !Word8 - -- | Stored with 4 bits - , horizontalSamplingFactor :: !Word8 - -- | Stored with 4 bits - , verticalSamplingFactor :: !Word8 - , quantizationTableDest :: !Word8 - } - deriving Show - -instance SizeCalculable JpgComponent where - calculateSize _ = 3 - -data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } - deriving Show - -data JpgScanSpecification = JpgScanSpecification - { componentSelector :: !Word8 - -- | Encoded as 4 bits - , dcEntropyCodingTable :: !Word8 - -- | Encoded as 4 bits - , acEntropyCodingTable :: !Word8 - - } - deriving Show - -instance SizeCalculable JpgScanSpecification where - calculateSize _ = 2 - -data JpgScanHeader = JpgScanHeader - { scanLength :: !Word16 - , scanComponentCount :: !Word8 - , scans :: [JpgScanSpecification] - - -- | (begin, end) - , spectralSelection :: (Word8, Word8) - - -- | Encoded as 4 bits - , successiveApproxHigh :: !Word8 - - -- | Encoded as 4 bits - , successiveApproxLow :: !Word8 - } - deriving Show - -instance SizeCalculable JpgScanHeader where - calculateSize hdr = 2 + 1 - + sum [calculateSize c | c <- scans hdr] - + 2 - + 1 - -data JpgQuantTableSpec = JpgQuantTableSpec - { -- | Stored on 4 bits - quantPrecision :: !Word8 - - -- | Stored on 4 bits - , quantDestination :: !Word8 - - , quantTable :: MacroBlock Int16 - } - deriving Show - -class SizeCalculable a where - calculateSize :: a -> Int - --- | Type introduced only to avoid some typeclass overlapping --- problem -newtype TableList a = TableList [a] - -instance (SizeCalculable a, Binary a) => Binary (TableList a) where - put (TableList lst) = do - putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 - mapM_ put lst - - get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) - where innerParse :: Int -> Get [a] - innerParse 0 = return [] - innerParse size = do - onStart <- fromIntegral <$> bytesRead - table <- get - onEnd <- fromIntegral <$> bytesRead - (table :) <$> innerParse (size - (onEnd - onStart)) - -instance SizeCalculable JpgQuantTableSpec where - calculateSize table = - 1 + (fromIntegral (quantPrecision table) + 1) * 64 - -instance Binary JpgQuantTableSpec where - put table = do - let precision = quantPrecision table - put4BitsOfEach precision (quantDestination table) - forM_ (VS.toList $ quantTable table) $ \coeff -> - if precision == 0 then putWord8 $ fromIntegral coeff - else putWord16be $ fromIntegral coeff - - get = do - (precision, dest) <- get4BitOfEach - coeffs <- replicateM 64 $ if precision == 0 - then fromIntegral <$> getWord8 - else fromIntegral <$> getWord16be - return JpgQuantTableSpec - { quantPrecision = precision - , quantDestination = dest - , quantTable = VS.fromListN 64 coeffs - } - -data JpgHuffmanTableSpec = JpgHuffmanTableSpec - { -- | 0 : DC, 1 : AC, stored on 4 bits - huffmanTableClass :: !DctComponent - -- | Stored on 4 bits - , huffmanTableDest :: !Word8 - - , huffSizes :: !(VU.Vector Word8) - , huffCodes :: !(V.Vector (VU.Vector Word8)) - } - deriving Show - -instance SizeCalculable JpgHuffmanTableSpec where - calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] - -instance Binary JpgHuffmanTableSpec where - put table = do - let classVal = if huffmanTableClass table == DcComponent - then 0 else 1 - put4BitsOfEach classVal $ huffmanTableDest table - mapM_ put . VU.toList $ huffSizes table - forM_ [0 .. 15] $ \i -> - when (huffSizes table ! i /= 0) - (let elements = VU.toList $ huffCodes table V.! i - in mapM_ put elements) - - get = do - (huffClass, huffDest) <- get4BitOfEach - sizes <- replicateM 16 getWord8 - codes <- forM sizes $ \s -> - VU.replicateM (fromIntegral s) getWord8 - return JpgHuffmanTableSpec - { huffmanTableClass = - if huffClass == 0 then DcComponent else AcComponent - , huffmanTableDest = huffDest - , huffSizes = VU.fromListN 16 sizes - , huffCodes = V.fromListN 16 codes - } - -instance Binary JpgImage where - put (JpgImage { jpgFrame = frames }) = - putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames - >> putWord8 0xFF >> putWord8 0xD9 - - get = do - let startOfImageMarker = 0xD8 - -- endOfImageMarker = 0xD9 - checkMarker commonMarkerFirstByte startOfImageMarker - eatUntilCode - frames <- parseFrames - {-checkMarker commonMarkerFirstByte endOfImageMarker-} - return JpgImage { jpgFrame = frames } - -eatUntilCode :: Get () -eatUntilCode = do - code <- getWord8 - unless (code == 0xFF) eatUntilCode - -takeCurrentFrame :: Get B.ByteString -takeCurrentFrame = do - size <- getWord16be - getByteString (fromIntegral size - 2) - -putFrame :: JpgFrame -> Put -putFrame (JpgAdobeAPP14 adobe) = - put (JpgAppSegment 14) >> putWord16be 14 >> put adobe -putFrame (JpgJFIF jfif) = - put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif -putFrame (JpgExif _exif) = - return () -- TODO - {-put (JpgAppSegment 0) >> put exif-} -putFrame (JpgAppFrame appCode str) = - put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str -putFrame (JpgExtension appCode str) = - put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str -putFrame (JpgQuantTable tables) = - put JpgQuantizationTable >> put (TableList tables) -putFrame (JpgHuffmanTable tables) = - put JpgHuffmanTableMarker >> put (TableList $ map fst tables) -putFrame (JpgIntervalRestart size) = - put JpgRestartInterval >> put (RestartInterval size) -putFrame (JpgScanBlob hdr blob) = do - put JpgStartOfScan - put hdr - putLazyByteString blob - putWord8 0 -- AKA the libjpeg pleaser, for some unknown reason - -- libjpeg raise a warning "invalid end of data segment". - -- so dumbly pad, seems to make the warning go away (and - -- I don't want to invest that much time looking for that). - -- - -- Ok this is a crummy fix.... -putFrame (JpgScans kind hdr) = - put kind >> put hdr - --------------------------------------------------- ----- Serialization instances --------------------------------------------------- -commonMarkerFirstByte :: Word8 -commonMarkerFirstByte = 0xFF - -checkMarker :: Word8 -> Word8 -> Get () -checkMarker b1 b2 = do - rb1 <- getWord8 - rb2 <- getWord8 - when (rb1 /= b1 || rb2 /= b2) - (fail "Invalid marker used") - -extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString) -extractScanContent str = aux 0 - where maxi = fromIntegral $ L.length str - 1 - - aux n | n >= maxi = (str, L.empty) - | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str - | otherwise = aux (n + 1) - where v = str `L.index` n - vNext = str `L.index` (n + 1) - isReset = 0xD0 <= vNext && vNext <= 0xD7 - -parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseAdobe14 str lst = go where - go = case runGetStrict get str of - Left _err -> lst - Right app14 -> JpgAdobeAPP14 app14 : lst - --- | Parse JFIF or JFXX information. Right now only JFIF. -parseJF__ :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseJF__ str lst = go where - go = case runGetStrict get str of - Left _err -> lst - Right jfif -> JpgJFIF jfif : lst - -parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseExif str lst - | exifHeader `B.isPrefixOf` str = go - | otherwise = lst - where - exifHeader = BC.pack "Exif\0\0" - tiff = B.drop (B.length exifHeader) str - go = case runGetStrict (getP tiff) tiff of - Left _err -> lst - Right (_hdr :: TiffHeader, ifds) -> JpgExif ifds : lst - -parseFrames :: Get [JpgFrame] -parseFrames = do - kind <- get - let parseNextFrame = do - word <- getWord8 - when (word /= 0xFF) $ do - readedData <- bytesRead - fail $ "Invalid Frame marker (" ++ show word - ++ ", bytes read : " ++ show readedData ++ ")" - parseFrames - - case kind of - JpgEndOfImage -> return [] - JpgAppSegment 0 -> - parseJF__ <$> takeCurrentFrame <*> parseNextFrame - JpgAppSegment 1 -> - parseExif <$> takeCurrentFrame <*> parseNextFrame - JpgAppSegment 14 -> - parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame - JpgAppSegment c -> - (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame - JpgExtensionSegment c -> - (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame - JpgQuantizationTable -> - (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame - JpgRestartInterval -> - (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame - JpgHuffmanTableMarker -> - (\(TableList huffTables) lst -> - JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) - <$> get <*> parseNextFrame - JpgStartOfScan -> - (\frm imgData -> - let (d, other) = extractScanContent imgData - in - case runGet parseFrames (L.drop 1 other) of - Left _ -> [JpgScanBlob frm d] - Right lst -> JpgScanBlob frm d : lst - ) <$> get <*> getRemainingLazyBytes - - _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame - -buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree -buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList - -secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 -secondStartOfFrameByteOfKind = aux - where - aux JpgBaselineDCTHuffman = 0xC0 - aux JpgExtendedSequentialDCTHuffman = 0xC1 - aux JpgProgressiveDCTHuffman = 0xC2 - aux JpgLosslessHuffman = 0xC3 - aux JpgDifferentialSequentialDCTHuffman = 0xC5 - aux JpgDifferentialProgressiveDCTHuffman = 0xC6 - aux JpgDifferentialLosslessHuffman = 0xC7 - aux JpgExtendedSequentialArithmetic = 0xC9 - aux JpgProgressiveDCTArithmetic = 0xCA - aux JpgLosslessArithmetic = 0xCB - aux JpgHuffmanTableMarker = 0xC4 - aux JpgDifferentialSequentialDCTArithmetic = 0xCD - aux JpgDifferentialProgressiveDCTArithmetic = 0xCE - aux JpgDifferentialLosslessArithmetic = 0xCF - aux JpgEndOfImage = 0xD9 - aux JpgQuantizationTable = 0xDB - aux JpgStartOfScan = 0xDA - aux JpgRestartInterval = 0xDD - aux (JpgRestartIntervalEnd v) = v - aux (JpgAppSegment a) = (a + 0xE0) - aux (JpgExtensionSegment a) = a - -data JpgImageKind = BaseLineDCT | ProgressiveDCT - -instance Binary JpgFrameKind where - put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) - get = do - -- no lookahead :( - {-word <- getWord8-} - word2 <- getWord8 - return $ case word2 of - 0xC0 -> JpgBaselineDCTHuffman - 0xC1 -> JpgExtendedSequentialDCTHuffman - 0xC2 -> JpgProgressiveDCTHuffman - 0xC3 -> JpgLosslessHuffman - 0xC4 -> JpgHuffmanTableMarker - 0xC5 -> JpgDifferentialSequentialDCTHuffman - 0xC6 -> JpgDifferentialProgressiveDCTHuffman - 0xC7 -> JpgDifferentialLosslessHuffman - 0xC9 -> JpgExtendedSequentialArithmetic - 0xCA -> JpgProgressiveDCTArithmetic - 0xCB -> JpgLosslessArithmetic - 0xCD -> JpgDifferentialSequentialDCTArithmetic - 0xCE -> JpgDifferentialProgressiveDCTArithmetic - 0xCF -> JpgDifferentialLosslessArithmetic - 0xD9 -> JpgEndOfImage - 0xDA -> JpgStartOfScan - 0xDB -> JpgQuantizationTable - 0xDD -> JpgRestartInterval - a | a >= 0xF0 -> JpgExtensionSegment a - | a >= 0xE0 -> JpgAppSegment (a - 0xE0) - | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a - | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") - -put4BitsOfEach :: Word8 -> Word8 -> Put -put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b - -get4BitOfEach :: Get (Word8, Word8) -get4BitOfEach = do - val <- get - return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF) - -newtype RestartInterval = RestartInterval Word16 - -instance Binary RestartInterval where - put (RestartInterval i) = putWord16be 4 >> putWord16be i - get = do - size <- getWord16be - when (size /= 4) (fail "Invalid jpeg restart interval size") - RestartInterval <$> getWord16be - -instance Binary JpgComponent where - get = do - ident <- getWord8 - (horiz, vert) <- get4BitOfEach - quantTableIndex <- getWord8 - return JpgComponent - { componentIdentifier = ident - , horizontalSamplingFactor = horiz - , verticalSamplingFactor = vert - , quantizationTableDest = quantTableIndex - } - put v = do - put $ componentIdentifier v - put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v - put $ quantizationTableDest v - -instance Binary JpgFrameHeader where - get = do - beginOffset <- fromIntegral <$> bytesRead - frmHLength <- getWord16be - samplePrec <- getWord8 - h <- getWord16be - w <- getWord16be - compCount <- getWord8 - components <- replicateM (fromIntegral compCount) get - endOffset <- fromIntegral <$> bytesRead - when (beginOffset - endOffset < fromIntegral frmHLength) - (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) - return JpgFrameHeader - { jpgFrameHeaderLength = frmHLength - , jpgSamplePrecision = samplePrec - , jpgHeight = h - , jpgWidth = w - , jpgImageComponentCount = compCount - , jpgComponents = components - } - - put v = do - putWord16be $ jpgFrameHeaderLength v - putWord8 $ jpgSamplePrecision v - putWord16be $ jpgHeight v - putWord16be $ jpgWidth v - putWord8 $ jpgImageComponentCount v - mapM_ put $ jpgComponents v - -instance Binary JpgScanSpecification where - put v = do - put $ componentSelector v - put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v - - get = do - compSel <- get - (dc, ac) <- get4BitOfEach - return JpgScanSpecification { - componentSelector = compSel - , dcEntropyCodingTable = dc - , acEntropyCodingTable = ac - } - -instance Binary JpgScanHeader where - get = do - thisScanLength <- getWord16be - compCount <- getWord8 - comp <- replicateM (fromIntegral compCount) get - specBeg <- get - specEnd <- get - (approxHigh, approxLow) <- get4BitOfEach - - return JpgScanHeader { - scanLength = thisScanLength, - scanComponentCount = compCount, - scans = comp, - spectralSelection = (specBeg, specEnd), - successiveApproxHigh = approxHigh, - successiveApproxLow = approxLow - } - - put v = do - putWord16be $ scanLength v - putWord8 $ scanComponentCount v - mapM_ put $ scans v - putWord8 . fst $ spectralSelection v - putWord8 . snd $ spectralSelection v - put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v - -{-# INLINE createEmptyMutableMacroBlock #-} --- | Create a new macroblock with the good array size -createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a) -createEmptyMutableMacroBlock = M.replicate 64 0 - -printMacroBlock :: (Storable a, PrintfArg a) - => MutableMacroBlock s a -> ST s String -printMacroBlock block = pLn 0 - where pLn 64 = return "===============================\n" - pLn i = do - v <- block `M.unsafeRead` i - vn <- pLn (i+1) - return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn - -printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String -printPureMacroBlock block = pLn 0 - where pLn 64 = "===============================\n" - pLn i = str ++ pLn (i + 1) - where str | i `mod` 8 == 0 = printf "\n%5d " v - | otherwise = printf "%5d" v - v = block VS.! i - - -{-# INLINE dctBlockSize #-} -dctBlockSize :: Num a => a -dctBlockSize = 8 +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Types( MutableMacroBlock + , createEmptyMutableMacroBlock + , printMacroBlock + , printPureMacroBlock + , DcCoefficient + , JpgImage( .. ) + , JpgComponent( .. ) + , JpgFrameHeader( .. ) + , JpgFrame( .. ) + , JpgFrameKind( .. ) + , JpgScanHeader( .. ) + , JpgQuantTableSpec( .. ) + , JpgHuffmanTableSpec( .. ) + , JpgImageKind( .. ) + , JpgScanSpecification( .. ) + , JpgColorSpace( .. ) + , AdobeTransform( .. ) + , JpgAdobeApp14( .. ) + , JpgJFIFApp0( .. ) + , JFifUnit( .. ) + , calculateSize + , dctBlockSize + ) where + + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + +import Control.Monad( when, replicateM, forM, forM_, unless ) +import Control.Monad.ST( ST ) +import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) +import Foreign.Storable ( Storable ) +import Data.Vector.Unboxed( (!) ) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L + +import Data.Int( Int16 ) +import Data.Word(Word8, Word16 ) +import Data.Binary( Binary(..) ) + +import Data.Binary.Get( Get + , getWord8 + , getWord16be + , getByteString + , skip + , bytesRead + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16be + , putLazyByteString + , putByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Jpg.DefaultTable +import Codec.Picture.Tiff.Types + +{-import Debug.Trace-} +import Text.Printf + +-- | Type only used to make clear what kind of integer we are carrying +-- Might be transformed into newtype in the future +type DcCoefficient = Int16 + +-- | Macroblock that can be transformed. +type MutableMacroBlock s a = M.STVector s a + +data JpgFrameKind = + JpgBaselineDCTHuffman + | JpgExtendedSequentialDCTHuffman + | JpgProgressiveDCTHuffman + | JpgLosslessHuffman + | JpgDifferentialSequentialDCTHuffman + | JpgDifferentialProgressiveDCTHuffman + | JpgDifferentialLosslessHuffman + | JpgExtendedSequentialArithmetic + | JpgProgressiveDCTArithmetic + | JpgLosslessArithmetic + | JpgDifferentialSequentialDCTArithmetic + | JpgDifferentialProgressiveDCTArithmetic + | JpgDifferentialLosslessArithmetic + | JpgQuantizationTable + | JpgHuffmanTableMarker + | JpgStartOfScan + | JpgEndOfImage + | JpgAppSegment Word8 + | JpgExtensionSegment Word8 + + | JpgRestartInterval + | JpgRestartIntervalEnd Word8 + deriving (Eq, Show) + +data JpgFrame = + JpgAppFrame !Word8 B.ByteString + | JpgAdobeAPP14 !JpgAdobeApp14 + | JpgJFIF !JpgJFIFApp0 + | JpgExif ![ImageFileDirectory] + | JpgExtension !Word8 B.ByteString + | JpgQuantTable ![JpgQuantTableSpec] + | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] + | JpgScanBlob !JpgScanHeader !L.ByteString + | JpgScans !JpgFrameKind !JpgFrameHeader + | JpgIntervalRestart !Word16 + deriving Show + +data JpgColorSpace + = JpgColorSpaceYCbCr + | JpgColorSpaceYCC + | JpgColorSpaceY + | JpgColorSpaceYA + | JpgColorSpaceYCCA + | JpgColorSpaceYCCK + | JpgColorSpaceCMYK + | JpgColorSpaceRGB + | JpgColorSpaceRGBA + deriving Show + +data AdobeTransform + = AdobeUnknown -- ^ Value 0 + | AdobeYCbCr -- ^ value 1 + | AdobeYCck -- ^ value 2 + deriving Show + +data JpgAdobeApp14 = JpgAdobeApp14 + { _adobeDctVersion :: !Word16 + , _adobeFlag0 :: !Word16 + , _adobeFlag1 :: !Word16 + , _adobeTransform :: !AdobeTransform + } + deriving Show + +-- | Size: 1 +data JFifUnit + = JFifUnitUnknown -- ^ 0 + | JFifPixelsPerInch -- ^ 1 + | JFifPixelsPerCentimeter -- ^ 2 + deriving Show + +instance Binary JFifUnit where + put v = putWord8 $ case v of + JFifUnitUnknown -> 0 + JFifPixelsPerInch -> 1 + JFifPixelsPerCentimeter -> 2 + get = do + v <- getWord8 + pure $ case v of + 0 -> JFifUnitUnknown + 1 -> JFifPixelsPerInch + 2 -> JFifPixelsPerCentimeter + _ -> JFifUnitUnknown + +data JpgJFIFApp0 = JpgJFIFApp0 + { _jfifUnit :: !JFifUnit + , _jfifDpiX :: !Word16 + , _jfifDpiY :: !Word16 + , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int) + } + deriving Show + +instance Binary JpgJFIFApp0 where + get = do + sig <- getByteString 5 + when (sig /= BC.pack "JFIF\0") $ + fail "Invalid JFIF signature" + major <- getWord8 + minor <- getWord8 + when (major /= 1 && minor > 2) $ + fail "Unrecognize JFIF version" + unit <- get + dpiX <- getWord16be + dpiY <- getWord16be + w <- getWord8 + h <- getWord8 + let pxCount = 3 * w * h + img <- case pxCount of + 0 -> return Nothing + _ -> return Nothing + return $ JpgJFIFApp0 + { _jfifUnit = unit + , _jfifDpiX = dpiX + , _jfifDpiY = dpiY + , _jfifThumbnail = img + } + + + put jfif = do + putByteString $ BC.pack "JFIF\0" -- 5 + putWord8 1 -- 1 6 + putWord8 2 -- 1 7 + put $ _jfifUnit jfif -- 1 8 + putWord16be $ _jfifDpiX jfif -- 2 10 + putWord16be $ _jfifDpiY jfif -- 2 12 + putWord8 0 -- 1 13 + putWord8 0 -- 1 14 + +{-Thumbnail width (tw) 1 Horizontal size of embedded JFIF thumbnail in pixels-} +{-Thumbnail height (th) 1 Vertical size of embedded JFIF thumbnail in pixels-} +{-Thumbnail data 3 × tw × th Uncompressed 24 bit RGB raster thumbnail-} + +instance Binary AdobeTransform where + put v = case v of + AdobeUnknown -> putWord8 0 + AdobeYCbCr -> putWord8 1 + AdobeYCck -> putWord8 2 + + get = do + v <- getWord8 + pure $ case v of + 0 -> AdobeUnknown + 1 -> AdobeYCbCr + 2 -> AdobeYCck + _ -> AdobeUnknown + +instance Binary JpgAdobeApp14 where + get = do + let sig = BC.pack "Adobe" + fileSig <- getByteString 5 + when (fileSig /= sig) $ + fail "Invalid Adobe APP14 marker" + version <- getWord16be + when (version /= 100) $ + fail $ "Invalid Adobe APP14 version " ++ show version + JpgAdobeApp14 version + <$> getWord16be + <*> getWord16be <*> get + + put (JpgAdobeApp14 v f0 f1 t) = do + putByteString $ BC.pack "Adobe" + putWord16be v + putWord16be f0 + putWord16be f1 + put t + + +data JpgFrameHeader = JpgFrameHeader + { jpgFrameHeaderLength :: !Word16 + , jpgSamplePrecision :: !Word8 + , jpgHeight :: !Word16 + , jpgWidth :: !Word16 + , jpgImageComponentCount :: !Word8 + , jpgComponents :: ![JpgComponent] + } + deriving Show + + +instance SizeCalculable JpgFrameHeader where + calculateSize hdr = 2 + 1 + 2 + 2 + 1 + + sum [calculateSize c | c <- jpgComponents hdr] + +data JpgComponent = JpgComponent + { componentIdentifier :: !Word8 + -- | Stored with 4 bits + , horizontalSamplingFactor :: !Word8 + -- | Stored with 4 bits + , verticalSamplingFactor :: !Word8 + , quantizationTableDest :: !Word8 + } + deriving Show + +instance SizeCalculable JpgComponent where + calculateSize _ = 3 + +data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } + deriving Show + +data JpgScanSpecification = JpgScanSpecification + { componentSelector :: !Word8 + -- | Encoded as 4 bits + , dcEntropyCodingTable :: !Word8 + -- | Encoded as 4 bits + , acEntropyCodingTable :: !Word8 + + } + deriving Show + +instance SizeCalculable JpgScanSpecification where + calculateSize _ = 2 + +data JpgScanHeader = JpgScanHeader + { scanLength :: !Word16 + , scanComponentCount :: !Word8 + , scans :: [JpgScanSpecification] + + -- | (begin, end) + , spectralSelection :: (Word8, Word8) + + -- | Encoded as 4 bits + , successiveApproxHigh :: !Word8 + + -- | Encoded as 4 bits + , successiveApproxLow :: !Word8 + } + deriving Show + +instance SizeCalculable JpgScanHeader where + calculateSize hdr = 2 + 1 + + sum [calculateSize c | c <- scans hdr] + + 2 + + 1 + +data JpgQuantTableSpec = JpgQuantTableSpec + { -- | Stored on 4 bits + quantPrecision :: !Word8 + + -- | Stored on 4 bits + , quantDestination :: !Word8 + + , quantTable :: MacroBlock Int16 + } + deriving Show + +class SizeCalculable a where + calculateSize :: a -> Int + +-- | Type introduced only to avoid some typeclass overlapping +-- problem +newtype TableList a = TableList [a] + +instance (SizeCalculable a, Binary a) => Binary (TableList a) where + put (TableList lst) = do + putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 + mapM_ put lst + + get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) + where innerParse :: Int -> Get [a] + innerParse 0 = return [] + innerParse size = do + onStart <- fromIntegral <$> bytesRead + table <- get + onEnd <- fromIntegral <$> bytesRead + (table :) <$> innerParse (size - (onEnd - onStart)) + +instance SizeCalculable JpgQuantTableSpec where + calculateSize table = + 1 + (fromIntegral (quantPrecision table) + 1) * 64 + +instance Binary JpgQuantTableSpec where + put table = do + let precision = quantPrecision table + put4BitsOfEach precision (quantDestination table) + forM_ (VS.toList $ quantTable table) $ \coeff -> + if precision == 0 then putWord8 $ fromIntegral coeff + else putWord16be $ fromIntegral coeff + + get = do + (precision, dest) <- get4BitOfEach + coeffs <- replicateM 64 $ if precision == 0 + then fromIntegral <$> getWord8 + else fromIntegral <$> getWord16be + return JpgQuantTableSpec + { quantPrecision = precision + , quantDestination = dest + , quantTable = VS.fromListN 64 coeffs + } + +data JpgHuffmanTableSpec = JpgHuffmanTableSpec + { -- | 0 : DC, 1 : AC, stored on 4 bits + huffmanTableClass :: !DctComponent + -- | Stored on 4 bits + , huffmanTableDest :: !Word8 + + , huffSizes :: !(VU.Vector Word8) + , huffCodes :: !(V.Vector (VU.Vector Word8)) + } + deriving Show + +instance SizeCalculable JpgHuffmanTableSpec where + calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] + +instance Binary JpgHuffmanTableSpec where + put table = do + let classVal = if huffmanTableClass table == DcComponent + then 0 else 1 + put4BitsOfEach classVal $ huffmanTableDest table + mapM_ put . VU.toList $ huffSizes table + forM_ [0 .. 15] $ \i -> + when (huffSizes table ! i /= 0) + (let elements = VU.toList $ huffCodes table V.! i + in mapM_ put elements) + + get = do + (huffClass, huffDest) <- get4BitOfEach + sizes <- replicateM 16 getWord8 + codes <- forM sizes $ \s -> + VU.replicateM (fromIntegral s) getWord8 + return JpgHuffmanTableSpec + { huffmanTableClass = + if huffClass == 0 then DcComponent else AcComponent + , huffmanTableDest = huffDest + , huffSizes = VU.fromListN 16 sizes + , huffCodes = V.fromListN 16 codes + } + +instance Binary JpgImage where + put (JpgImage { jpgFrame = frames }) = + putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames + >> putWord8 0xFF >> putWord8 0xD9 + + get = do + let startOfImageMarker = 0xD8 + -- endOfImageMarker = 0xD9 + checkMarker commonMarkerFirstByte startOfImageMarker + eatUntilCode + frames <- parseFrames + {-checkMarker commonMarkerFirstByte endOfImageMarker-} + return JpgImage { jpgFrame = frames } + +eatUntilCode :: Get () +eatUntilCode = do + code <- getWord8 + unless (code == 0xFF) eatUntilCode + +takeCurrentFrame :: Get B.ByteString +takeCurrentFrame = do + size <- getWord16be + getByteString (fromIntegral size - 2) + +putFrame :: JpgFrame -> Put +putFrame (JpgAdobeAPP14 adobe) = + put (JpgAppSegment 14) >> putWord16be 14 >> put adobe +putFrame (JpgJFIF jfif) = + put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif +putFrame (JpgExif _exif) = + return () -- TODO + {-put (JpgAppSegment 0) >> put exif-} +putFrame (JpgAppFrame appCode str) = + put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str +putFrame (JpgExtension appCode str) = + put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str +putFrame (JpgQuantTable tables) = + put JpgQuantizationTable >> put (TableList tables) +putFrame (JpgHuffmanTable tables) = + put JpgHuffmanTableMarker >> put (TableList $ map fst tables) +putFrame (JpgIntervalRestart size) = + put JpgRestartInterval >> put (RestartInterval size) +putFrame (JpgScanBlob hdr blob) = + put JpgStartOfScan >> put hdr >> putLazyByteString blob +putFrame (JpgScans kind hdr) = + put kind >> put hdr + +-------------------------------------------------- +---- Serialization instances +-------------------------------------------------- +commonMarkerFirstByte :: Word8 +commonMarkerFirstByte = 0xFF + +checkMarker :: Word8 -> Word8 -> Get () +checkMarker b1 b2 = do + rb1 <- getWord8 + rb2 <- getWord8 + when (rb1 /= b1 || rb2 /= b2) + (fail "Invalid marker used") + +extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString) +extractScanContent str = aux 0 + where maxi = fromIntegral $ L.length str - 1 + + aux n | n >= maxi = (str, L.empty) + | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str + | otherwise = aux (n + 1) + where v = str `L.index` n + vNext = str `L.index` (n + 1) + isReset = 0xD0 <= vNext && vNext <= 0xD7 + +parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame] +parseAdobe14 str lst = go where + go = case runGetStrict get str of + Left _err -> lst + Right app14 -> JpgAdobeAPP14 app14 : lst + +-- | Parse JFIF or JFXX information. Right now only JFIF. +parseJF__ :: B.ByteString -> [JpgFrame] -> [JpgFrame] +parseJF__ str lst = go where + go = case runGetStrict get str of + Left _err -> lst + Right jfif -> JpgJFIF jfif : lst + +parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame] +parseExif str lst + | exifHeader `B.isPrefixOf` str = go + | otherwise = lst + where + exifHeader = BC.pack "Exif\0\0" + tiff = B.drop (B.length exifHeader) str + go = case runGetStrict (getP tiff) tiff of + Left _err -> lst + Right (_hdr :: TiffHeader, ifds) -> JpgExif ifds : lst + +parseFrames :: Get [JpgFrame] +parseFrames = do + kind <- get + let parseNextFrame = do + word <- getWord8 + when (word /= 0xFF) $ do + readedData <- bytesRead + fail $ "Invalid Frame marker (" ++ show word + ++ ", bytes read : " ++ show readedData ++ ")" + parseFrames + + case kind of + JpgEndOfImage -> return [] + JpgAppSegment 0 -> + parseJF__ <$> takeCurrentFrame <*> parseNextFrame + JpgAppSegment 1 -> + parseExif <$> takeCurrentFrame <*> parseNextFrame + JpgAppSegment 14 -> + parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame + JpgAppSegment c -> + (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame + JpgExtensionSegment c -> + (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame + JpgQuantizationTable -> + (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame + JpgRestartInterval -> + (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame + JpgHuffmanTableMarker -> + (\(TableList huffTables) lst -> + JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) + <$> get <*> parseNextFrame + JpgStartOfScan -> + (\frm imgData -> + let (d, other) = extractScanContent imgData + in + case runGet parseFrames (L.drop 1 other) of + Left _ -> [JpgScanBlob frm d] + Right lst -> JpgScanBlob frm d : lst + ) <$> get <*> getRemainingLazyBytes + + _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame + +buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree +buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList + +secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 +secondStartOfFrameByteOfKind = aux + where + aux JpgBaselineDCTHuffman = 0xC0 + aux JpgExtendedSequentialDCTHuffman = 0xC1 + aux JpgProgressiveDCTHuffman = 0xC2 + aux JpgLosslessHuffman = 0xC3 + aux JpgDifferentialSequentialDCTHuffman = 0xC5 + aux JpgDifferentialProgressiveDCTHuffman = 0xC6 + aux JpgDifferentialLosslessHuffman = 0xC7 + aux JpgExtendedSequentialArithmetic = 0xC9 + aux JpgProgressiveDCTArithmetic = 0xCA + aux JpgLosslessArithmetic = 0xCB + aux JpgHuffmanTableMarker = 0xC4 + aux JpgDifferentialSequentialDCTArithmetic = 0xCD + aux JpgDifferentialProgressiveDCTArithmetic = 0xCE + aux JpgDifferentialLosslessArithmetic = 0xCF + aux JpgEndOfImage = 0xD9 + aux JpgQuantizationTable = 0xDB + aux JpgStartOfScan = 0xDA + aux JpgRestartInterval = 0xDD + aux (JpgRestartIntervalEnd v) = v + aux (JpgAppSegment a) = (a + 0xE0) + aux (JpgExtensionSegment a) = a + +data JpgImageKind = BaseLineDCT | ProgressiveDCT + +instance Binary JpgFrameKind where + put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) + get = do + -- no lookahead :( + {-word <- getWord8-} + word2 <- getWord8 + return $ case word2 of + 0xC0 -> JpgBaselineDCTHuffman + 0xC1 -> JpgExtendedSequentialDCTHuffman + 0xC2 -> JpgProgressiveDCTHuffman + 0xC3 -> JpgLosslessHuffman + 0xC4 -> JpgHuffmanTableMarker + 0xC5 -> JpgDifferentialSequentialDCTHuffman + 0xC6 -> JpgDifferentialProgressiveDCTHuffman + 0xC7 -> JpgDifferentialLosslessHuffman + 0xC9 -> JpgExtendedSequentialArithmetic + 0xCA -> JpgProgressiveDCTArithmetic + 0xCB -> JpgLosslessArithmetic + 0xCD -> JpgDifferentialSequentialDCTArithmetic + 0xCE -> JpgDifferentialProgressiveDCTArithmetic + 0xCF -> JpgDifferentialLosslessArithmetic + 0xD9 -> JpgEndOfImage + 0xDA -> JpgStartOfScan + 0xDB -> JpgQuantizationTable + 0xDD -> JpgRestartInterval + a | a >= 0xF0 -> JpgExtensionSegment a + | a >= 0xE0 -> JpgAppSegment (a - 0xE0) + | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a + | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") + +put4BitsOfEach :: Word8 -> Word8 -> Put +put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b + +get4BitOfEach :: Get (Word8, Word8) +get4BitOfEach = do + val <- get + return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF) + +newtype RestartInterval = RestartInterval Word16 + +instance Binary RestartInterval where + put (RestartInterval i) = putWord16be 4 >> putWord16be i + get = do + size <- getWord16be + when (size /= 4) (fail "Invalid jpeg restart interval size") + RestartInterval <$> getWord16be + +instance Binary JpgComponent where + get = do + ident <- getWord8 + (horiz, vert) <- get4BitOfEach + quantTableIndex <- getWord8 + return JpgComponent + { componentIdentifier = ident + , horizontalSamplingFactor = horiz + , verticalSamplingFactor = vert + , quantizationTableDest = quantTableIndex + } + put v = do + put $ componentIdentifier v + put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v + put $ quantizationTableDest v + +instance Binary JpgFrameHeader where + get = do + beginOffset <- fromIntegral <$> bytesRead + frmHLength <- getWord16be + samplePrec <- getWord8 + h <- getWord16be + w <- getWord16be + compCount <- getWord8 + components <- replicateM (fromIntegral compCount) get + endOffset <- fromIntegral <$> bytesRead + when (beginOffset - endOffset < fromIntegral frmHLength) + (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) + return JpgFrameHeader + { jpgFrameHeaderLength = frmHLength + , jpgSamplePrecision = samplePrec + , jpgHeight = h + , jpgWidth = w + , jpgImageComponentCount = compCount + , jpgComponents = components + } + + put v = do + putWord16be $ jpgFrameHeaderLength v + putWord8 $ jpgSamplePrecision v + putWord16be $ jpgHeight v + putWord16be $ jpgWidth v + putWord8 $ jpgImageComponentCount v + mapM_ put $ jpgComponents v + +instance Binary JpgScanSpecification where + put v = do + put $ componentSelector v + put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v + + get = do + compSel <- get + (dc, ac) <- get4BitOfEach + return JpgScanSpecification { + componentSelector = compSel + , dcEntropyCodingTable = dc + , acEntropyCodingTable = ac + } + +instance Binary JpgScanHeader where + get = do + thisScanLength <- getWord16be + compCount <- getWord8 + comp <- replicateM (fromIntegral compCount) get + specBeg <- get + specEnd <- get + (approxHigh, approxLow) <- get4BitOfEach + + return JpgScanHeader { + scanLength = thisScanLength, + scanComponentCount = compCount, + scans = comp, + spectralSelection = (specBeg, specEnd), + successiveApproxHigh = approxHigh, + successiveApproxLow = approxLow + } + + put v = do + putWord16be $ scanLength v + putWord8 $ scanComponentCount v + mapM_ put $ scans v + putWord8 . fst $ spectralSelection v + putWord8 . snd $ spectralSelection v + put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v + +{-# INLINE createEmptyMutableMacroBlock #-} +-- | Create a new macroblock with the good array size +createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a) +createEmptyMutableMacroBlock = M.replicate 64 0 + +printMacroBlock :: (Storable a, PrintfArg a) + => MutableMacroBlock s a -> ST s String +printMacroBlock block = pLn 0 + where pLn 64 = return "===============================\n" + pLn i = do + v <- block `M.unsafeRead` i + vn <- pLn (i+1) + return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn + +printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String +printPureMacroBlock block = pLn 0 + where pLn 64 = "===============================\n" + pLn i = str ++ pLn (i + 1) + where str | i `mod` 8 == 0 = printf "\n%5d " v + | otherwise = printf "%5d" v + v = block VS.! i + + +{-# INLINE dctBlockSize #-} +dctBlockSize :: Num a => a +dctBlockSize = 8