diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,6 +1,6 @@ Name: JuicyPixels -Version: 3.1.7.1 -Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) +Version: 3.3.9 +Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> . @@ -14,11 +14,21 @@ Category: Codec, Graphics, Image Stability: Stable Build-type: Simple - --- Constraint on the version of Cabal needed to build this package. -Cabal-version: >= 1.10 +cabal-version: 1.18 +tested-with: + GHC == 9.8.1 + GHC == 9.6.4 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 -extra-source-files: changelog, docimages/*.png, docimages/*.svg +extra-doc-files: changelog, docimages/*.png, docimages/*.svg, README.md extra-doc-files: docimages/*.png, docimages/*.svg Source-Repository head @@ -28,7 +38,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.1.7.1 + Tag: v3.3.8 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -37,46 +47,49 @@ Library hs-source-dirs: src Default-Language: Haskell2010 + default-extensions: TypeOperators 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 + Codec.Picture.ColorQuant, + Codec.Picture.Jpg.Internal.DefaultTable, + Codec.Picture.Jpg.Internal.Metadata, + Codec.Picture.Jpg.Internal.FastIdct, + Codec.Picture.Jpg.Internal.FastDct, + Codec.Picture.Jpg.Internal.Types, + Codec.Picture.Jpg.Internal.Common, + Codec.Picture.Jpg.Internal.Progressive, + Codec.Picture.Gif.Internal.LZW, + Codec.Picture.Gif.Internal.LZWEncoding, + Codec.Picture.Png.Internal.Export, + Codec.Picture.Png.Internal.Type, + Codec.Picture.Png.Internal.Metadata, + Codec.Picture.Tiff.Internal.Metadata, + Codec.Picture.Tiff.Internal.Types Ghc-options: -O3 -Wall - Ghc-prof-options: -rtsopts -Wall -prof -auto-all - Build-depends: base >= 4 && < 5, - bytestring >= 0.9 && < 0.11, - mtl >= 1.1 && < 2.3, - binary >= 0.5 && < 0.8, - zlib >= 0.5.3.1 && < 0.6, + Build-depends: base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.13, + mtl >= 1.1 && < 2.4, + binary >= 0.8.1 && < 0.9, + zlib >= 0.5.3.1 && < 0.8, transformers >= 0.2, - vector >= 0.9 && < 0.11, - primitive >= 0.4 && < 0.6, - deepseq >= 1.1 && < 1.4, - containers >= 0.4.2 && < 0.6 - - if flag(Mmap) - Build-depends: mmap - CC-Options: "-DWITH_MMAP_BYTESTRING" + vector >= 0.12.3.1, + primitive >= 0.4, + deepseq >= 1.1 && < 1.6, + containers >= 0.4.2 && < 0.8 -- Modules not exported by this package. - Other-modules: Codec.Picture.Jpg.DefaultTable, - 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.BitWriter, + Other-modules: Codec.Picture.BitWriter, Codec.Picture.InternalHelper, Codec.Picture.VectorByteConversion diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,119 @@ +![Juicy logo](https://raw.github.com/Twinside/Juicy.Pixels/master/docimages/juicy.png) + + +[![Hackage](https://img.shields.io/hackage/v/JuicyPixels.svg)](http://hackage.haskell.org/package/JuicyPixels) + +Juicy.Pixels +============ + +This library provides saving & loading of different picture formats for the +Haskell language. The aim of the library is to be as lightweight as possible, +you ask it to load an image, and it'll dump you a big Vector full of juicy +pixels. Or squared pixels, or whatever, as long as they're unboxed. + +Documentation +------------- + +The library documentation can be accessed on [Hackage](http://hackage.haskell.org/package/JuicyPixels) + +Wrappers +-------- + +For the user of: + + * [REPA](http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Repa_Tutorial), check-out JuicyPixels-repa on [GitHub](https://github.com/TomMD/JuicyPixels-repa) or [Hackage](http://hackage.haskell.org/package/JuicyPixels-repa) + + * [Gloss](http://hackage.haskell.org/package/gloss), check-out gloss-juicy on [GitHub](https://github.com/alpmestan/gloss-juicy) or [Hackage](http://hackage.haskell.org/package/gloss-juicy) + +Status +------ + + - PNG (.png) + * Reading + - 1,2,4,8 bits loading, Grayscale, 24bits, 24 bits with alpha, + interleaved & filtered (fully compliant with the standard, + tested against png suite). + + * Writing + - 8bits RGB (non interleaved) + - 8bits RGBA (non interleaved) + - 8bits greyscale (non interleaved) + - 16bits greyscale (non interleaved) + - 16bits RGB (non interleaved) + - 16bits RGBA (non interleaved) + - 8bits RGB paletted image + - 8bits RGBA paletted image + + * Metadata (reading/writing) + * in a tEXT chunk: 'Title', 'Description', 'Author', 'Copyright', + 'Software', 'Comment', 'Disclaimer', 'Source', 'Warning' + * any other tEXT chunk. + * in a gAMA field : 'Gamma' + * DPI information in a pHYs chunk. + + - Bitmap (.bmp) + * Reading + - 16 or 32 bit RGBA images + - 16, 24, 32 bit RGB images + - 1, 4, or 8 bit (greyscale & paletted) images + - RLE encoded or uncompressed + - Windows 2.0/3.1/95/98 style bitmaps all supported + + * Writing + - 32bits (RGBA) per pixel images + - 24bits (RGB) per pixel images + - 8 bits greyscale (with palette) + + * Metadata (reading/writing): DPI information + + - Jpeg (.jpg, .jpeg) + * Reading normal and interlaced baseline DCT image + - YCbCr (default) CMYK/YCbCrK/RGB colorspaces + + * Writing non-interlaced JPG + - YCbCr (favored), Y, RGB & CMYK colorspaces + + * Metadata: + - Reading and writing DpiX & DpiY from JFIF header. + - Reading & writing EXIF metadata. No GPS information + can be written now. + + - Gif (.gif) + * Reading single image & animated Gif image, handles interlaced images. + * Writing single & animated Gif images. + * No metadata. + + - Radiance (.pic, .hdr) + * Reading + * Writing + * No metadata. + + - Tga + * Reading + - 8, 16, 24 & 32 bits + - paletted and unpaletted + - RLE encoded or uncompressed + * Writing + - uncompressed 8bits (Pixel8) + - uncompressed 24bits (PixelRGB8) + - uncompressed 32bits (PixelRGBA8) + * No metadata + + - Tiff + * Reading + - 2, 4, 8, 16 int bit depth reading (planar and contiguous for each) + - 32 bit floating point reading + + - CMYK, YCbCr, RGB, RGBA, Paletted, Greyscale + - Uncompressed, PackBits, LZW + + * Writing + - 8 and 16 bits + - CMYK, YCbCr, RGB, RGBA, Greyscale + - Uncompressed + * Metadata: reading DpiX, DpiY and EXIF informations. + +_I love juicy pixels_ + +You can make [donations on this page](http://twinside.github.com/Juicy.Pixels/). + diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,11 +1,275 @@ --*-change-log-*- +Change log +========== +v3.3.9 June 2024 +---------------- + + * Something something compilation + +v3.3.7 July 2022 +---------------- + + * Dependence fidling + * Jpg: do not call "error" in the parser, use fail instead. + +v3.3.7 March 2022 +----------------- + + * Jpg: Fixing renderng bug with MCUs with single block in width and + multiple in height + +v3.3.6 October 2021 +------------------- + + * Bytestring bound bump + * Fix bug #187. (Some JPEGs are misidentified as SourceTiff.) + * Fix EXIF handling of strings of four characters or fewer. + * Fix endianness bug in short ExifString and ExifUndefined. + + +v3.3.5 January 2020 +------------------- + +Maintenance release to push various pull requests onto +hackage + + * Exporting Pixel32 (will) + * Palettization of transparent frames in Gif (flutterlice) + * Documentation fixes (lehins) + +v3.3.4 September 2019 +--------------------- + + * support reading compressed zTXt metadata from PNG files (claudeha) + * Add helper functions to convert a DynamicImage to RGB16 (uglyoldbob) + * Fix RGB to CMYK conversion (lehins) + +v3.3.3.1 June 2019 +------------------ + + * New GHC maintenance (thanks to ekmett) + +v3.3.3 December 2018 +-------------------- + + * Enhanced: loading of bitmap format (thanks to CLowcay) + * Refactoring: exposing more internal modules (thanks to wyager) + * Refactoring: exposing dynamicMap & dynamicPixelMap + through `Codec.Picture` (thnks to LightAndLight) + + * v3.3.3.1: fixing compilation with older GHC + +v3.3.2 October 2018 +------------------- + + * Fix: GHC-8.6 compilation fix (no upper bound on base) + * Fix: upper bound on containers (pull request phadej) + * Fix: palette validation for gifs (pull request omedan) + * New: More complete gif creation API (pull request omedan) + +v3.3.1 August 2018 +------------------ + + * Fix: gif decoding of 1bit palette (fix Ornedan) + * Fix: end of stream handling for gif's lzw encoding (fix Ornedan) + +v3.3 July 2018 +-------------- + + * New: Eq instances for image + * Fix: color gif resolution offset + * New: support for Float Tiff + * Breaking change: New `ImageY32` constructor for `Dynamic` + hence the version bump. + +v3.2.9.5 March 2018 +------------------- + + * Fix: uniform color quantization + +v3.2.9.4 January 2018 +---------------------- + + * Compat for GHC-8.4 (pull request) + * Fix: a character in latin1 which was still around. Whatever. + So tired of this. + + +v3.2.9.3 December 2017 +---------------------- + + * Fix: remove bad invisible unicde char + +v3.2.9.2 December 2017 +---------------------- + + * Fix: Progressive jpeg decoding when number of blocks of the MCU + is below line size + +v3.2.9.1 November 2017 +---------------------- + + * Feature: Paletted alpha png saving + +v3.2.9 November 2017 +---------------------- + + * Fix: Adding correct import of Exif Flash for Jpeg (thanks to Alexander Kjeldaas) + * Feature: Jpg Exif writing + + +v3.2.8.3 August 2017 +------------------ + + * Fix: Jpeg loading of extended sequential jpg, not sure of all + the implications, works with the sample + +v3.2.8.2 June 2017 +------------------ + + * Fix: usage of fail in Either monad, giving an unwanted exception + +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 @@ -13,10 +277,14 @@ * 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 @@ -25,12 +293,18 @@ 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 @@ -48,10 +322,14 @@ 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 @@ -60,23 +338,33 @@ * 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 @@ -84,9 +372,13 @@ * 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. @@ -94,6 +386,8 @@ * 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). @@ -103,6 +397,8 @@ * 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. @@ -113,35 +409,51 @@ 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/docimages/pixelgraph.svg b/docimages/pixelgraph.svg --- a/docimages/pixelgraph.svg +++ b/docimages/pixelgraph.svg @@ -1,264 +1,264 @@ - - - - - - -pixelGraphic - - -PixelRGB8 - -PixelRGB8 - - -PixelRGBA8 - -PixelRGBA8 - - -PixelRGB8->PixelRGBA8 - - -promotePixel - - -PixelRGBF - -PixelRGBF - - -PixelRGB8->PixelRGBF - - -promotePixel - - -Pixel8 - -Pixel8 - - -PixelRGB8->Pixel8 - - -computeLuma - - -PixelCMYK8 - -PixelCMYK8 - - -PixelRGB8->PixelCMYK8 - - -convertPixel - - -PixelYCbCr8 - -PixelYCbCr8 - - -PixelRGB8->PixelYCbCr8 - - -convertPixel - - -PixelRGB16 - -PixelRGB16 - - -PixelRGBA16 - -PixelRGBA16 - - -PixelRGB16->PixelRGBA16 - - -promotePixel - - -Pixel16 - -Pixel16 - - -PixelRGB16->Pixel16 - - -computeLuma - - -PixelCMYK16 - -PixelCMYK16 - - -PixelRGB16->PixelCMYK16 - - -convertPixel - - -PixelRGBA16->PixelRGB16 - - -dropTransparency - - -PixelRGBA8->PixelRGB8 - - -dropTransparency - - -PixelRGBA8->Pixel8 - - -computeLuma - - -PixelF - -PixelF - - -PixelRGBF->PixelF - - -computeLuma - - -PixelYA16 - -PixelYA16 - - -PixelYA16->PixelRGBA16 - - -promotePixel - - -PixelYA16->Pixel16 - - -dropTransparency - - -PixelYA8 - -PixelYA8 - - -PixelYA8->PixelRGB8 - - -promotePixel - - -PixelYA8->PixelRGBA8 - - -promotePixel - - -PixelYA8->Pixel8 - - -dropTransparency - - -PixelYA8->Pixel8 - - -computeLuma - - -PixelF->PixelRGBF - - -promotePixel - - -Pixel16->PixelRGB16 - - -promotePixel - - -Pixel16->PixelRGBA16 - - -promotePixel - - -Pixel16->PixelYA16 - - -promotePixel - - -Pixel8->PixelRGB8 - - -promotePixel - - -Pixel8->PixelRGBA8 - - -promotePixel - - -Pixel8->PixelYA8 - - -promotePixel - - -Pixel8->PixelF - - -promotePixel - - -Pixel8->Pixel16 - - -promotePixel - - -PixelCMYK16->PixelRGB16 - - -convertPixel - - -PixelCMYK8->PixelRGB8 - - -convertPixel - - -PixelYCbCr8->PixelRGB8 - - -convertPixel - - -PixelYCbCr8->Pixel8 - - -computeLuma - - - + + + + + + +pixelGraphic + + +PixelRGB8 + +PixelRGB8 + + +PixelRGBA8 + +PixelRGBA8 + + +PixelRGB8->PixelRGBA8 + + +promotePixel + + +PixelRGBF + +PixelRGBF + + +PixelRGB8->PixelRGBF + + +promotePixel + + +Pixel8 + +Pixel8 + + +PixelRGB8->Pixel8 + + +computeLuma + + +PixelCMYK8 + +PixelCMYK8 + + +PixelRGB8->PixelCMYK8 + + +convertPixel + + +PixelYCbCr8 + +PixelYCbCr8 + + +PixelRGB8->PixelYCbCr8 + + +convertPixel + + +PixelRGB16 + +PixelRGB16 + + +PixelRGBA16 + +PixelRGBA16 + + +PixelRGB16->PixelRGBA16 + + +promotePixel + + +Pixel16 + +Pixel16 + + +PixelRGB16->Pixel16 + + +computeLuma + + +PixelCMYK16 + +PixelCMYK16 + + +PixelRGB16->PixelCMYK16 + + +convertPixel + + +PixelRGBA16->PixelRGB16 + + +dropTransparency + + +PixelRGBA8->PixelRGB8 + + +dropTransparency + + +PixelRGBA8->Pixel8 + + +computeLuma + + +PixelF + +PixelF + + +PixelRGBF->PixelF + + +computeLuma + + +PixelYA16 + +PixelYA16 + + +PixelYA16->PixelRGBA16 + + +promotePixel + + +PixelYA16->Pixel16 + + +dropTransparency + + +PixelYA8 + +PixelYA8 + + +PixelYA8->PixelRGB8 + + +promotePixel + + +PixelYA8->PixelRGBA8 + + +promotePixel + + +PixelYA8->Pixel8 + + +dropTransparency + + +PixelYA8->Pixel8 + + +computeLuma + + +PixelF->PixelRGBF + + +promotePixel + + +Pixel16->PixelRGB16 + + +promotePixel + + +Pixel16->PixelRGBA16 + + +promotePixel + + +Pixel16->PixelYA16 + + +promotePixel + + +Pixel8->PixelRGB8 + + +promotePixel + + +Pixel8->PixelRGBA8 + + +promotePixel + + +Pixel8->PixelYA8 + + +promotePixel + + +Pixel8->PixelF + + +promotePixel + + +Pixel8->Pixel16 + + +promotePixel + + +PixelCMYK16->PixelRGB16 + + +convertPixel + + +PixelCMYK8->PixelRGB8 + + +convertPixel + + +PixelYCbCr8->PixelRGB8 + + +convertPixel + + +PixelYCbCr8->Pixel8 + + +computeLuma + + + diff --git a/src/Codec/Picture.hs b/src/Codec/Picture.hs --- a/src/Codec/Picture.hs +++ b/src/Codec/Picture.hs @@ -1,25 +1,45 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} -- | Main module for image import/export into various image formats. -- -- To use the library without thinking about it, look after 'decodeImage' and -- 'readImage'. -- --- Generally, the read* functions read the images from a file and try to decode --- it, and the decode* functions try to decode a bytestring. +-- Generally, the @read*@ functions read the images from a file and try to decode +-- it, and the @decode*@ functions try to decode a bytestring. -- -- For an easy image writing use the 'saveBmpImage', 'saveJpgImage' & 'savePngImage' -- functions module Codec.Picture ( -- * Generic functions readImage + , readImageWithMetadata , decodeImage + , decodeImageWithMetadata + , decodeImageWithPaletteAndMetadata , pixelMap + , dynamicMap + , dynamicPixelMap , generateImage , generateFoldImage , withImage + , palettedToTrueColor + -- * RGB helper functions + , convertRGB8 + , convertRGB16 + , convertRGBA8 + + -- * Lens compatibility + , Traversal + , imagePixels + , imageIPixels + -- * Generic image writing , saveBmpImage , saveJpgImage @@ -74,6 +94,13 @@ , encodeDynamicPng , writeDynamicPng + -- ** TGA handling + , readTGA + , decodeTga + , TgaSaveable + , encodeTga + , writeTga + -- ** Tiff handling , readTiff , TiffSaveable @@ -102,6 +129,7 @@ -- $graph , Pixel8 , Pixel16 + , Pixel32 , PixelF , PixelYA8( .. ) @@ -119,14 +147,28 @@ , imageFromUnsafePtr ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) +#endif + +import Control.Arrow( first ) +import Data.Bits( unsafeShiftR ) import Control.DeepSeq( NFData, deepseq ) import qualified Control.Exception as Exc ( catch, IOException ) -import Codec.Picture.Bitmap( BmpEncodable, decodeBitmap +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Bitmap( BmpEncodable + , decodeBitmap + , decodeBitmapWithPaletteAndMetadata , writeBitmap, encodeBitmap , encodeDynamicBitmap, writeDynamicBitmap ) -import Codec.Picture.Jpg( decodeJpeg, encodeJpeg, encodeJpegAtQuality ) -import Codec.Picture.Png( PngSavable( .. ), decodePng, writePng +import Codec.Picture.Jpg( decodeJpeg + , decodeJpegWithMetadata + , encodeJpeg + , encodeJpegAtQuality ) +import Codec.Picture.Png( PngSavable( .. ) + , decodePng + , decodePngWithPaletteAndMetadata + , writePng , encodeDynamicPng , encodePalettedPng , writeDynamicPng @@ -135,6 +177,7 @@ import Codec.Picture.Gif( GifDelay , GifLooping( .. ) , decodeGif + , decodeGifWithPaletteAndMetadata , decodeGifImages , encodeGifImage , encodeGifImageWithPalette @@ -146,13 +189,21 @@ ) import Codec.Picture.HDR( decodeHDR + , decodeHDRWithMetadata , encodeHDR , writeHDR ) import Codec.Picture.Tiff( decodeTiff + , decodeTiffWithPaletteAndMetadata , TiffSaveable , encodeTiff , writeTiff ) +import Codec.Picture.Tga( TgaSaveable + , decodeTga + , decodeTgaWithPaletteAndMetadata + , encodeTga + , writeTga + ) import Codec.Picture.Saving import Codec.Picture.Types import Codec.Picture.ColorQuant @@ -164,8 +215,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L - -#include "ConvGraph.hs" +import qualified Data.Vector.Storable as VS -- | Return the first Right thing, accumulating error eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b @@ -192,7 +242,7 @@ -- All the images of the animation are separated -- by the same delay. encodeGifAnimation :: GifDelay -> GifLooping - -> [Image PixelRGB8] -> Either String (L.ByteString) + -> [Image PixelRGB8] -> Either String L.ByteString encodeGifAnimation delay looping lst = encodeGifImages looping [(pal, delay, img) @@ -225,19 +275,171 @@ readImage :: FilePath -> IO (Either String DynamicImage) readImage = withImageDecoder decodeImage +-- | Equivalent to 'readImage' but also providing metadatas. +readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas)) +readImageWithMetadata = withImageDecoder decodeImageWithMetadata + + -- | If you want to decode an image in a bytestring without even thinking -- in term of format or whatever, this is the function to use. It will try -- to decode in each known format and if one decoding succeeds, it will return -- the decoded image in it's own colorspace. decodeImage :: B.ByteString -> Either String DynamicImage -decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) - ,("PNG", decodePng) - ,("Bitmap", decodeBitmap) - ,("GIF", decodeGif) - ,("HDR", decodeHDR) - ,("Tiff", decodeTiff) - ] +decodeImage = fmap fst . decodeImageWithMetadata +class Decimable px1 px2 where + decimateBitDepth :: Image px1 -> Image px2 + +decimateWord16 :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ Pixel16 + , PixelBaseComponent px2 ~ Pixel8 + ) => Image px1 -> Image px2 +decimateWord16 (Image w h da) = + Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da + +decimateWord3216 :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ Pixel32 + , PixelBaseComponent px2 ~ Pixel16 + ) => Image px1 -> Image px2 +decimateWord3216 (Image w h da) = + Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 16) da + +decimateWord32 :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ Pixel32 + , PixelBaseComponent px2 ~ Pixel8 + ) => Image px1 -> Image px2 +decimateWord32 (Image w h da) = + Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 24) da + +decimateFloat :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ PixelF + , PixelBaseComponent px2 ~ Pixel8 + ) => Image px1 -> Image px2 +decimateFloat (Image w h da) = + Image w h $ VS.map (floor . (255*) . max 0 . min 1) da + +decimateFloat16 :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ PixelF + , PixelBaseComponent px2 ~ Pixel16 + ) => Image px1 -> Image px2 +decimateFloat16 (Image w h da) = + Image w h $ VS.map (floor . (65535*) . max 0 . min 1) da + +instance Decimable Pixel16 Pixel8 where + decimateBitDepth = decimateWord16 + +instance Decimable Pixel32 Pixel16 where + decimateBitDepth = decimateWord3216 + +instance Decimable Pixel32 Pixel8 where + decimateBitDepth = decimateWord32 + +instance Decimable PixelYA16 PixelYA8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelRGB16 PixelRGB8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelRGBA16 PixelRGBA8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelCMYK16 PixelCMYK8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelF Pixel8 where + decimateBitDepth = decimateFloat + +instance Decimable PixelF Pixel16 where + decimateBitDepth = decimateFloat16 + +instance Decimable PixelRGBF PixelRGB8 where + decimateBitDepth = decimateFloat + +instance Decimable PixelRGBF PixelRGB16 where + decimateBitDepth = decimateFloat16 + +-- | Convert by any means possible a dynamic image to an image +-- in RGBA. The process can lose precision while converting from +-- 16bits pixels or Floating point pixels. +convertRGBA8 :: DynamicImage -> Image PixelRGBA8 +convertRGBA8 dynImage = case dynImage of + ImageY8 img -> promoteImage img + ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageY32 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYA8 img -> promoteImage img + ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) + ImageRGB8 img -> promoteImage img + ImageRGB16 img -> promoteImage (decimateBitDepth img :: Image PixelRGB8) + ImageRGBF img -> promoteImage (decimateBitDepth img :: Image PixelRGB8) + ImageRGBA8 img -> promoteImage img + ImageRGBA16 img -> decimateBitDepth img + ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8) + ImageCMYK8 img -> promoteImage (convertImage img :: Image PixelRGB8) + ImageCMYK16 img -> + promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8) + +-- | Convert by any means possible a dynamic image to an image +-- in RGB. The process can lose precision while converting from +-- 16bits pixels or Floating point pixels. Any alpha layer will +-- be dropped +convertRGB8 :: DynamicImage -> Image PixelRGB8 +convertRGB8 dynImage = case dynImage of + ImageY8 img -> promoteImage img + ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageY32 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYA8 img -> promoteImage img + ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) + ImageRGB8 img -> img + ImageRGB16 img -> decimateBitDepth img + ImageRGBF img -> decimateBitDepth img :: Image PixelRGB8 + ImageRGBA8 img -> dropAlphaLayer img + ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8) + ImageYCbCr8 img -> convertImage img + ImageCMYK8 img -> convertImage img + ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8) + +-- | Convert by any means possible a dynamic image to an image +-- in RGB. The process can lose precision while converting from +-- 32bits pixels or Floating point pixels. Any alpha layer will +-- be dropped +convertRGB16 :: DynamicImage -> Image PixelRGB16 +convertRGB16 dynImage = case dynImage of + ImageY8 img -> promoteImage img + ImageY16 img -> promoteImage img + ImageY32 img -> promoteImage (decimateBitDepth img :: Image Pixel16) + ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel16) + ImageYA8 img -> promoteImage img + ImageYA16 img -> promoteImage img + ImageRGB8 img -> promoteImage img + ImageRGB16 img -> img + ImageRGBF img -> decimateBitDepth img :: Image PixelRGB16 + ImageRGBA8 img -> dropAlphaLayer (promoteImage img :: Image PixelRGBA16) + ImageRGBA16 img -> dropAlphaLayer img + ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8) + ImageCMYK8 img -> promoteImage (convertImage img :: Image PixelRGB8) + ImageCMYK16 img -> convertImage img + +-- | Equivalent to 'decodeImage', but also provide potential metadatas +-- present in the given file and the palettes if the format provides them. +decodeImageWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeImageWithPaletteAndMetadata str = eitherLoad str + [ ("Jpeg", fmap (first TrueColorImage) . decodeJpegWithMetadata) + , ("PNG", decodePngWithPaletteAndMetadata) + , ("Bitmap", decodeBitmapWithPaletteAndMetadata) + , ("GIF", decodeGifWithPaletteAndMetadata) + , ("HDR", fmap (first TrueColorImage) . decodeHDRWithMetadata) + , ("Tiff", decodeTiffWithPaletteAndMetadata) + , ("TGA", decodeTgaWithPaletteAndMetadata) + ] + +-- | Equivalent to 'decodeImage', but also provide potential metadatas +-- present in the given file. +decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeImageWithMetadata = + fmap (first palettedToTrueColor) . decodeImageWithPaletteAndMetadata + -- | Helper function trying to load a png file from a file on disk. readPng :: FilePath -> IO (Either String DynamicImage) readPng = withImageDecoder decodePng @@ -252,7 +454,7 @@ -- | Helper function trying to load all the images of an animated -- gif file. -readGifImages :: FilePath -> IO (Either String [Image PixelRGB8]) +readGifImages :: FilePath -> IO (Either String [DynamicImage]) readGifImages = withImageDecoder decodeGifImages -- | Try to load a jpeg file and decompress. The colorspace is still @@ -261,7 +463,7 @@ readJpeg :: FilePath -> IO (Either String DynamicImage) readJpeg = withImageDecoder decodeJpeg --- | Try to load a .bmp file. The colorspace would be RGB or Y. +-- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y. readBitmap :: FilePath -> IO (Either String DynamicImage) readBitmap = withImageDecoder decodeBitmap @@ -269,6 +471,10 @@ -- RGB with floating point precision. readHDR :: FilePath -> IO (Either String DynamicImage) readHDR = withImageDecoder decodeHDR + +-- | Try to load a .tga file from disk. +readTGA :: FilePath -> IO (Either String DynamicImage) +readTGA = withImageDecoder decodeTga -- | Save an image to a '.jpg' file, will do everything it can to save an image. saveJpgImage :: Int -> FilePath -> DynamicImage -> IO () 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,4 +1,6 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} -- | This module implement helper functions to read & write data -- at bits level. module Codec.Picture.BitWriter( BoolReader @@ -8,13 +10,16 @@ , getNextBitsLSBFirst , getNextBitsMSBFirst , getNextBitJpg + , getNextIntJpg , setDecodedString + , setDecodedStringMSB , setDecodedStringJpg , runBoolReader , BoolWriteStateRef , newWriteStateRef , finalizeBoolWriter + , finalizeBoolWriterGif , writeBits' , writeBitsGif @@ -24,11 +29,15 @@ , runBoolReaderWith ) where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + import Data.STRef -import Control.Applicative( (<$>), (<*>) ) 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 ) @@ -38,6 +47,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L + -------------------------------------------------- ---- Reader -------------------------------------------------- @@ -71,7 +81,7 @@ case B.uncons str of Nothing -> BoolState 0 0 B.empty Just (0xFF, rest) -> case B.uncons rest of - Nothing -> BoolState maxBound 0 B.empty + Nothing -> BoolState 7 0 B.empty Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker Just (_ , afterMarker) -> initBoolStateJpg afterMarker Just (v, rest) -> BoolState 7 v rest @@ -89,8 +99,8 @@ BoolState idx _ chain <- S.get when (idx /= 7) (setDecodedStringJpg chain) -{-# INLINE getNextBitJpg #-} getNextBitJpg :: BoolReader s Bool +{-# INLINE getNextBitJpg #-} getNextBitJpg = do BoolState idx v chain <- S.get let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 @@ -99,25 +109,51 @@ else S.put $ BoolState (idx - 1) v chain return val -{-# INLINE getNextBitMSB #-} -getNextBitMSB :: BoolReader s Bool -getNextBitMSB = do +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 val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0 - if idx == 7 - then setDecodedString chain - else S.put $ BoolState (idx + 1) v chain - return val + 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 count = aux 0 count - where aux acc 0 = return acc - aux acc n = do - bit <- getNextBitMSB - let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1 - | otherwise = acc `unsafeShiftL` 1 - aux nextVal (n - 1) +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 @@ -143,9 +179,9 @@ -- 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 maxBound 0 B.empty + Nothing -> S.put $ BoolState 7 0 B.empty Just (0xFF, rest) -> case B.uncons rest of - Nothing -> S.put $ BoolState maxBound 0 B.empty + Nothing -> S.put $ BoolState 7 0 B.empty Just (0x00, afterMarker) -> -- trace "00" $ S.put $ BoolState 7 0xFF afterMarker Just (_ , afterMarker) -> setDecodedStringJpg afterMarker @@ -177,6 +213,7 @@ finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString finalizeBoolWriter st = do + flushLeftBits' st forceBufferFlushing' st L.fromChunks <$> readSTRef (bwsBufferList st) @@ -226,6 +263,13 @@ 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 @@ -274,7 +318,7 @@ currWord <- readSTRef $ bwsBitAcc st currCount <- readSTRef $ bwsBitReaded st serialize d c currWord currCount - where dumpByte i = pushByte' st i + where dumpByte = pushByte' st serialize bitData bitCount currentWord count | bitCount + count == 8 = do @@ -296,4 +340,19 @@ where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 cleanData = bitData .&. cleanMask :: Word32 + +finalizeBoolWriterGif :: BoolWriteStateRef s -> ST s L.ByteString +finalizeBoolWriterGif st = do + flushLeftBitsGif st + forceBufferFlushing' st + L.fromChunks <$> readSTRef (bwsBufferList st) + +flushLeftBitsGif :: BoolWriteStateRef s -> ST s () +flushLeftBitsGif st = do + currCount <- readSTRef $ bwsBitReaded st + when (currCount > 0) $ do + currWord <- readSTRef $ bwsBitAcc st + pushByte' st currWord + +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/Bitmap.hs b/src/Codec/Picture/Bitmap.hs --- a/src/Codec/Picture/Bitmap.hs +++ b/src/Codec/Picture/Bitmap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,40 +8,60 @@ module Codec.Picture.Bitmap( -- * Functions writeBitmap , encodeBitmap + , encodeBitmapWithMetadata , decodeBitmap - , encodeDynamicBitmap - , writeDynamicBitmap + , decodeBitmapWithMetadata + , decodeBitmapWithPaletteAndMetadata + , encodeDynamicBitmap + , encodeBitmapWithPaletteAndMetadata + , writeDynamicBitmap -- * Accepted format in output , BmpEncodable( ) ) where -import Control.Monad( when, forM_ ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>) ) +#endif + +import Control.Arrow( first ) +import Control.Monad( replicateM, when, foldM_, forM_, void ) import Control.Monad.ST ( ST, runST ) -import qualified Data.Vector as V +import Data.Maybe( fromMaybe ) import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Data.Binary( Binary( .. ) ) import Data.Binary.Put( Put , runPut + , putInt32le , putWord16le , putWord32le - , putByteString + , putByteString ) import Data.Binary.Get( Get , getWord8 - , getWord16le + , getWord16le , getWord32le + , getInt32le + , getByteString , bytesRead , skip + , label ) +import Data.Bits +import Data.Int( Int32 ) import Data.Word( Word32, Word16, Word8 ) import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Lazy as L import Codec.Picture.InternalHelper import Codec.Picture.Types import Codec.Picture.VectorByteConversion +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata ( Metadatas ) data BmpHeader = BmpHeader { magicIdentifier :: !Word16 @@ -77,76 +98,268 @@ , dataOffset = offset } +-- | The type of color space declared in a Windows BMP file. +data ColorSpaceType = CalibratedRGB + | DeviceDependentRGB + | DeviceDependentCMYK + | SRGB + | WindowsColorSpace + | ProfileEmbedded + | ProfileLinked + | UnknownColorSpace Word32 + deriving (Eq, Show) -data BmpInfoHeader = BmpInfoHeader +-- | BITMAPxHEADER with compatibility up to V5. This header was first introduced +-- with Windows 2.0 as the BITMAPCOREHEADER, and was later extended in Windows +-- 3.1, Windows 95 and Windows 98. The original BITMAPCOREHEADER includes all +-- fields up to 'bitPerPixel'. The Windows 3.1 BITMAPINFOHEADER adds all the +-- fields up to 'importantColors'. +-- +-- Some Windows 3.1 bitmaps with 16 or 32 bits per pixel might also have three +-- bitmasks following the BITMAPINFOHEADER. These bitmasks were later +-- incorporated into the bitmap header structure in the unreleased +-- BITMAPV2INFOHEADER. The (also unreleased) BITMAPV3INFOHEADER added another +-- bitmask for an alpha channel. +-- +-- The later Windows 95 and Windows 98 extensions to the BITMAPINFOHEADER extend +-- the BITMAPV3INFOHEADER, adding support for color correction. +-- +-- * BITMAPV4HEADER (Windows 95) may include a simple color profile in a +-- proprietary format. The fields in this color profile (which includes gamma +-- values) are not to be used unless the 'colorSpaceType' field is +-- 'CalibratedRGB'. +-- +-- * BITMAPV5HEADER (Windows 98) adds support for an ICC color profile. The +-- presence of an ICC color profile is indicated by setting the 'colorSpaceType' +-- field to 'ProfileEmbedded' or 'ProfileLinked'. If it is 'ProfileLinked' then +-- the profile data is actually a Windows-1252 encoded string containing the +-- fully qualified path to an ICC color profile. +data BmpV5Header = BmpV5Header { size :: !Word32 -- Header size in bytes - , width :: !Word32 - , height :: !Word32 + , width :: !Int32 + , height :: !Int32 , planes :: !Word16 -- Number of colour planes , bitPerPixel :: !Word16 , bitmapCompression :: !Word32 , byteImageSize :: !Word32 - , xResolution :: !Word32 -- ^ Pixels per meter - , yResolution :: !Word32 -- ^ Pixels per meter - , colorCount :: !Word32 + , xResolution :: !Int32 -- ^ Pixels per meter + , yResolution :: !Int32 -- ^ Pixels per meter + , colorCount :: !Word32 -- ^ Number of colors in the palette , importantColours :: !Word32 + -- Fields added to the header in V2 + , redMask :: !Word32 -- ^ Red bitfield mask, set to 0 if not used + , greenMask :: !Word32 -- ^ Green bitfield mask, set to 0 if not used + , blueMask :: !Word32 -- ^ Blue bitfield mask, set to 0 if not used + -- Fields added to the header in V3 + , alphaMask :: !Word32 -- ^ Alpha bitfield mask, set to 0 if not used + -- Fields added to the header in V4 + , colorSpaceType :: !ColorSpaceType + , colorSpace :: !B.ByteString -- ^ Windows color space, not decoded + -- Fields added to the header in V5 + , iccIntent :: !Word32 + , iccProfileData :: !Word32 + , iccProfileSize :: !Word32 } deriving Show -sizeofBmpHeader, sizeofBmpInfo :: Word32 +-- | Size of the Windows BITMAPV4INFOHEADER color space information. +sizeofColorProfile :: Int +sizeofColorProfile = 48 + +-- | Sizes of basic BMP headers. +sizeofBmpHeader, sizeofBmpCoreHeader, sizeofBmpInfoHeader :: Word32 sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 -sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4 +sizeofBmpCoreHeader = 12 +sizeofBmpInfoHeader = 40 -instance Binary BmpInfoHeader where +-- | Sizes of extended BMP headers. +sizeofBmpV2Header, sizeofBmpV3Header, sizeofBmpV4Header, sizeofBmpV5Header :: Word32 +sizeofBmpV2Header = 52 +sizeofBmpV3Header = 56 +sizeofBmpV4Header = 108 +sizeofBmpV5Header = 124 + +instance Binary ColorSpaceType where + put CalibratedRGB = putWord32le 0 + put DeviceDependentRGB = putWord32le 1 + put DeviceDependentCMYK = putWord32le 2 + put ProfileEmbedded = putWord32le 0x4D424544 + put ProfileLinked = putWord32le 0x4C494E4B + put SRGB = putWord32le 0x73524742 + put WindowsColorSpace = putWord32le 0x57696E20 + put (UnknownColorSpace x) = putWord32le x + get = do + w <- getWord32le + return $ case w of + 0 -> CalibratedRGB + 1 -> DeviceDependentRGB + 2 -> DeviceDependentCMYK + 0x4D424544 -> ProfileEmbedded + 0x4C494E4B -> ProfileLinked + 0x73524742 -> SRGB + 0x57696E20 -> WindowsColorSpace + _ -> UnknownColorSpace w + +instance Binary BmpV5Header where put hdr = do putWord32le $ size hdr - putWord32le $ width hdr - putWord32le $ height hdr - putWord16le $ planes hdr - putWord16le $ bitPerPixel hdr - putWord32le $ bitmapCompression hdr - putWord32le $ byteImageSize hdr - putWord32le $ xResolution hdr - putWord32le $ yResolution hdr - putWord32le $ colorCount hdr - putWord32le $ importantColours hdr + if (size hdr == sizeofBmpCoreHeader) then do + putWord16le . fromIntegral $ width hdr + putWord16le . fromIntegral $ height hdr + putWord16le $ planes hdr + putWord16le $ bitPerPixel hdr + else do + putInt32le $ width hdr + putInt32le $ height hdr + putWord16le $ planes hdr + putWord16le $ bitPerPixel hdr + + when (size hdr > sizeofBmpCoreHeader) $ do + putWord32le $ bitmapCompression hdr + putWord32le $ byteImageSize hdr + putInt32le $ xResolution hdr + putInt32le $ yResolution hdr + putWord32le $ colorCount hdr + putWord32le $ importantColours hdr + + when (size hdr > sizeofBmpInfoHeader || bitmapCompression hdr == 3) $ do + putWord32le $ redMask hdr + putWord32le $ greenMask hdr + putWord32le $ blueMask hdr + + when (size hdr > sizeofBmpV2Header) $ + putWord32le $ alphaMask hdr + + when (size hdr > sizeofBmpV3Header) $ do + put $ colorSpaceType hdr + putByteString $ colorSpace hdr + + when (size hdr > sizeofBmpV4Header) $ do + put $ iccIntent hdr + putWord32le $ iccProfileData hdr + putWord32le $ iccProfileSize hdr + putWord32le 0 -- reserved field + get = do - readSize <- getWord32le - readWidth <- getWord32le - readHeight <- getWord32le - readPlanes <- getWord16le - readBitPerPixel <- getWord16le - readBitmapCompression <- getWord32le - readByteImageSize <- getWord32le - readXResolution <- getWord32le - readYResolution <- getWord32le - readColorCount <- getWord32le - readImportantColours <- getWord32le - return BmpInfoHeader { - size = readSize, - width = readWidth, - height = readHeight, - planes = readPlanes, - bitPerPixel = readBitPerPixel, - bitmapCompression = readBitmapCompression, - byteImageSize = readByteImageSize, - xResolution = readXResolution, - yResolution = readYResolution, - colorCount = readColorCount, - importantColours = readImportantColours - } + readSize <- getWord32le + if readSize == sizeofBmpCoreHeader + then getBitmapCoreHeader readSize + else getBitmapInfoHeader readSize + where + getBitmapCoreHeader readSize = do + readWidth <- getWord16le + readHeight <- getWord16le + readPlanes <- getWord16le + readBitPerPixel <- getWord16le + return BmpV5Header { + size = readSize, + width = fromIntegral readWidth, + height = fromIntegral readHeight, + planes = readPlanes, + bitPerPixel = readBitPerPixel, + bitmapCompression = 0, + byteImageSize = 0, + xResolution = 2835, + yResolution = 2835, + colorCount = 2 ^ readBitPerPixel, + importantColours = 0, + redMask = 0, + greenMask = 0, + blueMask = 0, + alphaMask = 0, + colorSpaceType = DeviceDependentRGB, + colorSpace = B.empty, + iccIntent = 0, + iccProfileData = 0, + iccProfileSize = 0 + } + + getBitmapInfoHeader readSize = do + readWidth <- getInt32le + readHeight <- getInt32le + readPlanes <- getWord16le + readBitPerPixel <- getWord16le + readBitmapCompression <- getWord32le + readByteImageSize <- getWord32le + readXResolution <- getInt32le + readYResolution <- getInt32le + readColorCount <- getWord32le + readImportantColours <- getWord32le + + (readRedMask, readGreenMask, readBlueMask) <- + if readSize == sizeofBmpInfoHeader && readBitmapCompression /= 3 + then return (0, 0, 0) + else do + -- fields added to the header in V2, but sometimes present + -- immediately after a plain BITMAPINFOHEADER + innerReadRedMask <- getWord32le + innerReadGreenMask <- getWord32le + innerReadBlueMask <- getWord32le + return (innerReadRedMask, innerReadGreenMask, innerReadBlueMask) + + -- field added in V3 (undocumented) + readAlphaMask <- if readSize < sizeofBmpV3Header then return 0 else getWord32le + + (readColorSpaceType, readColorSpace) <- + if readSize < sizeofBmpV4Header + then return (DeviceDependentRGB, B.empty) + else do + -- fields added in V4 (Windows 95) + csType <- get + cs <- getByteString sizeofColorProfile + return (csType, cs) + + (readIccIntent, readIccProfileData, readIccProfileSize) <- + if readSize < sizeofBmpV5Header + then return (0, 0, 0) + else do + -- fields added in V5 (Windows 98) + innerIccIntent <- getWord32le + innerIccProfileData <- getWord32le + innerIccProfileSize <- getWord32le + void getWord32le -- reserved field + return (innerIccIntent, innerIccProfileData, innerIccProfileSize) + + return BmpV5Header { + size = readSize, + width = readWidth, + height = readHeight, + planes = readPlanes, + bitPerPixel = readBitPerPixel, + bitmapCompression = readBitmapCompression, + byteImageSize = readByteImageSize, + xResolution = readXResolution, + yResolution = readYResolution, + colorCount = readColorCount, + importantColours = readImportantColours, + redMask = readRedMask, + greenMask = readGreenMask, + blueMask = readBlueMask, + alphaMask = readAlphaMask, + colorSpaceType = readColorSpaceType, + colorSpace = readColorSpace, + iccIntent = readIccIntent, + iccProfileData = readIccProfileData, + iccProfileSize = readIccProfileSize + } + newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)] putPalette :: BmpPalette -> Put putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p +putICCProfile :: Maybe B.ByteString -> Put +putICCProfile Nothing = return () +putICCProfile (Just bytes) = put bytes + -- | All the instance of this class can be written as a bitmap file -- using this library. class BmpEncodable pixel where bitsPerPixel :: pixel -> Int bmpEncode :: Image pixel -> Put + hasAlpha :: Image pixel -> Bool defaultPalette :: pixel -> BmpPalette defaultPalette _ = BmpPalette [] @@ -159,6 +372,7 @@ inner (ix + 1) (n - 1) instance BmpEncodable Pixel8 where + hasAlpha _ = False defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]] bitsPerPixel _ = 8 bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = @@ -174,7 +388,7 @@ let lineIdx = line * w inner col | col >= w = return () inner col = do - let v = (arr `VS.unsafeIndex` (lineIdx + col)) + let v = arr `VS.unsafeIndex` (lineIdx + col) (buff `M.unsafeWrite` col) v inner (col + 1) @@ -184,8 +398,9 @@ VS.unsafeFreeze buff instance BmpEncodable PixelRGBA8 where + hasAlpha _ = True bitsPerPixel _ = 32 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l where putVector vec = putByteString . blitVector vec 0 $ w * 4 @@ -212,6 +427,7 @@ VS.unsafeFreeze buff instance BmpEncodable PixelRGB8 where + hasAlpha _ = False bitsPerPixel _ = 24 bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l @@ -226,10 +442,10 @@ let initialIndex = line * w * 3 inner col _ _ | col >= w = return () inner col writeIdx readIdx = do - let r = (arr `VS.unsafeIndex` readIdx) - g = (arr `VS.unsafeIndex` (readIdx + 1)) - b = (arr `VS.unsafeIndex` (readIdx + 2)) - + let r = arr `VS.unsafeIndex` readIdx + g = arr `VS.unsafeIndex` (readIdx + 1) + b = arr `VS.unsafeIndex` (readIdx + 2) + (buff `M.unsafeWrite` writeIdx) b (buff `M.unsafeWrite` (writeIdx + 1)) g (buff `M.unsafeWrite` (writeIdx + 2)) r @@ -239,105 +455,452 @@ inner 0 0 initialIndex VS.unsafeFreeze buff -decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 -decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray - where wi = fromIntegral w - hi = fromIntegral h - stArray = runST $ do - arr <- M.new (fromIntegral $ w * h * 3) - forM_ [hi - 1, hi - 2 .. 0] (readLine arr) - VS.unsafeFreeze arr +-- | Information required to extract data from a bitfield. +data Bitfield t = Bitfield + { bfMask :: !t -- ^ The original bitmask. + , bfShift :: !Int -- ^ The computed number of bits to shift right. + , bfScale :: !Float -- ^ The scale factor to fit the data into 8 bits. + } deriving (Eq, Show) - stride = linePadding 24 wi +-- | Four bitfields (red, green, blue, alpha) +data Bitfields4 t = Bitfields4 !(Bitfield t) + !(Bitfield t) + !(Bitfield t) + !(Bitfield t) + deriving (Eq, Show) - readLine :: forall s. M.MVector s Word8 -> Int -> ST s () - readLine arr line = - let readIndex = (wi * 3 + stride) * line - lastIndex = wi * (hi - 1 - line + 1) * 3 - writeIndex = wi * (hi - 1 - line) * 3 +-- | Default bitfields 32 bit bitmaps. +defaultBitfieldsRGB32 :: Bitfields3 Word32 +defaultBitfieldsRGB32 = Bitfields3 (makeBitfield 0x00FF0000) + (makeBitfield 0x0000FF00) + (makeBitfield 0x000000FF) - inner _ writeIdx | writeIdx >= lastIndex = return () - inner readIdx writeIdx = do - (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + 2)) - (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1)) - (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` readIdx) - inner (readIdx + 3) (writeIdx + 3) +-- | Default bitfields for 16 bit bitmaps. +defaultBitfieldsRGB16 :: Bitfields3 Word16 +defaultBitfieldsRGB16 = Bitfields3 (makeBitfield 0x7C00) + (makeBitfield 0x03E0) + (makeBitfield 0x001F) - in inner readIndex writeIndex +-- | Three bitfields (red, gree, blue). +data Bitfields3 t = Bitfields3 !(Bitfield t) + !(Bitfield t) + !(Bitfield t) + deriving (Eq, Show) -decodeImageY8 :: BmpInfoHeader -> B.ByteString -> Image Pixel8 -decodeImageY8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray - where wi = fromIntegral w - hi = fromIntegral h - stArray = runST $ do - arr <- M.new (fromIntegral $ w * h * 1) - forM_ [hi - 1, hi - 2 .. 0] (readLine arr) - VS.unsafeFreeze arr +-- | Pixel formats used to encode RGBA image data. +data RGBABmpFormat = RGBA32 !(Bitfields4 Word32) + | RGBA16 !(Bitfields4 Word16) + deriving (Eq, Show) - stride = linePadding 8 wi - - readLine :: forall s. M.MVector s Word8 -> Int -> ST s () - readLine arr line = - let readIndex = (wi * 1 + stride) * line - lastIndex = wi * (hi - 1 - line + 1) * 1 - writeIndex = wi * (hi - 1 - line) * 1 +-- | Pixel formats used to encode RGB image data. +data RGBBmpFormat = RGB32 !(Bitfields3 Word32) + | RGB24 + | RGB16 !(Bitfields3 Word16) + deriving (Eq, Show) - inner _ writeIdx | writeIdx >= lastIndex = return () - inner readIdx writeIdx = do - (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx) - inner (readIdx + 1) (writeIdx + 1) +-- | Pixel formats used to encode indexed or grayscale images. +data IndexedBmpFormat = OneBPP | FourBPP | EightBPP deriving Show - in inner readIndex writeIndex +-- | Extract pixel data from a bitfield. +extractBitfield :: (FiniteBits t, Integral t) => Bitfield t -> t -> Word8 +extractBitfield bf t = if bfScale bf == 1 + then fromIntegral field + else round $ bfScale bf * fromIntegral field + where field = (t .&. bfMask bf) `unsafeShiftR` bfShift bf +-- | Convert a bit mask into a 'BitField'. +makeBitfield :: (FiniteBits t, Integral t) => t -> Bitfield t +makeBitfield mask = Bitfield mask shiftBits scale + where + shiftBits = countTrailingZeros mask + scale = 255 / fromIntegral (mask `unsafeShiftR` shiftBits) -pixelGet :: Get PixelRGB8 -pixelGet = do +-- | Helper method to cast a 'B.ByteString' to a 'VS.Vector' of some type. +castByteString :: VS.Storable a => B.ByteString -> VS.Vector a +#if MIN_VERSION_bytestring(0,11,0) +castByteString (BI.BS fp len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp 0 len +#else +castByteString (BI.PS fp offset len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp offset len +#endif + +decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGBA8 +decodeImageRGBA8 pixelFormat (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where + wi = fromIntegral w + hi = abs $ fromIntegral h + stArray = runST $ do + arr <- M.new (fromIntegral $ w * abs h * 4) + if h > 0 then + foldM_ (readLine arr) 0 [0 .. hi - 1] + else + foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] + VS.unsafeFreeze arr + + paddingWords = (8 * linePadding intBPP wi) `div` intBPP + intBPP = fromIntegral bpp + + readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int + readLine arr readIndex line = case pixelFormat of + RGBA32 bitfields -> inner bitfields (castByteString str) readIndex writeIndex + RGBA16 bitfields -> inner bitfields (castByteString str) readIndex writeIndex + where + lastIndex = wi * (hi - 1 - line + 1) * 4 + writeIndex = wi * (hi - 1 - line) * 4 + + inner + :: (FiniteBits t, Integral t, M.Storable t, Show t) + => Bitfields4 t + -> VS.Vector t + -> Int + -> Int + -> ST s Int + inner (Bitfields4 r g b a) inStr = inner0 + where + inner0 :: Int -> Int -> ST s Int + inner0 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingWords + inner0 readIdx writeIdx = do + let word = inStr VS.! readIdx + (arr `M.unsafeWrite` writeIdx ) (extractBitfield r word) + (arr `M.unsafeWrite` (writeIdx + 1)) (extractBitfield g word) + (arr `M.unsafeWrite` (writeIdx + 2)) (extractBitfield b word) + (arr `M.unsafeWrite` (writeIdx + 3)) (extractBitfield a word) + inner0 (readIdx + 1) (writeIdx + 4) + +decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGB8 +decodeImageRGB8 pixelFormat (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where + wi = fromIntegral w + hi = abs $ fromIntegral h + stArray = runST $ do + arr <- M.new (fromIntegral $ w * abs h * 3) + if h > 0 then + foldM_ (readLine arr) 0 [0 .. hi - 1] + else + foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] + VS.unsafeFreeze arr + + paddingBytes = linePadding intBPP wi + paddingWords = (linePadding intBPP wi * 8) `div` intBPP + intBPP = fromIntegral bpp + + readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int + readLine arr readIndex line = case pixelFormat of + RGB16 bitfields -> innerBF bitfields (castByteString str) readIndex writeIndex + RGB32 bitfields -> innerBF bitfields (castByteString str) readIndex writeIndex + RGB24 -> inner24 readIndex writeIndex + where + lastIndex = wi * (hi - 1 - line + 1) * 3 + writeIndex = wi * (hi - 1 - line) * 3 + + inner24 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingBytes + inner24 readIdx writeIdx = do + (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + 2)) + (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1)) + (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` readIdx) + inner24 (readIdx + 3) (writeIdx + 3) + + innerBF + :: (FiniteBits t, Integral t, M.Storable t, Show t) + => Bitfields3 t + -> VS.Vector t + -> Int + -> Int + -> ST s Int + innerBF (Bitfields3 r g b) inStr = innerBF0 + where + innerBF0 :: Int -> Int -> ST s Int + innerBF0 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingWords + innerBF0 readIdx writeIdx = do + let word = inStr VS.! readIdx + (arr `M.unsafeWrite` writeIdx ) (extractBitfield r word) + (arr `M.unsafeWrite` (writeIdx + 1)) (extractBitfield g word) + (arr `M.unsafeWrite` (writeIdx + 2)) (extractBitfield b word) + innerBF0 (readIdx + 1) (writeIdx + 3) + +decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> B.ByteString -> Image Pixel8 +decodeImageY8 lowBPP (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where + wi = fromIntegral w + hi = abs $ fromIntegral h + stArray = runST $ do + arr <- M.new . fromIntegral $ w * abs h + if h > 0 then + foldM_ (readLine arr) 0 [0 .. hi - 1] + else + foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] + VS.unsafeFreeze arr + + padding = linePadding (fromIntegral bpp) wi + + readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int + readLine arr readIndex line = case lowBPP of + OneBPP -> inner1 readIndex writeIndex + FourBPP -> inner4 readIndex writeIndex + EightBPP -> inner8 readIndex writeIndex + where + lastIndex = wi * (hi - 1 - line + 1) + writeIndex = wi * (hi - 1 - line) + + inner8 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding + inner8 readIdx writeIdx = do + (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx) + inner8 (readIdx + 1) (writeIdx + 1) + + inner4 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding + inner4 readIdx writeIdx = do + let byte = str `B.index` readIdx + if writeIdx >= lastIndex - 1 then do + (arr `M.unsafeWrite` writeIdx) (byte `unsafeShiftR` 4) + inner4 (readIdx + 1) (writeIdx + 1) + else do + (arr `M.unsafeWrite` writeIdx) (byte `unsafeShiftR` 4) + (arr `M.unsafeWrite` (writeIdx + 1)) (byte .&. 0x0F) + inner4 (readIdx + 1) (writeIdx + 2) + + inner1 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding + inner1 readIdx writeIdx = do + let byte = str `B.index` readIdx + let toWrite = (lastIndex - writeIdx) `min` 8 + forM_ [0 .. (toWrite - 1)] $ \i -> + when (byte `testBit` (7 - i)) $ (arr `M.unsafeWrite` (writeIdx + i)) 1 + inner1 (readIdx + 1) (writeIdx + toWrite) + +decodeImageY8RLE :: Bool -> BmpV5Header -> B.ByteString -> Image Pixel8 +decodeImageY8RLE is4bpp (BmpV5Header { width = w, height = h, byteImageSize = sz }) str = Image wi hi stArray where + wi = fromIntegral w + hi = abs $ fromIntegral h + xOffsetMax = wi - 1 + + stArray = runST $ do + arr <- M.new . fromIntegral $ w * abs h + decodeRLE arr (B.unpack (B.take (fromIntegral sz) str)) ((hi - 1) * wi, 0) + VS.unsafeFreeze arr + + decodeRLE :: forall s . M.MVector s Word8 -> [Word8] -> (Int, Int) -> ST s () + decodeRLE arr = inner + where + inner :: [Word8] -> (Int, Int) -> ST s () + inner [] _ = return () + inner (0 : 0 : rest) (yOffset, _) = inner rest (yOffset - wi, 0) + inner (0 : 1 : _) _ = return () + inner (0 : 2 : hOffset : vOffset : rest) (yOffset, _) = + inner rest (yOffset - (wi * fromIntegral vOffset), fromIntegral hOffset) + inner (0 : n : rest) writePos = + let isPadded = if is4bpp then (n + 3) .&. 0x3 < 2 else odd n + in copyN isPadded (fromIntegral n) rest writePos + inner (n : b : rest) writePos = writeN (fromIntegral n) b rest writePos + inner _ _ = return () + + -- | Write n copies of a byte to the output array. + writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s () + writeN 0 _ rest writePos = inner rest writePos + writeN n b rest writePos = + case (is4bpp, n) of + (True, 1) -> + writeByte (b `unsafeShiftR` 4) writePos >>= writeN (n - 1) b rest + (True, _) -> + writeByte (b `unsafeShiftR` 4) writePos + >>= writeByte (b .&. 0x0F) >>= writeN (n - 2) b rest + (False, _) -> + writeByte b writePos >>= writeN (n - 1) b rest + + -- | Copy the next byte to the output array, possibly ignoring a padding byte at the end. + copyN :: Bool -> Int -> [Word8] -> (Int, Int) -> ST s () + copyN _ _ [] _ = return () + copyN False 0 rest writePos = inner rest writePos + copyN True 0 (_:rest) writePos = inner rest writePos + copyN isPadded n (b : rest) writePos = + case (is4bpp, n) of + (True, 1) -> + writeByte (b `unsafeShiftR` 4) writePos >>= copyN isPadded (n - 1) rest + (True, _) -> + writeByte (b `unsafeShiftR` 4) writePos + >>= writeByte (b .&. 0x0F) >>= copyN isPadded (n - 2) rest + (False, _) -> + writeByte b writePos >>= copyN isPadded (n - 1) rest + + -- | Write the next byte to the output array. + writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int) + writeByte byte (yOffset, xOffset) = do + (arr `M.unsafeWrite` (yOffset + xOffset)) byte + return (yOffset, (xOffset + 1) `min` xOffsetMax) + +pixel4Get :: Get [Word8] +pixel4Get = do b <- getWord8 g <- getWord8 r <- getWord8 _ <- getWord8 - return $ PixelRGB8 r g b + return [r, g, b] +pixel3Get :: Get [Word8] +pixel3Get = do + b <- getWord8 + g <- getWord8 + r <- getWord8 + return [r, g, b] + +metadataOfHeader :: BmpV5Header -> Maybe B.ByteString -> Metadatas +metadataOfHeader hdr iccProfile = + cs `mappend` Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr) dpiX dpiY + where + dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr + dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr + cs = case colorSpaceType hdr of + CalibratedRGB -> Met.singleton + Met.ColorSpace (Met.WindowsBitmapColorSpace $ colorSpace hdr) + SRGB -> Met.singleton Met.ColorSpace Met.SRGB + ProfileEmbedded -> case iccProfile of + Nothing -> Met.empty + Just profile -> Met.singleton Met.ColorSpace + (Met.ICCProfile profile) + _ -> Met.empty + -- | Try to decode a bitmap image. --- Right now this function can output the following pixel types : +-- Right now this function can output the following image: -- --- * PixelRGB8 +-- - 'ImageY8' -- --- * Pixel8 +-- - 'ImageRGB8' -- +-- - 'ImageRGBA8' +-- decodeBitmap :: B.ByteString -> Either String DynamicImage -decodeBitmap str = flip runGetStrict str $ do - hdr <- get :: Get BmpHeader - bmpHeader <- get :: Get BmpInfoHeader +decodeBitmap = fmap fst . decodeBitmapWithMetadata +-- | Same as 'decodeBitmap' but also extracts metadata. +decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeBitmapWithMetadata byte = + first palettedToTrueColor <$> decodeBitmapWithPaletteAndMetadata byte + +-- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette. +decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do + fileHeader <- get :: Get BmpHeader + bmpHeader <- get :: Get BmpV5Header + readed <- bytesRead - when (readed > fromIntegral (dataOffset hdr)) + when (readed > fromIntegral (dataOffset fileHeader)) (fail "Invalid bmp image, data in header") - let bpp = fromIntegral $ bitPerPixel bmpHeader :: Int - paletteColorCount - | colorCount bmpHeader == 0 = 2 ^ bpp - | otherwise = fromIntegral $ colorCount bmpHeader + when (width bmpHeader <= 0) + (fail $ "Invalid bmp width, " ++ show (width bmpHeader)) - table <- if bpp > 8 - then return V.empty - else V.replicateM paletteColorCount pixelGet + when (height bmpHeader == 0) + (fail $ "Invalid bmp height (0) ") - readed' <- bytesRead + decodeBitmapWithHeaders fileHeader bmpHeader - skip . fromIntegral $ dataOffset hdr - fromIntegral readed' - rest <- getRemainingBytes - case (bitPerPixel bmpHeader, planes bmpHeader, - bitmapCompression bmpHeader) of - -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" - (24, 1, 0) -> return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest - ( 8, 1, 0) -> - let indexer v = table V.! fromIntegral v in - return . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest +-- | Decode the rest of a bitmap, after the headers have been decoded. +decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas) +decodeBitmapWithHeaders fileHdr hdr = do + img <- bitmapData + profile <- getICCProfile + return $ addMetadata profile img - a -> fail $ "Can't handle BMP file " ++ show a + where + bpp = fromIntegral $ bitPerPixel hdr :: Int + paletteColorCount + | colorCount hdr == 0 = 2 ^ bpp + | otherwise = fromIntegral $ colorCount hdr + addMetadata profile i = (i, metadataOfHeader hdr profile) + getData = do + readed <- bytesRead + label "Start of pixel data" $ + skip . fromIntegral $ dataOffset fileHdr - fromIntegral readed + let pixelBytes = if bitmapCompression hdr == 1 || bitmapCompression hdr == 2 + then fromIntegral $ byteImageSize hdr + else sizeofPixelData bpp (fromIntegral $ width hdr) + (fromIntegral $ height hdr) + label "Pixel data" $ getByteString pixelBytes + + getICCProfile = + if size hdr >= sizeofBmpV5Header + && colorSpaceType hdr == ProfileLinked + && iccProfileData hdr > 0 + && iccProfileSize hdr > 0 + then do + readSoFar <- bytesRead + label "Start of embedded ICC color profile" $ + skip $ fromIntegral (iccProfileData hdr) - fromIntegral readSoFar + profile <- label "Embedded ICC color profile" $ + getByteString . fromIntegral $ iccProfileSize hdr + return (Just profile) + else return Nothing + + bitmapData = case (bitPerPixel hdr, planes hdr, bitmapCompression hdr) of + (32, 1, 0) -> do + rest <- getData + return . TrueColorImage . ImageRGB8 $ + decodeImageRGB8 (RGB32 defaultBitfieldsRGB32) hdr rest + -- (2, 1, 0, 3) means BGRA pixel order + (32, 1, 3) -> do + r <- getBitfield $ redMask hdr + g <- getBitfield $ greenMask hdr + b <- getBitfield $ blueMask hdr + rest <- getData + if alphaMask hdr == 0 + then return . TrueColorImage . ImageRGB8 $ + decodeImageRGB8 (RGB32 $ Bitfields3 r g b) hdr rest + else do + a <- getBitfield $ alphaMask hdr + return . TrueColorImage . ImageRGBA8 $ + decodeImageRGBA8 (RGBA32 $ Bitfields4 r g b a) hdr rest + (24, 1, 0) -> do + rest <- getData + return . TrueColorImage . ImageRGB8 $ + decodeImageRGB8 RGB24 hdr rest + (16, 1, 0) -> do + rest <- getData + return . TrueColorImage . ImageRGB8 $ + decodeImageRGB8 (RGB16 defaultBitfieldsRGB16) hdr rest + (16, 1, 3) -> do + r <- getBitfield . fromIntegral $ 0xFFFF .&. redMask hdr + g <- getBitfield . fromIntegral $ 0xFFFF .&. greenMask hdr + b <- getBitfield . fromIntegral $ 0xFFFF .&. blueMask hdr + rest <- getData + if alphaMask hdr == 0 + then return . TrueColorImage . ImageRGB8 $ + decodeImageRGB8 (RGB16 $ Bitfields3 r g b) hdr rest + else do + a <- getBitfield . fromIntegral $ 0xFFFF .&. alphaMask hdr + return . TrueColorImage . ImageRGBA8 $ + decodeImageRGBA8 (RGBA16 $ Bitfields4 r g b a) hdr rest + ( _, 1, compression) -> do + table <- if size hdr == sizeofBmpCoreHeader + then replicateM paletteColorCount pixel3Get + else replicateM paletteColorCount pixel4Get + rest <- getData + let palette = Palette' + { _paletteSize = paletteColorCount + , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table + } + image <- + case (bpp, compression) of + (8, 0) -> return $ decodeImageY8 EightBPP hdr rest + (4, 0) -> return $ decodeImageY8 FourBPP hdr rest + (1, 0) -> return $ decodeImageY8 OneBPP hdr rest + (8, 1) -> return $ decodeImageY8RLE False hdr rest + (4, 2) -> return $ decodeImageY8RLE True hdr rest + (a, b) -> fail $ "Can't handle BMP file " ++ show (a, 1 :: Int, b) + + return $ PalettedRGB8 image palette + + a -> fail $ "Can't handle BMP file " ++ show a + +-- | Decode a bitfield. Will fail if the bitfield is empty. +#if MIN_VERSION_base(4,13,0) +getBitfield :: (FiniteBits t, Integral t, Num t, MonadFail m) => t -> m (Bitfield t) +#else +getBitfield :: (FiniteBits t, Integral t, Num t, Monad m) => t -> m (Bitfield t) +#endif +getBitfield 0 = fail $ + "Codec.Picture.Bitmap.getBitfield: bitfield cannot be 0" +getBitfield w = return (makeBitfield w) + +-- | Compute the size of the pixel data +sizeofPixelData :: Int -> Int -> Int -> Int +sizeofPixelData bpp lineWidth nLines = ((bpp * (abs lineWidth) + 31) `div` 32) * 4 * abs nLines + -- | Write an image in a file use the bitmap format. writeBitmap :: (BmpEncodable pixel) => FilePath -> Image pixel -> IO () @@ -345,28 +908,38 @@ linePadding :: Int -> Int -> Int linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4 - where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8) + where bytesPerLine = (bpp * imgWidth + 7) `div` 8 -- | Encode an image into a bytestring in .bmp format ready to be written -- on disk. encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) +-- | Equivalent to 'encodeBitmap' but also store +-- the following metadatas: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel + => Metadatas -> Image pixel -> L.ByteString +encodeBitmapWithMetadata metas = + encodeBitmapWithPaletteAndMetadata metas (defaultPalette (undefined :: pixel)) -- | Write a dynamic image in a .bmp image file if possible. --- The same restriction as encodeDynamicBitmap apply. +-- The same restriction as 'encodeDynamicBitmap' apply. writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool) writeDynamicBitmap path img = case encodeDynamicBitmap img of Left err -> return $ Left err Right b -> L.writeFile path b >> return (Right True) --- | Encode a dynamic image in bmp if possible, supported pixel type are : +-- | Encode a dynamic image in BMP if possible, supported images are: -- --- - RGB8 +-- - 'ImageY8' -- --- - RGBA8 +-- - 'ImageRGB8' -- --- - Y8 +-- - 'ImageRGBA8' -- encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img @@ -374,38 +947,91 @@ encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" +extractDpiOfMetadata :: Metadatas -> (Word32, Word32) +extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where + fetch k = maybe 0 (fromIntegral . Met.dotPerInchToDotsPerMeter) $ Met.lookup k metas + -- | Convert an image to a bytestring ready to be serialized. encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel) => BmpPalette -> Image pixel -> L.ByteString -encodeBitmapWithPalette pal@(BmpPalette palette) img = +encodeBitmapWithPalette = encodeBitmapWithPaletteAndMetadata mempty + +-- | Equivalent to 'encodeBitmapWithPalette' but also store +-- the following metadatas: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel) + => Metadatas -> BmpPalette -> Image pixel + -> L.ByteString +encodeBitmapWithPaletteAndMetadata metas pal@(BmpPalette palette) img = runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img + >> putICCProfile colorProfileData + where imgWidth = fromIntegral $ imageWidth img imgHeight = fromIntegral $ imageHeight img + (dpiX, dpiY) = extractDpiOfMetadata metas + cs = Met.lookup Met.ColorSpace metas + colorType = case cs of + Just Met.SRGB -> SRGB + Just (Met.WindowsBitmapColorSpace _) -> CalibratedRGB + Just (Met.ICCProfile _) -> ProfileEmbedded + Nothing -> DeviceDependentRGB + colorSpaceInfo = case cs of + Just (Met.WindowsBitmapColorSpace bytes) -> bytes + _ -> B.pack $ replicate sizeofColorProfile 0 + + colorProfileData = case cs of + Just (Met.ICCProfile bytes) -> Just bytes + _ -> Nothing + + headerSize | colorType == ProfileEmbedded = sizeofBmpV5Header + | colorType == CalibratedRGB || hasAlpha img = sizeofBmpV4Header + | otherwise = sizeofBmpInfoHeader + paletteSize = fromIntegral $ length palette bpp = bitsPerPixel (undefined :: pixel) - padding = linePadding bpp (imgWidth + 1) - imagePixelSize = fromIntegral $ (imgWidth + padding) * imgHeight * 4 + + profileSize = fromIntegral $ maybe 0 B.length colorProfileData + imagePixelSize = fromIntegral $ sizeofPixelData bpp imgWidth imgHeight + offsetToData = sizeofBmpHeader + headerSize + 4 * paletteSize + offsetToICCProfile = offsetToData + imagePixelSize <$ colorProfileData + sizeOfFile = sizeofBmpHeader + headerSize + 4 * paletteSize + + imagePixelSize + profileSize + hdr = BmpHeader { magicIdentifier = bitmapMagicIdentifier, - fileSize = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize, + fileSize = sizeOfFile, reserved1 = 0, reserved2 = 0, - dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + dataOffset = offsetToData } - info = BmpInfoHeader { - size = sizeofBmpInfo, + info = BmpV5Header { + size = headerSize, width = fromIntegral imgWidth, height = fromIntegral imgHeight, planes = 1, bitPerPixel = fromIntegral bpp, - bitmapCompression = 0, -- no compression + bitmapCompression = if hasAlpha img then 3 else 0, byteImageSize = imagePixelSize, - xResolution = 0, - yResolution = 0, - colorCount = 0, - importantColours = paletteSize + xResolution = fromIntegral dpiX, + yResolution = fromIntegral dpiY, + colorCount = paletteSize, + importantColours = 0, + redMask = if hasAlpha img then 0x00FF0000 else 0, + greenMask = if hasAlpha img then 0x0000FF00 else 0, + blueMask = if hasAlpha img then 0x000000FF else 0, + alphaMask = if hasAlpha img then 0xFF000000 else 0, + colorSpaceType = colorType, + colorSpace = colorSpaceInfo, + iccIntent = 0, + iccProfileData = fromMaybe 0 offsetToICCProfile, + iccProfileSize = profileSize } + +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/ColorQuant.hs b/src/Codec/Picture/ColorQuant.hs --- a/src/Codec/Picture/ColorQuant.hs +++ b/src/Codec/Picture/ColorQuant.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} -- | This module provide some color quantisation algorithm -- in order to help in the creation of paletted images. -- The most important function is `palettize` which will @@ -9,12 +10,16 @@ -- with its palette. module Codec.Picture.ColorQuant ( palettize + , palettizeWithAlpha , defaultPaletteOptions , PaletteCreationMethod(..) , PaletteOptions( .. ) ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) +#endif + import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) import Data.List (elemIndex) import Data.Maybe (fromMaybe) @@ -28,6 +33,7 @@ import qualified Data.Vector.Storable as VS import Codec.Picture.Types +import Codec.Picture.Gif (GifFrame(..), GifDisposalMethod, GifDelay) ------------------------------------------------------------------------------- ---- Palette Creation and Dithering @@ -67,7 +73,54 @@ , paletteColorCount = 256 } --- | Reduces an image to a color palette according to `PaletteOpts` and +-- | Changes all pixels with alpha = 0 to black +-- converting image to RGB (from RGBA) in meantime +alphaToBlack :: Image PixelRGBA8 -> Image PixelRGB8 +alphaToBlack = pixelMap f + where f (PixelRGBA8 r g b a) = + if a == 0 then PixelRGB8 0 0 0 + else PixelRGB8 r g b + +-- | Using second image as a stencil, changes palette index to the transparent +alphaTo255 :: Image Pixel8 -> Image PixelRGBA8 -> Pixel8 -> Image Pixel8 +alphaTo255 img1 img2 transparentIndex = generateImage f (imageWidth img1) (imageHeight img2) + where f x y = + if a == 0 then transparentIndex + else v + where v = pixelAt img1 x y + PixelRGBA8 _ _ _ a = pixelAt img2 x y + +-- | Converts RGBA image to the array of GifFame's to use in encodeComplexGifImage +palettizeWithAlpha :: [(GifDelay, Image PixelRGBA8)] -> GifDisposalMethod -> [GifFrame] +palettizeWithAlpha [] _ = [] +palettizeWithAlpha (x:xs) dispose = + GifFrame + 0 -- Offset X + 0 -- Offset Y + (Just $ palet) + (Just $ transparentIndex) + delay + dispose + (alphaTo255 pixels i (fromIntegral transparentIndex)) + : palettizeWithAlpha xs dispose + where (delay, i) = x + img = alphaToBlack i + (palet, pixels) = + if isBelow + then (vecToPalette (belowPaletteVec `V.snoc` PixelRGB8 0 0 0), pixelMap belowPaletteIndex img) + else (vecToPalette (genPaletteVec `V.snoc` PixelRGB8 0 0 0), pixelMap genPaletteIndex img) + + (belowPalette, isBelow) = isColorCountBelow 255 img + belowPaletteVec = V.fromList $ Set.toList belowPalette + belowPaletteIndex p = nearestColorIdx p belowPaletteVec + + cs = Set.toList . clusters 255 $ img + genPaletteVec = mkPaletteVec cs + genPaletteIndex p = nearestColorIdx p genPaletteVec + + transparentIndex = length $ if isBelow then belowPaletteVec else genPaletteVec + +-- | Reduces an image to a color palette according to `PaletteOptions` and -- returns the /indices image/ along with its `Palette`. palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) palettize opts@PaletteOptions { paletteCreationMethod = method } = @@ -96,7 +149,7 @@ cs = Set.toList . clusters maxColorCount $ img dImg = pixelMapXY dither img --- | A naive one pass Color Quantiation algorithm - Uniform Quantization. +-- | A naive one pass Color Quantization algorithm - Uniform Quantization. -- Simply take the most significant bits. The maxCols parameter is rounded -- down to the nearest power of 2, and the bits are divided among the three -- color channels with priority order green, red, blue. Returns an @@ -116,7 +169,7 @@ (bg, br, bb) = bitDiv3 maxCols (dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb)) paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex - (PixelRGB8 (r .&. (255 - dr)) (g .&. (255 - dg)) (b .&. (255 - db))) + (PixelRGB8 (r .&. negate dr) (g .&. negate dg) (b .&. negate db)) paletteList) isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool) @@ -211,7 +264,7 @@ (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) = let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a) begin = Pair beginL beginR - done (Pair xL xR) = (doneL xL) (doneR xR) + done (Pair xL xR) = doneL xL $ doneR xR in Fold step begin done {-# INLINABLE (<*>) #-} @@ -225,7 +278,7 @@ -- Based on the OCaml implementation: -- http://rosettacode.org/wiki/Color_quantization --- which is in turn based on: www.leptonica.com/papers/mediancut.pdf. +-- which is in turn based on: www.leptonica.org/papers/mediancut.pdf. -- We use the product of volume and population to determine the next cluster -- to split and determine the placement of each color by compating it to the -- mean of the parent cluster. So median cut is a bit of a misnomer, since one @@ -321,9 +374,9 @@ (PixelRGBF mr mg mb) = meanColor cluster (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster cond = case maxAxis $ dims cluster of - RAxis -> (\(PixelRGB8 r _ _) -> fromIntegral r < mr) - GAxis -> (\(PixelRGB8 _ g _) -> fromIntegral g < mg) - BAxis -> (\(PixelRGB8 _ _ b) -> fromIntegral b < mb) + RAxis -> \(PixelRGB8 r _ _) -> fromIntegral r < mr + GAxis -> \(PixelRGB8 _ g _) -> fromIntegral g < mg + BAxis -> \(PixelRGB8 _ _ b) -> fromIntegral b < mb rgbIntPack :: PixelRGB8 -> PackedRGB rgbIntPack (PixelRGB8 r g b) = @@ -337,7 +390,7 @@ where r = fromIntegral $ v `unsafeShiftR` (2 * 8) g = fromIntegral $ v `unsafeShiftR` 8 - b = fromIntegral $ v + b = fromIntegral v initCluster :: Image PixelRGB8 -> Cluster initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer @@ -379,4 +432,4 @@ , fromIntegral b1 - fromIntegral b2 ) nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8 -nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (\px -> dist2Px px p) ps) +nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps) diff --git a/src/Codec/Picture/ConvGraph.hs b/src/Codec/Picture/ConvGraph.hs --- a/src/Codec/Picture/ConvGraph.hs +++ b/src/Codec/Picture/ConvGraph.hs @@ -1,10 +1,10 @@ --- $graph --- --- The following graph describe the differents way to convert between pixel types, --- --- * Nodes describe pixel type --- --- * Arrows describe functions --- --- <> --- +-- $graph +-- +-- The following graph describe the differents way to convert between pixel types, +-- +-- * Nodes describe pixel type +-- +-- * Arrows describe functions +-- +-- <> +-- diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs --- a/src/Codec/Picture/Gif.hs +++ b/src/Codec/Picture/Gif.hs @@ -1,25 +1,39 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} -- | Module implementing GIF decoding. module Codec.Picture.Gif ( -- * Reading decodeGif + , decodeGifWithMetadata + , decodeGifWithPaletteAndMetadata , decodeGifImages , getDelaysGifImages -- * Writing , GifDelay + , GifDisposalMethod( .. ) + , GifEncode( .. ) + , GifFrame( .. ) , GifLooping( .. ) , encodeGifImage , encodeGifImageWithPalette , encodeGifImages + , encodeComplexGifImage , writeGifImage , writeGifImageWithPalette , writeGifImages + , writeComplexGifImage , greyPalette ) where -import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( replicateM, replicateM_ ) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + +import Control.Arrow( first ) +import Control.Monad( replicateM, replicateM_, unless, when ) import Control.Monad.ST( runST ) import Control.Monad.Trans.Class( lift ) @@ -52,8 +66,11 @@ import Codec.Picture.InternalHelper import Codec.Picture.Types -import Codec.Picture.Gif.LZW -import Codec.Picture.Gif.LZWEncoding +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceGif ) + , basicMetadata ) +import Codec.Picture.Gif.Internal.LZW +import Codec.Picture.Gif.Internal.LZWEncoding import Codec.Picture.BitWriter -- | Delay to wait before showing the next Gif image. @@ -69,6 +86,42 @@ -- | The animation will repeat n times before stoping | LoopingRepeat Word16 + +-- | GIF image definition for encoding +data GifEncode = GifEncode + { -- | Screen width + geWidth :: Int + , -- | Screen height + geHeight :: Int + , -- | Global palette, optional + gePalette :: Maybe Palette + , -- | Background color index, optional. If given, a global palette is also required + geBackground :: Maybe Int + , -- | Looping behaviour + geLooping :: GifLooping + , -- | Image frames + geFrames :: [GifFrame] + } + +-- | An individual image frame in a GIF image +data GifFrame = GifFrame + { -- | Image X offset in GIF canvas + gfXOffset :: Int + , -- | Image Y offset in GIF canvas + gfYOffset :: Int + , -- | Image local palette, optional if a global palette is given + gfPalette :: Maybe Palette + , -- | Transparent color index, optional + gfTransparent :: Maybe Int + , -- | Frame transition delay, in 1/100ths of a second + gfDelay :: GifDelay + , -- | Frame disposal method + gfDisposal :: GifDisposalMethod + , -- | Image pixels + gfPixels :: Image Pixel8 + } + + {- ::= Header * Trailer @@ -146,7 +199,7 @@ tableSizeField = (colorTableSize v - 1) .&. 7 colorResolutionField = - ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5 + ((colorResolution v - 1) .&. 7) `unsafeShiftL` 4 packedField = globalMapField .|. colorTableSortedField @@ -167,7 +220,7 @@ { screenWidth = w , screenHeight = h , hasGlobalMap = packedField `testBit` 7 - , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 + , colorResolution = (packedField `unsafeShiftR` 4) .&. 0x7 + 1 , isColorTableSorted = packedField `testBit` 3 , colorTableSize = (packedField .&. 0x7) + 1 , backgroundIndex = backgroundColorIndex @@ -215,14 +268,14 @@ putSlices str = putWord8 (fromIntegral $ B.length str) >> putByteString str -data DisposalMethod +data GifDisposalMethod = DisposalAny | DisposalDoNot | DisposalRestoreBackground | DisposalRestorePrevious | DisposalUnknown Word8 -disposalMethodOfCode :: Word8 -> DisposalMethod +disposalMethodOfCode :: Word8 -> GifDisposalMethod disposalMethodOfCode v = case v of 0 -> DisposalAny 1 -> DisposalDoNot @@ -230,7 +283,7 @@ 3 -> DisposalRestorePrevious n -> DisposalUnknown n -codeOfDisposalMethod :: DisposalMethod -> Word8 +codeOfDisposalMethod :: GifDisposalMethod -> Word8 codeOfDisposalMethod v = case v of DisposalAny -> 0 DisposalDoNot -> 1 @@ -239,7 +292,7 @@ DisposalUnknown n -> n data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits + { gceDisposalMethod :: !GifDisposalMethod -- ^ Stored on 3 bits , gceUserInputFlag :: !Bool , gceTransparentFlag :: !Bool , gceDelay :: !Word16 @@ -325,9 +378,7 @@ skipSubDataBlocks :: Get () skipSubDataBlocks = do s <- fromIntegral <$> getWord8 - if s == 0 then - return () - else + unless (s == 0) $ skip s >> skipSubDataBlocks parseGifBlocks :: Get [Block] @@ -389,7 +440,6 @@ imgWidth <- getWord16le imgHeight <- getWord16le packedFields <- getWord8 - let tableSize = packedFields .&. 0x7 return ImageDescriptor { gDescPixelsFromLeft = imgLeftPos , gDescPixelsFromTop = imgTopPos @@ -398,7 +448,7 @@ , gDescHasLocalMap = packedFields `testBit` 7 , gDescIsInterlaced = packedFields `testBit` 6 , gDescIsImgDescriptorSorted = packedFields `testBit` 5 - , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 + , gDescLocalColorTableSize = (packedFields .&. 0x7) + 1 } @@ -407,7 +457,7 @@ -------------------------------------------------- getPalette :: Word8 -> Get Palette getPalette bitDepth = - replicateM (size * 3) get >>= return . Image size 1 . V.fromList + Image size 1 . V.fromList <$> replicateM (size * 3) get where size = 2 ^ (fromIntegral bitDepth :: Int) putPalette :: Int -> Palette -> Put @@ -423,15 +473,17 @@ data GifHeader = GifHeader { gifVersion :: GifVersion , gifScreenDescriptor :: LogicalScreenDescriptor - , gifGlobalMap :: !Palette + , gifGlobalMap :: Maybe Palette } instance Binary GifHeader where put v = do put $ gifVersion v let descr = gifScreenDescriptor v - put $ descr - putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v + put descr + case gifGlobalMap v of + Just palette -> putPalette (fromIntegral $ colorTableSize descr) palette + Nothing -> return () get = do version <- get @@ -439,9 +491,9 @@ palette <- if hasGlobalMap screenDesc then - getPalette $ colorTableSize screenDesc + return <$> getPalette (colorTableSize screenDesc) else - return $ greyPalette + return Nothing return GifHeader { gifVersion = version @@ -498,6 +550,13 @@ substituteColors palette = pixelMap swaper where swaper n = pixelAt palette (fromIntegral n) 0 +substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 +substituteColorsWithTransparency transparent palette = pixelMap swaper where + swaper n | ix == transparent = PixelRGBA8 0 0 0 0 + | otherwise = promotePixel $ pixelAt palette ix 0 + where ix = fromIntegral n + + decodeImage :: GifImage -> Image Pixel8 decodeImage img = runST $ runBoolReader $ do outputVector <- lift . M.new $ width * height @@ -532,9 +591,10 @@ , [1, 1 + 2 .. height - 1] ] -paletteOf :: Palette -> GifImage -> Palette +paletteOf :: (ColorConvertible PixelRGB8 px) + => Image px -> GifImage -> Image px paletteOf global GifImage { imgLocalPalette = Nothing } = global -paletteOf _ GifImage { imgLocalPalette = Just p } = p +paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p getFrameDelays :: GifFile -> [GifDelay] getFrameDelays GifFile { gifImages = [] } = [] @@ -544,78 +604,155 @@ Nothing -> 0 Just e -> fromIntegral $ gceDelay e -decodeAllGifImages :: GifFile -> [Image PixelRGB8] +transparentColorOf :: Maybe GraphicControlExtension -> Int +transparentColorOf Nothing = 300 +transparentColorOf (Just ext) + | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext + | otherwise = 300 + +hasTransparency :: Maybe GraphicControlExtension -> Bool +hasTransparency Nothing = False +hasTransparency (Just control) = gceTransparentFlag control + +decodeAllGifImages :: GifFile -> [PalettedImage] decodeAllGifImages GifFile { gifImages = [] } = [] decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette - , gifScreenDescriptor = wholeDescriptor - } - , gifImages = (firstControl, firstImage) : rest } = map paletteApplyer $ - scanl generator initState rest - where initState = (paletteOf palette firstImage, firstControl, decodeImage firstImage) - globalWidth = fromIntegral $ screenWidth wholeDescriptor - globalHeight = fromIntegral $ screenHeight wholeDescriptor + , gifScreenDescriptor = wholeDescriptor } + , gifImages = (firstControl, firstImage) : rest } + | not (hasTransparency firstControl) = + let backImage = + generateImage (\_ _ -> backgroundColor) globalWidth globalHeight + thisPalette = paletteOf globalPalette firstImage + baseImage = decodeImage firstImage + initState = + (thisPalette, firstControl, substituteColors thisPalette baseImage) + scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage + palette' = Palette' + { _paletteSize = imageWidth thisPalette + , _paletteData = imageData thisPalette + } + in + PalettedRGB8 baseImage palette' : + [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest] - background = backgroundIndex wholeDescriptor - backgroundImage = generateImage (\_ _ -> background) globalWidth globalHeight + | otherwise = + let backImage :: Image PixelRGBA8 + backImage = + generateImage (\_ _ -> transparentBackground) globalWidth globalHeight - paletteApplyer (pal, _, img) = substituteColors pal img + thisPalette :: Image PixelRGBA8 + thisPalette = paletteOf (promoteImage globalPalette) firstImage - generator (_, prevControl, img1) - (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = - (thisPalette, controlExt, thisImage) - where thisPalette = paletteOf palette img2 - thisImage = generateImage pixeler globalWidth globalHeight - localWidth = fromIntegral $ gDescImageWidth descriptor - localHeight = fromIntegral $ gDescImageHeight descriptor + transparentCode = transparentColorOf firstControl + decoded = + substituteColorsWithTransparency transparentCode thisPalette $ + decodeImage firstImage - left = fromIntegral $ gDescPixelsFromLeft descriptor - top = fromIntegral $ gDescPixelsFromTop descriptor + initState = (thisPalette, firstControl, decoded) + scanner = + gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in + [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] - isPixelInLocalImage x y = - x >= left && x < left + localWidth && y >= top && y < top + localHeight + where + globalWidth = fromIntegral $ screenWidth wholeDescriptor + globalHeight = fromIntegral $ screenHeight wholeDescriptor + globalPalette = maybe greyPalette id palette - decoded = decodeImage img2 + transparentBackground = PixelRGBA8 r g b 0 + where PixelRGB8 r g b = backgroundColor - transparent :: Int - transparent = case controlExt of - Nothing -> 300 - Just ext -> if gceTransparentFlag ext - then fromIntegral $ gceTransparentColorIndex ext - else 300 + backgroundColor + | hasGlobalMap wholeDescriptor = + pixelAt globalPalette (fromIntegral $ backgroundIndex wholeDescriptor) 0 + | otherwise = PixelRGB8 0 0 0 - oldImage = case gceDisposalMethod <$> prevControl of - Nothing -> img1 - Just DisposalAny -> img1 - Just DisposalDoNot -> img1 - Just DisposalRestoreBackground -> backgroundImage - Just DisposalRestorePrevious -> img1 - Just (DisposalUnknown _) -> img1 +gifAnimationApplyer :: forall px. (ColorConvertible PixelRGB8 px) + => (Int, Int) -> Image px -> Image px + -> (Image px, Maybe GraphicControlExtension, Image px) + -> (Maybe GraphicControlExtension, GifImage) + -> (Image px, Maybe GraphicControlExtension, Image px) +gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage + (_, prevControl, img1) + (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = + (thisPalette, controlExt, thisImage) + where + thisPalette :: Image px + thisPalette = paletteOf globalPalette img2 - pixeler x y - | isPixelInLocalImage x y && fromIntegral val /= transparent = val - where val = pixelAt decoded (x - left) (y - top) - pixeler x y = pixelAt oldImage x y + thisImage = generateImage pixeler globalWidth globalHeight + localWidth = fromIntegral $ gDescImageWidth descriptor + localHeight = fromIntegral $ gDescImageHeight descriptor -decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) + left = fromIntegral $ gDescPixelsFromLeft descriptor + top = fromIntegral $ gDescPixelsFromTop descriptor + + isPixelInLocalImage x y = + x >= left && x < left + localWidth && y >= top && y < top + localHeight + + decoded :: Image Pixel8 + decoded = decodeImage img2 + + transparent :: Int + transparent = case controlExt of + Nothing -> 300 + Just ext -> if gceTransparentFlag ext + then fromIntegral $ gceTransparentColorIndex ext + else 300 + + oldImage = case gceDisposalMethod <$> prevControl of + Nothing -> img1 + Just DisposalAny -> img1 + Just DisposalDoNot -> img1 + Just DisposalRestoreBackground -> backgroundImage + Just DisposalRestorePrevious -> img1 + Just (DisposalUnknown _) -> img1 + + pixeler x y + | isPixelInLocalImage x y && code /= transparent = val where + code = fromIntegral $ pixelAt decoded (x - left) (y - top) + val = pixelAt thisPalette (fromIntegral code) 0 + pixeler x y = pixelAt oldImage x y + +decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas) decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = case decodeAllGifImages img { gifImages = [firstImage] } of [] -> Left "No image after decoding" - (i:_) -> Right i + (i:_) -> Right (i, basicMetadata SourceGif (screenWidth hdr) (screenHeight hdr)) + where hdr = gifScreenDescriptor $ gifHeader img decodeFirstGifImage _ = Left "No image in gif file" --- | Transform a raw gif image to an image, witout --- modifying the pixels. --- This function can output the following pixel types : +-- | Transform a raw gif image to an image, without modifying the pixels. This +-- function can output the following images: -- --- * PixelRGB8 +-- * 'ImageRGB8' -- +-- * 'ImageRGBA8' +-- decodeGif :: B.ByteString -> Either String DynamicImage -decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage) +decodeGif img = decode img >>= (fmap (palettedToTrueColor . fst) . decodeFirstGifImage) +-- | Transform a raw gif image to an image, without modifying the pixels. This +-- function can output the following images: +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGBA8' +-- +-- Metadatas include Width & Height information. +-- +decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeGifWithMetadata img = first palettedToTrueColor <$> decodeGifWithPaletteAndMetadata img + +-- | Return the gif image with metadata and palette. +-- The palette is only returned for the first image of an +-- animation and has no transparency. +decodeGifWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeGifWithPaletteAndMetadata img = decode img >>= decodeFirstGifImage + -- | Transform a raw gif to a list of images, representing -- all the images of an animation. -decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8] -decodeGifImages img = decodeAllGifImages <$> decode img +decodeGifImages :: B.ByteString -> Either String [DynamicImage] +decodeGifImages img = fmap palettedToTrueColor . decodeAllGifImages <$> decode img -- | Extract a list of frame delays from a raw gif. getDelaysGifImages :: B.ByteString -> Either String [GifDelay] @@ -627,6 +764,67 @@ where toGrey x _ = PixelRGB8 ix ix ix where ix = fromIntegral x +checkImageSizes :: GifEncode -> Either String () +checkImageSizes GifEncode { geWidth = width, geHeight = height, geFrames = frames } + | not $ isInBounds width && isInBounds height = Left "Invalid screen bounds" + | not $ null outOfBounds = Left $ "GIF frames with invalid bounds: " ++ show (map snd outOfBounds) + | otherwise = Right () + where isInBounds dim = dim > 0 && dim <= 0xffff + outOfBounds = filter (not . isFrameInBounds . fst) $ zip frames [0 :: Int ..] + isFrameInBounds GifFrame { gfPixels = img } = isInBounds (imageWidth img) && isInBounds (imageHeight img) + +checkImagesInBounds :: GifEncode -> Either String () +checkImagesInBounds GifEncode { geWidth = width, geHeight = height, geFrames = frames } = + if null outOfBounds + then Right () + else Left $ "GIF frames out of screen bounds: " ++ show (map snd outOfBounds) + where outOfBounds = filter (not . isInBounds . fst) $ zip frames [0 :: Int ..] + isInBounds GifFrame { gfXOffset = xOff, gfYOffset = yOff, gfPixels = img } = + xOff >= 0 && yOff >= 0 && + xOff + imageWidth img <= width && yOff + imageHeight img <= height + +checkPaletteValidity :: GifEncode -> Either String () +checkPaletteValidity spec + | not $ isPaletteValid $ gePalette spec = Left "Invalid global palette size" + | not $ null invalidPalettes = Left $ "Invalid palette size in GIF frames: " ++ show (map snd invalidPalettes) + | otherwise = Right () + where invalidPalettes = filter (not . isPaletteValid . gfPalette . fst) $ zip (geFrames spec) [0 :: Int ..] + isPaletteValid Nothing = True + isPaletteValid (Just p) = let w = imageWidth p + h = imageHeight p + in h == 1 && w > 0 && w <= 256 + +checkIndexAbsentFromPalette :: GifEncode -> Either String () +checkIndexAbsentFromPalette GifEncode { gePalette = global, geFrames = frames } = + if null missingPalette + then Right () + else Left $ "GIF image frames with color indexes missing from palette: " ++ show (map snd missingPalette) + where missingPalette = filter (not . checkFrame . fst) $ zip frames [0 :: Int ..] + checkFrame frame = V.all (checkIndexInPalette global (gfPalette frame) . fromIntegral) $ + imageData $ gfPixels frame + +checkBackground :: GifEncode -> Either String () +checkBackground GifEncode { geBackground = Nothing } = Right () +checkBackground GifEncode { gePalette = global, geBackground = Just background } = + if checkIndexInPalette global Nothing background + then Right () + else Left "GIF background index absent from global palette" + +checkTransparencies :: GifEncode -> Either String () +checkTransparencies GifEncode { gePalette = global, geFrames = frames } = + if null missingTransparency + then Right () + else Left $ "GIF transparent index absent from palettes for frames: " ++ show (map snd missingTransparency) + where missingTransparency = filter (not . transparencyOK . fst) $ zip frames [0 :: Int ..] + transparencyOK GifFrame { gfTransparent = Nothing } = True + transparencyOK GifFrame { gfPalette = local, gfTransparent = Just transparent } = + checkIndexInPalette global local transparent + +checkIndexInPalette :: Maybe Palette -> Maybe Palette -> Int -> Bool +checkIndexInPalette Nothing Nothing _ = False +checkIndexInPalette _ (Just local) ix = ix < imageWidth local +checkIndexInPalette (Just global) _ ix = ix < imageWidth global + checkGifImageSizes :: [(a, b, Image px)] -> Bool checkGifImageSizes [] = False checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest @@ -636,23 +834,116 @@ checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = w == width && h == height -checkPaletteValidity :: [(Palette, a, b)] -> Bool -checkPaletteValidity [] = False -checkPaletteValidity lst = - and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst - , let w = imageWidth p - h = imageHeight p ] - -areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool -areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img - where paletteElemCount = imageWidth palette - isTooBig v = fromIntegral v >= paletteElemCount - -computeMinimumLzwKeySize :: Palette -> Int -computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 +computeColorTableSize :: Palette -> Int +computeColorTableSize Image { imageWidth = itemCount } = go 1 where go k | 2 ^ k >= itemCount = k | otherwise = go $ k + 1 +-- | Encode a complex gif to a bytestring. +-- +-- * There must be at least one image. +-- +-- * The screen and every frame dimensions must be between 1 and 65535. +-- +-- * Every frame image must fit within the screen bounds. +-- +-- * Every palette must have between one and 256 colors. +-- +-- * There must be a global palette or every image must have a local palette. +-- +-- * The background color index must be present in the global palette. +-- +-- * Every frame's transparent color index, if set, must be present in the palette used by that frame. +-- +-- * Every color index used in an image must be present in the palette used by that frame. +-- +encodeComplexGifImage :: GifEncode -> Either String L.ByteString +encodeComplexGifImage spec = do + when (null $ geFrames spec) $ Left "No GIF frames" + checkImageSizes spec + checkImagesInBounds spec + checkPaletteValidity spec + checkBackground spec + checkTransparencies spec + checkIndexAbsentFromPalette spec + + Right $ encode allFile + where + GifEncode { geWidth = width + , geHeight = height + , gePalette = globalPalette + , geBackground = background + , geLooping = looping + , geFrames = frames + } = spec + allFile = GifFile + { gifHeader = GifHeader + { gifVersion = version + , gifScreenDescriptor = logicalScreen + , gifGlobalMap = globalPalette + } + , gifImages = toSerialize + , gifLoopingBehaviour = looping + } + + version = case frames of + [] -> GIF87a + [_] -> GIF87a + _:_:_ -> GIF89a + + logicalScreen = LogicalScreenDescriptor + { screenWidth = fromIntegral width + , screenHeight = fromIntegral height + , backgroundIndex = maybe 0 fromIntegral background + , hasGlobalMap = maybe False (const True) globalPalette + , colorResolution = 8 + , isColorTableSorted = False + -- Imply a 8 bit global palette size if there's no explicit global palette. + , colorTableSize = maybe 8 (fromIntegral . computeColorTableSize) globalPalette + } + + toSerialize = [(controlExtension delay transparent disposal, GifImage + { imgDescriptor = imageDescriptor left top localPalette img + , imgLocalPalette = localPalette + , imgLzwRootSize = fromIntegral lzwKeySize + , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img + }) + | GifFrame { gfXOffset = left + , gfYOffset = top + , gfPalette = localPalette + , gfTransparent = transparent + , gfDelay = delay + , gfDisposal = disposal + , gfPixels = img } <- frames + , let palette = case (globalPalette, localPalette) of + (_, Just local) -> local + (Just global, Nothing) -> global + (Nothing, Nothing) -> error "No palette for image" -- redundant, we guard for this + -- Some decoders (looking at you, GIMP) don't handle initial LZW key size of 1 correctly. + -- We'll waste some space for the sake of interoperability + , let lzwKeySize = max 2 $ computeColorTableSize palette + ] + + controlExtension 0 Nothing DisposalAny = Nothing + controlExtension delay transparent disposal = Just GraphicControlExtension + { gceDisposalMethod = disposal + , gceUserInputFlag = False + , gceTransparentFlag = maybe False (const True) transparent + , gceDelay = fromIntegral delay + , gceTransparentColorIndex = maybe 0 fromIntegral transparent + } + + imageDescriptor left top localPalette img = ImageDescriptor + { gDescPixelsFromLeft = fromIntegral left + , gDescPixelsFromTop = fromIntegral top + , gDescImageWidth = fromIntegral $ imageWidth img + , gDescImageHeight = fromIntegral $ imageHeight img + , gDescHasLocalMap = maybe False (const True) localPalette + , gDescIsInterlaced = False + , gDescIsImgDescriptorSorted = False + , gDescLocalColorTableSize = maybe 0 (fromIntegral . computeColorTableSize) localPalette + } + -- | Encode a gif animation to a bytestring. -- -- * Every image must have the same size @@ -664,62 +955,15 @@ encodeGifImages _ [] = Left "No image in list" encodeGifImages _ imageList | not $ checkGifImageSizes imageList = Left "Gif images have different size" - | not $ checkPaletteValidity imageList = - Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] - | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" -encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile +encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = + encodeComplexGifImage $ GifEncode (imageWidth firstImage) (imageHeight firstImage) (Just firstPalette) Nothing looping frames where - allFile = GifFile - { gifHeader = GifHeader - { gifVersion = GIF89a - , gifScreenDescriptor = logicalScreen - , gifGlobalMap = firstPalette - } - , gifImages = toSerialize - , gifLoopingBehaviour = looping - } - - logicalScreen = LogicalScreenDescriptor - { screenWidth = fromIntegral $ imageWidth firstImage - , screenHeight = fromIntegral $ imageHeight firstImage - , backgroundIndex = 0 - , hasGlobalMap = True - , colorResolution = 8 - , isColorTableSorted = False - , colorTableSize = 8 - } + frames = [ GifFrame 0 0 localPalette Nothing delay DisposalAny image + | (palette, delay, image) <- imageList + , let localPalette = if paletteEqual palette then Nothing else Just palette ] paletteEqual p = imageData firstPalette == imageData p - controlExtension 0 = Nothing - controlExtension delay = Just GraphicControlExtension - { gceDisposalMethod = DisposalAny - , gceUserInputFlag = False - , gceTransparentFlag = False - , gceDelay = fromIntegral delay - , gceTransparentColorIndex = 0 - } - - toSerialize = [(controlExtension delay, GifImage - { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img - , imgLocalPalette = Just palette - , imgLzwRootSize = fromIntegral $ lzwKeySize - , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img - }) | (palette, delay, img) <- imageList - , let lzwKeySize = computeMinimumLzwKeySize palette - ] - - imageDescriptor paletteSize palEqual img = ImageDescriptor - { gDescPixelsFromLeft = 0 - , gDescPixelsFromTop = 0 - , gDescImageWidth = fromIntegral $ imageWidth img - , gDescImageHeight = fromIntegral $ imageHeight img - , gDescHasLocalMap = paletteSize > 0 && not palEqual - , gDescIsInterlaced = False - , gDescIsImgDescriptorSorted = False - , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize - } - -- | Encode a greyscale image to a bytestring. encodeGifImage :: Image Pixel8 -> L.ByteString encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of @@ -758,3 +1002,5 @@ writeGifImageWithPalette file img palette = L.writeFile file <$> encodeGifImageWithPalette img palette +writeComplexGifImage :: FilePath -> GifEncode -> Either String (IO ()) +writeComplexGifImage file spec = L.writeFile file <$> encodeComplexGifImage spec diff --git a/src/Codec/Picture/Gif/Internal/LZW.hs b/src/Codec/Picture/Gif/Internal/LZW.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Gif/Internal/LZW.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE CPP #-} +module Codec.Picture.Gif.Internal.LZW( decodeLzw, decodeLzwTiff ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Word( Word8 ) +import Control.Monad( when, unless ) + +import Data.Bits( (.&.) ) + +import Control.Monad.ST( ST ) +import Control.Monad.Trans.Class( MonadTrans, lift ) + +import Foreign.Storable ( Storable ) + +import qualified Data.ByteString as B +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.BitWriter + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a +(.!!!.) = M.unsafeRead + {-M.read-} + +{-# INLINE (..!!!..) #-} +(..!!!..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> t (ST s) a +(..!!!..) v idx = lift $ v .!!!. idx + +{-# INLINE (.<-.) #-} +(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () +(.<-.) = M.unsafeWrite + {-M.write-} + +{-# INLINE (..<-..) #-} +(..<-..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> a -> t (ST s) () +(..<-..) v idx = lift . (v .<-. idx) + + +duplicateData :: (MonadTrans t, Storable a) + => M.STVector s a -> M.STVector s a + -> Int -> Int -> Int -> t (ST s) () +duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex + where endIndex = sourceIndex + size + aux i _ | i == endIndex = return () + aux i j = do + src .!!!. i >>= (dest .<-. j) + aux (i + 1) (j + 1) + +rangeSetter :: (Storable a, Num a) + => Int -> M.STVector s a + -> ST s (M.STVector s a) +rangeSetter count vec = aux 0 + where aux n | n == count = return vec + aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) + +decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +decodeLzw str maxBitKey initialKey outVec = do + setDecodedString str + lzw GifVariant maxBitKey initialKey 0 outVec + +isOldTiffLZW :: B.ByteString -> Bool +isOldTiffLZW str = firstByte == 0 && secondByte == 1 + where firstByte = str `B.index` 0 + secondByte = (str `B.index` 1) .&. 1 + +decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int + -> BoolReader s() +decodeLzwTiff str outVec initialWriteIdx = do + if isOldTiffLZW str then + setDecodedString str + else + setDecodedStringMSB str + let variant | isOldTiffLZW str = OldTiffVariant + | otherwise = TiffVariant + lzw variant 12 9 initialWriteIdx outVec + +data TiffVariant = + GifVariant + | TiffVariant + | OldTiffVariant + deriving Eq + +-- | Gif image constraint from spec-gif89a, code size max : 12 bits. +lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do + -- Allocate buffer of maximum size. + lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray + lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray + lzwSizeTable <- lift $ M.replicate tableEntryCount 0 + lift $ lzwSizeTable `M.set` 1 + + let firstVal code = do + dataOffset <- lzwOffsetTable ..!!!.. code + lzwData ..!!!.. dataOffset + + writeString at code = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (at + dataSize <= maxWrite) $ + duplicateData lzwData outVec dataOffset dataSize at + + return dataSize + + addString pos at code val = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (pos < tableEntryCount) $ do + (lzwOffsetTable ..<-.. pos) at + (lzwSizeTable ..<-.. pos) $ dataSize + 1 + + when (at + dataSize + 1 <= maxDataSize) $ do + duplicateData lzwData lzwData dataOffset dataSize at + (lzwData ..<-.. (at + dataSize)) val + + return $ dataSize + 1 + + maxWrite = M.length outVec + loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code + | outWriteIdx >= maxWrite = return () + | code == endOfInfo = return () + | code == clearCode = do + toOutput <- getNextCode startCodeSize + unless (toOutput == endOfInfo) $ do + dataSize <- writeString outWriteIdx toOutput + getNextCode startCodeSize >>= + loop (outWriteIdx + dataSize) + firstFreeIndex firstFreeIndex startCodeSize toOutput + + | otherwise = do + (written, dicAdd) <- + if code >= writeIdx then do + c <- firstVal oldCode + wroteSize <- writeString outWriteIdx oldCode + (outVec ..<-.. (outWriteIdx + wroteSize)) c + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize + 1, addedSize) + else do + wroteSize <- writeString outWriteIdx code + c <- firstVal code + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize, addedSize) + + let new_code_size = updateCodeSize codeSize $ writeIdx + 1 + getNextCode new_code_size >>= + loop (outWriteIdx + written) + (writeIdx + 1) + (dicWriteIdx + dicAdd) + new_code_size + code + + getNextCode startCodeSize >>= + loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 + + where tableEntryCount = 2 ^ min 12 nMaxBitKeySize + maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 + + isNewTiff = variant == TiffVariant + (switchOffset, isTiffVariant) = case variant of + GifVariant -> (0, False) + TiffVariant -> (1, True) + OldTiffVariant -> (0, True) + + initialElementCount = 2 ^ initialKeySize :: Int + clearCode | isTiffVariant = 256 + | otherwise = initialElementCount + + endOfInfo | isTiffVariant = 257 + | otherwise = clearCode + 1 + + startCodeSize + | isTiffVariant = initialKeySize + | otherwise = initialKeySize + 1 + + firstFreeIndex = endOfInfo + 1 + + resetArray a = lift $ rangeSetter initialElementCount a + + updateCodeSize codeSize writeIdx + | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 + | otherwise = codeSize + + getNextCode s + | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s + | otherwise = fromIntegral <$> getNextBitsLSBFirst s + diff --git a/src/Codec/Picture/Gif/Internal/LZWEncoding.hs b/src/Codec/Picture/Gif/Internal/LZWEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Gif/Internal/LZWEncoding.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE BangPatterns, CPP #-} +module Codec.Picture.Gif.Internal.LZWEncoding( lzwEncode ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +import Data.Monoid( mempty ) +#endif + +import Control.Monad.ST( runST ) +import qualified Data.ByteString.Lazy as L +import Data.Maybe( fromMaybe ) +import Data.Word( Word8 ) + +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as I +#else +import qualified Data.IntMap as I +#endif +import qualified Data.Vector.Storable as V + +import Codec.Picture.BitWriter + +type Trie = I.IntMap TrieNode + +data TrieNode = TrieNode + { trieIndex :: {-# UNPACK #-} !Int + , trieSub :: !Trie + } + +emptyNode :: TrieNode +emptyNode = TrieNode + { trieIndex = -1 + , trieSub = mempty + } + +initialTrie :: Trie +initialTrie = I.fromList + [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]] + +lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie) +lookupUpdate vector freeIndex firstIndex trie = + matchUpdate $ go trie 0 firstIndex + where + matchUpdate (lzwOutputIndex, nextReadIndex, sub) = + (lzwOutputIndex, nextReadIndex, fromMaybe trie sub) + + maxi = V.length vector + go !currentTrie !prevIndex !index + | index >= maxi = (prevIndex, index, Nothing) + | otherwise = case I.lookup val currentTrie of + Just (TrieNode ix subTable) -> + let (lzwOutputIndex, nextReadIndex, newTable) = + go subTable ix $ index + 1 + tableUpdater t = + I.insert val (TrieNode ix t) currentTrie + in + (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable) + + Nothing | index == maxi -> (prevIndex, index, Nothing) + | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie) + + where val = fromIntegral $ vector `V.unsafeIndex` index + newNode = emptyNode { trieIndex = freeIndex } + +lzwEncode :: Int -> V.Vector Word8 -> L.ByteString +lzwEncode initialKeySize vec = runST $ do + bitWriter <- newWriteStateRef + + let updateCodeSize 12 writeIdx _ + | writeIdx == 2 ^ (12 :: Int) - 1 = do + writeBitsGif bitWriter (fromIntegral clearCode) 12 + return (startCodeSize, firstFreeIndex, initialTrie) + + updateCodeSize codeSize writeIdx trie + | writeIdx == 2 ^ codeSize = + return (codeSize + 1, writeIdx + 1, trie) + | otherwise = return (codeSize, writeIdx + 1, trie) + + go readIndex (codeSize, _, _) | readIndex >= maxi = + writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize + go !readIndex (!codeSize, !writeIndex, !trie) = do + let (indexToWrite, endIndex, trie') = + lookuper writeIndex readIndex trie + writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize + updateCodeSize codeSize writeIndex trie' + >>= go endIndex + + writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize + go 0 (startCodeSize, firstFreeIndex, initialTrie) + + finalizeBoolWriterGif bitWriter + where + maxi = V.length vec + + startCodeSize = initialKeySize + 1 + + clearCode = 2 ^ initialKeySize :: Int + endOfInfo = clearCode + 1 + firstFreeIndex = endOfInfo + 1 + + lookuper = lookupUpdate vec diff --git a/src/Codec/Picture/Gif/LZW.hs b/src/Codec/Picture/Gif/LZW.hs deleted file mode 100644 --- a/src/Codec/Picture/Gif/LZW.hs +++ /dev/null @@ -1,189 +0,0 @@ -module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where - -import Data.Word( Word8 ) -import Control.Applicative( (<$>) ) -import Control.Monad( when ) - -import Data.Bits( (.&.) ) - -import Control.Monad.ST( ST ) -import Control.Monad.Trans.Class( MonadTrans, lift ) - -import Foreign.Storable ( Storable ) - -import qualified Data.ByteString as B -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.BitWriter - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a -(.!!!.) = M.unsafeRead - {-M.read-} - -{-# INLINE (..!!!..) #-} -(..!!!..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> t (ST s) a -(..!!!..) v idx = lift $ v .!!!. idx - -{-# INLINE (.<-.) #-} -(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () -(.<-.) = M.unsafeWrite - {-M.write-} - -{-# INLINE (..<-..) #-} -(..<-..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> a -> t (ST s) () -(..<-..) v idx = lift . (v .<-. idx) - - -duplicateData :: (Show a, MonadTrans t, Storable a) - => M.STVector s a -> M.STVector s a - -> Int -> Int -> Int -> t (ST s) () -duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex - where endIndex = sourceIndex + size - aux i _ | i == endIndex = return () - aux i j = do - src .!!!. i >>= (dest .<-. j) - aux (i + 1) (j + 1) - -rangeSetter :: (Storable a, Num a) - => Int -> M.STVector s a - -> ST s (M.STVector s a) -rangeSetter count vec = aux 0 - where aux n | n == count = return vec - aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) - -decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -decodeLzw str maxBitKey initialKey outVec = do - setDecodedString str - lzw GifVariant maxBitKey initialKey 0 outVec - -isOldTiffLZW :: B.ByteString -> Bool -isOldTiffLZW str = firstByte == 0 && secondByte == 1 - where firstByte = str `B.index` 0 - secondByte = (str `B.index` 1) .&. 1 - -decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int - -> BoolReader s() -decodeLzwTiff str outVec initialWriteIdx = do - setDecodedString str - let variant | isOldTiffLZW str = OldTiffVariant - | otherwise = TiffVariant - lzw variant 12 9 initialWriteIdx outVec - -data TiffVariant = - GifVariant - | TiffVariant - | OldTiffVariant - deriving Eq - --- | Gif image constraint from spec-gif89a, code size max : 12 bits. -lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do - -- Allocate buffer of maximum size. - lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray - lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray - lzwSizeTable <- lift $ M.replicate tableEntryCount 0 - lift $ lzwSizeTable `M.set` 1 - - let firstVal code = do - dataOffset <- lzwOffsetTable ..!!!.. code - lzwData ..!!!.. dataOffset - - writeString at code = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (at + dataSize <= maxWrite) $ - duplicateData lzwData outVec dataOffset dataSize at - - return dataSize - - addString pos at code val = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (pos < tableEntryCount) $ do - (lzwOffsetTable ..<-.. pos) at - (lzwSizeTable ..<-.. pos) $ dataSize + 1 - - when (at + dataSize + 1 <= maxDataSize) $ do - duplicateData lzwData lzwData dataOffset dataSize at - (lzwData ..<-.. (at + dataSize)) val - - return $ dataSize + 1 - - maxWrite = M.length outVec - loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code - | outWriteIdx >= maxWrite = return () - | code == endOfInfo = return () - | code == clearCode = do - toOutput <- getNextCode startCodeSize - if toOutput == endOfInfo then - return () - else do - dataSize <- writeString outWriteIdx toOutput - getNextCode startCodeSize >>= - loop (outWriteIdx + dataSize) - firstFreeIndex firstFreeIndex startCodeSize toOutput - - | otherwise = do - (written, dicAdd) <- - if code >= writeIdx then do - c <- firstVal oldCode - wroteSize <- writeString outWriteIdx oldCode - (outVec ..<-.. (outWriteIdx + wroteSize)) c - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize + 1, addedSize) - else do - wroteSize <- writeString outWriteIdx code - c <- firstVal code - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize, addedSize) - - let new_code_size = updateCodeSize codeSize $ writeIdx + 1 - getNextCode new_code_size >>= - loop (outWriteIdx + written) - (writeIdx + 1) - (dicWriteIdx + dicAdd) - new_code_size - code - - getNextCode startCodeSize >>= - loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 - - where tableEntryCount = 2 ^ min 12 nMaxBitKeySize - maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 - - isNewTiff = variant == TiffVariant - (switchOffset, isTiffVariant) = case variant of - GifVariant -> (0, False) - TiffVariant -> (1, True) - OldTiffVariant -> (0, True) - - initialElementCount = 2 ^ initialKeySize :: Int - clearCode | isTiffVariant = 256 - | otherwise = initialElementCount - - endOfInfo | isTiffVariant = 257 - | otherwise = clearCode + 1 - - startCodeSize - | isTiffVariant = initialKeySize - | otherwise = initialKeySize + 1 - - firstFreeIndex = endOfInfo + 1 - - resetArray a = lift $ rangeSetter initialElementCount a - - updateCodeSize codeSize writeIdx - | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 - | otherwise = codeSize - - getNextCode s - | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s - | otherwise = fromIntegral <$> getNextBitsLSBFirst s - diff --git a/src/Codec/Picture/Gif/LZWEncoding.hs b/src/Codec/Picture/Gif/LZWEncoding.hs deleted file mode 100644 --- a/src/Codec/Picture/Gif/LZWEncoding.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} -module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where - -import Control.Applicative( (<$>) ) -import Control.Monad.ST( runST ) -import qualified Data.ByteString.Lazy as L -import Data.Maybe( fromMaybe ) -import Data.Monoid( mempty ) -import Data.Word( Word8 ) -#if MIN_VERSION_containers(0,5,0) -import qualified Data.IntMap.Strict as I -#else -import qualified Data.IntMap as I -#endif -import qualified Data.Vector.Storable as V - -import Codec.Picture.BitWriter - -type Trie = I.IntMap TrieNode - -data TrieNode = TrieNode - { trieIndex :: {-# UNPACK #-} !Int - , trieSub :: !Trie - } - -emptyNode :: TrieNode -emptyNode = TrieNode - { trieIndex = -1 - , trieSub = mempty - } - -initialTrie :: Trie -initialTrie = I.fromList - [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]] - -lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie) -lookupUpdate vector freeIndex firstIndex trie = - matchUpdate $ go trie 0 firstIndex - where - matchUpdate (lzwOutputIndex, nextReadIndex, sub) = - (lzwOutputIndex, nextReadIndex, fromMaybe trie sub) - - maxi = V.length vector - go !currentTrie !prevIndex !index - | index >= maxi = (prevIndex, index, Nothing) - | otherwise = case I.lookup val currentTrie of - Just (TrieNode ix subTable) -> - let (lzwOutputIndex, nextReadIndex, newTable) = - go subTable ix $ index + 1 - tableUpdater t = - I.insert val (TrieNode ix t) currentTrie - in - (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable) - - Nothing | index == maxi -> (prevIndex, index, Nothing) - | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie) - - where val = fromIntegral $ vector `V.unsafeIndex` index - newNode = emptyNode { trieIndex = freeIndex } - -lzwEncode :: Int -> V.Vector Word8 -> L.ByteString -lzwEncode initialKeySize vec = runST $ do - bitWriter <- newWriteStateRef - - let updateCodeSize 12 writeIdx _ - | writeIdx == 2 ^ (12 :: Int) - 1 = do - writeBitsGif bitWriter (fromIntegral clearCode) 12 - return (startCodeSize, firstFreeIndex, initialTrie) - - updateCodeSize codeSize writeIdx trie - | writeIdx == 2 ^ codeSize = - return (codeSize + 1, writeIdx + 1, trie) - | otherwise = return (codeSize, writeIdx + 1, trie) - - go readIndex (codeSize, _, _) | readIndex >= maxi = - writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize - go !readIndex (!codeSize, !writeIndex, !trie) = do - let (indexToWrite, endIndex, trie') = - lookuper writeIndex readIndex trie - writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize - updateCodeSize codeSize writeIndex trie' - >>= go endIndex - - writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize - go 0 (startCodeSize, firstFreeIndex, initialTrie) - - finalizeBoolWriter bitWriter - where - maxi = V.length vec - - startCodeSize = initialKeySize + 1 - - clearCode = 2 ^ initialKeySize :: Int - endOfInfo = clearCode + 1 - firstFreeIndex = endOfInfo + 1 - - lookuper = lookupUpdate vec diff --git a/src/Codec/Picture/HDR.hs b/src/Codec/Picture/HDR.hs --- a/src/Codec/Picture/HDR.hs +++ b/src/Codec/Picture/HDR.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} -- | Module dedicated of Radiance file decompression (.hdr or .pic) file. -- Radiance file format is used for High dynamic range imaging. module Codec.Picture.HDR( decodeHDR + , decodeHDRWithMetadata , encodeHDR , encodeRawHDR , encodeRLENewStyleHDR @@ -10,12 +12,19 @@ , writeRLENewStyleHDR ) where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) import Data.Char( ord, chr, isDigit ) import Data.Word( Word8 ) + +#if !MIN_VERSION_base(4,11,0) import Data.Monoid( (<>) ) -import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( when, foldM, foldM_, forM, forM_ ) +#endif + +import Control.Monad( when, foldM, foldM_, forM, forM_, unless ) import Control.Monad.Trans.Class( lift ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -32,6 +41,9 @@ import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceHDR ) + , basicMetadata ) import Codec.Picture.InternalHelper import Codec.Picture.Types import Codec.Picture.VectorByteConversion @@ -160,18 +172,22 @@ c -> (:) <$> parsePair c <*> decodeInfos --- | Decode an HDR (radiance) image, the resulting pixel --- type can be : +-- | Decode an HDR (radiance) image, the resulting image can be: -- --- * PixelRGBF +-- * 'ImageRGBF' -- decodeHDR :: B.ByteString -> Either String DynamicImage -decodeHDR str = runST $ runExceptT $ do - case runGet decodeHeader $ L.fromChunks [str] of - Left err -> throwE err - Right rez -> - ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) +decodeHDR = fmap fst . decodeHDRWithMetadata +-- | Equivalent to decodeHDR but with aditional metadatas. +decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeHDRWithMetadata str = runST $ runExceptT $ + case runGet decodeHeader $ L.fromChunks [str] of + Left err -> throwE err + Right rez -> + let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $ radianceHeight rez) in + (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) + getChar8 :: Get Char getChar8 = chr . fromIntegral <$> getWord8 @@ -187,11 +203,11 @@ letter <- getChar8 space <- getChar8 - when (not $ isSign sign && isAxisLetter letter && space == ' ') - (fail "Invalid radiance size declaration") + unless (isSign sign && isAxisLetter letter && space == ' ') + (fail "Invalid radiance size declaration") let numDec acc c | isDigit c = - getChar8 >>= numDec (acc * 10 + ord c - (ord '0')) + getChar8 >>= numDec (acc * 10 + ord c - ord '0') numDec acc _ | sign == '-' = pure $ negate acc | otherwise = pure acc @@ -371,7 +387,7 @@ case val == prev of True -> runLength (n + 1) 0 prev (idx + 1) at False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at - False -> do + False -> pushRun n prev at >>= runLength 1 0 val (idx + 1) @@ -379,7 +395,7 @@ val <- vec `M.unsafeRead` idx if val /= prev then runLength 0 (n + 1) val (idx + 1) at - else do + else pushData (idx - 1) (n - 1) at >>= runLength (2 :: Int) 0 val (idx + 1) @@ -464,7 +480,7 @@ (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff - pure $ RadianceHeader + pure RadianceHeader { radianceInfos = [] , radianceFormat = FormatRGBE , radianceHeight = h @@ -473,7 +489,7 @@ } -decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF)) +decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) decodeRadiancePicture hdr = do let width = abs $ radianceWidth hdr height = abs $ radianceHeight hdr diff --git a/src/Codec/Picture/InternalHelper.hs b/src/Codec/Picture/InternalHelper.hs --- a/src/Codec/Picture/InternalHelper.hs +++ b/src/Codec/Picture/InternalHelper.hs @@ -13,39 +13,20 @@ ) import qualified Data.Binary.Get as G -#if MIN_VERSION_binary(0,6,4) -#else -import Control.Applicative( (<$>) ) -import qualified Control.Exception as E --- I feel so dirty. :( -import System.IO.Unsafe( unsafePerformIO ) -#endif - decode :: (Binary a) => B.ByteString -> Either String a decode = runGetStrict get runGet :: Get a -> L.ByteString -> Either String a -#if MIN_VERSION_binary(0,6,4) runGet act = unpack . G.runGetOrFail act where unpack (Left (_, _, str)) = Left str unpack (Right (_, _, element)) = Right element -#else -runGet act str = unsafePerformIO $ E.catch - (Right <$> E.evaluate (G.runGet act str)) - (\msg -> return . Left $ show (msg :: E.SomeException)) -#endif runGetStrict :: Get a -> B.ByteString -> Either String a runGetStrict act buffer = runGet act $ L.fromChunks [buffer] getRemainingBytes :: Get B.ByteString -getRemainingBytes = do - rest <- getRemainingLazyByteString - return $ case L.toChunks rest of - [] -> B.empty - [a] -> a - lst -> B.concat lst +getRemainingBytes = L.toStrict <$> getRemainingLazyByteString getRemainingLazyBytes :: Get L.ByteString -getRemainingLazyBytes = getRemainingLazyByteString +getRemainingLazyBytes = getRemainingLazyByteString 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 @@ -4,21 +4,36 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fspec-constr-count=5 #-} -- | Module used for JPEG file loading and writing. module Codec.Picture.Jpg( decodeJpeg + , decodeJpegWithMetadata , encodeJpegAtQuality + , encodeJpegAtQualityWithMetadata + , encodeDirectJpegAtQualityWithMetadata , encodeJpeg + , JpgEncodable ) where -import Control.Arrow( (>>>) ) +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( foldMap ) +import Data.Monoid( mempty ) import Control.Applicative( pure, (<$>) ) +#endif + +import Control.Applicative( (<|>) ) + +import Control.Arrow( (>>>) ) import Control.Monad( when, forM_ ) import Control.Monad.ST( ST, runST ) import Control.Monad.Trans( lift ) import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS ) import Data.Bits( (.|.), unsafeShiftL ) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif import Data.Int( Int16, Int32 ) import Data.Word(Word8, Word32) import Data.Binary( Binary(..), encode ) @@ -36,11 +51,17 @@ import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.Common -import Codec.Picture.Jpg.Progressive -import Codec.Picture.Jpg.DefaultTable -import Codec.Picture.Jpg.FastDct +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceJpeg ) + , basicMetadata ) +import Codec.Picture.Tiff.Internal.Types +import Codec.Picture.Tiff.Internal.Metadata +import Codec.Picture.Jpg.Internal.Types +import Codec.Picture.Jpg.Internal.Common +import Codec.Picture.Jpg.Internal.Progressive +import Codec.Picture.Jpg.Internal.DefaultTable +import Codec.Picture.Jpg.Internal.FastDct +import Codec.Picture.Jpg.Internal.Metadata quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32) @@ -144,7 +165,7 @@ val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) (img `M.unsafeWrite` idx) val0 - (img `M.unsafeWrite` (idx + (3 * 1))) val1 + (img `M.unsafeWrite` (idx + 3 )) val1 (img `M.unsafeWrite` (idx + (3 * 2))) val2 (img `M.unsafeWrite` (idx + (3 * 3))) val3 (img `M.unsafeWrite` (idx + (3 * 4))) val4 @@ -189,8 +210,8 @@ (img `M.unsafeWrite` idx) v0 (img `M.unsafeWrite` (idx + 3)) v0 - (img `M.unsafeWrite` (idx + 6 * 1)) v1 - (img `M.unsafeWrite` (idx + 6 * 1 + 3)) v1 + (img `M.unsafeWrite` (idx + 6 )) v1 + (img `M.unsafeWrite` (idx + 6 + 3)) v1 (img `M.unsafeWrite` (idx + 6 * 2)) v2 (img `M.unsafeWrite` (idx + 6 * 2 + 3)) v2 @@ -228,7 +249,10 @@ , quantizationMatrices :: !(V.Vector (MacroBlock Int16)) , currentRestartInterv :: !Int , currentFrame :: Maybe JpgFrameHeader - , minimumComponentIndex :: !Int + , app14Marker :: !(Maybe JpgAdobeApp14) + , app0JFifMarker :: !(Maybe JpgJFIFApp0) + , app1ExifMarker :: !(Maybe [ImageFileDirectory]) + , componentIndexMapping :: ![(Word8, Int)] , isProgressive :: !Bool , maximumHorizontalResolution :: !Int , maximumVerticalResolution :: !Int @@ -252,7 +276,10 @@ , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1) , currentRestartInterv = -1 , currentFrame = Nothing - , minimumComponentIndex = 1 + , componentIndexMapping = [] + , app14Marker = Nothing + , app0JFifMarker = Nothing + , app1ExifMarker = Nothing , isProgressive = False , maximumHorizontalResolution = 0 , maximumVerticalResolution = 0 @@ -262,6 +289,12 @@ -- | This pseudo interpreter interpret the Jpg frame for the huffman, -- quant table and restart interval parameters. jpgMachineStep :: JpgFrame -> JpgScripter s () +jpgMachineStep (JpgAdobeAPP14 app14) = modify $ \s -> + s { app14Marker = Just app14 } +jpgMachineStep (JpgExif exif) = modify $ \s -> + s { app1ExifMarker = Just exif } +jpgMachineStep (JpgJFIF app0) = modify $ \s -> + s { app0JFifMarker = Just app0 } jpgMachineStep (JpgAppFrame _ _) = pure () jpgMachineStep (JpgExtension _ _) = pure () jpgMachineStep (JpgScanBlob hdr raw_data) = do @@ -276,13 +309,15 @@ scanSpecifier scanCount scanSpec = do - minimumIndex <- gets minimumComponentIndex + compMapping <- gets componentIndexMapping + comp <- case lookup (componentSelector scanSpec) compMapping of + Nothing -> error "Jpg decoding error - bad component selector in blob." + Just v -> return v let maximumHuffmanTable = 4 dcIndex = min (maximumHuffmanTable - 1) . fromIntegral $ dcEntropyCodingTable scanSpec acIndex = min (maximumHuffmanTable - 1) . fromIntegral $ acEntropyCodingTable scanSpec - comp = fromIntegral (componentSelector scanSpec) - minimumIndex dcTree <- gets $ (V.! dcIndex) . dcDecoderTables acTree <- gets $ (V.! acIndex) . acDecoderTables @@ -293,7 +328,7 @@ frameInfo <- gets currentFrame blobId <- gets seenBlobs case frameInfo of - Nothing -> fail "Jpg decoding error - no previous frame" + Nothing -> error "Jpg decoding error - no previous frame" Just v -> do let compDesc = jpgComponents v !! comp compCount = length $ jpgComponents v @@ -320,7 +355,7 @@ , coefficientRange = ( fromIntegral selectionLow , fromIntegral selectionHigh ) - , blockIndex = y * ySampling + x + , blockIndex = y * xSampling + x , blockMcuX = x , blockMcuY = y }, unpackerDecision compCount componentSubSampling) @@ -329,8 +364,8 @@ jpgMachineStep (JpgScans kind hdr) = modify $ \s -> s { currentFrame = Just hdr - , minimumComponentIndex = - fromIntegral $ minimum [componentIdentifier comp | comp <- jpgComponents hdr] + , componentIndexMapping = + [(componentIdentifier comp, ix) | (ix, comp) <- zip [0..] $ jpgComponents hdr] , isProgressive = case kind of JpgProgressiveDCTHuffman -> True _ -> False @@ -350,7 +385,7 @@ if idx >= V.length (dcDecoderTables s) then s else let neu = dcDecoderTables s // [(idx, tree)] in - s { dcDecoderTables = neu `seq` neu } + s { dcDecoderTables = neu } where idx = fromIntegral $ huffmanTableDest spec AcComponent -> modify $ \s -> @@ -368,7 +403,7 @@ unpackerDecision :: Int -> (Int, Int) -> Unpacker s unpackerDecision 1 (1, 1) = unpack444Y -unpackerDecision _ (1, 1) = unpack444Ycbcr +unpackerDecision 3 (1, 1) = unpack444Ycbcr unpackerDecision _ (2, 1) = unpack421Ycbcr unpackerDecision compCount (xScalingFactor, yScalingFactor) = unpackMacroBlock compCount xScalingFactor yScalingFactor @@ -377,7 +412,7 @@ -> V.Vector (MacroBlock Int16) -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] -> MutableImage s PixelYCbCr8 -- ^ Result image to write into - -> ST s () + -> ST s (MutableImage s PixelYCbCr8) decodeImage frame quants lst outImage = do let compCount = length $ jpgComponents frame zigZagArray <- createEmptyMutableMacroBlock @@ -387,12 +422,19 @@ forM_ lst $ \(params, str) -> do let componentsInfo = V.fromList params compReader = initBoolStateJpg . B.concat $ L.toChunks str - maxiW = maximum [fst $ subSampling c | (c,_) <- params] - maxiH = maximum [snd $ subSampling c | (c,_) <- params] + maxiSubSampW = maximum [fst $ subSampling c | (c,_) <- params] + maxiSubSampH = maximum [snd $ subSampling c | (c,_) <- params] - imageBlockWidth = (imgWidth + 7) `div` 8 - imageBlockHeight = (imgHeight + 7) `div` 8 + (maxiW, maxiH) = + if length params > 1 then + (maximum [componentWidth c | (c,_) <- params], + maximum [componentHeight c | (c,_) <- params]) + else + (maxiSubSampW, maxiSubSampH) + imageBlockWidth = toBlockSize imgWidth + imageBlockHeight = toBlockSize imgHeight + imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH @@ -412,7 +454,7 @@ acTree = acHuffmanTree comp quantId = fromIntegral . quantizationTableDest $ jpgComponents frame !! compIdx - qTable = quants V.! (min 3 quantId) + qTable = quants V.! min 3 quantId xd = blockMcuX comp yd = blockMcuY comp (subX, subY) = subSampling comp @@ -428,6 +470,8 @@ else lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block + return outImage + where imgComponentCount = length $ jpgComponents frame imgWidth = fromIntegral $ jpgWidth frame @@ -440,68 +484,159 @@ gatherImageKind lst = case [k | JpgScans k _ <- lst, isDctSpecifier k] of [JpgBaselineDCTHuffman] -> Just BaseLineDCT [JpgProgressiveDCTHuffman] -> Just ProgressiveDCT + [JpgExtendedSequentialDCTHuffman] -> Just BaseLineDCT _ -> Nothing where isDctSpecifier JpgProgressiveDCTHuffman = True isDctSpecifier JpgBaselineDCTHuffman = True + isDctSpecifier JpgExtendedSequentialDCTHuffman = True isDctSpecifier _ = False gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img] --- | Try to decompress a jpeg file and decompress. The colorspace is still --- YCbCr if you want to perform computation on the luma part. You can --- convert it to RGB using 'convertImage' from the 'ColorSpaceConvertible' --- typeclass. +dynamicOfColorSpace :: Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8 + -> Either String DynamicImage +dynamicOfColorSpace Nothing _ _ _ = Left "Unknown color space" +dynamicOfColorSpace (Just color) w h imgData = case color of + JpgColorSpaceCMYK -> return . ImageCMYK8 $ Image w h imgData + JpgColorSpaceYCCK -> + let ymg = Image w h $ VS.map (255-) imgData :: Image PixelYCbCrK8 in + return . ImageCMYK8 $ convertImage ymg + JpgColorSpaceYCbCr -> return . ImageYCbCr8 $ Image w h imgData + JpgColorSpaceRGB -> return . ImageRGB8 $ Image w h imgData + JpgColorSpaceYA -> return . ImageYA8 $ Image w h imgData + JpgColorSpaceY -> return . ImageY8 $ Image w h imgData + colorSpace -> Left $ "Wrong color space : " ++ show colorSpace + +colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace +colorSpaceOfAdobe compCount app = case (compCount, _adobeTransform app) of + (3, AdobeYCbCr) -> pure JpgColorSpaceYCbCr + (1, AdobeUnknown) -> pure JpgColorSpaceY + (3, AdobeUnknown) -> pure JpgColorSpaceRGB + (4, AdobeYCck) -> pure JpgColorSpaceYCCK + {-(4, AdobeUnknown) -> pure JpgColorSpaceCMYKInverted-} + _ -> Nothing + +colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace +colorSpaceOfState st = do + hdr <- currentFrame st + let compStr = [toEnum . fromEnum $ componentIdentifier comp + | comp <- jpgComponents hdr] + app14 = do + marker <- app14Marker st + colorSpaceOfAdobe (length compStr) marker + app14 <|> colorSpaceOfComponentStr compStr + + +colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace +colorSpaceOfComponentStr s = case s of + [_] -> pure JpgColorSpaceY + [_,_] -> pure JpgColorSpaceYA + "\0\1\2" -> pure JpgColorSpaceYCbCr + "\1\2\3" -> pure JpgColorSpaceYCbCr + "RGB" -> pure JpgColorSpaceRGB + "YCc" -> pure JpgColorSpaceYCC + [_,_,_] -> pure JpgColorSpaceYCbCr + + "RGBA" -> pure JpgColorSpaceRGBA + "YCcA" -> pure JpgColorSpaceYCCA + "CMYK" -> pure JpgColorSpaceCMYK + "YCcK" -> pure JpgColorSpaceYCCK + [_,_,_,_] -> pure JpgColorSpaceCMYK + _ -> Nothing + +-- | Try to decompress and decode a jpeg file. The colorspace is still +-- YCbCr if you want to perform computation on the luma part. You can convert it +-- to RGB using 'convertImage' from the 'ColorSpaceConvertible' typeclass. -- --- This function can output the following pixel types : +-- This function can output the following images: -- --- * PixelY8 +-- * 'ImageY8' -- --- * PixelYCbCr8 +-- * 'ImageYA8' -- +-- * 'ImageRGB8' +-- +-- * 'ImageCMYK8' +-- +-- * 'ImageYCbCr8' +-- decodeJpeg :: B.ByteString -> Either String DynamicImage -decodeJpeg file = case runGetStrict get file of +decodeJpeg = fmap fst . decodeJpegWithMetadata + +-- | Equivalent to 'decodeJpeg' but also extracts metadatas. +-- +-- Extract the following metadatas from the JFIF block: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +-- Exif metadata are also extracted if present. +-- +decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeJpegWithMetadata file = case runGetStrict get file of Left err -> Left err - Right img -> case (compCount, imgKind) of - (_, Nothing) -> Left "Unknown Jpg kind" - (3, Just ProgressiveDCT) -> Right . ImageYCbCr8 $ decodeProgressive - (1, Just BaseLineDCT) -> Right . ImageY8 $ Image imgWidth imgHeight pixelData - (3, Just BaseLineDCT) -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData - _ -> Left "Wrong component count" + Right img -> case imgKind of + Just BaseLineDCT -> + let (st, arr) = decodeBaseline + jfifMeta = foldMap extractMetadatas $ app0JFifMarker st + exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st + meta = jfifMeta <> exifMeta <> sizeMeta + in + (, meta) <$> + dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr + Just ProgressiveDCT -> + let (st, arr) = decodeProgressive + jfifMeta = foldMap extractMetadatas $ app0JFifMarker st + exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st + meta = jfifMeta <> exifMeta <> sizeMeta + in + (, meta) <$> + dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr + _ -> Left "Unknown JPG kind" + where + compCount = length $ jpgComponents scanInfo + (_,scanInfo) = gatherScanInfo img - where compCount = length $ jpgComponents scanInfo - (_,scanInfo) = gatherScanInfo img + imgKind = gatherImageKind $ jpgFrame img + imgWidth = fromIntegral $ jpgWidth scanInfo + imgHeight = fromIntegral $ jpgHeight scanInfo - imgKind = gatherImageKind $ jpgFrame img - imgWidth = fromIntegral $ jpgWidth scanInfo - imgHeight = fromIntegral $ jpgHeight scanInfo + sizeMeta = basicMetadata SourceJpeg imgWidth imgHeight - imageSize = imgWidth * imgHeight * compCount + imageSize = imgWidth * imgHeight * compCount - decodeProgressive = runST $ do - let (st, wrotten) = - execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState - Just fHdr = currentFrame st - progressiveUnpack - (maximumHorizontalResolution st, maximumVerticalResolution st) - fHdr - (quantizationMatrices st) - wrotten >>= unsafeFreezeImage - pixelData = runST $ do - let (st, wrotten) = - execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState - Just fHdr = currentFrame st - resultImage <- M.new imageSize - let wrapped = MutableImage imgWidth imgHeight resultImage - decodeImage - fHdr - (quantizationMatrices st) - wrotten - wrapped - VS.unsafeFreeze resultImage + decodeProgressive = runST $ do + let (st, wrotten) = + execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState + Just fHdr = currentFrame st + fimg <- + progressiveUnpack + (maximumHorizontalResolution st, maximumVerticalResolution st) + fHdr + (quantizationMatrices st) + wrotten + frozen <- unsafeFreezeImage fimg + return (st, imageData frozen) -extractBlock :: Image PixelYCbCr8 -- ^ Source image + + decodeBaseline = runST $ do + let (st, wrotten) = + execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState + Just fHdr = currentFrame st + resultImage <- M.new imageSize + let wrapped = MutableImage imgWidth imgHeight resultImage + fImg <- decodeImage + fHdr + (quantizationMatrices st) + wrotten + wrapped + frozen <- unsafeFreezeImage fImg + return (st, imageData frozen) + +extractBlock :: forall s px. (PixelBaseComponent px ~ Word8) + => Image px -- ^ Source image -> MutableMacroBlock s Int16 -- ^ Mutable block where to put extracted block -> Int -- ^ Plane -> Int -- ^ X sampling factor @@ -619,125 +754,321 @@ , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable ] +lumaQuantTableAtQuality :: Int -> QuantificationTable +lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable + +chromaQuantTableAtQuality :: Int -> QuantificationTable +chromaQuantTableAtQuality qual = + scaleQuantisationMatrix qual defaultChromaQuantizationTable + +zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec] +zigzaggedQuantificationSpec qual = + [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma } + , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma } + ] + where + luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual + -- | Function to call to encode an image to jpeg. -- The quality factor should be between 0 and 100 (100 being -- the best quality). encodeJpegAtQuality :: Word8 -- ^ Quality factor -> Image PixelYCbCr8 -- ^ Image to encode -> L.ByteString -- ^ Encoded JPEG -encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage - where finalImage = JpgImage [ JpgQuantTable quantTables - , JpgScans JpgBaselineDCTHuffman hdr - , JpgHuffmanTable defaultHuffmanTables - , JpgScanBlob scanHeader encodedImage - ] +encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty - outputComponentCount = 3 +-- | Record gathering all information to encode a component +-- from the source image. Previously was a huge tuple +-- burried in the code +data EncoderState = EncoderState + { _encComponentIndex :: !Int + , _encBlockWidth :: !Int + , _encBlockHeight :: !Int + , _encQuantTable :: !QuantificationTable + , _encDcHuffman :: !HuffmanWriterCode + , _encAcHuffman :: !HuffmanWriterCode + } - scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } - scanHeader' = JpgScanHeader - { scanLength = 0 - , scanComponentCount = outputComponentCount - , scans = [ JpgScanSpecification { componentSelector = 1 - , dcEntropyCodingTable = 0 - , acEntropyCodingTable = 0 - } - , JpgScanSpecification { componentSelector = 2 - , dcEntropyCodingTable = 1 - , acEntropyCodingTable = 1 - } - , JpgScanSpecification { componentSelector = 3 - , dcEntropyCodingTable = 1 - , acEntropyCodingTable = 1 - } - ] - , spectralSelection = (0, 63) - , successiveApproxHigh = 0 - , successiveApproxLow = 0 - } +-- | Helper type class describing all JPG-encodable pixel types +class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where + additionalBlocks :: Image px -> [JpgFrame] + additionalBlocks _ = [] - hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } - hdr' = JpgFrameHeader { jpgFrameHeaderLength = 0 - , jpgSamplePrecision = 8 - , jpgHeight = fromIntegral h - , jpgWidth = fromIntegral w - , jpgImageComponentCount = outputComponentCount - , jpgComponents = [ - JpgComponent { componentIdentifier = 1 - , horizontalSamplingFactor = 2 - , verticalSamplingFactor = 2 - , quantizationTableDest = 0 - } - , JpgComponent { componentIdentifier = 2 - , horizontalSamplingFactor = 1 - , verticalSamplingFactor = 1 - , quantizationTableDest = 1 - } - , JpgComponent { componentIdentifier = 3 - , horizontalSamplingFactor = 1 - , verticalSamplingFactor = 1 - , quantizationTableDest = 1 - } - ] - } + componentsOfColorSpace :: Image px -> [JpgComponent] - lumaQuant = scaleQuantisationMatrix (fromIntegral quality) - defaultLumaQuantizationTable - chromaQuant = scaleQuantisationMatrix (fromIntegral quality) - defaultChromaQuantizationTable + encodingState :: Int -> Image px -> V.Vector EncoderState - zigzagedLumaQuant = zigZagReorderForwardv lumaQuant - zigzagedChromaQuant = zigZagReorderForwardv chromaQuant - quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0 - , quantTable = zigzagedLumaQuant } - , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1 - , quantTable = zigzagedChromaQuant } - ] + imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)] + imageHuffmanTables _ = defaultHuffmanTables - encodedImage = runST $ do - let horizontalMetaBlockCount = - w `divUpward` (dctBlockSize * maxSampling) - verticalMetaBlockCount = - h `divUpward` (dctBlockSize * maxSampling) - maxSampling = 2 - lumaSamplingSize = ( maxSampling, maxSampling, zigzagedLumaQuant - , makeInverseTable defaultDcLumaHuffmanTree - , makeInverseTable defaultAcLumaHuffmanTree) - chromaSamplingSize = ( maxSampling - 1, maxSampling - 1, zigzagedChromaQuant - , makeInverseTable defaultDcChromaHuffmanTree - , makeInverseTable defaultAcChromaHuffmanTree) - componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize] + scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification] - imageComponentCount = length componentDef + quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec] + quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual - dc_table <- M.replicate 3 0 - block <- createEmptyMutableMacroBlock - workData <- createEmptyMutableMacroBlock - zigzaged <- createEmptyMutableMacroBlock - writeState <- newWriteStateRef + maximumSubSamplingOf :: Image px -> Int + maximumSubSamplingOf _ = 1 - -- It's ugly, I know, be avoid allocation - let blockDecoder mx my = component $ zip [0..] componentDef - where component [] = return () - component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) = - rasterMap sizeX sizeY decoder >> component comp_rest - where xSamplingFactor = maxSampling - sizeX + 1 - ySamplingFactor = maxSampling - sizeY + 1 - extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount +instance JpgEncodable Pixel8 where + scanSpecificationOfColorSpace _ = + [ JpgScanSpecification { componentSelector = 1 + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + ] - decoder subX subY = do - let blockY = my * sizeY + subY - blockX = mx * sizeX + subX - prev_dc <- dc_table `M.unsafeRead` comp - (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= - encodeMacroBlock table workData zigzaged prev_dc) - (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff - serializeMacroBlock writeState dc ac neo_block + componentsOfColorSpace _ = + [ JpgComponent { componentIdentifier = 1 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 0 + } + ] - rasterMap - horizontalMetaBlockCount verticalMetaBlockCount - blockDecoder + imageHuffmanTables _ = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + ] - finalizeBoolWriter writeState + encodingState qual _ = V.singleton EncoderState + { _encComponentIndex = 0 + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + + +instance JpgEncodable PixelYCbCr8 where + maximumSubSamplingOf _ = 2 + quantTableSpec _ qual = zigzaggedQuantificationSpec qual + scanSpecificationOfColorSpace _ = + [ JpgScanSpecification { componentSelector = 1 + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + , JpgScanSpecification { componentSelector = 2 + , dcEntropyCodingTable = 1 + , acEntropyCodingTable = 1 + } + , JpgScanSpecification { componentSelector = 3 + , dcEntropyCodingTable = 1 + , acEntropyCodingTable = 1 + } + ] + + componentsOfColorSpace _ = + [ JpgComponent { componentIdentifier = 1 + , horizontalSamplingFactor = 2 + , verticalSamplingFactor = 2 + , quantizationTableDest = 0 + } + , JpgComponent { componentIdentifier = 2 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 1 + } + , JpgComponent { componentIdentifier = 3 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 1 + } + ] + + encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }] + where + lumaState = EncoderState + { _encComponentIndex = 0 + , _encBlockWidth = 2 + , _encBlockHeight = 2 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + chromaState = EncoderState + { _encComponentIndex = 1 + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ chromaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcChromaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcChromaHuffmanTree + } + +instance JpgEncodable PixelRGB8 where + additionalBlocks _ = [JpgAdobeAPP14 adobe14] where + adobe14 = JpgAdobeApp14 + { _adobeDctVersion = 100 + , _adobeFlag0 = 0 + , _adobeFlag1 = 0 + , _adobeTransform = AdobeUnknown + } + + imageHuffmanTables _ = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + ] + + scanSpecificationOfColorSpace _ = fmap build "RGB" where + build c = JpgScanSpecification + { componentSelector = fromIntegral $ fromEnum c + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + + componentsOfColorSpace _ = fmap build "RGB" where + build c = JpgComponent + { componentIdentifier = fromIntegral $ fromEnum c + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 0 + } + + encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where + build ix = EncoderState + { _encComponentIndex = ix + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + +instance JpgEncodable PixelCMYK8 where + additionalBlocks _ = [] where + _adobe14 = JpgAdobeApp14 + { _adobeDctVersion = 100 + , _adobeFlag0 = 32768 + , _adobeFlag1 = 0 + , _adobeTransform = AdobeYCck + } + + imageHuffmanTables _ = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + ] + + scanSpecificationOfColorSpace _ = fmap build "CMYK" where + build c = JpgScanSpecification + { componentSelector = fromIntegral $ fromEnum c + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + + componentsOfColorSpace _ = fmap build "CMYK" where + build c = JpgComponent + { componentIdentifier = fromIntegral $ fromEnum c + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 0 + } + + encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where + build ix = EncoderState + { _encComponentIndex = ix + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + +-- | Equivalent to 'encodeJpegAtQuality', but will store the following +-- metadatas in the file using a JFIF block: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +encodeJpegAtQualityWithMetadata :: Word8 -- ^ Quality factor + -> Metadatas + -> Image PixelYCbCr8 -- ^ Image to encode + -> L.ByteString -- ^ Encoded JPEG +encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata + +-- | Equivalent to 'encodeJpegAtQuality', but will store the following +-- metadatas in the file using a JFIF block: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +-- This function also allow to create JPEG files with the following color +-- space: +-- +-- * Y ('Pixel8') for greyscale. +-- * RGB ('PixelRGB8') with no color downsampling on any plane +-- * CMYK ('PixelCMYK8') with no color downsampling on any plane +-- +encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px) + => Word8 -- ^ Quality factor + -> Metadatas + -> Image px -- ^ Image to encode + -> L.ByteString -- ^ Encoded JPEG +encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where + !w = imageWidth img + !h = imageHeight img + !exifMeta = case encodeTiffStringMetadata metas of + [] -> [] + lst -> [JpgExif lst] + finalImage = JpgImage $ + encodeMetadatas metas ++ + exifMeta ++ + additionalBlocks img ++ + [ JpgQuantTable $ quantTableSpec img (fromIntegral quality) + , JpgScans JpgBaselineDCTHuffman hdr + , JpgHuffmanTable $ imageHuffmanTables img + , JpgScanBlob scanHeader encodedImage + ] + + !outputComponentCount = componentCount (undefined :: px) + + scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } + scanHeader' = JpgScanHeader + { scanLength = 0 + , scanComponentCount = fromIntegral outputComponentCount + , scans = scanSpecificationOfColorSpace img + , spectralSelection = (0, 63) + , successiveApproxHigh = 0 + , successiveApproxLow = 0 + } + + hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } + hdr' = JpgFrameHeader + { jpgFrameHeaderLength = 0 + , jpgSamplePrecision = 8 + , jpgHeight = fromIntegral h + , jpgWidth = fromIntegral w + , jpgImageComponentCount = fromIntegral outputComponentCount + , jpgComponents = componentsOfColorSpace img + } + + !maxSampling = maximumSubSamplingOf img + !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling) + !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling) + !componentDef = encodingState (fromIntegral quality) img + + encodedImage = runST $ do + dc_table <- M.replicate outputComponentCount 0 + block <- createEmptyMutableMacroBlock + workData <- createEmptyMutableMacroBlock + zigzaged <- createEmptyMutableMacroBlock + writeState <- newWriteStateRef + + rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my -> + V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) -> + let !xSamplingFactor = maxSampling - sizeX + 1 + !ySamplingFactor = maxSampling - sizeY + 1 + !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount + in + rasterMap sizeX sizeY $ \subX subY -> do + let !blockY = my * sizeY + subY + !blockX = mx * sizeX + subX + prev_dc <- dc_table `M.unsafeRead` comp + extracted <- extractor comp blockX blockY + (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted + (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff + serializeMacroBlock writeState dc ac neo_block + + finalizeBoolWriter writeState diff --git a/src/Codec/Picture/Jpg/Common.hs b/src/Codec/Picture/Jpg/Common.hs deleted file mode 100644 --- a/src/Codec/Picture/Jpg/Common.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -module Codec.Picture.Jpg.Common - ( DctCoefficients - , JpgUnpackerParameter( .. ) - , decodeInt - , dcCoefficientDecode - , deQuantize - , decodeRrrrSsss - , zigZagReorderForward - , zigZagReorderForwardv - , zigZagReorder - , inverseDirectCosineTransform - , unpackInt - , unpackMacroBlock - , rasterMap - , decodeMacroBlock - , decodeRestartInterval - ) where - -import Control.Applicative( (<$>), pure ) -import Control.Monad( replicateM, when ) -import Control.Monad.ST( ST, runST ) -import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) -import Data.Int( Int16, Int32 ) -import Data.List( foldl' ) -import Data.Maybe( fromMaybe ) -import Data.Word( Word8 ) -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import Foreign.Storable ( Storable ) - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.FastIdct -import Codec.Picture.Jpg.DefaultTable - --- | Same as for DcCoefficient, to provide nicer type signatures -type DctCoefficients = DcCoefficient - -data JpgUnpackerParameter = JpgUnpackerParameter - { dcHuffmanTree :: !HuffmanPackedTree - , acHuffmanTree :: !HuffmanPackedTree - , componentIndex :: {-# UNPACK #-} !Int - , restartInterval :: {-# UNPACK #-} !Int - , componentWidth :: {-# UNPACK #-} !Int - , componentHeight :: {-# UNPACK #-} !Int - , subSampling :: !(Int, Int) - , coefficientRange :: !(Int, Int) - , successiveApprox :: !(Int, Int) - , readerIndex :: {-# UNPACK #-} !Int - , indiceVector :: {-# UNPACK #-} !Int - , blockIndex :: {-# UNPACK #-} !Int - , blockMcuX :: {-# UNPACK #-} !Int - , blockMcuY :: {-# UNPACK #-} !Int - } - deriving Show - -decodeRestartInterval :: BoolReader s Int32 -decodeRestartInterval = return (-1) {- do - bits <- replicateM 8 getNextBitJpg - if bits == replicate 8 True - then do - marker <- replicateM 8 getNextBitJpg - return $ packInt marker - else return (-1) - -} - -{-# INLINE decodeInt #-} -decodeInt :: Int -> BoolReader s Int32 -decodeInt ssss = do - signBit <- getNextBitJpg - let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) - leftBitCount = ssss - 1 - -- First following bits store the sign of the coefficient, and counted in - -- SSSS, so the bit count for the int, is ssss - 1 - if signBit - then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount - else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount - -decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) -decodeRrrrSsss tree = do - rrrrssss <- huffmanPackedDecode tree - let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF - ssss = rrrrssss .&. 0xF - pure (fromIntegral rrrr, fromIntegral ssss) - -dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient -dcCoefficientDecode dcTree = do - ssss <- huffmanPackedDecode dcTree - if ssss == 0 - then return 0 - else fromIntegral <$> decodeInt (fromIntegral ssss) - --- | Apply a quantization matrix to a macroblock -{-# INLINE deQuantize #-} -deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -deQuantize table block = update 0 - where update 64 = return block - update i = do - val <- block `M.unsafeRead` i - let finalValue = val * (table `VS.unsafeIndex` i) - (block `M.unsafeWrite` i) finalValue - update $ i + 1 - -inverseDirectCosineTransform :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -inverseDirectCosineTransform mBlock = - fastIdct mBlock >>= mutableLevelShift - -zigZagOrder :: MacroBlock Int -zigZagOrder = makeMacroBlock $ concat - [[ 0, 1, 5, 6,14,15,27,28] - ,[ 2, 4, 7,13,16,26,29,42] - ,[ 3, 8,12,17,25,30,41,43] - ,[ 9,11,18,24,31,40,44,53] - ,[10,19,23,32,39,45,52,54] - ,[20,22,33,38,46,51,55,60] - ,[21,34,37,47,50,56,59,61] - ,[35,36,48,49,57,58,62,63] - ] - -zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a -zigZagReorderForwardv vec = runST $ do - v <- M.new 64 - mv <- VS.thaw vec - zigZagReorderForward v mv >>= VS.freeze - -zigZagOrderForward :: MacroBlock Int -zigZagOrderForward = VS.generate 64 inv - where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder - -zigZagReorderForward :: (Storable a, Num a) - => MutableMacroBlock s a - -> MutableMacroBlock s a - -> ST s (MutableMacroBlock s a) -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int32 - -> ST s (MutableMacroBlock s Int32) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 - -> MutableMacroBlock s Word8 - -> ST s (MutableMacroBlock s Word8) #-} -zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged - where ordering !table = reorder (0 :: Int) - where reorder !i | i >= 64 = return () - reorder i = do - let idx = table `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - reorder (i + 1) - -zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -zigZagReorder zigzaged block = do - let update i = do - let idx = zigZagOrder `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - - reorder 63 = update 63 - reorder i = update i >> reorder (i + 1) - - reorder (0 :: Int) - return zigzaged - --- | Unpack an int of the given size encoded from MSB to LSB. -unpackInt :: Int -> BoolReader s Int32 -unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg - - -{-# INLINE rasterMap #-} -rasterMap :: (Monad m) - => Int -> Int -> (Int -> Int -> m ()) - -> m () -rasterMap width height f = liner 0 - where liner y | y >= height = return () - liner y = columner 0 - where columner x | x >= width = liner (y + 1) - columner x = f x y >> columner (x + 1) - -packInt :: [Bool] -> Int32 -packInt = foldl' bitStep 0 - where bitStep acc True = (acc `unsafeShiftL` 1) + 1 - bitStep acc False = acc `unsafeShiftL` 1 - -pixelClamp :: Int16 -> Word8 -pixelClamp n = fromIntegral . min 255 $ max 0 n - --- | Given a size coefficient (how much a pixel span horizontally --- and vertically), the position of the macroblock, return a list --- of indices and value to be stored in an array (like the final --- image) -unpackMacroBlock :: Int -- ^ Component count - -> Int -- ^ Width coefficient - -> Int -- ^ Height coefficient - -> Int -- ^ x - -> Int -- ^ y - -> Int -- ^ Component index - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpackMacroBlock compCount wCoeff hCoeff compIdx x y - (MutableImage { mutableImageWidth = imgWidth, - mutableImageHeight = imgHeight, mutableImageData = img }) - block = rasterMap dctBlockSize dctBlockSize unpacker - where unpacker i j = do - let yBase = y * dctBlockSize + j * hCoeff - compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) - rasterMap wCoeff hCoeff $ \wDup hDup -> do - let xBase = x * dctBlockSize + i * wCoeff - xPos = xBase + wDup - yPos = yBase + hDup - - when (xPos < imgWidth && yPos < imgHeight) - (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx - (img `M.unsafeWrite` mutableIdx) compVal) - --- | This is one of the most important function of the decoding, --- it form the barebone decoding pipeline for macroblock. It's all --- there is to know for macro block transformation -decodeMacroBlock :: MacroBlock DctCoefficients - -> MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -decodeMacroBlock quantizationTable zigZagBlock block = - deQuantize quantizationTable block >>= zigZagReorder zigZagBlock - >>= inverseDirectCosineTransform - diff --git a/src/Codec/Picture/Jpg/DefaultTable.hs b/src/Codec/Picture/Jpg/DefaultTable.hs deleted file mode 100644 --- a/src/Codec/Picture/Jpg/DefaultTable.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} --- | Module used by the jpeg decoder internally, shouldn't be used --- in user code. -module Codec.Picture.Jpg.DefaultTable( DctComponent( .. ) - , HuffmanTree( .. ) - , HuffmanTable - , HuffmanPackedTree - , MacroBlock - , QuantificationTable - , HuffmanWriterCode - , scaleQuantisationMatrix - , makeMacroBlock - , makeInverseTable - , buildHuffmanTree - , packHuffmanTree - , huffmanPackedDecode - - , defaultChromaQuantizationTable - - , defaultLumaQuantizationTable - - , defaultAcChromaHuffmanTree - , defaultAcChromaHuffmanTable - - , defaultAcLumaHuffmanTree - , defaultAcLumaHuffmanTable - - , defaultDcChromaHuffmanTree - , defaultDcChromaHuffmanTable - - , defaultDcLumaHuffmanTree - , defaultDcLumaHuffmanTable - ) where - -import Data.Int( Int16 ) -import Foreign.Storable ( Storable ) -import Control.Monad.ST( runST ) -import qualified Data.Vector.Storable as SV -import qualified Data.Vector as V -import Data.Bits( unsafeShiftL, (.|.), (.&.) ) -import Data.Word( Word8, Word16 ) -import Data.List( foldl' ) -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.BitWriter - --- | Tree storing the code used for huffman encoding. -data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right. - | Leaf Word8 -- ^ We should output the value - | Empty -- ^ no value present - deriving (Eq, Show) - -type HuffmanPackedTree = SV.Vector Word16 - -type HuffmanWriterCode = V.Vector (Word8, Word16) - -packHuffmanTree :: HuffmanTree -> HuffmanPackedTree -packHuffmanTree tree = runST $ do - table <- M.replicate 512 0x8000 - let aux (Empty) idx = return $ idx + 1 - aux (Leaf v) idx = do - (table `M.unsafeWrite` idx) $ (fromIntegral v .|. 0x4000) - return $ idx + 1 - - aux (Branch i1@(Leaf _) i2@(Leaf _)) idx = - aux i1 idx >>= aux i2 - - aux (Branch i1@(Leaf _) i2) idx = do - _ <- aux i1 idx - ix2 <- aux i2 $ idx + 2 - (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2 - return ix2 - - aux (Branch i1 i2@(Leaf _)) idx = do - ix1 <- aux i1 (idx + 2) - _ <- aux i2 (idx + 1) - (table `M.unsafeWrite` idx) . fromIntegral $ idx + 2 - return ix1 - - aux (Branch i1 i2) idx = do - ix1 <- aux i1 (idx + 2) - ix2 <- aux i2 ix1 - (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2) - (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1) - return ix2 - _ <- aux tree 0 - SV.unsafeFreeze table - -makeInverseTable :: HuffmanTree -> HuffmanWriterCode -makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t - where inner _ _ Empty = [] - inner depth code (Leaf v) = [(fromIntegral v, (depth, code))] - inner depth code (Branch l r) = - inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r - where shifted = code `unsafeShiftL` 1 - --- | Represent a compact array of 8 * 8 values. The size --- is not guarenteed by type system, but if makeMacroBlock is --- used, everything should be fine size-wise -type MacroBlock a = SV.Vector a - -type QuantificationTable = MacroBlock Int16 - --- | Helper function to create pure macro block of the good size. -makeMacroBlock :: (Storable a) => [a] -> MacroBlock a -makeMacroBlock = SV.fromListN 64 - --- | Enumeration used to search in the tables for different components. -data DctComponent = DcComponent | AcComponent - deriving (Eq, Show) - --- | Transform parsed coefficients from the jpeg header to a --- tree which can be used to decode data. -buildHuffmanTree :: [[Word8]] -> HuffmanTree -buildHuffmanTree table = foldl' insertHuffmanVal Empty - . concatMap (\(i, t) -> map (i + 1,) t) - $ zip ([0..] :: [Int]) table - where isTreeFullyDefined Empty = False - isTreeFullyDefined (Leaf _) = True - isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r - - insertHuffmanVal Empty (0, val) = Leaf val - insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty - insertHuffmanVal (Branch l r) (d, val) - | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val)) - | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r - insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" - -scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable -scaleQuantisationMatrix quality - | quality < 0 = scaleQuantisationMatrix 0 - -- shouldn't show much difference than with 1, - -- but hey, at least we're complete - | quality == 0 = SV.map (scale (10000 :: Int)) - | quality < 50 = let qq = 5000 `div` quality - in SV.map (scale qq) - | otherwise = SV.map (scale q) - where q = 200 - quality * 2 - scale coeff i = fromIntegral . min 255 - . max 1 - $ fromIntegral i * coeff `div` 100 - -huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8 -huffmanPackedDecode table = getNextBitJpg >>= aux 0 - where aux idx b - | (v .&. 0x8000) /= 0 = return 0 - | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF - | otherwise = getNextBitJpg >>= aux v - where tableIndex | b = idx + 1 - | otherwise = idx - v = table `SV.unsafeIndex` fromIntegral tableIndex - -defaultLumaQuantizationTable :: QuantificationTable -defaultLumaQuantizationTable = makeMacroBlock - [16, 11, 10, 16, 24, 40, 51, 61 - ,12, 12, 14, 19, 26, 58, 60, 55 - ,14, 13, 16, 24, 40, 57, 69, 56 - ,14, 17, 22, 29, 51, 87, 80, 62 - ,18, 22, 37, 56, 68, 109, 103, 77 - ,24, 35, 55, 64, 81, 104, 113, 92 - ,49, 64, 78, 87, 103, 121, 120, 101 - ,72, 92, 95, 98, 112, 100, 103, 99 - ] - -defaultChromaQuantizationTable :: QuantificationTable -defaultChromaQuantizationTable = makeMacroBlock - [17, 18, 24, 47, 99, 99, 99, 99 - ,18, 21, 26, 66, 99, 99, 99, 99 - ,24, 26, 56, 99, 99, 99, 99, 99 - ,47, 66, 99, 99, 99, 99, 99, 99 - ,99, 99, 99, 99, 99, 99, 99, 99 - ,99, 99, 99, 99, 99, 99, 99, 99 - ,99, 99, 99, 99, 99, 99, 99, 99 - ,99, 99, 99, 99, 99, 99, 99, 99 - ] - -defaultDcLumaHuffmanTree :: HuffmanTree -defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable - --- | From the Table K.3 of ITU-81 (p153) -defaultDcLumaHuffmanTable :: HuffmanTable -defaultDcLumaHuffmanTable = - [ [] - , [0] - , [1, 2, 3, 4, 5] - , [6] - , [7] - , [8] - , [9] - , [10] - , [11] - , [] - , [] - , [] - , [] - , [] - , [] - , [] - ] - -defaultDcChromaHuffmanTree :: HuffmanTree -defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable - --- | From the Table K.4 of ITU-81 (p153) -defaultDcChromaHuffmanTable :: HuffmanTable -defaultDcChromaHuffmanTable = - [ [] - , [0, 1, 2] - , [3] - , [4] - , [5] - , [6] - , [7] - , [8] - , [9] - , [10] - , [11] - , [] - , [] - , [] - , [] - , [] - ] - -defaultAcLumaHuffmanTree :: HuffmanTree -defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable - --- | From the Table K.5 of ITU-81 (p154) -defaultAcLumaHuffmanTable :: HuffmanTable -defaultAcLumaHuffmanTable = - [ [] - , [0x01, 0x02] - , [0x03] - , [0x00, 0x04, 0x11] - , [0x05, 0x12, 0x21] - , [0x31, 0x41] - , [0x06, 0x13, 0x51, 0x61] - , [0x07, 0x22, 0x71] - , [0x14, 0x32, 0x81, 0x91, 0xA1] - , [0x08, 0x23, 0x42, 0xB1, 0xC1] - , [0x15, 0x52, 0xD1, 0xF0] - , [0x24, 0x33, 0x62, 0x72] - , [] - , [] - , [0x82] - , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35 - ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54 - ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 - ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A - ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7 - ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4 - ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA - ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5 - ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] - ] - -type HuffmanTable = [[Word8]] - -defaultAcChromaHuffmanTree :: HuffmanTree -defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable - -defaultAcChromaHuffmanTable :: HuffmanTable -defaultAcChromaHuffmanTable = - [ [] - , [0x00, 0x01] - , [0x02] - , [0x03, 0x11] - , [0x04, 0x05, 0x21, 0x31] - , [0x06, 0x12, 0x41, 0x51] - , [0x07, 0x61, 0x71] - , [0x13, 0x22, 0x32, 0x81] - , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1] - , [0x09, 0x23, 0x33, 0x52, 0xF0] - , [0x15, 0x62, 0x72, 0xD1] - , [0x0A, 0x16, 0x24, 0x34] - , [] - , [0xE1] - , [0x25, 0xF1] - , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35 - , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47 - , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59 - , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 - , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84 - , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95 - , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6 - , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7 - , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8 - , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9 - , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA - , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA - ] - ] - diff --git a/src/Codec/Picture/Jpg/FastDct.hs b/src/Codec/Picture/Jpg/FastDct.hs deleted file mode 100644 --- a/src/Codec/Picture/Jpg/FastDct.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where - -import Control.Applicative( (<$>) ) -import Data.Int( Int16, Int32 ) -import Data.Bits( unsafeShiftR, unsafeShiftL ) -import Control.Monad.ST( ST ) - -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Jpg.Types -import Control.Monad( forM, forM_ ) - --- | Reference implementation of the DCT, directly implementing the formula --- of ITU-81. It's slow as hell, perform to many operations, but is accurate --- and a good reference point. -referenceDct :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int32) -referenceDct workData block = forM_ [(u, v) | u <- [0 :: Int .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] (\(u,v) -> do - val <- at (u,v) - (workData `M.unsafeWrite` (v * dctBlockSize + u)) . truncate $ (1 / 4) * c u * c v * val) - >> return workData - where -- at :: (Int, Int) -> ST s Float - at (u,v) = sum <$> (forM [(x,y) | x <- [0..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do - sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + x)) - return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) - * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16)) - c 0 = 1 / sqrt 2 - c _ = 1 - -pASS1_BITS, cONST_BITS :: Int -cONST_BITS = 13 -pASS1_BITS = 2 - - -fIX_0_298631336, fIX_0_390180644, fIX_0_541196100, - fIX_0_765366865, fIX_0_899976223, fIX_1_175875602, - fIX_1_501321110, fIX_1_847759065, fIX_1_961570560, - fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32 -fIX_0_298631336 =(2446) -- FIX(0.298631336) */ -fIX_0_390180644 =(3196) -- FIX(0.390180644) */ -fIX_0_541196100 =(4433) -- FIX(0.541196100) */ -fIX_0_765366865 =(6270) -- FIX(0.765366865) */ -fIX_0_899976223 =(7373) -- FIX(0.899976223) */ -fIX_1_175875602 =(9633) -- FIX(1.175875602) */ -fIX_1_501321110 =(12299) -- FIX(1.501321110) */ -fIX_1_847759065 =(15137) -- FIX(1.847759065) */ -fIX_1_961570560 =(16069) -- FIX(1.961570560) */ -fIX_2_053119869 =(16819) -- FIX(2.053119869) */ -fIX_2_562915447 =(20995) -- FIX(2.562915447) */ -fIX_3_072711026 =(25172) -- FIX(3.072711026) */ - -cENTERJSAMPLE :: Int32 -cENTERJSAMPLE = 128 - --- | Fast DCT extracted from libjpeg -fastDctLibJpeg :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int32) -fastDctLibJpeg workData sample_block = do - firstPass workData 0 - secondPass workData 7 - {-_ <- mutate (\_ a -> a `quot` 8) workData-} - return workData - where -- Pass 1: process rows. - -- Note results are scaled up by sqrt(8) compared to a true DCT; - -- furthermore, we scale the results by 2**PASS1_BITS. - firstPass _ i | i == dctBlockSize = return () - firstPass dataBlock i = do - let baseIdx = i * dctBlockSize - readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) - mult = (*) - writeAt idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) n - writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) - (n `unsafeShiftR` (cONST_BITS - pASS1_BITS)) - - blk0 <- readAt 0 - blk1 <- readAt 1 - blk2 <- readAt 2 - blk3 <- readAt 3 - blk4 <- readAt 4 - blk5 <- readAt 5 - blk6 <- readAt 6 - blk7 <- readAt 7 - - let tmp0 = blk0 + blk7 - tmp1 = blk1 + blk6 - tmp2 = blk2 + blk5 - tmp3 = blk3 + blk4 - - tmp10 = tmp0 + tmp3 - tmp12 = tmp0 - tmp3 - tmp11 = tmp1 + tmp2 - tmp13 = tmp1 - tmp2 - - tmp0' = blk0 - blk7 - tmp1' = blk1 - blk6 - tmp2' = blk2 - blk5 - tmp3' = blk3 - blk4 - - -- Stage 4 and output - writeAt 0 $ (tmp10 + tmp11 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS - writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS - - let z1 = mult (tmp12 + tmp13) fIX_0_541196100 - + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1)) - - writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 - writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 - - let tmp10' = tmp0' + tmp3' - tmp11' = tmp1' + tmp2' - tmp12' = tmp0' + tmp2' - tmp13' = tmp1' + tmp3' - z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- c3 */ - -- Add fudge factor here for final descale. */ - + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1)) - tmp0'' = mult tmp0' fIX_1_501321110 - tmp1'' = mult tmp1' fIX_3_072711026 - tmp2'' = mult tmp2' fIX_2_053119869 - tmp3'' = mult tmp3' fIX_0_298631336 - - tmp10'' = mult tmp10' (- fIX_0_899976223) - tmp11'' = mult tmp11' (- fIX_2_562915447) - tmp12'' = mult tmp12' (- fIX_0_390180644) + z1' - tmp13'' = mult tmp13' (- fIX_1_961570560) + z1' - - writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' - writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' - writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' - writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' - - firstPass dataBlock $ i + 1 - - -- Pass 2: process columns. - -- We remove the PASS1_BITS scaling, but leave the results scaled up - -- by an overall factor of 8. - secondPass :: M.STVector s Int32 -> Int -> ST s () - secondPass _ (-1) = return () - secondPass block i = do - let readAt idx = block `M.unsafeRead` ((7 - i) + idx * dctBlockSize) - mult = (*) - writeAt idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) n - writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3) - blk0 <- readAt 0 - blk1 <- readAt 1 - blk2 <- readAt 2 - blk3 <- readAt 3 - blk4 <- readAt 4 - blk5 <- readAt 5 - blk6 <- readAt 6 - blk7 <- readAt 7 - - let tmp0 = blk0 + blk7 - tmp1 = blk1 + blk6 - tmp2 = blk2 + blk5 - tmp3 = blk3 + blk4 - - -- Add fudge factor here for final descale. */ - tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1)) - tmp12 = tmp0 - tmp3 - tmp11 = tmp1 + tmp2 - tmp13 = tmp1 - tmp2 - - tmp0' = blk0 - blk7 - tmp1' = blk1 - blk6 - tmp2' = blk2 - blk5 - tmp3' = blk3 - blk4 - - writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3) - writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) - - let z1 = mult (tmp12 + tmp13) fIX_0_541196100 - + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1)) - - writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 - writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 - - let tmp10' = tmp0' + tmp3' - tmp11' = tmp1' + tmp2' - tmp12' = tmp0' + tmp2' - tmp13' = tmp1' + tmp3' - - z1' = mult (tmp12' + tmp13') fIX_1_175875602 - -- Add fudge factor here for final descale. */ - + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1); - - tmp0'' = mult tmp0' fIX_1_501321110 - tmp1'' = mult tmp1' fIX_3_072711026 - tmp2'' = mult tmp2' fIX_2_053119869 - tmp3'' = mult tmp3' fIX_0_298631336 - tmp10'' = mult tmp10' (- fIX_0_899976223) - tmp11'' = mult tmp11' (- fIX_2_562915447) - tmp12'' = mult tmp12' (- fIX_0_390180644) - + z1' - tmp13'' = mult tmp13' (- fIX_1_961570560) - + z1' - writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' - writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' - writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' - writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' - - secondPass block (i - 1) diff --git a/src/Codec/Picture/Jpg/FastIdct.hs b/src/Codec/Picture/Jpg/FastIdct.hs deleted file mode 100644 --- a/src/Codec/Picture/Jpg/FastIdct.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} --- | Module providing a 'fast' implementation of IDCT --- --- inverse two dimensional DCT, Chen-Wang algorithm --- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984) --- 32-bit integer arithmetic (8 bit coefficients) --- 11 mults, 29 adds per DCT --- sE, 18.8.91 --- --- coefficients extended to 12 bit for IEEE1180-1990 --- compliance sE, 2.1.94 --- --- this code assumes >> to be a two's-complement arithmetic --- right shift: (-2)>>1 == -1 , (-3)>>1 == -2 -module Codec.Picture.Jpg.FastIdct( MutableMacroBlock - , fastIdct - , mutableLevelShift - , createEmptyMutableMacroBlock - ) where - -import qualified Data.Vector.Storable as V -import Control.Monad.ST( ST ) -import Data.Bits( unsafeShiftL, unsafeShiftR ) -import Data.Int( Int16 ) -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Jpg.Types - -iclip :: V.Vector Int16 -iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ] - where val i | i < (-256) = -256 - | i > 255 = 255 - | otherwise = i - -data IDctStage = IDctStage { - x0 :: {-# UNPACK #-} !Int, - x1 :: {-# UNPACK #-} !Int, - x2 :: {-# UNPACK #-} !Int, - x3 :: {-# UNPACK #-} !Int, - x4 :: {-# UNPACK #-} !Int, - x5 :: {-# UNPACK #-} !Int, - x6 :: {-# UNPACK #-} !Int, - x7 :: {-# UNPACK #-} !Int, - x8 :: {-# UNPACK #-} !Int - } - -w1, w2, w3, w5, w6, w7 :: Int -w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16) -w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16) -w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16) -w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16) -w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) -w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) - --- row (horizontal) IDCT --- --- 7 pi 1 --- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l ) --- l=0 8 2 --- --- where: c[0] = 128 --- c[1..7] = 128*sqrt(2) -idctRow :: MutableMacroBlock s Int16 -> Int -> ST s () -idctRow blk idx = do - xx0 <- blk `M.unsafeRead` (0 + idx) - xx1 <- blk `M.unsafeRead` (4 + idx) - xx2 <- blk `M.unsafeRead` (6 + idx) - xx3 <- blk `M.unsafeRead` (2 + idx) - xx4 <- blk `M.unsafeRead` (1 + idx) - xx5 <- blk `M.unsafeRead` (7 + idx) - xx6 <- blk `M.unsafeRead` (5 + idx) - xx7 <- blk `M.unsafeRead` (3 + idx) - let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128 - , x1 = fromIntegral xx1 `unsafeShiftL` 11 - , x2 = fromIntegral xx2 - , x3 = fromIntegral xx3 - , x4 = fromIntegral xx4 - , x5 = fromIntegral xx5 - , x6 = fromIntegral xx6 - , x7 = fromIntegral xx7 - , x8 = 0 - } - - firstStage c = c { x4 = x8' + (w1 - w7) * x4 c - , x5 = x8' - (w1 + w7) * x5 c - , x6 = x8'' - (w3 - w5) * x6 c - , x7 = x8'' - (w3 + w5) * x7 c - , x8 = x8'' - } - where x8' = w7 * (x4 c + x5 c) - x8'' = w3 * (x6 c + x7 c) - - secondStage c = c { x0 = x0 c - x1 c - , x8 = x0 c + x1 c - , x1 = x1'' - , x2 = x1' - (w2 + w6) * x2 c - , x3 = x1' + (w2 - w6) * x3 c - , x4 = x4 c - x6 c - , x6 = x5 c + x7 c - , x5 = x5 c - x7 c - } - where x1' = w6 * (x3 c + x2 c) - x1'' = x4 c + x6 c - - thirdStage c = c { x7 = x8 c + x3 c - , x8 = x8 c - x3 c - , x3 = x0 c + x2 c - , x0 = x0 c - x2 c - , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 - , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 - } - scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8 - , x1 = (x3 c + x2 c) `unsafeShiftR` 8 - , x2 = (x0 c + x4 c) `unsafeShiftR` 8 - , x3 = (x8 c + x6 c) `unsafeShiftR` 8 - , x4 = (x8 c - x6 c) `unsafeShiftR` 8 - , x5 = (x0 c - x4 c) `unsafeShiftR` 8 - , x6 = (x3 c - x2 c) `unsafeShiftR` 8 - , x7 = (x7 c - x1 c) `unsafeShiftR` 8 - } - transformed = scaled . thirdStage . secondStage $ firstStage initialState - - (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed - (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed - (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed - (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed - (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed - (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed - (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed - (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed - --- column (vertical) IDCT --- --- 7 pi 1 --- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l ) --- l=0 8 2 --- --- where: c[0] = 1/1024 --- c[1..7] = (1/1024)*sqrt(2) --- -idctCol :: MutableMacroBlock s Int16 -> Int -> ST s () -idctCol blk idx = do - xx0 <- blk `M.unsafeRead` ( 0 + idx) - xx1 <- blk `M.unsafeRead` (8 * 4 + idx) - xx2 <- blk `M.unsafeRead` (8 * 6 + idx) - xx3 <- blk `M.unsafeRead` (8 * 2 + idx) - xx4 <- blk `M.unsafeRead` (8 + idx) - xx5 <- blk `M.unsafeRead` (8 * 7 + idx) - xx6 <- blk `M.unsafeRead` (8 * 5 + idx) - xx7 <- blk `M.unsafeRead` (8 * 3 + idx) - let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192 - , x1 = fromIntegral xx1 `unsafeShiftL` 8 - , x2 = fromIntegral xx2 - , x3 = fromIntegral xx3 - , x4 = fromIntegral xx4 - , x5 = fromIntegral xx5 - , x6 = fromIntegral xx6 - , x7 = fromIntegral xx7 - , x8 = 0 - } - firstStage c = c { x4 = (x8' + (w1 - w7) * x4 c) `unsafeShiftR` 3 - , x5 = (x8' - (w1 + w7) * x5 c) `unsafeShiftR` 3 - , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3 - , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3 - , x8 = x8'' - } - where x8' = w7 * (x4 c + x5 c) + 4 - x8'' = w3 * (x6 c + x7 c) + 4 - - secondStage c = c { x8 = x0 c + x1 c - , x0 = x0 c - x1 c - , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3 - , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3 - , x4 = x4 c - x6 c - , x1 = x1'' - , x6 = x5 c + x7 c - , x5 = x5 c - x7 c - } - where x1' = w6 * (x3 c + x2 c) + 4 - x1'' = x4 c + x6 c - - thirdStage c = c { x7 = x8 c + x3 c - , x8 = x8 c - x3 c - , x3 = x0 c + x2 c - , x0 = x0 c - x2 c - , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 - , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 - } - - clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512) - else iclip `V.unsafeIndex` 0 - - | otherwise = iclip `V.unsafeIndex` 1023 - - f = thirdStage . secondStage $ firstStage initialState - (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8 )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14 - - -{-# INLINE fastIdct #-} --- | Algorithm to call to perform an IDCT, return the same --- block that the one given as input. -fastIdct :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -fastIdct block = rows 0 - where rows 8 = cols 0 - rows i = idctRow block (8 * i) >> rows (i + 1) - - cols 8 = return block - cols i = idctCol block i >> cols (i + 1) - -{-# INLINE mutableLevelShift #-} --- | Perform a Jpeg level shift in a mutable fashion. -mutableLevelShift :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -mutableLevelShift block = update 0 - where update 64 = return block - update idx = do - val <- block `M.unsafeRead` idx - (block `M.unsafeWrite` idx) $ val + 128 - update $ idx + 1 - diff --git a/src/Codec/Picture/Jpg/Internal/Common.hs b/src/Codec/Picture/Jpg/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/Common.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Internal.Common + ( DctCoefficients + , JpgUnpackerParameter( .. ) + , decodeInt + , dcCoefficientDecode + , deQuantize + , decodeRrrrSsss + , zigZagReorderForward + , zigZagReorderForwardv + , zigZagReorder + , inverseDirectCosineTransform + , unpackInt + , unpackMacroBlock + , rasterMap + , decodeMacroBlock + , decodeRestartInterval + , toBlockSize + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>) ) +#endif + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) +import Data.Int( Int16, Int32 ) +import Data.Maybe( fromMaybe ) +import Data.Word( Word8 ) +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import Foreign.Storable ( Storable ) + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Internal.Types +import Codec.Picture.Jpg.Internal.FastIdct +import Codec.Picture.Jpg.Internal.DefaultTable + +-- | Same as for DcCoefficient, to provide nicer type signatures +type DctCoefficients = DcCoefficient + +data JpgUnpackerParameter = JpgUnpackerParameter + { dcHuffmanTree :: !HuffmanPackedTree + , acHuffmanTree :: !HuffmanPackedTree + , componentIndex :: {-# UNPACK #-} !Int + , restartInterval :: {-# UNPACK #-} !Int + , componentWidth :: {-# UNPACK #-} !Int + , componentHeight :: {-# UNPACK #-} !Int + , subSampling :: !(Int, Int) + , coefficientRange :: !(Int, Int) + , successiveApprox :: !(Int, Int) + , readerIndex :: {-# UNPACK #-} !Int + -- | When in progressive mode, we can have many + -- color in a scan or only one. The indices changes + -- on this fact, when mixed, there is whole + -- MCU for all color components, spanning multiple + -- block lines. With only one color component we use + -- the normal raster order. + , indiceVector :: {-# UNPACK #-} !Int + , blockIndex :: {-# UNPACK #-} !Int + , blockMcuX :: {-# UNPACK #-} !Int + , blockMcuY :: {-# UNPACK #-} !Int + } + deriving Show + +toBlockSize :: Int -> Int +toBlockSize v = (v + 7) `div` 8 + +decodeRestartInterval :: BoolReader s Int32 +decodeRestartInterval = return (-1) {- do + bits <- replicateM 8 getNextBitJpg + if bits == replicate 8 True + then do + marker <- replicateM 8 getNextBitJpg + return $ packInt marker + else return (-1) + -} + +{-# INLINE decodeInt #-} +decodeInt :: Int -> BoolReader s Int32 +decodeInt ssss = do + signBit <- getNextBitJpg + let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) + leftBitCount = ssss - 1 + -- First following bits store the sign of the coefficient, and counted in + -- SSSS, so the bit count for the int, is ssss - 1 + if signBit + then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount + else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount + +decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) +decodeRrrrSsss tree = do + rrrrssss <- huffmanPackedDecode tree + let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF + ssss = rrrrssss .&. 0xF + pure (fromIntegral rrrr, fromIntegral ssss) + +dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient +dcCoefficientDecode dcTree = do + ssss <- huffmanPackedDecode dcTree + if ssss == 0 + then return 0 + else fromIntegral <$> decodeInt (fromIntegral ssss) + +-- | Apply a quantization matrix to a macroblock +{-# INLINE deQuantize #-} +deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +deQuantize table block = update 0 + where update 64 = return block + update i = do + val <- block `M.unsafeRead` i + let finalValue = val * (table `VS.unsafeIndex` i) + (block `M.unsafeWrite` i) finalValue + update $ i + 1 + +inverseDirectCosineTransform :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +inverseDirectCosineTransform mBlock = + fastIdct mBlock >>= mutableLevelShift + +zigZagOrder :: MacroBlock Int +zigZagOrder = makeMacroBlock $ concat + [[ 0, 1, 5, 6,14,15,27,28] + ,[ 2, 4, 7,13,16,26,29,42] + ,[ 3, 8,12,17,25,30,41,43] + ,[ 9,11,18,24,31,40,44,53] + ,[10,19,23,32,39,45,52,54] + ,[20,22,33,38,46,51,55,60] + ,[21,34,37,47,50,56,59,61] + ,[35,36,48,49,57,58,62,63] + ] + +zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a +zigZagReorderForwardv vec = runST $ do + v <- M.new 64 + mv <- VS.thaw vec + zigZagReorderForward v mv >>= VS.freeze + +zigZagOrderForward :: MacroBlock Int +zigZagOrderForward = VS.generate 64 inv + where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder + +zigZagReorderForward :: (Storable a) + => MutableMacroBlock s a + -> MutableMacroBlock s a + -> ST s (MutableMacroBlock s a) +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int32 + -> ST s (MutableMacroBlock s Int32) #-} +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) #-} +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 + -> MutableMacroBlock s Word8 + -> ST s (MutableMacroBlock s Word8) #-} +zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged + where ordering !table = reorder (0 :: Int) + where reorder !i | i >= 64 = return () + reorder i = do + let idx = table `VS.unsafeIndex` i + v <- block `M.unsafeRead` idx + (zigzaged `M.unsafeWrite` i) v + reorder (i + 1) + +zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +zigZagReorder zigzaged block = do + let update i = do + let idx = zigZagOrder `VS.unsafeIndex` i + v <- block `M.unsafeRead` idx + (zigzaged `M.unsafeWrite` i) v + + reorder 63 = update 63 + reorder i = update i >> reorder (i + 1) + + reorder (0 :: Int) + return zigzaged + +-- | Unpack an int of the given size encoded from MSB to LSB. +unpackInt :: Int -> BoolReader s Int32 +unpackInt = getNextIntJpg + +{-# INLINE rasterMap #-} +rasterMap :: (Monad m) + => Int -> Int -> (Int -> Int -> m ()) + -> m () +rasterMap width height f = liner 0 + where liner y | y >= height = return () + liner y = columner 0 + where columner x | x >= width = liner (y + 1) + columner x = f x y >> columner (x + 1) + +pixelClamp :: Int16 -> Word8 +pixelClamp n = fromIntegral . min 255 $ max 0 n + +-- | Given a size coefficient (how much a pixel span horizontally +-- and vertically), the position of the macroblock, return a list +-- of indices and value to be stored in an array (like the final +-- image) +unpackMacroBlock :: Int -- ^ Component count + -> Int -- ^ Width coefficient + -> Int -- ^ Height coefficient + -> Int -- ^ Component index + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () +unpackMacroBlock compCount wCoeff hCoeff compIdx x y + (MutableImage { mutableImageWidth = imgWidth, + mutableImageHeight = imgHeight, mutableImageData = img }) + block = rasterMap dctBlockSize dctBlockSize unpacker + where unpacker i j = do + let yBase = y * dctBlockSize + j * hCoeff + compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) + rasterMap wCoeff hCoeff $ \wDup hDup -> do + let xBase = x * dctBlockSize + i * wCoeff + xPos = xBase + wDup + yPos = yBase + hDup + + when (xPos < imgWidth && yPos < imgHeight) + (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx + (img `M.unsafeWrite` mutableIdx) compVal) + +-- | This is one of the most important function of the decoding, +-- it form the barebone decoding pipeline for macroblock. It's all +-- there is to know for macro block transformation +decodeMacroBlock :: MacroBlock DctCoefficients + -> MutableMacroBlock s Int16 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +decodeMacroBlock quantizationTable zigZagBlock block = + deQuantize quantizationTable block >>= zigZagReorder zigZagBlock + >>= inverseDirectCosineTransform + diff --git a/src/Codec/Picture/Jpg/Internal/DefaultTable.hs b/src/Codec/Picture/Jpg/Internal/DefaultTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/DefaultTable.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Module used by the jpeg decoder internally, shouldn't be used +-- in user code. +module Codec.Picture.Jpg.Internal.DefaultTable( DctComponent( .. ) + , HuffmanTree( .. ) + , HuffmanTable + , HuffmanPackedTree + , MacroBlock + , QuantificationTable + , HuffmanWriterCode + , scaleQuantisationMatrix + , makeMacroBlock + , makeInverseTable + , buildHuffmanTree + , packHuffmanTree + , huffmanPackedDecode + + , defaultChromaQuantizationTable + + , defaultLumaQuantizationTable + + , defaultAcChromaHuffmanTree + , defaultAcChromaHuffmanTable + + , defaultAcLumaHuffmanTree + , defaultAcLumaHuffmanTable + + , defaultDcChromaHuffmanTree + , defaultDcChromaHuffmanTable + + , defaultDcLumaHuffmanTree + , defaultDcLumaHuffmanTable + ) where + +import Control.DeepSeq( NFData(..) ) +import Data.Int( Int16 ) +import Foreign.Storable ( Storable ) +import Control.Monad.ST( runST ) +import qualified Data.Vector.Storable as SV +import qualified Data.Vector as V +import Data.Bits( unsafeShiftL, (.|.), (.&.) ) +import Data.Word( Word8, Word16 ) +import Data.List( foldl' ) +import qualified Data.Vector.Storable.Mutable as M +import GHC.Generics( Generic ) + +import Codec.Picture.BitWriter + +-- | Tree storing the code used for huffman encoding. +data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right. + | Leaf Word8 -- ^ We should output the value + | Empty -- ^ no value present + deriving (Eq, Show) + +type HuffmanPackedTree = SV.Vector Word16 + +type HuffmanWriterCode = V.Vector (Word8, Word16) + +packHuffmanTree :: HuffmanTree -> HuffmanPackedTree +packHuffmanTree tree = runST $ do + table <- M.replicate 512 0x8000 + let aux (Empty) idx = return $ idx + 1 + aux (Leaf v) idx = do + (table `M.unsafeWrite` idx) $ fromIntegral v .|. 0x4000 + return $ idx + 1 + + aux (Branch i1@(Leaf _) i2@(Leaf _)) idx = + aux i1 idx >>= aux i2 + + aux (Branch i1@(Leaf _) i2) idx = do + _ <- aux i1 idx + ix2 <- aux i2 $ idx + 2 + (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2 + return ix2 + + aux (Branch i1 i2@(Leaf _)) idx = do + ix1 <- aux i1 (idx + 2) + _ <- aux i2 (idx + 1) + (table `M.unsafeWrite` idx) . fromIntegral $ idx + 2 + return ix1 + + aux (Branch i1 i2) idx = do + ix1 <- aux i1 (idx + 2) + ix2 <- aux i2 ix1 + (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2) + (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1) + return ix2 + _ <- aux tree 0 + SV.unsafeFreeze table + +makeInverseTable :: HuffmanTree -> HuffmanWriterCode +makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t + where inner _ _ Empty = [] + inner depth code (Leaf v) = [(fromIntegral v, (depth, code))] + inner depth code (Branch l r) = + inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r + where shifted = code `unsafeShiftL` 1 + +-- | Represent a compact array of 8 * 8 values. The size +-- is not guarenteed by type system, but if makeMacroBlock is +-- used, everything should be fine size-wise +type MacroBlock a = SV.Vector a + +type QuantificationTable = MacroBlock Int16 + +-- | Helper function to create pure macro block of the good size. +makeMacroBlock :: (Storable a) => [a] -> MacroBlock a +makeMacroBlock = SV.fromListN 64 + +-- | Enumeration used to search in the tables for different components. +data DctComponent = DcComponent | AcComponent + deriving (Eq, Show, Generic) +instance NFData DctComponent + +-- | Transform parsed coefficients from the jpeg header to a +-- tree which can be used to decode data. +buildHuffmanTree :: [[Word8]] -> HuffmanTree +buildHuffmanTree table = foldl' insertHuffmanVal Empty + . concatMap (\(i, t) -> map (i + 1,) t) + $ zip ([0..] :: [Int]) table + where isTreeFullyDefined Empty = False + isTreeFullyDefined (Leaf _) = True + isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r + + insertHuffmanVal Empty (0, val) = Leaf val + insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty + insertHuffmanVal (Branch l r) (d, val) + | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val)) + | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r + insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" + +scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable +scaleQuantisationMatrix quality + | quality < 0 = scaleQuantisationMatrix 0 + -- shouldn't show much difference than with 1, + -- but hey, at least we're complete + | quality == 0 = SV.map (scale (10000 :: Int)) + | quality < 50 = let qq = 5000 `div` quality + in SV.map (scale qq) + | otherwise = SV.map (scale q) + where q = 200 - quality * 2 + scale coeff i = fromIntegral . min 255 + . max 1 + $ fromIntegral i * coeff `div` 100 + +huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8 +huffmanPackedDecode table = getNextBitJpg >>= aux 0 + where aux idx b + | (v .&. 0x8000) /= 0 = return 0 + | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF + | otherwise = getNextBitJpg >>= aux v + where tableIndex | b = idx + 1 + | otherwise = idx + v = table `SV.unsafeIndex` fromIntegral tableIndex + +defaultLumaQuantizationTable :: QuantificationTable +defaultLumaQuantizationTable = makeMacroBlock + [16, 11, 10, 16, 24, 40, 51, 61 + ,12, 12, 14, 19, 26, 58, 60, 55 + ,14, 13, 16, 24, 40, 57, 69, 56 + ,14, 17, 22, 29, 51, 87, 80, 62 + ,18, 22, 37, 56, 68, 109, 103, 77 + ,24, 35, 55, 64, 81, 104, 113, 92 + ,49, 64, 78, 87, 103, 121, 120, 101 + ,72, 92, 95, 98, 112, 100, 103, 99 + ] + +defaultChromaQuantizationTable :: QuantificationTable +defaultChromaQuantizationTable = makeMacroBlock + [17, 18, 24, 47, 99, 99, 99, 99 + ,18, 21, 26, 66, 99, 99, 99, 99 + ,24, 26, 56, 99, 99, 99, 99, 99 + ,47, 66, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ] + +defaultDcLumaHuffmanTree :: HuffmanTree +defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable + +-- | From the Table K.3 of ITU-81 (p153) +defaultDcLumaHuffmanTable :: HuffmanTable +defaultDcLumaHuffmanTable = + [ [] + , [0] + , [1, 2, 3, 4, 5] + , [6] + , [7] + , [8] + , [9] + , [10] + , [11] + , [] + , [] + , [] + , [] + , [] + , [] + , [] + ] + +defaultDcChromaHuffmanTree :: HuffmanTree +defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable + +-- | From the Table K.4 of ITU-81 (p153) +defaultDcChromaHuffmanTable :: HuffmanTable +defaultDcChromaHuffmanTable = + [ [] + , [0, 1, 2] + , [3] + , [4] + , [5] + , [6] + , [7] + , [8] + , [9] + , [10] + , [11] + , [] + , [] + , [] + , [] + , [] + ] + +defaultAcLumaHuffmanTree :: HuffmanTree +defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable + +-- | From the Table K.5 of ITU-81 (p154) +defaultAcLumaHuffmanTable :: HuffmanTable +defaultAcLumaHuffmanTable = + [ [] + , [0x01, 0x02] + , [0x03] + , [0x00, 0x04, 0x11] + , [0x05, 0x12, 0x21] + , [0x31, 0x41] + , [0x06, 0x13, 0x51, 0x61] + , [0x07, 0x22, 0x71] + , [0x14, 0x32, 0x81, 0x91, 0xA1] + , [0x08, 0x23, 0x42, 0xB1, 0xC1] + , [0x15, 0x52, 0xD1, 0xF0] + , [0x24, 0x33, 0x62, 0x72] + , [] + , [] + , [0x82] + , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35 + ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54 + ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 + ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A + ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7 + ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4 + ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA + ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5 + ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] + ] + +type HuffmanTable = [[Word8]] + +defaultAcChromaHuffmanTree :: HuffmanTree +defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable + +defaultAcChromaHuffmanTable :: HuffmanTable +defaultAcChromaHuffmanTable = + [ [] + , [0x00, 0x01] + , [0x02] + , [0x03, 0x11] + , [0x04, 0x05, 0x21, 0x31] + , [0x06, 0x12, 0x41, 0x51] + , [0x07, 0x61, 0x71] + , [0x13, 0x22, 0x32, 0x81] + , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1] + , [0x09, 0x23, 0x33, 0x52, 0xF0] + , [0x15, 0x62, 0x72, 0xD1] + , [0x0A, 0x16, 0x24, 0x34] + , [] + , [0xE1] + , [0x25, 0xF1] + , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35 + , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47 + , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59 + , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 + , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84 + , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95 + , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6 + , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7 + , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8 + , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9 + , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA + , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA + ] + ] + diff --git a/src/Codec/Picture/Jpg/Internal/FastDct.hs b/src/Codec/Picture/Jpg/Internal/FastDct.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/FastDct.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +module Codec.Picture.Jpg.Internal.FastDct( referenceDct, fastDctLibJpeg ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Int( Int16, Int32 ) +import Data.Bits( unsafeShiftR, unsafeShiftL ) +import Control.Monad.ST( ST ) + +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Jpg.Internal.Types +import Control.Monad( forM, forM_ ) + +-- | Reference implementation of the DCT, directly implementing the formula +-- of ITU-81. It's slow as hell, perform to many operations, but is accurate +-- and a good reference point. +referenceDct :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int32) +referenceDct workData block = do + forM_ [(u, v) | u <- [0 :: Int .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] $ \(u,v) -> do + val <- at (u,v) + (workData `M.unsafeWrite` (v * dctBlockSize + u)) . truncate $ (1 / 4) * c u * c v * val + + return workData + where -- at :: (Int, Int) -> ST s Float + at (u,v) = do + toSum <- + forM [(x,y) | x <- [0..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do + sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + x)) + return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) + * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16) + return $ sum toSum + + c 0 = 1 / sqrt 2 + c _ = 1 + +pASS1_BITS, cONST_BITS :: Int +cONST_BITS = 13 +pASS1_BITS = 2 + + +fIX_0_298631336, fIX_0_390180644, fIX_0_541196100, + fIX_0_765366865, fIX_0_899976223, fIX_1_175875602, + fIX_1_501321110, fIX_1_847759065, fIX_1_961570560, + fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32 +fIX_0_298631336 = 2446 -- FIX(0.298631336) */ +fIX_0_390180644 = 3196 -- FIX(0.390180644) */ +fIX_0_541196100 = 4433 -- FIX(0.541196100) */ +fIX_0_765366865 = 6270 -- FIX(0.765366865) */ +fIX_0_899976223 = 7373 -- FIX(0.899976223) */ +fIX_1_175875602 = 9633 -- FIX(1.175875602) */ +fIX_1_501321110 = 12299 -- FIX(1.501321110) */ +fIX_1_847759065 = 15137 -- FIX(1.847759065) */ +fIX_1_961570560 = 16069 -- FIX(1.961570560) */ +fIX_2_053119869 = 16819 -- FIX(2.053119869) */ +fIX_2_562915447 = 20995 -- FIX(2.562915447) */ +fIX_3_072711026 = 25172 -- FIX(3.072711026) */ + +cENTERJSAMPLE :: Int32 +cENTERJSAMPLE = 128 + +-- | Fast DCT extracted from libjpeg +fastDctLibJpeg :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int32) +fastDctLibJpeg workData sample_block = do + firstPass workData 0 + secondPass workData 7 + {-_ <- mutate (\_ a -> a `quot` 8) workData-} + return workData + where -- Pass 1: process rows. + -- Note results are scaled up by sqrt(8) compared to a true DCT; + -- furthermore, we scale the results by 2**PASS1_BITS. + firstPass _ i | i == dctBlockSize = return () + firstPass dataBlock i = do + let baseIdx = i * dctBlockSize + readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) + mult = (*) + writeAt idx = dataBlock `M.unsafeWrite` (baseIdx + idx) + writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) + (n `unsafeShiftR` (cONST_BITS - pASS1_BITS)) + + blk0 <- readAt 0 + blk1 <- readAt 1 + blk2 <- readAt 2 + blk3 <- readAt 3 + blk4 <- readAt 4 + blk5 <- readAt 5 + blk6 <- readAt 6 + blk7 <- readAt 7 + + let tmp0 = blk0 + blk7 + tmp1 = blk1 + blk6 + tmp2 = blk2 + blk5 + tmp3 = blk3 + blk4 + + tmp10 = tmp0 + tmp3 + tmp12 = tmp0 - tmp3 + tmp11 = tmp1 + tmp2 + tmp13 = tmp1 - tmp2 + + tmp0' = blk0 - blk7 + tmp1' = blk1 - blk6 + tmp2' = blk2 - blk5 + tmp3' = blk3 - blk4 + + -- Stage 4 and output + writeAt 0 $ (tmp10 + tmp11 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS + writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS + + let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1)) + + writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 + writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 + + let tmp10' = tmp0' + tmp3' + tmp11' = tmp1' + tmp2' + tmp12' = tmp0' + tmp2' + tmp13' = tmp1' + tmp3' + z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- c3 */ + -- Add fudge factor here for final descale. */ + + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1)) + tmp0'' = mult tmp0' fIX_1_501321110 + tmp1'' = mult tmp1' fIX_3_072711026 + tmp2'' = mult tmp2' fIX_2_053119869 + tmp3'' = mult tmp3' fIX_0_298631336 + + tmp10'' = mult tmp10' (- fIX_0_899976223) + tmp11'' = mult tmp11' (- fIX_2_562915447) + tmp12'' = mult tmp12' (- fIX_0_390180644) + z1' + tmp13'' = mult tmp13' (- fIX_1_961570560) + z1' + + writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' + writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' + writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' + writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' + + firstPass dataBlock $ i + 1 + + -- Pass 2: process columns. + -- We remove the PASS1_BITS scaling, but leave the results scaled up + -- by an overall factor of 8. + secondPass :: M.STVector s Int32 -> Int -> ST s () + secondPass _ (-1) = return () + secondPass block i = do + let readAt idx = block `M.unsafeRead` ((7 - i) + idx * dctBlockSize) + mult = (*) + writeAt idx = block `M.unsafeWrite` (dctBlockSize * idx + (7 - i)) + writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3) + blk0 <- readAt 0 + blk1 <- readAt 1 + blk2 <- readAt 2 + blk3 <- readAt 3 + blk4 <- readAt 4 + blk5 <- readAt 5 + blk6 <- readAt 6 + blk7 <- readAt 7 + + let tmp0 = blk0 + blk7 + tmp1 = blk1 + blk6 + tmp2 = blk2 + blk5 + tmp3 = blk3 + blk4 + + -- Add fudge factor here for final descale. */ + tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1)) + tmp12 = tmp0 - tmp3 + tmp11 = tmp1 + tmp2 + tmp13 = tmp1 - tmp2 + + tmp0' = blk0 - blk7 + tmp1' = blk1 - blk6 + tmp2' = blk2 - blk5 + tmp3' = blk3 - blk4 + + writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3) + writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) + + let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1)) + + writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 + writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 + + let tmp10' = tmp0' + tmp3' + tmp11' = tmp1' + tmp2' + tmp12' = tmp0' + tmp2' + tmp13' = tmp1' + tmp3' + + z1' = mult (tmp12' + tmp13') fIX_1_175875602 + -- Add fudge factor here for final descale. */ + + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1); + + tmp0'' = mult tmp0' fIX_1_501321110 + tmp1'' = mult tmp1' fIX_3_072711026 + tmp2'' = mult tmp2' fIX_2_053119869 + tmp3'' = mult tmp3' fIX_0_298631336 + tmp10'' = mult tmp10' (- fIX_0_899976223) + tmp11'' = mult tmp11' (- fIX_2_562915447) + tmp12'' = mult tmp12' (- fIX_0_390180644) + + z1' + tmp13'' = mult tmp13' (- fIX_1_961570560) + + z1' + writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' + writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' + writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' + writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' + + secondPass block (i - 1) + +{-# ANN module "HLint: ignore Use camelCase" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Jpg/Internal/FastIdct.hs b/src/Codec/Picture/Jpg/Internal/FastIdct.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/FastIdct.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +-- | Module providing a 'fast' implementation of IDCT +-- +-- inverse two dimensional DCT, Chen-Wang algorithm +-- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984) +-- 32-bit integer arithmetic (8 bit coefficients) +-- 11 mults, 29 adds per DCT +-- sE, 18.8.91 +-- +-- coefficients extended to 12 bit for IEEE1180-1990 +-- compliance sE, 2.1.94 +-- +-- this code assumes >> to be a two's-complement arithmetic +-- right shift: (-2)>>1 == -1 , (-3)>>1 == -2 +module Codec.Picture.Jpg.Internal.FastIdct( MutableMacroBlock + , fastIdct + , mutableLevelShift + , createEmptyMutableMacroBlock + ) where + +import qualified Data.Vector.Storable as V +import Control.Monad.ST( ST ) +import Data.Bits( unsafeShiftL, unsafeShiftR ) +import Data.Int( Int16 ) +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Jpg.Internal.Types + +iclip :: V.Vector Int16 +iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ] + where val i | i < (-256) = -256 + | i > 255 = 255 + | otherwise = i + +data IDctStage = IDctStage { + x0 :: {-# UNPACK #-} !Int, + x1 :: {-# UNPACK #-} !Int, + x2 :: {-# UNPACK #-} !Int, + x3 :: {-# UNPACK #-} !Int, + x4 :: {-# UNPACK #-} !Int, + x5 :: {-# UNPACK #-} !Int, + x6 :: {-# UNPACK #-} !Int, + x7 :: {-# UNPACK #-} !Int, + x8 :: {-# UNPACK #-} !Int + } + +w1, w2, w3, w5, w6, w7 :: Int +w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16) +w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16) +w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16) +w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16) +w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) +w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) + +-- row (horizontal) IDCT +-- +-- 7 pi 1 +-- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l ) +-- l=0 8 2 +-- +-- where: c[0] = 128 +-- c[1..7] = 128*sqrt(2) +idctRow :: MutableMacroBlock s Int16 -> Int -> ST s () +idctRow blk idx = do + xx0 <- blk `M.unsafeRead` (0 + idx) + xx1 <- blk `M.unsafeRead` (4 + idx) + xx2 <- blk `M.unsafeRead` (6 + idx) + xx3 <- blk `M.unsafeRead` (2 + idx) + xx4 <- blk `M.unsafeRead` (1 + idx) + xx5 <- blk `M.unsafeRead` (7 + idx) + xx6 <- blk `M.unsafeRead` (5 + idx) + xx7 <- blk `M.unsafeRead` (3 + idx) + let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128 + , x1 = fromIntegral xx1 `unsafeShiftL` 11 + , x2 = fromIntegral xx2 + , x3 = fromIntegral xx3 + , x4 = fromIntegral xx4 + , x5 = fromIntegral xx5 + , x6 = fromIntegral xx6 + , x7 = fromIntegral xx7 + , x8 = 0 + } + + firstStage c = c { x4 = x8' + (w1 - w7) * x4 c + , x5 = x8' - (w1 + w7) * x5 c + , x6 = x8'' - (w3 - w5) * x6 c + , x7 = x8'' - (w3 + w5) * x7 c + , x8 = x8'' + } + where x8' = w7 * (x4 c + x5 c) + x8'' = w3 * (x6 c + x7 c) + + secondStage c = c { x0 = x0 c - x1 c + , x8 = x0 c + x1 c + , x1 = x1'' + , x2 = x1' - (w2 + w6) * x2 c + , x3 = x1' + (w2 - w6) * x3 c + , x4 = x4 c - x6 c + , x6 = x5 c + x7 c + , x5 = x5 c - x7 c + } + where x1' = w6 * (x3 c + x2 c) + x1'' = x4 c + x6 c + + thirdStage c = c { x7 = x8 c + x3 c + , x8 = x8 c - x3 c + , x3 = x0 c + x2 c + , x0 = x0 c - x2 c + , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 + , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 + } + scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8 + , x1 = (x3 c + x2 c) `unsafeShiftR` 8 + , x2 = (x0 c + x4 c) `unsafeShiftR` 8 + , x3 = (x8 c + x6 c) `unsafeShiftR` 8 + , x4 = (x8 c - x6 c) `unsafeShiftR` 8 + , x5 = (x0 c - x4 c) `unsafeShiftR` 8 + , x6 = (x3 c - x2 c) `unsafeShiftR` 8 + , x7 = (x7 c - x1 c) `unsafeShiftR` 8 + } + transformed = scaled . thirdStage . secondStage $ firstStage initialState + + (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed + (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed + (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed + (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed + (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed + (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed + (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed + (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed + +-- column (vertical) IDCT +-- +-- 7 pi 1 +-- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l ) +-- l=0 8 2 +-- +-- where: c[0] = 1/1024 +-- c[1..7] = (1/1024)*sqrt(2) +-- +idctCol :: MutableMacroBlock s Int16 -> Int -> ST s () +idctCol blk idx = do + xx0 <- blk `M.unsafeRead` ( 0 + idx) + xx1 <- blk `M.unsafeRead` (8 * 4 + idx) + xx2 <- blk `M.unsafeRead` (8 * 6 + idx) + xx3 <- blk `M.unsafeRead` (8 * 2 + idx) + xx4 <- blk `M.unsafeRead` (8 + idx) + xx5 <- blk `M.unsafeRead` (8 * 7 + idx) + xx6 <- blk `M.unsafeRead` (8 * 5 + idx) + xx7 <- blk `M.unsafeRead` (8 * 3 + idx) + let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192 + , x1 = fromIntegral xx1 `unsafeShiftL` 8 + , x2 = fromIntegral xx2 + , x3 = fromIntegral xx3 + , x4 = fromIntegral xx4 + , x5 = fromIntegral xx5 + , x6 = fromIntegral xx6 + , x7 = fromIntegral xx7 + , x8 = 0 + } + firstStage c = c { x4 = (x8' + (w1 - w7) * x4 c) `unsafeShiftR` 3 + , x5 = (x8' - (w1 + w7) * x5 c) `unsafeShiftR` 3 + , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3 + , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3 + , x8 = x8'' + } + where x8' = w7 * (x4 c + x5 c) + 4 + x8'' = w3 * (x6 c + x7 c) + 4 + + secondStage c = c { x8 = x0 c + x1 c + , x0 = x0 c - x1 c + , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3 + , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3 + , x4 = x4 c - x6 c + , x1 = x1'' + , x6 = x5 c + x7 c + , x5 = x5 c - x7 c + } + where x1' = w6 * (x3 c + x2 c) + 4 + x1'' = x4 c + x6 c + + thirdStage c = c { x7 = x8 c + x3 c + , x8 = x8 c - x3 c + , x3 = x0 c + x2 c + , x0 = x0 c - x2 c + , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 + , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 + } + + clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512) + else iclip `V.unsafeIndex` 0 + + | otherwise = iclip `V.unsafeIndex` 1023 + + f = thirdStage . secondStage $ firstStage initialState + (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8 )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14 + + +{-# INLINE fastIdct #-} +-- | Algorithm to call to perform an IDCT, return the same +-- block that the one given as input. +fastIdct :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +fastIdct block = rows 0 + where rows 8 = cols 0 + rows i = idctRow block (8 * i) >> rows (i + 1) + + cols 8 = return block + cols i = idctCol block i >> cols (i + 1) + +{-# INLINE mutableLevelShift #-} +-- | Perform a Jpeg level shift in a mutable fashion. +mutableLevelShift :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +mutableLevelShift block = update 0 + where update 64 = return block + update idx = do + val <- block `M.unsafeRead` idx + (block `M.unsafeWrite` idx) $ val + 128 + update $ idx + 1 + diff --git a/src/Codec/Picture/Jpg/Internal/Metadata.hs b/src/Codec/Picture/Jpg/Internal/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/Metadata.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Internal.Metadata ( extractMetadatas, encodeMetadatas ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +import Data.Monoid( mempty ) +import Data.Word( Word ) +#endif + +import Data.Word( Word16 ) +import Data.Maybe( fromMaybe ) +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Jpg.Internal.Types + +scalerOfUnit :: JFifUnit -> Met.Keys Word -> Word16 -> Metadatas -> Metadatas +scalerOfUnit unit k v = case unit of + JFifUnitUnknown -> id + JFifPixelsPerInch -> Met.insert k (fromIntegral v) + JFifPixelsPerCentimeter -> + Met.insert k (Met.dotsPerCentiMeterToDotPerInch $ fromIntegral v) + +extractMetadatas :: JpgJFIFApp0 -> Metadatas +extractMetadatas jfif = + inserter Met.DpiX (_jfifDpiX jfif) + $ inserter Met.DpiY (_jfifDpiY jfif) mempty + where + inserter = scalerOfUnit $ _jfifUnit jfif + + +encodeMetadatas :: Metadatas -> [JpgFrame] +encodeMetadatas metas = fromMaybe [] $ do + dpiX <- Met.lookup Met.DpiX metas + dpiY <- Met.lookup Met.DpiY metas + pure . pure . JpgJFIF $ JpgJFIFApp0 + { _jfifUnit = JFifPixelsPerInch + , _jfifDpiX = fromIntegral dpiX + , _jfifDpiY = fromIntegral dpiY + , _jfifThumbnail = Nothing + } + diff --git a/src/Codec/Picture/Jpg/Internal/Progressive.hs b/src/Codec/Picture/Jpg/Internal/Progressive.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/Progressive.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Internal.Progressive + ( JpgUnpackerParameter( .. ) + , progressiveUnpack + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>) ) +#endif + +import Control.Monad( when, unless, forM_ ) +import Control.Monad.ST( ST ) +import Control.Monad.Trans( lift ) +import Data.Bits( (.&.), (.|.), unsafeShiftL ) +import Data.Int( Int16, Int32 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Vector( (!) ) +import qualified Data.Vector.Mutable as M +import qualified Data.Vector.Storable.Mutable as MS + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Internal.Common +import Codec.Picture.Jpg.Internal.Types +import Codec.Picture.Jpg.Internal.DefaultTable + +createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) +createMcuLineIndices param imgWidth mcuWidth = + V.fromList $ VS.fromList <$> [indexSolo, indexMulti] + where compW = fromIntegral $ horizontalSamplingFactor param + compH = fromIntegral $ verticalSamplingFactor param + imageBlockSize = toBlockSize imgWidth + + -- if the displayed MCU block is only displayed in half (like with + -- width 500 then we loose one macroblock of the MCU at the end of + -- the line. Previous implementation which naively used full mcu + -- was wrong. Only taking into account visible macroblocks + indexSolo = [base + x + | y <- [0 .. compH - 1] + , let base = y * mcuWidth * compW + , x <- [0 .. imageBlockSize - 1]] + + indexMulti = + [(mcu + y * mcuWidth) * compW + x + | mcu <- [0 .. mcuWidth - 1] + , y <- [0 .. compH - 1] + , x <- [0 .. compW - 1] ] + +decodeFirstDC :: JpgUnpackerParameter + -> MS.STVector s Int16 + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun + where unpack = do + (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params + previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params + let neoDcCoefficient = previousDc + dcDeltaCoefficient + approxLow = fst $ successiveApprox params + scaledDc = neoDcCoefficient `unsafeShiftL` approxLow + lift $ (block `MS.unsafeWrite` 0) scaledDc + lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient + +decodeRefineDc :: JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeRefineDc params _ block eobrun = unpack >> pure eobrun + where approxLow = fst $ successiveApprox params + plusOne = 1 `unsafeShiftL` approxLow + unpack = do + bit <- getNextBitJpg + when bit . lift $ do + v <- block `MS.unsafeRead` 0 + (block `MS.unsafeWrite` 0) $ v .|. plusOne + +decodeFirstAc :: JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 +decodeFirstAc params _ block _ = unpack startIndex + where (startIndex, maxIndex) = coefficientRange params + (low, _) = successiveApprox params + unpack n | n > maxIndex = pure 0 + unpack n = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> unpack $ n + 16 + ( 0, 0) -> return 0 + ( r, 0) -> eobrun <$> unpackInt r + where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits + ( r, s) -> do + let n' = n + r + val <- (`unsafeShiftL` low) <$> decodeInt s + lift . (block `MS.unsafeWrite` n') $ fromIntegral val + unpack $ n' + 1 + +decodeRefineAc :: forall a s. JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeRefineAc params _ block eobrun + | eobrun == 0 = unpack startIndex + | otherwise = performEobRun startIndex >> return (eobrun - 1) + where (startIndex, maxIndex) = coefficientRange params + (low, _) = successiveApprox params + plusOne = 1 `unsafeShiftL` low + minusOne = (-1) `unsafeShiftL` low + + getBitVal = do + v <- getNextBitJpg + pure $ if v then plusOne else minusOne + + performEobRun idx | idx > maxIndex = pure () + performEobRun idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + case (bit, (coeff .&. plusOne) == 0) of + (False, _) -> performEobRun $ idx + 1 + (True, False) -> performEobRun $ idx + 1 + (True, True) -> do + let newVal | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) newVal + performEobRun $ idx + 1 + else + performEobRun $ idx + 1 + + unpack idx | idx > maxIndex = pure 0 + unpack idx = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> do + idx' <- updateCoeffs 0xF idx + unpack $ idx' + 1 + + ( r, 0) -> do + lowBits <- unpackInt r + let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 + performEobRun idx + pure newEobRun + + ( r, _) -> do + val <- getBitVal + idx' <- updateCoeffs (fromIntegral r) idx + when (idx' <= maxIndex) $ + lift $ (block `MS.unsafeWrite` idx') val + unpack $ idx' + 1 + + updateCoeffs :: Int -> Int -> BoolReader s Int + updateCoeffs r idx + | r < 0 = pure $ idx - 1 + | idx > maxIndex = pure idx + updateCoeffs r idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + when (bit && coeff .&. plusOne == 0) $ do + let writeCoeff | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) writeCoeff + updateCoeffs r $ idx + 1 + else + updateCoeffs (r - 1) $ idx + 1 + +type Unpacker s = + JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 + -> BoolReader s Int32 + + +prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) + , M.STVector s BoolState) +prepareUnpacker lst = do + let boolStates = V.fromList $ map snd infos + vec <- V.unsafeThaw boolStates + return (V.fromList $ map fst infos, vec) + where infos = map prepare lst + prepare ([], _) = error "progressiveUnpack, no component" + prepare (whole@((param, _) : _) , byteString) = + (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) + where unpacker = selection (successiveApprox param) (coefficientRange param) + boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString + + selection (_, 0) (0, _) = decodeFirstDC + selection (_, 0) _ = decodeFirstAc + selection _ (0, _) = decodeRefineDc + selection _ _ = decodeRefineAc + +data ComponentData s = ComponentData + { componentIndices :: V.Vector (VS.Vector Int) + , componentBlocks :: V.Vector (MutableMacroBlock s Int16) + , componentId :: !Int + , componentBlockCount :: !Int + } + +-- | Iteration from 0 to n in monadic context, without data +-- keeping. +lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () +{-# INLINE lineMap #-} +lineMap count f = go 0 + where go n | n >= count = return () + go n = f n >> go (n + 1) + +progressiveUnpack :: (Int, Int) + -> JpgFrameHeader + -> V.Vector (MacroBlock Int16) + -> [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s (MutableImage s PixelYCbCr8) +progressiveUnpack (maxiW, maxiH) frame quants lst = do + (unpackers, readers) <- prepareUnpacker lst + allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame + :: ST s [ComponentData s] + let scanCount = length lst + restartIntervalValue = case lst of + ((p,_):_,_): _ -> restartInterval p + _ -> -1 + dcCoeffs <- MS.replicate imgComponentCount 0 + eobRuns <- MS.replicate (length lst) 0 + workBlock <- createEmptyMutableMacroBlock + writeIndices <- MS.replicate imgComponentCount (0 :: Int) + restartIntervals <- MS.replicate scanCount restartIntervalValue + let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount + img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 + + let processRestartInterval = + forM_ [0 .. scanCount - 1] $ \ix -> do + v <- restartIntervals `MS.read` ix + if v == 0 then do + -- reset DC prediction + when (ix == 0) (MS.set dcCoeffs 0) + reader <- readers `M.read` ix + (_, updated) <- runBoolReaderWith reader $ + byteAlignJpg >> decodeRestartInterval + (readers `M.write` ix) updated + (eobRuns `MS.unsafeWrite` ix) 0 + (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 + else + (restartIntervals `MS.unsafeWrite` ix) $ v - 1 + + + lineMap imageMcuHeight $ \mmY -> do + -- Reset all blocks to 0 + forM_ allBlocks $ V.mapM_ (`MS.set` 0) . componentBlocks + MS.set writeIndices 0 + + lineMap imageMcuWidth $ \_mmx -> do + processRestartInterval + V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do + boolState <- readers `M.read` readerIndex unpackParam + eobrun <- eobRuns `MS.read` readerIndex unpackParam + let componentNumber = componentIndex unpackParam + writeIndex <- writeIndices `MS.read` componentNumber + let componentData = allBlocks !! componentNumber + -- We get back the correct block indices for the number of component + -- in the current scope (precalculated) + indexVector = + componentIndices componentData ! indiceVector unpackParam + maxIndexLength = VS.length indexVector + unless (writeIndex + blockIndex unpackParam >= maxIndexLength) $ do + let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) + writeBlock = componentBlocks componentData ! realIndex + (eobrun', state) <- + runBoolReaderWith boolState $ + unpacker unpackParam dcCoeffs writeBlock eobrun + + (readers `M.write` readerIndex unpackParam) state + (eobRuns `MS.write` readerIndex unpackParam) eobrun' + + -- Update the write indices + forM_ allBlocks $ \comp -> do + writeIndex <- writeIndices `MS.read` componentId comp + let newIndex = writeIndex + componentBlockCount comp + (writeIndices `MS.write` componentId comp) newIndex + + forM_ allBlocks $ \compData -> do + let compBlocks = componentBlocks compData + cId = componentId compData + comp = jpgComponents frame !! cId + quantId = + fromIntegral $ quantizationTableDest comp + table = quants ! min 3 quantId + compW = fromIntegral $ horizontalSamplingFactor comp + compH = fromIntegral $ verticalSamplingFactor comp + cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 + ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 + + rasterMap (imageMcuWidth * compW) compH $ \rx y -> do + let ry = mmY * maxiH + y + block = compBlocks ! (y * imageMcuWidth * compW + rx) + transformed <- decodeMacroBlock table workBlock block + unpackMacroBlock imgComponentCount + cw8 ch8 cId (rx * cw8) ry + img transformed + + return img + + where imgComponentCount = length $ jpgComponents frame + + imgWidth = fromIntegral $ jpgWidth frame + imgHeight = fromIntegral $ jpgHeight frame + + imageBlockWidth = toBlockSize imgWidth + imageBlockHeight = toBlockSize imgHeight + + imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW + imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH + + allocateWorkingBlocks (ix, comp) = do + let blockCount = hSample * vSample * imageMcuWidth * 2 + blocks <- V.replicateM blockCount createEmptyMutableMacroBlock + return ComponentData + { componentBlocks = blocks + , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth + , componentBlockCount = hSample * vSample + , componentId = ix + } + where hSample = fromIntegral $ horizontalSamplingFactor comp + vSample = fromIntegral $ verticalSamplingFactor comp + diff --git a/src/Codec/Picture/Jpg/Internal/Types.hs b/src/Codec/Picture/Jpg/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Internal/Types.hs @@ -0,0 +1,1073 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} + +-- | A good explanation of the JPEG format, including diagrams, is given at: +-- +-- +-- The full spec (excluding EXIF): https://www.w3.org/Graphics/JPEG/itu-t81.pdf +module Codec.Picture.Jpg.Internal.Types( MutableMacroBlock + , createEmptyMutableMacroBlock + , printMacroBlock + , printPureMacroBlock + , DcCoefficient + , JpgImage( .. ) + , JpgComponent( .. ) + , JpgFrameHeader( .. ) + , JpgFrame( .. ) + , JpgFrameKind( .. ) + , JpgScanHeader( .. ) + , JpgQuantTableSpec( .. ) + , JpgHuffmanTableSpec( .. ) + , JpgImageKind( .. ) + , JpgScanSpecification( .. ) + , JpgColorSpace( .. ) + , AdobeTransform( .. ) + , JpgAdobeApp14( .. ) + , JpgJFIFApp0( .. ) + , JFifUnit( .. ) + , TableList( .. ) + , RestartInterval( .. ) + , getJpgImage + , calculateSize + , dctBlockSize + , parseECS + , parseECS_simple + , skipUntilFrames + , skipFrameMarker + , parseFrameOfKind + , parseFrames + , parseFrameKinds + , parseToFirstFrameHeader + ) where + + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + +import Control.DeepSeq( NFData(..) ) +import Control.Monad( when, replicateM, forM, forM_, unless ) +import Control.Monad.ST( ST ) +import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) +import Data.List( partition ) +import Data.Maybe( maybeToList ) +import GHC.Generics( Generic ) + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif + +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 qualified Data.ByteString.Unsafe as BU + +import Data.Int( Int16, Int64 ) +import Data.Word(Word8, Word16 ) +import Data.Binary( Binary(..) ) + +import Data.Binary.Get( Get + , getWord8 + , getWord16be + , getByteString + , skip + , bytesRead + , lookAhead + , ByteOffset + , getLazyByteString + ) +import qualified Data.Binary.Get.Internal as GetInternal + +import Data.Binary.Put( Put + , putWord8 + , putWord16be + , putLazyByteString + , putByteString + , runPut + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Jpg.Internal.DefaultTable +import Codec.Picture.Tiff.Internal.Types +import Codec.Picture.Tiff.Internal.Metadata( exifOffsetIfd ) +import Codec.Picture.Metadata.Exif + +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, Generic) +instance NFData JpgFrameKind + +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 -- ^ The @ByteString@ is the ECS (Entropy-Coded Segment), typically the largest part of compressed image data. + | JpgScans !JpgFrameKind !JpgFrameHeader + | JpgIntervalRestart !Word16 + deriving (Eq, Show, Generic) +instance NFData JpgFrame + +data JpgColorSpace + = JpgColorSpaceYCbCr + | JpgColorSpaceYCC + | JpgColorSpaceY + | JpgColorSpaceYA + | JpgColorSpaceYCCA + | JpgColorSpaceYCCK + | JpgColorSpaceCMYK + | JpgColorSpaceRGB + | JpgColorSpaceRGBA + deriving (Eq, Show, Generic) +instance NFData JpgColorSpace + +data AdobeTransform + = AdobeUnknown -- ^ Value 0 + | AdobeYCbCr -- ^ value 1 + | AdobeYCck -- ^ value 2 + deriving (Eq, Show, Generic) +instance NFData AdobeTransform + +data JpgAdobeApp14 = JpgAdobeApp14 + { _adobeDctVersion :: !Word16 + , _adobeFlag0 :: !Word16 + , _adobeFlag1 :: !Word16 + , _adobeTransform :: !AdobeTransform + } + deriving (Eq, Show, Generic) +instance NFData JpgAdobeApp14 + +-- | Size: 1 +data JFifUnit + = JFifUnitUnknown -- ^ 0 + | JFifPixelsPerInch -- ^ 1 + | JFifPixelsPerCentimeter -- ^ 2 + deriving (Eq, Show, Generic) +instance NFData JFifUnit + +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 (Eq, Show, Generic) +instance NFData JpgJFIFApp0 + +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 (Eq, Show, Generic) +instance NFData JpgFrameHeader + + +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 (Eq, Show, Generic) +instance NFData JpgComponent + +instance SizeCalculable JpgComponent where + calculateSize _ = 3 + +data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } + deriving (Eq, Show, Generic) +instance NFData JpgImage + +data JpgScanSpecification = JpgScanSpecification + { componentSelector :: !Word8 + -- | Encoded as 4 bits + , dcEntropyCodingTable :: !Word8 + -- | Encoded as 4 bits + , acEntropyCodingTable :: !Word8 + + } + deriving (Eq, Show, Generic) +instance NFData JpgScanSpecification + +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 (Eq, Show, Generic) +instance NFData JpgScanHeader + +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 (Eq, Show, Generic) +instance NFData JpgQuantTableSpec + +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 (Eq, Show, Generic) +instance NFData JpgHuffmanTableSpec + +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 + + -- | Consider using `getJpgImage` instead for a non-semi-lazy implementation. + get = do + skipUntilFrames + frames <- parseFramesSemiLazy + -- let endOfImageMarker = 0xD9 + {-checkMarker commonMarkerFirstByte endOfImageMarker-} + return JpgImage { jpgFrame = frames } + +-- | Like `get` from `instance Binary JpgImage`, but without the legacy +-- semi-lazy implementation. +getJpgImage :: Get JpgImage +getJpgImage = do + skipUntilFrames + frames <- parseFrames + return JpgImage { jpgFrame = frames } + +skipUntilFrames :: Get () +skipUntilFrames = do + let startOfImageMarker = 0xD8 + checkMarker commonMarkerFirstByte startOfImageMarker + eatUntilCode + +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) = putExif 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") + +-- | Simpler implementation of `parseECS` to allow an easier understanding +-- of the logic, and to provide a comparison for correctness. +parseECS_simple :: Get L.ByteString +parseECS_simple = do + -- There's no efficient way in `binary` to parse byte-by-byte while assembling a + -- resulting ByteString (without using `.Internal` modules, which is what + -- `parseECS` does), so instead first compute the length of the content + -- byte-by-byte inside a `lookAhead` (not advancing the parser offset), and + -- then efficiently take that long a ByteString (advancing the parser offset). + -- + -- This is still slow compared to `parseECS` because parser functions + -- (`getWord8`) are used repeatedly, instead of plain loops over ByteString contents. + -- The slowdown is ~2x on GHC 8.10.7 on an Intel Core i7-7500U. + n <- lookAhead getContentLength + getLazyByteString n + where + getContentLength :: Get ByteOffset + getContentLength = do + bytesReadBeforeContent <- bytesRead + let loop :: Word8 -> Get ByteOffset + loop !v = do + vNext <- getWord8 + let isReset = 0xD0 <= vNext && vNext <= 0xD7 + let vIsSegmentMarker = v == 0xFF && vNext /= 0 && not isReset + if not vIsSegmentMarker + then loop vNext + else do + bytesReadAfterContentPlus2 <- bytesRead -- "plus 2" because we've also read the segment marker (0xFF and `vNext`) + let !contentLength = (bytesReadAfterContentPlus2 - 2) - bytesReadBeforeContent + return contentLength + + v_first <- getWord8 + loop v_first + +-- Replace by `Data.ByteString.dropEnd` once we require `bytestring >= 0.11.1.0`. +bsDropEnd :: Int -> B.ByteString -> B.ByteString +bsDropEnd n bs + | n <= 0 = bs + | n >= len = B.empty + | otherwise = B.take (len - 1) bs + where + len = B.length bs +{-# INLINE bsDropEnd #-} + +-- | Parses a Scan's ECS (Entropy-Coded Segment, the largest part of compressed image data) +-- from the `Get` stream. +-- +-- When this function is called, the parser's offset should be +-- immediately behind the SOS tag. +-- +-- As described on e.g. https://www.ccoderun.ca/programming/2017-01-31_jpeg/, +-- +-- > To find the next segment after the SOS, you must keep reading until you +-- > find a 0xFF bytes which is not immediately followed by 0x00 (see "byte stuffing") +-- > [or a reset marker's byte: 0xD0 through 0xD7]. +-- > Normally, this will be the EOI segment that comes at the end of the file. +-- +-- where the 0xFF is the next segment's marker. +-- See https://github.com/corkami/formats/blob/master/image/jpeg.md#entropy-coded-segment +-- for more details. +-- +-- This function returns the ECS, not including the next segment's +-- marker on its trailing end. +parseECS :: Get L.ByteString +parseECS = do + -- For a simpler but slower implementation of this function, see + -- `parseECS_simple`. + + v_first <- getWord8 + -- TODO: Compare with what `scan` from `binary-parsers` does. + -- Probably we cannot use it because it does not allow us to set the parser state + -- to be _before_ the segment marker which would be convenient to not have to + -- make a special case the function that calls this function. + -- But `scan` works on pointers into the bytestring chunks. Why, for performance? + -- I've asked on https://github.com/winterland1989/binary-parsers/issues/7 + -- If that is for performance, we may want to replicate the same thing here. + -- + -- An orthogonal idea is to use `Data.ByteString.elemIndex` to fast-forward + -- to the next 0xFF using `memchr`, but the `unsafe` call to `memchr` might + -- have too much overhead, since 0xFF bytes appear statistically every 256 bytes. + -- See https://stackoverflow.com/questions/14519905/how-much-does-it-cost-for-haskell-ffi-to-go-into-c-and-back + + -- `withInputChunks` allows us to work on chunks of ByteStrings, + -- reducing the number of higher-overhead `Get` functions called. + -- It also allows to easily assemble the ByteString to return, + -- which may be cross-chunk. + -- `withInputChunks` terminates when we return a + -- Right (consumed :: ByteString, unconsumed :: ByteString) + -- from `consumeChunk`, setting the `Get` parser's offset to just before `unconsumed`. + -- Because the segment marker we seek may be the 2 bytes across chunk boundaries, + -- we need to keep a reference to the previous chunk (initialised as `B.empty`), + -- so that we can set `consumed` properly, because this function is supposed + -- to not consume the start of the segment marker (see code dropping the last + -- byte of the previous chunk below). + GetInternal.withInputChunks + (v_first, B.empty) + consumeChunk + ( L.fromChunks . (B.singleton v_first :)) -- `v_first` also belongs to the returned BS + (return . L.fromChunks . (B.singleton v_first :)) -- `v_first` also belongs to the returned BS + where + consumeChunk :: GetInternal.Consume (Word8, B.ByteString) -- which is: (Word8, B.ByteString) -> B.ByteString -> Either (Word8, B.ByteString) (B.ByteString, B.ByteString) + consumeChunk (!v_chunk_start, !prev_chunk) !chunk + -- If `withInputChunks` hands us an empty chunk (which `binary` probably + -- won't do, but since that's not documented, handle it anyway) then skip over it, + -- so that we always remember the last `prev_chunk` that actually has data in it, + -- since we `bsDropEnd 1 prev_chunk` in the `case` below. + | B.null chunk = Left (v_chunk_start, prev_chunk) + | otherwise = loop v_chunk_start 0 + where + loop :: Word8 -> Int -> Either (Word8, B.ByteString) (B.ByteString, B.ByteString) + loop !v !offset_in_chunk + | offset_in_chunk >= B.length chunk = Left (v, chunk) + | otherwise = + let !vNext = BU.unsafeIndex chunk offset_in_chunk -- bounds check is done above + !isReset = 0xD0 <= vNext && vNext <= 0xD7 + !vIsSegmentMarker = v == 0xFF && vNext /= 0 && not isReset + in + if not vIsSegmentMarker + then loop vNext (offset_in_chunk+1) + else + -- Set the parser state to _before_ the segment marker. + -- The first case, where the segment marker's 2 bytes are exactly + -- at the chunk boundary, requires us to allocate a new BS with + -- `B.cons`; luckily this case should be rare. + let (!consumed, !unconsumed) = case () of + () | offset_in_chunk == 0 -> (bsDropEnd 1 prev_chunk, v `B.cons` chunk) -- segment marker starts at `v`, which is the last byte of the previous chunk + | offset_in_chunk == 1 -> (B.empty, chunk) -- segment marker starts exactly at `chunk` + | otherwise -> B.splitAt (offset_in_chunk - 1) chunk -- segment marker starts at `v`, which is 1 before `vNext` (which is at `offset_in_chunk`) + in Right $! (consumed, unconsumed) + + + +parseAdobe14 :: B.ByteString -> Maybe JpgFrame +parseAdobe14 str = case runGetStrict get str of + Left _err -> Nothing + Right app14 -> Just $! JpgAdobeAPP14 app14 + +-- | Parse JFIF or JFXX information. Right now only JFIF. +parseJF__ :: B.ByteString -> Maybe JpgFrame +parseJF__ str = case runGetStrict get str of + Left _err -> Nothing + Right jfif -> Just $! JpgJFIF jfif + +parseExif :: B.ByteString -> Maybe JpgFrame +parseExif str + | exifHeader `B.isPrefixOf` str = + let + tiff = B.drop (B.length exifHeader) str + in + case runGetStrict (getP tiff) tiff of + Left _err -> Nothing + Right (_hdr :: TiffHeader, []) -> Nothing + Right (_hdr :: TiffHeader, ifds : _) -> Just $! JpgExif ifds + | otherwise = Nothing + where + exifHeader = BC.pack "Exif\0\0" + +putExif :: [ImageFileDirectory] -> Put +putExif ifds = putAll where + hdr = TiffHeader + { hdrEndianness = EndianBig + , hdrOffset = 8 + } + + ifdList = case partition (isInIFD0 . ifdIdentifier) ifds of + (ifd0, []) -> [ifd0] + (ifd0, ifdExif) -> [ifd0 <> pure exifOffsetIfd, ifdExif] + + exifBlob = runPut $ do + putByteString $ BC.pack "Exif\0\0" + putP BC.empty (hdr, ifdList) + + putAll = do + put (JpgAppSegment 1) + putWord16be . fromIntegral $ L.length exifBlob + 2 + putLazyByteString exifBlob + +skipFrameMarker :: Get () +skipFrameMarker = do + word <- getWord8 + when (word /= 0xFF) $ do + readedData <- bytesRead + fail $ "Invalid Frame marker (" ++ show word + ++ ", bytes read : " ++ show readedData ++ ")" + +-- | Parses a single frame. +-- +-- Returns `Nothing` when we encounter a frame we want to skip. +parseFrameOfKind :: JpgFrameKind -> Get (Maybe JpgFrame) +parseFrameOfKind kind = do + case kind of + JpgEndOfImage -> return Nothing + JpgAppSegment 0 -> parseJF__ <$> takeCurrentFrame + JpgAppSegment 1 -> parseExif <$> takeCurrentFrame + JpgAppSegment 14 -> parseAdobe14 <$> takeCurrentFrame + JpgAppSegment c -> Just . JpgAppFrame c <$> takeCurrentFrame + JpgExtensionSegment c -> Just . JpgExtension c <$> takeCurrentFrame + JpgQuantizationTable -> + (\(TableList quants) -> Just $! JpgQuantTable quants) <$> get + JpgRestartInterval -> + (\(RestartInterval i) -> Just $! JpgIntervalRestart i) <$> get + JpgHuffmanTableMarker -> + (\(TableList huffTables) -> Just $! + JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables]) + <$> get + JpgStartOfScan -> do + scanHeader <- get + ecs <- parseECS + return $! Just $! JpgScanBlob scanHeader ecs + _ -> Just . JpgScans kind <$> get + + +-- | Parse a list of `JpgFrame`s. +-- +-- This function has various quirks; consider the below with great caution +-- when using this function. +-- +-- While @data JpgFrame = ... | JpgScanBlob !...` itself has strict fields, +-- +-- This function is written in such a way that that it can construct +-- the @[JpgFrame]@ "lazily" such that the expensive byte-by-byte traversal +-- in `parseECS` to create a `JpgScanBlob` can be avoided if only +-- list elements before that `JpgScanBlob` are evaluated. +-- +-- That means the user can write code such as +-- +-- > let mbFirstScan = +-- > case runGetOrFail (get @JPG.JpgImage) hugeImageByteString of -- (`get @JPG.JpgImage` uses `parseFramesSemiLazy`) +-- > Right (_restBs, _offset, res) -> +-- > find (\frame -> case frame of { JPG.JpgScans{} -> True; _ -> False }) (JPG.jpgFrame res) +-- +-- with the guarantee that only the bytes before the ECS (large compressed image data) +-- will be inspected, assuming that indeed there is at least 1 `JpgScan` in front +-- of the `JpgScanBlob` that contains the ECS. +-- +-- This guarantee can be useful to e.g. quickly read just the image +-- dimensions (width, height) without traversing the large data. +-- +-- Also note that this `Get` parser does not correctly maintain the parser byte offset +-- (`Data.Binary.Get.bytesRead`), because as soon as a `JpgStartOfScan` is returned, +-- it uses `Data.Binary.Get.getRemainingLazyBytes` to provide: +-- +-- 1. the laziness described above, and +-- 2. the ability to ignore any parser failure after the first successfully-parsed +-- `JpgScanBlob` (it is debatable whether this behaviour is a desirable behaviour of this +-- library, but it is historically so and existing exposed functions do not break +-- this for backwards compatibility with existing uses of this library). +-- This fact also means that even `parseNextFrameStrict` cannot maintain +-- correct parser byte offsets. +-- +-- Further note that if you are reading a huge JPEG image from disk strictly, +-- this will already incur a full traversal (namely creation) of the `hugeImageByteString`. +-- Thus, `parseNextFrameLazy` only provides any benefit if you: +-- +-- - read the image from disk using lazy IO (not recommended!) such as via +-- `Data.ByteString.Lazy.readFile`, +-- - or do something similar, such as creating the `hugeImageByteString` via @mmap()@ +-- +-- This function is called "semi lazy" because only the first `JpgScanBlob` returned +-- in the `[JpgFrame]` is returned lazily; frames of other types, or multiple +-- `JpgScanBlob`s, are confusingly not dealt with lazily. +-- +-- If as a caller you do not want to deal with any of these quirks, +-- and use proper strict IO and/or via `Data.Binary.Get`'s incremental input interface: +-- +-- - If you want the whole `[JpgFrame]`: use `parseFrames`. +-- - If you want parsing to terminate early as in the example shown above, +-- use in combination with just the right amount of `get :: Get JpgFrameKind`, +-- `parseFrameOfKind`, and `skipFrameMarker`. +parseFramesSemiLazy :: Get [JpgFrame] +parseFramesSemiLazy = do + kind <- get + case kind of + -- The end-of-image case needs to be here because `_ ->` default case below + -- unconditionally uses `skipFrameMarker` which does not exist after `JpgEndOfImage`. + JpgEndOfImage -> pure [] + JpgStartOfScan -> do + scanHeader <- get + remainingBytes <- getRemainingLazyBytes + -- It is after the above `getRemainingLazyBytes` that the `Get` parser lazily succeeds, + -- allowing consumers of `parseFramesSemiLazy` evaluate all `[JpgFrame]` list elements + -- until (excluding) the cons-cell around the `JpgScanBlob ...` we construct below. + + return $ case runGet parseECS remainingBytes of + Left _ -> + -- Construct invalid `JpgScanBlob` even when the compressed JPEG + -- data is truncated or otherwise invalid, because that's what JuicyPixels's + -- `parseFramesSemiLazy` function did in the past, for backwards compat. + [JpgScanBlob scanHeader remainingBytes] + Right ecs -> + JpgScanBlob scanHeader ecs + : + -- TODO Why `drop 1` instead of `runGet (skipFrameMarker *> parseFramesSemiLazy) remainingBytes` that would check that the dropped 1 Byte is really a frame marker? + case runGet parseFramesSemiLazy (L.drop (L.length ecs + 1) remainingBytes) of + -- After we've encountered the first scan blob containing encoded image data, + -- we accept anything else after to fail parsing, ignoring that failure, + -- end emitting no further frames. + -- TODO: Explain why JuicyPixel chose to use this logic, insteaed of failing. + Left _ -> [] + Right remainingFrames -> remainingFrames + _ -> do + mbFrame <- parseFrameOfKind kind + skipFrameMarker + remainingFrames <- parseFramesSemiLazy + return $ maybeToList mbFrame ++ remainingFrames + +-- | Parse a list of `JpgFrame`s. +parseFrames :: Get [JpgFrame] +parseFrames = do + kind <- get + case kind of + JpgEndOfImage -> pure [] + _ -> do + mbFrame <- parseFrameOfKind kind + skipFrameMarker + remainingFrames <- parseFrames + return $ maybeToList mbFrame ++ remainingFrames + +-- | Parse a list of `JpgFrameKind`s with their corresponding offsets and lengths +-- (not counting the segment and frame markers into the lengths). +-- +-- Useful for debugging. +parseFrameKinds :: Get [(JpgFrameKind, Int64, Int64)] +parseFrameKinds = do + kindMarkerOffset :: Int64 <- bytesRead + kind <- get + case kind of + JpgEndOfImage -> pure [(JpgEndOfImage, kindMarkerOffset, 0)] + _ -> do + parserOffsetBefore <- bytesRead + _ <- parseFrameOfKind kind + parserOffsetAfter <- bytesRead + let !segmentLengthWithoutMarker = parserOffsetAfter - parserOffsetBefore + skipFrameMarker + remainingKinds <- parseFrameKinds + return $ (kind, kindMarkerOffset, segmentLengthWithoutMarker):remainingKinds + +-- | Parses forward, returning the first scan header encountered. +-- +-- Should be used after `skipUntilFrames`. +-- +-- Fails parsing when an SOS segment marker (`JpgStartOfScan`, resulting +-- in `JpgScanBlob`) is encountered before an SOF segment marker (that +-- results in `JpgScans` carrying the `JpgFrameHeader`). +parseToFirstFrameHeader :: Get (Maybe JpgFrameHeader) +parseToFirstFrameHeader = do + kind <- get + case kind of + JpgEndOfImage -> return Nothing + JpgStartOfScan -> fail "parseToFirstFrameHeader: Encountered SOS frame marker before frame header that tells its dimensions" + _ -> do + mbFrame <- parseFrameOfKind kind + case mbFrame of + Nothing -> continueSearching + Just frame -> case frame of + JpgScans _ frameHeader -> return $ Just $! frameHeader + _ -> continueSearching + where + continueSearching = do + skipFrameMarker + parseToFirstFrameHeader + +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 + case word2 of + 0xC0 -> return JpgBaselineDCTHuffman + 0xC1 -> return JpgExtendedSequentialDCTHuffman + 0xC2 -> return JpgProgressiveDCTHuffman + 0xC3 -> return JpgLosslessHuffman + 0xC4 -> return JpgHuffmanTableMarker + 0xC5 -> return JpgDifferentialSequentialDCTHuffman + 0xC6 -> return JpgDifferentialProgressiveDCTHuffman + 0xC7 -> return JpgDifferentialLosslessHuffman + 0xC9 -> return JpgExtendedSequentialArithmetic + 0xCA -> return JpgProgressiveDCTArithmetic + 0xCB -> return JpgLosslessArithmetic + 0xCD -> return JpgDifferentialSequentialDCTArithmetic + 0xCE -> return JpgDifferentialProgressiveDCTArithmetic + 0xCF -> return JpgDifferentialLosslessArithmetic + 0xD9 -> return JpgEndOfImage + 0xDA -> return JpgStartOfScan + 0xDB -> return JpgQuantizationTable + 0xDD -> return JpgRestartInterval + a | a >= 0xF0 -> return $! JpgExtensionSegment a + | a >= 0xE0 -> return $! JpgAppSegment (a - 0xE0) + | a >= 0xD0 && a <= 0xD7 -> return $! JpgRestartIntervalEnd a + | otherwise -> fail ("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 diff --git a/src/Codec/Picture/Jpg/Progressive.hs b/src/Codec/Picture/Jpg/Progressive.hs deleted file mode 100644 --- a/src/Codec/Picture/Jpg/Progressive.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Codec.Picture.Jpg.Progressive - ( JpgUnpackerParameter( .. ) - , progressiveUnpack - ) where - -import Control.Applicative( pure, (<$>) ) -import Control.Monad( when, forM_ ) -import Control.Monad.ST( ST ) -import Control.Monad.Trans( lift ) -import Data.Bits( (.&.), (.|.), unsafeShiftL ) -import Data.Int( Int16, Int32 ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import Data.Vector( (!) ) -import qualified Data.Vector.Mutable as M -import qualified Data.Vector.Storable.Mutable as MS - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Common -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.DefaultTable - -createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) -createMcuLineIndices param imgWidth mcuWidth = - V.fromList $ VS.fromList <$> [indexSolo, indexMulti] - where compW = fromIntegral $ horizontalSamplingFactor param - compH = fromIntegral $ verticalSamplingFactor param - imageBlockSize = (imgWidth + 7) `div` 8 - - indexSolo = - [y * mcuWidth * compW + x - | y <- [0 .. compH - 1], x <- [0 .. imageBlockSize - 1]] - - indexMulti = - [(mcu + y * mcuWidth) * compW + x - | mcu <- [0 .. mcuWidth - 1] - , y <- [0 .. compH - 1] - , x <- [0 .. compW - 1] ] - -decodeFirstDC :: JpgUnpackerParameter - -> MS.STVector s Int16 - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun - where unpack = do - (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params - previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params - let neoDcCoefficient = previousDc + dcDeltaCoefficient - approxLow = fst $ successiveApprox params - scaledDc = neoDcCoefficient `unsafeShiftL` approxLow - lift $ (block `MS.unsafeWrite` 0) scaledDc - lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient - -decodeRefineDc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeRefineDc params _ block eobrun = unpack >> pure eobrun - where approxLow = fst $ successiveApprox params - plusOne = 1 `unsafeShiftL` approxLow - unpack = do - bit <- getNextBitJpg - when bit . lift $ do - v <- block `MS.unsafeRead` 0 - (block `MS.unsafeWrite` 0) $ v .|. plusOne - -decodeFirstAc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 -decodeFirstAc params _ block _ = unpack startIndex - where (startIndex, maxIndex) = coefficientRange params - (low, _) = successiveApprox params - unpack n | n > maxIndex = pure 0 - unpack n = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> unpack $ n + 16 - ( 0, 0) -> return 0 - ( r, 0) -> eobrun <$> unpackInt r - where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits - ( r, s) -> do - let n' = n + r - val <- (`unsafeShiftL` low) <$> decodeInt s - lift . (block `MS.unsafeWrite` n') $ fromIntegral val - unpack $ n' + 1 - -decodeRefineAc :: forall a s. JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeRefineAc params _ block eobrun - | eobrun == 0 = unpack startIndex - | otherwise = performEobRun startIndex >> return (eobrun - 1) - where (startIndex, maxIndex) = coefficientRange params - (low, _) = successiveApprox params - plusOne = 1 `unsafeShiftL` low - minusOne = (-1) `unsafeShiftL` low - - getBitVal = do - v <- getNextBitJpg - pure $ if v then plusOne else minusOne - - performEobRun idx | idx > maxIndex = pure () - performEobRun idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if (coeff /= 0) then do - bit <- getNextBitJpg - case (bit, (coeff .&. plusOne) == 0) of - (False, _) -> performEobRun $ idx + 1 - (True, False) -> performEobRun $ idx + 1 - (True, True) -> do - let newVal | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) newVal - performEobRun $ idx + 1 - else - performEobRun $ idx + 1 - - unpack idx | idx > maxIndex = pure 0 - unpack idx = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> do - idx' <- updateCoeffs 0xF idx - unpack $ idx' + 1 - - ( r, 0) -> do - lowBits <- unpackInt r - let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 - performEobRun idx - pure newEobRun - - ( r, _) -> do - val <- getBitVal - idx' <- updateCoeffs (fromIntegral r) idx - when (idx' <= maxIndex) $ - (lift $ (block `MS.unsafeWrite` idx') val) - unpack $ idx' + 1 - - updateCoeffs :: Int -> Int -> BoolReader s Int - updateCoeffs r idx - | r < 0 = pure $ idx - 1 - | idx > maxIndex = pure idx - updateCoeffs r idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if coeff /= 0 then do - bit <- getNextBitJpg - when (bit && coeff .&. plusOne == 0) $ do - let writeCoeff | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) writeCoeff - updateCoeffs r $ idx + 1 - else - updateCoeffs (r - 1) $ idx + 1 - -type Unpacker s = - JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 - -> BoolReader s Int32 - - -prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) - , M.STVector s BoolState) -prepareUnpacker lst = do - let boolStates = V.fromList $ map snd infos - vec <- V.unsafeThaw boolStates - return (V.fromList $ map fst infos, vec) - where infos = map prepare lst - prepare ([], _) = error "progressiveUnpack, no component" - prepare (whole@((param, _) : _) , byteString) = - (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) - where unpacker = selection (successiveApprox param) (coefficientRange param) - boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString - - selection (_, 0) (0, _) = decodeFirstDC - selection (_, 0) _ = decodeFirstAc - selection _ (0, _) = decodeRefineDc - selection _ _ = decodeRefineAc - -data ComponentData s = ComponentData - { componentIndices :: V.Vector (VS.Vector Int) - , componentBlocks :: V.Vector (MutableMacroBlock s Int16) - , componentId :: !Int - , componentBlockCount :: !Int - } - --- | Iteration from to n in monadic context, without data --- keeping. -lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () -{-# INLINE lineMap #-} -lineMap count f = go 0 - where go n | n >= count = return () - go n = f n >> go (n + 1) - -progressiveUnpack :: (Int, Int) - -> JpgFrameHeader - -> V.Vector (MacroBlock Int16) - -> [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s (MutableImage s PixelYCbCr8) -progressiveUnpack (maxiW, maxiH) frame quants lst = do - (unpackers, readers) <- prepareUnpacker lst - allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame - :: ST s [ComponentData s] - let scanCount = length lst - restartIntervalValue = case lst of - ((p,_):_,_): _ -> restartInterval p - _ -> -1 - dcCoeffs <- MS.replicate imgComponentCount 0 - eobRuns <- MS.replicate (length lst) 0 - workBlock <- createEmptyMutableMacroBlock - writeIndices <- MS.replicate imgComponentCount (0 :: Int) - restartIntervals <- MS.replicate scanCount restartIntervalValue - let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount - img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 - - let processRestartInterval = - forM_ [0 .. scanCount - 1] $ \ix -> do - v <- restartIntervals `MS.read` ix - if v == 0 then do - -- reset DC prediction - when (ix == 0) (MS.set dcCoeffs 0) - reader <- readers `M.read` ix - (_, updated) <- runBoolReaderWith reader $ - byteAlignJpg >> decodeRestartInterval - (readers `M.write` ix) updated - (eobRuns `MS.unsafeWrite` ix) 0 - (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 - else - (restartIntervals `MS.unsafeWrite` ix) $ v - 1 - - - lineMap imageMcuHeight $ \mmY -> do - -- Reset all blocks to 0 - forM_ allBlocks $ V.mapM_ (flip MS.set 0) . componentBlocks - MS.set writeIndices 0 - - lineMap imageMcuWidth $ \_mmx -> do - processRestartInterval - V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do - boolState <- readers `M.read` readerIndex unpackParam - eobrun <- eobRuns `MS.read` readerIndex unpackParam - let componentNumber = componentIndex unpackParam - writeIndex <- writeIndices `MS.read` componentNumber - let componentData = allBlocks !! componentNumber - indexVector = - componentIndices componentData ! indiceVector unpackParam - maxIndexLength = VS.length indexVector - if writeIndex + blockIndex unpackParam >= maxIndexLength then - return () - else do - let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) - writeBlock = componentBlocks componentData ! realIndex - (eobrun', state) <- - runBoolReaderWith boolState $ - unpacker unpackParam dcCoeffs writeBlock eobrun - - (readers `M.write` readerIndex unpackParam) state - (eobRuns `MS.write` readerIndex unpackParam) eobrun' - - -- Update the write indices - forM_ allBlocks $ \comp -> do - writeIndex <- writeIndices `MS.read` componentId comp - let newIndex = writeIndex + componentBlockCount comp - (writeIndices `MS.write` componentId comp) $ newIndex - - forM_ allBlocks $ \compData -> do - let compBlocks = componentBlocks compData - cId = componentId compData - comp = jpgComponents frame !! cId - quantId = - fromIntegral $ quantizationTableDest comp - table = quants ! min 3 quantId - compW = fromIntegral $ horizontalSamplingFactor comp - compH = fromIntegral $ verticalSamplingFactor comp - cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 - ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 - - rasterMap (imageMcuWidth * compW) compH $ \rx y -> do - let ry = mmY * maxiH + y - block = compBlocks ! (y * imageMcuWidth * compW + rx) - transformed <- decodeMacroBlock table workBlock block - unpackMacroBlock imgComponentCount - cw8 ch8 cId (rx * cw8) ry - img transformed - - return img - - where imgComponentCount = length $ jpgComponents frame - - imgWidth = fromIntegral $ jpgWidth frame - imgHeight = fromIntegral $ jpgHeight frame - - imageBlockWidth = (imgWidth + 7) `div` 8 - imageBlockHeight = (imgHeight + 7) `div` 8 - - imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW - imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH - - allocateWorkingBlocks (ix, comp) = do - let blockCount = hSample * vSample * imageMcuWidth - blocks <- V.replicateM blockCount createEmptyMutableMacroBlock - return $ ComponentData - { componentBlocks = blocks - , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth - , componentBlockCount = hSample * vSample - , componentId = ix - } - where hSample = fromIntegral $ horizontalSamplingFactor comp - vSample = fromIntegral $ verticalSamplingFactor comp - diff --git a/src/Codec/Picture/Jpg/Types.hs b/src/Codec/Picture/Jpg/Types.hs deleted file mode 100644 --- a/src/Codec/Picture/Jpg/Types.hs +++ /dev/null @@ -1,547 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Codec.Picture.Jpg.Types( MutableMacroBlock - , createEmptyMutableMacroBlock - , printMacroBlock - , printPureMacroBlock - , DcCoefficient - , JpgImage( .. ) - , JpgComponent( .. ) - , JpgFrameHeader( .. ) - , JpgFrame( .. ) - , JpgFrameKind( .. ) - , JpgScanHeader( .. ) - , JpgQuantTableSpec( .. ) - , JpgHuffmanTableSpec( .. ) - , JpgImageKind( .. ) - , JpgScanSpecification( .. ) - , calculateSize - , dctBlockSize - ) where - -import Control.Applicative( (<$>), (<*>)) -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.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 - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Jpg.DefaultTable - -{-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 - | JpgExtension !Word8 B.ByteString - | JpgQuantTable ![JpgQuantTableSpec] - | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] - | JpgScanBlob !JpgScanHeader !L.ByteString - | JpgScans !JpgFrameKind !JpgFrameHeader - | JpgIntervalRestart !Word16 - deriving Show - -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 (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 - -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 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 - 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 - | 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 diff --git a/src/Codec/Picture/Metadata.hs b/src/Codec/Picture/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Metadata.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +-- | This module expose a common "metadata" storage for various image +-- type. Different format can generate different metadatas, and write +-- only a part of them. +-- +-- Since version 3.2.5 +-- +module Codec.Picture.Metadata( -- * Types + Metadatas + , Keys( .. ) + , Value( .. ) + , Elem( .. ) + , SourceFormat( .. ) + , ColorSpace( .. ) + + -- * Functions + , Codec.Picture.Metadata.lookup + , empty + , insert + , delete + , singleton + + -- * Folding + , foldl' + , Codec.Picture.Metadata.foldMap + + -- * Helper functions + , mkDpiMetadata + , mkSizeMetadata + , basicMetadata + , simpleMetadata + , extractExifMetas + + -- * Conversion functions + , dotsPerMeterToDotPerInch + , dotPerInchToDotsPerMeter + , dotsPerCentiMeterToDotPerInch + ) where + +import Prelude hiding (Foldable(..)) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid, mempty, mappend ) +import Data.Word( Word ) +#endif + + +import Control.DeepSeq( NFData( .. ) ) +import qualified Data.ByteString as B +import qualified Data.Foldable as F + +import Codec.Picture.Metadata.Exif + +#if MIN_VERSION_base(4,7,0) +import Data.Typeable( (:~:)( Refl ) ) +type Equiv = (:~:) +#else +data Equiv a b where + Refl :: Equiv a a +#endif + +-- | Type describing the original file format of the file. +data SourceFormat + = SourceJpeg + | SourceGif + | SourceBitmap + | SourceTiff + | SourcePng + | SourceHDR + | SourceTGA + deriving (Eq, Show) + +instance NFData SourceFormat where + rnf a = a `seq` () + +-- | The same color values may result in slightly different colors on different +-- devices. To get consistent colors accross multiple devices we need a way of +-- mapping color values from a source device into their equivalents on the +-- target device. +-- +-- The solution is essentially to define, for each device, a family of mappings +-- that convert between device colors and standard CIEXYZ or CIELAB colors. The +-- collection of mappings for a device is known as the 'color-profile' of that +-- device, and each color-profile can be thought of as describing a +-- 'color-space'. +-- +-- If we know the color-space of the input pixels, and the color space of the +-- output device, then we can convert the colors in the image to their +-- equivalents on the output device. +-- +-- JuicyPixels does not parse color-profiles or attempt to perform color +-- correction. +-- +-- The following color space types are recognised: +-- +-- * sRGB: Standard RGB color space. +-- * Windows BMP color space: Color space information embedded within a V4 +-- Windows BMP file. +-- * ICC profile: An ICC color profile. +data ColorSpace = SRGB + | WindowsBitmapColorSpace !B.ByteString + | ICCProfile !B.ByteString + deriving (Eq, Show) + +instance NFData ColorSpace where + rnf v = v `seq` () + +-- | Store various additional information about an image. If +-- something is not recognized, it can be stored in an unknown tag. +-- +-- * 'DpiX' Dot per inch on this x axis. +-- +-- * 'DpiY' Dot per inch on this y axis. +-- +-- * 'Width' Image width in pixel. Relying on the metadata for this +-- information can avoid the full decompression of the image. +-- Ignored for image writing. +-- +-- * 'Height' Image height in pixels. Relying on the metadata for this +-- information can void the full decompression of the image. +-- Ignored for image writing. +-- +-- * 'ColorProfile' An unparsed ICC color profile. Currently only supported by +-- the Bitmap format. +-- +-- * 'Unknown' unlikely to be decoded, but usefull for metadata writing +-- +-- * 'Exif' Exif tag and associated data. +-- +data Keys a where + Gamma :: Keys Double + ColorSpace :: Keys ColorSpace + Format :: Keys SourceFormat + DpiX :: Keys Word + DpiY :: Keys Word + Width :: Keys Word + Height :: Keys Word + Title :: Keys String + Description :: Keys String + Author :: Keys String + Copyright :: Keys String + Software :: Keys String + Comment :: Keys String + Disclaimer :: Keys String + Source :: Keys String + Warning :: Keys String + Exif :: !ExifTag -> Keys ExifData + Unknown :: !String -> Keys Value + +deriving instance Show (Keys a) +deriving instance Eq (Keys a) +{-deriving instance Ord (Keys a)-} + +-- | Encode values for unknown information +data Value + = Int !Int + | Double !Double + | String !String + deriving (Eq, Show) + +instance NFData Value where + rnf v = v `seq` () -- everything is strict, so it's OK + +-- | Element describing a metadata and it's (typed) associated +-- value. +data Elem k = + forall a. (Show a, NFData a) => !(k a) :=> a + +deriving instance Show (Elem Keys) + +instance NFData (Elem Keys) where + rnf (_ :=> v) = rnf v `seq` () + +keyEq :: Keys a -> Keys b -> Maybe (Equiv a b) +keyEq a b = case (a, b) of + (Gamma, Gamma) -> Just Refl + (ColorSpace, ColorSpace) -> Just Refl + (DpiX, DpiX) -> Just Refl + (DpiY, DpiY) -> Just Refl + (Width, Width) -> Just Refl + (Height, Height) -> Just Refl + (Title, Title) -> Just Refl + (Description, Description) -> Just Refl + (Author, Author) -> Just Refl + (Copyright, Copyright) -> Just Refl + (Software, Software) -> Just Refl + (Comment, Comment) -> Just Refl + (Disclaimer, Disclaimer) -> Just Refl + (Source, Source) -> Just Refl + (Warning, Warning) -> Just Refl + (Format, Format) -> Just Refl + (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl + (Exif t1, Exif t2) | t1 == t2 -> Just Refl + _ -> Nothing + +-- | Dependent storage used for metadatas. +-- All metadatas of a given kind are unique within +-- this container. + -- +-- The current data structure is based on list, +-- so bad performances can be expected. +newtype Metadatas = Metadatas + { getMetadatas :: [Elem Keys] + } + deriving (Show, NFData) + +instance Monoid Metadatas where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#else +instance Semigroup Metadatas where + (<>) = union +#endif + +-- | Right based union +union :: Metadatas -> Metadatas -> Metadatas +union m1 = F.foldl' go m1 . getMetadatas where + go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc) + +-- | Strict left fold of the metadatas +foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc +foldl' f initAcc = F.foldl' f initAcc . getMetadatas + +-- | foldMap equivalent for metadatas. +foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m +foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty + +-- | Remove an element of the given keys from the metadatas. +-- If not present does nothing. +delete :: Keys a -> Metadatas -> Metadatas +delete k = Metadatas . go . getMetadatas where + go [] = [] + go (el@(k2 :=> _) : rest) = case keyEq k k2 of + Nothing -> el : go rest + Just Refl -> rest + +-- | Extract all Exif specific metadatas +extractExifMetas :: Metadatas -> [(ExifTag, ExifData)] +extractExifMetas = go . getMetadatas where + go :: [Elem Keys] -> [(ExifTag, ExifData)] + go [] = [] + go ((k :=> v) : rest) = + case k of + Exif t -> (t, v) : go rest + _ -> go rest + +-- | Search a metadata with the given key. +lookup :: Keys a -> Metadatas -> Maybe a +lookup k = go . getMetadatas where + go [] = Nothing + go ((k2 :=> v) : rest) = case keyEq k k2 of + Nothing -> go rest + Just Refl -> Just v + +-- | Insert an element in the metadatas, if an element with +-- the same key is present, it is overwritten. +insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas +insert k val metas = + Metadatas $ (k :=> val) : getMetadatas (delete k metas) + +-- | Create metadatas with a single element. +singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas +singleton k val = Metadatas [k :=> val] + +-- | Empty metadatas. Favor 'mempty' +empty :: Metadatas +empty = Metadatas mempty + +-- | Conversion from dpm to dpi +dotsPerMeterToDotPerInch :: Word -> Word +dotsPerMeterToDotPerInch z = z * 254 `div` 10000 + +-- | Conversion from dpi to dpm +dotPerInchToDotsPerMeter :: Word -> Word +dotPerInchToDotsPerMeter z = (z * 10000) `div` 254 + +-- | Conversion dpcm -> dpi +dotsPerCentiMeterToDotPerInch :: Word -> Word +dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100 + +-- | Create metadatas indicating the resolution, with DpiX == DpiY +mkDpiMetadata :: Word -> Metadatas +mkDpiMetadata w = + Metadatas [DpiY :=> w, DpiX :=> w] + +-- | Create metadatas holding width and height information. +mkSizeMetadata :: Integral n => n -> n -> Metadatas +mkSizeMetadata w h = + Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ] + +-- | Create simple metadatas with Format, Width & Height +basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas +basicMetadata f w h = + Metadatas [ Format :=> f + , Width :=> fromIntegral w + , Height :=> fromIntegral h + ] + +-- | Create simple metadatas with Format, Width, Height, DpiX & DpiY +simpleMetadata :: (Integral nSize, Integral nDpi) + => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas +simpleMetadata f w h dpiX dpiY = + Metadatas [ Format :=> f + , Width :=> fromIntegral w + , Height :=> fromIntegral h + , DpiX :=> fromIntegral dpiX + , DpiY :=> fromIntegral dpiY + ] + diff --git a/src/Codec/Picture/Metadata/Exif.hs b/src/Codec/Picture/Metadata/Exif.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Metadata/Exif.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | This module provide a totally partial and incomplete maping +-- of Exif values. Used for Tiff parsing and reused for Exif extraction. +module Codec.Picture.Metadata.Exif ( ExifTag( .. ) + , ExifData( .. ) + + , tagOfWord16 + , word16OfTag + + , isInIFD0 + ) where + +import Control.DeepSeq( NFData( .. ) ) +import Data.Int( Int32 ) +import Data.Word( Word16, Word32 ) +import qualified Data.Vector as V +import qualified Data.ByteString as B +import GHC.Generics( Generic ) + +-- | Tag values used for exif fields. Completly incomplete +data ExifTag + = TagPhotometricInterpretation + | TagCompression -- ^ Short type + | TagImageWidth -- ^ Short or long type + | TagImageLength -- ^ Short or long type + | TagXResolution -- ^ Rational type + | TagYResolution -- ^ Rational type + | TagResolutionUnit -- ^ Short type + | TagRowPerStrip -- ^ Short or long type + | TagStripByteCounts -- ^ Short or long + | TagStripOffsets -- ^ Short or long + | TagBitsPerSample -- ^ Short + | TagColorMap -- ^ Short + | TagTileWidth + | TagTileLength + | TagTileOffset + | TagTileByteCount + | TagSamplesPerPixel -- ^ Short + | TagArtist + | TagDocumentName + | TagSoftware + | TagPlanarConfiguration -- ^ Short + | TagOrientation + | TagSampleFormat -- ^ Short + | TagInkSet + | TagSubfileType + | TagFillOrder + | TagYCbCrCoeff + | TagYCbCrSubsampling + | TagYCbCrPositioning + | TagReferenceBlackWhite + | TagXPosition + | TagYPosition + | TagExtraSample + | TagImageDescription + | TagPredictor + | TagCopyright + | TagMake + | TagModel + | TagDateTime + | TagGPSInfo + | TagLightSource -- ^ Short + | TagFlash -- ^ Short + + | TagJpegProc + | TagJPEGInterchangeFormat + | TagJPEGInterchangeFormatLength + | TagJPEGRestartInterval + | TagJPEGLosslessPredictors + | TagJPEGPointTransforms + | TagJPEGQTables + | TagJPEGDCTables + | TagJPEGACTables + + | TagExifOffset + | TagUnknown !Word16 + deriving (Eq, Ord, Show, Generic) +instance NFData ExifTag + +-- | Convert a value to it's corresponding Exif tag. +-- Will often be written as 'TagUnknown' +tagOfWord16 :: Word16 -> ExifTag +tagOfWord16 v = case v of + 255 -> TagSubfileType + 256 -> TagImageWidth + 257 -> TagImageLength + 258 -> TagBitsPerSample + 259 -> TagCompression + 262 -> TagPhotometricInterpretation + 266 -> TagFillOrder + 269 -> TagDocumentName + 270 -> TagImageDescription + 271 -> TagMake + 272 -> TagModel + 273 -> TagStripOffsets + 274 -> TagOrientation + 277 -> TagSamplesPerPixel + 278 -> TagRowPerStrip + 279 -> TagStripByteCounts + 282 -> TagXResolution + 283 -> TagYResolution + 284 -> TagPlanarConfiguration + 286 -> TagXPosition + 287 -> TagYPosition + 296 -> TagResolutionUnit + 305 -> TagSoftware + 306 -> TagDateTime + 315 -> TagArtist + 317 -> TagPredictor + 320 -> TagColorMap + 322 -> TagTileWidth + 323 -> TagTileLength + 324 -> TagTileOffset + 325 -> TagTileByteCount + 332 -> TagInkSet + 338 -> TagExtraSample + 339 -> TagSampleFormat + 529 -> TagYCbCrCoeff + 512 -> TagJpegProc + 513 -> TagJPEGInterchangeFormat + 514 -> TagJPEGInterchangeFormatLength + 515 -> TagJPEGRestartInterval + 517 -> TagJPEGLosslessPredictors + 518 -> TagJPEGPointTransforms + 519 -> TagJPEGQTables + 520 -> TagJPEGDCTables + 521 -> TagJPEGACTables + 530 -> TagYCbCrSubsampling + 531 -> TagYCbCrPositioning + 532 -> TagReferenceBlackWhite + 33432 -> TagCopyright + 34665 -> TagExifOffset + 34853 -> TagGPSInfo + 37384 -> TagLightSource + 37385 -> TagFlash + vv -> TagUnknown vv + +-- | Convert a tag to it's corresponding value. +word16OfTag :: ExifTag -> Word16 +word16OfTag t = case t of + TagSubfileType -> 255 + TagImageWidth -> 256 + TagImageLength -> 257 + TagBitsPerSample -> 258 + TagCompression -> 259 + TagPhotometricInterpretation -> 262 + TagFillOrder -> 266 + TagDocumentName -> 269 + TagImageDescription -> 270 + TagMake -> 271 + TagModel -> 272 + TagStripOffsets -> 273 + TagOrientation -> 274 + TagSamplesPerPixel -> 277 + TagRowPerStrip -> 278 + TagStripByteCounts -> 279 + TagXResolution -> 282 + TagYResolution -> 283 + TagPlanarConfiguration -> 284 + TagXPosition -> 286 + TagYPosition -> 287 + TagResolutionUnit -> 296 + TagSoftware -> 305 + TagDateTime -> 306 + TagArtist -> 315 + TagPredictor -> 317 + TagColorMap -> 320 + TagTileWidth -> 322 + TagTileLength -> 323 + TagTileOffset -> 324 + TagTileByteCount -> 325 + TagInkSet -> 332 + TagExtraSample -> 338 + TagSampleFormat -> 339 + TagYCbCrCoeff -> 529 + TagJpegProc -> 512 + TagJPEGInterchangeFormat -> 513 + TagJPEGInterchangeFormatLength -> 514 + TagJPEGRestartInterval -> 515 + TagJPEGLosslessPredictors -> 517 + TagJPEGPointTransforms -> 518 + TagJPEGQTables -> 519 + TagJPEGDCTables -> 520 + TagJPEGACTables -> 521 + TagYCbCrSubsampling -> 530 + TagYCbCrPositioning -> 531 + TagReferenceBlackWhite -> 532 + TagCopyright -> 33432 + TagExifOffset -> 34665 + TagGPSInfo -> 34853 + TagLightSource -> 37384 + TagFlash -> 37385 + (TagUnknown v) -> v + +isInIFD0 :: ExifTag -> Bool +isInIFD0 t = word16OfTag t <= lastTag || isRedirectTag where + lastTag = word16OfTag TagCopyright + isRedirectTag = t `elem` [TagExifOffset, TagGPSInfo] + +-- | Possible data held by an Exif tag +data ExifData + = ExifNone + | ExifLong !Word32 + | ExifShort !Word16 + | ExifString !B.ByteString + | ExifUndefined !B.ByteString + | ExifShorts !(V.Vector Word16) + | ExifLongs !(V.Vector Word32) + | ExifRational !Word32 !Word32 + | ExifSignedRational !Int32 !Int32 + | ExifIFD ![(ExifTag, ExifData)] + deriving (Eq, Show, Generic) +instance NFData ExifData diff --git a/src/Codec/Picture/Png.hs b/src/Codec/Picture/Png.hs --- a/src/Codec/Picture/Png.hs +++ b/src/Codec/Picture/Png.hs @@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) -- files. -- @@ -16,19 +17,30 @@ -- -- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html) module Codec.Picture.Png( -- * High level functions - PngSavable( .. ) + PngSavable( .. ), + PngPaletteSaveable( .. ) , decodePng + , decodePngWithMetadata + , decodePngWithPaletteAndMetadata + , writePng - , encodePalettedPng , encodeDynamicPng , writeDynamicPng - ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) -import Control.Monad( forM_, foldM_, when ) +#endif + +import Control.Arrow( first ) +import Control.Monad( forM_, foldM_, when, void ) import Control.Monad.ST( ST, runST ) + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif + import Data.Binary( Binary( get) ) import qualified Data.Vector.Storable as V @@ -43,8 +55,10 @@ import Foreign.Storable ( Storable ) import Codec.Picture.Types -import Codec.Picture.Png.Type -import Codec.Picture.Png.Export +import Codec.Picture.Metadata +import Codec.Picture.Png.Internal.Type +import Codec.Picture.Png.Internal.Export +import Codec.Picture.Png.Internal.Metadata import Codec.Picture.InternalHelper -- | Simple structure used to hold information about Adam7 deinterlacing. @@ -151,7 +165,7 @@ b' = fromIntegral valB average = fromIntegral ((a' + b') `div` (2 :: Word16)) writeVal = byte + average - (thisLine `M.unsafeWrite` idx) $ writeVal + (thisLine `M.unsafeWrite` idx) writeVal inner (idx + 1) $ readIdx + 1 filterPaeth !previousLine !thisLine = inner beginZeroes @@ -297,7 +311,7 @@ lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1) let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8) writeIdx = destSampleIndex + sample - (arr `M.unsafeWrite` writeIdx) $ fullValue + (arr `M.unsafeWrite` writeIdx) fullValue -- | Transform a scanline to a bunch of bytes. Bytes are then packed -- into pixels at a further step. @@ -317,7 +331,7 @@ -> B.ByteString -> ST s () scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str = - pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 >> return () + void $ pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth strideInfo | depth < 8 = 1 | otherwise = sampleCount * (depth `div` 8) @@ -327,7 +341,7 @@ adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) -> B.ByteString -> ST s () adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str = - foldM_ (\i f -> f i) 0 subImages >> return () + void $ foldM_ (\i f -> f i) 0 subImages where Adam7MatrixInfo { adam7StartingRow = startRows , adam7RowIncrement = rowIncrement , adam7StartingCol = startCols @@ -352,8 +366,8 @@ deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16)) deinterlacer (PngIHdr { width = w, height = h, colourType = imgKind , interlaceMethod = method, bitDepth = depth }) str = do - let compCount = sampleCountOfImageType imgKind - arraySize = fromIntegral $ w * h * compCount + let compCount = fromIntegral $ sampleCountOfImageType imgKind + arraySize = (fromIntegral w) * (fromIntegral h) * compCount deinterlaceFunction = case method of PngNoInterlace -> scanLineInterleaving PngInterlaceAdam7 -> adam7Unpack @@ -363,10 +377,9 @@ imgArray <- M.new arraySize let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray deinterlaceFunction iBitDepth - (fromIntegral compCount) + compCount (fromIntegral w, fromIntegral h) - (scanlineUnpacker8 iBitDepth (fromIntegral compCount) - mutableImage) + (scanlineUnpacker8 iBitDepth compCount mutableImage) str Left <$> V.unsafeFreeze imgArray @@ -374,14 +387,14 @@ imgArray <- M.new arraySize let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray deinterlaceFunction iBitDepth - (fromIntegral compCount) + compCount (fromIntegral w, fromIntegral h) - (shortUnpacker (fromIntegral compCount) mutableImage) + (shortUnpacker compCount mutableImage) str Right <$> V.unsafeFreeze imgArray generateGreyscalePalette :: Word8 -> PngPalette -generateGreyscalePalette bits = Image (maxValue+1) 1 vec +generateGreyscalePalette bits = Palette' (maxValue+1) vec where maxValue = 2 ^ bits - 1 vec = V.fromListN ((fromIntegral maxValue + 1) * 3) $ concat pixels pixels = [[i, i, i] | n <- [0 .. maxValue] @@ -399,113 +412,125 @@ paletteRGB2 = generateGreyscalePalette 2 paletteRGB4 = generateGreyscalePalette 4 -{-# INLINE bounds #-} -bounds :: Storable a => V.Vector a -> (Int, Int) -bounds v = (0, V.length v - 1) +addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8 +addTransparencyToPalette pal transpBuffer = + Palette' (_paletteSize pal) . imageData . pixelMapXY addOpacity $ palettedAsImage pal + where + maxi = fromIntegral $ Lb.length transpBuffer + addOpacity ix _ (PixelRGB8 r g b) | ix < maxi = + PixelRGBA8 r g b $ Lb.index transpBuffer (fromIntegral ix) + addOpacity _ _ (PixelRGB8 r g b) = PixelRGBA8 r g b 255 -applyPalette :: PngPalette -> V.Vector Word8 -> V.Vector Word8 -applyPalette pal img = V.fromListN ((initSize + 1) * 3) pixels - where (_, initSize) = bounds img - pixels = concat [[r, g, b] | ipx <- V.toList img - , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] +unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType + -> B.ByteString -> Either String PalettedImage +unparse ihdr _ t PngGreyscale bytes + | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes + | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes + | bitDepth ihdr == 4 = unparse ihdr (Just paletteRGB4) t PngIndexedColor bytes + | otherwise = + fmap TrueColorImage . toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes -applyPaletteWithTransparency :: PngPalette -> Lb.ByteString -> V.Vector Word8 - -> V.Vector Word8 -applyPaletteWithTransparency pal transpBuffer img = V.fromListN ((initSize + 1) * 4) pixels - where (_, initSize) = bounds img - maxi = Lb.length transpBuffer - pixels = concat - [ [r, g, b, opacity] - | ipx <- V.toList img - , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0 - opacity | fromIntegral ipx < maxi = Lb.index transpBuffer $ fromIntegral ipx - | otherwise = 255] +unparse _ Nothing _ PngIndexedColor _ = Left "no valid palette found" +unparse ihdr _ _ PngTrueColour bytes = + fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes +unparse ihdr _ _ PngGreyscaleWithAlpha bytes = + fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes +unparse ihdr _ _ PngTrueColourWithAlpha bytes = + fmap TrueColorImage . toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes +unparse ihdr (Just plte) transparency PngIndexedColor bytes = + palette8 ihdr plte transparency $ runST $ deinterlacer ihdr bytes +toImage :: forall a pxWord8 pxWord16 + . PngIHdr + -> (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage) + -> Either (V.Vector (PixelBaseComponent pxWord8)) + (V.Vector (PixelBaseComponent pxWord16)) + -> Either a DynamicImage +toImage hdr const1 const2 lr = Right $ case lr of + Left a -> const1 $ Image w h a + Right a -> const2 $ Image w h a + where + w = fromIntegral $ width hdr + h = fromIntegral $ height hdr + +palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t + -> Either String PalettedImage +palette8 hdr palette transparency eimg = case (transparency, eimg) of + ([c], Left img) -> + Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c + (_, Left img) -> + return $ PalettedRGB8 (Image w h img) palette + (_, Right _) -> + Left "Invalid bit depth for paleted image" + where + w = fromIntegral $ width hdr + h = fromIntegral $ height hdr + + -- | Transform a raw png image to an image, without modifying the -- underlying pixel type. If the image is greyscale and < 8 bits, -- a transformation to RGBA8 is performed. This should change -- in the future. -- The resulting image let you manage the pixel types. -- --- This function can output the following pixel types: +-- This function can output the following images: -- --- * PixelY8 +-- * 'ImageY8' -- --- * PixelY16 +-- * 'ImageY16' -- --- * PixelYA8 +-- * 'ImageYA8' -- --- * PixelYA16 +-- * 'ImageYA16' -- --- * PixelRGB8 +-- * 'ImageRGB8' -- --- * PixelRGB16 +-- * 'ImageRGB16' -- --- * PixelRGBA8 +-- * 'ImageRGBA8' -- --- * PixelRGBA16 +-- * 'ImageRGBA16' -- decodePng :: B.ByteString -> Either String DynamicImage -decodePng byte = do - rawImg <- runGetStrict get byte - let ihdr@(PngIHdr { width = w, height = h }) = header rawImg - compressedImageData = - Lb.concat [chunkData chunk | chunk <- chunks rawImg - , chunkType chunk == iDATSignature] - zlibHeaderSize = 1 {- compression method/flags code -} - + 1 {- Additional flags/check bits -} - + 4 {-CRC-} +decodePng = fmap fst . decodePngWithMetadata - palette8 palette [c] (Left img) = - Right . ImageRGBA8 - . Image (fromIntegral w) (fromIntegral h) - $ applyPaletteWithTransparency palette c img +-- | Decode a PNG file with, possibly, separated palette. +decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodePngWithMetadata b = first palettedToTrueColor <$> decodePngWithPaletteAndMetadata b - palette8 palette _ (Left img) = - Right . ImageRGB8 - . Image (fromIntegral w) (fromIntegral h) - $ applyPalette palette img +-- | Same as 'decodePng' but also extract meta datas present +-- in the files. +decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodePngWithPaletteAndMetadata byte = do + rawImg <- runGetStrict get byte + let ihdr = header rawImg + metadatas = + basicMetadata SourcePng (width ihdr) (height ihdr) <> extractMetadatas rawImg + compressedImageData = + Lb.concat [chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == iDATSignature] + zlibHeaderSize = 1 {- compression method/flags code -} + + 1 {- Additional flags/check bits -} + + 4 {-CRC-} - palette8 _ _ (Right _) = Left "Invalid bit depth for paleted image" + transparencyColor = + [ chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == tRNSSignature ] - toImage :: forall a pxWord8 pxWord16 - . (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage) - -> Either (V.Vector (PixelBaseComponent pxWord8)) - (V.Vector (PixelBaseComponent pxWord16)) - -> Either a DynamicImage - toImage const1 _const2 (Left a) = - Right . const1 $ Image (fromIntegral w) (fromIntegral h) a - toImage _const1 const2 (Right a) = - Right . const2 $ Image (fromIntegral w) (fromIntegral h) a - transparencyColor = - [ chunkData chunk | chunk <- chunks rawImg - , chunkType chunk == tRNSSignature ] - - unparse _ t PngGreyscale bytes - | bitDepth ihdr == 1 = unparse (Just paletteRGB1) t PngIndexedColor bytes - | bitDepth ihdr == 2 = unparse (Just paletteRGB2) t PngIndexedColor bytes - | bitDepth ihdr == 4 = unparse (Just paletteRGB4) t PngIndexedColor bytes - | otherwise = toImage ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes - - unparse Nothing _ PngIndexedColor _ = Left "no valid palette found" - unparse _ _ PngTrueColour bytes = - toImage ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes - unparse _ _ PngGreyscaleWithAlpha bytes = - toImage ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes - unparse _ _ PngTrueColourWithAlpha bytes = - toImage ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes - unparse (Just plte) transparency PngIndexedColor bytes = - palette8 plte transparency $ runST $ deinterlacer ihdr bytes + if Lb.length compressedImageData <= zlibHeaderSize then + Left "Invalid data size" + else + let imgData = Z.decompress compressedImageData + parseableData = B.concat $ Lb.toChunks imgData + palette = do + p <- find (\c -> pLTESignature == chunkType c) $ chunks rawImg + case parsePalette p of + Left _ -> Nothing + Right plte -> return plte + in + (, metadatas) <$> + unparse ihdr palette transparencyColor (colourType ihdr) parseableData - if Lb.length compressedImageData <= zlibHeaderSize - then Left "Invalid data size" - else let imgData = Z.decompress compressedImageData - parseableData = B.concat $ Lb.toChunks imgData - palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of - Nothing -> Nothing - Just p -> case parsePalette p of - Left _ -> Nothing - Right plte -> Just plte - in unparse palette transparencyColor (colourType ihdr) parseableData +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/Png/Export.hs b/src/Codec/Picture/Png/Export.hs deleted file mode 100644 --- a/src/Codec/Picture/Png/Export.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Module implementing a basic png export, no filtering is applyed, but --- export at least valid images. -module Codec.Picture.Png.Export( PngSavable( .. ) - , writePng - , encodeDynamicPng - , writeDynamicPng - , encodePalettedPng - ) where - -import Control.Monad( forM_ ) -import Control.Monad.ST( ST, runST ) -import Data.Bits( unsafeShiftR, (.&.) ) -import Data.Binary( encode ) -import Data.Word(Word8, Word16) -import qualified Codec.Compression.Zlib as Z -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as Lb - -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Types -import Codec.Picture.Png.Type -import Codec.Picture.VectorByteConversion( blitVector, toByteString ) - --- | Encode an image into a png if possible. -class PngSavable a where - -- | Transform an image into a png encoded bytestring, ready - -- to be written as a file. - encodePng :: Image a -> Lb.ByteString - -preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr -preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr - { width = fromIntegral w - , height = fromIntegral h - , bitDepth = depth - , colourType = imgType - , compressionMethod = 0 - , filterMethod = 0 - , interlaceMethod = PngNoInterlace - } - --- | Helper function to directly write an image as a png on disk. -writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () -writePng path img = Lb.writeFile path $ encodePng img - -endChunk :: PngRawChunk -endChunk = PngRawChunk { chunkLength = 0 - , chunkType = iENDSignature - , chunkCRC = pngComputeCrc [iENDSignature] - , chunkData = Lb.empty - } - - -prepareIDatChunk :: Lb.ByteString -> PngRawChunk -prepareIDatChunk imgData = PngRawChunk - { chunkLength = fromIntegral $ Lb.length imgData - , chunkType = iDATSignature - , chunkCRC = pngComputeCrc [iDATSignature, imgData] - , chunkData = imgData - } - -genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16) - => PngImageType -> Image px -> Lb.ByteString -genericEncode16BitsPng imgKind - image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = - encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]} - where hdr = preparePngHeader image imgKind 16 - zero = B.singleton 0 - compCount = componentCount (undefined :: px) - - lineSize = compCount * w - blitToByteString vec = blitVector vec 0 (lineSize * 2) - encodeLine line = blitToByteString $ runST $ do - finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8) - let baseIndex = line * lineSize - forM_ [0 .. lineSize - 1] $ \ix -> do - let v = arr `VS.unsafeIndex` (baseIndex + ix) - high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF - low = fromIntegral $ v .&. 0xFF - - (finalVec `M.unsafeWrite` (ix * 2 + 0)) high - (finalVec `M.unsafeWrite` (ix * 2 + 1)) low - - VS.unsafeFreeze finalVec - - imgEncodedData = Z.compress . Lb.fromChunks - $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] - -preparePalette :: Palette -> PngRawChunk -preparePalette pal = PngRawChunk - { chunkLength = fromIntegral $ imageWidth pal * 3 - , chunkType = pLTESignature - , chunkCRC = pngComputeCrc [pLTESignature, binaryData] - , chunkData = binaryData - } - where binaryData = Lb.fromChunks [toByteString $ imageData pal] - -genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8) - => Maybe Palette -> PngImageType -> Image px - -> Lb.ByteString -genericEncodePng palette imgKind - image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = - encode PngRawImage { header = hdr - , chunks = prependPalette palette [prepareIDatChunk imgEncodedData, endChunk]} - where hdr = preparePngHeader image imgKind 8 - zero = B.singleton 0 - compCount = componentCount (undefined :: px) - - prependPalette Nothing l = l - prependPalette (Just p) l = preparePalette p : l - - lineSize = compCount * w - encodeLine line = blitVector arr (line * lineSize) lineSize - imgEncodedData = Z.compress . Lb.fromChunks - $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] - -instance PngSavable PixelRGBA8 where - encodePng = genericEncodePng Nothing PngTrueColourWithAlpha - -instance PngSavable PixelRGB8 where - encodePng = genericEncodePng Nothing PngTrueColour - -instance PngSavable Pixel8 where - encodePng = genericEncodePng Nothing PngGreyscale - -instance PngSavable PixelYA8 where - encodePng = genericEncodePng Nothing PngGreyscaleWithAlpha - -instance PngSavable PixelYA16 where - encodePng = genericEncode16BitsPng PngGreyscaleWithAlpha - -instance PngSavable Pixel16 where - encodePng = genericEncode16BitsPng PngGreyscale - -instance PngSavable PixelRGB16 where - encodePng = genericEncode16BitsPng PngTrueColour - -instance PngSavable PixelRGBA16 where - encodePng = genericEncode16BitsPng PngTrueColourWithAlpha - --- | Write a dynamic image in a .png image file if possible. --- The same restriction as encodeDynamicPng apply. -writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) -writeDynamicPng path img = case encodeDynamicPng img of - Left err -> return $ Left err - Right b -> Lb.writeFile path b >> return (Right True) - --- | Encode a paletted image as a color indexed 8-bit PNG. --- the palette must have between 1 and 256 values in it. -encodePalettedPng :: Palette -> Image Pixel8 -> Either String Lb.ByteString -encodePalettedPng pal img - | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" - | VS.any isTooBig $ imageData img = - Left "Image contains indexes absent from the palette" - | otherwise = Right $ genericEncodePng (Just pal) PngIndexedColor img - where w = imageWidth pal - h = imageHeight pal - isTooBig v = fromIntegral v >= w - --- | Encode a dynamic image in bmp if possible, supported pixel type are : --- --- - Y8 --- --- - Y16 --- --- - YA8 --- --- - YA16 --- --- - RGB8 --- --- - RGB16 --- --- - RGBA8 --- --- - RGBA16 --- -encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString -encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img -encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img -encodeDynamicPng (ImageY8 img) = Right $ encodePng img -encodeDynamicPng (ImageY16 img) = Right $ encodePng img -encodeDynamicPng (ImageYA8 img) = Right $ encodePng img -encodeDynamicPng (ImageYA16 img) = Right $ encodePng img -encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img -encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img -encodeDynamicPng _ = Left "Unsupported image format for PNG export" diff --git a/src/Codec/Picture/Png/Internal/Export.hs b/src/Codec/Picture/Png/Internal/Export.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png/Internal/Export.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module implementing a basic png export, no filtering is applyed, but +-- export at least valid images. +module Codec.Picture.Png.Internal.Export( PngSavable( .. ) + , PngPaletteSaveable( .. ) + , writePng + , encodeDynamicPng + , writeDynamicPng + ) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +#endif + +import Control.Monad( forM_ ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( unsafeShiftR, (.&.) ) +import Data.Binary( encode ) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif +import Data.Word(Word8, Word16) +import qualified Codec.Compression.Zlib as Z +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb + +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Types +import Codec.Picture.Png.Internal.Type +import Codec.Picture.Png.Internal.Metadata +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.VectorByteConversion( blitVector, toByteString ) + +-- | Encode a paletted image into a png if possible. +class PngPaletteSaveable a where + -- | Encode a paletted image as a color indexed 8-bit PNG. + -- the palette must have between 1 and 256 values in it. + -- Accepts `PixelRGB8` and `PixelRGBA8` as palette pixel type + encodePalettedPng :: Image a -> Image Pixel8 -> Either String Lb.ByteString + encodePalettedPng = encodePalettedPngWithMetadata mempty + + -- | Equivalent to 'encodePalettedPng' but allow writing of metadatas. + -- See `encodePngWithMetadata` for the details of encoded metadatas + -- Accepts `PixelRGB8` and `PixelRGBA8` as palette pixel type + encodePalettedPngWithMetadata :: Metadatas -> Image a -> Image Pixel8 -> Either String Lb.ByteString + +instance PngPaletteSaveable PixelRGB8 where + encodePalettedPngWithMetadata metas pal img + | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" + | VS.any isTooBig $ imageData img = + Left "Image contains indexes absent from the palette" + | otherwise = Right $ genericEncodePng (Just pal) Nothing PngIndexedColor metas img + where w = imageWidth pal + h = imageHeight pal + isTooBig v = fromIntegral v >= w + +instance PngPaletteSaveable PixelRGBA8 where + encodePalettedPngWithMetadata metas pal img + | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" + | VS.any isTooBig $ imageData img = + Left "Image contains indexes absent from the palette" + | otherwise = Right $ genericEncodePng (Just opaquePalette) (Just alphaPal) PngIndexedColor metas img + where + w = imageWidth pal + h = imageHeight pal + opaquePalette = dropAlphaLayer pal + alphaPal = imageData $ extractComponent PlaneAlpha pal + isTooBig v = fromIntegral v >= w + +-- | Encode an image into a png if possible. +class PngSavable a where + -- | Transform an image into a png encoded bytestring, ready + -- to be written as a file. + encodePng :: Image a -> Lb.ByteString + encodePng = encodePngWithMetadata mempty + + -- | Encode a png using some metadatas. The following metadata keys will + -- be stored in a `tEXt` field : + -- + -- * 'Codec.Picture.Metadata.Title' + -- * 'Codec.Picture.Metadata.Description' + -- * 'Codec.Picture.Metadata.Author' + -- * 'Codec.Picture.Metadata.Copyright' + -- * 'Codec.Picture.Metadata.Software' + -- * 'Codec.Picture.Metadata.Comment' + -- * 'Codec.Picture.Metadata.Disclaimer' + -- * 'Codec.Picture.Metadata.Source' + -- * 'Codec.Picture.Metadata.Warning' + -- * 'Codec.Picture.Metadata.Unknown' using the key present in the constructor. + -- + -- the followings metadata will be stored in the `gAMA` chunk. + -- + -- * 'Codec.Picture.Metadata.Gamma' + -- + -- The followings metadata will be stored in a `pHYs` chunk + -- + -- * 'Codec.Picture.Metadata.DpiX' + -- * 'Codec.Picture.Metadata.DpiY' + encodePngWithMetadata :: Metadatas -> Image a -> Lb.ByteString + +preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr +preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr + { width = fromIntegral w + , height = fromIntegral h + , bitDepth = depth + , colourType = imgType + , compressionMethod = 0 + , filterMethod = 0 + , interlaceMethod = PngNoInterlace + } + +-- | Helper function to directly write an image as a png on disk. +writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () +writePng path img = Lb.writeFile path $ encodePng img + +endChunk :: PngRawChunk +endChunk = mkRawChunk iENDSignature mempty + +prepareIDatChunk :: Lb.ByteString -> PngRawChunk +prepareIDatChunk = mkRawChunk iDATSignature + +genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16) + => PngImageType -> Metadatas -> Image px -> Lb.ByteString +genericEncode16BitsPng imgKind metas + image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = + encode PngRawImage { header = hdr + , chunks = encodeMetadatas metas + <> [ prepareIDatChunk imgEncodedData + , endChunk + ] + } + where hdr = preparePngHeader image imgKind 16 + zero = B.singleton 0 + compCount = componentCount (undefined :: px) + + lineSize = compCount * w + blitToByteString vec = blitVector vec 0 (lineSize * 2) + encodeLine line = blitToByteString $ runST $ do + finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8) + let baseIndex = line * lineSize + forM_ [0 .. lineSize - 1] $ \ix -> do + let v = arr `VS.unsafeIndex` (baseIndex + ix) + high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF + low = fromIntegral $ v .&. 0xFF + + (finalVec `M.unsafeWrite` (ix * 2 + 0)) high + (finalVec `M.unsafeWrite` (ix * 2 + 1)) low + + VS.unsafeFreeze finalVec + + imgEncodedData = Z.compress . Lb.fromChunks + $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] + +preparePalette :: Palette -> PngRawChunk +preparePalette pal = PngRawChunk + { chunkLength = fromIntegral $ imageWidth pal * 3 + , chunkType = pLTESignature + , chunkCRC = pngComputeCrc [pLTESignature, binaryData] + , chunkData = binaryData + } + where binaryData = Lb.fromChunks [toByteString $ imageData pal] + +preparePaletteAlpha :: VS.Vector Pixel8 -> PngRawChunk +preparePaletteAlpha alphaPal = PngRawChunk + { chunkLength = fromIntegral $ VS.length alphaPal + , chunkType = tRNSSignature + , chunkCRC = pngComputeCrc [tRNSSignature, binaryData] + , chunkData = binaryData + } + where binaryData = Lb.fromChunks [toByteString alphaPal] + +type PaletteAlpha = VS.Vector Pixel8 + +genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8) + => Maybe Palette + -> Maybe PaletteAlpha + -> PngImageType -> Metadatas -> Image px + -> Lb.ByteString +genericEncodePng palette palAlpha imgKind metas + image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = + encode PngRawImage { header = hdr + , chunks = encodeMetadatas metas + <> paletteChunk + <> transpChunk + <> [ prepareIDatChunk imgEncodedData + , endChunk + ]} + where + hdr = preparePngHeader image imgKind 8 + zero = B.singleton 0 + compCount = componentCount (undefined :: px) + + paletteChunk = case palette of + Nothing -> [] + Just p -> [preparePalette p] + + transpChunk = case palAlpha of + Nothing -> [] + Just p -> [preparePaletteAlpha p] + + lineSize = compCount * w + encodeLine line = blitVector arr (line * lineSize) lineSize + imgEncodedData = Z.compress + . Lb.fromChunks + $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] + +instance PngSavable PixelRGBA8 where + encodePngWithMetadata = genericEncodePng Nothing Nothing PngTrueColourWithAlpha + +instance PngSavable PixelRGB8 where + encodePngWithMetadata = genericEncodePng Nothing Nothing PngTrueColour + +instance PngSavable Pixel8 where + encodePngWithMetadata = genericEncodePng Nothing Nothing PngGreyscale + +instance PngSavable PixelYA8 where + encodePngWithMetadata = genericEncodePng Nothing Nothing PngGreyscaleWithAlpha + +instance PngSavable PixelYA16 where + encodePngWithMetadata = genericEncode16BitsPng PngGreyscaleWithAlpha + +instance PngSavable Pixel16 where + encodePngWithMetadata = genericEncode16BitsPng PngGreyscale + +instance PngSavable PixelRGB16 where + encodePngWithMetadata = genericEncode16BitsPng PngTrueColour + +instance PngSavable PixelRGBA16 where + encodePngWithMetadata = genericEncode16BitsPng PngTrueColourWithAlpha + +-- | Write a dynamic image in a .png image file if possible. +-- The same restriction as encodeDynamicPng apply. +writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) +writeDynamicPng path img = case encodeDynamicPng img of + Left err -> return $ Left err + Right b -> Lb.writeFile path b >> return (Right True) + +-- | Encode a dynamic image in PNG if possible, supported images are: +-- +-- * 'ImageY8' +-- +-- * 'ImageY16' +-- +-- * 'ImageYA8' +-- +-- * 'ImageYA16' +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGB16' +-- +-- * 'ImageRGBA8' +-- +-- * 'ImageRGBA16' +-- +encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString +encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img +encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img +encodeDynamicPng (ImageY8 img) = Right $ encodePng img +encodeDynamicPng (ImageY16 img) = Right $ encodePng img +encodeDynamicPng (ImageYA8 img) = Right $ encodePng img +encodeDynamicPng (ImageYA16 img) = Right $ encodePng img +encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img +encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img +encodeDynamicPng _ = Left "Unsupported image format for PNG export" diff --git a/src/Codec/Picture/Png/Internal/Metadata.hs b/src/Codec/Picture/Png/Internal/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png/Internal/Metadata.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module Codec.Picture.Png.Internal.Metadata( extractMetadatas + , encodeMetadatas + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Monoid( Monoid, mempty ) +import Data.Foldable( foldMap ) +#endif + +import Data.Maybe( fromMaybe ) +import Data.Binary( Binary( get, put ), encode ) +import Data.Binary.Get( getLazyByteStringNul, getWord8 ) +import Data.Binary.Put( putLazyByteString, putWord8 ) +import qualified Data.ByteString.Lazy.Char8 as L +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif + +import qualified Codec.Compression.Zlib as Z + +import Codec.Picture.InternalHelper +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata ( Metadatas + , dotsPerMeterToDotPerInch + , Elem( (:=>) ) ) +import Codec.Picture.Png.Internal.Type + +#if !MIN_VERSION_base(4,7,0) +eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m +eitherFoldMap f v = case v of + Left _ -> mempty + Right a -> f a +#else +eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m +eitherFoldMap = foldMap +#endif + +getGamma :: [L.ByteString] -> Metadatas +getGamma [] = mempty +getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g + where + unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma) + +getDpis :: [L.ByteString] -> Metadatas +getDpis [] = mempty +getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b + where + unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } = + Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72 + unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } = + Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy + where + dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy + dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy + +data PngText = PngText + { pngKeyword :: !L.ByteString + , pngData :: !L.ByteString + } + deriving Show + +instance Binary PngText where + get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes + put (PngText kw pdata) = do + putLazyByteString kw + putWord8 0 + putLazyByteString pdata + +data PngZText = PngZText + { pngZKeyword :: !L.ByteString + , pngZData :: !L.ByteString + } + deriving Show + +instance Binary PngZText where + get = PngZText <$> getLazyByteStringNul <* getCompressionType <*> (Z.decompress <$> getRemainingLazyBytes) + where + getCompressionType = do + 0 <- getWord8 + return () + put (PngZText kw pdata) = do + putLazyByteString kw + putWord8 0 + putWord8 0 -- compression type + putLazyByteString (Z.compress pdata) + +aToMetadata :: (a -> L.ByteString) -> (a -> L.ByteString) -> a -> Metadatas +aToMetadata pkeyword pdata ptext = case pkeyword ptext of + "Title" -> strValue Met.Title + "Author" -> strValue Met.Author + "Description" -> strValue Met.Description + "Copyright" -> strValue Met.Copyright + {-"Creation Time" -> strValue Creation-} + "Software" -> strValue Met.Software + "Disclaimer" -> strValue Met.Disclaimer + "Warning" -> strValue Met.Warning + "Source" -> strValue Met.Source + "Comment" -> strValue Met.Comment + other -> + Met.singleton + (Met.Unknown $ L.unpack other) + (Met.String . L.unpack $ pdata ptext) + where + strValue k = Met.singleton k . L.unpack $ pdata ptext + +textToMetadata :: PngText -> Metadatas +textToMetadata = aToMetadata pngKeyword pngData + +ztxtToMetadata :: PngZText -> Metadatas +ztxtToMetadata = aToMetadata pngZKeyword pngZData + +getTexts :: [L.ByteString] -> Metadatas +getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) + +getZTexts :: [L.ByteString] -> Metadatas +getZTexts = foldMap (eitherFoldMap ztxtToMetadata . runGet get) + +extractMetadatas :: PngRawImage -> Metadatas +extractMetadatas img = getDpis (chunksOf pHYsSignature) + <> getGamma (chunksOf gammaSignature) + <> getTexts (chunksOf tEXtSignature) + <> getZTexts (chunksOf zTXtSignature) + where + chunksOf = chunksWithSig img + +encodePhysicalMetadata :: Metadatas -> [PngRawChunk] +encodePhysicalMetadata metas = fromMaybe [] $ do + dx <- Met.lookup Met.DpiX metas + dy <- Met.lookup Met.DpiY metas + let to = fromIntegral . Met.dotPerInchToDotsPerMeter + dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter + pure [mkRawChunk pHYsSignature $ encode dim] + +encodeSingleMetadata :: Metadatas -> [PngRawChunk] +encodeSingleMetadata = Met.foldMap go where + go :: Elem Met.Keys -> [PngRawChunk] + go v = case v of + Met.Exif _ :=> _ -> mempty + Met.DpiX :=> _ -> mempty + Met.DpiY :=> _ -> mempty + Met.Width :=> _ -> mempty + Met.Height :=> _ -> mempty + Met.Format :=> _ -> mempty + Met.Gamma :=> g -> + pure $ mkRawChunk gammaSignature . encode $ PngGamma g + Met.ColorSpace :=> _ -> mempty + Met.Title :=> tx -> txt "Title" (L.pack tx) + Met.Description :=> tx -> txt "Description" (L.pack tx) + Met.Author :=> tx -> txt "Author" (L.pack tx) + Met.Copyright :=> tx -> txt "Copyright" (L.pack tx) + Met.Software :=> tx -> txt "Software" (L.pack tx) + Met.Comment :=> tx -> txt "Comment" (L.pack tx) + Met.Disclaimer :=> tx -> txt "Disclaimer" (L.pack tx) + Met.Source :=> tx -> txt "Source" (L.pack tx) + Met.Warning :=> tx -> txt "Warning" (L.pack tx) + Met.Unknown k :=> Met.String tx -> txt (L.pack k) (L.pack tx) + Met.Unknown _ :=> _ -> mempty + + txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c + +encodeMetadatas :: Metadatas -> [PngRawChunk] +encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m + diff --git a/src/Codec/Picture/Png/Internal/Type.hs b/src/Codec/Picture/Png/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png/Internal/Type.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP #-} +-- | Low level png module, you should import 'Codec.Picture.Png.Internal' instead. +module Codec.Picture.Png.Internal.Type( PngIHdr( .. ) + , PngFilter( .. ) + , PngInterlaceMethod( .. ) + , PngPalette + , PngImageType( .. ) + , PngPhysicalDimension( .. ) + , PngGamma( .. ) + , PngUnit( .. ) + , APngAnimationControl( .. ) + , APngFrameDisposal( .. ) + , APngBlendOp( .. ) + , APngFrameControl( .. ) + , parsePalette + , pngComputeCrc + , pngSignature + , iHDRSignature + , pLTESignature + , iDATSignature + , iENDSignature + , tRNSSignature + , tEXtSignature + , zTXtSignature + , gammaSignature + , pHYsSignature + , animationControlSignature + -- * Low level types + , ChunkSignature + , PngRawImage( .. ) + , PngChunk( .. ) + , PngRawChunk( .. ) + , PngLowLevel( .. ) + , chunksWithSig + , mkRawChunk + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.Monad( when, replicateM ) +import Data.Bits( xor, (.&.), unsafeShiftR ) +import Data.Binary( Binary(..), Get, get ) +import Data.Binary.Get( getWord8 + , getWord32be + , getLazyByteString + ) +import Data.Binary.Put( runPut + , putWord8 + , putWord32be + , putLazyByteString + ) +import Data.Vector.Unboxed( Vector, fromListN, (!) ) +import qualified Data.Vector.Storable as V +import Data.List( foldl' ) +import Data.Word( Word32, Word16, Word8 ) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LS + +import Codec.Picture.Types +import Codec.Picture.InternalHelper + +-------------------------------------------------- +---- Types +-------------------------------------------------- + +-- | Value used to identify a png chunk, must be 4 bytes long. +type ChunkSignature = L.ByteString + +-- | Generic header used in PNG images. +data PngIHdr = PngIHdr + { width :: !Word32 -- ^ Image width in number of pixel + , height :: !Word32 -- ^ Image height in number of pixel + , bitDepth :: !Word8 -- ^ Number of bit per sample + , colourType :: !PngImageType -- ^ Kind of png image (greyscale, true color, indexed...) + , compressionMethod :: !Word8 -- ^ Compression method used + , filterMethod :: !Word8 -- ^ Must be 0 + , interlaceMethod :: !PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering) + } + deriving Show + +data PngUnit + = PngUnitUnknown -- ^ 0 value + | PngUnitMeter -- ^ 1 value + +instance Binary PngUnit where + get = do + v <- getWord8 + pure $ case v of + 0 -> PngUnitUnknown + 1 -> PngUnitMeter + _ -> PngUnitUnknown + + put v = case v of + PngUnitUnknown -> putWord8 0 + PngUnitMeter -> putWord8 1 + +data PngPhysicalDimension = PngPhysicalDimension + { pngDpiX :: !Word32 + , pngDpiY :: !Word32 + , pngUnit :: !PngUnit + } + +instance Binary PngPhysicalDimension where + get = PngPhysicalDimension <$> getWord32be <*> getWord32be <*> get + put (PngPhysicalDimension dpx dpy unit) = + putWord32be dpx >> putWord32be dpy >> put unit + +newtype PngGamma = PngGamma { getPngGamma :: Double } + +instance Binary PngGamma where + get = PngGamma . (/ 100000) . fromIntegral <$> getWord32be + put = putWord32be . ceiling . (100000 *) . getPngGamma + +data APngAnimationControl = APngAnimationControl + { animationFrameCount :: !Word32 + , animationPlayCount :: !Word32 + } + deriving Show + +-- | Encoded in a Word8 +data APngFrameDisposal + -- | No disposal is done on this frame before rendering the + -- next; the contents of the output buffer are left as is. + -- Has Value 0 + = APngDisposeNone + -- | The frame's region of the output buffer is to be cleared + -- to fully transparent black before rendering the next frame. + -- Has Value 1 + | APngDisposeBackground + -- | the frame's region of the output buffer is to be reverted + -- to the previous contents before rendering the next frame. + -- Has Value 2 + | APngDisposePrevious + deriving Show + +-- | Encoded in a Word8 +data APngBlendOp + -- | Overwrite output buffer. has value '0' + = APngBlendSource + -- | Alpha blend to the output buffer. Has value '1' + | APngBlendOver + deriving Show + +data APngFrameControl = APngFrameControl + { frameSequenceNum :: !Word32 -- ^ Starting from 0 + , frameWidth :: !Word32 -- ^ Width of the following frame + , frameHeight :: !Word32 -- ^ Height of the following frame + , frameLeft :: !Word32 -- X position where to render the frame. + , frameTop :: !Word32 -- Y position where to render the frame. + , frameDelayNumerator :: !Word16 + , frameDelayDenuminator :: !Word16 + , frameDisposal :: !APngFrameDisposal + , frameBlending :: !APngBlendOp + } + deriving Show + +-- | What kind of information is encoded in the IDAT section +-- of the PngFile +data PngImageType = + PngGreyscale + | PngTrueColour + | PngIndexedColor + | PngGreyscaleWithAlpha + | PngTrueColourWithAlpha + deriving Show + +-- | Raw parsed image which need to be decoded. +data PngRawImage = PngRawImage + { header :: PngIHdr + , chunks :: [PngRawChunk] + } + +-- | Palette with indices beginning at 0 to elemcount - 1 +type PngPalette = Palette' PixelRGB8 + +-- | Parse a palette from a png chunk. +parsePalette :: PngRawChunk -> Either String PngPalette +parsePalette plte + | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" + | otherwise = Palette' pixelCount . V.fromListN (3 * pixelCount) <$> pixels + where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get + pixelCount = fromIntegral $ chunkLength plte `div` 3 + pixels = runGet pixelUnpacker (chunkData plte) + +-- | Data structure during real png loading/parsing +data PngRawChunk = PngRawChunk + { chunkLength :: Word32 + , chunkType :: ChunkSignature + , chunkCRC :: Word32 + , chunkData :: L.ByteString + } + +mkRawChunk :: ChunkSignature -> L.ByteString -> PngRawChunk +mkRawChunk sig binaryData = PngRawChunk + { chunkLength = fromIntegral $ L.length binaryData + , chunkType = sig + , chunkCRC = pngComputeCrc [sig, binaryData] + , chunkData = binaryData + } + +-- | PNG chunk representing some extra information found in the parsed file. +data PngChunk = PngChunk + { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk + , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk. + } + +-- | Low level access to PNG information +data PngLowLevel a = PngLowLevel + { pngImage :: Image a -- ^ The real uncompressed image + , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present. + } + +-- | The pixels value should be : +-- +---+---+ +-- | c | b | +-- +---+---+ +-- | a | x | +-- +---+---+ +-- x being the current filtered pixel +data PngFilter = + -- | Filt(x) = Orig(x), Recon(x) = Filt(x) + FilterNone + -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a) + | FilterSub + -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b) + | FilterUp + -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2), + -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2) + | FilterAverage + -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)), + -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c)) + | FilterPaeth + deriving (Enum, Show) + +-- | Different known interlace methods for PNG image +data PngInterlaceMethod = + -- | No interlacing, basic data ordering, line by line + -- from left to right. + PngNoInterlace + + -- | Use the Adam7 ordering, see `adam7Reordering` + | PngInterlaceAdam7 + deriving (Enum, Show) + +-------------------------------------------------- +---- Instances +-------------------------------------------------- +instance Binary PngFilter where + put = putWord8 . toEnum . fromEnum + get = getWord8 >>= \w -> case w of + 0 -> return FilterNone + 1 -> return FilterSub + 2 -> return FilterUp + 3 -> return FilterAverage + 4 -> return FilterPaeth + _ -> fail "Invalid scanline filter" + +instance Binary PngRawImage where + put img = do + putLazyByteString pngSignature + put $ header img + mapM_ put $ chunks img + + get = parseRawPngImage + +instance Binary PngRawChunk where + put chunk = do + putWord32be $ chunkLength chunk + putLazyByteString $ chunkType chunk + when (chunkLength chunk /= 0) + (putLazyByteString $ chunkData chunk) + putWord32be $ chunkCRC chunk + + get = do + size <- getWord32be + chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature) + imgData <- if size == 0 + then return L.empty + else getLazyByteString (fromIntegral size) + crc <- getWord32be + + let computedCrc = pngComputeCrc [chunkSig, imgData] + when (computedCrc `xor` crc /= 0) + (fail $ "Invalid CRC : " ++ show computedCrc ++ ", " + ++ show crc) + return PngRawChunk { + chunkLength = size, + chunkData = imgData, + chunkCRC = crc, + chunkType = chunkSig + } + +instance Binary PngIHdr where + put hdr = do + putWord32be 13 + let inner = runPut $ do + putLazyByteString iHDRSignature + putWord32be $ width hdr + putWord32be $ height hdr + putWord8 $ bitDepth hdr + put $ colourType hdr + put $ compressionMethod hdr + put $ filterMethod hdr + put $ interlaceMethod hdr + crc = pngComputeCrc [inner] + putLazyByteString inner + putWord32be crc + + get = do + _size <- getWord32be + ihdrSig <- getLazyByteString (L.length iHDRSignature) + when (ihdrSig /= iHDRSignature) + (fail "Invalid PNG file, wrong ihdr") + w <- getWord32be + h <- getWord32be + depth <- get + colorType <- get + compression <- get + filtermethod <- get + interlace <- get + _crc <- getWord32be + return PngIHdr { + width = w, + height = h, + bitDepth = depth, + colourType = colorType, + compressionMethod = compression, + filterMethod = filtermethod, + interlaceMethod = interlace + } + +-- | Parse method for a png chunk, without decompression. +parseChunks :: Get [PngRawChunk] +parseChunks = do + chunk <- get + + if chunkType chunk == iENDSignature + then return [chunk] + else (chunk:) <$> parseChunks + + +instance Binary PngInterlaceMethod where + get = getWord8 >>= \w -> case w of + 0 -> return PngNoInterlace + 1 -> return PngInterlaceAdam7 + _ -> fail "Invalid interlace method" + + put PngNoInterlace = putWord8 0 + put PngInterlaceAdam7 = putWord8 1 + +-- | Implementation of the get method for the PngRawImage, +-- unpack raw data, without decompressing it. +parseRawPngImage :: Get PngRawImage +parseRawPngImage = do + sig <- getLazyByteString (L.length pngSignature) + when (sig /= pngSignature) + (fail "Invalid PNG file, signature broken") + + ihdr <- get + + chunkList <- parseChunks + return PngRawImage { header = ihdr, chunks = chunkList } + +-------------------------------------------------- +---- functions +-------------------------------------------------- + +-- | Signature signalling that the following data will be a png image +-- in the png bit stream +pngSignature :: ChunkSignature +pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10] + +-- | Helper function to help pack signatures. +signature :: String -> ChunkSignature +signature = LS.pack + +-- | Signature for the header chunk of png (must be the first) +iHDRSignature :: ChunkSignature +iHDRSignature = signature "IHDR" + +-- | Signature for a palette chunk in the pgn file. Must +-- occure before iDAT. +pLTESignature :: ChunkSignature +pLTESignature = signature "PLTE" + +-- | Signature for a data chuck (with image parts in it) +iDATSignature :: ChunkSignature +iDATSignature = signature "IDAT" + +-- | Signature for the last chunk of a png image, telling +-- the end. +iENDSignature :: ChunkSignature +iENDSignature = signature "IEND" + +tRNSSignature :: ChunkSignature +tRNSSignature = signature "tRNS" + +gammaSignature :: ChunkSignature +gammaSignature = signature "gAMA" + +pHYsSignature :: ChunkSignature +pHYsSignature = signature "pHYs" + +tEXtSignature :: ChunkSignature +tEXtSignature = signature "tEXt" + +zTXtSignature :: ChunkSignature +zTXtSignature = signature "zTXt" + +animationControlSignature :: ChunkSignature +animationControlSignature = signature "acTL" + +instance Binary PngImageType where + put PngGreyscale = putWord8 0 + put PngTrueColour = putWord8 2 + put PngIndexedColor = putWord8 3 + put PngGreyscaleWithAlpha = putWord8 4 + put PngTrueColourWithAlpha = putWord8 6 + + get = get >>= imageTypeOfCode + +imageTypeOfCode :: Word8 -> Get PngImageType +imageTypeOfCode 0 = return PngGreyscale +imageTypeOfCode 2 = return PngTrueColour +imageTypeOfCode 3 = return PngIndexedColor +imageTypeOfCode 4 = return PngGreyscaleWithAlpha +imageTypeOfCode 6 = return PngTrueColourWithAlpha +imageTypeOfCode _ = fail "Invalid png color code" + +-- | From the Annex D of the png specification. +pngCrcTable :: Vector Word32 +pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ] + where zero = 0 :: Int -- To avoid defaulting to Integer + updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1) + | otherwise = c `unsafeShiftR` 1 + magicConstant = 0xedb88320 :: Word32 + +-- | Compute the CRC of a raw buffer, as described in annex D of the PNG +-- specification. +pngComputeCrc :: [L.ByteString] -> Word32 +pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat + where updateCrc crc val = + let u32Val = fromIntegral val + lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) + in lutVal `xor` (crc `unsafeShiftR` 8) + +chunksWithSig :: PngRawImage -> ChunkSignature -> [LS.ByteString] +chunksWithSig rawImg sig = + [chunkData chunk | chunk <- chunks rawImg, chunkType chunk == sig] + diff --git a/src/Codec/Picture/Png/Type.hs b/src/Codec/Picture/Png/Type.hs deleted file mode 100644 --- a/src/Codec/Picture/Png/Type.hs +++ /dev/null @@ -1,329 +0,0 @@ --- | Low level png module, you should import 'Codec.Picture.Png' instead. -module Codec.Picture.Png.Type( PngIHdr( .. ) - , PngFilter( .. ) - , PngInterlaceMethod( .. ) - , PngPalette - , PngImageType( .. ) - , parsePalette - , pngComputeCrc - , pLTESignature - , iDATSignature - , iENDSignature - , tRNSSignature - -- * Low level types - , ChunkSignature - , PngRawImage( .. ) - , PngChunk( .. ) - , PngRawChunk( .. ) - , PngLowLevel( .. ) - ) where - -import Control.Applicative( (<$>) ) -import Control.Monad( when, replicateM ) -import Data.Bits( xor, (.&.), unsafeShiftR ) -import Data.Binary( Binary(..), Get, get ) -import Data.Binary.Get( getWord8 - , getWord32be - , getLazyByteString - ) -import Data.Binary.Put( runPut - , putWord8 - , putWord32be - , putLazyByteString - ) -import Data.Vector.Unboxed( Vector, fromListN, (!) ) -import qualified Data.Vector.Storable as V -import Data.List( foldl' ) -import Data.Word( Word32, Word8 ) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as LS - -import Codec.Picture.Types -import Codec.Picture.InternalHelper - --------------------------------------------------- ----- Types --------------------------------------------------- - --- | Value used to identify a png chunk, must be 4 bytes long. -type ChunkSignature = L.ByteString - --- | Generic header used in PNG images. -data PngIHdr = PngIHdr - { width :: Word32 -- ^ Image width in number of pixel - , height :: Word32 -- ^ Image height in number of pixel - , bitDepth :: Word8 -- ^ Number of bit per sample - , colourType :: PngImageType -- ^ Kind of png image (greyscale, true color, indexed...) - , compressionMethod :: Word8 -- ^ Compression method used - , filterMethod :: Word8 -- ^ Must be 0 - , interlaceMethod :: PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering) - } - deriving Show - --- | What kind of information is encoded in the IDAT section --- of the PngFile -data PngImageType = - PngGreyscale - | PngTrueColour - | PngIndexedColor - | PngGreyscaleWithAlpha - | PngTrueColourWithAlpha - deriving Show - --- | Raw parsed image which need to be decoded. -data PngRawImage = PngRawImage - { header :: PngIHdr - , chunks :: [PngRawChunk] - } - --- | Palette with indices beginning at 0 to elemcount - 1 -type PngPalette = Image PixelRGB8 - --- | Parse a palette from a png chunk. -parsePalette :: PngRawChunk -> Either String PngPalette -parsePalette plte - | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" - | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels - where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get - pixelCount = fromIntegral $ chunkLength plte `div` 3 - pixels = runGet pixelUnpacker (chunkData plte) - --- | Data structure during real png loading/parsing -data PngRawChunk = PngRawChunk - { chunkLength :: Word32 - , chunkType :: ChunkSignature - , chunkCRC :: Word32 - , chunkData :: L.ByteString - } - --- | PNG chunk representing some extra information found in the parsed file. -data PngChunk = PngChunk - { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk - , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk. - } - --- | Low level access to PNG information -data PngLowLevel a = PngLowLevel - { pngImage :: Image a -- ^ The real uncompressed image - , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present. - } - --- | The pixels value should be : --- +---+---+ --- | c | b | --- +---+---+ --- | a | x | --- +---+---+ --- x being the current filtered pixel -data PngFilter = - -- | Filt(x) = Orig(x), Recon(x) = Filt(x) - FilterNone - -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a) - | FilterSub - -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b) - | FilterUp - -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2), - -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2) - | FilterAverage - -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)), - -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c)) - | FilterPaeth - deriving (Enum, Show) - --- | Different known interlace methods for PNG image -data PngInterlaceMethod = - -- | No interlacing, basic data ordering, line by line - -- from left to right. - PngNoInterlace - - -- | Use the Adam7 ordering, see `adam7Reordering` - | PngInterlaceAdam7 - deriving (Enum, Show) - --------------------------------------------------- ----- Instances --------------------------------------------------- -instance Binary PngFilter where - put = putWord8 . toEnum . fromEnum - get = getWord8 >>= \w -> case w of - 0 -> return FilterNone - 1 -> return FilterSub - 2 -> return FilterUp - 3 -> return FilterAverage - 4 -> return FilterPaeth - _ -> fail "Invalid scanline filter" - -instance Binary PngRawImage where - put img = do - putLazyByteString pngSignature - put $ header img - mapM_ put $ chunks img - - get = parseRawPngImage - -instance Binary PngRawChunk where - put chunk = do - putWord32be $ chunkLength chunk - putLazyByteString $ chunkType chunk - when (chunkLength chunk /= 0) - (putLazyByteString $ chunkData chunk) - putWord32be $ chunkCRC chunk - - get = do - size <- getWord32be - chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature) - imgData <- if size == 0 - then return L.empty - else getLazyByteString (fromIntegral size) - crc <- getWord32be - - let computedCrc = pngComputeCrc [chunkSig, imgData] - when (computedCrc `xor` crc /= 0) - (fail $ "Invalid CRC : " ++ show computedCrc ++ ", " - ++ show crc) - return PngRawChunk { - chunkLength = size, - chunkData = imgData, - chunkCRC = crc, - chunkType = chunkSig - } - -instance Binary PngIHdr where - put hdr = do - putWord32be 13 - let inner = runPut $ do - putLazyByteString iHDRSignature - putWord32be $ width hdr - putWord32be $ height hdr - putWord8 $ bitDepth hdr - put $ colourType hdr - put $ compressionMethod hdr - put $ filterMethod hdr - put $ interlaceMethod hdr - crc = pngComputeCrc [inner] - putLazyByteString inner - putWord32be crc - - get = do - _size <- getWord32be - ihdrSig <- getLazyByteString (L.length iHDRSignature) - when (ihdrSig /= iHDRSignature) - (fail "Invalid PNG file, wrong ihdr") - w <- getWord32be - h <- getWord32be - depth <- get - colorType <- get - compression <- get - filtermethod <- get - interlace <- get - _crc <- getWord32be - return PngIHdr { - width = w, - height = h, - bitDepth = depth, - colourType = colorType, - compressionMethod = compression, - filterMethod = filtermethod, - interlaceMethod = interlace - } - --- | Parse method for a png chunk, without decompression. -parseChunks :: Get [PngRawChunk] -parseChunks = do - chunk <- get - - if chunkType chunk == iENDSignature - then return [chunk] - else (chunk:) <$> parseChunks - - -instance Binary PngInterlaceMethod where - get = getWord8 >>= \w -> case w of - 0 -> return PngNoInterlace - 1 -> return PngInterlaceAdam7 - _ -> fail "Invalid interlace method" - - put PngNoInterlace = putWord8 0 - put PngInterlaceAdam7 = putWord8 1 - --- | Implementation of the get method for the PngRawImage, --- unpack raw data, without decompressing it. -parseRawPngImage :: Get PngRawImage -parseRawPngImage = do - sig <- getLazyByteString (L.length pngSignature) - when (sig /= pngSignature) - (fail "Invalid PNG file, signature broken") - - ihdr <- get - - chunkList <- parseChunks - return PngRawImage { header = ihdr, chunks = chunkList } - --------------------------------------------------- ----- functions --------------------------------------------------- - --- | Signature signalling that the following data will be a png image --- in the png bit stream -pngSignature :: ChunkSignature -pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10] - --- | Helper function to help pack signatures. -signature :: String -> ChunkSignature -signature = LS.pack - --- | Signature for the header chunk of png (must be the first) -iHDRSignature :: ChunkSignature -iHDRSignature = signature "IHDR" - --- | Signature for a palette chunk in the pgn file. Must --- occure before iDAT. -pLTESignature :: ChunkSignature -pLTESignature = signature "PLTE" - --- | Signature for a data chuck (with image parts in it) -iDATSignature :: ChunkSignature -iDATSignature = signature "IDAT" - --- | Signature for the last chunk of a png image, telling --- the end. -iENDSignature :: ChunkSignature -iENDSignature = signature "IEND" - -tRNSSignature :: ChunkSignature -tRNSSignature = signature "tRNS" - -instance Binary PngImageType where - put PngGreyscale = putWord8 0 - put PngTrueColour = putWord8 2 - put PngIndexedColor = putWord8 3 - put PngGreyscaleWithAlpha = putWord8 4 - put PngTrueColourWithAlpha = putWord8 6 - - get = get >>= imageTypeOfCode - -imageTypeOfCode :: Word8 -> Get PngImageType -imageTypeOfCode 0 = return PngGreyscale -imageTypeOfCode 2 = return PngTrueColour -imageTypeOfCode 3 = return PngIndexedColor -imageTypeOfCode 4 = return PngGreyscaleWithAlpha -imageTypeOfCode 6 = return PngTrueColourWithAlpha -imageTypeOfCode _ = fail "Invalid png color code" - --- | From the Annex D of the png specification. -pngCrcTable :: Vector Word32 -pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ] - where zero = 0 :: Int -- To avoid defaulting to Integer - updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1) - | otherwise = c `unsafeShiftR` 1 - magicConstant = 0xedb88320 :: Word32 - --- | Compute the CRC of a raw buffer, as described in annex D of the PNG --- specification. -pngComputeCrc :: [L.ByteString] -> Word32 -pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat - where updateCrc crc val = - let u32Val = fromIntegral val - lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) - in lutVal `xor` (crc `unsafeShiftR` 8) - diff --git a/src/Codec/Picture/Saving.hs b/src/Codec/Picture/Saving.hs --- a/src/Codec/Picture/Saving.hs +++ b/src/Codec/Picture/Saving.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} -- | Helper functions to save dynamic images to other file format -- with automatic color space/sample format conversion done automatically. module Codec.Picture.Saving( imageToJpg @@ -7,10 +8,15 @@ , imageToBitmap , imageToTiff , imageToRadiance + , imageToTga ) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +#endif + import Data.Bits( unsafeShiftR ) -import Data.Word( Word8, Word16 ) +import Data.Word( Word8, Word16, Word32 ) import qualified Data.ByteString.Lazy as L import Codec.Picture.Bitmap import Codec.Picture.Jpg @@ -20,6 +26,7 @@ import Codec.Picture.HDR import Codec.Picture.Types import Codec.Picture.Tiff +import Codec.Picture.Tga import qualified Data.Vector.Storable as V @@ -27,7 +34,7 @@ componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 toStandardDef :: Image PixelRGBF -> Image PixelRGB8 -toStandardDef img = pixelMap pixelConverter img +toStandardDef = pixelMap pixelConverter where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b where r = componentToLDR rf g = componentToLDR gf @@ -44,6 +51,22 @@ where transformed = V.map toWord8 arr toWord8 v = fromIntegral (v `unsafeShiftR` 8) +from32to8 :: ( PixelBaseComponent source ~ Word32 + , PixelBaseComponent dest ~ Word8 ) + => Image source -> Image dest +from32to8 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral (v `unsafeShiftR` 24) + +from32to16 :: ( PixelBaseComponent source ~ Word32 + , PixelBaseComponent dest ~ Word16 ) + => Image source -> Image dest +from32to16 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord16 arr + toWord16 v = fromIntegral (v `unsafeShiftR` 16) + from16toFloat :: ( PixelBaseComponent source ~ Word16 , PixelBaseComponent dest ~ Float ) => Image source -> Image dest @@ -77,7 +100,10 @@ imageToRadiance . ImageRGBF $ pixelMap toRgbf img where toRgbf v = PixelRGBF val val val where val = fromIntegral v / 65536.0 - +imageToRadiance (ImageY32 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf v = PixelRGBF val val val + where val = fromIntegral v / 4294967296.0 imageToRadiance (ImageYA16 img) = imageToRadiance . ImageRGBF $ pixelMap toRgbf img where toRgbf (PixelYA16 v _) = PixelRGBF val val val @@ -92,9 +118,13 @@ -- | This function will try to do anything to encode an image -- as JPEG, make all color conversion and such. Equivalent -- of 'decodeImage' for jpeg encoding +-- Save Y or YCbCr Jpeg only, all other colorspaces are converted. +-- To save a RGB or CMYK JPEG file, use the +-- 'Codec.Picture.Jpg.Internal.encodeDirectJpegAtQualityWithMetadata' function imageToJpg :: Int -> DynamicImage -> L.ByteString imageToJpg quality dynImage = let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) + encodeWithMeta = encodeDirectJpegAtQualityWithMetadata (fromIntegral quality) mempty in case dynImage of ImageYCbCr8 img -> encodeAtQuality img ImageCMYK8 img -> imageToJpg quality . ImageRGB8 $ convertImage img @@ -103,12 +133,11 @@ ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img - ImageY8 img -> encodeAtQuality . convertImage - $ (promoteImage img :: Image PixelRGB8) - ImageYA8 img -> encodeAtQuality $ - convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8) + ImageY8 img -> encodeWithMeta img + ImageYA8 img -> encodeWithMeta $ dropAlphaLayer img ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img + ImageY32 img -> imageToJpg quality . ImageY8 $ from32to8 img ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img @@ -126,6 +155,7 @@ imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img imageToPng (ImageYA8 img) = encodePng img imageToPng (ImageY16 img) = encodePng img +imageToPng (ImageY32 img) = imageToPng . ImageY16 $ from32to16 img imageToPng (ImageYA16 img) = encodePng img imageToPng (ImageRGB16 img) = encodePng img imageToPng (ImageRGBA16 img) = encodePng img @@ -144,6 +174,7 @@ imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img imageToTiff (ImageY16 img) = encodeTiff img +imageToTiff (ImageY32 img) = encodeTiff img imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img imageToTiff (ImageRGB16 img) = encodeTiff img imageToTiff (ImageRGBA16 img) = encodeTiff img @@ -162,6 +193,7 @@ imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img +imageToBitmap (ImageY32 img) = imageToBitmap . ImageY8 $ from32to8 img imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img @@ -182,6 +214,26 @@ imageToGif (ImageYF img) = imageToGif . ImageY8 $ greyScaleToStandardDef img imageToGif (ImageYA8 img) = imageToGif . ImageY8 $ dropAlphaLayer img imageToGif (ImageY16 img) = imageToGif . ImageY8 $ from16to8 img +imageToGif (ImageY32 img) = imageToGif . ImageY8 $ from32to8 img imageToGif (ImageYA16 img) = imageToGif . ImageYA8 $ from16to8 img imageToGif (ImageRGB16 img) = imageToGif . ImageRGB8 $ from16to8 img imageToGif (ImageRGBA16 img) = imageToGif . ImageRGBA8 $ from16to8 img + +-- | This function will try to do anything to encode an image +-- as a tga, make all color conversion and quantization. Equivalent +-- of 'decodeImage' for tga encoding +imageToTga :: DynamicImage -> L.ByteString +imageToTga (ImageYCbCr8 img) = encodeTga (convertImage img :: Image PixelRGB8) +imageToTga (ImageCMYK8 img) = encodeTga (convertImage img :: Image PixelRGB8) +imageToTga (ImageCMYK16 img) = encodeTga (from16to8 img :: Image PixelRGB8) +imageToTga (ImageRGBF img) = encodeTga $ toStandardDef img +imageToTga (ImageRGB8 img) = encodeTga img +imageToTga (ImageRGBA8 img) = encodeTga img +imageToTga (ImageY8 img) = encodeTga img +imageToTga (ImageYF img) = encodeTga $ greyScaleToStandardDef img +imageToTga (ImageYA8 img) = encodeTga (promoteImage img :: Image PixelRGBA8) +imageToTga (ImageY16 img) = encodeTga (from16to8 img :: Image Pixel8) +imageToTga (ImageY32 img) = encodeTga (from32to8 img :: Image Pixel8) +imageToTga (ImageYA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) +imageToTga (ImageRGB16 img) = encodeTga (from16to8 img :: Image PixelRGB8) +imageToTga (ImageRGBA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) diff --git a/src/Codec/Picture/Tga.hs b/src/Codec/Picture/Tga.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tga.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +-- | Module implementing function to read and write +-- Targa (*.tga) files. +module Codec.Picture.Tga( decodeTga + , decodeTgaWithMetadata + , decodeTgaWithPaletteAndMetadata + , TgaSaveable + , encodeTga + , writeTga + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<*>), pure, (<$>) ) +#endif + +import Control.Arrow( first ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( (.&.) + , (.|.) + , bit + , testBit + , setBit + , unsafeShiftL + , unsafeShiftR ) +import Data.Word( Word8, Word16 ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get + , getByteString + , getWord8 + , getWord16le + ) +import Data.Binary.Put( putWord8 + , putWord16le + , putByteString + ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb +import qualified Data.ByteString.Unsafe as U +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Types +import Codec.Picture.InternalHelper +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceTGA ) + , basicMetadata ) +import Codec.Picture.VectorByteConversion + +data TgaColorMapType + = ColorMapWithoutTable + | ColorMapWithTable + | ColorMapUnknown Word8 + +instance Binary TgaColorMapType where + get = do + v <- getWord8 + return $ case v of + 0 -> ColorMapWithoutTable + 1 -> ColorMapWithTable + n -> ColorMapUnknown n + + put v = case v of + ColorMapWithoutTable -> putWord8 0 + ColorMapWithTable -> putWord8 1 + (ColorMapUnknown vv) -> putWord8 vv + +data TgaImageType + = ImageTypeNoData Bool + | ImageTypeColorMapped Bool + | ImageTypeTrueColor Bool + | ImageTypeMonochrome Bool + +isRleEncoded :: TgaImageType -> Bool +isRleEncoded v = case v of + ImageTypeNoData yn -> yn + ImageTypeColorMapped yn -> yn + ImageTypeTrueColor yn -> yn + ImageTypeMonochrome yn -> yn + +imageTypeOfCode :: Word8 -> Get TgaImageType +imageTypeOfCode v = case v .&. 3 of + 0 -> return $ ImageTypeNoData isEncoded + 1 -> return $ ImageTypeColorMapped isEncoded + 2 -> return $ ImageTypeTrueColor isEncoded + 3 -> return $ ImageTypeMonochrome isEncoded + _ -> fail $ "Unknown TGA image type " ++ show v + where + isEncoded = testBit v 3 + +codeOfImageType :: TgaImageType -> Word8 +codeOfImageType v = case v of + ImageTypeNoData encoded -> setVal 0 encoded + ImageTypeColorMapped encoded -> setVal 1 encoded + ImageTypeTrueColor encoded -> setVal 2 encoded + ImageTypeMonochrome encoded -> setVal 3 encoded + where + setVal vv True = setBit vv 3 + setVal vv False = vv + +instance Binary TgaImageType where + get = getWord8 >>= imageTypeOfCode + put = putWord8 . codeOfImageType + +data TgaImageDescription = TgaImageDescription + { _tgaIdXOrigin :: Bool + , _tgaIdYOrigin :: Bool + , _tgaIdAttributeBits :: Word8 + } + +instance Binary TgaImageDescription where + put desc = putWord8 $ xOrig .|. yOrig .|. attr + where + xOrig | _tgaIdXOrigin desc = bit 4 + | otherwise = 0 + + yOrig | not $ _tgaIdYOrigin desc = bit 5 + | otherwise = 0 + + attr = _tgaIdAttributeBits desc .&. 0xF + + get = toDescr <$> getWord8 where + toDescr v = TgaImageDescription + { _tgaIdXOrigin = testBit v 4 + , _tgaIdYOrigin = not $ testBit v 5 + , _tgaIdAttributeBits = v .&. 0xF + } + +data TgaHeader = TgaHeader + { _tgaHdrIdLength :: {-# UNPACK #-} !Word8 + , _tgaHdrColorMapType :: !TgaColorMapType + , _tgaHdrImageType :: !TgaImageType + , _tgaHdrMapStart :: {-# UNPACK #-} !Word16 + , _tgaHdrMapLength :: {-# UNPACK #-} !Word16 + , _tgaHdrMapDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrXOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrYOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrWidth :: {-# UNPACK #-} !Word16 + , _tgaHdrHeight :: {-# UNPACK #-} !Word16 + , _tgaHdrPixelDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription + } + +instance Binary TgaHeader where + get = TgaHeader + <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8 + <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get + where g16 = getWord16le + g8 = getWord8 + + put v = do + let p8 = putWord8 + p16 = putWord16le + p8 $ _tgaHdrIdLength v + put $ _tgaHdrColorMapType v + put $ _tgaHdrImageType v + + p16 $ _tgaHdrMapStart v + p16 $ _tgaHdrMapLength v + p8 $ _tgaHdrMapDepth v + p16 $ _tgaHdrXOffset v + p16 $ _tgaHdrYOffset v + p16 $ _tgaHdrWidth v + p16 $ _tgaHdrHeight v + p8 $ _tgaHdrPixelDepth v + put $ _tgaHdrImageDescription v + + +data TgaFile = TgaFile + { _tgaFileHeader :: !TgaHeader + , _tgaFileId :: !B.ByteString + , _tgaPalette :: !B.ByteString + , _tgaFileRest :: !B.ByteString + } + +getPalette :: TgaHeader -> Get B.ByteString +getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty +getPalette hdr = getByteString $ bytePerPixel * pixelCount + where + bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8 + pixelCount = fromIntegral $ _tgaHdrMapLength hdr + +instance Binary TgaFile where + get = do + hdr <- get + validateTga hdr + fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr + palette <- getPalette hdr + rest <- getRemainingBytes + + return TgaFile { + _tgaFileHeader = hdr + , _tgaFileId = fileId + , _tgaPalette = palette + , _tgaFileRest = rest + } + + put file = do + put $ _tgaFileHeader file + putByteString $ _tgaFileId file + putByteString $ _tgaPalette file + putByteString $ _tgaFileRest file + +data Depth8 = Depth8 +data Depth15 = Depth15 +data Depth24 = Depth24 +data Depth32 = Depth32 + +class (Pixel (Unpacked a)) => TGAPixel a where + type Unpacked a + packedByteSize :: a -> Int + tgaUnpack :: a -> B.ByteString -> Int -> Unpacked a + +instance TGAPixel Depth8 where + type Unpacked Depth8 = Pixel8 + packedByteSize _ = 1 + tgaUnpack _ = U.unsafeIndex + +instance TGAPixel Depth15 where + type Unpacked Depth15 = PixelRGBA8 + packedByteSize _ = 2 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + v0 = U.unsafeIndex str ix + v1 = U.unsafeIndex str $ ix + 1 + r = (v1 .&. 0x7c) `unsafeShiftL` 1; + g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2); + b = (v0 .&. 0x1f) `unsafeShiftL` 3 + a = 255 -- v1 .&. 0x80 + +instance TGAPixel Depth24 where + type Unpacked Depth24 = PixelRGB8 + packedByteSize _ = 3 + tgaUnpack _ str ix = PixelRGB8 r g b + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + +instance TGAPixel Depth32 where + type Unpacked Depth32 = PixelRGBA8 + packedByteSize _ = 4 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + a = U.unsafeIndex str (ix + 3) + +prepareUnpacker :: TgaFile + -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx)) + -> Either String DynamicImage +prepareUnpacker file f = + let hdr = _tgaFileHeader file + flipper :: (Pixel px) => Image px -> Image px + flipper = flipImage $ _tgaHdrImageDescription hdr + in + case _tgaHdrPixelDepth hdr of + 8 -> pure . ImageY8 . flipper $ f Depth8 file + 16 -> pure . ImageRGBA8 . flipper $ f Depth15 file + 24 -> pure . ImageRGB8 . flipper $ f Depth24 file + 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file + n -> Left $ "Invalid bit depth (" ++ show n ++ ")" + +toPaletted :: (Pixel px) + => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px + -> DynamicImage + -> Either String PalettedImage +toPaletted f palette (ImageY8 img) = pure $ f img pal where + pal = Palette' + { _paletteSize = imageWidth palette + , _paletteData = imageData palette + } +toPaletted _ _ _ = Left "Bad colorspace for image" + +unparse :: TgaFile -> Either String (PalettedImage, Metadatas) +unparse file = + let hdr = _tgaFileHeader file + imageType = _tgaHdrImageType hdr + + unpacker :: forall tgapx. (TGAPixel tgapx) + => tgapx -> TgaFile -> Image (Unpacked tgapx) + unpacker | isRleEncoded imageType = unpackRLETga + | otherwise = unpackUncompressedTga + + metas = basicMetadata SourceTGA (_tgaHdrWidth hdr) (_tgaHdrHeight hdr) + decodedPalette = unparse file + { _tgaFileHeader = hdr + { _tgaHdrHeight = 1 + , _tgaHdrWidth = _tgaHdrMapLength hdr + , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr + , _tgaHdrImageType = ImageTypeTrueColor False + } + , _tgaFileRest = _tgaPalette file + } + in + case imageType of + ImageTypeNoData _ -> Left "No data detected in TGA file" + ImageTypeTrueColor _ -> + fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker + ImageTypeMonochrome _ -> + fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker + ImageTypeColorMapped _ -> + case decodedPalette of + Left str -> Left str + Right (TrueColorImage (ImageY8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedY8 img + Right (TrueColorImage (ImageRGB8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGB8 img + Right (TrueColorImage (ImageRGBA8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGBA8 img + Right _ -> Left "Unknown pixel type" + +writeRun :: (Pixel px) + => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int + -> ST s Int +writeRun imgData localMaxi px = run + where + writeDelta = componentCount px + run writeIndex + | writeIndex >= localMaxi = return writeIndex + run writeIndex = do + unsafeWritePixel imgData writeIndex px + run $ writeIndex + writeDelta + +copyData :: forall tgapx s + . (TGAPixel tgapx) + => tgapx + -> M.STVector s (PixelBaseComponent (Unpacked tgapx)) + -> B.ByteString + -> Int -> Int + -> Int -> Int + -> ST s (Int, Int) +copyData tgapx imgData readData maxi maxRead = go + where + readDelta = packedByteSize tgapx + writeDelta = componentCount (undefined :: Unpacked tgapx) + + go writeIndex readIndex + | writeIndex >= maxi || + readIndex >= maxRead = return (writeIndex, readIndex) + go writeIndex readIndex = do + let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx + unsafeWritePixel imgData writeIndex px + go (writeIndex + writeDelta) (readIndex + readDelta) + +unpackUncompressedTga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackUncompressedTga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + _ <- copyData tga imgData readData maxi maxRead 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + +isRleChunk :: Word8 -> Bool +isRleChunk v = testBit v 7 + +runLength :: Word8 -> Int +runLength v = fromIntegral (v .&. 0x7F) + 1 + +unpackRLETga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackRLETga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + + go writeIndex readIndex + | writeIndex >= maxi = return () + | readIndex >= maxRead = return () + go writeIndex readIndex = do + let code = U.unsafeIndex readData readIndex + copyMax = min maxi $ writeIndex + runLength code * compCount + + if isRleChunk code then do + let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx + lastWriteIndex <- writeRun imgData copyMax px writeIndex + go lastWriteIndex $ readIndex + 1 + readDelta + + else do + (newWrite, newRead) <- + copyData tga imgData readData copyMax maxRead + writeIndex (readIndex + 1) + go newWrite newRead + + go 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + readDelta = packedByteSize tga + +flipImage :: (Pixel px) + => TgaImageDescription -> Image px -> Image px +flipImage desc img + | xFlip && yFlip = + generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h + | xFlip = + generateImage (\x y -> pixelAt img (wMax - x) y) w h + | yFlip = + generateImage (\x y -> pixelAt img x (hMax - y)) w h + | otherwise = img + where + xFlip = _tgaIdXOrigin desc + yFlip = _tgaIdYOrigin desc + w = imageWidth img + h = imageHeight img + + !wMax = w - 1 + !hMax = h - 1 + +validateTga :: TgaHeader -> Get () +validateTga hdr + | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative" + | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative" +validateTga _ = return () + +-- | Transform a raw tga image to an image, without modifying +-- the underlying pixel type. +-- +-- This function can output the following images: +-- +-- * 'ImageY8' +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGBA8' +-- +decodeTga :: B.ByteString -> Either String DynamicImage +decodeTga byte = fst <$> decodeTgaWithMetadata byte + +-- | Equivalent to decodeTga but also provide metadata +decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeTgaWithMetadata byte = first palettedToTrueColor <$> decodeTgaWithPaletteAndMetadata byte + +-- | Equivalent to decodeTga but with metdata and palette if any +decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeTgaWithPaletteAndMetadata byte = runGetStrict get byte >>= unparse + +-- | This typeclass determine if a pixel can be saved in the +-- TGA format. +class TgaSaveable a where + tgaDataOfImage :: Image a -> B.ByteString + tgaPixelDepthOfImage :: Image a -> Word8 + tgaTypeOfImage :: Image a -> TgaImageType + +instance TgaSaveable Pixel8 where + tgaDataOfImage = toByteString . imageData + tgaPixelDepthOfImage _ = 8 + tgaTypeOfImage _ = ImageTypeMonochrome False + +instance TgaSaveable PixelRGB8 where + tgaPixelDepthOfImage _ = 24 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgb + where + flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r + +instance TgaSaveable PixelRGBA8 where + tgaPixelDepthOfImage _ = 32 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgba + where + flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a + +-- | Helper function to directly write an image a tga on disk. +writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO () +writeTga path img = Lb.writeFile path $ encodeTga img + +-- | Transform a compatible image to a raw bytestring +-- representing a Targa file. +encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString +encodeTga img = encode file + where + file = TgaFile + { _tgaFileHeader = TgaHeader + { _tgaHdrIdLength = 0 + , _tgaHdrColorMapType = ColorMapWithoutTable + , _tgaHdrImageType = tgaTypeOfImage img + , _tgaHdrMapStart = 0 + , _tgaHdrMapLength = 0 + , _tgaHdrMapDepth = 0 + , _tgaHdrXOffset = 0 + , _tgaHdrYOffset = 0 + , _tgaHdrWidth = fromIntegral $ imageWidth img + , _tgaHdrHeight = fromIntegral $ imageHeight img + , _tgaHdrPixelDepth = tgaPixelDepthOfImage img + , _tgaHdrImageDescription = TgaImageDescription + { _tgaIdXOrigin = False + , _tgaIdYOrigin = False + , _tgaIdAttributeBits = 0 + } + } + , _tgaFileId = mempty + , _tgaPalette = mempty + , _tgaFileRest = tgaDataOfImage img + } + +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs --- a/src/Codec/Picture/Tiff.hs +++ b/src/Codec/Picture/Tiff.hs @@ -4,6 +4,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE CPP #-} -- | Module implementing TIFF decoding. -- -- Supported compression schemes: @@ -24,438 +26,86 @@ -- -- * 16 bits -- -module Codec.Picture.Tiff( decodeTiff, TiffSaveable, encodeTiff, writeTiff ) where +module Codec.Picture.Tiff( decodeTiff + , decodeTiffWithMetadata + , decodeTiffWithPaletteAndMetadata + , TiffSaveable + , encodeTiff + , writeTiff + ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>), (<*>), pure ) -import Control.Monad( when, replicateM, foldM_ ) +import Data.Monoid( mempty ) +#endif + +import Control.Arrow( first ) +import Control.Monad( when, foldM_, unless, forM_ ) import Control.Monad.ST( ST, runST ) import Control.Monad.Writer.Strict( execWriter, tell, Writer ) import Data.Int( Int8 ) -import Data.Word( Word8, Word16 ) +import Data.Word( Word8, Word16, Word32 ) import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , getWord16le, getWord16be - , getWord32le, getWord32be - , bytesRead - , skip - , getByteString - ) -import Data.Binary.Put( Put, runPut - , putWord16le, putWord16be - , putWord32le, putWord32be - , putByteString - ) +import Data.Binary.Get( Get ) +import Data.Binary.Put( runPut ) -import Data.List( sortBy, mapAccumL ) import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M -import Data.Word( Word32 ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as Lb import qualified Data.ByteString.Unsafe as BU import Foreign.Storable( sizeOf ) +import Codec.Picture.Metadata.Exif +import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types -import Codec.Picture.Gif.LZW +import Codec.Picture.Gif.Internal.LZW +import Codec.Picture.Tiff.Internal.Types +import Codec.Picture.Tiff.Internal.Metadata import Codec.Picture.VectorByteConversion( toByteString ) -data Endianness = EndianLittle - | EndianBig - deriving (Eq, Show) - -instance Binary Endianness where - put EndianLittle = putWord16le 0x4949 - put EndianBig = putWord16le 0x4D4D - - get = do - tag <- getWord16le - case tag of - 0x4949 -> return EndianLittle - 0x4D4D -> return EndianBig - _ -> fail "Invalid endian tag value" - --- | Because having a polymorphic get with endianness is to nice --- to pass on, introducing this helper type class, which is just --- a superset of Binary, but formalising a parameter passing --- into it. -class BinaryParam a b where - getP :: a -> Get b - putP :: a -> b -> Put - -data TiffHeader = TiffHeader - { hdrEndianness :: !Endianness - , hdrOffset :: {-# UNPACK #-} !Word32 - } - deriving (Eq, Show) - -instance BinaryParam Endianness Word16 where - putP EndianLittle = putWord16le - putP EndianBig = putWord16be - - getP EndianLittle = getWord16le - getP EndianBig = getWord16be - -instance BinaryParam Endianness Word32 where - putP EndianLittle = putWord32le - putP EndianBig = putWord32be - - getP EndianLittle = getWord32le - getP EndianBig = getWord32be - -instance Binary TiffHeader where - put hdr = do - let endian = hdrEndianness hdr - put endian - putP endian (42 :: Word16) - putP endian $ hdrOffset hdr - - get = do - endian <- get - magic <- getP endian - let magicValue = 42 :: Word16 - when (magic /= magicValue) - (fail "Invalid TIFF magic number") - TiffHeader endian <$> getP endian - -data TiffPlanarConfiguration = - PlanarConfigContig -- = 1 - | PlanarConfigSeparate -- = 2 - -planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration -planarConfgOfConstant 0 = pure PlanarConfigContig -planarConfgOfConstant 1 = pure PlanarConfigContig -planarConfgOfConstant 2 = pure PlanarConfigSeparate -planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" - -constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 -constantToPlaneConfiguration PlanarConfigContig = 1 -constantToPlaneConfiguration PlanarConfigSeparate = 2 - -data TiffCompression = - CompressionNone -- 1 - | CompressionModifiedRLE -- 2 - | CompressionLZW -- 5 - | CompressionJPEG -- 6 - | CompressionPackBit -- 32273 - -data IfdType = TypeByte - | TypeAscii - | TypeShort - | TypeLong - | TypeRational - | TypeSByte - | TypeUndefined - | TypeSignedShort - | TypeSignedLong - | TypeSignedRational - | TypeFloat - | TypeDouble - -instance BinaryParam Endianness IfdType where - getP endianness = getP endianness >>= conv - where - conv :: Word16 -> Get IfdType - conv 1 = return TypeByte - conv 2 = return TypeAscii - conv 3 = return TypeShort - conv 4 = return TypeLong - conv 5 = return TypeRational - conv 6 = return TypeSByte - conv 7 = return TypeUndefined - conv 8 = return TypeSignedShort - conv 9 = return TypeSignedLong - conv 10 = return TypeSignedRational - conv 11 = return TypeFloat - conv 12 = return TypeDouble - conv _ = fail "Invalid TIF directory type" - - putP endianness = putP endianness . conv - where - conv :: IfdType -> Word16 - conv TypeByte = 1 - conv TypeAscii = 2 - conv TypeShort = 3 - conv TypeLong = 4 - conv TypeRational = 5 - conv TypeSByte = 6 - conv TypeUndefined = 7 - conv TypeSignedShort = 8 - conv TypeSignedLong = 9 - conv TypeSignedRational = 10 - conv TypeFloat = 11 - conv TypeDouble = 12 - -data TiffTag = TagPhotometricInterpretation - | TagCompression -- ^ Short type - | TagImageWidth -- ^ Short or long type - | TagImageLength -- ^ Short or long type - | TagXResolution -- ^ Rational type - | TagYResolution -- ^ Rational type - | TagResolutionUnit -- ^ Short type - | TagRowPerStrip -- ^ Short or long type - | TagStripByteCounts -- ^ Short or long - | TagStripOffsets -- ^ Short or long - | TagBitsPerSample -- ^ Short - | TagColorMap -- ^ Short - | TagTileWidth - | TagTileLength - | TagTileOffset - | TagTileByteCount - | TagSamplesPerPixel -- ^ Short - | TagArtist - | TagDocumentName - | TagSoftware - | TagPlanarConfiguration -- ^ Short - | TagOrientation - | TagSampleFormat -- ^ Short - | TagInkSet - | TagSubfileType - | TagFillOrder - | TagYCbCrCoeff - | TagYCbCrSubsampling - | TagYCbCrPositioning - | TagReferenceBlackWhite - | TagXPosition - | TagYPosition - | TagExtraSample - | TagImageDescription - - | TagJpegProc - | TagJPEGInterchangeFormat - | TagJPEGInterchangeFormatLength - | TagJPEGRestartInterval - | TagJPEGLosslessPredictors - | TagJPEGPointTransforms - | TagJPEGQTables - | TagJPEGDCTables - | TagJPEGACTables - - | TagUnknown Word16 - deriving (Eq, Show) - -tagOfWord16 :: Word16 -> TiffTag -tagOfWord16 = aux - where aux 255 = TagSubfileType - aux 256 = TagImageWidth - aux 257 = TagImageLength - aux 258 = TagBitsPerSample - aux 259 = TagCompression - aux 262 = TagPhotometricInterpretation - aux 266 = TagFillOrder - aux 269 = TagDocumentName - aux 270 = TagImageDescription - aux 273 = TagStripOffsets - aux 274 = TagOrientation - aux 277 = TagSamplesPerPixel - aux 278 = TagRowPerStrip - aux 279 = TagStripByteCounts - aux 282 = TagXResolution - aux 283 = TagYResolution - aux 284 = TagPlanarConfiguration - aux 286 = TagXPosition - aux 287 = TagYPosition - aux 296 = TagResolutionUnit - aux 305 = TagSoftware - aux 315 = TagArtist - aux 320 = TagColorMap - aux 322 = TagTileWidth - aux 323 = TagTileLength - aux 324 = TagTileOffset - aux 325 = TagTileByteCount - aux 332 = TagInkSet - aux 338 = TagExtraSample - aux 339 = TagSampleFormat - aux 529 = TagYCbCrCoeff - aux 512 = TagJpegProc - aux 513 = TagJPEGInterchangeFormat - aux 514 = TagJPEGInterchangeFormatLength - aux 515 = TagJPEGRestartInterval - aux 517 = TagJPEGLosslessPredictors - aux 518 = TagJPEGPointTransforms - aux 519 = TagJPEGQTables - aux 520 = TagJPEGDCTables - aux 521 = TagJPEGACTables - aux 530 = TagYCbCrSubsampling - aux 531 = TagYCbCrPositioning - aux 532 = TagReferenceBlackWhite - aux v = TagUnknown v - -word16OfTag :: TiffTag -> Word16 -word16OfTag = aux - where aux TagSubfileType = 255 - aux TagImageWidth = 256 - aux TagImageLength = 257 - aux TagBitsPerSample = 258 - aux TagCompression = 259 - aux TagPhotometricInterpretation = 262 - aux TagFillOrder = 266 - aux TagDocumentName = 269 - aux TagImageDescription = 270 - aux TagStripOffsets = 273 - aux TagOrientation = 274 - aux TagSamplesPerPixel = 277 - aux TagRowPerStrip = 278 - aux TagStripByteCounts = 279 - aux TagXResolution = 282 - aux TagYResolution = 283 - aux TagPlanarConfiguration = 284 - aux TagXPosition = 286 - aux TagYPosition = 287 - aux TagResolutionUnit = 296 - aux TagSoftware = 305 - aux TagArtist = 315 - aux TagColorMap = 320 - aux TagTileWidth = 322 - aux TagTileLength = 323 - aux TagTileOffset = 324 - aux TagTileByteCount = 325 - aux TagInkSet = 332 - aux TagExtraSample = 338 - aux TagSampleFormat = 339 - aux TagYCbCrCoeff = 529 - aux TagJpegProc = 512 - aux TagJPEGInterchangeFormat = 513 - aux TagJPEGInterchangeFormatLength = 514 - aux TagJPEGRestartInterval = 515 - aux TagJPEGLosslessPredictors = 517 - aux TagJPEGPointTransforms = 518 - aux TagJPEGQTables = 519 - aux TagJPEGDCTables = 520 - aux TagJPEGACTables = 521 - aux TagYCbCrSubsampling = 530 - aux TagYCbCrPositioning = 531 - aux TagReferenceBlackWhite = 532 - aux (TagUnknown v) = v - -instance BinaryParam Endianness TiffTag where - getP endianness = tagOfWord16 <$> getP endianness - putP endianness = putP endianness . word16OfTag - -data ExtendedDirectoryData = - ExtendedDataNone - | ExtendedDataAscii !B.ByteString - | ExtendedDataShort !(V.Vector Word16) - | ExtendedDataLong !(V.Vector Word32) - deriving (Eq, Show) - -instance BinaryParam (Endianness, ImageFileDirectory) ExtendedDirectoryData where - putP (endianness, _) = dump - where - dump ExtendedDataNone = pure () - dump (ExtendedDataAscii bstr) = putByteString bstr - dump (ExtendedDataShort shorts) = V.mapM_ (putP endianness) shorts - dump (ExtendedDataLong longs) = V.mapM_ (putP endianness) longs - - getP (endianness, ifd) = fetcher ifd - where - align ImageFileDirectory { ifdOffset = offset } = do - readed <- bytesRead - skip . fromIntegral $ fromIntegral offset - readed - - getE :: (BinaryParam Endianness a) => Get a - getE = getP endianness - - getVec count = V.replicateM (fromIntegral count) - - fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = - align ifd >> (ExtendedDataAscii <$> getByteString (fromIntegral count)) - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = - pure . ExtendedDataShort $ V.fromListN 2 valList - where high = fromIntegral $ ofs `unsafeShiftR` 16 - low = fromIntegral $ ofs .&. 0xFFFF - valList = case endianness of - EndianLittle -> [low, high] - EndianBig -> [high, low] - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = - align ifd >> (ExtendedDataShort <$> getVec count getE) - fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = - align ifd >> (ExtendedDataLong <$> getVec count getE) - fetcher _ = pure ExtendedDataNone - -data TiffSampleFormat = - TiffSampleUint - | TiffSampleInt - | TiffSampleDouble - | TiffSampleUnknown - deriving Eq - -unpackSampleFormat :: Word32 -> Get TiffSampleFormat -unpackSampleFormat = aux - where - aux 1 = pure TiffSampleUint - aux 2 = pure TiffSampleInt - aux 3 = pure TiffSampleDouble - aux 4 = pure TiffSampleUnknown - aux v = fail $ "Undefined data format (" ++ show v ++ ")" - -data ImageFileDirectory = ImageFileDirectory - { ifdIdentifier :: !TiffTag - , ifdType :: !IfdType - , ifdCount :: !Word32 - , ifdOffset :: !Word32 - , ifdExtended :: !ExtendedDirectoryData - } +data TiffInfo = TiffInfo + { tiffHeader :: TiffHeader + , tiffWidth :: Word32 + , tiffHeight :: Word32 + , tiffColorspace :: TiffColorspace + , tiffSampleCount :: Word32 + , tiffRowPerStrip :: Word32 + , tiffPlaneConfiguration :: TiffPlanarConfiguration + , tiffSampleFormat :: [TiffSampleFormat] + , tiffBitsPerSample :: V.Vector Word32 + , tiffCompression :: TiffCompression + , tiffStripSize :: V.Vector Word32 + , tiffOffsets :: V.Vector Word32 + , tiffPalette :: Maybe (Image PixelRGB16) + , tiffYCbCrSubsampling :: V.Vector Word32 + , tiffExtraSample :: Maybe ExtraSample + , tiffPredictor :: Predictor + , tiffMetadatas :: Metadatas + } -unLong :: String -> ExtendedDirectoryData -> Get (V.Vector Word32) -unLong _ (ExtendedDataShort v) = pure $ V.map fromIntegral v -unLong _ (ExtendedDataLong v) = pure v +unLong :: String -> ExifData -> Get (V.Vector Word32) +unLong _ (ExifLong v) = pure $ V.singleton v +unLong _ (ExifShort v) = pure $ V.singleton (fromIntegral v) +unLong _ (ExifShorts v) = pure $ V.map fromIntegral v +unLong _ (ExifLongs v) = pure v unLong errMessage _ = fail errMessage -cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory -cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd - where aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } - aux _ = ifd -cleanImageFileDirectory _ ifd = ifd - -instance BinaryParam Endianness ImageFileDirectory where - getP endianness = - ImageFileDirectory <$> getE <*> getE <*> getE <*> getE - <*> pure ExtendedDataNone - where getE :: (BinaryParam Endianness a) => Get a - getE = getP endianness - - putP endianness ifd =do - let putE :: (BinaryParam Endianness a) => a -> Put - putE = putP endianness - putE $ ifdIdentifier ifd - putE $ ifdType ifd - putE $ ifdCount ifd - putE $ ifdOffset ifd - -instance BinaryParam Endianness [ImageFileDirectory] where - getP endianness = do - count <- getP endianness :: Get Word16 - rez <- replicateM (fromIntegral count) $ getP endianness - _ <- getP endianness :: Get Word32 - pure rez - - putP endianness lst = do - let count = fromIntegral $ length lst :: Word16 - putP endianness count - mapM_ (putP endianness) lst - putP endianness (0 :: Word32) - -fetchExtended :: Endianness -> [ImageFileDirectory] -> Get [ImageFileDirectory] -fetchExtended endian = mapM $ \ifd -> do - v <- getP (endian, ifd) - pure $ ifd { ifdExtended = v } - -findIFD :: String -> TiffTag -> [ImageFileDirectory] +findIFD :: String -> ExifTag -> [ImageFileDirectory] -> Get ImageFileDirectory findIFD errorMessage tag lst = - case [v | v <- lst, ifdIdentifier v == tag] of - [] -> fail errorMessage - (x:_) -> pure x + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> fail errorMessage + (x:_) -> pure x findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16)) findPalette ifds = case [v | v <- ifds, ifdIdentifier v == TagColorMap] of - (ImageFileDirectory { ifdExtended = ExtendedDataShort vec }:_) -> + (ImageFileDirectory { ifdExtended = ExifShorts vec }:_) -> pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx where pixelCount = V.length vec `div` 3 axx v = vec `V.unsafeIndex` (idx + color * pixelCount) @@ -463,34 +113,34 @@ _ -> pure Nothing -findIFDData :: String -> TiffTag -> [ImageFileDirectory] -> Get Word32 +findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32 findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst -findIFDDefaultData :: Word32 -> TiffTag -> [ImageFileDirectory] -> Get Word32 +findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32 findIFDDefaultData d tag lst = case [v | v <- lst, ifdIdentifier v == tag] of [] -> pure d (x:_) -> pure $ ifdOffset x -findIFDExt :: String -> TiffTag -> [ImageFileDirectory] -> Get ExtendedDirectoryData +findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData findIFDExt msg tag lst = do val <- findIFD msg tag lst case val of ImageFileDirectory { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> - pure . ExtendedDataShort . V.singleton $ fromIntegral ofs + pure . ExifShorts . V.singleton $ fromIntegral ofs ImageFileDirectory { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> - pure . ExtendedDataLong . V.singleton $ fromIntegral ofs + pure . ExifLongs . V.singleton $ fromIntegral ofs ImageFileDirectory { ifdExtended = v } -> pure v -findIFDExtDefaultData :: [Word32] -> TiffTag -> [ImageFileDirectory] +findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory] -> Get [Word32] findIFDExtDefaultData d tag lst = case [v | v <- lst, ifdIdentifier v == tag] of [] -> pure d - (ImageFileDirectory { ifdExtended = ExtendedDataNone }:_) -> return d + (ImageFileDirectory { ifdExtended = ExifNone }:_) -> return d (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x) where errorMessage = "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x) @@ -501,88 +151,6 @@ instance Show (Image PixelRGB16) where show _ = "Image PixelRGB16" -} -data ExtraSample - = ExtraSampleUnspecified -- ^ 0 - | ExtraSampleAssociatedAlpha -- ^ 1 - | ExtraSampleUnassociatedAlpha -- ^ 2 - -codeOfExtraSample :: ExtraSample -> Word16 -codeOfExtraSample ExtraSampleUnspecified = 0 -codeOfExtraSample ExtraSampleAssociatedAlpha = 1 -codeOfExtraSample ExtraSampleUnassociatedAlpha = 2 - -data TiffInfo = TiffInfo - { tiffHeader :: TiffHeader - , tiffWidth :: Word32 - , tiffHeight :: Word32 - , tiffColorspace :: TiffColorspace - , tiffSampleCount :: Word32 - , tiffRowPerStrip :: Word32 - , tiffPlaneConfiguration :: TiffPlanarConfiguration - , tiffSampleFormat :: [TiffSampleFormat] - , tiffBitsPerSample :: V.Vector Word32 - , tiffCompression :: TiffCompression - , tiffStripSize :: V.Vector Word32 - , tiffOffsets :: V.Vector Word32 - , tiffPalette :: Maybe (Image PixelRGB16) - , tiffYCbCrSubsampling :: V.Vector Word32 - , tiffExtraSample :: Maybe ExtraSample - } - -data TiffColorspace = - TiffMonochromeWhite0 -- ^ 0 - | TiffMonochrome -- ^ 1 - | TiffRGB -- ^ 2 - | TiffPaleted -- ^ 3 - | TiffTransparencyMask -- ^ 4 - | TiffCMYK -- ^ 5 - | TiffYCbCr -- ^ 6 - | TiffCIELab -- ^ 8 - -packPhotometricInterpretation :: TiffColorspace -> Word16 -packPhotometricInterpretation = aux - where - aux TiffMonochromeWhite0 = 0 - aux TiffMonochrome = 1 - aux TiffRGB = 2 - aux TiffPaleted = 3 - aux TiffTransparencyMask = 4 - aux TiffCMYK = 5 - aux TiffYCbCr = 6 - aux TiffCIELab = 8 - -unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace -unpackPhotometricInterpretation = aux - where aux 0 = pure TiffMonochromeWhite0 - aux 1 = pure TiffMonochrome - aux 2 = pure TiffRGB - aux 3 = pure TiffPaleted - aux 4 = pure TiffTransparencyMask - aux 5 = pure TiffCMYK - aux 6 = pure TiffYCbCr - aux 8 = pure TiffCIELab - aux v = fail $ "Unrecognized color space " ++ show v - -unPackCompression :: Word32 -> Get TiffCompression -unPackCompression = aux - where - aux 0 = pure CompressionNone - aux 1 = pure CompressionNone - aux 2 = pure CompressionModifiedRLE - aux 5 = pure CompressionLZW - aux 6 = pure CompressionJPEG - aux 32773 = pure CompressionPackBit - aux v = fail $ "Unknown compression scheme " ++ show v - -packCompression :: TiffCompression -> Word16 -packCompression = aux - where - aux CompressionNone = 1 - aux CompressionModifiedRLE = 2 - aux CompressionLZW = 5 - aux CompressionJPEG = 6 - aux CompressionPackBit = 32773 - copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int copyByteString str vec stride startWrite (from, count) = inner startWrite fromi @@ -614,7 +182,7 @@ choice -- data - | 0 <= v = do + | 0 <= v = copyByteString str outVec stride writeIdx (fromIntegral $ i + 1, fromIntegral v + 1) >>= loop (i + 2 + fromIntegral v) @@ -739,6 +307,33 @@ looperBe (writeIndex + stride) (readIndex + 4) +instance Unpackable Float where + type StorageType Float = Float + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ s = M.new $ s * 4 + mergeBackTempBuffer :: forall s. Float + -> Endianness + -> M.STVector s Word8 + -> Int + -> Int + -> Word32 + -> Int + -> M.STVector s (StorageType Float) + -> ST s () + mergeBackTempBuffer _ endianness tempVec lineSize index size stride outVec = + let outVecWord32 :: M.STVector s Word32 + outVecWord32 = M.unsafeCast outVec + in mergeBackTempBuffer (0 :: Word32) + endianness + tempVec + lineSize + index + size + stride + outVecWord32 + data Pack4 = Pack4 instance Unpackable Pack4 where @@ -948,16 +543,24 @@ idxVector = V.enumFromN 0 stride sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo) + when (tiffPredictor nfo == PredictorHorizontalDifferencing) $ do + let f _ c1 c2 = c1 + c2 + forM_ [0 .. height - 1] $ \y -> + forM_ [1 .. width - 1] $ \x -> do + p <- readPixel mutableImage (x - 1) y + q <- readPixel mutableImage x y + writePixel mutableImage x y $ mixWith f p q + unsafeFreezeImage mutableImage -ifdSingleLong :: TiffTag -> Word32 -> Writer [ImageFileDirectory] () +ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] () ifdSingleLong tag = ifdMultiLong tag . V.singleton -ifdSingleShort :: Endianness -> TiffTag -> Word16 +ifdSingleShort :: Endianness -> ExifTag -> Word16 -> Writer [ImageFileDirectory] () ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral -ifdMultiLong :: TiffTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () +ifdMultiLong :: ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () ifdMultiLong tag v = tell . pure $ ImageFileDirectory { ifdIdentifier = tag , ifdType = TypeLong @@ -966,10 +569,10 @@ , ifdExtended = extended } where (offset, extended) - | V.length v > 1 = (0, ExtendedDataLong v) - | otherwise = (V.head v, ExtendedDataNone) + | V.length v > 1 = (0, ExifLongs v) + | otherwise = (V.head v, ExifNone) -ifdMultiShort :: Endianness -> TiffTag -> V.Vector Word32 +ifdMultiShort :: Endianness -> ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory { ifdIdentifier = tag @@ -980,98 +583,60 @@ } where size = fromIntegral $ V.length v (offset, extended) - | size > 2 = (0, ExtendedDataShort $ V.map fromIntegral v) + | size > 2 = (0, ExifShorts $ V.map fromIntegral v) | size == 2 = let v1 = fromIntegral $ V.head v v2 = fromIntegral $ v `V.unsafeIndex` 1 in case endian of - EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExtendedDataNone) - EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExtendedDataNone) + EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExifNone) + EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExifNone) | otherwise = case endian of - EndianLittle -> (V.head v, ExtendedDataNone) - EndianBig -> (V.head v `unsafeShiftL` 16, ExtendedDataNone) - --- | All the IFD must be written in order according to the tag --- value of the IFD. To avoid getting to much restriction in the --- serialization code, just sort it. -orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] -orderIfdByTag = sortBy comparer - where comparer a b = compare t1 t2 - where t1 = word16OfTag $ ifdIdentifier a - t2 = word16OfTag $ ifdIdentifier b - --- | Given an official offset and a list of IFD, update the offset information --- of the IFD with extended data. -setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> [ImageFileDirectory] -setupIfdOffsets initialOffset lst = snd $ mapAccumL updater startExtended lst - where ifdElementCount = fromIntegral $ length lst - ifdSize = 12 - ifdCountSize = 2 - nextOffsetSize = 4 - startExtended = initialOffset - + ifdElementCount * ifdSize - + ifdCountSize + nextOffsetSize - - updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataAscii b }) = - (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) - updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataLong v }) - | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) - , ifd { ifdOffset = ix } ) - updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataShort v }) - | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) - , ifd { ifdOffset = ix }) - updater ix ifd = (ix, ifd) + EndianLittle -> (V.head v, ExifNone) + EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone) instance BinaryParam B.ByteString TiffInfo where - putP rawData nfo = do - put $ tiffHeader nfo - - let ifdStartOffset = hdrOffset $ tiffHeader nfo - endianness = hdrEndianness $ tiffHeader nfo - - ifdShort = ifdSingleShort endianness - ifdShorts = ifdMultiShort endianness - list = setupIfdOffsets ifdStartOffset . orderIfdByTag . execWriter $ do - ifdSingleLong TagImageWidth $ tiffWidth nfo - ifdSingleLong TagImageLength $ tiffHeight nfo - ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo - ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo - ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo - ifdShort TagPhotometricInterpretation - . packPhotometricInterpretation - $ tiffColorspace nfo - ifdShort TagPlanarConfiguration - . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo - ifdShort TagCompression . packCompression - $ tiffCompression nfo - ifdMultiLong TagStripOffsets $ tiffOffsets nfo + putP rawData nfo = putP rawData (tiffHeader nfo, [list]) where + endianness = hdrEndianness $ tiffHeader nfo - ifdMultiLong TagStripByteCounts $ tiffStripSize nfo + ifdShort = ifdSingleShort endianness + ifdShorts = ifdMultiShort endianness - maybe (return ()) - (ifdShort TagExtraSample . codeOfExtraSample) - $ tiffExtraSample nfo + list = execWriter $ do + ifdSingleLong TagImageWidth $ tiffWidth nfo + ifdSingleLong TagImageLength $ tiffHeight nfo + ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo + ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo + ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo + ifdShort TagPhotometricInterpretation + . packPhotometricInterpretation + $ tiffColorspace nfo + ifdShort TagPlanarConfiguration + . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo + ifdMultiLong TagSampleFormat + . V.fromList + . map packSampleFormat + $ tiffSampleFormat nfo + ifdShort TagCompression . packCompression + $ tiffCompression nfo + ifdMultiLong TagStripOffsets $ tiffOffsets nfo - let subSampling = tiffYCbCrSubsampling nfo - when (not $ V.null subSampling) $ - ifdShorts TagYCbCrSubsampling subSampling + ifdMultiLong TagStripByteCounts $ tiffStripSize nfo - putByteString rawData - putP endianness list - mapM_ (\ifd -> putP (endianness, ifd) $ ifdExtended ifd) list + maybe (return ()) + (ifdShort TagExtraSample . codeOfExtraSample) + $ tiffExtraSample nfo - getP _ = do - hdr <- get - readed <- bytesRead - skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed - let endian = hdrEndianness hdr + let subSampling = tiffYCbCrSubsampling nfo + unless (V.null subSampling) $ + ifdShorts TagYCbCrSubsampling subSampling - ifd <- fmap (cleanImageFileDirectory endian) <$> getP endian - cleaned <- fetchExtended endian ifd + getP rawData = do + (hdr, cleanedFull :: [[ImageFileDirectory]]) <- getP rawData - let dataFind str tag = findIFDData str tag cleaned + let cleaned = concat cleanedFull + dataFind str tag = findIFDData str tag cleaned dataDefault def tag = findIFDDefaultData def tag cleaned extFind str tag = findIFDExt str tag cleaned extDefault def tag = findIFDExtDefaultData def tag cleaned @@ -1098,8 +663,17 @@ <*> findPalette cleaned <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) <*> pure Nothing + <*> (dataDefault 1 TagPredictor + >>= predictorOfConstant) + <*> pure (extractTiffMetadata cleaned) -unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage +palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16 +palette16Of p = Palette' + { _paletteSize = imageWidth p + , _paletteData = imageData p + } + +unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage -- | while mandatory some images don't put correct -- rowperstrip. So replacing 0 with actual image height. unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } = @@ -1110,75 +684,62 @@ , tiffPalette = Just p } | lst == V.singleton 8 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips (0 :: Word8) file nfo - in - pure . ImageRGB16 $ applyPalette gathered - + pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p | lst == V.singleton 4 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips Pack4 file nfo - in - pure . ImageRGB16 $ applyPalette gathered - + pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p | lst == V.singleton 2 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips Pack2 file nfo - in - pure . ImageRGB16 $ applyPalette gathered + pure . PalettedRGB16 (gatherStrips Pack2 file nfo) $ palette16Of p unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo -unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } - | otherwise = do +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) case img of - ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i - ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i - ImageYA8 i -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a - in pure . ImageYA8 $ pixelMap negative i - ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a - in pure . ImageYA16 $ pixelMap negative i - _ -> fail $ "Unsupported color type used with colorspace MonochromeWhite0" + TrueColorImage (ImageY8 i) -> pure . TrueColorImage . ImageY8 $ pixelMap (maxBound -) i + TrueColorImage (ImageY16 i) -> pure . TrueColorImage . ImageY16 $ pixelMap (maxBound -) i + TrueColorImage (ImageYA8 i) -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a + in pure . TrueColorImage . ImageYA8 $ pixelMap negative i + TrueColorImage (ImageYA16 i) -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a + in pure . TrueColorImage . ImageYA16 $ pixelMap negative i + _ -> Left "Unsupported color type used with colorspace MonochromeWhite0" unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.singleton 2 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.singleton 4 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.singleton 8 && all (TiffSampleUint ==) format = - pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo | lst == V.singleton 12 && all (TiffSampleUint ==) format = - pure . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.singleton 16 && all (TiffSampleUint ==) format = - pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageY16 $ gatherStrips (0 :: Word16) file nfo | lst == V.singleton 32 && all (TiffSampleUint ==) format = - let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 - img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 - in - pure . ImageY16 $ pixelMap (toWord16) img + let img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + in pure $ TrueColorImage $ ImageY32 $ img + | lst == V.singleton 32 && all (TiffSampleFloat ==) format = + let img = gatherStrips (0 :: Float) file nfo :: Image PixelF + in pure $ TrueColorImage $ ImageYF $ img + | lst == V.singleton 64 = Left "Failure to unpack TIFF file, 64-bit samples unsupported." | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = - pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = - pure . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = - pure . ImageYA8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = - pure . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = - pure . ImageYA16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo where expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) @@ -1187,7 +748,7 @@ , tiffPlaneConfiguration = PlanarConfigContig , tiffSampleFormat = format } | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageYCbCr8 $ gatherStrips cbcrConf file nfo + pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf file nfo where defaulting 0 = 2 defaulting n = n @@ -1204,54 +765,73 @@ , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst , tiffSampleFormat = format } -- some files are a little bit borked... | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo -unpack _ _ = fail "Failure to unpack TIFF file" +unpack _ _ = Left "Failure to unpack TIFF file" -- | Decode a tiff encoded image while preserving the underlying -- pixel type (except for Y32 which is truncated to 16 bits). -- --- This function can output the following pixel types: +-- This function can output the following images: -- --- * PixelY8 +-- * 'ImageY8' -- --- * PixelY16 +-- * 'ImageY16' -- --- * PixelYA8 +-- * 'ImageY32' -- --- * PixelYA16 +-- * 'ImageYF' -- --- * PixelRGB8 +-- * 'ImageYA8' -- --- * PixelRGB16 +-- * 'ImageYA16' -- --- * PixelRGBA8 +-- * 'ImageRGB8' -- --- * PixelRGBA16 +-- * 'ImageRGB16' -- --- * PixelCMYK8 +-- * 'ImageRGBA8' -- --- * PixelCMYK16 +-- * 'ImageRGBA16' -- +-- * 'ImageCMYK8' +-- +-- * 'ImageCMYK16' +-- decodeTiff :: B.ByteString -> Either String DynamicImage -decodeTiff file = runGetStrict (getP file) file >>= unpack file +decodeTiff = fmap fst . decodeTiffWithMetadata +-- | Like 'decodeTiff' but also provides some metdata present +-- in the Tiff file. +-- +-- The metadata extracted are the 'Codec.Picture.Metadata.DpiX' & +-- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations. +decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeTiffWithMetadata str = first palettedToTrueColor <$> decodeTiffWithPaletteAndMetadata str + +-- | Decode TIFF and provide separated palette and metadata +decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeTiffWithPaletteAndMetadata file = runGetStrict (getP file) file >>= go + where + go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo + + -- | Class defining which pixel types can be serialized in a -- Tiff file. class (Pixel px) => TiffSaveable px where @@ -1263,12 +843,22 @@ subSamplingInfo :: px -> V.Vector Word32 subSamplingInfo _ = V.empty + sampleFormat :: px -> [TiffSampleFormat] + sampleFormat _ = [TiffSampleUint] + instance TiffSaveable Pixel8 where colorSpaceOfPixel _ = TiffMonochrome instance TiffSaveable Pixel16 where colorSpaceOfPixel _ = TiffMonochrome +instance TiffSaveable Pixel32 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable PixelF where + colorSpaceOfPixel _ = TiffMonochrome + sampleFormat _ = [TiffSampleFloat] + instance TiffSaveable PixelYA8 where colorSpaceOfPixel _ = TiffMonochrome extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha @@ -1308,7 +898,7 @@ where intSampleCount = componentCount (undefined :: px) sampleCount = fromIntegral intSampleCount - sampleType = (undefined :: PixelBaseComponent px) + sampleType = undefined :: PixelBaseComponent px pixelData = imageData img rawPixelData = toByteString pixelData @@ -1328,10 +918,10 @@ , tiffWidth = width , tiffHeight = height , tiffColorspace = colorSpaceOfPixel (undefined :: px) - , tiffSampleCount = fromIntegral $ sampleCount + , tiffSampleCount = fromIntegral sampleCount , tiffRowPerStrip = fromIntegral $ imageHeight img , tiffPlaneConfiguration = PlanarConfigContig - , tiffSampleFormat = [TiffSampleUint] + , tiffSampleFormat = sampleFormat (undefined :: px) , tiffBitsPerSample = V.replicate intSampleCount bitPerSample , tiffCompression = CompressionNone , tiffStripSize = V.singleton imageSize @@ -1339,9 +929,13 @@ , tiffPalette = Nothing , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px) , tiffExtraSample = extraSampleCodeOfPixel (undefined :: px) + , tiffPredictor = PredictorNone -- not used when writing + , tiffMetadatas = mempty } -- | Helper function to directly write an image as a tiff on disk. writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO () writeTiff path img = Lb.writeFile path $ encodeTiff img + +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/Tiff/Internal/Metadata.hs b/src/Codec/Picture/Tiff/Internal/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tiff/Internal/Metadata.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE CPP #-} +module Codec.Picture.Tiff.Internal.Metadata + ( extractTiffMetadata + , encodeTiffStringMetadata + , exifOffsetIfd + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Data.Foldable( foldMap ) +import Control.Applicative( (<$>) ) +#endif + +import Data.Bits( unsafeShiftL, (.|.) ) +import Data.Foldable( find ) +import Data.List( sortBy ) +import Data.Function( on ) +import qualified Data.Foldable as F +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif +import Codec.Picture.Metadata( Metadatas ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Codec.Picture.Metadata as Met +import qualified Data.Vector.Generic as V +import Codec.Picture.Tiff.Internal.Types +import Codec.Picture.Metadata( extractExifMetas ) +import Codec.Picture.Metadata.Exif + +exifOffsetIfd :: ImageFileDirectory +exifOffsetIfd = ImageFileDirectory + { ifdIdentifier = TagExifOffset + , ifdCount = 1 + , ifdType = TypeLong + , ifdOffset = 0 + , ifdExtended = ExifNone + } + +typeOfData :: ExifData -> IfdType +typeOfData d = case d of + ExifNone -> error "Impossible - typeOfData : ExifNone" + ExifIFD _exifs -> error "Impossible - typeOfData : ExifIFD" + ExifLong _l -> TypeLong + ExifLongs _l -> TypeLong + ExifShort _s -> TypeShort + ExifShorts _s -> TypeShort + ExifString _str -> TypeAscii + ExifUndefined _undef -> TypeUndefined + ExifRational _r1 _r2 -> TypeRational + ExifSignedRational _sr1 _sr2 -> TypeSignedRational + +makeIfd :: ExifTag -> ExifData -> ImageFileDirectory +makeIfd t (ExifShort v) = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeShort + , ifdCount = 1 + , ifdOffset = fromIntegral v `unsafeShiftL` 16 + , ifdExtended = ExifNone + } +makeIfd t (ExifLong v) = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeLong + , ifdCount = 1 + , ifdOffset = fromIntegral v + , ifdExtended = ExifNone + } +makeIfd t d@(ExifShorts v) + | size == 2 = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeShort + , ifdCount = 2 + , ifdOffset = combined + , ifdExtended = ExifNone + } + | otherwise = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeShort + , ifdCount = size + , ifdOffset = 0 + , ifdExtended = d + } + where + size = fromIntegral $ F.length v + at i = fromIntegral $ v V.! i + combined = (at 0 `unsafeShiftL` 16) .|. at 1 +makeIfd t d@(ExifLongs v) + | size == 1 = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeLong + , ifdCount = 1 + , ifdOffset = v V.! 0 + , ifdExtended = ExifNone + } + | otherwise = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeLong + , ifdCount = size + , ifdOffset = 0 + , ifdExtended = d + } + where size = fromIntegral $ F.length v +makeIfd t s@(ExifString str) = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeAscii + , ifdCount = fromIntegral $ BC.length str + , ifdOffset = 0 + , ifdExtended = s + } +makeIfd t s@(ExifUndefined str) + | size > 4 = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeUndefined + , ifdCount = size + , ifdOffset = 0 + , ifdExtended = s + } + | otherwise = ImageFileDirectory + { ifdIdentifier = t + , ifdType = TypeUndefined + , ifdCount = size + , ifdOffset = ofs + , ifdExtended = ExifNone + } + where + size = fromIntegral $ BC.length str + at ix + | fromIntegral ix < size = fromIntegral $ B.index str ix `unsafeShiftL` (4 - (8 * ix)) + | otherwise = 0 + ofs = at 0 .|. at 1 .|. at 2 .|. at 3 +makeIfd t d = ImageFileDirectory + { ifdIdentifier = t + , ifdType = typeOfData d + , ifdCount = 1 + , ifdOffset = 0 + , ifdExtended = d + } + +encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory] +encodeTiffStringMetadata metas = sortBy (compare `on` word16OfTag . ifdIdentifier) $ allTags where + keyStr tag k = case Met.lookup k metas of + Nothing -> mempty + Just v -> pure . makeIfd tag . ExifString $ BC.pack v + allTags = copyright <> artist <> title <> description <> software <> allPureExif + + allPureExif = fmap (uncurry makeIfd) $ extractExifMetas metas + + copyright = keyStr TagCopyright Met.Copyright + artist = keyStr TagArtist Met.Author + title = keyStr TagDocumentName Met.Title + description = keyStr TagImageDescription Met.Description + software = keyStr TagSoftware Met.Software + +extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas +extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where + strMeta k = Met.singleton k . BC.unpack + exif ifd = + Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd + inserter acc (k, v) = Met.insert (Met.Exif k) v acc + exifShort ifd = + Met.singleton (Met.Exif $ ifdIdentifier ifd) . (ExifShort . fromIntegral) $ ifdOffset ifd + + go :: ImageFileDirectory -> Metadatas + go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of + (TagArtist, ExifString v) -> strMeta Met.Author v + (TagBitsPerSample, _) -> mempty + (TagColorMap, _) -> mempty + (TagCompression, _) -> mempty + (TagCopyright, ExifString v) -> strMeta Met.Copyright v + (TagDocumentName, ExifString v) -> strMeta Met.Title v + (TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst + (TagImageDescription, ExifString v) -> strMeta Met.Description v + (TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd + (TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd + (TagJPEGACTables, _) -> mempty + (TagJPEGDCTables, _) -> mempty + (TagJPEGInterchangeFormat, _) -> mempty + (TagJPEGInterchangeFormatLength, _) -> mempty + (TagJPEGLosslessPredictors, _) -> mempty + (TagJPEGPointTransforms, _) -> mempty + (TagJPEGQTables, _) -> mempty + (TagJPEGRestartInterval, _) -> mempty + (TagJpegProc, _) -> mempty + (TagModel, v) -> Met.singleton (Met.Exif TagModel) v + (TagMake, v) -> Met.singleton (Met.Exif TagMake) v + (TagOrientation, _) -> exifShort ifd + (TagResolutionUnit, _) -> mempty + (TagRowPerStrip, _) -> mempty + (TagSamplesPerPixel, _) -> mempty + (TagSoftware, ExifString v) -> strMeta Met.Software v + (TagStripByteCounts, _) -> mempty + (TagStripOffsets, _) -> mempty + (TagTileByteCount, _) -> mempty + (TagTileLength, _) -> mempty + (TagTileOffset, _) -> mempty + (TagTileWidth, _) -> mempty + (TagUnknown _, _) -> exif ifd + (TagXResolution, _) -> mempty + (TagYCbCrCoeff, _) -> mempty + (TagYCbCrPositioning, _) -> mempty + (TagYCbCrSubsampling, _) -> mempty + (TagYResolution, _) -> mempty + _ -> mempty + +byTag :: ExifTag -> ImageFileDirectory -> Bool +byTag t ifd = ifdIdentifier ifd == t + +data TiffResolutionUnit + = ResolutionUnitUnknown + | ResolutionUnitInch + | ResolutionUnitCentimeter + +unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit +unitOfIfd ifd = case (ifdType ifd, ifdOffset ifd) of + (TypeShort, 1) -> ResolutionUnitUnknown + (TypeShort, 2) -> ResolutionUnitInch + (TypeShort, 3) -> ResolutionUnitCentimeter + _ -> ResolutionUnitUnknown + +extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas +extractTiffDpiMetadata lst = go where + go = case unitOfIfd <$> find (byTag TagResolutionUnit) lst of + Nothing -> mempty + Just ResolutionUnitUnknown -> mempty + Just ResolutionUnitCentimeter -> findDpis Met.dotsPerCentiMeterToDotPerInch mempty + Just ResolutionUnitInch -> findDpis id mempty + + findDpis toDpi = + findDpi Met.DpiX TagXResolution toDpi . findDpi Met.DpiY TagYResolution toDpi + + findDpi k tag toDpi metas = case find (byTag tag) lst of + Nothing -> metas + Just ImageFileDirectory { ifdExtended = ExifRational num den } -> + Met.insert k (toDpi . fromIntegral $ num `div` den) metas + Just _ -> metas + +extractTiffMetadata :: [ImageFileDirectory] -> Metadatas +extractTiffMetadata lst = extractTiffDpiMetadata lst <> extractTiffStringMetadata lst + diff --git a/src/Codec/Picture/Tiff/Internal/Types.hs b/src/Codec/Picture/Tiff/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tiff/Internal/Types.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Codec.Picture.Tiff.Internal.Types + ( BinaryParam( .. ) + , Endianness( .. ) + , TiffHeader( .. ) + , TiffPlanarConfiguration( .. ) + , TiffCompression( .. ) + , IfdType( .. ) + , TiffColorspace( .. ) + , TiffSampleFormat( .. ) + , ImageFileDirectory( .. ) + , ExtraSample( .. ) + , Predictor( .. ) + + , planarConfgOfConstant + , constantToPlaneConfiguration + , unpackSampleFormat + , packSampleFormat + , word16OfTag + , unpackPhotometricInterpretation + , packPhotometricInterpretation + , codeOfExtraSample + , unPackCompression + , packCompression + , predictorOfConstant + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.DeepSeq( NFData(..) ) +import Control.Monad( forM_, when, replicateM, ) +import Data.Bits( (.&.), unsafeShiftR ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord16le, getWord16be + , getWord32le, getWord32be + , bytesRead + , skip + , getByteString + ) +import Data.Binary.Put( Put + , putWord16le, putWord16be + , putWord32le, putWord32be + , putByteString + ) +import Data.Function( on ) +import Data.List( sortBy, mapAccumL ) +import qualified Data.Vector as V +import qualified Data.ByteString as B +import Data.Int( Int32 ) +import Data.Word( Word8, Word16, Word32 ) +import GHC.Generics( Generic ) + +import Codec.Picture.Metadata.Exif +{-import Debug.Trace-} + +data Endianness + = EndianLittle + | EndianBig + deriving (Eq, Show) + +instance Binary Endianness where + put EndianLittle = putWord16le 0x4949 + put EndianBig = putWord16le 0x4D4D + + get = do + tag <- getWord16le + case tag of + 0x4949 -> return EndianLittle + 0x4D4D -> return EndianBig + _ -> fail "Invalid endian tag value" + +-- | Because having a polymorphic get with endianness is to nice +-- to pass on, introducing this helper type class, which is just +-- a superset of Binary, but formalising a parameter passing +-- into it. +class BinaryParam a b where + getP :: a -> Get b + putP :: a -> b -> Put + +data TiffHeader = TiffHeader + { hdrEndianness :: !Endianness + , hdrOffset :: {-# UNPACK #-} !Word32 + } + deriving (Eq, Show) + +instance BinaryParam Endianness Word16 where + putP EndianLittle = putWord16le + putP EndianBig = putWord16be + + getP EndianLittle = getWord16le + getP EndianBig = getWord16be + +instance BinaryParam Endianness Int32 where + putP en v = putP en $ (fromIntegral v :: Word32) + getP en = fromIntegral <$> (getP en :: Get Word32) + +instance BinaryParam Endianness Word32 where + putP EndianLittle = putWord32le + putP EndianBig = putWord32be + + getP EndianLittle = getWord32le + getP EndianBig = getWord32be + +instance Binary TiffHeader where + put hdr = do + let endian = hdrEndianness hdr + put endian + putP endian (42 :: Word16) + putP endian $ hdrOffset hdr + + get = do + endian <- get + magic <- getP endian + let magicValue = 42 :: Word16 + when (magic /= magicValue) + (fail "Invalid TIFF magic number") + TiffHeader endian <$> getP endian + +data TiffPlanarConfiguration + = PlanarConfigContig -- = 1 + | PlanarConfigSeparate -- = 2 + +planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration +planarConfgOfConstant 0 = pure PlanarConfigContig +planarConfgOfConstant 1 = pure PlanarConfigContig +planarConfgOfConstant 2 = pure PlanarConfigSeparate +planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" + +constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 +constantToPlaneConfiguration PlanarConfigContig = 1 +constantToPlaneConfiguration PlanarConfigSeparate = 2 + +data TiffCompression + = CompressionNone -- 1 + | CompressionModifiedRLE -- 2 + | CompressionLZW -- 5 + | CompressionJPEG -- 6 + | CompressionPackBit -- 32273 + +data IfdType + = TypeByte + | TypeAscii + | TypeShort + | TypeLong + | TypeRational + | TypeSByte + | TypeUndefined + | TypeSignedShort + | TypeSignedLong + | TypeSignedRational + | TypeFloat + | TypeDouble + deriving (Eq, Show, Generic) +instance NFData IfdType + +instance BinaryParam Endianness IfdType where + getP endianness = getP endianness >>= conv where + conv :: Word16 -> Get IfdType + conv v = case v of + 1 -> return TypeByte + 2 -> return TypeAscii + 3 -> return TypeShort + 4 -> return TypeLong + 5 -> return TypeRational + 6 -> return TypeSByte + 7 -> return TypeUndefined + 8 -> return TypeSignedShort + 9 -> return TypeSignedLong + 10 -> return TypeSignedRational + 11 -> return TypeFloat + 12 -> return TypeDouble + _ -> fail "Invalid TIF directory type" + + putP endianness = putP endianness . conv where + conv :: IfdType -> Word16 + conv v = case v of + TypeByte -> 1 + TypeAscii -> 2 + TypeShort -> 3 + TypeLong -> 4 + TypeRational -> 5 + TypeSByte -> 6 + TypeUndefined -> 7 + TypeSignedShort -> 8 + TypeSignedLong -> 9 + TypeSignedRational -> 10 + TypeFloat -> 11 + TypeDouble -> 12 + +instance BinaryParam Endianness ExifTag where + getP endianness = tagOfWord16 <$> getP endianness + putP endianness = putP endianness . word16OfTag + +data Predictor + = PredictorNone -- 1 + | PredictorHorizontalDifferencing -- 2 + deriving Eq + +predictorOfConstant :: Word32 -> Get Predictor +predictorOfConstant 1 = pure PredictorNone +predictorOfConstant 2 = pure PredictorHorizontalDifferencing +predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")" + +paddWrite :: B.ByteString -> Put +paddWrite str = putByteString str >> padding where + zero = 0 :: Word8 + padding = when (odd (B.length str)) $ put zero + +instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where + putP (endianness, _, _) = dump + where + dump ExifNone = pure () + dump (ExifLong _) = pure () + dump (ExifShort _) = pure () + dump (ExifIFD _) = pure () + dump (ExifString bstr) = paddWrite bstr + dump (ExifUndefined bstr) = paddWrite bstr + -- wrong if length == 2 + dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts + dump (ExifLongs longs) = V.mapM_ (putP endianness) longs + dump (ExifRational a b) = putP endianness a >> putP endianness b + dump (ExifSignedRational a b) = putP endianness a >> putP endianness b + + getP (endianness, maxi, ifd) = fetcher ifd + where + align ImageFileDirectory { ifdOffset = offset } act = do + readed <- bytesRead + let delta = fromIntegral offset - readed + if offset >= fromIntegral maxi || fromIntegral readed > offset then + pure ExifNone + else do + skip $ fromIntegral delta + act + + getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + getVec count = V.replicateM (fromIntegral count) + + immediateBytes ofs = + let bytes = [fromIntegral $ (ofs .&. 0xFF000000) `unsafeShiftR` (3 * 8) + ,fromIntegral $ (ofs .&. 0x00FF0000) `unsafeShiftR` (2 * 8) + ,fromIntegral $ (ofs .&. 0x0000FF00) `unsafeShiftR` (1 * 8) + ,fromIntegral $ ofs .&. 0x000000FF + ] + in case endianness of + EndianLittle -> reverse bytes + EndianBig -> bytes + + fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset + , ifdType = TypeLong + , ifdCount = 1 } = do + align ifd $ do + let byOffset = sortBy (compare `on` ifdOffset) + cleansIfds = fmap (cleanImageFileDirectory endianness) + subIfds <- cleansIfds . byOffset <$> getP endianness + cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds + pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] + {- + fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo + , ifdType = TypeLong + , ifdCount = 1 } = do + align ifd + subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness + cleaned <- fetchExtended endianness subIfds + pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] + -} + fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 = + align ifd $ ExifUndefined <$> getByteString (fromIntegral count) + fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } = + pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd) + (immediateBytes ofs) + fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 4 = + align ifd $ ExifString <$> getByteString (fromIntegral count) + fetcher ImageFileDirectory { ifdType = TypeAscii, ifdOffset = ofs } = + pure . ExifString . B.pack $ take (fromIntegral $ ifdCount ifd) + (immediateBytes ofs) + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = + pure . ExifShorts $ V.fromListN 2 valList + where high = fromIntegral $ ofs `unsafeShiftR` 16 + low = fromIntegral $ ofs .&. 0xFFFF + valList = case endianness of + EndianLittle -> [low, high] + EndianBig -> [high, low] + fetcher ImageFileDirectory { ifdType = TypeRational, ifdCount = 1 } = do + align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle + fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do + align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } = + pure . ExifShort . fromIntegral $ ifdOffset ifd + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = + align ifd $ ExifShorts <$> getVec count getE + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } = + pure . ExifLong . fromIntegral $ ifdOffset ifd + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = + align ifd $ ExifLongs <$> getVec count getE + fetcher _ = pure ExifNone + +cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory +cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd + where + aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } + aux _ = ifd +cleanImageFileDirectory _ ifd = ifd + +fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory] +fetchExtended endian maxi = mapM $ \ifd -> do + v <- getP (endian, maxi, ifd) + pure $ ifd { ifdExtended = v } + +-- | All the IFD must be written in order according to the tag +-- value of the IFD. To avoid getting to much restriction in the +-- serialization code, just sort it. +orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] +orderIfdByTag = sortBy comparer where + comparer a b = compare t1 t2 where + t1 = word16OfTag $ ifdIdentifier a + t2 = word16OfTag $ ifdIdentifier b + +-- | Given an official offset and a list of IFD, update the offset information +-- of the IFD with extended data. +setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> (Word32, [ImageFileDirectory]) +setupIfdOffsets initialOffset lst = mapAccumL updater startExtended lst + where ifdElementCount = fromIntegral $ length lst + ifdSize = 12 + ifdCountSize = 2 + nextOffsetSize = 4 + startExtended = initialOffset + + ifdElementCount * ifdSize + + ifdCountSize + nextOffsetSize + + paddedSize blob = fromIntegral $ blobLength + padding where + blobLength = B.length blob + padding = if odd blobLength then 1 else 0 + + updater ix ifd@(ImageFileDirectory { ifdIdentifier = TagExifOffset }) = + (ix, ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifUndefined b }) = + (ix + paddedSize b, ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifString b }) = + (ix + paddedSize b, ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v }) + | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) + , ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v }) + | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) + , ifd { ifdOffset = ix }) + updater ix ifd = (ix, ifd) + +instance BinaryParam B.ByteString (TiffHeader, [[ImageFileDirectory]]) where + putP rawData (hdr, ifds) = do + put hdr + putByteString rawData + let endianness = hdrEndianness hdr + (_, offseted) = mapAccumL + (\ix ifd -> setupIfdOffsets ix $ orderIfdByTag ifd) + (hdrOffset hdr) + ifds + forM_ offseted $ \list -> do + putP endianness list + mapM_ (\field -> putP (endianness, (0::Int), field) $ ifdExtended field) list + + getP raw = do + hdr <- get + readed <- bytesRead + skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed + let endian = hdrEndianness hdr + byOffset = sortBy (compare `on` ifdOffset) + cleanIfds = fmap (cleanImageFileDirectory endian) + + ifd <- cleanIfds . byOffset <$> getP endian + cleaned <- fetchExtended endian (B.length raw) ifd + return (hdr, [cleaned]) + +data TiffSampleFormat + = TiffSampleUint + | TiffSampleInt + | TiffSampleFloat + | TiffSampleUnknown + deriving Eq + +unpackSampleFormat :: Word32 -> Get TiffSampleFormat +unpackSampleFormat v = case v of + 1 -> pure TiffSampleUint + 2 -> pure TiffSampleInt + 3 -> pure TiffSampleFloat + 4 -> pure TiffSampleUnknown + vv -> fail $ "Undefined data format (" ++ show vv ++ ")" + +packSampleFormat :: TiffSampleFormat -> Word32 +packSampleFormat TiffSampleUint = 1 +packSampleFormat TiffSampleInt = 2 +packSampleFormat TiffSampleFloat = 3 +packSampleFormat TiffSampleUnknown = 4 + +data ImageFileDirectory = ImageFileDirectory + { ifdIdentifier :: !ExifTag -- Word16 + , ifdType :: !IfdType -- Word16 + , ifdCount :: !Word32 + , ifdOffset :: !Word32 + , ifdExtended :: !ExifData + } + deriving (Eq, Show, Generic) +instance NFData ImageFileDirectory + +instance BinaryParam Endianness ImageFileDirectory where + getP endianness = + ImageFileDirectory <$> getE <*> getE <*> getE <*> getE + <*> pure ExifNone + where getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + putP endianness ifd = do + let putE :: (BinaryParam Endianness a) => a -> Put + putE = putP endianness + putE $ ifdIdentifier ifd + putE $ ifdType ifd + putE $ ifdCount ifd + putE $ ifdOffset ifd + +instance BinaryParam Endianness [ImageFileDirectory] where + getP endianness = do + count <- getP endianness :: Get Word16 + rez <- replicateM (fromIntegral count) $ getP endianness + _ <- getP endianness :: Get Word32 + pure rez + + + putP endianness lst = do + let count = fromIntegral $ length lst :: Word16 + putP endianness count + mapM_ (putP endianness) lst + putP endianness (0 :: Word32) + +data TiffColorspace + = TiffMonochromeWhite0 -- ^ 0 + | TiffMonochrome -- ^ 1 + | TiffRGB -- ^ 2 + | TiffPaleted -- ^ 3 + | TiffTransparencyMask -- ^ 4 + | TiffCMYK -- ^ 5 + | TiffYCbCr -- ^ 6 + | TiffCIELab -- ^ 8 + + +packPhotometricInterpretation :: TiffColorspace -> Word16 +packPhotometricInterpretation v = case v of + TiffMonochromeWhite0 -> 0 + TiffMonochrome -> 1 + TiffRGB -> 2 + TiffPaleted -> 3 + TiffTransparencyMask -> 4 + TiffCMYK -> 5 + TiffYCbCr -> 6 + TiffCIELab -> 8 + +unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace +unpackPhotometricInterpretation v = case v of + 0 -> pure TiffMonochromeWhite0 + 1 -> pure TiffMonochrome + 2 -> pure TiffRGB + 3 -> pure TiffPaleted + 4 -> pure TiffTransparencyMask + 5 -> pure TiffCMYK + 6 -> pure TiffYCbCr + 8 -> pure TiffCIELab + vv -> fail $ "Unrecognized color space " ++ show vv + +data ExtraSample + = ExtraSampleUnspecified -- ^ 0 + | ExtraSampleAssociatedAlpha -- ^ 1 + | ExtraSampleUnassociatedAlpha -- ^ 2 + +codeOfExtraSample :: ExtraSample -> Word16 +codeOfExtraSample v = case v of + ExtraSampleUnspecified -> 0 + ExtraSampleAssociatedAlpha -> 1 + ExtraSampleUnassociatedAlpha -> 2 + +unPackCompression :: Word32 -> Get TiffCompression +unPackCompression v = case v of + 0 -> pure CompressionNone + 1 -> pure CompressionNone + 2 -> pure CompressionModifiedRLE + 5 -> pure CompressionLZW + 6 -> pure CompressionJPEG + 32773 -> pure CompressionPackBit + vv -> fail $ "Unknown compression scheme " ++ show vv + +packCompression :: TiffCompression -> Word16 +packCompression v = case v of + CompressionNone -> 1 + CompressionModifiedRLE -> 2 + CompressionLZW -> 5 + CompressionJPEG -> 6 + CompressionPackBit -> 32773 + diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs --- a/src/Codec/Picture/Types.hs +++ b/src/Codec/Picture/Types.hs @@ -1,29 +1,40 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- | Module provides basic types for image manipulation in the library. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | Module providing the basic types for image manipulation in the library. --- Defining the types used to store all those _Juicy Pixels_ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +-- Defined types are used to store all of those __Juicy Pixels__ module Codec.Picture.Types( -- * Types -- ** Image types Image( .. ) , MutableImage( .. ) , DynamicImage( .. ) + , PalettedImage( .. ) , Palette + , Palette'( .. ) -- ** Image functions , createMutableImage + , newMutableImage , freezeImage , unsafeFreezeImage , thawImage , unsafeThawImage + -- ** Image Lenses + , Traversal + , imagePixels + , imageIPixels + -- ** Pixel types , Pixel8 , Pixel16 @@ -39,6 +50,7 @@ , PixelCMYK8( .. ) , PixelCMYK16( .. ) , PixelYCbCr8( .. ) + , PixelYCbCrK8( .. ) -- * Type classes , ColorConvertible( .. ) @@ -53,9 +65,12 @@ , pixelMapXY , pixelFold , pixelFoldM + , pixelFoldMap , dynamicMap , dynamicPixelMap + , palettedToTrueColor + , palettedAsImage , dropAlphaLayer , withImage , zipPixelComponent3 @@ -85,19 +100,27 @@ -- * Packeable writing (unsafe but faster) , PackeablePixel( .. ) , fillImageWith - , unsafeWritePixelBetweenAt + , readPackedPixelAt , writePackedPixelAt + , unsafeWritePixelBetweenAt ) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid, mempty ) +import Control.Applicative( Applicative, pure, (<*>), (<$>) ) +#endif +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid( (<>) ) +#endif import Control.Monad( foldM, liftM, ap ) import Control.DeepSeq( NFData( .. ) ) -import Control.Monad.ST( runST ) +import Control.Monad.ST( ST, runST ) import Control.Monad.Primitive ( PrimMonad, PrimState ) import Foreign.ForeignPtr( castForeignPtr ) import Foreign.Storable ( Storable ) -import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.) ) +import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) ) +import Data.Typeable ( Typeable ) import Data.Word( Word8, Word16, Word32, Word64 ) -import Data.List( foldl' ) import Data.Vector.Storable ( (!) ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M @@ -131,7 +154,14 @@ -- component within each pixel. , imageData :: V.Vector (PixelBaseComponent a) } + deriving (Typeable) +instance (Eq (PixelBaseComponent a), Storable (PixelBaseComponent a)) + => Eq (Image a) where + a == b = imageWidth a == imageWidth b && + imageHeight a == imageHeight b && + imageData a == imageData b + -- | Type for the palette used in Gif & PNG files. type Palette = Image PixelRGB8 @@ -145,40 +175,51 @@ -- | Define the plane for the red color component data PlaneRed = PlaneRed + deriving (Typeable) -- | Define the plane for the green color component data PlaneGreen = PlaneGreen + deriving (Typeable) -- | Define the plane for the blue color component data PlaneBlue = PlaneBlue + deriving (Typeable) -- | Define the plane for the alpha (transparency) component data PlaneAlpha = PlaneAlpha + deriving (Typeable) -- | Define the plane for the luma component data PlaneLuma = PlaneLuma + deriving (Typeable) -- | Define the plane for the Cr component data PlaneCr = PlaneCr + deriving (Typeable) -- | Define the plane for the Cb component data PlaneCb = PlaneCb + deriving (Typeable) -- | Define plane for the cyan component of the -- CMYK color space. data PlaneCyan = PlaneCyan + deriving (Typeable) -- | Define plane for the magenta component of the -- CMYK color space. data PlaneMagenta = PlaneMagenta + deriving (Typeable) -- | Define plane for the yellow component of the -- CMYK color space. data PlaneYellow = PlaneYellow + deriving (Typeable) -- | Define plane for the black component of -- the CMYK color space. data PlaneBlack = PlaneBlack + deriving (Typeable) -- | Extract a color plane from an image given a present plane in the image -- examples: @@ -214,7 +255,7 @@ | comp >= padd = error $ "extractComponent : invalid component index (" ++ show comp ++ ", max:" ++ show padd ++ ")" | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane } - where plane = stride img 1 padd comp + where plane = stride img padd comp padd = componentCount (undefined :: a) -- | For any image with an alpha component (transparency), @@ -239,14 +280,6 @@ {-# INLINE getTransparency #-} getTransparency (PixelRGBA8 _ _ _ a) = a --- | Iteration from to n in monadic context, without data --- keeping. -lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () -{-# INLINE lineMap #-} -lineMap count f = go 0 - where go n | n >= count = return () - go n = f n >> go (n + 1) - lineFold :: (Monad m) => a -> Int -> (a -> Int -> m a) -> m a {-# INLINE lineFold #-} lineFold initial count f = go 0 initial @@ -254,19 +287,18 @@ go n acc = f acc n >>= go (n + 1) stride :: (Storable (PixelBaseComponent a)) - => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a) + => Image a -> Int -> Int -> V.Vector (PixelBaseComponent a) stride Image { imageWidth = w, imageHeight = h, imageData = array } - run padd firstComponent = runST $ do - let cell_count = w * h * run + padd firstComponent = runST $ do + let cell_count = w * h outArray <- M.new cell_count - let strideWrite write_idx _ | write_idx == cell_count = return () - strideWrite write_idx read_idx = do - lineMap (run - 1) $ \i -> - (outArray `M.unsafeWrite` (write_idx + i)) $ array `V.unsafeIndex` (read_idx + i) - strideWrite (write_idx + run) (read_idx + padd) + let go writeIndex _ | writeIndex >= cell_count = return () + go writeIndex readIndex = do + (outArray `M.unsafeWrite` writeIndex) $ array `V.unsafeIndex` readIndex + go (writeIndex + 1) $ readIndex + padd - strideWrite 0 firstComponent + go 0 firstComponent V.unsafeFreeze outArray instance NFData (Image a) where @@ -289,6 +321,7 @@ -- you should use the helpers functions. , mutableImageData :: M.STVector s (PixelBaseComponent a) } + deriving (Typeable) -- | `O(n)` Yield an immutable copy of an image by making a copy of it freezeImage :: (Storable (PixelBaseComponent px), PrimMonad m) @@ -304,6 +337,7 @@ -- The source image shouldn't be used after this operation. unsafeThawImage :: (Storable (PixelBaseComponent px), PrimMonad m) => Image px -> m (MutableImage (PrimState m) px) +{-# NOINLINE unsafeThawImage #-} unsafeThawImage (Image w h d) = MutableImage w h `liftM` V.unsafeThaw d -- | `O(1)` Unsafe convert a mutable image to an immutable one without copying. @@ -319,8 +353,17 @@ -> px -- ^ Background color -> m (MutableImage (PrimState m) px) createMutableImage width height background = - unsafeThawImage $ generateImage (\_ _ -> background) width height + generateMutableImage (\_ _ -> background) width height +-- | Create a mutable image with garbage as content. All data +-- is uninitialized. +newMutableImage :: forall px m. (Pixel px, PrimMonad m) + => Int -- ^ Width + -> Int -- ^ Height + -> m (MutableImage (PrimState m) px) +newMutableImage w h = MutableImage w h `liftM` M.new (w * h * compCount) + where compCount = componentCount (undefined :: px) + instance NFData (MutableImage s a) where rnf (MutableImage width height dat) = width `seq` height `seq` @@ -335,6 +378,8 @@ ImageY8 (Image Pixel8) -- | A greyscale image with 16bit components | ImageY16 (Image Pixel16) + -- | A greyscale image with 32bit components + | ImageY32 (Image Pixel32) -- | A greyscale HDR image | ImageYF (Image PixelF) -- | An image in greyscale with an alpha channel. @@ -357,7 +402,46 @@ | ImageCMYK8 (Image PixelCMYK8) -- | An image in the colorspace CMYK and 16 bits precision | ImageCMYK16 (Image PixelCMYK16) + deriving (Eq, Typeable) +-- | Type used to expose a palette extracted during reading. +-- Use `palettedAsImage` to convert it to a palette usable for +-- writing. +data Palette' px = Palette' + { -- | Number of element in pixels. + _paletteSize :: !Int + -- | Real data used by the palette. + , _paletteData :: !(V.Vector (PixelBaseComponent px)) + } + deriving Typeable + +-- | Convert a palette to an image. Used mainly for +-- backward compatibility. +palettedAsImage :: Palette' px -> Image px +palettedAsImage p = Image (_paletteSize p) 1 $ _paletteData p + +-- | Describe an image and it's potential associated +-- palette. If no palette is present, fallback to a +-- DynamicImage +data PalettedImage + = TrueColorImage DynamicImage -- ^ Fallback + | PalettedY8 (Image Pixel8) (Palette' Pixel8) + | PalettedRGB8 (Image Pixel8) (Palette' PixelRGB8) + | PalettedRGBA8 (Image Pixel8) (Palette' PixelRGBA8) + | PalettedRGB16 (Image Pixel8) (Palette' PixelRGB16) + deriving (Typeable) + +-- | Flatten a PalettedImage to a DynamicImage +palettedToTrueColor :: PalettedImage -> DynamicImage +palettedToTrueColor img = case img of + TrueColorImage d -> d + PalettedY8 i p -> ImageY8 $ toTrueColor 1 (_paletteData p) i + PalettedRGB8 i p -> ImageRGB8 $ toTrueColor 3 (_paletteData p) i + PalettedRGBA8 i p -> ImageRGBA8 $ toTrueColor 4 (_paletteData p) i + PalettedRGB16 i p -> ImageRGB16 $ toTrueColor 3 (_paletteData p) i + where + toTrueColor c vec = pixelMap (unsafePixelAt vec . (c *) . fromIntegral) + -- | Helper function to help extract information from dynamic -- image. To get the width of a dynamic image, you can use -- the following snippet: @@ -369,6 +453,7 @@ -> DynamicImage -> a dynamicMap f (ImageY8 i) = f i dynamicMap f (ImageY16 i) = f i +dynamicMap f (ImageY32 i) = f i dynamicMap f (ImageYF i) = f i dynamicMap f (ImageYA8 i) = f i dynamicMap f (ImageYA16 i) = f i @@ -389,7 +474,7 @@ -- without caring about colorspace, you can use the following snippet. -- -- > dynSquare :: DynamicImage -> DynamicImage --- > dynSquare = dynMap squareImage +-- > dynSquare = dynamicPixelMap squareImage -- > -- > squareImage :: Pixel a => Image a -> Image a -- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge @@ -401,6 +486,7 @@ where aux (ImageY8 i) = ImageY8 (f i) aux (ImageY16 i) = ImageY16 (f i) + aux (ImageY32 i) = ImageY32 (f i) aux (ImageYF i) = ImageYF (f i) aux (ImageYA8 i) = ImageYA8 (f i) aux (ImageYA16 i) = ImageYA16 (f i) @@ -416,6 +502,7 @@ instance NFData DynamicImage where rnf (ImageY8 img) = rnf img rnf (ImageY16 img) = rnf img + rnf (ImageY32 img) = rnf img rnf (ImageYF img) = rnf img rnf (ImageYA8 img) = rnf img rnf (ImageYA16 img) = rnf img @@ -453,7 +540,7 @@ -- data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8 -- Luminance {-# UNPACK #-} !Pixel8 -- Alpha value - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit Luminance (Y) and alpha (A) information. -- Values are stored in the following order: @@ -464,7 +551,7 @@ -- data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16 -- Luminance {-# UNPACK #-} !Pixel16 -- Alpha value - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Classic pixel type storing 8bit red, green and blue (RGB) information. -- Values are stored in the following order: @@ -478,8 +565,24 @@ data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red {-# UNPACK #-} !Pixel8 -- Green {-# UNPACK #-} !Pixel8 -- Blue - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) +-- | Pixel type storing value for the YCCK color space: +-- +-- * Y (Luminance) +-- +-- * Cb +-- +-- * Cr +-- +-- * Black +-- +data PixelYCbCrK8 = PixelYCbCrK8 {-# UNPACK #-} !Pixel8 + {-# UNPACK #-} !Pixel8 + {-# UNPACK #-} !Pixel8 + {-# UNPACK #-} !Pixel8 + deriving (Eq, Ord, Show, Typeable) + -- | Pixel type storing 16bit red, green and blue (RGB) information. -- Values are stored in the following order: -- @@ -492,7 +595,7 @@ data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red {-# UNPACK #-} !Pixel16 -- Green {-# UNPACK #-} !Pixel16 -- Blue - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | HDR pixel type storing floating point 32bit red, green and blue (RGB) information. -- Same value range and comments apply as for 'PixelF'. @@ -507,7 +610,7 @@ data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red {-# UNPACK #-} !PixelF -- Green {-# UNPACK #-} !PixelF -- Blue - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 8bit luminance, blue difference and red difference (YCbCr) information. -- Values are stored in the following order: @@ -521,7 +624,7 @@ data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance {-# UNPACK #-} !Pixel8 -- Cb blue difference {-# UNPACK #-} !Pixel8 -- Cr red difference - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 8bit cyan, magenta, yellow and black (CMYK) information. -- Values are stored in the following order: @@ -538,7 +641,7 @@ {-# UNPACK #-} !Pixel8 -- Magenta {-# UNPACK #-} !Pixel8 -- Yellow {-# UNPACK #-} !Pixel8 -- Black - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit cyan, magenta, yellow and black (CMYK) information. -- Values are stored in the following order: @@ -555,7 +658,7 @@ {-# UNPACK #-} !Pixel16 -- Magenta {-# UNPACK #-} !Pixel16 -- Yellow {-# UNPACK #-} !Pixel16 -- Black - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Classical pixel type storing 8bit red, green, blue and alpha (RGBA) information. @@ -573,7 +676,7 @@ {-# UNPACK #-} !Pixel8 -- Green {-# UNPACK #-} !Pixel8 -- Blue {-# UNPACK #-} !Pixel8 -- Alpha - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit red, green, blue and alpha (RGBA) information. -- Values are stored in the following order: @@ -590,7 +693,7 @@ {-# UNPACK #-} !Pixel16 -- Green {-# UNPACK #-} !Pixel16 -- Blue {-# UNPACK #-} !Pixel16 -- Alpha - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) -- | Definition of pixels used in images. Each pixel has a color space, and a representative -- component (Word8 or Float). @@ -702,6 +805,26 @@ convertImage :: Image a -> Image b convertImage = pixelMap convertPixel +generateMutableImage :: forall m px. (Pixel px, PrimMonad m) + => (Int -> Int -> px) -- ^ Generating function, with `x` and `y` params. + -> Int -- ^ Width in pixels + -> Int -- ^ Height in pixels + -> m (MutableImage (PrimState m) px) +{-# INLINE generateMutableImage #-} +generateMutableImage f w h = MutableImage w h `liftM` generated where + compCount = componentCount (undefined :: px) + + generated = do + arr <- M.new (w * h * compCount) + let lineGenerator _ !y | y >= h = return () + lineGenerator !lineIdx y = column lineIdx 0 + where column !idx !x | x >= w = lineGenerator idx $ y + 1 + column idx x = do + unsafeWritePixel arr idx $ f x y + column (idx + compCount) $ x + 1 + lineGenerator 0 0 + return arr + -- | Create an image given a function to generate pixels. -- The function will receive values from 0 to width-1 for the x parameter -- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper @@ -711,27 +834,17 @@ -- -- > imageCreator :: String -> IO () -- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300 --- > where pixelRenderer x y = PixelRGB8 x y 128 +-- > where pixelRenderer x y = PixelRGB8 (fromIntegral x) (fromIntegral y) 128 -- -generateImage :: forall a. (Pixel a) - => (Int -> Int -> a) -- ^ Generating function, with `x` and `y` params. +generateImage :: forall px. (Pixel px) + => (Int -> Int -> px) -- ^ Generating function, with `x` and `y` params. -> Int -- ^ Width in pixels -> Int -- ^ Height in pixels - -> Image a + -> Image px {-# INLINE generateImage #-} -generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated } - where compCount = componentCount (undefined :: a) - generated = runST $ do - arr <- M.new (w * h * compCount) - let lineGenerator _ y | y >= h = return () - lineGenerator lineIdx y = column lineIdx 0 - where column idx x | x >= w = lineGenerator idx $ y + 1 - column idx x = do - unsafeWritePixel arr idx $ f x y - column (idx + compCount) $ x + 1 - - lineGenerator 0 0 - V.unsafeFreeze arr +generateImage f w h = runST img where + img :: ST s (Image px) + img = generateMutableImage f w h >>= unsafeFreezeImage -- | Create an image using a monadic initializer function. -- The function will receive values from 0 to width-1 for the x parameter @@ -794,14 +907,23 @@ -- | Fold over the pixel of an image with a raster scan order: -- from top to bottom, left to right {-# INLINE pixelFold #-} -pixelFold :: (Pixel pixel) +pixelFold :: forall acc pixel. (Pixel pixel) => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = - foldl' columnFold initialAccumulator [0 .. h - 1] + columnFold 0 initialAccumulator 0 where - pixelFolder y acc x = f acc x y $ pixelAt img x y - columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] + !compCount = componentCount (undefined :: pixel) + !vec = imageData img + lfold !y acc !x !idx + | x >= w = columnFold (y + 1) acc idx + | otherwise = + lfold y (f acc x y $ unsafePixelAt vec idx) (x + 1) (idx + compCount) + + columnFold !y lineAcc !readIdx + | y >= h = lineAcc + | otherwise = lfold y lineAcc 0 readIdx + -- | Fold over the pixel of an image with a raster scan order: -- from top to bottom, left to right, carrying out a state pixelFoldM :: (Pixel pixel, Monad m) @@ -816,6 +938,20 @@ pixelFolder y acc x = action acc x y $ pixelAt img x y columnFold lineAcc y = lineFold lineAcc w (pixelFolder y) + +-- | Fold over the pixel of an image with a raster scan order: +-- from top to bottom, left to right. This functions is analog +-- to the foldMap from the 'Foldable' typeclass, but due to the +-- Pixel constraint, Image cannot be made an instance of it. +pixelFoldMap :: forall m px. (Pixel px, Monoid m) => (px -> m) -> Image px -> m +pixelFoldMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = folder 0 + where + compCount = componentCount (undefined :: px) + maxi = w * h * compCount + + folder idx | idx >= maxi = mempty + folder idx = f (unsafePixelAt vec idx) <> folder (idx + compCount) + -- | `map` equivalent for an image, working at the pixel level. -- Little example : a brightness function for an rgb image -- @@ -833,6 +969,7 @@ {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} +{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-} pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = Image w h pixels where sourceComponentCount = componentCount (undefined :: a) @@ -856,6 +993,81 @@ -- outside of this where block V.unsafeFreeze newArr + +-- | Helpers to embed a rankNTypes inside an Applicative +newtype GenST a = GenST { genAction :: forall s. ST s (M.STVector s a) } + +-- | Traversal type matching the definition in the Lens package. +type Traversal s t a b = + forall f. Applicative f => (a -> f b) -> s -> f t + +writePx :: Pixel px + => Int -> GenST (PixelBaseComponent px) -> px -> GenST (PixelBaseComponent px) +{-# INLINE writePx #-} +writePx idx act px = GenST $ do + vec <- genAction act + unsafeWritePixel vec idx px + return vec + +freezeGenST :: Pixel px + => Int -> Int -> GenST (PixelBaseComponent px) -> Image px +freezeGenST w h act = + Image w h (runST (genAction act >>= V.unsafeFreeze)) + +-- | Traversal in "raster" order, from left to right the top to bottom. +-- This traversal is matching pixelMap in spirit. +-- +-- Since 3.2.4 +imagePixels :: forall pxa pxb. (Pixel pxa, Pixel pxb) + => Traversal (Image pxa) (Image pxb) pxa pxb +{-# INLINE imagePixels #-} +imagePixels f Image { imageWidth = w, imageHeight = h, imageData = vec } = + freezeGenST w h <$> pixels + where + sourceComponentCount = componentCount (undefined :: pxa) + destComponentCount = componentCount (undefined :: pxb) + + maxi = w * h * sourceComponentCount + pixels = + go (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 + + go act readIdx _ | readIdx >= maxi = act + go act readIdx writeIdx = + go newAct (readIdx + sourceComponentCount) (writeIdx + destComponentCount) + where + px = f (unsafePixelAt vec readIdx) + newAct = writePx writeIdx <$> act <*> px + +-- | Traversal providing the pixel position with it's value. +-- The traversal in raster order, from lef to right, then top +-- to bottom. The traversal match pixelMapXY in spirit. +-- +-- Since 3.2.4 +imageIPixels :: forall pxa pxb. (Pixel pxa, Pixel pxb) + => Traversal (Image pxa) (Image pxb) (Int, Int, pxa) pxb +{-# INLINE imageIPixels #-} +imageIPixels f Image { imageWidth = w, imageHeight = h, imageData = vec } = + freezeGenST w h <$> pixels + where + sourceComponentCount = componentCount (undefined :: pxa) + destComponentCount = componentCount (undefined :: pxb) + + pixels = + lineMapper (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 0 + + lineMapper act _ _ y | y >= h = act + lineMapper act readIdxLine writeIdxLine y = + go act readIdxLine writeIdxLine 0 + where + go cact readIdx writeIdx x + | x >= w = lineMapper cact readIdx writeIdx $ y + 1 + | otherwise = do + let px = f (x, y, unsafePixelAt vec readIdx) + go (writePx writeIdx <$> cact <*> px) + (readIdx + sourceComponentCount) + (writeIdx + destComponentCount) + (x + 1) + -- | Just like `pixelMap` only the function takes the pixel coordinates as -- additional parameters. pixelMapXY :: forall a b. (Pixel a, Pixel b) @@ -928,7 +1140,7 @@ -- of an image or a pixel class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where -- | Compute the luminance part of a pixel - computeLuma :: a -> (PixelBaseComponent a) + computeLuma :: a -> PixelBaseComponent a -- | Extract a luma plane out of an image. This -- method is in the typeclass to help performant @@ -966,9 +1178,10 @@ instance LumaPlaneExtractable PixelRGBA8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b + computeLuma (PixelRGBA8 r g b _) = + floor $ (0.3 :: Double) * fromIntegral r + + 0.59 * fromIntegral g + + 0.11 * fromIntegral b instance LumaPlaneExtractable PixelYCbCr8 where {-# INLINE computeLuma #-} @@ -1035,6 +1248,10 @@ {-# INLINE promotePixel #-} promotePixel c = PixelRGB8 c c c +instance ColorConvertible Pixel8 PixelRGB16 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGB16 (fromIntegral c * 257) (fromIntegral c * 257) (fromIntegral c * 257) + instance ColorConvertible Pixel8 PixelRGBA8 where {-# INLINE promotePixel #-} promotePixel c = PixelRGBA8 c c c 255 @@ -1211,6 +1428,10 @@ {-# INLINE promotePixel #-} promotePixel (PixelYA8 y _) = PixelRGB8 y y y +instance ColorConvertible PixelYA8 PixelRGB16 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA8 y _) = PixelRGB16 (fromIntegral y * 257) (fromIntegral y * 257) (fromIntegral y * 257) + instance ColorConvertible PixelYA8 PixelRGBA8 where {-# INLINE promotePixel #-} promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a @@ -1281,6 +1502,10 @@ unsafeWritePixel v idx (PixelYA16 y a) = M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a +instance ColorConvertible PixelYA16 PixelRGB16 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA16 y _) = PixelRGB16 y y y + instance ColorConvertible PixelYA16 PixelRGBA16 where {-# INLINE promotePixel #-} promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a @@ -1431,9 +1656,11 @@ instance LumaPlaneExtractable PixelRGB16 where {-# INLINE computeLuma #-} - computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b + computeLuma (PixelRGB16 r g b) = + floor $ (0.3 :: Double) * fromIntegral r + + 0.59 * fromIntegral g + + 0.11 * fromIntegral b + -------------------------------------------------- ---- PixelRGB8 instances -------------------------------------------------- @@ -1515,9 +1742,10 @@ instance LumaPlaneExtractable PixelRGB8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b + computeLuma (PixelRGB8 r g b) = + floor $ (0.3 :: Double) * fromIntegral r + + 0.59 * fromIntegral g + + 0.11 * fromIntegral b -------------------------------------------------- ---- PixelRGBA8 instances @@ -1776,11 +2004,11 @@ rY = fix 0.29900 gY = fix 0.58700 bY = fix 0.11400 - rCb = (- fix 0.16874) - gCb = (- fix 0.33126) + rCb = - fix 0.16874 + gCb = - fix 0.33126 bCb = fix 0.5 - gCr = (- fix 0.41869) - bCr = (- fix 0.08131) + gCr = - fix 0.41869 + bCr = - fix 0.08131 newData = runST $ do block <- M.new $ maxi * 3 @@ -1920,39 +2148,133 @@ convertPixel (PixelCMYK8 c m y k) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) where - clampWord8 = fromIntegral . (`unsafeShiftR` 8) - ik :: Int - ik = 255 - fromIntegral k + clampWord8 = fromIntegral . max 0 . min 255 . (`div` 255) + ik :: Int + ik = 255 - fromIntegral k - r = (255 - fromIntegral c) * ik - g = (255 - fromIntegral m) * ik - b = (255 - fromIntegral y) * ik + r = (255 - fromIntegral c) * ik + g = (255 - fromIntegral m) * ik + b = (255 - fromIntegral y) * ik +-------------------------------------------------- +---- PixelYCbCrK8 instances +-------------------------------------------------- +instance Pixel PixelYCbCrK8 where + type PixelBaseComponent PixelYCbCrK8 = Word8 + {-# INLINE pixelOpacity #-} + pixelOpacity = const maxBound + + {-# INLINE mixWith #-} + mixWith f (PixelYCbCrK8 ya cba cra ka) (PixelYCbCrK8 yb cbb crb kb) = + PixelYCbCrK8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) (f 3 ka kb) + + {-# INLINE colorMap #-} + colorMap f (PixelYCbCrK8 y cb cr k) = PixelYCbCrK8 (f y) (f cb) (f cr) (f k) + + {-# INLINE componentCount #-} + componentCount _ = 4 + + {-# INLINE pixelAt #-} + pixelAt image@(Image { imageData = arr }) x y = + PixelYCbCrK8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) + where baseIdx = pixelBaseIndex image x y + + {-# INLINE readPixel #-} + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + yv <- arr `M.read` baseIdx + cbv <- arr `M.read` (baseIdx + 1) + crv <- arr `M.read` (baseIdx + 2) + kv <- arr `M.read` (baseIdx + 3) + return $ PixelYCbCrK8 yv cbv crv kv + where baseIdx = mutablePixelBaseIndex image x y + + {-# INLINE writePixel #-} + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCrK8 yv cbv crv kv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr `M.write` (baseIdx + 0)) yv + (arr `M.write` (baseIdx + 1)) cbv + (arr `M.write` (baseIdx + 2)) crv + (arr `M.write` (baseIdx + 3)) kv + + {-# INLINE unsafePixelAt #-} + unsafePixelAt v idx = + PixelYCbCrK8 (V.unsafeIndex v idx) + (V.unsafeIndex v $ idx + 1) + (V.unsafeIndex v $ idx + 2) + (V.unsafeIndex v $ idx + 3) + + {-# INLINE unsafeReadPixel #-} + unsafeReadPixel vec idx = + PixelYCbCrK8 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + `ap` M.unsafeRead vec (idx + 3) + + {-# INLINE unsafeWritePixel #-} + unsafeWritePixel v idx (PixelYCbCrK8 y cb cr k) = + M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb + >> M.unsafeWrite v (idx + 2) cr + >> M.unsafeWrite v (idx + 3) k + +instance ColorSpaceConvertible PixelYCbCrK8 PixelRGB8 where + convertPixel (PixelYCbCrK8 y cb cr _k) = PixelRGB8 (clamp r) (clamp g) (clamp b) + where + tof :: Word8 -> Float + tof = fromIntegral + + clamp :: Float -> Word8 + clamp = floor . max 0 . min 255 + + yf = tof y + + r = yf + 1.402 * tof cr - 179.456 + g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589 + b = yf + 1.772 * tof cb - 226.816 + +instance ColorSpaceConvertible PixelYCbCrK8 PixelCMYK8 where + convertPixel (PixelYCbCrK8 y cb cr k) = PixelCMYK8 c m ye k + where + tof :: Word8 -> Float + tof = fromIntegral + + clamp :: Float -> Word8 + clamp = floor . max 0 . min 255 + + yf = tof y + + r = yf + 1.402 * tof cr - 179.456 + g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589 + b = yf + 1.772 * tof cb - 226.816 + + c = clamp $ 255 - r + m = clamp $ 255 - g + ye = clamp $ 255 - b + {-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b) -> (Word8, Word8, Word8) -> b #-} {-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b) -> (Word16, Word16, Word16) -> b #-} +-- | Convert RGB8 or RGB16 to CMYK8 and CMYK16 respectfully. +-- +-- /Note/ - 32bit precision is not supported. Make sure to adjust implementation if ever +-- used with Word32. integralRGBToCMYK :: (Bounded a, Integral a) => (a -> a -> a -> a -> b) -- ^ Pixel building function -> (a, a, a) -- ^ RGB sample -> b -- ^ Resulting sample -integralRGBToCMYK build (r, g, b) = - build (clamp c) (clamp m) (clamp y) (fromIntegral kInt) - where maxi = maxBound - - ir = fromIntegral $ maxi - r :: Int - ig = fromIntegral $ maxi - g - ib = fromIntegral $ maxi - b - - kInt = minimum [ir, ig, ib] - ik = fromIntegral maxi - kInt - - c = (ir - kInt) `div` ik - m = (ig - kInt) `div` ik - y = (ib - kInt) `div` ik - - clamp = fromIntegral . (max 0) +integralRGBToCMYK build (r, g, b) + | kMax == 0 = build 0 0 0 maxVal -- prevent division by zero + | otherwise = build (fromIntegral c) (fromIntegral m) (fromIntegral y) k + where maxVal = maxBound + max32 = fromIntegral maxVal :: Word32 + kMax32 = fromIntegral kMax :: Word32 + kMax = max r (max g b) + k = maxVal - kMax + c = max32 * (kMax32 - fromIntegral r) `div` kMax32 + m = max32 * (kMax32 - fromIntegral g) `div` kMax32 + y = max32 * (kMax32 - fromIntegral b) `div` kMax32 instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b) @@ -2090,29 +2412,42 @@ -- to a primitive. packPixel :: a -> PackedRepresentation a + -- | Inverse transformation, to speed up + -- reading + unpackPixel :: PackedRepresentation a -> a + instance PackeablePixel Pixel8 where type PackedRepresentation Pixel8 = Pixel8 packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel Pixel16 where type PackedRepresentation Pixel16 = Pixel16 packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel Pixel32 where type PackedRepresentation Pixel32 = Pixel32 packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel PixelF where type PackedRepresentation PixelF = PixelF packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel PixelRGBA8 where type PackedRepresentation PixelRGBA8 = Word32 + {-# INLINE packPixel #-} packPixel (PixelRGBA8 r g b a) = (fi r `unsafeShiftL` (0 * bitCount)) .|. (fi g `unsafeShiftL` (1 * bitCount)) .|. @@ -2121,8 +2456,19 @@ where fi = fromIntegral bitCount = 8 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelRGBA8 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFF) + bitCount = 8 + instance PackeablePixel PixelRGBA16 where type PackedRepresentation PixelRGBA16 = Word64 + {-# INLINE packPixel #-} packPixel (PixelRGBA16 r g b a) = (fi r `unsafeShiftL` (0 * bitCount)) .|. (fi g `unsafeShiftL` (1 * bitCount)) .|. @@ -2131,8 +2477,19 @@ where fi = fromIntegral bitCount = 16 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelRGBA16 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFFFF) + bitCount = 16 + instance PackeablePixel PixelCMYK8 where type PackedRepresentation PixelCMYK8 = Word32 + {-# INLINE packPixel #-} packPixel (PixelCMYK8 c m y k) = (fi c `unsafeShiftL` (0 * bitCount)) .|. (fi m `unsafeShiftL` (1 * bitCount)) .|. @@ -2141,8 +2498,19 @@ where fi = fromIntegral bitCount = 8 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelCMYK8 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFF) + bitCount = 8 + instance PackeablePixel PixelCMYK16 where type PackedRepresentation PixelCMYK16 = Word64 + {-# INLINE packPixel #-} packPixel (PixelCMYK16 c m y k) = (fi c `unsafeShiftL` (0 * bitCount)) .|. (fi m `unsafeShiftL` (1 * bitCount)) .|. @@ -2151,22 +2519,46 @@ where fi = fromIntegral bitCount = 16 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelCMYK16 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFFFF) + bitCount = 16 + instance PackeablePixel PixelYA16 where type PackedRepresentation PixelYA16 = Word32 + {-# INLINE packPixel #-} packPixel (PixelYA16 y a) = (fi y `unsafeShiftL` (0 * bitCount)) .|. (fi a `unsafeShiftL` (1 * bitCount)) where fi = fromIntegral bitCount = 16 + {-# INLINE unpackPixel #-} + unpackPixel w = PixelYA16 (low w) (low $ w `unsafeShiftR` bitCount) + where + low v = fromIntegral (v .&. 0xFFFF) + bitCount = 16 + instance PackeablePixel PixelYA8 where type PackedRepresentation PixelYA8 = Word16 + {-# INLINE packPixel #-} packPixel (PixelYA8 y a) = (fi y `unsafeShiftL` (0 * bitCount)) .|. (fi a `unsafeShiftL` (1 * bitCount)) where fi = fromIntegral bitCount = 8 + {-# INLINE unpackPixel #-} + unpackPixel w = PixelYA8 (low w) (low $ w `unsafeShiftR` bitCount) + where + low v = fromIntegral (v .&. 0xFF) + bitCount = 8 + -- | This function will fill an image with a simple packeable -- pixel. It will be faster than any unsafeWritePixel. fillImageWith :: ( Pixel px, PackeablePixel px @@ -2201,6 +2593,28 @@ !converted = M.unsafeFromForeignPtr packedPtr s s2 +-- | Read a packeable pixel from an image. Equivalent to +-- unsafeReadPixel +readPackedPixelAt :: forall m px. + ( Pixel px, PackeablePixel px + , M.Storable (PackedRepresentation px) + , PrimMonad m + ) + => MutableImage (PrimState m) px -- ^ Image to read from + -> Int -- ^ Index in (PixelBaseComponent px) count + -> m px +{-# INLINE readPackedPixelAt #-} +readPackedPixelAt img idx = do + unpacked <- M.unsafeRead converted (idx `div` compCount) + return $ unpackPixel unpacked + where + !compCount = componentCount (undefined :: px) + (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img + !packedPtr = castForeignPtr ptr + !converted = + M.unsafeFromForeignPtr packedPtr s s2 + + -- | Write a packeable pixel into an image. equivalent to unsafeWritePixel. writePackedPixelAt :: ( Pixel px, PackeablePixel px , M.Storable (PackedRepresentation px) @@ -2221,4 +2635,6 @@ !packedPtr = castForeignPtr ptr !converted = M.unsafeFromForeignPtr packedPtr s s2 + +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/VectorByteConversion.hs b/src/Codec/Picture/VectorByteConversion.hs --- a/src/Codec/Picture/VectorByteConversion.hs +++ b/src/Codec/Picture/VectorByteConversion.hs @@ -1,25 +1,39 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module Codec.Picture.VectorByteConversion( blitVector , toByteString , imageFromUnsafePtr ) where import Data.Word( Word8 ) import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) -import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) import Foreign.Storable( Storable, sizeOf ) +#if !MIN_VERSION_base(4,8,0) +import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) +#else +import Foreign.ForeignPtr( ForeignPtr, castForeignPtr ) +#endif + + import qualified Data.ByteString as B import qualified Data.ByteString.Internal as S import Codec.Picture.Types +mkBS :: ForeignPtr Word8 -> Int -> Int -> S.ByteString +#if MIN_VERSION_bytestring(0,11,0) +mkBS fptr off = S.BS (fptr `S.plusForeignPtr` off) +#else +mkBS = S.PS +#endif + blitVector :: Vector Word8 -> Int -> Int -> B.ByteString -blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize +blitVector vec atIndex = mkBS ptr (offset + atIndex) where (ptr, offset, _length) = unsafeToForeignPtr vec toByteString :: forall a. (Storable a) => Vector a -> B.ByteString -toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) +toByteString vec = mkBS (castForeignPtr ptr) offset (len * size) where (ptr, offset, len) = unsafeToForeignPtr vec size = sizeOf (undefined :: a)