JuicyPixels 3.2.6.4 → 3.2.7

raw patch · 12 files changed

+742/−362 lines, 12 filesdep ~basedep ~binaryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, binary

API changes (from Hackage documentation)

Files

• JuicyPixels.cabal +3/−4
• README.md +4/−1
• changelog +14/−1
• src/Codec/Picture.hs +90/−1
• src/Codec/Picture/BitWriter.hs +47/−16
• src/Codec/Picture/Bitmap.hs +67/−14
• src/Codec/Picture/Gif/LZW.hs +194/−191
• src/Codec/Picture/Jpg.hs +293/−110
• src/Codec/Picture/Jpg/Common.hs +2/−9
• src/Codec/Picture/Jpg/Types.hs +2/−1
• src/Codec/Picture/Saving.hs +11/−4
• src/Codec/Picture/Types.hs +15/−10

@@ -1,5 +1,5 @@ Name:                JuicyPixels-Version:             3.2.6.4+Version:             3.2.7 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==>>@@ -28,7 +28,7 @@ Source-Repository this     Type:      git     Location:  git://github.com/Twinside/Juicy.Pixels.git-    Tag:       v3.2.6.4+    Tag:       v3.2.7  Flag Mmap     Description: Enable the file loading via mmap (memory map)@@ -52,11 +52,10 @@                     Codec.Picture.ColorQuant    Ghc-options: -O3 -Wall-  Ghc-prof-options: -rtsopts -Wall -prof -auto-all   Build-depends: base                >= 4.5     && < 5,                  bytestring          >= 0.9     && < 0.11,                  mtl                 >= 1.1     && < 2.3,-                 binary              >= 0.5     && < 0.8,+                 binary              >= 0.5     && < 0.9,                  zlib                >= 0.5.3.1 && < 0.7,                  transformers        >= 0.2,                  vector              >= 0.9     && < 0.12,

@@ -52,6 +52,7 @@ 
  - Bitmap (.bmp) (mainly used as a debug output format)
     * Reading
+        - 32bits (RGBA) images
         - 24bits (RGB) images
         - 8bits (greyscale & paletted) images
 
@@ -62,10 +63,12 @@ 
     * Metadata (reading/writing): DPI information
 
- - Jpeg   (.jpg, .jpeg) 
+ - Jpeg   (.jpg, .jpeg)
     * Reading normal and interlaced baseline DCT image
         - YCbCr (default) CMYK/YCbCrK/RGB colorspaces
+
     * Writing non-interlaced JPG
+        - YCbCr (favored), Y, RGB & CMYK colorspaces
 
     * Metadata:
         - Reading and writing DpiX & DpiY from JFIF header.

@@ -1,7 +1,20 @@ Change log ========== -v3.2.6.3 December 2015+v3.2.7 January 2016+-------------------+ * Addition: convertRGB8 and convertRGBA8 helper functions+ * Addition: new output colorspace for JPEG format: Y, RGB & CMYK+ * Addition: RGBA8 bitmap reading (thanks to mtolly)+ * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck)+ * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck)+ * Fix: GHC 8.0 compilation (thanks to phadej)++v3.2.6.5 December 2015+----------------------+ * Fix: Compilation on GHC 7.6/7.8++v3.2.6.4 December 2015 ----------------------  * Fix: previous broken bugfix. 

@@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
 -- | Main module for image import/export into various image formats.
 --
 -- To use the library without thinking about it, look after 'decodeImage' and
@@ -23,6 +26,10 @@                      , generateFoldImage
                      , withImage
 
+                      -- * RGB helper functions
+                     , convertRGB8
+                     , convertRGBA8
+
                      -- * Lens compatibility
                      , Traversal
                      , imagePixels
@@ -138,6 +145,7 @@ import Control.Applicative( (<$>) )
 #endif
 
+import Data.Bits( unsafeShiftR )
 import Control.DeepSeq( NFData, deepseq )
 import qualified Control.Exception as Exc ( catch, IOException )
 import Codec.Picture.Metadata( Metadatas )
@@ -200,6 +208,7 @@ 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
+import qualified Data.Vector.Storable as VS
 
 -- | Return the first Right thing, accumulating error
 eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b
@@ -263,6 +272,7 @@ readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas))
 readImageWithMetadata = withImageDecoder decodeImageWithMetadata
 
+
 -- | If you want to decode an image in a bytestring without even thinking
 -- in term of format or whatever, this is the function to use. It will try
 -- to decode in each known format and if one decoding succeeds, it will return
@@ -270,6 +280,85 @@ decodeImage :: B.ByteString -> Either String DynamicImage
 decodeImage = fmap fst . decodeImageWithMetadata 
 
+class Decimable px1 px2 where
+   decimateBitDepth :: Image px1 -> Image px2
+
+decimateWord16 :: ( Pixel px1, Pixel px2
+                  , PixelBaseComponent px1 ~ Pixel16
+                  , PixelBaseComponent px2 ~ Pixel8
+                  ) => Image px1 -> Image px2
+decimateWord16 (Image w h da) =
+  Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da
+
+decimateFloat :: ( Pixel px1, Pixel px2
+                 , PixelBaseComponent px1 ~ PixelF
+                 , PixelBaseComponent px2 ~ Pixel8
+                 ) => Image px1 -> Image px2
+decimateFloat (Image w h da) =
+  Image w h $ VS.map (floor . (255*) . max 0 . min 1) da
+
+instance Decimable Pixel16 Pixel8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelYA16 PixelYA8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGB16 PixelRGB8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGBA16 PixelRGBA8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelCMYK16 PixelCMYK8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelF Pixel8 where
+   decimateBitDepth = decimateFloat
+
+instance Decimable PixelRGBF PixelRGB8 where
+   decimateBitDepth = decimateFloat
+
+-- | Convert by any mean 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)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+  ImageRGB8   img -> promoteImage img
+  ImageRGB16  img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+  ImageRGBF   img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+  ImageRGBA8  img -> promoteImage img
+  ImageRGBA16 img -> decimateBitDepth img
+  ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK8  img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK16 img ->
+    promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8)
+
+-- | Convert by any mean possible a dynamic image to an image
+-- in RGB. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels. Any alpha layer will
+-- be dropped
+convertRGB8 :: DynamicImage -> Image PixelRGB8
+convertRGB8 dynImage = case dynImage of
+  ImageY8     img -> promoteImage img
+  ImageY16    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+  ImageRGB8   img -> img
+  ImageRGB16  img -> decimateBitDepth img
+  ImageRGBF   img -> decimateBitDepth img :: Image PixelRGB8
+  ImageRGBA8  img -> dropAlphaLayer img
+  ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8)
+  ImageYCbCr8 img -> convertImage img
+  ImageCMYK8  img -> convertImage img
+  ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8)
+
+
 -- | Equivalent to 'decodeImage', but also provide potential metadatas
 -- present in the given file.
 decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
@@ -306,7 +395,7 @@ readJpeg :: FilePath -> IO (Either String DynamicImage)
 readJpeg = withImageDecoder decodeJpeg
 
--- | Try to load a .bmp file. The colorspace would be RGB or Y.
+-- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y.
 readBitmap :: FilePath -> IO (Either String DynamicImage)
 readBitmap = withImageDecoder decodeBitmap
 

@@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -- | This module implement helper functions to read & write data -- at bits level.@@ -9,7 +10,9 @@                               , getNextBitsLSBFirst                               , getNextBitsMSBFirst                                , getNextBitJpg+                              , getNextIntJpg                               , setDecodedString+                              , setDecodedStringMSB                               , setDecodedStringJpg                               , runBoolReader @@ -33,6 +36,7 @@ import Control.Monad( when ) import Control.Monad.ST( ST ) import qualified Control.Monad.Trans.State.Strict as S+import Data.Int ( Int32 ) import Data.Word( Word8, Word32 ) import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL ) @@ -42,6 +46,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L + -------------------------------------------------- ----            Reader --------------------------------------------------@@ -93,8 +98,8 @@   BoolState idx _ chain <- S.get   when (idx /= 7) (setDecodedStringJpg chain) -{-# INLINE getNextBitJpg #-} getNextBitJpg :: BoolReader s Bool+{-# INLINE getNextBitJpg #-} getNextBitJpg = do     BoolState idx v chain <- S.get     let val = (v .&. (1 `unsafeShiftL` idx)) /= 0@@ -103,25 +108,51 @@       else S.put $ BoolState (idx - 1) v chain     return val -{-# INLINE getNextBitMSB #-}-getNextBitMSB :: BoolReader s Bool-getNextBitMSB = do+getNextIntJpg :: Int -> BoolReader s Int32+{-# INLINE getNextIntJpg #-}+getNextIntJpg = go 0 where+  go !acc !0 = return acc+  go !acc !n = do     BoolState idx v chain <- S.get-    let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0-    if idx == 7-      then setDecodedString chain-      else S.put $ BoolState (idx + 1) v chain-    return val+    let !leftBits = 1 + fromIntegral idx+    if n >= leftBits then do+      setDecodedStringJpg chain+      let !remaining = n - leftBits+          !mask = (1 `unsafeShiftL` leftBits) - 1+          !finalV = fromIntegral v .&. mask+          !theseBits = finalV `unsafeShiftL` remaining+      go (acc .|. theseBits) remaining+    else do+      let !remaining = leftBits - n+          !mask = (1 `unsafeShiftL` n) - 1+          !finalV = fromIntegral v `unsafeShiftR` remaining+      S.put $ BoolState (fromIntegral remaining - 1) v chain+      return $ (finalV .&. mask) .|. acc ++setDecodedStringMSB :: B.ByteString -> BoolReader s ()+setDecodedStringMSB str = case B.uncons str of+  Nothing        -> S.put $ BoolState      8 0 B.empty+  Just (v, rest) -> S.put $ BoolState      8 v    rest++ {-# INLINE getNextBitsMSBFirst #-} getNextBitsMSBFirst :: Int -> BoolReader s Word32-getNextBitsMSBFirst = aux 0-  where aux acc 0 = return acc-        aux acc n = do-            bit <- getNextBitMSB-            let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1-                        | otherwise = acc `unsafeShiftL` 1-            aux nextVal (n - 1)+getNextBitsMSBFirst requested = go 0 requested where+  go :: Word32 -> Int -> BoolReader s Word32+  go !acc !0 = return acc+  go !acc !n = do+    BoolState idx v chain <- S.get+    let !leftBits = fromIntegral idx+    if n >= leftBits then do+      setDecodedStringMSB chain+      let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits)+      go (acc .|. theseBits) (n - leftBits)+    else do+      let !remaining = leftBits - n+          !mask = (1 `unsafeShiftL` remaining) - 1+      S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain+      return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc  {-# INLINE getNextBitsLSBFirst #-} getNextBitsLSBFirst :: Int -> BoolReader s Word32

@@ -41,6 +41,7 @@                       , getWord8
                       , getWord16le 
                       , getWord32le
+                      , getWord32be
                       , bytesRead
                       , skip
                       )
@@ -253,6 +254,34 @@               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
+  wi = fromIntegral w
+  hi = abs $ fromIntegral h
+  stArray = runST $ do
+      arr <- M.new (fromIntegral $ w * abs h * 4)
+      if h > 0 then
+        foldM_ (readLine arr) 0 [0 .. hi - 1]
+      else
+        foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
+      VS.unsafeFreeze arr
+
+  stride = linePadding 32 wi -- will be 0
+
+  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
+
+    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)
+
 decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8
 decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where
   wi = fromIntegral w
@@ -322,6 +351,8 @@ -- | Try to decode a bitmap image.
 -- Right now this function can output the following pixel types :
 --
+--    * PixelRGBA8
+--
 --    * PixelRGB8
 --
 --    * Pixel8
@@ -349,26 +380,48 @@       paletteColorCount
         | colorCount bmpHeader == 0 = 2 ^ bpp
         | otherwise = fromIntegral $ colorCount bmpHeader
-
-  table <- if bpp > 8
-    then return V.empty
-    else V.replicateM paletteColorCount pixelGet 
-
-  readed' <- bytesRead
+      getData = do
+        readed' <- bytesRead
+        skip . fromIntegral $ dataOffset hdr - fromIntegral readed'
+        getRemainingBytes
+      addMetadata i = (i, metadataOfHeader bmpHeader)
 
-  skip . fromIntegral $ dataOffset hdr - fromIntegral readed'
-  rest <- getRemainingBytes
-  let addMetadata i = (i, metadataOfHeader bmpHeader)
   case (bitPerPixel bmpHeader, planes  bmpHeader,
               bitmapCompression bmpHeader) of
-    -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh"
-    (24, 1, 0) -> return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest
-    ( 8, 1, 0) ->
-        let indexer v = table V.! fromIntegral v in
-        return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest
+    (32, 1, 0) -> do
+      rest <- getData
+      return . addMetadata . 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 . ImageRGBA8 $
+        decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest
+    (24, 1, 0) -> do
+      rest <- getData
+      return . addMetadata . ImageRGB8  $ decodeImageRGB8  bmpHeader rest
+    ( 8, 1, 0) -> do
+      table <- V.replicateM paletteColorCount pixelGet
+      rest <- getData
+      let indexer v = table V.! fromIntegral v
+      return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest
 
     a          -> fail $ "Can't handle BMP file " ++ show a
 
+
+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
 
 -- | Write an image in a file use the bitmap format.
 writeBitmap :: (BmpEncodable pixel)

@@ -1,191 +1,194 @@-{-# 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 :: (Show a, MonadTrans t, Storable a)
-              => M.STVector s a -> M.STVector s a
-              -> Int -> Int -> Int -> t (ST s) ()
-duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex
-  where endIndex = sourceIndex + size
-        aux i _ | i == endIndex  = return ()
-        aux i j = do
-          src .!!!. i >>= (dest .<-. j)
-          aux (i + 1) (j + 1)
-
-rangeSetter :: (Storable a, Num a)
-            => Int -> M.STVector s a
-            -> ST s (M.STVector s a)
-rangeSetter count vec = aux 0
-  where aux n | n == count = return vec
-        aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)
-
-decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8
-          -> BoolReader s ()
-decodeLzw str maxBitKey initialKey outVec = do
-    setDecodedString str
-    lzw GifVariant maxBitKey initialKey 0 outVec
-
-isOldTiffLZW :: B.ByteString -> Bool
-isOldTiffLZW str = firstByte == 0 && secondByte == 1
-    where firstByte = str `B.index` 0
-          secondByte = (str `B.index` 1) .&. 1
-
-decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int
-              -> BoolReader s()
-decodeLzwTiff str outVec initialWriteIdx = do
-    setDecodedString str
-    let variant | isOldTiffLZW str = OldTiffVariant
-                | otherwise = TiffVariant
-    lzw variant 12 9 initialWriteIdx outVec
-
-data TiffVariant =
-      GifVariant
-    | TiffVariant
-    | OldTiffVariant
-    deriving Eq
-
--- | Gif image constraint from spec-gif89a, code size max : 12 bits.
-lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8
-    -> BoolReader s ()
-lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do
-    -- Allocate buffer of maximum size.
-    lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray
-    lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray
-    lzwSizeTable <- lift $ M.replicate tableEntryCount 0
-    lift $ lzwSizeTable `M.set` 1
-
-    let firstVal code = do
-            dataOffset <- lzwOffsetTable ..!!!.. code
-            lzwData ..!!!.. dataOffset
-
-        writeString at code = do
-            dataOffset <- lzwOffsetTable ..!!!.. code
-            dataSize   <- lzwSizeTable   ..!!!.. code
-
-            when (at + dataSize <= maxWrite) $
-                 duplicateData lzwData outVec dataOffset dataSize at
-
-            return dataSize
-
-        addString pos at code val = do
-            dataOffset <- lzwOffsetTable ..!!!.. code
-            dataSize   <- lzwSizeTable   ..!!!.. code
-
-            when (pos < tableEntryCount) $ do
-              (lzwOffsetTable ..<-.. pos) at
-              (lzwSizeTable ..<-.. pos) $ dataSize + 1
-
-            when (at + dataSize + 1 <= maxDataSize) $ do
-              duplicateData lzwData lzwData dataOffset dataSize at
-              (lzwData ..<-.. (at + dataSize)) val
-
-            return $ dataSize + 1
-
-        maxWrite = M.length outVec
-        loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code
-          | outWriteIdx >= maxWrite = return ()
-          | code == endOfInfo = return ()
-          | code == clearCode = do
-              toOutput <- getNextCode startCodeSize
-              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
-
+{-# 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 :: (Show a, MonadTrans t, Storable a)+              => M.STVector s a -> M.STVector s a+              -> Int -> Int -> Int -> t (ST s) ()+duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex+  where endIndex = sourceIndex + size+        aux i _ | i == endIndex  = return ()+        aux i j = do+          src .!!!. i >>= (dest .<-. j)+          aux (i + 1) (j + 1)++rangeSetter :: (Storable a, Num a)+            => Int -> M.STVector s a+            -> ST s (M.STVector s a)+rangeSetter count vec = aux 0+  where aux n | n == count = return vec+        aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)++decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8+          -> BoolReader s ()+decodeLzw str maxBitKey initialKey outVec = do+    setDecodedString str+    lzw GifVariant maxBitKey initialKey 0 outVec++isOldTiffLZW :: B.ByteString -> Bool+isOldTiffLZW str = firstByte == 0 && secondByte == 1+    where firstByte = str `B.index` 0+          secondByte = (str `B.index` 1) .&. 1++decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int+              -> BoolReader s()+decodeLzwTiff str outVec initialWriteIdx = do+    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+

@@ -11,7 +11,9 @@                         , decodeJpegWithMetadata
                         , encodeJpegAtQuality
                         , encodeJpegAtQualityWithMetadata
+                        , encodeDirectJpegAtQualityWithMetadata
                         , encodeJpeg
+                        , JpgEncodable
                         ) where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -546,6 +548,8 @@ --
 --    * PixelRGB8
 --
+--    * PixelCMYK8
+--
 --    * PixelYCbCr8
 --
 decodeJpeg :: B.ByteString -> Either String DynamicImage
@@ -623,7 +627,8 @@         frozen <- unsafeFreezeImage fImg
         return (st, imageData frozen)
 
-extractBlock :: Image PixelYCbCr8       -- ^ Source image
+extractBlock :: forall s px. (PixelBaseComponent px ~ Word8)
+             => Image px       -- ^ Source image
              -> MutableMacroBlock s Int16      -- ^ Mutable block where to put extracted block
              -> Int                     -- ^ Plane
              -> Int                     -- ^ X sampling factor
@@ -741,6 +746,22 @@     , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
     ]
 
+lumaQuantTableAtQuality :: Int -> QuantificationTable 
+lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable
+
+chromaQuantTableAtQuality :: Int -> QuantificationTable
+chromaQuantTableAtQuality qual =
+  scaleQuantisationMatrix qual defaultChromaQuantizationTable
+
+zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
+zigzaggedQuantificationSpec qual =
+  [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma }
+  , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma }
+  ]
+  where
+    luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+    chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
+
 -- | Function to call to encode an image to jpeg.
 -- The quality factor should be between 0 and 100 (100 being
 -- the best quality).
@@ -749,6 +770,203 @@                     -> L.ByteString         -- ^ Encoded JPEG
 encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty
 
