JuicyPixels 3.2.9.5 → 3.3.9
raw patch · 46 files changed
Files
- JuicyPixels.cabal +41/−34
- README.md +9/−5
- changelog +81/−0
- src/Codec/Picture.hs +62/−2
- src/Codec/Picture/BitWriter.hs +14/−0
- src/Codec/Picture/Bitmap.hs +658/−157
- src/Codec/Picture/ColorQuant.hs +53/−4
- src/Codec/Picture/Gif.hs +1006/−859
- src/Codec/Picture/Gif/Internal/LZW.hs +194/−0
- src/Codec/Picture/Gif/Internal/LZWEncoding.hs +101/−0
- src/Codec/Picture/Gif/LZW.hs +0/−194
- src/Codec/Picture/Gif/LZWEncoding.hs +0/−101
- src/Codec/Picture/HDR.hs +534/−530
- src/Codec/Picture/InternalHelper.hs +32/−51
- src/Codec/Picture/Jpg.hs +23/−14
- src/Codec/Picture/Jpg/Common.hs +0/−240
- src/Codec/Picture/Jpg/DefaultTable.hs +0/−294
- src/Codec/Picture/Jpg/FastDct.hs +0/−218
- src/Codec/Picture/Jpg/FastIdct.hs +0/−229
- src/Codec/Picture/Jpg/Internal/Common.hs +240/−0
- src/Codec/Picture/Jpg/Internal/DefaultTable.hs +298/−0
- src/Codec/Picture/Jpg/Internal/FastDct.hs +218/−0
- src/Codec/Picture/Jpg/Internal/FastIdct.hs +229/−0
- src/Codec/Picture/Jpg/Internal/Metadata.hs +41/−0
- src/Codec/Picture/Jpg/Internal/Progressive.hs +332/−0
- src/Codec/Picture/Jpg/Internal/Types.hs +1073/−0
- src/Codec/Picture/Jpg/Metadata.hs +0/−41
- src/Codec/Picture/Jpg/Progressive.hs +0/−332
- src/Codec/Picture/Jpg/Types.hs +0/−753
- src/Codec/Picture/Metadata.hs +44/−3
- src/Codec/Picture/Metadata/Exif.hs +7/−11
- src/Codec/Picture/Png.hs +13/−12
- src/Codec/Picture/Png/Export.hs +0/−268
- src/Codec/Picture/Png/Internal/Export.hs +270/−0
- src/Codec/Picture/Png/Internal/Metadata.hs +167/−0
- src/Codec/Picture/Png/Internal/Type.hs +452/−0
- src/Codec/Picture/Png/Metadata.hs +0/−135
- src/Codec/Picture/Png/Type.hs +0/−450
- src/Codec/Picture/Saving.hs +239/−214
- src/Codec/Picture/Tiff.hs +58/−8
- src/Codec/Picture/Tiff/Internal/Metadata.hs +239/−0
- src/Codec/Picture/Tiff/Internal/Types.hs +504/−0
- src/Codec/Picture/Tiff/Metadata.hs +0/−237
- src/Codec/Picture/Tiff/Types.hs +0/−483
- src/Codec/Picture/Types.hs +55/−30
- src/Codec/Picture/VectorByteConversion.hs +52/−45
JuicyPixels.cabal view
@@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.9.5 +Version: 3.3.9 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> @@ -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.18 +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, README.md +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.2.9.5 + Tag: v3.3.8 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -37,6 +47,7 @@ Library hs-source-dirs: src Default-Language: Haskell2010 + default-extensions: TypeOperators Exposed-modules: Codec.Picture, Codec.Picture.Bitmap, Codec.Picture.Gif, @@ -49,40 +60,36 @@ 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 Build-depends: base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - mtl >= 1.1 && < 2.3, - binary >= 0.5 && < 0.9, - zlib >= 0.5.3.1 && < 0.7, + 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.10 && < 0.13, - primitive >= 0.4 && < 0.7, - deepseq >= 1.1 && < 1.5, - containers >= 0.4.2 && < 0.6 - - if flag(Mmap) - Build-depends: mmap - CC-Options: "-DWITH_MMAP_BYTESTRING" + 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.Metadata, - Codec.Picture.Jpg.FastIdct, - Codec.Picture.Jpg.FastDct, - Codec.Picture.Jpg.Types, - Codec.Picture.Jpg.Common, - Codec.Picture.Jpg.Progressive, - Codec.Picture.Gif.LZW, - Codec.Picture.Gif.LZWEncoding, - Codec.Picture.Png.Export, - Codec.Picture.Png.Type, - Codec.Picture.Png.Metadata, - Codec.Picture.Tiff.Metadata, - Codec.Picture.Tiff.Types, - Codec.Picture.BitWriter, + Other-modules: Codec.Picture.BitWriter, Codec.Picture.InternalHelper, Codec.Picture.VectorByteConversion
README.md view
@@ -51,11 +51,13 @@ * in a gAMA field : 'Gamma' * DPI information in a pHYs chunk. - - Bitmap (.bmp) (mainly used as a debug output format) + - Bitmap (.bmp) * Reading - - 32bits (RGBA) images - - 24bits (RGB) images - - 8bits (greyscale & paletted) images + - 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 @@ -99,7 +101,9 @@ - Tiff * Reading - - 2, 4, 8, 16 bit depth reading (planar and contiguous for each) + - 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
changelog view
@@ -1,6 +1,87 @@ 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 -------------------
src/Codec/Picture.hs view
@@ -23,6 +23,8 @@ , decodeImageWithMetadata , decodeImageWithPaletteAndMetadata , pixelMap + , dynamicMap + , dynamicPixelMap , generateImage , generateFoldImage , withImage @@ -30,6 +32,7 @@ -- * RGB helper functions , convertRGB8 + , convertRGB16 , convertRGBA8 -- * Lens compatibility @@ -126,6 +129,7 @@ -- $graph , Pixel8 , Pixel16 + , Pixel32 , PixelF , PixelYA8( .. ) @@ -293,6 +297,20 @@ 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 @@ -300,9 +318,22 @@ 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 @@ -318,16 +349,23 @@ instance Decimable PixelF Pixel8 where decimateBitDepth = decimateFloat +instance Decimable PixelF Pixel16 where + decimateBitDepth = decimateFloat16 + instance Decimable PixelRGBF PixelRGB8 where decimateBitDepth = decimateFloat --- | Convert by any mean possible a dynamic image to an image +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) @@ -341,7 +379,7 @@ ImageCMYK16 img -> promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8) --- | Convert by any mean possible a dynamic image to an image +-- | 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 @@ -349,6 +387,7 @@ 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) @@ -360,6 +399,27 @@ 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.
src/Codec/Picture/BitWriter.hs view
@@ -19,6 +19,7 @@ , BoolWriteStateRef , newWriteStateRef , finalizeBoolWriter + , finalizeBoolWriterGif , writeBits' , writeBitsGif @@ -339,6 +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" #-}
src/Codec/Picture/Bitmap.hs view
@@ -12,9 +12,9 @@ , decodeBitmap , decodeBitmapWithMetadata , decodeBitmapWithPaletteAndMetadata - , encodeDynamicBitmap + , encodeDynamicBitmap , encodeBitmapWithPaletteAndMetadata - , writeDynamicBitmap + , writeDynamicBitmap -- * Accepted format in output , BmpEncodable( ) ) where @@ -25,7 +25,7 @@ #endif import Control.Arrow( first ) -import Control.Monad( replicateM, when, foldM_, forM_ ) +import Control.Monad( replicateM, when, foldM_, forM_, void ) import Control.Monad.ST ( ST, runST ) import Data.Maybe( fromMaybe ) import qualified Data.Vector.Storable as VS @@ -33,23 +33,28 @@ import Data.Binary( Binary( .. ) ) import Data.Binary.Put( Put , runPut + , putInt32le , putWord16le , putWord32le - , putByteString + , putByteString ) import Data.Binary.Get( Get , getWord8 - , getWord16le + , getWord16le , getWord32le - , getWord32be + , 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 @@ -93,8 +98,43 @@ , 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 :: !Int32 , height :: !Int32 @@ -102,67 +142,224 @@ , bitPerPixel :: !Word16 , bitmapCompression :: !Word32 , byteImageSize :: !Word32 - , xResolution :: !Int32 -- ^ Pixels per meter - , yResolution :: !Int32 -- ^ 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 . fromIntegral $ width hdr - putWord32le . fromIntegral $ height hdr - putWord16le $ planes hdr - putWord16le $ bitPerPixel hdr - putWord32le $ bitmapCompression hdr - putWord32le $ byteImageSize hdr - putWord32le . fromIntegral $ xResolution hdr - putWord32le . fromIntegral $ 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 <- fromIntegral <$> getWord32le - readHeight <- fromIntegral <$> getWord32le - readPlanes <- getWord16le - readBitPerPixel <- getWord16le - readBitmapCompression <- getWord32le - readByteImageSize <- getWord32le - readXResolution <- fromIntegral <$> getWord32le - readYResolution <- fromIntegral <$> 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 [] @@ -175,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}) = @@ -200,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 @@ -228,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 @@ -245,7 +445,7 @@ 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 @@ -255,8 +455,76 @@ inner 0 0 initialIndex VS.unsafeFreeze buff -decodeImageRGBA8 :: BmpInfoHeader -> (Int, Int, Int, Int) -> B.ByteString -> Image PixelRGBA8 -decodeImageRGBA8 (BmpInfoHeader { width = w, height = h }) (posR, posG, posB, posA) str = Image wi hi stArray where +-- | 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) + +-- | Four bitfields (red, green, blue, alpha) +data Bitfields4 t = Bitfields4 !(Bitfield t) + !(Bitfield t) + !(Bitfield t) + !(Bitfield t) + deriving (Eq, Show) + +-- | Default bitfields 32 bit bitmaps. +defaultBitfieldsRGB32 :: Bitfields3 Word32 +defaultBitfieldsRGB32 = Bitfields3 (makeBitfield 0x00FF0000) + (makeBitfield 0x0000FF00) + (makeBitfield 0x000000FF) + +-- | Default bitfields for 16 bit bitmaps. +defaultBitfieldsRGB16 :: Bitfields3 Word16 +defaultBitfieldsRGB16 = Bitfields3 (makeBitfield 0x7C00) + (makeBitfield 0x03E0) + (makeBitfield 0x001F) + +-- | Three bitfields (red, gree, blue). +data Bitfields3 t = Bitfields3 !(Bitfield t) + !(Bitfield t) + !(Bitfield t) + deriving (Eq, Show) + +-- | Pixel formats used to encode RGBA image data. +data RGBABmpFormat = RGBA32 !(Bitfields4 Word32) + | RGBA16 !(Bitfields4 Word16) + deriving (Eq, Show) + +-- | Pixel formats used to encode RGB image data. +data RGBBmpFormat = RGB32 !(Bitfields3 Word32) + | RGB24 + | RGB16 !(Bitfields3 Word16) + deriving (Eq, Show) + +-- | Pixel formats used to encode indexed or grayscale images. +data IndexedBmpFormat = OneBPP | FourBPP | EightBPP deriving Show + +-- | 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) + +-- | 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 @@ -267,24 +535,38 @@ foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] VS.unsafeFreeze arr - stride = linePadding 32 wi -- will be 0 + 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 = inner readIndex writeIndex where - lastIndex = wi * (hi - 1 - line + 1) * 4 - writeIndex = wi * (hi - 1 - line) * 4 + 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 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride - inner readIdx writeIdx = do - -- 32-bit BMP pixels are BGRA - (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + posR)) - (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + posG)) - (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` (readIdx + posB)) - (arr `M.unsafeWrite` (writeIdx + 3)) (str `B.index` (readIdx + posA)) - inner (readIdx + 4) (writeIdx + 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 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 -decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where +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 @@ -295,22 +577,46 @@ foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] VS.unsafeFreeze arr - stride = linePadding 24 wi + 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 = inner readIndex writeIndex where - lastIndex = wi * (hi - 1 - line + 1) * 3 - writeIndex = wi * (hi - 1 - line) * 3 + 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 - inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride - 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) + 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) -decodeImageY8 :: BmpInfoHeader -> B.ByteString -> Image Pixel8 -decodeImageY8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where + 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 @@ -321,33 +627,131 @@ foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] VS.unsafeFreeze arr - stride = linePadding 8 wi - + padding = linePadding (fromIntegral bpp) wi + readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int - readLine arr readIndex line = inner readIndex writeIndex where - lastIndex = wi * (hi - 1 - line + 1) - writeIndex = wi * (hi - 1 - line) + 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) - inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride - inner readIdx writeIdx = do - (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx) - inner (readIdx + 1) (writeIdx + 1) + 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) -pixelGet :: Get [Word8] -pixelGet = do + 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 $ [r, g, b] + return [r, g, b] -metadataOfHeader :: BmpInfoHeader -> Metadatas -metadataOfHeader hdr = - Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr) dpiX dpiY +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 image: @@ -369,71 +773,134 @@ -- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette. decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do - hdr <- get :: Get BmpHeader - bmpHeader <- get :: Get BmpInfoHeader + 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") - + when (width bmpHeader <= 0) (fail $ "Invalid bmp width, " ++ show (width bmpHeader)) when (height bmpHeader == 0) (fail $ "Invalid bmp height (0) ") - let bpp = fromIntegral $ bitPerPixel bmpHeader :: Int - paletteColorCount - | colorCount bmpHeader == 0 = 2 ^ bpp - | otherwise = fromIntegral $ colorCount bmpHeader - getData = do - readed' <- bytesRead - skip . fromIntegral $ dataOffset hdr - fromIntegral readed' - getRemainingBytes - addMetadata i = (i, metadataOfHeader bmpHeader) + decodeBitmapWithHeaders fileHeader bmpHeader - case (bitPerPixel bmpHeader, planes bmpHeader, - bitmapCompression bmpHeader) of - (32, 1, 0) -> do - rest <- getData - return . addMetadata . TrueColorImage . ImageRGBA8 - $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest - -- (2, 1, 0, 3) means BGRA pixel order - (32, 1, 3) -> do - posRed <- getBitfield - posGreen <- getBitfield - posBlue <- getBitfield - posAlpha <- getBitfield - rest <- getData - return . addMetadata . TrueColorImage . ImageRGBA8 $ - decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest - (24, 1, 0) -> do - rest <- getData - return . addMetadata . TrueColorImage . ImageRGB8 $ - decodeImageRGB8 bmpHeader rest - ( 8, 1, 0) -> do - table <- replicateM paletteColorCount pixelGet - rest <- getData - let palette = Palette' - { _paletteSize = paletteColorCount - , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table - } - return . addMetadata $ PalettedRGB8 (decodeImageY8 bmpHeader rest) palette +-- | 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) -getBitfield :: Get Int -getBitfield = do - w32 <- getWord32be - case w32 of - 0xFF000000 -> return 0 - 0x00FF0000 -> return 1 - 0x0000FF00 -> return 2 - 0x000000FF -> return 3 - _ -> fail $ - "Codec.Picture.Bitmap.getBitfield: unsupported bitfield of " ++ show w32 + 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 () @@ -441,7 +908,7 @@ 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. @@ -452,7 +919,7 @@ -- the following metadatas: -- -- * 'Codec.Picture.Metadata.DpiX' --- * 'Codec.Picture.Metadata.DpiY' +-- * 'Codec.Picture.Metadata.DpiY' -- encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel => Metadatas -> Image pixel -> L.ByteString @@ -482,8 +949,7 @@ extractDpiOfMetadata :: Metadatas -> (Word32, Word32) extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where - fetch k = fromMaybe 0 - $ fromIntegral . Met.dotPerInchToDotsPerMeter <$> Met.lookup k metas + 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) @@ -494,41 +960,76 @@ -- the following metadatas: -- -- * 'Codec.Picture.Metadata.DpiX' --- * 'Codec.Picture.Metadata.DpiY' +-- * '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 - imagePixelSize = fromIntegral $ (imgWidth * div bpp 8 + padding) * imgHeight + + 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 = fromIntegral dpiX, yResolution = fromIntegral dpiY, - colorCount = 0, - importantColours = paletteSize + 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 }
src/Codec/Picture/ColorQuant.hs view
@@ -10,6 +10,7 @@ -- with its palette. module Codec.Picture.ColorQuant ( palettize + , palettizeWithAlpha , defaultPaletteOptions , PaletteCreationMethod(..) , PaletteOptions( .. ) @@ -32,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 @@ -71,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 } = @@ -100,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 @@ -120,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 .&. (256 - dr)) (g .&. (256 - dg)) (b .&. (256 - db))) + (PixelRGB8 (r .&. negate dr) (g .&. negate dg) (b .&. negate db)) paletteList) isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool) @@ -229,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
src/Codec/Picture/Gif.hs view
@@ -1,859 +1,1006 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}--- | Module implementing GIF decoding.-module Codec.Picture.Gif ( -- * Reading- decodeGif- , decodeGifWithMetadata- , decodeGifWithPaletteAndMetadata- , decodeGifImages- , getDelaysGifImages-- -- * Writing- , GifDelay- , GifLooping( .. )- , encodeGifImage- , encodeGifImageWithPalette- , encodeGifImages-- , writeGifImage- , writeGifImageWithPalette- , writeGifImages- , greyPalette- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( pure, (<*>), (<$>) )-#endif--import Control.Arrow( first )-import Control.Monad( replicateM, replicateM_, unless )-import Control.Monad.ST( runST )-import Control.Monad.Trans.Class( lift )--import Data.Bits( (.&.), (.|.)- , unsafeShiftR- , unsafeShiftL- , testBit, setBit )-import Data.Word( Word8, Word16 )--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as L-import qualified Data.Vector.Storable as V-import qualified Data.Vector.Storable.Mutable as M--import Data.Binary( Binary(..), encode )-import Data.Binary.Get( Get- , getWord8- , getWord16le- , getByteString- , bytesRead- , skip- )--import Data.Binary.Put( Put- , putWord8- , putWord16le- , putByteString- )--import Codec.Picture.InternalHelper-import Codec.Picture.Types-import Codec.Picture.Metadata( Metadatas- , SourceFormat( SourceGif )- , basicMetadata )-import Codec.Picture.Gif.LZW-import Codec.Picture.Gif.LZWEncoding-import Codec.Picture.BitWriter---- | Delay to wait before showing the next Gif image.--- The delay is expressed in 100th of seconds.-type GifDelay = Int---- | Help to control the behaviour of GIF animation looping.-data GifLooping =- -- | The animation will stop once the end is reached- LoopingNever- -- | The animation will restart once the end is reached- | LoopingForever- -- | The animation will repeat n times before stoping- | LoopingRepeat Word16--{-- <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer-- <Logical Screen> ::= Logical Screen Descriptor [Global Color Table]-- <Data> ::= <Graphic Block> |- <Special-Purpose Block>-- <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block>-- <Graphic-Rendering Block> ::= <Table-Based Image> |- Plain Text Extension-- <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data-- <Special-Purpose Block> ::= Application Extension |- Comment Extension- -}--------------------------------------------------------- GifVersion----------------------------------------------------data GifVersion = GIF87a | GIF89a--gif87aSignature, gif89aSignature :: B.ByteString-gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a"-gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a"--instance Binary GifVersion where- put GIF87a = putByteString gif87aSignature- put GIF89a = putByteString gif89aSignature-- get = do- sig <- getByteString (B.length gif87aSignature)- case (sig == gif87aSignature, sig == gif89aSignature) of- (True, _) -> pure GIF87a- (_ , True) -> pure GIF89a- _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig)---------------------------------------------------------- LogicalScreenDescriptor------------------------------------------------------ | Section 18 of spec-gif89a-data LogicalScreenDescriptor = LogicalScreenDescriptor- { -- | Stored on 16 bits- screenWidth :: !Word16- -- | Stored on 16 bits- , screenHeight :: !Word16- -- | Stored on 8 bits- , backgroundIndex :: !Word8-- -- | Stored on 1 bit- , hasGlobalMap :: !Bool- -- | Stored on 3 bits- , colorResolution :: !Word8- -- | Stored on 1 bit- , isColorTableSorted :: !Bool- -- | Stored on 3 bits- , colorTableSize :: !Word8- }--instance Binary LogicalScreenDescriptor where- put v = do- putWord16le $ screenWidth v- putWord16le $ screenHeight v- let globalMapField- | hasGlobalMap v = 0x80- | otherwise = 0-- colorTableSortedField- | isColorTableSorted v = 0x08- | otherwise = 0-- tableSizeField = (colorTableSize v - 1) .&. 7-- colorResolutionField =- ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5-- packedField = globalMapField- .|. colorTableSortedField- .|. tableSizeField- .|. colorResolutionField-- putWord8 packedField- putWord8 0 -- aspect ratio- putWord8 $ backgroundIndex v-- get = do- w <- getWord16le- h <- getWord16le- packedField <- getWord8- backgroundColorIndex <- getWord8- _aspectRatio <- getWord8- return LogicalScreenDescriptor- { screenWidth = w- , screenHeight = h- , hasGlobalMap = packedField `testBit` 7- , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1- , isColorTableSorted = packedField `testBit` 3- , colorTableSize = (packedField .&. 0x7) + 1- , backgroundIndex = backgroundColorIndex- }---------------------------------------------------------- ImageDescriptor------------------------------------------------------ | Section 20 of spec-gif89a-data ImageDescriptor = ImageDescriptor- { gDescPixelsFromLeft :: !Word16- , gDescPixelsFromTop :: !Word16- , gDescImageWidth :: !Word16- , gDescImageHeight :: !Word16- , gDescHasLocalMap :: !Bool- , gDescIsInterlaced :: !Bool- , gDescIsImgDescriptorSorted :: !Bool- , gDescLocalColorTableSize :: !Word8- }--imageSeparator, extensionIntroducer, gifTrailer :: Word8-imageSeparator = 0x2C-extensionIntroducer = 0x21-gifTrailer = 0x3B--graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8-plainTextLabel = 0x01-graphicControlLabel = 0xF9-commentLabel = 0xFE-applicationLabel = 0xFF---parseDataBlocks :: Get B.ByteString-parseDataBlocks = B.concat <$> (getWord8 >>= aux)- where aux 0 = pure []- aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux)--putDataBlocks :: B.ByteString -> Put-putDataBlocks wholeString = putSlices wholeString >> putWord8 0- where putSlices str | B.length str == 0 = pure ()- | B.length str > 0xFF =- let (before, after) = B.splitAt 0xFF str in- putWord8 0xFF >> putByteString before >> putSlices after- putSlices str =- putWord8 (fromIntegral $ B.length str) >> putByteString str--data DisposalMethod- = DisposalAny- | DisposalDoNot- | DisposalRestoreBackground- | DisposalRestorePrevious- | DisposalUnknown Word8--disposalMethodOfCode :: Word8 -> DisposalMethod-disposalMethodOfCode v = case v of- 0 -> DisposalAny- 1 -> DisposalDoNot- 2 -> DisposalRestoreBackground- 3 -> DisposalRestorePrevious- n -> DisposalUnknown n--codeOfDisposalMethod :: DisposalMethod -> Word8-codeOfDisposalMethod v = case v of- DisposalAny -> 0- DisposalDoNot -> 1- DisposalRestoreBackground -> 2- DisposalRestorePrevious -> 3- DisposalUnknown n -> n--data GraphicControlExtension = GraphicControlExtension- { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits- , gceUserInputFlag :: !Bool- , gceTransparentFlag :: !Bool- , gceDelay :: !Word16- , gceTransparentColorIndex :: !Word8- }--instance Binary GraphicControlExtension where- put v = do- putWord8 extensionIntroducer- putWord8 graphicControlLabel- putWord8 0x4 -- size- let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v- disposalField =- (disposalCode .&. 0x7) `unsafeShiftL` 2-- userInputField- | gceUserInputFlag v = 0 `setBit` 1- | otherwise = 0-- transparentField- | gceTransparentFlag v = 0 `setBit` 0- | otherwise = 0-- packedFields = disposalField- .|. userInputField- .|. transparentField-- putWord8 packedFields- putWord16le $ gceDelay v- putWord8 $ gceTransparentColorIndex v- putWord8 0 -- blockTerminator-- get = do- -- due to missing lookahead- {-_extensionLabel <- getWord8-}- _size <- getWord8- packedFields <- getWord8- delay <- getWord16le- idx <- getWord8- _blockTerminator <- getWord8- return GraphicControlExtension- { gceDisposalMethod = - disposalMethodOfCode $- (packedFields `unsafeShiftR` 2) .&. 0x07- , gceUserInputFlag = packedFields `testBit` 1- , gceTransparentFlag = packedFields `testBit` 0- , gceDelay = delay- , gceTransparentColorIndex = idx- }--data GifImage = GifImage- { imgDescriptor :: !ImageDescriptor- , imgLocalPalette :: !(Maybe Palette)- , imgLzwRootSize :: !Word8- , imgData :: B.ByteString- }--instance Binary GifImage where- put img = do- let descriptor = imgDescriptor img- put descriptor- case ( imgLocalPalette img- , gDescHasLocalMap $ imgDescriptor img) of- (Nothing, _) -> return ()- (Just _, False) -> return ()- (Just p, True) ->- putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p- putWord8 $ imgLzwRootSize img- putDataBlocks $ imgData img-- get = do- desc <- get- let hasLocalColorTable = gDescHasLocalMap desc- palette <- if hasLocalColorTable- then Just <$> getPalette (gDescLocalColorTableSize desc)- else pure Nothing-- GifImage desc palette <$> getWord8 <*> parseDataBlocks--data Block = BlockImage GifImage- | BlockGraphicControl GraphicControlExtension--skipSubDataBlocks :: Get ()-skipSubDataBlocks = do- s <- fromIntegral <$> getWord8- unless (s == 0) $- skip s >> skipSubDataBlocks--parseGifBlocks :: Get [Block]-parseGifBlocks = getWord8 >>= blockParse- where- blockParse v- | v == gifTrailer = pure []- | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks- | v == extensionIntroducer = getWord8 >>= extensionParse-- blockParse v = do- readPosition <- bytesRead- fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition)-- extensionParse code- | code == graphicControlLabel =- (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks- | code == commentLabel = skipSubDataBlocks >> parseGifBlocks- | code `elem` [plainTextLabel, applicationLabel] =- fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks- | otherwise = parseDataBlocks >> parseGifBlocks---instance Binary ImageDescriptor where- put v = do- putWord8 imageSeparator- putWord16le $ gDescPixelsFromLeft v- putWord16le $ gDescPixelsFromTop v- putWord16le $ gDescImageWidth v- putWord16le $ gDescImageHeight v- let localMapField- | gDescHasLocalMap v = 0 `setBit` 7- | otherwise = 0-- isInterlacedField- | gDescIsInterlaced v = 0 `setBit` 6- | otherwise = 0-- isImageDescriptorSorted- | gDescIsImgDescriptorSorted v = 0 `setBit` 5- | otherwise = 0-- localSize = gDescLocalColorTableSize v- tableSizeField- | localSize > 0 = (localSize - 1) .&. 0x7- | otherwise = 0-- packedFields = localMapField- .|. isInterlacedField- .|. isImageDescriptorSorted- .|. tableSizeField- putWord8 packedFields-- get = do- -- due to missing lookahead- {-_imageSeparator <- getWord8-}- imgLeftPos <- getWord16le- imgTopPos <- getWord16le- imgWidth <- getWord16le- imgHeight <- getWord16le- packedFields <- getWord8- let tableSize = packedFields .&. 0x7- return ImageDescriptor- { gDescPixelsFromLeft = imgLeftPos- , gDescPixelsFromTop = imgTopPos- , gDescImageWidth = imgWidth- , gDescImageHeight = imgHeight- , gDescHasLocalMap = packedFields `testBit` 7- , gDescIsInterlaced = packedFields `testBit` 6- , gDescIsImgDescriptorSorted = packedFields `testBit` 5- , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0- }---------------------------------------------------------- Palette----------------------------------------------------getPalette :: Word8 -> Get Palette-getPalette bitDepth = - Image size 1 . V.fromList <$> replicateM (size * 3) get- where size = 2 ^ (fromIntegral bitDepth :: Int)--putPalette :: Int -> Palette -> Put-putPalette size pal = do- V.mapM_ putWord8 (imageData pal)- replicateM_ missingColorComponent (putWord8 0)- where elemCount = 2 ^ size- missingColorComponent = (elemCount - imageWidth pal) * 3--------------------------------------------------------- GifImage----------------------------------------------------data GifHeader = GifHeader- { gifVersion :: GifVersion- , gifScreenDescriptor :: LogicalScreenDescriptor- , gifGlobalMap :: !Palette- }--instance Binary GifHeader where- put v = do- put $ gifVersion v- let descr = gifScreenDescriptor v- put descr- putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v-- get = do- version <- get- screenDesc <- get- - palette <- - if hasGlobalMap screenDesc then- getPalette $ colorTableSize screenDesc- else- return greyPalette-- return GifHeader- { gifVersion = version- , gifScreenDescriptor = screenDesc- , gifGlobalMap = palette- }--data GifFile = GifFile- { gifHeader :: !GifHeader- , gifImages :: [(Maybe GraphicControlExtension, GifImage)]- , gifLoopingBehaviour :: GifLooping- }--putLooping :: GifLooping -> Put-putLooping LoopingNever = return ()-putLooping LoopingForever = putLooping $ LoopingRepeat 0-putLooping (LoopingRepeat count) = do- putWord8 extensionIntroducer- putWord8 applicationLabel- putWord8 11 -- the size- putByteString $ BC.pack "NETSCAPE2.0"- putWord8 3 -- size of sub block- putWord8 1- putWord16le count- putWord8 0--associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]-associateDescr [] = []-associateDescr [BlockGraphicControl _] = []-associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) =- associateDescr rest-associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs-associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) =- (Just ctrl, img) : associateDescr xs--instance Binary GifFile where- put v = do- put $ gifHeader v- let putter (Nothing, i) = put i- putter (Just a, i) = put a >> put i- putLooping $ gifLoopingBehaviour v- mapM_ putter $ gifImages v- put gifTrailer-- get = do- hdr <- get- blocks <- parseGifBlocks- return GifFile { gifHeader = hdr- , gifImages = associateDescr blocks- , gifLoopingBehaviour = LoopingNever- }--substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8-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- decodeLzw (imgData img) 12 lzwRoot outputVector- frozenData <- lift $ V.unsafeFreeze outputVector- return . deinterlaceGif $ Image- { imageWidth = width- , imageHeight = height- , imageData = frozenData- }- where lzwRoot = fromIntegral $ imgLzwRootSize img- width = fromIntegral $ gDescImageWidth descriptor- height = fromIntegral $ gDescImageHeight descriptor- isInterlaced = gDescIsInterlaced descriptor- descriptor = imgDescriptor img-- deinterlaceGif | not isInterlaced = id- | otherwise = deinterlaceGifImage--deinterlaceGifImage :: Image Pixel8 -> Image Pixel8-deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h- where lineIndices = gifInterlacingIndices h- generator x y = pixelAt img x y'- where y' = lineIndices V.! y--gifInterlacingIndices :: Int -> V.Vector Int-gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices- where indices = flip zip [0..] $- concat [ [0, 8 .. height - 1]- , [4, 4 + 8 .. height - 1]- , [2, 2 + 4 .. height - 1]- , [1, 1 + 2 .. height - 1]- ]--paletteOf :: (ColorConvertible PixelRGB8 px)- => Image px -> GifImage -> Image px-paletteOf global GifImage { imgLocalPalette = Nothing } = global-paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p--getFrameDelays :: GifFile -> [GifDelay]-getFrameDelays GifFile { gifImages = [] } = []-getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs- where extractDelay (ext, _) =- case ext of- Nothing -> 0- Just e -> fromIntegral $ gceDelay e--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 }- | not (hasTransparency firstControl) =- let backImage =- generateImage (\_ _ -> backgroundColor) globalWidth globalHeight- thisPalette = paletteOf palette 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]-- | otherwise =- let backImage :: Image PixelRGBA8- backImage =- generateImage (\_ _ -> transparentBackground) globalWidth globalHeight-- thisPalette :: Image PixelRGBA8- thisPalette = paletteOf (promoteImage palette) firstImage-- transparentCode = transparentColorOf firstControl- decoded = - substituteColorsWithTransparency transparentCode thisPalette $- decodeImage firstImage-- initState = (thisPalette, firstControl, decoded)- scanner =- gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in- [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest]-- where - globalWidth = fromIntegral $ screenWidth wholeDescriptor- globalHeight = fromIntegral $ screenHeight wholeDescriptor-- transparentBackground = PixelRGBA8 r g b 0- where PixelRGB8 r g b = backgroundColor-- backgroundColor- | hasGlobalMap wholeDescriptor =- pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0- | otherwise = PixelRGB8 0 0 0--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-- thisImage = generateImage pixeler globalWidth globalHeight- localWidth = fromIntegral $ gDescImageWidth descriptor- localHeight = fromIntegral $ gDescImageHeight descriptor-- 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, 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, without modifying the pixels. This--- function can output the following images:------ * 'ImageRGB8'------ * 'ImageRGBA8'----decodeGif :: B.ByteString -> Either String DynamicImage-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 [DynamicImage]-decodeGifImages img = fmap palettedToTrueColor . decodeAllGifImages <$> decode img---- | Extract a list of frame delays from a raw gif.-getDelaysGifImages :: B.ByteString -> Either String [GifDelay]-getDelaysGifImages img = getFrameDelays <$> decode img---- | Default palette to produce greyscale images.-greyPalette :: Palette-greyPalette = generateImage toGrey 256 1- where toGrey x _ = PixelRGB8 ix ix ix- where ix = fromIntegral x--checkGifImageSizes :: [(a, b, Image px)] -> Bool-checkGifImageSizes [] = False-checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest- where width = imageWidth img- height = imageHeight img-- 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- where go k | 2 ^ k >= itemCount = k- | otherwise = go $ k + 1---- | Encode a gif animation to a bytestring.------ * Every image must have the same size------ * Every palette must have between one and 256 colors.----encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)]- -> Either String L.ByteString-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- where- version = case imageList of- [] -> GIF87a- [_] -> GIF87a- _:_:_ -> GIF89a-- allFile = GifFile- { gifHeader = GifHeader- { gifVersion = version- , 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- }-- 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- Left err -> error $ "Impossible:" ++ err- Right v -> v---- | Encode an image with a given palette.--- Can return errors if the palette is ill-formed.------ * A palette must have between 1 and 256 colors----encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString-encodeGifImageWithPalette img palette =- encodeGifImages LoopingNever [(palette, 0, img)]---- | Write a greyscale in a gif file on the disk.-writeGifImage :: FilePath -> Image Pixel8 -> IO ()-writeGifImage file = L.writeFile file . encodeGifImage---- | Write a list of images as a gif animation in a file.------ * Every image must have the same size------ * Every palette must have between one and 256 colors.----writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)]- -> Either String (IO ())-writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst---- | Write a gif image with a palette to a file.------ * A palette must have between 1 and 256 colors----writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette- -> Either String (IO ())-writeGifImageWithPalette file img palette =- L.writeFile file <$> encodeGifImageWithPalette img palette-+{-# 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 + +#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 ) + +import Data.Bits( (.&.), (.|.) + , unsafeShiftR + , unsafeShiftL + , testBit, setBit ) +import Data.Word( Word8, Word16 ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +import Data.Binary( Binary(..), encode ) +import Data.Binary.Get( Get + , getWord8 + , getWord16le + , getByteString + , bytesRead + , skip + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16le + , putByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Types +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. +-- The delay is expressed in 100th of seconds. +type GifDelay = Int + +-- | Help to control the behaviour of GIF animation looping. +data GifLooping = + -- | The animation will stop once the end is reached + LoopingNever + -- | The animation will restart once the end is reached + | LoopingForever + -- | 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 + } + + +{- + <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer + + <Logical Screen> ::= Logical Screen Descriptor [Global Color Table] + + <Data> ::= <Graphic Block> | + <Special-Purpose Block> + + <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block> + + <Graphic-Rendering Block> ::= <Table-Based Image> | + Plain Text Extension + + <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data + + <Special-Purpose Block> ::= Application Extension | + Comment Extension + -} + +-------------------------------------------------- +---- GifVersion +-------------------------------------------------- +data GifVersion = GIF87a | GIF89a + +gif87aSignature, gif89aSignature :: B.ByteString +gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" +gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" + +instance Binary GifVersion where + put GIF87a = putByteString gif87aSignature + put GIF89a = putByteString gif89aSignature + + get = do + sig <- getByteString (B.length gif87aSignature) + case (sig == gif87aSignature, sig == gif89aSignature) of + (True, _) -> pure GIF87a + (_ , True) -> pure GIF89a + _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) + + +-------------------------------------------------- +---- LogicalScreenDescriptor +-------------------------------------------------- +-- | Section 18 of spec-gif89a +data LogicalScreenDescriptor = LogicalScreenDescriptor + { -- | Stored on 16 bits + screenWidth :: !Word16 + -- | Stored on 16 bits + , screenHeight :: !Word16 + -- | Stored on 8 bits + , backgroundIndex :: !Word8 + + -- | Stored on 1 bit + , hasGlobalMap :: !Bool + -- | Stored on 3 bits + , colorResolution :: !Word8 + -- | Stored on 1 bit + , isColorTableSorted :: !Bool + -- | Stored on 3 bits + , colorTableSize :: !Word8 + } + +instance Binary LogicalScreenDescriptor where + put v = do + putWord16le $ screenWidth v + putWord16le $ screenHeight v + let globalMapField + | hasGlobalMap v = 0x80 + | otherwise = 0 + + colorTableSortedField + | isColorTableSorted v = 0x08 + | otherwise = 0 + + tableSizeField = (colorTableSize v - 1) .&. 7 + + colorResolutionField = + ((colorResolution v - 1) .&. 7) `unsafeShiftL` 4 + + packedField = globalMapField + .|. colorTableSortedField + .|. tableSizeField + .|. colorResolutionField + + putWord8 packedField + putWord8 0 -- aspect ratio + putWord8 $ backgroundIndex v + + get = do + w <- getWord16le + h <- getWord16le + packedField <- getWord8 + backgroundColorIndex <- getWord8 + _aspectRatio <- getWord8 + return LogicalScreenDescriptor + { screenWidth = w + , screenHeight = h + , hasGlobalMap = packedField `testBit` 7 + , colorResolution = (packedField `unsafeShiftR` 4) .&. 0x7 + 1 + , isColorTableSorted = packedField `testBit` 3 + , colorTableSize = (packedField .&. 0x7) + 1 + , backgroundIndex = backgroundColorIndex + } + + +-------------------------------------------------- +---- ImageDescriptor +-------------------------------------------------- +-- | Section 20 of spec-gif89a +data ImageDescriptor = ImageDescriptor + { gDescPixelsFromLeft :: !Word16 + , gDescPixelsFromTop :: !Word16 + , gDescImageWidth :: !Word16 + , gDescImageHeight :: !Word16 + , gDescHasLocalMap :: !Bool + , gDescIsInterlaced :: !Bool + , gDescIsImgDescriptorSorted :: !Bool + , gDescLocalColorTableSize :: !Word8 + } + +imageSeparator, extensionIntroducer, gifTrailer :: Word8 +imageSeparator = 0x2C +extensionIntroducer = 0x21 +gifTrailer = 0x3B + +graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 +plainTextLabel = 0x01 +graphicControlLabel = 0xF9 +commentLabel = 0xFE +applicationLabel = 0xFF + + +parseDataBlocks :: Get B.ByteString +parseDataBlocks = B.concat <$> (getWord8 >>= aux) + where aux 0 = pure [] + aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) + +putDataBlocks :: B.ByteString -> Put +putDataBlocks wholeString = putSlices wholeString >> putWord8 0 + where putSlices str | B.length str == 0 = pure () + | B.length str > 0xFF = + let (before, after) = B.splitAt 0xFF str in + putWord8 0xFF >> putByteString before >> putSlices after + putSlices str = + putWord8 (fromIntegral $ B.length str) >> putByteString str + +data GifDisposalMethod + = DisposalAny + | DisposalDoNot + | DisposalRestoreBackground + | DisposalRestorePrevious + | DisposalUnknown Word8 + +disposalMethodOfCode :: Word8 -> GifDisposalMethod +disposalMethodOfCode v = case v of + 0 -> DisposalAny + 1 -> DisposalDoNot + 2 -> DisposalRestoreBackground + 3 -> DisposalRestorePrevious + n -> DisposalUnknown n + +codeOfDisposalMethod :: GifDisposalMethod -> Word8 +codeOfDisposalMethod v = case v of + DisposalAny -> 0 + DisposalDoNot -> 1 + DisposalRestoreBackground -> 2 + DisposalRestorePrevious -> 3 + DisposalUnknown n -> n + +data GraphicControlExtension = GraphicControlExtension + { gceDisposalMethod :: !GifDisposalMethod -- ^ Stored on 3 bits + , gceUserInputFlag :: !Bool + , gceTransparentFlag :: !Bool + , gceDelay :: !Word16 + , gceTransparentColorIndex :: !Word8 + } + +instance Binary GraphicControlExtension where + put v = do + putWord8 extensionIntroducer + putWord8 graphicControlLabel + putWord8 0x4 -- size + let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v + disposalField = + (disposalCode .&. 0x7) `unsafeShiftL` 2 + + userInputField + | gceUserInputFlag v = 0 `setBit` 1 + | otherwise = 0 + + transparentField + | gceTransparentFlag v = 0 `setBit` 0 + | otherwise = 0 + + packedFields = disposalField + .|. userInputField + .|. transparentField + + putWord8 packedFields + putWord16le $ gceDelay v + putWord8 $ gceTransparentColorIndex v + putWord8 0 -- blockTerminator + + get = do + -- due to missing lookahead + {-_extensionLabel <- getWord8-} + _size <- getWord8 + packedFields <- getWord8 + delay <- getWord16le + idx <- getWord8 + _blockTerminator <- getWord8 + return GraphicControlExtension + { gceDisposalMethod = + disposalMethodOfCode $ + (packedFields `unsafeShiftR` 2) .&. 0x07 + , gceUserInputFlag = packedFields `testBit` 1 + , gceTransparentFlag = packedFields `testBit` 0 + , gceDelay = delay + , gceTransparentColorIndex = idx + } + +data GifImage = GifImage + { imgDescriptor :: !ImageDescriptor + , imgLocalPalette :: !(Maybe Palette) + , imgLzwRootSize :: !Word8 + , imgData :: B.ByteString + } + +instance Binary GifImage where + put img = do + let descriptor = imgDescriptor img + put descriptor + case ( imgLocalPalette img + , gDescHasLocalMap $ imgDescriptor img) of + (Nothing, _) -> return () + (Just _, False) -> return () + (Just p, True) -> + putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p + putWord8 $ imgLzwRootSize img + putDataBlocks $ imgData img + + get = do + desc <- get + let hasLocalColorTable = gDescHasLocalMap desc + palette <- if hasLocalColorTable + then Just <$> getPalette (gDescLocalColorTableSize desc) + else pure Nothing + + GifImage desc palette <$> getWord8 <*> parseDataBlocks + +data Block = BlockImage GifImage + | BlockGraphicControl GraphicControlExtension + +skipSubDataBlocks :: Get () +skipSubDataBlocks = do + s <- fromIntegral <$> getWord8 + unless (s == 0) $ + skip s >> skipSubDataBlocks + +parseGifBlocks :: Get [Block] +parseGifBlocks = getWord8 >>= blockParse + where + blockParse v + | v == gifTrailer = pure [] + | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks + | v == extensionIntroducer = getWord8 >>= extensionParse + + blockParse v = do + readPosition <- bytesRead + fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) + + extensionParse code + | code == graphicControlLabel = + (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks + | code == commentLabel = skipSubDataBlocks >> parseGifBlocks + | code `elem` [plainTextLabel, applicationLabel] = + fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks + | otherwise = parseDataBlocks >> parseGifBlocks + + +instance Binary ImageDescriptor where + put v = do + putWord8 imageSeparator + putWord16le $ gDescPixelsFromLeft v + putWord16le $ gDescPixelsFromTop v + putWord16le $ gDescImageWidth v + putWord16le $ gDescImageHeight v + let localMapField + | gDescHasLocalMap v = 0 `setBit` 7 + | otherwise = 0 + + isInterlacedField + | gDescIsInterlaced v = 0 `setBit` 6 + | otherwise = 0 + + isImageDescriptorSorted + | gDescIsImgDescriptorSorted v = 0 `setBit` 5 + | otherwise = 0 + + localSize = gDescLocalColorTableSize v + tableSizeField + | localSize > 0 = (localSize - 1) .&. 0x7 + | otherwise = 0 + + packedFields = localMapField + .|. isInterlacedField + .|. isImageDescriptorSorted + .|. tableSizeField + putWord8 packedFields + + get = do + -- due to missing lookahead + {-_imageSeparator <- getWord8-} + imgLeftPos <- getWord16le + imgTopPos <- getWord16le + imgWidth <- getWord16le + imgHeight <- getWord16le + packedFields <- getWord8 + return ImageDescriptor + { gDescPixelsFromLeft = imgLeftPos + , gDescPixelsFromTop = imgTopPos + , gDescImageWidth = imgWidth + , gDescImageHeight = imgHeight + , gDescHasLocalMap = packedFields `testBit` 7 + , gDescIsInterlaced = packedFields `testBit` 6 + , gDescIsImgDescriptorSorted = packedFields `testBit` 5 + , gDescLocalColorTableSize = (packedFields .&. 0x7) + 1 + } + + +-------------------------------------------------- +---- Palette +-------------------------------------------------- +getPalette :: Word8 -> Get Palette +getPalette bitDepth = + Image size 1 . V.fromList <$> replicateM (size * 3) get + where size = 2 ^ (fromIntegral bitDepth :: Int) + +putPalette :: Int -> Palette -> Put +putPalette size pal = do + V.mapM_ putWord8 (imageData pal) + replicateM_ missingColorComponent (putWord8 0) + where elemCount = 2 ^ size + missingColorComponent = (elemCount - imageWidth pal) * 3 + +-------------------------------------------------- +---- GifImage +-------------------------------------------------- +data GifHeader = GifHeader + { gifVersion :: GifVersion + , gifScreenDescriptor :: LogicalScreenDescriptor + , gifGlobalMap :: Maybe Palette + } + +instance Binary GifHeader where + put v = do + put $ gifVersion v + let descr = gifScreenDescriptor v + put descr + case gifGlobalMap v of + Just palette -> putPalette (fromIntegral $ colorTableSize descr) palette + Nothing -> return () + + get = do + version <- get + screenDesc <- get + + palette <- + if hasGlobalMap screenDesc then + return <$> getPalette (colorTableSize screenDesc) + else + return Nothing + + return GifHeader + { gifVersion = version + , gifScreenDescriptor = screenDesc + , gifGlobalMap = palette + } + +data GifFile = GifFile + { gifHeader :: !GifHeader + , gifImages :: [(Maybe GraphicControlExtension, GifImage)] + , gifLoopingBehaviour :: GifLooping + } + +putLooping :: GifLooping -> Put +putLooping LoopingNever = return () +putLooping LoopingForever = putLooping $ LoopingRepeat 0 +putLooping (LoopingRepeat count) = do + putWord8 extensionIntroducer + putWord8 applicationLabel + putWord8 11 -- the size + putByteString $ BC.pack "NETSCAPE2.0" + putWord8 3 -- size of sub block + putWord8 1 + putWord16le count + putWord8 0 + +associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] +associateDescr [] = [] +associateDescr [BlockGraphicControl _] = [] +associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = + associateDescr rest +associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs +associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = + (Just ctrl, img) : associateDescr xs + +instance Binary GifFile where + put v = do + put $ gifHeader v + let putter (Nothing, i) = put i + putter (Just a, i) = put a >> put i + putLooping $ gifLoopingBehaviour v + mapM_ putter $ gifImages v + put gifTrailer + + get = do + hdr <- get + blocks <- parseGifBlocks + return GifFile { gifHeader = hdr + , gifImages = associateDescr blocks + , gifLoopingBehaviour = LoopingNever + } + +substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 +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 + decodeLzw (imgData img) 12 lzwRoot outputVector + frozenData <- lift $ V.unsafeFreeze outputVector + return . deinterlaceGif $ Image + { imageWidth = width + , imageHeight = height + , imageData = frozenData + } + where lzwRoot = fromIntegral $ imgLzwRootSize img + width = fromIntegral $ gDescImageWidth descriptor + height = fromIntegral $ gDescImageHeight descriptor + isInterlaced = gDescIsInterlaced descriptor + descriptor = imgDescriptor img + + deinterlaceGif | not isInterlaced = id + | otherwise = deinterlaceGifImage + +deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 +deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h + where lineIndices = gifInterlacingIndices h + generator x y = pixelAt img x y' + where y' = lineIndices V.! y + +gifInterlacingIndices :: Int -> V.Vector Int +gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices + where indices = flip zip [0..] $ + concat [ [0, 8 .. height - 1] + , [4, 4 + 8 .. height - 1] + , [2, 2 + 4 .. height - 1] + , [1, 1 + 2 .. height - 1] + ] + +paletteOf :: (ColorConvertible PixelRGB8 px) + => Image px -> GifImage -> Image px +paletteOf global GifImage { imgLocalPalette = Nothing } = global +paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p + +getFrameDelays :: GifFile -> [GifDelay] +getFrameDelays GifFile { gifImages = [] } = [] +getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs + where extractDelay (ext, _) = + case ext of + Nothing -> 0 + Just e -> fromIntegral $ gceDelay e + +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 } + | 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] + + | otherwise = + let backImage :: Image PixelRGBA8 + backImage = + generateImage (\_ _ -> transparentBackground) globalWidth globalHeight + + thisPalette :: Image PixelRGBA8 + thisPalette = paletteOf (promoteImage globalPalette) firstImage + + transparentCode = transparentColorOf firstControl + decoded = + substituteColorsWithTransparency transparentCode thisPalette $ + decodeImage firstImage + + initState = (thisPalette, firstControl, decoded) + scanner = + gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in + [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] + + where + globalWidth = fromIntegral $ screenWidth wholeDescriptor + globalHeight = fromIntegral $ screenHeight wholeDescriptor + globalPalette = maybe greyPalette id palette + + transparentBackground = PixelRGBA8 r g b 0 + where PixelRGB8 r g b = backgroundColor + + backgroundColor + | hasGlobalMap wholeDescriptor = + pixelAt globalPalette (fromIntegral $ backgroundIndex wholeDescriptor) 0 + | otherwise = PixelRGB8 0 0 0 + +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 + + thisImage = generateImage pixeler globalWidth globalHeight + localWidth = fromIntegral $ gDescImageWidth descriptor + localHeight = fromIntegral $ gDescImageHeight descriptor + + 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, 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, without modifying the pixels. This +-- function can output the following images: +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGBA8' +-- +decodeGif :: B.ByteString -> Either String DynamicImage +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 [DynamicImage] +decodeGifImages img = fmap palettedToTrueColor . decodeAllGifImages <$> decode img + +-- | Extract a list of frame delays from a raw gif. +getDelaysGifImages :: B.ByteString -> Either String [GifDelay] +getDelaysGifImages img = getFrameDelays <$> decode img + +-- | Default palette to produce greyscale images. +greyPalette :: Palette +greyPalette = generateImage toGrey 256 1 + 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 + where width = imageWidth img + height = imageHeight img + + checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = + w == width && h == height + +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 +-- +-- * Every palette must have between one and 256 colors. +-- +encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String L.ByteString +encodeGifImages _ [] = Left "No image in list" +encodeGifImages _ imageList + | not $ checkGifImageSizes imageList = Left "Gif images have different size" +encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = + encodeComplexGifImage $ GifEncode (imageWidth firstImage) (imageHeight firstImage) (Just firstPalette) Nothing looping frames + where + 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 + +-- | Encode a greyscale image to a bytestring. +encodeGifImage :: Image Pixel8 -> L.ByteString +encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of + Left err -> error $ "Impossible:" ++ err + Right v -> v + +-- | Encode an image with a given palette. +-- Can return errors if the palette is ill-formed. +-- +-- * A palette must have between 1 and 256 colors +-- +encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString +encodeGifImageWithPalette img palette = + encodeGifImages LoopingNever [(palette, 0, img)] + +-- | Write a greyscale in a gif file on the disk. +writeGifImage :: FilePath -> Image Pixel8 -> IO () +writeGifImage file = L.writeFile file . encodeGifImage + +-- | Write a list of images as a gif animation in a file. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String (IO ()) +writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst + +-- | Write a gif image with a palette to a file. +-- +-- * A palette must have between 1 and 256 colors +-- +writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette + -> Either String (IO ()) +writeGifImageWithPalette file img palette = + L.writeFile file <$> encodeGifImageWithPalette img palette + +writeComplexGifImage :: FilePath -> GifEncode -> Either String (IO ()) +writeComplexGifImage file spec = L.writeFile file <$> encodeComplexGifImage spec
+ src/Codec/Picture/Gif/Internal/LZW.hs view
@@ -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 +
+ src/Codec/Picture/Gif/Internal/LZWEncoding.hs view
@@ -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
− src/Codec/Picture/Gif/LZW.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE CPP #-}-module Codec.Picture.Gif.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-
− src/Codec/Picture/Gif/LZWEncoding.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}-module Codec.Picture.Gif.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)-- finalizeBoolWriter bitWriter- where- maxi = V.length vec-- startCodeSize = initialKeySize + 1-- clearCode = 2 ^ initialKeySize :: Int- endOfInfo = clearCode + 1- firstFreeIndex = endOfInfo + 1- - lookuper = lookupUpdate vec
src/Codec/Picture/HDR.hs view
@@ -1,530 +1,534 @@-{-# 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- , writeHDR- , 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 )-import Data.Monoid( (<>) )-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-import qualified Data.ByteString.Char8 as BC--import Data.List( partition )-import Data.Binary( Binary( .. ), encode )-import Data.Binary.Get( Get, getByteString, getWord8 )-import Data.Binary.Put( putByteString, putLazyByteString )--import Control.Monad.ST( ST, runST )-import Foreign.Storable ( Storable )-import Control.Monad.Primitive ( PrimState, PrimMonad )-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--#if MIN_VERSION_transformers(0, 4, 0)-import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT )-#else--- Transfomers 0.3 compat-import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT )--type ExceptT = ErrorT--throwE :: (Monad m, Error e) => e -> ErrorT e m a-throwE = throwError--runExceptT :: ErrorT e m a -> m (Either e a)-runExceptT = runErrorT-#endif--{-# INLINE (.<<.) #-}-(.<<.), (.>>.) :: (Bits a) => a -> Int -> a-(.<<.) = unsafeShiftL-(.>>.) = unsafeShiftR--{-# INLINE (.<-.) #-}-(.<-.) :: (PrimMonad m, Storable a)- => M.STVector (PrimState m) a -> Int -> a -> m ()-(.<-.) = M.write - {-M.unsafeWrite-}--type HDRReader s a = ExceptT String (ST s) a--data RGBE = RGBE !Word8 !Word8 !Word8 !Word8--instance Binary RGBE where- put (RGBE r g b e) = put r >> put g >> put b >> put e- get = RGBE <$> get <*> get <*> get <*> get--checkLineLength :: RGBE -> Int-checkLineLength (RGBE _ _ a b) =- (fromIntegral a .<<. 8) .|. fromIntegral b--isNewRunLengthMarker :: RGBE -> Bool-isNewRunLengthMarker (RGBE 2 2 _ _) = True-isNewRunLengthMarker _ = False--data RadianceFormat =- FormatRGBE- | FormatXYZE--radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString-radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"-radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"--instance Binary RadianceFormat where- put FormatRGBE = putByteString radiance32bitRleRGBEFormat- put FormatXYZE = putByteString radiance32bitRleXYZEFromat-- get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format- where format sig- | sig == radiance32bitRleRGBEFormat = pure FormatRGBE- | sig == radiance32bitRleXYZEFromat = pure FormatXYZE- | otherwise = fail "Unrecognized Radiance format"--toRGBE :: PixelRGBF -> RGBE-toRGBE (PixelRGBF r g b)- | d <= 1e-32 = RGBE 0 0 0 0- | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)- where d = maximum [r, g, b]- e = exponent d- coeff = significand d * 255.9999 / d- fix v = truncate $ v * coeff---dropUntil :: Word8 -> Get ()-dropUntil c = getWord8 >>= inner- where inner val | val == c = pure ()- inner _ = getWord8 >>= inner--getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString-getUntil f initialAcc = getWord8 >>= inner initialAcc- where inner acc c | f c = pure acc- inner acc c = getWord8 >>= inner (B.snoc acc c)--data RadianceHeader = RadianceHeader- { radianceInfos :: [(B.ByteString, B.ByteString)]- , radianceFormat :: RadianceFormat- , radianceHeight :: !Int- , radianceWidth :: !Int- , radianceData :: L.ByteString- }--radianceFileSignature :: B.ByteString-radianceFileSignature = BC.pack "#?RADIANCE\n"--unpackColor :: L.ByteString -> Int -> RGBE-unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)- where at n = L.index str . fromIntegral $ idx + n--storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()-storeColor vec idx (RGBE r g b e) = do- (vec .<-. (idx + 0)) r- (vec .<-. (idx + 1)) g- (vec .<-. (idx + 2)) b- (vec .<-. (idx + 3)) e--parsePair :: Char -> Get (B.ByteString, B.ByteString)-parsePair firstChar = do- let eol c = c == fromIntegral (ord '\n')- line <- getUntil eol B.empty- case BC.split '=' line of- [] -> pure (BC.singleton firstChar, B.empty)- [val] -> pure (BC.singleton firstChar, val)- [key, val] -> pure (BC.singleton firstChar <> key, val)- (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)--decodeInfos :: Get [(B.ByteString, B.ByteString)]-decodeInfos = do- char <- getChar8- case char of- -- comment- '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos- -- end of header, no more information- '\n' -> pure []- -- Classical parsing- c -> (:) <$> parsePair c <*> decodeInfos----- | Decode an HDR (radiance) image, the resulting image can be:------ * 'ImageRGBF'----decodeHDR :: B.ByteString -> Either String DynamicImage-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--isSign :: Char -> Bool-isSign c = c == '+' || c == '-'--isAxisLetter :: Char -> Bool-isAxisLetter c = c == 'X' || c == 'Y'--decodeNum :: Get Int-decodeNum = do- sign <- getChar8- letter <- getChar8- space <- getChar8-- 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')- numDec acc _- | sign == '-' = pure $ negate acc- | otherwise = pure acc-- getChar8 >>= numDec 0--copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()-copyPrevColor scanLine idx = do- r <- scanLine `M.unsafeRead` (idx - 4)- g <- scanLine `M.unsafeRead` (idx - 3)- b <- scanLine `M.unsafeRead` (idx - 2)- e <- scanLine `M.unsafeRead` (idx - 1)-- (scanLine `M.unsafeWrite` (idx + 0)) r- (scanLine `M.unsafeWrite` (idx + 1)) g- (scanLine `M.unsafeWrite` (idx + 2)) b- (scanLine `M.unsafeWrite` (idx + 3)) e--oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8- -> HDRReader s Int-oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0- where maxOutput = M.length scanLine- maxInput = fromIntegral $ L.length inputData-- inner readIdx writeIdx _- | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx- inner readIdx writeIdx shift = do- let color@(RGBE r g b e) = unpackColor inputData readIdx- isRun = r == 1 && g == 1 && b == 1-- if not isRun- then do- lift $ storeColor scanLine writeIdx color- inner (readIdx + 4) (writeIdx + 4) 0- - else do- let count = fromIntegral e .<<. shift- lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i)- inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)--newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8- -> HDRReader s Int-newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]- where dataAt idx- | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")"- | otherwise = pure $ L.index inputData (fromIntegral idx)-- maxOutput = M.length scanline- maxInput = fromIntegral $ L.length inputData- stride = 4--- strideSet count destIndex _ | endIndex > maxOutput + stride =- throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")"- where endIndex = destIndex + count * stride- strideSet count destIndex val = aux destIndex count- where aux i 0 = pure i- aux i c = do- lift $ (scanline .<-. i) val- aux (i + stride) (c - 1)--- strideCopy _ count destIndex- | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline"- where writeEndBound = destIndex + count * stride- strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count- where aux _ j 0 = pure j- aux i j c = do- val <- dataAt i- lift $ (scanline .<-. j) val- aux (i + 1) (j + stride) (c - 1)-- inner readIdx writeIdx- | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx- inner readIdx writeIdx = do- code <- dataAt readIdx- if code > 128- then do- let repeatCount = fromIntegral code .&. 0x7F- newVal <- dataAt $ readIdx + 1- endIndex <- strideSet repeatCount writeIdx newVal- inner (readIdx + 2) endIndex -- else do- let iCode = fromIntegral code- endIndex <- strideCopy (readIdx + 1) iCode writeIdx- inner (readIdx + iCode + 1) endIndex--instance Binary RadianceHeader where- get = decodeHeader- put hdr = do- putByteString radianceFileSignature- putByteString $ BC.pack "FORMAT="- put $ radianceFormat hdr- let sizeString =- BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)- ++ " +X " ++ show (radianceWidth hdr) ++ "\n"- putByteString sizeString- putLazyByteString $ radianceData hdr---decodeHeader :: Get RadianceHeader-decodeHeader = do- sig <- getByteString $ B.length radianceFileSignature- when (sig /= radianceFileSignature)- (fail "Invalid radiance file signature")-- infos <- decodeInfos- let formatKey = BC.pack "FORMAT"- case partition (\(k,_) -> k /= formatKey) infos of- (_, []) -> fail "No radiance format specified"- (info, [(_, formatString)]) ->- case runGet get $ L.fromChunks [formatString] of- Left err -> fail err- Right format -> do- (n1, n2, b) <- (,,) <$> decodeNum- <*> decodeNum- <*> getRemainingBytes- return . RadianceHeader info format n1 n2 $ L.fromChunks [b]-- _ -> fail "Multiple radiance format specified"--toFloat :: RGBE -> PixelRGBF-toFloat (RGBE r g b e) = PixelRGBF rf gf bf- where f = encodeFloat 1 $ fromIntegral e - (128 + 8)- rf = (fromIntegral r + 0.0) * f- gf = (fromIntegral g + 0.0) * f- bf = (fromIntegral b + 0.0) * f--encodeScanlineColor :: M.STVector s Word8- -> M.STVector s Word8- -> Int- -> ST s Int-encodeScanlineColor vec outVec outIdx = do- val <- vec `M.unsafeRead` 0- runLength 1 0 val 1 outIdx- where maxIndex = M.length vec-- pushRun len val at = do- (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80- (outVec `M.unsafeWrite` (at + 1)) val- return $ at + 2-- pushData start len at = do- (outVec `M.unsafeWrite` at) $ fromIntegral len- let first = start - len- end = start - 1- offset = at - first + 1- forM_ [first .. end] $ \i -> do- v <- vec `M.unsafeRead` i- (outVec `M.unsafeWrite` (offset + i)) v-- return $ at + len + 1-- -- End of scanline, empty the thing- runLength run cpy prev idx at | idx >= maxIndex =- case (run, cpy) of- (0, 0) -> pure at- (0, n) -> pushData idx n at- (n, 0) -> pushRun n prev at- (_, _) -> error "HDR - Run length algorithm is wrong"-- -- full runlength, we must write the packet- runLength r@127 _ prev idx at = do- val <- vec `M.unsafeRead` idx- pushRun r prev at >>=- runLength 1 0 val (idx + 1)-- -- full copy, we must write the packet- runLength _ c@127 _ idx at = do- val <- vec `M.unsafeRead` idx- pushData idx c at >>=- runLength 1 0 val (idx + 1)-- runLength n 0 prev idx at = do- val <- vec `M.unsafeRead` idx- 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 ->- pushRun n prev at >>=- runLength 1 0 val (idx + 1)-- runLength 0 n prev idx at = do- val <- vec `M.unsafeRead` idx- if val /= prev- then runLength 0 (n + 1) val (idx + 1) at- else- pushData (idx - 1) (n - 1) at >>=- runLength (2 :: Int) 0 val (idx + 1)-- runLength _ _ _ _ _ =- error "HDR RLE inconsistent state"---- | Write an High dynamic range image into a radiance--- image file on disk.-writeHDR :: FilePath -> Image PixelRGBF -> IO ()-writeHDR filename img = L.writeFile filename $ encodeHDR img---- | Write a RLE encoded High dynamic range image into a radiance--- image file on disk.-writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO ()-writeRLENewStyleHDR filename img =- L.writeFile filename $ encodeRLENewStyleHDR img---- | Encode an High dynamic range image into a radiance image--- file format.--- Alias for encodeRawHDR-encodeHDR :: Image PixelRGBF -> L.ByteString-encodeHDR = encodeRawHDR---- | Encode an High dynamic range image into a radiance image--- file format. without compression-encodeRawHDR :: Image PixelRGBF -> L.ByteString-encodeRawHDR pic = encode descriptor- where- newImage = pixelMap rgbeInRgba pic- -- we are cheating to death here, the layout we want- -- correspond to the layout of pixelRGBA8, so we- -- convert- rgbeInRgba pixel = PixelRGBA8 r g b e- where RGBE r g b e = toRGBE pixel-- descriptor = RadianceHeader- { radianceInfos = []- , radianceFormat = FormatRGBE- , radianceHeight = imageHeight pic- , radianceWidth = imageWidth pic- , radianceData = L.fromChunks [toByteString $ imageData newImage]- }----- | Encode an High dynamic range image into a radiance image--- file format using a light RLE compression. Some problems--- seem to arise with some image viewer.-encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString-encodeRLENewStyleHDR pic = encode $ runST $ do- let w = imageWidth pic- h = imageHeight pic-- scanLineR <- M.new w :: ST s (M.STVector s Word8)- scanLineG <- M.new w- scanLineB <- M.new w- scanLineE <- M.new w-- encoded <-- forM [0 .. h - 1] $ \line -> do- buff <- M.new $ w * 4 + w `div` 127 + 2- let columner col | col >= w = return ()- columner col = do- let RGBE r g b e = toRGBE $ pixelAt pic col line- (scanLineR `M.unsafeWrite` col) r- (scanLineG `M.unsafeWrite` col) g- (scanLineB `M.unsafeWrite` col) b- (scanLineE `M.unsafeWrite` col) e-- columner (col + 1)-- columner 0-- (buff `M.unsafeWrite` 0) 2- (buff `M.unsafeWrite` 1) 2- (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF)- (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF)-- i1 <- encodeScanlineColor scanLineR buff 4 - i2 <- encodeScanlineColor scanLineG buff i1- i3 <- encodeScanlineColor scanLineB buff i2- endIndex <- encodeScanlineColor scanLineE buff i3-- (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff-- pure RadianceHeader- { radianceInfos = []- , radianceFormat = FormatRGBE- , radianceHeight = h- , radianceWidth = w- , radianceData = L.fromChunks encoded - }- --decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)-decodeRadiancePicture hdr = do- let width = abs $ radianceWidth hdr- height = abs $ radianceHeight hdr- packedData = radianceData hdr-- scanLine <- lift $ M.new $ width * 4- resultBuffer <- lift $ M.new $ width * height * 3-- let scanLineImage = MutableImage- { mutableImageWidth = width- , mutableImageHeight = 1- , mutableImageData = scanLine- }-- finalImage = MutableImage- { mutableImageWidth = width- , mutableImageHeight = height- , mutableImageData = resultBuffer- }-- let scanLineExtractor readIdx line = do- let color = unpackColor packedData readIdx- inner | isNewRunLengthMarker color = do- let calcSize = checkLineLength color- when (calcSize /= width)- (throwE "Invalid sanline size")- pure $ \idx -> newStyleRLE packedData (idx + 4)- | otherwise = pure $ oldStyleRLE packedData- f <- inner- newRead <- f readIdx scanLine- forM_ [0 .. width - 1] $ \i -> do- -- mokay, it's a hack, but I don't want to define a- -- pixel instance of RGBE...- PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0- lift $ writePixel finalImage i line . toFloat $ RGBE r g b e-- return newRead-- foldM_ scanLineExtractor 0 [0 .. height - 1]-- return finalImage-+{-# 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 + , writeHDR + , 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( (<>) ) +#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 +import qualified Data.ByteString.Char8 as BC + +import Data.List( partition ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get, getByteString, getWord8 ) +import Data.Binary.Put( putByteString, putLazyByteString ) + +import Control.Monad.ST( ST, runST ) +import Foreign.Storable ( Storable ) +import Control.Monad.Primitive ( PrimState, PrimMonad ) +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 + +#if MIN_VERSION_transformers(0, 4, 0) +import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT ) +#else +-- Transfomers 0.3 compat +import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT ) + +type ExceptT = ErrorT + +throwE :: (Monad m, Error e) => e -> ErrorT e m a +throwE = throwError + +runExceptT :: ErrorT e m a -> m (Either e a) +runExceptT = runErrorT +#endif + +{-# INLINE (.<<.) #-} +(.<<.), (.>>.) :: (Bits a) => a -> Int -> a +(.<<.) = unsafeShiftL +(.>>.) = unsafeShiftR + +{-# INLINE (.<-.) #-} +(.<-.) :: (PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> a -> m () +(.<-.) = M.write + {-M.unsafeWrite-} + +type HDRReader s a = ExceptT String (ST s) a + +data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 + +instance Binary RGBE where + put (RGBE r g b e) = put r >> put g >> put b >> put e + get = RGBE <$> get <*> get <*> get <*> get + +checkLineLength :: RGBE -> Int +checkLineLength (RGBE _ _ a b) = + (fromIntegral a .<<. 8) .|. fromIntegral b + +isNewRunLengthMarker :: RGBE -> Bool +isNewRunLengthMarker (RGBE 2 2 _ _) = True +isNewRunLengthMarker _ = False + +data RadianceFormat = + FormatRGBE + | FormatXYZE + +radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString +radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe" +radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze" + +instance Binary RadianceFormat where + put FormatRGBE = putByteString radiance32bitRleRGBEFormat + put FormatXYZE = putByteString radiance32bitRleXYZEFromat + + get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format + where format sig + | sig == radiance32bitRleRGBEFormat = pure FormatRGBE + | sig == radiance32bitRleXYZEFromat = pure FormatXYZE + | otherwise = fail "Unrecognized Radiance format" + +toRGBE :: PixelRGBF -> RGBE +toRGBE (PixelRGBF r g b) + | d <= 1e-32 = RGBE 0 0 0 0 + | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128) + where d = maximum [r, g, b] + e = exponent d + coeff = significand d * 255.9999 / d + fix v = truncate $ v * coeff + + +dropUntil :: Word8 -> Get () +dropUntil c = getWord8 >>= inner + where inner val | val == c = pure () + inner _ = getWord8 >>= inner + +getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString +getUntil f initialAcc = getWord8 >>= inner initialAcc + where inner acc c | f c = pure acc + inner acc c = getWord8 >>= inner (B.snoc acc c) + +data RadianceHeader = RadianceHeader + { radianceInfos :: [(B.ByteString, B.ByteString)] + , radianceFormat :: RadianceFormat + , radianceHeight :: !Int + , radianceWidth :: !Int + , radianceData :: L.ByteString + } + +radianceFileSignature :: B.ByteString +radianceFileSignature = BC.pack "#?RADIANCE\n" + +unpackColor :: L.ByteString -> Int -> RGBE +unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3) + where at n = L.index str . fromIntegral $ idx + n + +storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s () +storeColor vec idx (RGBE r g b e) = do + (vec .<-. (idx + 0)) r + (vec .<-. (idx + 1)) g + (vec .<-. (idx + 2)) b + (vec .<-. (idx + 3)) e + +parsePair :: Char -> Get (B.ByteString, B.ByteString) +parsePair firstChar = do + let eol c = c == fromIntegral (ord '\n') + line <- getUntil eol B.empty + case BC.split '=' line of + [] -> pure (BC.singleton firstChar, B.empty) + [val] -> pure (BC.singleton firstChar, val) + [key, val] -> pure (BC.singleton firstChar <> key, val) + (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals) + +decodeInfos :: Get [(B.ByteString, B.ByteString)] +decodeInfos = do + char <- getChar8 + case char of + -- comment + '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos + -- end of header, no more information + '\n' -> pure [] + -- Classical parsing + c -> (:) <$> parsePair c <*> decodeInfos + + +-- | Decode an HDR (radiance) image, the resulting image can be: +-- +-- * 'ImageRGBF' +-- +decodeHDR :: B.ByteString -> Either String DynamicImage +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 + +isSign :: Char -> Bool +isSign c = c == '+' || c == '-' + +isAxisLetter :: Char -> Bool +isAxisLetter c = c == 'X' || c == 'Y' + +decodeNum :: Get Int +decodeNum = do + sign <- getChar8 + letter <- getChar8 + space <- getChar8 + + 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') + numDec acc _ + | sign == '-' = pure $ negate acc + | otherwise = pure acc + + getChar8 >>= numDec 0 + +copyPrevColor :: M.STVector s Word8 -> Int -> ST s () +copyPrevColor scanLine idx = do + r <- scanLine `M.unsafeRead` (idx - 4) + g <- scanLine `M.unsafeRead` (idx - 3) + b <- scanLine `M.unsafeRead` (idx - 2) + e <- scanLine `M.unsafeRead` (idx - 1) + + (scanLine `M.unsafeWrite` (idx + 0)) r + (scanLine `M.unsafeWrite` (idx + 1)) g + (scanLine `M.unsafeWrite` (idx + 2)) b + (scanLine `M.unsafeWrite` (idx + 3)) e + +oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 + where maxOutput = M.length scanLine + maxInput = fromIntegral $ L.length inputData + + inner readIdx writeIdx _ + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx shift = do + let color@(RGBE r g b e) = unpackColor inputData readIdx + isRun = r == 1 && g == 1 && b == 1 + + if not isRun + then do + lift $ storeColor scanLine writeIdx color + inner (readIdx + 4) (writeIdx + 4) 0 + + else do + let count = fromIntegral e .<<. shift + lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) + inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) + +newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] + where dataAt idx + | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")" + | otherwise = pure $ L.index inputData (fromIntegral idx) + + maxOutput = M.length scanline + maxInput = fromIntegral $ L.length inputData + stride = 4 + + + strideSet count destIndex _ | endIndex > maxOutput + stride = + throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" + where endIndex = destIndex + count * stride + strideSet count destIndex val = aux destIndex count + where aux i 0 = pure i + aux i c = do + lift $ (scanline .<-. i) val + aux (i + stride) (c - 1) + + + strideCopy _ count destIndex + | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline" + where writeEndBound = destIndex + count * stride + strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count + where aux _ j 0 = pure j + aux i j c = do + val <- dataAt i + lift $ (scanline .<-. j) val + aux (i + 1) (j + stride) (c - 1) + + inner readIdx writeIdx + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx = do + code <- dataAt readIdx + if code > 128 + then do + let repeatCount = fromIntegral code .&. 0x7F + newVal <- dataAt $ readIdx + 1 + endIndex <- strideSet repeatCount writeIdx newVal + inner (readIdx + 2) endIndex + + else do + let iCode = fromIntegral code + endIndex <- strideCopy (readIdx + 1) iCode writeIdx + inner (readIdx + iCode + 1) endIndex + +instance Binary RadianceHeader where + get = decodeHeader + put hdr = do + putByteString radianceFileSignature + putByteString $ BC.pack "FORMAT=" + put $ radianceFormat hdr + let sizeString = + BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) + ++ " +X " ++ show (radianceWidth hdr) ++ "\n" + putByteString sizeString + putLazyByteString $ radianceData hdr + + +decodeHeader :: Get RadianceHeader +decodeHeader = do + sig <- getByteString $ B.length radianceFileSignature + when (sig /= radianceFileSignature) + (fail "Invalid radiance file signature") + + infos <- decodeInfos + let formatKey = BC.pack "FORMAT" + case partition (\(k,_) -> k /= formatKey) infos of + (_, []) -> fail "No radiance format specified" + (info, [(_, formatString)]) -> + case runGet get $ L.fromChunks [formatString] of + Left err -> fail err + Right format -> do + (n1, n2, b) <- (,,) <$> decodeNum + <*> decodeNum + <*> getRemainingBytes + return . RadianceHeader info format n1 n2 $ L.fromChunks [b] + + _ -> fail "Multiple radiance format specified" + +toFloat :: RGBE -> PixelRGBF +toFloat (RGBE r g b e) = PixelRGBF rf gf bf + where f = encodeFloat 1 $ fromIntegral e - (128 + 8) + rf = (fromIntegral r + 0.0) * f + gf = (fromIntegral g + 0.0) * f + bf = (fromIntegral b + 0.0) * f + +encodeScanlineColor :: M.STVector s Word8 + -> M.STVector s Word8 + -> Int + -> ST s Int +encodeScanlineColor vec outVec outIdx = do + val <- vec `M.unsafeRead` 0 + runLength 1 0 val 1 outIdx + where maxIndex = M.length vec + + pushRun len val at = do + (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 + (outVec `M.unsafeWrite` (at + 1)) val + return $ at + 2 + + pushData start len at = do + (outVec `M.unsafeWrite` at) $ fromIntegral len + let first = start - len + end = start - 1 + offset = at - first + 1 + forM_ [first .. end] $ \i -> do + v <- vec `M.unsafeRead` i + (outVec `M.unsafeWrite` (offset + i)) v + + return $ at + len + 1 + + -- End of scanline, empty the thing + runLength run cpy prev idx at | idx >= maxIndex = + case (run, cpy) of + (0, 0) -> pure at + (0, n) -> pushData idx n at + (n, 0) -> pushRun n prev at + (_, _) -> error "HDR - Run length algorithm is wrong" + + -- full runlength, we must write the packet + runLength r@127 _ prev idx at = do + val <- vec `M.unsafeRead` idx + pushRun r prev at >>= + runLength 1 0 val (idx + 1) + + -- full copy, we must write the packet + runLength _ c@127 _ idx at = do + val <- vec `M.unsafeRead` idx + pushData idx c at >>= + runLength 1 0 val (idx + 1) + + runLength n 0 prev idx at = do + val <- vec `M.unsafeRead` idx + 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 -> + pushRun n prev at >>= + runLength 1 0 val (idx + 1) + + runLength 0 n prev idx at = do + val <- vec `M.unsafeRead` idx + if val /= prev + then runLength 0 (n + 1) val (idx + 1) at + else + pushData (idx - 1) (n - 1) at >>= + runLength (2 :: Int) 0 val (idx + 1) + + runLength _ _ _ _ _ = + error "HDR RLE inconsistent state" + +-- | Write an High dynamic range image into a radiance +-- image file on disk. +writeHDR :: FilePath -> Image PixelRGBF -> IO () +writeHDR filename img = L.writeFile filename $ encodeHDR img + +-- | Write a RLE encoded High dynamic range image into a radiance +-- image file on disk. +writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO () +writeRLENewStyleHDR filename img = + L.writeFile filename $ encodeRLENewStyleHDR img + +-- | Encode an High dynamic range image into a radiance image +-- file format. +-- Alias for encodeRawHDR +encodeHDR :: Image PixelRGBF -> L.ByteString +encodeHDR = encodeRawHDR + +-- | Encode an High dynamic range image into a radiance image +-- file format. without compression +encodeRawHDR :: Image PixelRGBF -> L.ByteString +encodeRawHDR pic = encode descriptor + where + newImage = pixelMap rgbeInRgba pic + -- we are cheating to death here, the layout we want + -- correspond to the layout of pixelRGBA8, so we + -- convert + rgbeInRgba pixel = PixelRGBA8 r g b e + where RGBE r g b e = toRGBE pixel + + descriptor = RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = imageHeight pic + , radianceWidth = imageWidth pic + , radianceData = L.fromChunks [toByteString $ imageData newImage] + } + + +-- | Encode an High dynamic range image into a radiance image +-- file format using a light RLE compression. Some problems +-- seem to arise with some image viewer. +encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString +encodeRLENewStyleHDR pic = encode $ runST $ do + let w = imageWidth pic + h = imageHeight pic + + scanLineR <- M.new w :: ST s (M.STVector s Word8) + scanLineG <- M.new w + scanLineB <- M.new w + scanLineE <- M.new w + + encoded <- + forM [0 .. h - 1] $ \line -> do + buff <- M.new $ w * 4 + w `div` 127 + 2 + let columner col | col >= w = return () + columner col = do + let RGBE r g b e = toRGBE $ pixelAt pic col line + (scanLineR `M.unsafeWrite` col) r + (scanLineG `M.unsafeWrite` col) g + (scanLineB `M.unsafeWrite` col) b + (scanLineE `M.unsafeWrite` col) e + + columner (col + 1) + + columner 0 + + (buff `M.unsafeWrite` 0) 2 + (buff `M.unsafeWrite` 1) 2 + (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) + (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) + + i1 <- encodeScanlineColor scanLineR buff 4 + i2 <- encodeScanlineColor scanLineG buff i1 + i3 <- encodeScanlineColor scanLineB buff i2 + endIndex <- encodeScanlineColor scanLineE buff i3 + + (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff + + pure RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = h + , radianceWidth = w + , radianceData = L.fromChunks encoded + } + + +decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) +decodeRadiancePicture hdr = do + let width = abs $ radianceWidth hdr + height = abs $ radianceHeight hdr + packedData = radianceData hdr + + scanLine <- lift $ M.new $ width * 4 + resultBuffer <- lift $ M.new $ width * height * 3 + + let scanLineImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = 1 + , mutableImageData = scanLine + } + + finalImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = height + , mutableImageData = resultBuffer + } + + let scanLineExtractor readIdx line = do + let color = unpackColor packedData readIdx + inner | isNewRunLengthMarker color = do + let calcSize = checkLineLength color + when (calcSize /= width) + (throwE "Invalid sanline size") + pure $ \idx -> newStyleRLE packedData (idx + 4) + | otherwise = pure $ oldStyleRLE packedData + f <- inner + newRead <- f readIdx scanLine + forM_ [0 .. width - 1] $ \i -> do + -- mokay, it's a hack, but I don't want to define a + -- pixel instance of RGBE... + PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 + lift $ writePixel finalImage i line . toFloat $ RGBE r g b e + + return newRead + + foldM_ scanLineExtractor 0 [0 .. height - 1] + + return finalImage +
src/Codec/Picture/InternalHelper.hs view
@@ -1,51 +1,32 @@-{-# LANGUAGE CPP #-}-module Codec.Picture.InternalHelper ( runGet- , runGetStrict- , decode- , getRemainingBytes- , getRemainingLazyBytes ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Binary( Binary( get ) )-import Data.Binary.Get( Get- , getRemainingLazyByteString- )-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--getRemainingLazyBytes :: Get L.ByteString-getRemainingLazyBytes = getRemainingLazyByteString -+{-# LANGUAGE CPP #-} +module Codec.Picture.InternalHelper ( runGet + , runGetStrict + , decode + , getRemainingBytes + , getRemainingLazyBytes ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Binary( Binary( get ) ) +import Data.Binary.Get( Get + , getRemainingLazyByteString + ) +import qualified Data.Binary.Get as G + +decode :: (Binary a) => B.ByteString -> Either String a +decode = runGetStrict get + +runGet :: Get a -> L.ByteString -> Either String a +runGet act = unpack . G.runGetOrFail act + where unpack (Left (_, _, str)) = Left str + unpack (Right (_, _, element)) = Right element + +runGetStrict :: Get a -> B.ByteString -> Either String a +runGetStrict act buffer = runGet act $ L.fromChunks [buffer] + +getRemainingBytes :: Get B.ByteString +getRemainingBytes = L.toStrict <$> getRemainingLazyByteString + +getRemainingLazyBytes :: Get L.ByteString +getRemainingLazyBytes = getRemainingLazyByteString +
src/Codec/Picture/Jpg.hs view
@@ -31,7 +31,9 @@ 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 ) @@ -52,14 +54,14 @@ import Codec.Picture.Metadata( Metadatas , SourceFormat( SourceJpeg ) , basicMetadata ) -import Codec.Picture.Tiff.Types -import Codec.Picture.Tiff.Metadata -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.Jpg.Metadata +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) @@ -309,7 +311,7 @@ scanSpecifier scanCount scanSpec = do compMapping <- gets componentIndexMapping comp <- case lookup (componentSelector scanSpec) compMapping of - Nothing -> fail "Jpg decoding error - bad component selector in blob." + Nothing -> error "Jpg decoding error - bad component selector in blob." Just v -> return v let maximumHuffmanTable = 4 dcIndex = min (maximumHuffmanTable - 1) @@ -326,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 @@ -420,9 +422,16 @@ 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] + (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 @@ -572,7 +581,7 @@ let (st, arr) = decodeBaseline jfifMeta = foldMap extractMetadatas $ app0JFifMarker st exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st - meta = sizeMeta <> jfifMeta <> exifMeta + meta = jfifMeta <> exifMeta <> sizeMeta in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr @@ -580,7 +589,7 @@ let (st, arr) = decodeProgressive jfifMeta = foldMap extractMetadatas $ app0JFifMarker st exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st - meta = sizeMeta <> jfifMeta <> exifMeta + meta = jfifMeta <> exifMeta <> sizeMeta in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr
− src/Codec/Picture/Jpg/Common.hs
@@ -1,240 +0,0 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.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.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 - -- | 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 -
− src/Codec/Picture/Jpg/DefaultTable.hs
@@ -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 - ] - ] -
− src/Codec/Picture/Jpg/FastDct.hs
@@ -1,218 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-module Codec.Picture.Jpg.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.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" #-}-
− src/Codec/Picture/Jpg/FastIdct.hs
@@ -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 -
+ src/Codec/Picture/Jpg/Internal/Common.hs view
@@ -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 +
+ src/Codec/Picture/Jpg/Internal/DefaultTable.hs view
@@ -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 + ] + ] +
+ src/Codec/Picture/Jpg/Internal/FastDct.hs view
@@ -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" #-} +
+ src/Codec/Picture/Jpg/Internal/FastIdct.hs view
@@ -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 +
+ src/Codec/Picture/Jpg/Internal/Metadata.hs view
@@ -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 + } +
+ src/Codec/Picture/Jpg/Internal/Progressive.hs view
@@ -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 +
+ src/Codec/Picture/Jpg/Internal/Types.hs view
@@ -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: +-- <https://github.com/corkami/formats/blob/master/image/jpeg.md> +-- +-- 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
− src/Codec/Picture/Jpg/Metadata.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE CPP #-}-module Codec.Picture.Jpg.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.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- }-
− src/Codec/Picture/Jpg/Progressive.hs
@@ -1,332 +0,0 @@-{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.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.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 = 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 -
− src/Codec/Picture/Jpg/Types.hs
@@ -1,753 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Types( MutableMacroBlock - , createEmptyMutableMacroBlock - , printMacroBlock - , printPureMacroBlock - , DcCoefficient - , JpgImage( .. ) - , JpgComponent( .. ) - , JpgFrameHeader( .. ) - , JpgFrame( .. ) - , JpgFrameKind( .. ) - , JpgScanHeader( .. ) - , JpgQuantTableSpec( .. ) - , JpgHuffmanTableSpec( .. ) - , JpgImageKind( .. ) - , JpgScanSpecification( .. ) - , JpgColorSpace( .. ) - , AdobeTransform( .. ) - , JpgAdobeApp14( .. ) - , JpgJFIFApp0( .. ) - , JFifUnit( .. ) - , calculateSize - , dctBlockSize - ) where - - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<*>), (<$>) ) -#endif - -import Control.Monad( when, replicateM, forM, forM_, unless ) -import Control.Monad.ST( ST ) -import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) -import Data.List( partition ) -import Data.Monoid( (<>) ) -import Foreign.Storable ( Storable ) -import Data.Vector.Unboxed( (!) ) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L - -import Data.Int( Int16 ) -import Data.Word(Word8, Word16 ) -import Data.Binary( Binary(..) ) - -import Data.Binary.Get( Get - , getWord8 - , getWord16be - , getByteString - , skip - , bytesRead - ) - -import Data.Binary.Put( Put - , putWord8 - , putWord16be - , putLazyByteString - , putByteString - , runPut - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Jpg.DefaultTable -import Codec.Picture.Tiff.Types -import Codec.Picture.Tiff.Metadata( exifOffsetIfd ) -import Codec.Picture.Metadata.Exif - -{-import Debug.Trace-} -import Text.Printf - --- | Type only used to make clear what kind of integer we are carrying --- Might be transformed into newtype in the future -type DcCoefficient = Int16 - --- | Macroblock that can be transformed. -type MutableMacroBlock s a = M.STVector s a - -data JpgFrameKind = - JpgBaselineDCTHuffman - | JpgExtendedSequentialDCTHuffman - | JpgProgressiveDCTHuffman - | JpgLosslessHuffman - | JpgDifferentialSequentialDCTHuffman - | JpgDifferentialProgressiveDCTHuffman - | JpgDifferentialLosslessHuffman - | JpgExtendedSequentialArithmetic - | JpgProgressiveDCTArithmetic - | JpgLosslessArithmetic - | JpgDifferentialSequentialDCTArithmetic - | JpgDifferentialProgressiveDCTArithmetic - | JpgDifferentialLosslessArithmetic - | JpgQuantizationTable - | JpgHuffmanTableMarker - | JpgStartOfScan - | JpgEndOfImage - | JpgAppSegment Word8 - | JpgExtensionSegment Word8 - - | JpgRestartInterval - | JpgRestartIntervalEnd Word8 - deriving (Eq, Show) - -data JpgFrame = - JpgAppFrame !Word8 B.ByteString - | JpgAdobeAPP14 !JpgAdobeApp14 - | JpgJFIF !JpgJFIFApp0 - | JpgExif ![ImageFileDirectory] - | JpgExtension !Word8 B.ByteString - | JpgQuantTable ![JpgQuantTableSpec] - | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] - | JpgScanBlob !JpgScanHeader !L.ByteString - | JpgScans !JpgFrameKind !JpgFrameHeader - | JpgIntervalRestart !Word16 - deriving Show - -data JpgColorSpace - = JpgColorSpaceYCbCr - | JpgColorSpaceYCC - | JpgColorSpaceY - | JpgColorSpaceYA - | JpgColorSpaceYCCA - | JpgColorSpaceYCCK - | JpgColorSpaceCMYK - | JpgColorSpaceRGB - | JpgColorSpaceRGBA - deriving Show - -data AdobeTransform - = AdobeUnknown -- ^ Value 0 - | AdobeYCbCr -- ^ value 1 - | AdobeYCck -- ^ value 2 - deriving Show - -data JpgAdobeApp14 = JpgAdobeApp14 - { _adobeDctVersion :: !Word16 - , _adobeFlag0 :: !Word16 - , _adobeFlag1 :: !Word16 - , _adobeTransform :: !AdobeTransform - } - deriving Show - --- | Size: 1 -data JFifUnit - = JFifUnitUnknown -- ^ 0 - | JFifPixelsPerInch -- ^ 1 - | JFifPixelsPerCentimeter -- ^ 2 - deriving Show - -instance Binary JFifUnit where - put v = putWord8 $ case v of - JFifUnitUnknown -> 0 - JFifPixelsPerInch -> 1 - JFifPixelsPerCentimeter -> 2 - get = do - v <- getWord8 - pure $ case v of - 0 -> JFifUnitUnknown - 1 -> JFifPixelsPerInch - 2 -> JFifPixelsPerCentimeter - _ -> JFifUnitUnknown - -data JpgJFIFApp0 = JpgJFIFApp0 - { _jfifUnit :: !JFifUnit - , _jfifDpiX :: !Word16 - , _jfifDpiY :: !Word16 - , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int) - } - deriving Show - -instance Binary JpgJFIFApp0 where - get = do - sig <- getByteString 5 - when (sig /= BC.pack "JFIF\0") $ - fail "Invalid JFIF signature" - major <- getWord8 - minor <- getWord8 - when (major /= 1 && minor > 2) $ - fail "Unrecognize JFIF version" - unit <- get - dpiX <- getWord16be - dpiY <- getWord16be - w <- getWord8 - h <- getWord8 - let pxCount = 3 * w * h - img <- case pxCount of - 0 -> return Nothing - _ -> return Nothing - return $ JpgJFIFApp0 - { _jfifUnit = unit - , _jfifDpiX = dpiX - , _jfifDpiY = dpiY - , _jfifThumbnail = img - } - - - put jfif = do - putByteString $ BC.pack "JFIF\0" -- 5 - putWord8 1 -- 1 6 - putWord8 2 -- 1 7 - put $ _jfifUnit jfif -- 1 8 - putWord16be $ _jfifDpiX jfif -- 2 10 - putWord16be $ _jfifDpiY jfif -- 2 12 - putWord8 0 -- 1 13 - putWord8 0 -- 1 14 - -{-Thumbnail width (tw) 1 Horizontal size of embedded JFIF thumbnail in pixels-} -{-Thumbnail height (th) 1 Vertical size of embedded JFIF thumbnail in pixels-} -{-Thumbnail data 3 × tw × th Uncompressed 24 bit RGB raster thumbnail-} - -instance Binary AdobeTransform where - put v = case v of - AdobeUnknown -> putWord8 0 - AdobeYCbCr -> putWord8 1 - AdobeYCck -> putWord8 2 - - get = do - v <- getWord8 - pure $ case v of - 0 -> AdobeUnknown - 1 -> AdobeYCbCr - 2 -> AdobeYCck - _ -> AdobeUnknown - -instance Binary JpgAdobeApp14 where - get = do - let sig = BC.pack "Adobe" - fileSig <- getByteString 5 - when (fileSig /= sig) $ - fail "Invalid Adobe APP14 marker" - version <- getWord16be - when (version /= 100) $ - fail $ "Invalid Adobe APP14 version " ++ show version - JpgAdobeApp14 version - <$> getWord16be - <*> getWord16be <*> get - - put (JpgAdobeApp14 v f0 f1 t) = do - putByteString $ BC.pack "Adobe" - putWord16be v - putWord16be f0 - putWord16be f1 - put t - - -data JpgFrameHeader = JpgFrameHeader - { jpgFrameHeaderLength :: !Word16 - , jpgSamplePrecision :: !Word8 - , jpgHeight :: !Word16 - , jpgWidth :: !Word16 - , jpgImageComponentCount :: !Word8 - , jpgComponents :: ![JpgComponent] - } - deriving Show - - -instance SizeCalculable JpgFrameHeader where - calculateSize hdr = 2 + 1 + 2 + 2 + 1 - + sum [calculateSize c | c <- jpgComponents hdr] - -data JpgComponent = JpgComponent - { componentIdentifier :: !Word8 - -- | Stored with 4 bits - , horizontalSamplingFactor :: !Word8 - -- | Stored with 4 bits - , verticalSamplingFactor :: !Word8 - , quantizationTableDest :: !Word8 - } - deriving Show - -instance SizeCalculable JpgComponent where - calculateSize _ = 3 - -data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } - deriving Show - -data JpgScanSpecification = JpgScanSpecification - { componentSelector :: !Word8 - -- | Encoded as 4 bits - , dcEntropyCodingTable :: !Word8 - -- | Encoded as 4 bits - , acEntropyCodingTable :: !Word8 - - } - deriving Show - -instance SizeCalculable JpgScanSpecification where - calculateSize _ = 2 - -data JpgScanHeader = JpgScanHeader - { scanLength :: !Word16 - , scanComponentCount :: !Word8 - , scans :: [JpgScanSpecification] - - -- | (begin, end) - , spectralSelection :: (Word8, Word8) - - -- | Encoded as 4 bits - , successiveApproxHigh :: !Word8 - - -- | Encoded as 4 bits - , successiveApproxLow :: !Word8 - } - deriving Show - -instance SizeCalculable JpgScanHeader where - calculateSize hdr = 2 + 1 - + sum [calculateSize c | c <- scans hdr] - + 2 - + 1 - -data JpgQuantTableSpec = JpgQuantTableSpec - { -- | Stored on 4 bits - quantPrecision :: !Word8 - - -- | Stored on 4 bits - , quantDestination :: !Word8 - - , quantTable :: MacroBlock Int16 - } - deriving Show - -class SizeCalculable a where - calculateSize :: a -> Int - --- | Type introduced only to avoid some typeclass overlapping --- problem -newtype TableList a = TableList [a] - -instance (SizeCalculable a, Binary a) => Binary (TableList a) where - put (TableList lst) = do - putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 - mapM_ put lst - - get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) - where innerParse :: Int -> Get [a] - innerParse 0 = return [] - innerParse size = do - onStart <- fromIntegral <$> bytesRead - table <- get - onEnd <- fromIntegral <$> bytesRead - (table :) <$> innerParse (size - (onEnd - onStart)) - -instance SizeCalculable JpgQuantTableSpec where - calculateSize table = - 1 + (fromIntegral (quantPrecision table) + 1) * 64 - -instance Binary JpgQuantTableSpec where - put table = do - let precision = quantPrecision table - put4BitsOfEach precision (quantDestination table) - forM_ (VS.toList $ quantTable table) $ \coeff -> - if precision == 0 then putWord8 $ fromIntegral coeff - else putWord16be $ fromIntegral coeff - - get = do - (precision, dest) <- get4BitOfEach - coeffs <- replicateM 64 $ if precision == 0 - then fromIntegral <$> getWord8 - else fromIntegral <$> getWord16be - return JpgQuantTableSpec - { quantPrecision = precision - , quantDestination = dest - , quantTable = VS.fromListN 64 coeffs - } - -data JpgHuffmanTableSpec = JpgHuffmanTableSpec - { -- | 0 : DC, 1 : AC, stored on 4 bits - huffmanTableClass :: !DctComponent - -- | Stored on 4 bits - , huffmanTableDest :: !Word8 - - , huffSizes :: !(VU.Vector Word8) - , huffCodes :: !(V.Vector (VU.Vector Word8)) - } - deriving Show - -instance SizeCalculable JpgHuffmanTableSpec where - calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] - -instance Binary JpgHuffmanTableSpec where - put table = do - let classVal = if huffmanTableClass table == DcComponent - then 0 else 1 - put4BitsOfEach classVal $ huffmanTableDest table - mapM_ put . VU.toList $ huffSizes table - forM_ [0 .. 15] $ \i -> - when (huffSizes table ! i /= 0) - (let elements = VU.toList $ huffCodes table V.! i - in mapM_ put elements) - - get = do - (huffClass, huffDest) <- get4BitOfEach - sizes <- replicateM 16 getWord8 - codes <- forM sizes $ \s -> - VU.replicateM (fromIntegral s) getWord8 - return JpgHuffmanTableSpec - { huffmanTableClass = - if huffClass == 0 then DcComponent else AcComponent - , huffmanTableDest = huffDest - , huffSizes = VU.fromListN 16 sizes - , huffCodes = V.fromListN 16 codes - } - -instance Binary JpgImage where - put (JpgImage { jpgFrame = frames }) = - putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames - >> putWord8 0xFF >> putWord8 0xD9 - - get = do - let startOfImageMarker = 0xD8 - -- endOfImageMarker = 0xD9 - checkMarker commonMarkerFirstByte startOfImageMarker - eatUntilCode - frames <- parseFrames - {-checkMarker commonMarkerFirstByte endOfImageMarker-} - return JpgImage { jpgFrame = frames } - -eatUntilCode :: Get () -eatUntilCode = do - code <- getWord8 - unless (code == 0xFF) eatUntilCode - -takeCurrentFrame :: Get B.ByteString -takeCurrentFrame = do - size <- getWord16be - getByteString (fromIntegral size - 2) - -putFrame :: JpgFrame -> Put -putFrame (JpgAdobeAPP14 adobe) = - put (JpgAppSegment 14) >> putWord16be 14 >> put adobe -putFrame (JpgJFIF jfif) = - put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif -putFrame (JpgExif exif) = 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") - -extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString) -extractScanContent str = aux 0 - where maxi = fromIntegral $ L.length str - 1 - - aux n | n >= maxi = (str, L.empty) - | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str - | otherwise = aux (n + 1) - where v = str `L.index` n - vNext = str `L.index` (n + 1) - isReset = 0xD0 <= vNext && vNext <= 0xD7 - -parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseAdobe14 str lst = go where - go = case runGetStrict get str of - Left _err -> lst - Right app14 -> JpgAdobeAPP14 app14 : lst - --- | Parse JFIF or JFXX information. Right now only JFIF. -parseJF__ :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseJF__ str lst = go where - go = case runGetStrict get str of - Left _err -> lst - Right jfif -> JpgJFIF jfif : lst - -parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseExif str lst - | exifHeader `B.isPrefixOf` str = go - | otherwise = lst - where - exifHeader = BC.pack "Exif\0\0" - tiff = B.drop (B.length exifHeader) str - go = case runGetStrict (getP tiff) tiff of - Left _err -> lst - Right (_hdr :: TiffHeader, []) -> lst - Right (_hdr :: TiffHeader, ifds : _) -> JpgExif ifds : lst - -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 - -parseFrames :: Get [JpgFrame] -parseFrames = do - kind <- get - let parseNextFrame = do - word <- getWord8 - when (word /= 0xFF) $ do - readedData <- bytesRead - fail $ "Invalid Frame marker (" ++ show word - ++ ", bytes read : " ++ show readedData ++ ")" - parseFrames - - case kind of - JpgEndOfImage -> return [] - JpgAppSegment 0 -> - parseJF__ <$> takeCurrentFrame <*> parseNextFrame - JpgAppSegment 1 -> - parseExif <$> takeCurrentFrame <*> parseNextFrame - JpgAppSegment 14 -> - parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame - JpgAppSegment c -> - (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame - JpgExtensionSegment c -> - (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame - JpgQuantizationTable -> - (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame - JpgRestartInterval -> - (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame - JpgHuffmanTableMarker -> - (\(TableList huffTables) lst -> - JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) - <$> get <*> parseNextFrame - JpgStartOfScan -> - (\frm imgData -> - let (d, other) = extractScanContent imgData - in - case runGet parseFrames (L.drop 1 other) of - Left _ -> [JpgScanBlob frm d] - Right lst -> JpgScanBlob frm d : lst - ) <$> get <*> getRemainingLazyBytes - - _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame - -buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree -buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList - -secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 -secondStartOfFrameByteOfKind = aux - where - aux JpgBaselineDCTHuffman = 0xC0 - aux JpgExtendedSequentialDCTHuffman = 0xC1 - aux JpgProgressiveDCTHuffman = 0xC2 - aux JpgLosslessHuffman = 0xC3 - aux JpgDifferentialSequentialDCTHuffman = 0xC5 - aux JpgDifferentialProgressiveDCTHuffman = 0xC6 - aux JpgDifferentialLosslessHuffman = 0xC7 - aux JpgExtendedSequentialArithmetic = 0xC9 - aux JpgProgressiveDCTArithmetic = 0xCA - aux JpgLosslessArithmetic = 0xCB - aux JpgHuffmanTableMarker = 0xC4 - aux JpgDifferentialSequentialDCTArithmetic = 0xCD - aux JpgDifferentialProgressiveDCTArithmetic = 0xCE - aux JpgDifferentialLosslessArithmetic = 0xCF - aux JpgEndOfImage = 0xD9 - aux JpgQuantizationTable = 0xDB - aux JpgStartOfScan = 0xDA - aux JpgRestartInterval = 0xDD - aux (JpgRestartIntervalEnd v) = v - aux (JpgAppSegment a) = (a + 0xE0) - aux (JpgExtensionSegment a) = a - -data JpgImageKind = BaseLineDCT | ProgressiveDCT - -instance Binary JpgFrameKind where - put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) - get = do - -- no lookahead :( - {-word <- getWord8-} - word2 <- getWord8 - return $ case word2 of - 0xC0 -> JpgBaselineDCTHuffman - 0xC1 -> JpgExtendedSequentialDCTHuffman - 0xC2 -> JpgProgressiveDCTHuffman - 0xC3 -> JpgLosslessHuffman - 0xC4 -> JpgHuffmanTableMarker - 0xC5 -> JpgDifferentialSequentialDCTHuffman - 0xC6 -> JpgDifferentialProgressiveDCTHuffman - 0xC7 -> JpgDifferentialLosslessHuffman - 0xC9 -> JpgExtendedSequentialArithmetic - 0xCA -> JpgProgressiveDCTArithmetic - 0xCB -> JpgLosslessArithmetic - 0xCD -> JpgDifferentialSequentialDCTArithmetic - 0xCE -> JpgDifferentialProgressiveDCTArithmetic - 0xCF -> JpgDifferentialLosslessArithmetic - 0xD9 -> JpgEndOfImage - 0xDA -> JpgStartOfScan - 0xDB -> JpgQuantizationTable - 0xDD -> JpgRestartInterval - a | a >= 0xF0 -> JpgExtensionSegment a - | a >= 0xE0 -> JpgAppSegment (a - 0xE0) - | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a - | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") - -put4BitsOfEach :: Word8 -> Word8 -> Put -put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b - -get4BitOfEach :: Get (Word8, Word8) -get4BitOfEach = do - val <- get - return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF) - -newtype RestartInterval = RestartInterval Word16 - -instance Binary RestartInterval where - put (RestartInterval i) = putWord16be 4 >> putWord16be i - get = do - size <- getWord16be - when (size /= 4) (fail "Invalid jpeg restart interval size") - RestartInterval <$> getWord16be - -instance Binary JpgComponent where - get = do - ident <- getWord8 - (horiz, vert) <- get4BitOfEach - quantTableIndex <- getWord8 - return JpgComponent - { componentIdentifier = ident - , horizontalSamplingFactor = horiz - , verticalSamplingFactor = vert - , quantizationTableDest = quantTableIndex - } - put v = do - put $ componentIdentifier v - put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v - put $ quantizationTableDest v - -instance Binary JpgFrameHeader where - get = do - beginOffset <- fromIntegral <$> bytesRead - frmHLength <- getWord16be - samplePrec <- getWord8 - h <- getWord16be - w <- getWord16be - compCount <- getWord8 - components <- replicateM (fromIntegral compCount) get - endOffset <- fromIntegral <$> bytesRead - when (beginOffset - endOffset < fromIntegral frmHLength) - (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) - return JpgFrameHeader - { jpgFrameHeaderLength = frmHLength - , jpgSamplePrecision = samplePrec - , jpgHeight = h - , jpgWidth = w - , jpgImageComponentCount = compCount - , jpgComponents = components - } - - put v = do - putWord16be $ jpgFrameHeaderLength v - putWord8 $ jpgSamplePrecision v - putWord16be $ jpgHeight v - putWord16be $ jpgWidth v - putWord8 $ jpgImageComponentCount v - mapM_ put $ jpgComponents v - -instance Binary JpgScanSpecification where - put v = do - put $ componentSelector v - put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v - - get = do - compSel <- get - (dc, ac) <- get4BitOfEach - return JpgScanSpecification { - componentSelector = compSel - , dcEntropyCodingTable = dc - , acEntropyCodingTable = ac - } - -instance Binary JpgScanHeader where - get = do - thisScanLength <- getWord16be - compCount <- getWord8 - comp <- replicateM (fromIntegral compCount) get - specBeg <- get - specEnd <- get - (approxHigh, approxLow) <- get4BitOfEach - - return JpgScanHeader { - scanLength = thisScanLength, - scanComponentCount = compCount, - scans = comp, - spectralSelection = (specBeg, specEnd), - successiveApproxHigh = approxHigh, - successiveApproxLow = approxLow - } - - put v = do - putWord16be $ scanLength v - putWord8 $ scanComponentCount v - mapM_ put $ scans v - putWord8 . fst $ spectralSelection v - putWord8 . snd $ spectralSelection v - put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v - -{-# INLINE createEmptyMutableMacroBlock #-} --- | Create a new macroblock with the good array size -createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a) -createEmptyMutableMacroBlock = M.replicate 64 0 - -printMacroBlock :: (Storable a, PrintfArg a) - => MutableMacroBlock s a -> ST s String -printMacroBlock block = pLn 0 - where pLn 64 = return "===============================\n" - pLn i = do - v <- block `M.unsafeRead` i - vn <- pLn (i+1) - return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn - -printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String -printPureMacroBlock block = pLn 0 - where pLn 64 = "===============================\n" - pLn i = str ++ pLn (i + 1) - where str | i `mod` 8 == 0 = printf "\n%5d " v - | otherwise = printf "%5d" v - v = block VS.! i - - -{-# INLINE dctBlockSize #-} -dctBlockSize :: Num a => a -dctBlockSize = 8
src/Codec/Picture/Metadata.hs view
@@ -17,6 +17,7 @@ , Value( .. ) , Elem( .. ) , SourceFormat( .. ) + , ColorSpace( .. ) -- * Functions , Codec.Picture.Metadata.lookup @@ -42,6 +43,8 @@ , dotsPerCentiMeterToDotPerInch ) where +import Prelude hiding (Foldable(..)) + #if !MIN_VERSION_base(4,8,0) import Data.Monoid( Monoid, mempty, mappend ) import Data.Word( Word ) @@ -49,6 +52,7 @@ import Control.DeepSeq( NFData( .. ) ) +import qualified Data.ByteString as B import qualified Data.Foldable as F import Codec.Picture.Metadata.Exif @@ -61,7 +65,7 @@ Refl :: Equiv a a #endif --- | Type describing the original file format of the ilfe. +-- | Type describing the original file format of the file. data SourceFormat = SourceJpeg | SourceGif @@ -75,6 +79,38 @@ 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. -- @@ -86,16 +122,20 @@ -- information can avoid the full decompression of the image. -- Ignored for image writing. -- --- * 'Height' Image height in pixels. Relyiung on the metadata for this --- information can void the full decomrpession of the image. +-- * '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 @@ -140,6 +180,7 @@ 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
src/Codec/Picture/Metadata/Exif.hs view
@@ -1,3 +1,5 @@+{-# 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( .. ) @@ -14,6 +16,7 @@ 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 @@ -72,7 +75,8 @@ | TagExifOffset | TagUnknown !Word16 - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData ExifTag -- | Convert a value to it's corresponding Exif tag. -- Will often be written as 'TagUnknown' @@ -206,13 +210,5 @@ | ExifRational !Word32 !Word32 | ExifSignedRational !Int32 !Int32 | ExifIFD ![(ExifTag, ExifData)] - deriving Show - -instance NFData ExifTag where - rnf a = a `seq` () - -instance NFData ExifData where - rnf (ExifIFD ifds) = rnf ifds `seq` () - rnf (ExifLongs l) = rnf l `seq` () - rnf (ExifShorts l) = rnf l `seq` () - rnf a = a `seq` () + deriving (Eq, Show, Generic) +instance NFData ExifData
src/Codec/Picture/Png.hs view
@@ -26,8 +26,6 @@ , writePng , encodeDynamicPng - , encodePalettedPng - , encodePalettedPngWithMetadata , writeDynamicPng ) where @@ -38,7 +36,11 @@ 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 @@ -54,9 +56,9 @@ import Codec.Picture.Types import Codec.Picture.Metadata -import Codec.Picture.Png.Type -import Codec.Picture.Png.Export -import Codec.Picture.Png.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. @@ -364,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 @@ -375,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 @@ -386,9 +387,9 @@ 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
− src/Codec/Picture/Png/Export.hs
@@ -1,268 +0,0 @@-{-# 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.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 ) -import Data.Monoid( (<>) ) -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.Png.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 bes tored 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"
+ src/Codec/Picture/Png/Internal/Export.hs view
@@ -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"
+ src/Codec/Picture/Png/Internal/Metadata.hs view
@@ -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 +
+ src/Codec/Picture/Png/Internal/Type.hs view
@@ -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] +
− src/Codec/Picture/Png/Metadata.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-module Codec.Picture.Png.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 )-import Data.Binary.Put( putLazyByteString, putWord8 )-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Monoid( (<>) )--import Codec.Picture.InternalHelper-import qualified Codec.Picture.Metadata as Met-import Codec.Picture.Metadata ( Metadatas- , dotsPerMeterToDotPerInch- , Elem( (:=>) ) )-import Codec.Picture.Png.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--textToMetadata :: PngText -> Metadatas-textToMetadata ptext = case pngKeyword 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 $ pngData ptext)- where- strValue k = Met.singleton k . L.unpack $ pngData ptext--getTexts :: [L.ByteString] -> Metadatas-getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) where- --extractMetadatas :: PngRawImage -> Metadatas-extractMetadatas img = getDpis (chunksOf pHYsSignature)- <> getGamma (chunksOf gammaSignature)- <> getTexts (chunksOf tEXtSignature)- 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.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-
− src/Codec/Picture/Png/Type.hs
@@ -1,450 +0,0 @@-{-# LANGUAGE CPP #-} --- | Low level png module, you should import 'Codec.Picture.Png' instead. -module Codec.Picture.Png.Type( PngIHdr( .. ) - , PngFilter( .. ) - , PngInterlaceMethod( .. ) - , PngPalette - , PngImageType( .. ) - , PngPhysicalDimension( .. ) - , PngGamma( .. ) - , PngUnit( .. ) - , APngAnimationControl( .. ) - , APngFrameDisposal( .. ) - , APngBlendOp( .. ) - , APngFrameControl( .. ) - , parsePalette - , pngComputeCrc - , 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] -
src/Codec/Picture/Saving.hs view
@@ -1,214 +1,239 @@-{-# 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- , imageToPng- , imageToGif- , 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 qualified Data.ByteString.Lazy as L-import Codec.Picture.Bitmap-import Codec.Picture.Jpg-import Codec.Picture.Png-import Codec.Picture.Gif-import Codec.Picture.ColorQuant-import Codec.Picture.HDR-import Codec.Picture.Types-import Codec.Picture.Tiff-import Codec.Picture.Tga--import qualified Data.Vector.Storable as V--componentToLDR :: Float -> Word8-componentToLDR = truncate . (255 *) . min 1.0 . max 0.0--toStandardDef :: Image PixelRGBF -> Image PixelRGB8-toStandardDef = pixelMap pixelConverter- where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b- where r = componentToLDR rf- g = componentToLDR gf- b = componentToLDR bf--greyScaleToStandardDef :: Image PixelF -> Image Pixel8-greyScaleToStandardDef = pixelMap componentToLDR--from16to8 :: ( PixelBaseComponent source ~ Word16- , PixelBaseComponent dest ~ Word8 )- => Image source -> Image dest-from16to8 Image { imageWidth = w, imageHeight = h- , imageData = arr } = Image w h transformed- where transformed = V.map toWord8 arr- toWord8 v = fromIntegral (v `unsafeShiftR` 8)--from16toFloat :: ( PixelBaseComponent source ~ Word16- , PixelBaseComponent dest ~ Float )- => Image source -> Image dest-from16toFloat Image { imageWidth = w, imageHeight = h- , imageData = arr } = Image w h transformed- where transformed = V.map toWord8 arr- toWord8 v = fromIntegral v / 65536.0---- | This function will try to do anything to encode an image--- as RADIANCE, make all color conversion and such. Equivalent--- of 'decodeImage' for radiance encoding-imageToRadiance :: DynamicImage -> L.ByteString-imageToRadiance (ImageCMYK8 img) =- imageToRadiance . ImageRGB8 $ convertImage img-imageToRadiance (ImageCMYK16 img) =- imageToRadiance . ImageRGB16 $ convertImage img-imageToRadiance (ImageYCbCr8 img) =- imageToRadiance . ImageRGB8 $ convertImage img-imageToRadiance (ImageRGB8 img) =- imageToRadiance . ImageRGBF $ promoteImage img-imageToRadiance (ImageRGBF img) = encodeHDR img-imageToRadiance (ImageRGBA8 img) =- imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img-imageToRadiance (ImageY8 img) =- imageToRadiance . ImageRGB8 $ promoteImage img-imageToRadiance (ImageYF img) =- imageToRadiance . ImageRGBF $ promoteImage img-imageToRadiance (ImageYA8 img) =- imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img-imageToRadiance (ImageY16 img) =- imageToRadiance . ImageRGBF $ pixelMap toRgbf img- where toRgbf v = PixelRGBF val val val- where val = fromIntegral v / 65536.0--imageToRadiance (ImageYA16 img) =- imageToRadiance . ImageRGBF $ pixelMap toRgbf img- where toRgbf (PixelYA16 v _) = PixelRGBF val val val- where val = fromIntegral v / 65536.0-imageToRadiance (ImageRGB16 img) =- imageToRadiance . ImageRGBF $ from16toFloat img-imageToRadiance (ImageRGBA16 img) =- imageToRadiance . ImageRGBF $ pixelMap toRgbf img- where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b)- where f v = fromIntegral v / 65536.0---- | 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.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- ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img- ImageRGB8 img -> encodeAtQuality (convertImage img)- ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img- ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img)- ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img- ImageY8 img -> encodeWithMeta img- ImageYA8 img -> encodeWithMeta $ dropAlphaLayer img- ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img- ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img- ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img- ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img---- | This function will try to do anything to encode an image--- as PNG, make all color conversion and such. Equivalent--- of 'decodeImage' for PNG encoding-imageToPng :: DynamicImage -> L.ByteString-imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8)-imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8)-imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16)-imageToPng (ImageRGB8 img) = encodePng img-imageToPng (ImageRGBF img) = encodePng $ toStandardDef img-imageToPng (ImageRGBA8 img) = encodePng img-imageToPng (ImageY8 img) = encodePng img-imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img-imageToPng (ImageYA8 img) = encodePng img-imageToPng (ImageY16 img) = encodePng img-imageToPng (ImageYA16 img) = encodePng img-imageToPng (ImageRGB16 img) = encodePng img-imageToPng (ImageRGBA16 img) = encodePng img---- | This function will try to do anything to encode an image--- as a Tiff, make all color conversion and such. Equivalent--- of 'decodeImage' for Tiff encoding-imageToTiff :: DynamicImage -> L.ByteString-imageToTiff (ImageYCbCr8 img) = encodeTiff img-imageToTiff (ImageCMYK8 img) = encodeTiff img-imageToTiff (ImageCMYK16 img) = encodeTiff img-imageToTiff (ImageRGB8 img) = encodeTiff img-imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img-imageToTiff (ImageRGBA8 img) = encodeTiff img-imageToTiff (ImageY8 img) = encodeTiff img-imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img-imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img-imageToTiff (ImageY16 img) = encodeTiff img-imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img-imageToTiff (ImageRGB16 img) = encodeTiff img-imageToTiff (ImageRGBA16 img) = encodeTiff img---- | This function will try to do anything to encode an image--- as bitmap, make all color conversion and such. Equivalent--- of 'decodeImage' for Bitmap encoding-imageToBitmap :: DynamicImage -> L.ByteString-imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)-imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)-imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img-imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img-imageToBitmap (ImageRGB8 img) = encodeBitmap img-imageToBitmap (ImageRGBA8 img) = encodeBitmap img-imageToBitmap (ImageY8 img) = encodeBitmap img-imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img-imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8)-imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img-imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img-imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img-imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img----- | This function will try to do anything to encode an image--- as a gif, make all color conversion and quantization. Equivalent--- of 'decodeImage' for gif encoding-imageToGif :: DynamicImage -> Either String L.ByteString-imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img-imageToGif (ImageCMYK8 img) = imageToGif . ImageRGB8 $ convertImage img-imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img-imageToGif (ImageRGBF img) = imageToGif . ImageRGB8 $ toStandardDef img-imageToGif (ImageRGB8 img) = encodeGifImageWithPalette indexed pal- where (indexed, pal) = palettize defaultPaletteOptions img-imageToGif (ImageRGBA8 img) = imageToGif . ImageRGB8 $ dropAlphaLayer img-imageToGif (ImageY8 img) = Right $ encodeGifImage img-imageToGif (ImageYF img) = imageToGif . ImageY8 $ greyScaleToStandardDef img-imageToGif (ImageYA8 img) = imageToGif . ImageY8 $ dropAlphaLayer img-imageToGif (ImageY16 img) = imageToGif . ImageY8 $ from16to8 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 (ImageYA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8)-imageToTga (ImageRGB16 img) = encodeTga (from16to8 img :: Image PixelRGB8)-imageToTga (ImageRGBA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8)+{-# 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 + , imageToPng + , imageToGif + , 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, Word32 ) +import qualified Data.ByteString.Lazy as L +import Codec.Picture.Bitmap +import Codec.Picture.Jpg +import Codec.Picture.Png +import Codec.Picture.Gif +import Codec.Picture.ColorQuant +import Codec.Picture.HDR +import Codec.Picture.Types +import Codec.Picture.Tiff +import Codec.Picture.Tga + +import qualified Data.Vector.Storable as V + +componentToLDR :: Float -> Word8 +componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 + +toStandardDef :: Image PixelRGBF -> Image PixelRGB8 +toStandardDef = pixelMap pixelConverter + where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b + where r = componentToLDR rf + g = componentToLDR gf + b = componentToLDR bf + +greyScaleToStandardDef :: Image PixelF -> Image Pixel8 +greyScaleToStandardDef = pixelMap componentToLDR + +from16to8 :: ( PixelBaseComponent source ~ Word16 + , PixelBaseComponent dest ~ Word8 ) + => Image source -> Image dest +from16to8 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + 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 +from16toFloat Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral v / 65536.0 + +-- | This function will try to do anything to encode an image +-- as RADIANCE, make all color conversion and such. Equivalent +-- of 'decodeImage' for radiance encoding +imageToRadiance :: DynamicImage -> L.ByteString +imageToRadiance (ImageCMYK8 img) = + imageToRadiance . ImageRGB8 $ convertImage img +imageToRadiance (ImageCMYK16 img) = + imageToRadiance . ImageRGB16 $ convertImage img +imageToRadiance (ImageYCbCr8 img) = + imageToRadiance . ImageRGB8 $ convertImage img +imageToRadiance (ImageRGB8 img) = + imageToRadiance . ImageRGBF $ promoteImage img +imageToRadiance (ImageRGBF img) = encodeHDR img +imageToRadiance (ImageRGBA8 img) = + imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img +imageToRadiance (ImageY8 img) = + imageToRadiance . ImageRGB8 $ promoteImage img +imageToRadiance (ImageYF img) = + imageToRadiance . ImageRGBF $ promoteImage img +imageToRadiance (ImageYA8 img) = + imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img +imageToRadiance (ImageY16 img) = + 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 + where val = fromIntegral v / 65536.0 +imageToRadiance (ImageRGB16 img) = + imageToRadiance . ImageRGBF $ from16toFloat img +imageToRadiance (ImageRGBA16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b) + where f v = fromIntegral v / 65536.0 + +-- | 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 + ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img + ImageRGB8 img -> encodeAtQuality (convertImage img) + ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img + ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) + ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img + 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 + +-- | This function will try to do anything to encode an image +-- as PNG, make all color conversion and such. Equivalent +-- of 'decodeImage' for PNG encoding +imageToPng :: DynamicImage -> L.ByteString +imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) +imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8) +imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16) +imageToPng (ImageRGB8 img) = encodePng img +imageToPng (ImageRGBF img) = encodePng $ toStandardDef img +imageToPng (ImageRGBA8 img) = encodePng img +imageToPng (ImageY8 img) = encodePng img +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 + +-- | This function will try to do anything to encode an image +-- as a Tiff, make all color conversion and such. Equivalent +-- of 'decodeImage' for Tiff encoding +imageToTiff :: DynamicImage -> L.ByteString +imageToTiff (ImageYCbCr8 img) = encodeTiff img +imageToTiff (ImageCMYK8 img) = encodeTiff img +imageToTiff (ImageCMYK16 img) = encodeTiff img +imageToTiff (ImageRGB8 img) = encodeTiff img +imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img +imageToTiff (ImageRGBA8 img) = encodeTiff img +imageToTiff (ImageY8 img) = encodeTiff img +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 + +-- | This function will try to do anything to encode an image +-- as bitmap, make all color conversion and such. Equivalent +-- of 'decodeImage' for Bitmap encoding +imageToBitmap :: DynamicImage -> L.ByteString +imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img +imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img +imageToBitmap (ImageRGB8 img) = encodeBitmap img +imageToBitmap (ImageRGBA8 img) = encodeBitmap img +imageToBitmap (ImageY8 img) = encodeBitmap img +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 + + +-- | This function will try to do anything to encode an image +-- as a gif, make all color conversion and quantization. Equivalent +-- of 'decodeImage' for gif encoding +imageToGif :: DynamicImage -> Either String L.ByteString +imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img +imageToGif (ImageCMYK8 img) = imageToGif . ImageRGB8 $ convertImage img +imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img +imageToGif (ImageRGBF img) = imageToGif . ImageRGB8 $ toStandardDef img +imageToGif (ImageRGB8 img) = encodeGifImageWithPalette indexed pal + where (indexed, pal) = palettize defaultPaletteOptions img +imageToGif (ImageRGBA8 img) = imageToGif . ImageRGB8 $ dropAlphaLayer img +imageToGif (ImageY8 img) = Right $ encodeGifImage img +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)
src/Codec/Picture/Tiff.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE CPP #-} -- | Module implementing TIFF decoding. -- @@ -62,9 +63,9 @@ import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types -import Codec.Picture.Gif.LZW -import Codec.Picture.Tiff.Types -import Codec.Picture.Tiff.Metadata +import Codec.Picture.Gif.Internal.LZW +import Codec.Picture.Tiff.Internal.Types +import Codec.Picture.Tiff.Internal.Metadata import Codec.Picture.VectorByteConversion( toByteString ) data TiffInfo = TiffInfo @@ -88,6 +89,8 @@ } 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 @@ -304,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 @@ -584,6 +614,10 @@ $ tiffColorspace nfo ifdShort TagPlanarConfiguration . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo + ifdMultiLong TagSampleFormat + . V.fromList + . map packSampleFormat + $ tiffSampleFormat nfo ifdShort TagCompression . packCompression $ tiffCompression nfo ifdMultiLong TagStripOffsets $ tiffOffsets nfo @@ -690,10 +724,12 @@ | lst == V.singleton 16 && all (TiffSampleUint ==) format = 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 . TrueColorImage . 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 . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = @@ -758,6 +794,10 @@ -- -- * 'ImageY16' -- +-- * 'ImageY32' +-- +-- * 'ImageYF' +-- -- * 'ImageYA8' -- -- * 'ImageYA16' @@ -803,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 @@ -871,7 +921,7 @@ , 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
+ src/Codec/Picture/Tiff/Internal/Metadata.hs view
@@ -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 +
+ src/Codec/Picture/Tiff/Internal/Types.hs view
@@ -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 +
− src/Codec/Picture/Tiff/Metadata.hs
@@ -1,237 +0,0 @@-{-# LANGUAGE CPP #-} -module Codec.Picture.Tiff.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 -import Data.Monoid( (<>) ) -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.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 -
− src/Codec/Picture/Tiff/Types.hs
@@ -1,483 +0,0 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -module Codec.Picture.Tiff.Types - ( BinaryParam( .. ) - , Endianness( .. ) - , TiffHeader( .. ) - , TiffPlanarConfiguration( .. ) - , TiffCompression( .. ) - , IfdType( .. ) - , TiffColorspace( .. ) - , TiffSampleFormat( .. ) - , ImageFileDirectory( .. ) - , ExtraSample( .. ) - , Predictor( .. ) - - , planarConfgOfConstant - , constantToPlaneConfiguration - , unpackSampleFormat - , word16OfTag - , unpackPhotometricInterpretation - , packPhotometricInterpretation - , codeOfExtraSample - , unPackCompression - , packCompression - , predictorOfConstant - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>), pure ) -#endif - -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 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 Show - -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) - - 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) - [fromIntegral $ ofs .&. 0xFF000000 `unsafeShiftR` (3 * 8) - ,fromIntegral $ ofs .&. 0x00FF0000 `unsafeShiftR` (2 * 8) - ,fromIntegral $ ofs .&. 0x0000FF00 `unsafeShiftR` (1 * 8) - ,fromIntegral $ ofs .&. 0x000000FF - ] - fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = - align ifd $ ExifString <$> getByteString (fromIntegral count) - 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 - | TiffSampleDouble - | TiffSampleUnknown - deriving Eq - -unpackSampleFormat :: Word32 -> Get TiffSampleFormat -unpackSampleFormat v = case v of - 1 -> pure TiffSampleUint - 2 -> pure TiffSampleInt - 3 -> pure TiffSampleDouble - 4 -> pure TiffSampleUnknown - vv -> fail $ "Undefined data format (" ++ show vv ++ ")" - -data ImageFileDirectory = ImageFileDirectory - { ifdIdentifier :: !ExifTag -- Word16 - , ifdType :: !IfdType -- Word16 - , ifdCount :: !Word32 - , ifdOffset :: !Word32 - , ifdExtended :: !ExifData - } - deriving Show - -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 -
src/Codec/Picture/Types.hs view
@@ -1,15 +1,17 @@-{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | Module provides basic types for image manipulation in the library. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# 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 @@ -107,8 +109,9 @@ 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( ST, runST ) @@ -153,6 +156,12 @@ } 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 @@ -369,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. @@ -391,10 +402,10 @@ | ImageCMYK8 (Image PixelCMYK8) -- | An image in the colorspace CMYK and 16 bits precision | ImageCMYK16 (Image PixelCMYK16) - deriving (Typeable) + deriving (Eq, Typeable) -- | Type used to expose a palette extracted during reading. --- Use palettedAsImage to convert it to a palette usable for +-- Use `palettedAsImage` to convert it to a palette usable for -- writing. data Palette' px = Palette' { -- | Number of element in pixels. @@ -442,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 @@ -474,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) @@ -489,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 @@ -1234,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 @@ -1410,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 @@ -1480,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 @@ -2230,26 +2256,25 @@ -> (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)
src/Codec/Picture/VectorByteConversion.hs view
@@ -1,45 +1,52 @@-{-# 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.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--blitVector :: Vector Word8 -> Int -> Int -> B.ByteString-blitVector vec atIndex = S.PS 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)- where (ptr, offset, len) = unsafeToForeignPtr vec- size = sizeOf (undefined :: a)---- | Import a image from an unsafe pointer--- The pointer must have a size of width * height * componentCount px-imageFromUnsafePtr :: forall px- . (Pixel px, (PixelBaseComponent px) ~ Word8)- => Int -- ^ Width in pixels- -> Int -- ^ Height in pixels- -> ForeignPtr Word8 -- ^ Pointer to the raw data- -> Image px-imageFromUnsafePtr width height ptr =- Image width height $ unsafeFromForeignPtr0 ptr size- where compCount = componentCount (undefined :: px)- size = width * height * compCount-+{-# 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.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 = mkBS ptr (offset + atIndex) + where (ptr, offset, _length) = unsafeToForeignPtr vec + +toByteString :: forall a. (Storable a) => Vector a -> B.ByteString +toByteString vec = mkBS (castForeignPtr ptr) offset (len * size) + where (ptr, offset, len) = unsafeToForeignPtr vec + size = sizeOf (undefined :: a) + +-- | Import a image from an unsafe pointer +-- The pointer must have a size of width * height * componentCount px +imageFromUnsafePtr :: forall px + . (Pixel px, (PixelBaseComponent px) ~ Word8) + => Int -- ^ Width in pixels + -> Int -- ^ Height in pixels + -> ForeignPtr Word8 -- ^ Pointer to the raw data + -> Image px +imageFromUnsafePtr width height ptr = + Image width height $ unsafeFromForeignPtr0 ptr size + where compCount = componentCount (undefined :: px) + size = width * height * compCount +