diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -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: <> @@ -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) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 ------------------ diff --git a/src/Codec/Picture/ColorQuant.hs b/src/Codec/Picture/ColorQuant.hs --- a/src/Codec/Picture/ColorQuant.hs +++ b/src/Codec/Picture/ColorQuant.hs @@ -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) diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -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 diff --git a/src/Codec/Picture/Jpg/Common.hs b/src/Codec/Picture/Jpg/Common.hs --- a/src/Codec/Picture/Jpg/Common.hs +++ b/src/Codec/Picture/Jpg/Common.hs @@ -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 + diff --git a/src/Codec/Picture/Saving.hs b/src/Codec/Picture/Saving.hs --- a/src/Codec/Picture/Saving.hs +++ b/src/Codec/Picture/Saving.hs @@ -1,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) diff --git a/src/Codec/Picture/Tga.hs b/src/Codec/Picture/Tga.hs --- a/src/Codec/Picture/Tga.hs +++ b/src/Codec/Picture/Tga.hs @@ -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))