+-- | Record gathering all information to encode a component
+-- from the source image. Previously was a huge tuple
+-- burried in the code
+data EncoderState = EncoderState
+  { _encComponentIndex :: !Int
+  , _encBlockWidth     :: !Int
+  , _encBlockHeight    :: !Int
+  , _encQuantTable     :: !QuantificationTable
+  , _encDcHuffman      :: !HuffmanWriterCode
+  , _encAcHuffman      :: !HuffmanWriterCode
+  }
+
+
+-- | Helper type class describing all JPG-encodable pixel types
+class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where
+  additionalBlocks :: Image px -> [JpgFrame]
+  additionalBlocks _ = []
+
+  componentsOfColorSpace :: Image px -> [JpgComponent]
+
+  encodingState :: Int -> Image px -> V.Vector EncoderState
+
+  imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
+  imageHuffmanTables _ = defaultHuffmanTables 
+
+  scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification]
+
+  quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec]
+  quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual
+
+  maximumSubSamplingOf :: Image px -> Int
+  maximumSubSamplingOf _ = 1
+
+instance JpgEncodable Pixel8 where
+  scanSpecificationOfColorSpace _ =
+    [ JpgScanSpecification { componentSelector = 1
+                           , dcEntropyCodingTable = 0
+                           , acEntropyCodingTable = 0
+                           }
+    ]
+
+  componentsOfColorSpace _ =
+    [ JpgComponent { componentIdentifier      = 1
+                   , horizontalSamplingFactor = 1
+                   , verticalSamplingFactor   = 1
+                   , quantizationTableDest    = 0
+                   }
+    ]
+
+  imageHuffmanTables _ =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    ]
+
+  encodingState qual _ = V.singleton EncoderState
+     { _encComponentIndex = 0
+     , _encBlockWidth     = 1
+     , _encBlockHeight    = 1
+     , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+     , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+     , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+     }
+
+
+instance JpgEncodable PixelYCbCr8 where
+  maximumSubSamplingOf _ = 2
+  quantTableSpec _ qual = zigzaggedQuantificationSpec qual
+  scanSpecificationOfColorSpace _ =
+    [ JpgScanSpecification { componentSelector = 1
+                           , dcEntropyCodingTable = 0
+                           , acEntropyCodingTable = 0
+                           }
+    , JpgScanSpecification { componentSelector = 2
+                           , dcEntropyCodingTable = 1
+                           , acEntropyCodingTable = 1
+                           }
+    , JpgScanSpecification { componentSelector = 3
+                           , dcEntropyCodingTable = 1
+                           , acEntropyCodingTable = 1
+                           }
+    ]
+
+  componentsOfColorSpace _ =
+    [ JpgComponent { componentIdentifier      = 1
+                   , horizontalSamplingFactor = 2
+                   , verticalSamplingFactor   = 2
+                   , quantizationTableDest    = 0
+                   }
+    , JpgComponent { componentIdentifier      = 2
+                   , horizontalSamplingFactor = 1
+                   , verticalSamplingFactor   = 1
+                   , quantizationTableDest    = 1
+                   }
+    , JpgComponent { componentIdentifier      = 3
+                   , horizontalSamplingFactor = 1
+                   , verticalSamplingFactor   = 1
+                   , quantizationTableDest    = 1
+                   }
+    ]
+  
+  encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }]
+    where
+      lumaState = EncoderState
+        { _encComponentIndex = 0
+        , _encBlockWidth     = 2
+        , _encBlockHeight    = 2
+        , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+        , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+        , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+        }
+      chromaState = EncoderState
+        { _encComponentIndex = 1
+        , _encBlockWidth     = 1
+        , _encBlockHeight    = 1
+        , _encQuantTable     = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
+        , _encDcHuffman      = makeInverseTable defaultDcChromaHuffmanTree
+        , _encAcHuffman      = makeInverseTable defaultAcChromaHuffmanTree
+        }
+
+instance JpgEncodable PixelRGB8 where
+  additionalBlocks _ = [] where
+    _adobe14 = JpgAdobeApp14
+        { _adobeDctVersion = 100
+        , _adobeFlag0      = 0
+        , _adobeFlag1      = 0
+        , _adobeTransform  = AdobeUnknown
+        }
+
+  imageHuffmanTables _ =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    ]
+
+  scanSpecificationOfColorSpace _ = fmap build "RGB" where
+    build c = JpgScanSpecification
+      { componentSelector = fromIntegral $ fromEnum c
+      , dcEntropyCodingTable = 0
+      , acEntropyCodingTable = 0
+      }
+
+  componentsOfColorSpace _ = fmap build "RGB" where
+    build c = JpgComponent
+      { componentIdentifier      = fromIntegral $ fromEnum c
+      , horizontalSamplingFactor = 1
+      , verticalSamplingFactor   = 1
+      , quantizationTableDest    = 0
+      }
+
+  encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where
+    build ix = EncoderState
+      { _encComponentIndex = ix
+      , _encBlockWidth     = 1
+      , _encBlockHeight    = 1
+      , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+      , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+      , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+      }
+
+instance JpgEncodable PixelCMYK8 where
+  additionalBlocks _ = [] where
+    _adobe14 = JpgAdobeApp14
+        { _adobeDctVersion = 100
+        , _adobeFlag0      = 32768
+        , _adobeFlag1      = 0
+        , _adobeTransform  = AdobeYCck
+        }
+    
+  imageHuffmanTables _ =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    ]
+
+  scanSpecificationOfColorSpace _ = fmap build "CMYK" where
+    build c = JpgScanSpecification
+      { componentSelector = fromIntegral $ fromEnum c
+      , dcEntropyCodingTable = 0
+      , acEntropyCodingTable = 0
+      }
+
+  componentsOfColorSpace _ = fmap build "CMYK" where
+    build c = JpgComponent
+      { componentIdentifier      = fromIntegral $ fromEnum c
+      , horizontalSamplingFactor = 1
+      , verticalSamplingFactor   = 1
+      , quantizationTableDest    = 0
+      }
+
+  encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where
+    build ix = EncoderState
+      { _encComponentIndex = ix
+      , _encBlockWidth     = 1
+      , _encBlockHeight    = 1
+      , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+      , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+      , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+      }
+
 -- | Equivalent to 'encodeJpegAtQuality', but will store the following
 -- metadatas in the file using a JFIF block:
 --
