JuicyPixels 3.2.5.3 → 3.2.6
raw patch · 7 files changed
+841/−814 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Codec.Picture.Saving: imageToTga :: DynamicImage -> ByteString
Files
- JuicyPixels.cabal +2/−2
- changelog +7/−0
- src/Codec/Picture/ColorQuant.hs +386/−386
- src/Codec/Picture/Jpg.hs +1/−1
- src/Codec/Picture/Jpg/Common.hs +237/−237
- src/Codec/Picture/Saving.hs +207/−187
- src/Codec/Picture/Tga.hs +1/−1
JuicyPixels.cabal view
@@ -1,5 +1,5 @@ Name: JuicyPixels-Version: 3.2.5.3+Version: 3.2.6 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.5.3+ Tag: v3.2.6 Flag Mmap Description: Enable the file loading via mmap (memory map)
changelog view
@@ -1,6 +1,13 @@ Change log ========== +V3.2.6 August 2015+--------------------++ * Added: imageToTga saving helper function.+ * Fix: don't invert TGA alpha channel.+ * Fix: various typo in documentation.+ V3.2.5.3 July 2015 ------------------
src/Codec/Picture/ColorQuant.hs view
@@ -1,386 +1,386 @@-{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} --- | This module provide some color quantisation algorithm --- in order to help in the creation of paletted images. --- The most important function is `palettize` which will --- make everything to create a nice color indexed image --- with its palette. -module Codec.Picture.ColorQuant - ( palettize - , defaultPaletteOptions - , PaletteCreationMethod(..) - , PaletteOptions( .. ) - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif - -import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) -import Data.List (elemIndex) -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word (Word32) - -import Data.Vector (Vector, (!)) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Storable as VS - -import Codec.Picture.Types - -------------------------------------------------------------------------------- ----- Palette Creation and Dithering -------------------------------------------------------------------------------- - --- | Define which palette creation method is used. -data PaletteCreationMethod = - -- | MedianMeanCut method, provide the best results (visualy) - -- at the cost of increased calculations. - MedianMeanCut - -- | Very fast algorithm (one pass), doesn't provide good - -- looking results. - | Uniform - --- | To specify how the palette will be created. -data PaletteOptions = PaletteOptions - { -- | Algorithm used to find the palette - paletteCreationMethod :: PaletteCreationMethod - - -- | Do we want to apply the dithering to the - -- image. Enabling it often reduce compression - -- ratio but enhance the perceived quality - -- of the final image. - , enableImageDithering :: Bool - - -- | Maximum number of color we want in the - -- palette - , paletteColorCount :: Int - } - --- | Default palette option, which aim at the best quality --- and maximum possible colors (256) -defaultPaletteOptions :: PaletteOptions -defaultPaletteOptions = PaletteOptions - { paletteCreationMethod = MedianMeanCut - , enableImageDithering = True - , paletteColorCount = 256 - } - --- | Reduces an image to a color palette according to `PaletteOpts` and --- returns the /indices image/ along with its `Palette`. -palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) -palettize opts@PaletteOptions { paletteCreationMethod = method } = - case method of - MedianMeanCut -> medianMeanCutQuantization opts - Uniform -> uniformQuantization opts - --- | Modified median cut algorithm with optional ordered dithering. Returns an --- image of `Pixel8` that acts as a matrix of indices into the `Palette`. -medianMeanCutQuantization :: PaletteOptions -> Image PixelRGB8 - -> (Image Pixel8, Palette) -medianMeanCutQuantization opts img - | isBelow = - (pixelMap okPaletteIndex img, vecToPalette okPaletteVec) - | enableImageDithering opts = (pixelMap paletteIndex dImg, palette) - | otherwise = (pixelMap paletteIndex img, palette) - where - maxColorCount = paletteColorCount opts - (okPalette, isBelow) = isColorCountBelow maxColorCount img - okPaletteVec = V.fromList $ Set.toList okPalette - okPaletteIndex p = nearestColorIdx p okPaletteVec - - palette = vecToPalette paletteVec - paletteIndex p = nearestColorIdx p paletteVec - paletteVec = mkPaletteVec cs - cs = Set.toList . clusters maxColorCount $ img - dImg = pixelMapXY dither img - --- | A naive one pass Color Quantiation 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 --- image of `Pixel8` that acts as a matrix of indices into the `Palette`. -uniformQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) -uniformQuantization opts img - -- -| colorCount img <= maxCols = colorQuantExact img - | enableImageDithering opts = - (pixelMap paletteIndex (pixelMapXY dither img), palette) - | otherwise = (pixelMap paletteIndex img, palette) - where - maxCols = paletteColorCount opts - palette = listToPalette paletteList - paletteList = [PixelRGB8 r g b | r <- [0,dr..255] - , g <- [0,dg..255] - , b <- [0,db..255]] - (bg, br, bb) = bitDiv3 maxCols - (dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb)) - paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex - (PixelRGB8 (r .&. (255 - dr)) (g .&. (255 - dg)) (b .&. (255 - db))) - paletteList) - -isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool) -isColorCountBelow maxColorCount img = go 0 Set.empty - where rawData = imageData img - maxIndex = VS.length rawData - - go !idx !allColors - | Set.size allColors > maxColorCount = (Set.empty, False) - | idx >= maxIndex - 2 = (allColors, True) - | otherwise = go (idx + 3) $ Set.insert px allColors - where px = unsafePixelAt rawData idx - -vecToPalette :: Vector PixelRGB8 -> Palette -vecToPalette ps = generateImage (\x _ -> ps ! x) (V.length ps) 1 - -listToPalette :: [PixelRGB8] -> Palette -listToPalette ps = generateImage (\x _ -> ps !! x) (length ps) 1 - -bitDiv3 :: Int -> (Int, Int, Int) -bitDiv3 n = case r of - 0 -> (q, q, q) - 1 -> (q+1, q, q) - _ -> (q+1, q+1, q) - where - r = m `mod` 3 - q = m `div` 3 - m = floor . logBase (2 :: Double) $ fromIntegral n - -------------------------------------------------------------------------------- ----- Dithering -------------------------------------------------------------------------------- - --- Add a dither mask to an image for ordered dithering. --- Uses a small, spatially stable dithering algorithm based on magic numbers --- and arithmetic inspired by the /a dither/ algorithm of Øyvind Kolås, --- pippin@gimp.org, 2013. See, http://pippin.gimp.org/a_dither/. -dither :: Int -> Int -> PixelRGB8 -> PixelRGB8 -dither x y (PixelRGB8 r g b) = PixelRGB8 (fromIntegral r') - (fromIntegral g') - (fromIntegral b') - where - -- Should view 16 as a parameter that can be optimized for best looking - -- results - r' = min 255 (fromIntegral r + (x' + y') .&. 16) - g' = min 255 (fromIntegral g + (x' + y' + 7973) .&. 16) - b' = min 255 (fromIntegral b + (x' + y' + 15946) .&. 16) - x' = 119 * x - y' = 28084 * y - -------------------------------------------------------------------------------- ----- Small modification of foldl package by Gabriel Gonzalez -------------------------------------------------------------------------------- - --- Modification to Control.foldl by Gabriel Gonzalez copyright 2013, BSD3. --- http://hackage.haskell.org/package/foldl-1.0.1/docs/Control-Foldl.html - -{-| Efficient representation of a left fold that preserves the fold's step - function, initial accumulator, and extraction function - - This allows the 'Applicative' instance to assemble derived folds that - traverse the container only once --} -data Fold a b = forall x . Fold (x -> a -> x) x (x -> b) - -{-| Apply a strict left 'Fold' to a 'Foldable' container - - Much slower than 'fold' on lists because 'Foldable' operations currently do - not trigger @build/foldr@ fusion --} -fold :: Fold PackedRGB b -> VU.Vector PackedRGB -> b -fold (Fold step begin done) = done . VU.foldl' step begin -{-# INLINE fold #-} - -{- -F.foldr :: (a -> b -> b) -> b -> t a -> b - -fold :: (Foldable f) => Fold a b -> f a -> b -fold (Fold step begin done) as = F.foldr step' done as begin - where step' x k z = k $! step z x --} - -data Pair a b = Pair !a !b - -instance Functor (Fold a) where - fmap f (Fold step begin done) = Fold step begin (f . done) - {-# INLINABLE fmap #-} - -instance Applicative (Fold a) where - pure b = Fold (\() _ -> ()) () (\() -> b) - {-# INLINABLE pure #-} - (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) = - let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a) - begin = Pair beginL beginR - done (Pair xL xR) = doneL xL $ doneR xR - in Fold step begin done - {-# INLINABLE (<*>) #-} - -{- | Like 'length', except with a more general 'Num' return value -} -intLength :: Fold a Int -intLength = Fold (\n _ -> n + 1) 0 id - -------------------------------------------------------------------------------- ----- Modified Median Cut Algorithm -------------------------------------------------------------------------------- - --- Based on the OCaml implementation: --- http://rosettacode.org/wiki/Color_quantization --- which is in turn based on: www.leptonica.com/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 --- of the modifiations is to use the mean. - -mkPaletteVec :: [Cluster] -> Vector PixelRGB8 -mkPaletteVec = V.fromList . map (toRGB8 . meanColor) - -type PackedRGB = Word32 - -data Cluster = Cluster - { value :: {-# UNPACK #-} !Float - , meanColor :: !PixelRGBF - , dims :: !PixelRGBF - , colors :: VU.Vector PackedRGB - } - -instance Eq Cluster where - a == b = - (value a, meanColor a, dims a) == (value b, meanColor b, dims b) - -instance Ord Cluster where - compare a b = - compare (value a, meanColor a, dims a) (value b, meanColor b, dims b) - -data Axis = RAxis | GAxis | BAxis - -inf :: Float -inf = read "Infinity" - -fromRGB8 :: PixelRGB8 -> PixelRGBF -fromRGB8 (PixelRGB8 r g b) = - PixelRGBF (fromIntegral r) (fromIntegral g) (fromIntegral b) - -toRGB8 :: PixelRGBF -> PixelRGB8 -toRGB8 (PixelRGBF r g b) = - PixelRGB8 (round r) (round g) (round b) - -meanRGB :: Fold PixelRGBF PixelRGBF -meanRGB = mean <$> intLength <*> pixelSum - where - pixelSum = Fold (mixWith $ const (+)) (PixelRGBF 0 0 0) id - mean n = colorMap (/ nf) - where nf = fromIntegral n - -minimal :: Fold PixelRGBF PixelRGBF -minimal = Fold mini (PixelRGBF inf inf inf) id - where mini = mixWith $ const min - -maximal :: Fold PixelRGBF PixelRGBF -maximal = Fold maxi (PixelRGBF (-inf) (-inf) (-inf)) id - where maxi = mixWith $ const max - -extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF) -extrems = (,) <$> minimal <*> maximal - -volAndDims :: Fold PixelRGBF (Float, PixelRGBF) -volAndDims = deltify <$> extrems - where deltify (mini, maxi) = (dr * dg * db, delta) - where delta@(PixelRGBF dr dg db) = - mixWith (const (-)) maxi mini - -unpackFold :: Fold PixelRGBF a -> Fold PackedRGB a -unpackFold (Fold step start done) = Fold (\acc -> step acc . transform) start done - where transform = fromRGB8 . rgbIntUnpack - -mkCluster :: VU.Vector PackedRGB -> Cluster -mkCluster ps = Cluster - { value = v * fromIntegral l - , meanColor = m - , dims = ds - , colors = ps - } - where - worker = (,,) <$> volAndDims <*> meanRGB <*> intLength - ((v, ds), m, l) = fold (unpackFold worker) ps - -maxAxis :: PixelRGBF -> Axis -maxAxis (PixelRGBF r g b) = - case (r `compare` g, r `compare` b, g `compare` b) of - (GT, GT, _) -> RAxis - (LT, GT, _) -> GAxis - (GT, LT, _) -> BAxis - (LT, LT, GT) -> GAxis - (EQ, GT, _) -> RAxis - (_, _, _) -> BAxis - --- Split a cluster about its largest axis using the mean to divide up the --- pixels. -subdivide :: Cluster -> (Cluster, Cluster) -subdivide cluster = (mkCluster px1, mkCluster px2) - where - (PixelRGBF mr mg mb) = meanColor cluster - (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster - cond = case maxAxis $ dims cluster of - RAxis -> \(PixelRGB8 r _ _) -> fromIntegral r < mr - GAxis -> \(PixelRGB8 _ g _) -> fromIntegral g < mg - BAxis -> \(PixelRGB8 _ _ b) -> fromIntegral b < mb - -rgbIntPack :: PixelRGB8 -> PackedRGB -rgbIntPack (PixelRGB8 r g b) = - wr `unsafeShiftL` (2 * 8) .|. wg `unsafeShiftL` 8 .|. wb - where wr = fromIntegral r - wg = fromIntegral g - wb = fromIntegral b - -rgbIntUnpack :: PackedRGB -> PixelRGB8 -rgbIntUnpack v = PixelRGB8 r g b - where - r = fromIntegral $ v `unsafeShiftR` (2 * 8) - g = fromIntegral $ v `unsafeShiftR` 8 - b = fromIntegral v - -initCluster :: Image PixelRGB8 -> Cluster -initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer - where samplingFactor = 3 - subSampling = samplingFactor * samplingFactor - compCount = componentCount (undefined :: PixelRGB8) - w = imageWidth img - h = imageHeight img - rawData = imageData img - packer ix = - rgbIntPack . unsafePixelAt rawData $ ix * subSampling * compCount - --- Take the cluster with the largest value = (volume * population) and remove it --- from the priority queue. Then subdivide it about its largest axis and put the --- two new clusters on the queue. -split :: Set Cluster -> Set Cluster -split cs = Set.insert c1 . Set.insert c2 $ cs' - where - (c, cs') = Set.deleteFindMax cs - (c1, c2) = subdivide c - --- Keep splitting the initial cluster until there are 256 clusters, then return --- a priority queue containing all 256. -clusters :: Int -> Image PixelRGB8 -> Set Cluster -clusters maxCols img = clusters' (maxCols - 1) - where - clusters' :: Int -> Set Cluster - clusters' 0 = Set.singleton c - clusters' n = split (clusters' (n-1)) - c = initCluster img - --- Euclidean distance squared, between two pixels. -dist2Px :: PixelRGB8 -> PixelRGB8 -> Int -dist2Px (PixelRGB8 r1 g1 b1) (PixelRGB8 r2 g2 b2) = dr*dr + dg*dg + db*db - where - (dr, dg, db) = - ( fromIntegral r1 - fromIntegral r2 - , fromIntegral g1 - fromIntegral g2 - , fromIntegral b1 - fromIntegral b2 ) - -nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8 -nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps) +{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+-- | This module provide some color quantisation algorithm+-- in order to help in the creation of paletted images.+-- The most important function is `palettize` which will+-- make everything to create a nice color indexed image+-- with its palette.+module Codec.Picture.ColorQuant+ ( palettize+ , defaultPaletteOptions+ , PaletteCreationMethod(..)+ , PaletteOptions( .. )+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif++import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))+import Data.List (elemIndex)+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Word (Word32)++import Data.Vector (Vector, (!))+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Storable as VS++import Codec.Picture.Types++-------------------------------------------------------------------------------+---- Palette Creation and Dithering+-------------------------------------------------------------------------------++-- | Define which palette creation method is used.+data PaletteCreationMethod =+ -- | MedianMeanCut method, provide the best results (visualy)+ -- at the cost of increased calculations.+ MedianMeanCut+ -- | Very fast algorithm (one pass), doesn't provide good+ -- looking results.+ | Uniform++-- | To specify how the palette will be created.+data PaletteOptions = PaletteOptions+ { -- | Algorithm used to find the palette+ paletteCreationMethod :: PaletteCreationMethod++ -- | Do we want to apply the dithering to the+ -- image. Enabling it often reduce compression+ -- ratio but enhance the perceived quality+ -- of the final image.+ , enableImageDithering :: Bool++ -- | Maximum number of color we want in the+ -- palette+ , paletteColorCount :: Int+ }++-- | Default palette option, which aim at the best quality+-- and maximum possible colors (256)+defaultPaletteOptions :: PaletteOptions+defaultPaletteOptions = PaletteOptions+ { paletteCreationMethod = MedianMeanCut+ , enableImageDithering = True+ , paletteColorCount = 256+ }++-- | Reduces an image to a color palette according to `PaletteOpts` and+-- returns the /indices image/ along with its `Palette`.+palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette)+palettize opts@PaletteOptions { paletteCreationMethod = method } =+ case method of+ MedianMeanCut -> medianMeanCutQuantization opts+ Uniform -> uniformQuantization opts++-- | Modified median cut algorithm with optional ordered dithering. Returns an+-- image of `Pixel8` that acts as a matrix of indices into the `Palette`.+medianMeanCutQuantization :: PaletteOptions -> Image PixelRGB8+ -> (Image Pixel8, Palette)+medianMeanCutQuantization opts img+ | isBelow =+ (pixelMap okPaletteIndex img, vecToPalette okPaletteVec)+ | enableImageDithering opts = (pixelMap paletteIndex dImg, palette)+ | otherwise = (pixelMap paletteIndex img, palette)+ where+ maxColorCount = paletteColorCount opts+ (okPalette, isBelow) = isColorCountBelow maxColorCount img+ okPaletteVec = V.fromList $ Set.toList okPalette+ okPaletteIndex p = nearestColorIdx p okPaletteVec++ palette = vecToPalette paletteVec+ paletteIndex p = nearestColorIdx p paletteVec+ paletteVec = mkPaletteVec cs+ cs = Set.toList . clusters maxColorCount $ img+ dImg = pixelMapXY dither img++-- | A naive one pass Color Quantiation 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+-- image of `Pixel8` that acts as a matrix of indices into the `Palette`.+uniformQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette)+uniformQuantization opts img+ -- -| colorCount img <= maxCols = colorQuantExact img+ | enableImageDithering opts =+ (pixelMap paletteIndex (pixelMapXY dither img), palette)+ | otherwise = (pixelMap paletteIndex img, palette)+ where+ maxCols = paletteColorCount opts+ palette = listToPalette paletteList+ paletteList = [PixelRGB8 r g b | r <- [0,dr..255]+ , g <- [0,dg..255]+ , b <- [0,db..255]]+ (bg, br, bb) = bitDiv3 maxCols+ (dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb))+ paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex+ (PixelRGB8 (r .&. (255 - dr)) (g .&. (255 - dg)) (b .&. (255 - db)))+ paletteList)++isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool)+isColorCountBelow maxColorCount img = go 0 Set.empty+ where rawData = imageData img+ maxIndex = VS.length rawData+ + go !idx !allColors+ | Set.size allColors > maxColorCount = (Set.empty, False)+ | idx >= maxIndex - 2 = (allColors, True)+ | otherwise = go (idx + 3) $ Set.insert px allColors+ where px = unsafePixelAt rawData idx ++vecToPalette :: Vector PixelRGB8 -> Palette+vecToPalette ps = generateImage (\x _ -> ps ! x) (V.length ps) 1++listToPalette :: [PixelRGB8] -> Palette+listToPalette ps = generateImage (\x _ -> ps !! x) (length ps) 1++bitDiv3 :: Int -> (Int, Int, Int)+bitDiv3 n = case r of+ 0 -> (q, q, q)+ 1 -> (q+1, q, q)+ _ -> (q+1, q+1, q)+ where+ r = m `mod` 3+ q = m `div` 3+ m = floor . logBase (2 :: Double) $ fromIntegral n++-------------------------------------------------------------------------------+---- Dithering+-------------------------------------------------------------------------------++-- Add a dither mask to an image for ordered dithering.+-- Uses a small, spatially stable dithering algorithm based on magic numbers+-- and arithmetic inspired by the /a dither/ algorithm of Øyvind Kolås,+-- pippin@gimp.org, 2013. See, http://pippin.gimp.org/a_dither/.+dither :: Int -> Int -> PixelRGB8 -> PixelRGB8+dither x y (PixelRGB8 r g b) = PixelRGB8 (fromIntegral r')+ (fromIntegral g')+ (fromIntegral b')+ where+ -- Should view 16 as a parameter that can be optimized for best looking+ -- results+ r' = min 255 (fromIntegral r + (x' + y') .&. 16)+ g' = min 255 (fromIntegral g + (x' + y' + 7973) .&. 16)+ b' = min 255 (fromIntegral b + (x' + y' + 15946) .&. 16)+ x' = 119 * x+ y' = 28084 * y++-------------------------------------------------------------------------------+---- Small modification of foldl package by Gabriel Gonzalez+-------------------------------------------------------------------------------++-- Modification to Control.foldl by Gabriel Gonzalez copyright 2013, BSD3.+-- http://hackage.haskell.org/package/foldl-1.0.1/docs/Control-Foldl.html++{-| Efficient representation of a left fold that preserves the fold's step+ function, initial accumulator, and extraction function++ This allows the 'Applicative' instance to assemble derived folds that+ traverse the container only once+-}+data Fold a b = forall x . Fold (x -> a -> x) x (x -> b)++{-| Apply a strict left 'Fold' to a 'Foldable' container++ Much slower than 'fold' on lists because 'Foldable' operations currently do+ not trigger @build/foldr@ fusion+-}+fold :: Fold PackedRGB b -> VU.Vector PackedRGB -> b+fold (Fold step begin done) = done . VU.foldl' step begin+{-# INLINE fold #-}++{-+F.foldr :: (a -> b -> b) -> b -> t a -> b++fold :: (Foldable f) => Fold a b -> f a -> b+fold (Fold step begin done) as = F.foldr step' done as begin+ where step' x k z = k $! step z x+-}++data Pair a b = Pair !a !b++instance Functor (Fold a) where+ fmap f (Fold step begin done) = Fold step begin (f . done)+ {-# INLINABLE fmap #-}++instance Applicative (Fold a) where+ pure b = Fold (\() _ -> ()) () (\() -> b)+ {-# INLINABLE pure #-}+ (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =+ let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a)+ begin = Pair beginL beginR+ done (Pair xL xR) = doneL xL $ doneR xR+ in Fold step begin done+ {-# INLINABLE (<*>) #-}++{- | Like 'length', except with a more general 'Num' return value -}+intLength :: Fold a Int+intLength = Fold (\n _ -> n + 1) 0 id++-------------------------------------------------------------------------------+---- Modified Median Cut Algorithm+-------------------------------------------------------------------------------++-- Based on the OCaml implementation:+-- http://rosettacode.org/wiki/Color_quantization+-- which is in turn based on: www.leptonica.com/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+-- of the modifiations is to use the mean.++mkPaletteVec :: [Cluster] -> Vector PixelRGB8+mkPaletteVec = V.fromList . map (toRGB8 . meanColor)++type PackedRGB = Word32++data Cluster = Cluster+ { value :: {-# UNPACK #-} !Float+ , meanColor :: !PixelRGBF+ , dims :: !PixelRGBF+ , colors :: VU.Vector PackedRGB+ }++instance Eq Cluster where+ a == b =+ (value a, meanColor a, dims a) == (value b, meanColor b, dims b)++instance Ord Cluster where+ compare a b =+ compare (value a, meanColor a, dims a) (value b, meanColor b, dims b)++data Axis = RAxis | GAxis | BAxis++inf :: Float+inf = read "Infinity"++fromRGB8 :: PixelRGB8 -> PixelRGBF+fromRGB8 (PixelRGB8 r g b) =+ PixelRGBF (fromIntegral r) (fromIntegral g) (fromIntegral b)++toRGB8 :: PixelRGBF -> PixelRGB8+toRGB8 (PixelRGBF r g b) =+ PixelRGB8 (round r) (round g) (round b)++meanRGB :: Fold PixelRGBF PixelRGBF+meanRGB = mean <$> intLength <*> pixelSum+ where+ pixelSum = Fold (mixWith $ const (+)) (PixelRGBF 0 0 0) id+ mean n = colorMap (/ nf)+ where nf = fromIntegral n++minimal :: Fold PixelRGBF PixelRGBF+minimal = Fold mini (PixelRGBF inf inf inf) id+ where mini = mixWith $ const min++maximal :: Fold PixelRGBF PixelRGBF+maximal = Fold maxi (PixelRGBF (-inf) (-inf) (-inf)) id+ where maxi = mixWith $ const max++extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF)+extrems = (,) <$> minimal <*> maximal++volAndDims :: Fold PixelRGBF (Float, PixelRGBF)+volAndDims = deltify <$> extrems+ where deltify (mini, maxi) = (dr * dg * db, delta)+ where delta@(PixelRGBF dr dg db) =+ mixWith (const (-)) maxi mini++unpackFold :: Fold PixelRGBF a -> Fold PackedRGB a+unpackFold (Fold step start done) = Fold (\acc -> step acc . transform) start done+ where transform = fromRGB8 . rgbIntUnpack++mkCluster :: VU.Vector PackedRGB -> Cluster+mkCluster ps = Cluster+ { value = v * fromIntegral l+ , meanColor = m+ , dims = ds+ , colors = ps+ }+ where+ worker = (,,) <$> volAndDims <*> meanRGB <*> intLength+ ((v, ds), m, l) = fold (unpackFold worker) ps++maxAxis :: PixelRGBF -> Axis+maxAxis (PixelRGBF r g b) =+ case (r `compare` g, r `compare` b, g `compare` b) of+ (GT, GT, _) -> RAxis+ (LT, GT, _) -> GAxis+ (GT, LT, _) -> BAxis+ (LT, LT, GT) -> GAxis+ (EQ, GT, _) -> RAxis+ (_, _, _) -> BAxis++-- Split a cluster about its largest axis using the mean to divide up the+-- pixels.+subdivide :: Cluster -> (Cluster, Cluster)+subdivide cluster = (mkCluster px1, mkCluster px2)+ where+ (PixelRGBF mr mg mb) = meanColor cluster+ (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster+ cond = case maxAxis $ dims cluster of+ RAxis -> \(PixelRGB8 r _ _) -> fromIntegral r < mr+ GAxis -> \(PixelRGB8 _ g _) -> fromIntegral g < mg+ BAxis -> \(PixelRGB8 _ _ b) -> fromIntegral b < mb++rgbIntPack :: PixelRGB8 -> PackedRGB+rgbIntPack (PixelRGB8 r g b) =+ wr `unsafeShiftL` (2 * 8) .|. wg `unsafeShiftL` 8 .|. wb+ where wr = fromIntegral r+ wg = fromIntegral g+ wb = fromIntegral b++rgbIntUnpack :: PackedRGB -> PixelRGB8+rgbIntUnpack v = PixelRGB8 r g b+ where+ r = fromIntegral $ v `unsafeShiftR` (2 * 8)+ g = fromIntegral $ v `unsafeShiftR` 8+ b = fromIntegral v++initCluster :: Image PixelRGB8 -> Cluster+initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer+ where samplingFactor = 3+ subSampling = samplingFactor * samplingFactor+ compCount = componentCount (undefined :: PixelRGB8)+ w = imageWidth img+ h = imageHeight img+ rawData = imageData img+ packer ix =+ rgbIntPack . unsafePixelAt rawData $ ix * subSampling * compCount++-- Take the cluster with the largest value = (volume * population) and remove it+-- from the priority queue. Then subdivide it about its largest axis and put the+-- two new clusters on the queue.+split :: Set Cluster -> Set Cluster+split cs = Set.insert c1 . Set.insert c2 $ cs'+ where+ (c, cs') = Set.deleteFindMax cs+ (c1, c2) = subdivide c++-- Keep splitting the initial cluster until there are 256 clusters, then return+-- a priority queue containing all 256.+clusters :: Int -> Image PixelRGB8 -> Set Cluster+clusters maxCols img = clusters' (maxCols - 1)+ where+ clusters' :: Int -> Set Cluster+ clusters' 0 = Set.singleton c+ clusters' n = split (clusters' (n-1))+ c = initCluster img++-- Euclidean distance squared, between two pixels.+dist2Px :: PixelRGB8 -> PixelRGB8 -> Int+dist2Px (PixelRGB8 r1 g1 b1) (PixelRGB8 r2 g2 b2) = dr*dr + dg*dg + db*db+ where+ (dr, dg, db) =+ ( fromIntegral r1 - fromIntegral r2+ , fromIntegral g1 - fromIntegral g2+ , fromIntegral b1 - fromIntegral b2 )++nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8+nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps)
src/Codec/Picture/Jpg.hs view
@@ -581,7 +581,7 @@ in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr - _ -> Left "Unnkown JPG kind" + _ -> Left "Unknown JPG kind" where compCount = length $ jpgComponents scanInfo (_,scanInfo) = gatherScanInfo img
src/Codec/Picture/Jpg/Common.hs view
@@ -1,237 +1,237 @@-{-# 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 - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<$>) ) -#endif - -import Control.Monad( replicateM, when ) -import Control.Monad.ST( ST, runST ) -import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) -import Data.Int( Int16, Int32 ) -import Data.List( foldl' ) -import Data.Maybe( fromMaybe ) -import Data.Word( Word8 ) -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import Foreign.Storable ( Storable ) - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.FastIdct -import Codec.Picture.Jpg.DefaultTable - --- | Same as for DcCoefficient, to provide nicer type signatures -type DctCoefficients = DcCoefficient - -data JpgUnpackerParameter = JpgUnpackerParameter - { dcHuffmanTree :: !HuffmanPackedTree - , acHuffmanTree :: !HuffmanPackedTree - , componentIndex :: {-# UNPACK #-} !Int - , restartInterval :: {-# UNPACK #-} !Int - , componentWidth :: {-# UNPACK #-} !Int - , componentHeight :: {-# UNPACK #-} !Int - , subSampling :: !(Int, Int) - , coefficientRange :: !(Int, Int) - , successiveApprox :: !(Int, Int) - , readerIndex :: {-# UNPACK #-} !Int - , indiceVector :: {-# UNPACK #-} !Int - , blockIndex :: {-# UNPACK #-} !Int - , blockMcuX :: {-# UNPACK #-} !Int - , blockMcuY :: {-# UNPACK #-} !Int - } - deriving Show - -decodeRestartInterval :: BoolReader s Int32 -decodeRestartInterval = return (-1) {- do - bits <- replicateM 8 getNextBitJpg - if bits == replicate 8 True - then do - marker <- replicateM 8 getNextBitJpg - return $ packInt marker - else return (-1) - -} - -{-# INLINE decodeInt #-} -decodeInt :: Int -> BoolReader s Int32 -decodeInt ssss = do - signBit <- getNextBitJpg - let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) - leftBitCount = ssss - 1 - -- First following bits store the sign of the coefficient, and counted in - -- SSSS, so the bit count for the int, is ssss - 1 - if signBit - then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount - else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount - -decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) -decodeRrrrSsss tree = do - rrrrssss <- huffmanPackedDecode tree - let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF - ssss = rrrrssss .&. 0xF - pure (fromIntegral rrrr, fromIntegral ssss) - -dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient -dcCoefficientDecode dcTree = do - ssss <- huffmanPackedDecode dcTree - if ssss == 0 - then return 0 - else fromIntegral <$> decodeInt (fromIntegral ssss) - --- | Apply a quantization matrix to a macroblock -{-# INLINE deQuantize #-} -deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -deQuantize table block = update 0 - where update 64 = return block - update i = do - val <- block `M.unsafeRead` i - let finalValue = val * (table `VS.unsafeIndex` i) - (block `M.unsafeWrite` i) finalValue - update $ i + 1 - -inverseDirectCosineTransform :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -inverseDirectCosineTransform mBlock = - fastIdct mBlock >>= mutableLevelShift - -zigZagOrder :: MacroBlock Int -zigZagOrder = makeMacroBlock $ concat - [[ 0, 1, 5, 6,14,15,27,28] - ,[ 2, 4, 7,13,16,26,29,42] - ,[ 3, 8,12,17,25,30,41,43] - ,[ 9,11,18,24,31,40,44,53] - ,[10,19,23,32,39,45,52,54] - ,[20,22,33,38,46,51,55,60] - ,[21,34,37,47,50,56,59,61] - ,[35,36,48,49,57,58,62,63] - ] - -zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a -zigZagReorderForwardv vec = runST $ do - v <- M.new 64 - mv <- VS.thaw vec - zigZagReorderForward v mv >>= VS.freeze - -zigZagOrderForward :: MacroBlock Int -zigZagOrderForward = VS.generate 64 inv - where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder - -zigZagReorderForward :: (Storable a, Num a) - => MutableMacroBlock s a - -> MutableMacroBlock s a - -> ST s (MutableMacroBlock s a) -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int32 - -> ST s (MutableMacroBlock s Int32) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 - -> MutableMacroBlock s Word8 - -> ST s (MutableMacroBlock s Word8) #-} -zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged - where ordering !table = reorder (0 :: Int) - where reorder !i | i >= 64 = return () - reorder i = do - let idx = table `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - reorder (i + 1) - -zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -zigZagReorder zigzaged block = do - let update i = do - let idx = zigZagOrder `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - - reorder 63 = update 63 - reorder i = update i >> reorder (i + 1) - - reorder (0 :: Int) - return zigzaged - --- | Unpack an int of the given size encoded from MSB to LSB. -unpackInt :: Int -> BoolReader s Int32 -unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg - - -{-# INLINE rasterMap #-} -rasterMap :: (Monad m) - => Int -> Int -> (Int -> Int -> m ()) - -> m () -rasterMap width height f = liner 0 - where liner y | y >= height = return () - liner y = columner 0 - where columner x | x >= width = liner (y + 1) - columner x = f x y >> columner (x + 1) - -packInt :: [Bool] -> Int32 -packInt = foldl' bitStep 0 - where bitStep acc True = (acc `unsafeShiftL` 1) + 1 - bitStep acc False = acc `unsafeShiftL` 1 - -pixelClamp :: Int16 -> Word8 -pixelClamp n = fromIntegral . min 255 $ max 0 n - --- | Given a size coefficient (how much a pixel span horizontally --- and vertically), the position of the macroblock, return a list --- of indices and value to be stored in an array (like the final --- image) -unpackMacroBlock :: Int -- ^ Component count - -> Int -- ^ Width coefficient - -> Int -- ^ Height coefficient - -> Int -- ^ x - -> Int -- ^ y - -> Int -- ^ Component index - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpackMacroBlock compCount wCoeff hCoeff compIdx x y - (MutableImage { mutableImageWidth = imgWidth, - mutableImageHeight = imgHeight, mutableImageData = img }) - block = rasterMap dctBlockSize dctBlockSize unpacker - where unpacker i j = do - let yBase = y * dctBlockSize + j * hCoeff - compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) - rasterMap wCoeff hCoeff $ \wDup hDup -> do - let xBase = x * dctBlockSize + i * wCoeff - xPos = xBase + wDup - yPos = yBase + hDup - - when (xPos < imgWidth && yPos < imgHeight) - (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx - (img `M.unsafeWrite` mutableIdx) compVal) - --- | This is one of the most important function of the decoding, --- it form the barebone decoding pipeline for macroblock. It's all --- there is to know for macro block transformation -decodeMacroBlock :: MacroBlock DctCoefficients - -> MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -decodeMacroBlock quantizationTable zigZagBlock block = - deQuantize quantizationTable block >>= zigZagReorder zigZagBlock - >>= inverseDirectCosineTransform - +{-# 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+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( pure, (<$>) )+#endif++import Control.Monad( replicateM, when )+import Control.Monad.ST( ST, runST )+import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) )+import Data.Int( Int16, Int32 )+import Data.List( foldl' )+import Data.Maybe( fromMaybe )+import Data.Word( Word8 )+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Storable.Mutable as M+import Foreign.Storable ( Storable )++import Codec.Picture.Types+import Codec.Picture.BitWriter+import Codec.Picture.Jpg.Types+import Codec.Picture.Jpg.FastIdct+import Codec.Picture.Jpg.DefaultTable++-- | Same as for DcCoefficient, to provide nicer type signatures+type DctCoefficients = DcCoefficient++data JpgUnpackerParameter = JpgUnpackerParameter+ { dcHuffmanTree :: !HuffmanPackedTree+ , acHuffmanTree :: !HuffmanPackedTree+ , componentIndex :: {-# UNPACK #-} !Int+ , restartInterval :: {-# UNPACK #-} !Int+ , componentWidth :: {-# UNPACK #-} !Int+ , componentHeight :: {-# UNPACK #-} !Int+ , subSampling :: !(Int, Int)+ , coefficientRange :: !(Int, Int)+ , successiveApprox :: !(Int, Int)+ , readerIndex :: {-# UNPACK #-} !Int+ , indiceVector :: {-# UNPACK #-} !Int+ , blockIndex :: {-# UNPACK #-} !Int+ , blockMcuX :: {-# UNPACK #-} !Int+ , blockMcuY :: {-# UNPACK #-} !Int+ }+ deriving Show++decodeRestartInterval :: BoolReader s Int32+decodeRestartInterval = return (-1) {- do+ bits <- replicateM 8 getNextBitJpg+ if bits == replicate 8 True+ then do+ marker <- replicateM 8 getNextBitJpg+ return $ packInt marker+ else return (-1)+ -}++{-# INLINE decodeInt #-}+decodeInt :: Int -> BoolReader s Int32+decodeInt ssss = do+ signBit <- getNextBitJpg+ let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1)+ leftBitCount = ssss - 1+ -- First following bits store the sign of the coefficient, and counted in+ -- SSSS, so the bit count for the int, is ssss - 1+ if signBit+ then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount+ else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount++decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int)+decodeRrrrSsss tree = do+ rrrrssss <- huffmanPackedDecode tree+ let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF+ ssss = rrrrssss .&. 0xF+ pure (fromIntegral rrrr, fromIntegral ssss)++dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient+dcCoefficientDecode dcTree = do+ ssss <- huffmanPackedDecode dcTree+ if ssss == 0+ then return 0+ else fromIntegral <$> decodeInt (fromIntegral ssss)++-- | Apply a quantization matrix to a macroblock+{-# INLINE deQuantize #-}+deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int16)+deQuantize table block = update 0+ where update 64 = return block+ update i = do+ val <- block `M.unsafeRead` i+ let finalValue = val * (table `VS.unsafeIndex` i)+ (block `M.unsafeWrite` i) finalValue+ update $ i + 1++inverseDirectCosineTransform :: MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int16)+inverseDirectCosineTransform mBlock =+ fastIdct mBlock >>= mutableLevelShift++zigZagOrder :: MacroBlock Int+zigZagOrder = makeMacroBlock $ concat+ [[ 0, 1, 5, 6,14,15,27,28]+ ,[ 2, 4, 7,13,16,26,29,42]+ ,[ 3, 8,12,17,25,30,41,43]+ ,[ 9,11,18,24,31,40,44,53]+ ,[10,19,23,32,39,45,52,54]+ ,[20,22,33,38,46,51,55,60]+ ,[21,34,37,47,50,56,59,61]+ ,[35,36,48,49,57,58,62,63]+ ]++zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a+zigZagReorderForwardv vec = runST $ do+ v <- M.new 64+ mv <- VS.thaw vec+ zigZagReorderForward v mv >>= VS.freeze++zigZagOrderForward :: MacroBlock Int+zigZagOrderForward = VS.generate 64 inv+ where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder++zigZagReorderForward :: (Storable a, Num a)+ => MutableMacroBlock s a+ -> MutableMacroBlock s a+ -> ST s (MutableMacroBlock s a)+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32+ -> MutableMacroBlock s Int32+ -> ST s (MutableMacroBlock s Int32) #-}+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16+ -> MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int16) #-}+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8+ -> MutableMacroBlock s Word8+ -> ST s (MutableMacroBlock s Word8) #-}+zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged+ where ordering !table = reorder (0 :: Int)+ where reorder !i | i >= 64 = return ()+ reorder i = do+ let idx = table `VS.unsafeIndex` i+ v <- block `M.unsafeRead` idx+ (zigzaged `M.unsafeWrite` i) v+ reorder (i + 1)++zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int16)+zigZagReorder zigzaged block = do+ let update i = do+ let idx = zigZagOrder `VS.unsafeIndex` i+ v <- block `M.unsafeRead` idx+ (zigzaged `M.unsafeWrite` i) v++ reorder 63 = update 63+ reorder i = update i >> reorder (i + 1)++ reorder (0 :: Int)+ return zigzaged++-- | Unpack an int of the given size encoded from MSB to LSB.+unpackInt :: Int -> BoolReader s Int32+unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg+++{-# INLINE rasterMap #-}+rasterMap :: (Monad m)+ => Int -> Int -> (Int -> Int -> m ())+ -> m ()+rasterMap width height f = liner 0+ where liner y | y >= height = return ()+ liner y = columner 0+ where columner x | x >= width = liner (y + 1)+ columner x = f x y >> columner (x + 1)++packInt :: [Bool] -> Int32+packInt = foldl' bitStep 0+ where bitStep acc True = (acc `unsafeShiftL` 1) + 1+ bitStep acc False = acc `unsafeShiftL` 1++pixelClamp :: Int16 -> Word8+pixelClamp n = fromIntegral . min 255 $ max 0 n++-- | Given a size coefficient (how much a pixel span horizontally+-- and vertically), the position of the macroblock, return a list+-- of indices and value to be stored in an array (like the final+-- image)+unpackMacroBlock :: Int -- ^ Component count+ -> Int -- ^ Width coefficient+ -> Int -- ^ Height coefficient+ -> Int -- ^ x+ -> Int -- ^ y+ -> Int -- ^ Component index+ -> MutableImage s PixelYCbCr8+ -> MutableMacroBlock s Int16+ -> ST s ()+unpackMacroBlock compCount wCoeff hCoeff compIdx x y+ (MutableImage { mutableImageWidth = imgWidth,+ mutableImageHeight = imgHeight, mutableImageData = img })+ block = rasterMap dctBlockSize dctBlockSize unpacker+ where unpacker i j = do+ let yBase = y * dctBlockSize + j * hCoeff+ compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize))+ rasterMap wCoeff hCoeff $ \wDup hDup -> do+ let xBase = x * dctBlockSize + i * wCoeff+ xPos = xBase + wDup+ yPos = yBase + hDup++ when (xPos < imgWidth && yPos < imgHeight)+ (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx+ (img `M.unsafeWrite` mutableIdx) compVal)++-- | This is one of the most important function of the decoding,+-- it form the barebone decoding pipeline for macroblock. It's all+-- there is to know for macro block transformation+decodeMacroBlock :: MacroBlock DctCoefficients+ -> MutableMacroBlock s Int16+ -> MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int16)+decodeMacroBlock quantizationTable zigZagBlock block =+ deQuantize quantizationTable block >>= zigZagReorder zigZagBlock+ >>= inverseDirectCosineTransform+
src/Codec/Picture/Saving.hs view
@@ -1,187 +1,207 @@-{-# LANGUAGE TypeFamilies #-} --- | 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 - ) where - -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 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 -imageToJpg :: Int -> DynamicImage -> L.ByteString -imageToJpg quality dynImage = - let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) - 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 -> encodeAtQuality . convertImage - $ (promoteImage img :: Image PixelRGB8) - ImageYA8 img -> encodeAtQuality $ - convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8) - 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 +{-# LANGUAGE TypeFamilies #-}+-- | 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++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+imageToJpg :: Int -> DynamicImage -> L.ByteString+imageToJpg quality dynImage =+ let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)+ 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 -> encodeAtQuality . convertImage+ $ (promoteImage img :: Image PixelRGB8)+ ImageYA8 img -> encodeAtQuality $+ convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)+ 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)
src/Codec/Picture/Tga.hs view
@@ -250,7 +250,7 @@ b = U.unsafeIndex str ix g = U.unsafeIndex str (ix + 1) r = U.unsafeIndex str (ix + 2)- a = 255 - U.unsafeIndex str (ix + 3)+ a = U.unsafeIndex str (ix + 3) prepareUnpacker :: TgaFile -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx))