JuicyPixels 3.2.8 → 3.2.8.1
raw patch · 5 files changed
+1497/−1489 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- JuicyPixels.cabal +91/−91
- changelog +331/−323
- src/Codec/Picture/BitWriter.hs +344/−336
- src/Codec/Picture/Jpg.hs +2/−2
- src/Codec/Picture/Jpg/Types.hs +729/−737
JuicyPixels.cabal view
@@ -1,91 +1,91 @@-Name: JuicyPixels-Version: 3.2.8-Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance)-Description:- <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>- .- 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: + <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> + . + 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 +
changelog view
@@ -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 +
src/Codec/Picture/BitWriter.hs view
@@ -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" #-} +
src/Codec/Picture/Jpg.hs view
@@ -888,8 +888,8 @@ } instance JpgEncodable PixelRGB8 where - additionalBlocks _ = [] where - _adobe14 = JpgAdobeApp14 + additionalBlocks _ = [JpgAdobeAPP14 adobe14] where + adobe14 = JpgAdobeApp14 { _adobeDctVersion = 100 , _adobeFlag0 = 0 , _adobeFlag1 = 0
src/Codec/Picture/Jpg/Types.hs view
@@ -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