@@ -759,121 +977,86 @@                                 -> Metadatas
                                 -> Image PixelYCbCr8    -- ^ Image to encode
                                 -> L.ByteString         -- ^ Encoded JPEG
-encodeJpegAtQualityWithMetadata quality metas img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage
-  where finalImage = JpgImage $
-            encodeMetadatas metas ++
-            [ JpgQuantTable quantTables
-            , JpgScans JpgBaselineDCTHuffman hdr
-            , JpgHuffmanTable defaultHuffmanTables
-            , JpgScanBlob scanHeader encodedImage
-            ]
-
-        outputComponentCount = 3
-
-        scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
-        scanHeader' = JpgScanHeader
-            { scanLength = 0
-            , scanComponentCount = outputComponentCount
-            , scans = [ JpgScanSpecification { componentSelector = 1
-                                             , dcEntropyCodingTable = 0
-                                             , acEntropyCodingTable = 0
-                                             }
-                      , JpgScanSpecification { componentSelector = 2
-                                             , dcEntropyCodingTable = 1
-                                             , acEntropyCodingTable = 1
-                                             }
-                      , JpgScanSpecification { componentSelector = 3
-                                             , dcEntropyCodingTable = 1
-                                             , acEntropyCodingTable = 1
-                                             }
-                      ]
-
-            , spectralSelection = (0, 63)
-            , successiveApproxHigh = 0
-            , successiveApproxLow  = 0
-            }
-
-        hdr = hdr' { jpgFrameHeaderLength   = fromIntegral $ calculateSize hdr' }
-        hdr' = JpgFrameHeader { jpgFrameHeaderLength   = 0
-                              , jpgSamplePrecision     = 8
-                              , jpgHeight              = fromIntegral h
-                              , jpgWidth               = fromIntegral w
-                              , jpgImageComponentCount = outputComponentCount
-                              , jpgComponents          = [
-                                    JpgComponent { componentIdentifier      = 1
-                                                 , horizontalSamplingFactor = 2
-                                                 , verticalSamplingFactor   = 2
-                                                 , quantizationTableDest    = 0
-                                                 }
-                                  , JpgComponent { componentIdentifier      = 2
-                                                 , horizontalSamplingFactor = 1
-                                                 , verticalSamplingFactor   = 1
-                                                 , quantizationTableDest    = 1
-                                                 }
-                                  , JpgComponent { componentIdentifier      = 3
-                                                 , horizontalSamplingFactor = 1
-                                                 , verticalSamplingFactor   = 1
-                                                 , quantizationTableDest    = 1
-                                                 }
-                                  ]
-                              }
-
-        lumaQuant = scaleQuantisationMatrix (fromIntegral quality)
-                        defaultLumaQuantizationTable
-        chromaQuant = scaleQuantisationMatrix (fromIntegral quality)
-                            defaultChromaQuantizationTable
+encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata
 
-        zigzagedLumaQuant = zigZagReorderForwardv lumaQuant
-        zigzagedChromaQuant = zigZagReorderForwardv chromaQuant
-        quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0
-                                          , quantTable = zigzagedLumaQuant }
-                      , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1
-                                          , quantTable = zigzagedChromaQuant }
-                      ]
+-- | Equivalent to 'encodeJpegAtQuality', but will store the following
+-- metadatas in the file using a JFIF block:
+--
+--  * 'Codec.Picture.Metadata.DpiX'
+--  * 'Codec.Picture.Metadata.DpiY' 
+--
+-- This function also allow to create JPEG files with the following color
+-- space:
+--
+--  * Y (Pixel8) for greyscale.
+--  * RGB (PixelRGB8) with no color downsampling on any plane
+--  * CMYK (PixelCMYK8) with no color downsampling on any plane
+--
+encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px)
+                                      => Word8                -- ^ Quality factor
+                                      -> Metadatas
+                                      -> Image px             -- ^ Image to encode
+                                      -> L.ByteString         -- ^ Encoded JPEG
+encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where
+  !w = imageWidth img
+  !h = imageHeight img
+  finalImage = JpgImage $
+      encodeMetadatas metas ++
+      additionalBlocks img ++
+      [ JpgQuantTable $ quantTableSpec img (fromIntegral quality)
+      , JpgScans JpgBaselineDCTHuffman hdr
+      , JpgHuffmanTable $ imageHuffmanTables img
+      , JpgScanBlob scanHeader encodedImage
+      ]
 
-        encodedImage = runST $ do
-            let horizontalMetaBlockCount =
-                    w `divUpward` (dctBlockSize * maxSampling)
-                verticalMetaBlockCount =
-                    h `divUpward` (dctBlockSize * maxSampling)
-                maxSampling = 2
-                lumaSamplingSize = ( maxSampling, maxSampling, zigzagedLumaQuant
-                                   , makeInverseTable defaultDcLumaHuffmanTree
-                                   , makeInverseTable defaultAcLumaHuffmanTree)
-                chromaSamplingSize = ( maxSampling - 1, maxSampling - 1, zigzagedChromaQuant
-                                     , makeInverseTable defaultDcChromaHuffmanTree
-                                     , makeInverseTable defaultAcChromaHuffmanTree)
-                componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize]
+  !outputComponentCount = componentCount (undefined :: px)
 
-                imageComponentCount = length componentDef
+  scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
+  scanHeader' = JpgScanHeader
+      { scanLength = 0
+      , scanComponentCount = fromIntegral outputComponentCount
+      , scans = scanSpecificationOfColorSpace img
+      , spectralSelection = (0, 63)
+      , successiveApproxHigh = 0
+      , successiveApproxLow  = 0
+      }
 
-            dc_table <- M.replicate 3 0
-            block <- createEmptyMutableMacroBlock
-            workData <- createEmptyMutableMacroBlock
-            zigzaged <- createEmptyMutableMacroBlock
-            writeState <- newWriteStateRef
+  hdr = hdr' { jpgFrameHeaderLength   = fromIntegral $ calculateSize hdr' }
+  hdr' = JpgFrameHeader
+    { jpgFrameHeaderLength   = 0
+    , jpgSamplePrecision     = 8
+    , jpgHeight              = fromIntegral h
+    , jpgWidth               = fromIntegral w
+    , jpgImageComponentCount = fromIntegral outputComponentCount
+    , jpgComponents          = componentsOfColorSpace img
+    }
 
-            -- It's ugly, I know, be avoid allocation
-            let blockDecoder mx my = component $ zip [0..] componentDef
-                  where component [] = return ()
-                        component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) =
-                           rasterMap sizeX sizeY decoder >> component comp_rest
-                          where xSamplingFactor = maxSampling - sizeX + 1
-                                ySamplingFactor = maxSampling - sizeY + 1
-                                extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount
+  !maxSampling = maximumSubSamplingOf img
+  !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling)
+  !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling)
+  !componentDef = encodingState (fromIntegral quality) img
 
-                                decoder subX subY = do
-                                  let blockY = my * sizeY + subY
-                                      blockX = mx * sizeX + subX
-                                  prev_dc <- dc_table `M.unsafeRead` comp
-                                  (dc_coeff, neo_block) <- extractor comp blockX blockY >>=
-                                                          encodeMacroBlock table workData zigzaged prev_dc
-                                  (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
-                                  serializeMacroBlock writeState dc ac neo_block
+  encodedImage = runST $ do
+    dc_table <- M.replicate outputComponentCount 0
+    block <- createEmptyMutableMacroBlock
+    workData <- createEmptyMutableMacroBlock
+    zigzaged <- createEmptyMutableMacroBlock
+    writeState <- newWriteStateRef
 
-            rasterMap 
-                horizontalMetaBlockCount verticalMetaBlockCount
-                blockDecoder
+    rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my ->
+      V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) -> 
+        let !xSamplingFactor = maxSampling - sizeX + 1
+            !ySamplingFactor = maxSampling - sizeY + 1
+            !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount
+        in
+        rasterMap sizeX sizeY $ \subX subY -> do
+          let !blockY = my * sizeY + subY
+              !blockX = mx * sizeX + subX
+          prev_dc <- dc_table `M.unsafeRead` comp
+          extracted <- extractor comp blockX blockY
+          (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted
+          (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
+          serializeMacroBlock writeState dc ac neo_block
 
-            finalizeBoolWriter writeState
+    finalizeBoolWriter writeState
 

@@ -23,11 +23,10 @@ import Control.Applicative( pure, (<$>) ) #endif -import Control.Monad( replicateM, when )+import Control.Monad( when ) import Control.Monad.ST( ST, runST ) import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) import Data.Int( Int16, Int32 )-import Data.List( foldl' ) import Data.Maybe( fromMaybe ) import Data.Word( Word8 ) import qualified Data.Vector.Storable as VS@@ -174,8 +173,7 @@  -- | Unpack an int of the given size encoded from MSB to LSB. unpackInt :: Int -> BoolReader s Int32-unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg-+unpackInt = getNextIntJpg  {-# INLINE rasterMap #-} rasterMap :: (Monad m)@@ -186,11 +184,6 @@         liner y = columner 0           where columner x | x >= width = liner (y + 1)                 columner x = f x y >> columner (x + 1)--packInt :: [Bool] -> Int32-packInt = foldl' bitStep 0-    where bitStep acc True = (acc `unsafeShiftL` 1) + 1-          bitStep acc False = acc `unsafeShiftL` 1  pixelClamp :: Int16 -> Word8 pixelClamp n = fromIntegral . min 255 $ max 0 n

@@ -427,7 +427,8 @@     getByteString (fromIntegral size - 2)  putFrame :: JpgFrame -> Put-putFrame (JpgAdobeAPP14 _adobe) = return ()+putFrame (JpgAdobeAPP14 adobe) = +    put (JpgAppSegment 14) >> putWord16be 14 >> put adobe putFrame (JpgJFIF jfif) =     put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif putFrame (JpgExif _exif) =

@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-} -- | Helper functions to save dynamic images to other file format -- with automatic color space/sample format conversion done automatically. module Codec.Picture.Saving( imageToJpg@@ -10,6 +11,10 @@                            , 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@@ -94,9 +99,13 @@ -- | This function will try to do anything to encode an image -- as JPEG, make all color conversion and such. Equivalent -- of 'decodeImage' for jpeg encoding+-- Save Y or YCbCr Jpeg only, all other colorspaces are converted.+-- To save a RGB or CMYK JPEG file, use the+-- 'Codec.Picture.Jpg.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@@ -105,10 +114,8 @@         ImageRGBF   img -> imageToJpg quality . ImageRGB8 $ toStandardDef img         ImageRGBA8  img -> encodeAtQuality (convertImage $ dropAlphaLayer img)         ImageYF     img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img-        ImageY8     img -> encodeAtQuality . convertImage-                                           $ (promoteImage img :: Image PixelRGB8)-        ImageYA8    img -> encodeAtQuality $-                            convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)+        ImageY8     img -> encodeWithMeta img+        ImageYA8    img -> encodeWithMeta $ dropAlphaLayer img         ImageY16    img -> imageToJpg quality . ImageY8 $ from16to8 img         ImageYA16   img -> imageToJpg quality . ImageYA8 $ from16to8 img         ImageRGB16  img -> imageToJpg quality . ImageRGB8 $ from16to8 img

@@ -739,7 +739,7 @@                      -> Int        -- ^ Height in pixels
                      -> m (MutableImage (PrimState m) px)
 {-# INLINE generateMutableImage #-}
-generateMutableImage f w h = MutableImage w h <$> generated where
+generateMutableImage f w h = MutableImage w h `liftM` generated where
   compCount = componentCount (undefined :: px)
 
   generated = do
@@ -897,6 +897,7 @@ {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-}
 {-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-}
 {-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-}
 pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } =
   Image w h pixels
     where sourceComponentCount = componentCount (undefined :: a)
@@ -1105,9 +1106,10 @@ 
 instance LumaPlaneExtractable PixelRGBA8 where
     {-# INLINE computeLuma #-}
-    computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r +
-                                             0.59 * toRational g +
-                                             0.11 * toRational b
+    computeLuma (PixelRGBA8 r g b _) =
+       floor $ (0.3 :: Double) * fromIntegral r
+             + 0.59 * fromIntegral g
+             + 0.11 * fromIntegral b
 
 instance LumaPlaneExtractable PixelYCbCr8 where
     {-# INLINE computeLuma #-}
@@ -1570,9 +1572,11 @@ 
 instance LumaPlaneExtractable PixelRGB16 where
     {-# INLINE computeLuma #-}
-    computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r +
-                                             0.59 * toRational g +
-                                             0.11 * toRational b
+    computeLuma (PixelRGB16 r g b) =
+        floor $ (0.3 :: Double) * fromIntegral r
+              + 0.59 * fromIntegral g
+              + 0.11 * fromIntegral b
+
 --------------------------------------------------
 ----            PixelRGB8 instances
 --------------------------------------------------
@@ -1654,9 +1658,10 @@ 
 instance LumaPlaneExtractable PixelRGB8 where
     {-# INLINE computeLuma #-}
-    computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r +
-                                            0.59 * toRational g +
-                                            0.11 * toRational b
+    computeLuma (PixelRGB8 r g b) =
+        floor $ (0.3 :: Double) * fromIntegral r
+              + 0.59 * fromIntegral g
+              + 0.11 * fromIntegral b
 
 --------------------------------------------------
 ----            PixelRGBA8 instances