diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2016, Alexey Kuleshevich +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of hip nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/hip.cabal b/hip.cabal new file mode 100644 --- /dev/null +++ b/hip.cabal @@ -0,0 +1,91 @@ +Name: hip +Version: 1.0.0.0 +License: BSD3 +License-File: LICENSE +Author: Alexey Kuleshevich +Stability: experimental +Maintainer: lehins@yandex.ru +Category: Image Processing, Graphics +Synopsis: Haskell Image Processing (HIP) Library. +Description: + . + Haskell Image Processing (HIP) Library provides an easy to use interface with a whole variaty of image manipulation capabilities. + . + Processing can be done sequentially as well as in parallel, with an inherited fusion capabily, all through and packages. It is highly extendable, with an ability to add custom color spaces or use some other underlying data structure. + . + It is capable of reading and writing a number of popular image formats by using and packages. Being a pure Haskell library it does not require any external programs, but it can display images using a program of your choice. +Homepage: https://github.com/lehins/hip +Bug-Reports: https://github.com/lehins/hip/issues +Cabal-Version: >= 1.10 +Build-Type: Simple +Extra-Doc-Files: images/*.jpg + , images/*.png + +Library + Default-Language: Haskell2010 + HS-Source-Dirs: src + Build-Depends: base >= 4.5 && < 5 + , bytestring >= 0.9.0.4 + , deepseq >= 1.1 +-- , easyplot >= 1.0 + , filepath >= 1.0 + , JuicyPixels >= 3.2.7 + , netpbm >= 1.0.1 + , primitive >= 0.4 + , process >= 1.1.0.0 + , repa >= 3.2.1.1 && < 4 + , temporary >= 1.1.1 + , vector >= 0.9 && < 0.11 + , vector-th-unbox >= 0.2.1.0 + + Other-Extensions: BangPatterns + , ConstraintKinds + , GADTs + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , MultiParamTypeClasses + , MultiWayIf + , ScopedTypeVariables + , TemplateHaskell + , TypeFamilies + , UndecidableInstances + , ViewPatterns + + Exposed-Modules: Graphics.Image + , Graphics.Image.ColorSpace + , Graphics.Image.IO + , Graphics.Image.IO.External + , Graphics.Image.Interface + , Graphics.Image.Interface.Repa + , Graphics.Image.Interface.Vector + , Graphics.Image.Processing + , Graphics.Image.Processing.Binary + , Graphics.Image.Processing.Complex + + Other-Modules: Graphics.Image.ColorSpace.Binary + , Graphics.Image.ColorSpace.CMYK + , Graphics.Image.ColorSpace.Complex + , Graphics.Image.ColorSpace.Gray + , Graphics.Image.ColorSpace.HSI + , Graphics.Image.ColorSpace.Luma + , Graphics.Image.ColorSpace.RGB + , Graphics.Image.ColorSpace.YCbCr + , Graphics.Image.IO.Base + , Graphics.Image.IO.External.JuicyPixels + , Graphics.Image.IO.External.Netpbm + , Graphics.Image.Interface.Repa.Internal + , Graphics.Image.Interface.Vector.Unboxed + , Graphics.Image.Processing.Convolution + , Graphics.Image.Processing.Complex.Fourier + , Graphics.Image.Processing.Geometric + , Graphics.Image.Processing.Interpolation + + GHC-Options: + -Wall + -Odph + -fcpr-off + +Source-Repository head + Type: git + Location: https://github.com/lehins/hip.git diff --git a/images/centaurus.jpg b/images/centaurus.jpg new file mode 100644 Binary files /dev/null and b/images/centaurus.jpg differ diff --git a/images/cluster.jpg b/images/cluster.jpg new file mode 100644 Binary files /dev/null and b/images/cluster.jpg differ diff --git a/images/figure.png b/images/figure.png new file mode 100644 Binary files /dev/null and b/images/figure.png differ diff --git a/images/figure_close.png b/images/figure_close.png new file mode 100644 Binary files /dev/null and b/images/figure_close.png differ diff --git a/images/figure_dialate.png b/images/figure_dialate.png new file mode 100644 Binary files /dev/null and b/images/figure_dialate.png differ diff --git a/images/figure_erode.png b/images/figure_erode.png new file mode 100644 Binary files /dev/null and b/images/figure_erode.png differ diff --git a/images/figure_open.png b/images/figure_open.png new file mode 100644 Binary files /dev/null and b/images/figure_open.png differ diff --git a/images/frog.jpg b/images/frog.jpg new file mode 100644 Binary files /dev/null and b/images/frog.jpg differ diff --git a/images/frog_blue.jpg b/images/frog_blue.jpg new file mode 100644 Binary files /dev/null and b/images/frog_blue.jpg differ diff --git a/images/frog_eye_grid.png b/images/frog_eye_grid.png new file mode 100644 Binary files /dev/null and b/images/frog_eye_grid.png differ diff --git a/images/frog_flipH.jpg b/images/frog_flipH.jpg new file mode 100644 Binary files /dev/null and b/images/frog_flipH.jpg differ diff --git a/images/frog_flipV.jpg b/images/frog_flipV.jpg new file mode 100644 Binary files /dev/null and b/images/frog_flipV.jpg differ diff --git a/images/frog_green.jpg b/images/frog_green.jpg new file mode 100644 Binary files /dev/null and b/images/frog_green.jpg differ diff --git a/images/frog_rbg.jpg b/images/frog_rbg.jpg new file mode 100644 Binary files /dev/null and b/images/frog_rbg.jpg differ diff --git a/images/frog_red.jpg b/images/frog_red.jpg new file mode 100644 Binary files /dev/null and b/images/frog_red.jpg differ diff --git a/images/frog_resize.jpg b/images/frog_resize.jpg new file mode 100644 Binary files /dev/null and b/images/frog_resize.jpg differ diff --git a/images/frog_rotate180.jpg b/images/frog_rotate180.jpg new file mode 100644 Binary files /dev/null and b/images/frog_rotate180.jpg differ diff --git a/images/frog_rotate270.jpg b/images/frog_rotate270.jpg new file mode 100644 Binary files /dev/null and b/images/frog_rotate270.jpg differ diff --git a/images/frog_rotate90.jpg b/images/frog_rotate90.jpg new file mode 100644 Binary files /dev/null and b/images/frog_rotate90.jpg differ diff --git a/images/grad_color.png b/images/grad_color.png new file mode 100644 Binary files /dev/null and b/images/grad_color.png differ diff --git a/images/grad_fromLists.png b/images/grad_fromLists.png new file mode 100644 Binary files /dev/null and b/images/grad_fromLists.png differ diff --git a/images/grad_fromVector.png b/images/grad_fromVector.png new file mode 100644 Binary files /dev/null and b/images/grad_fromVector.png differ diff --git a/images/grad_gray.png b/images/grad_gray.png new file mode 100644 Binary files /dev/null and b/images/grad_gray.png differ diff --git a/images/struct.png b/images/struct.png new file mode 100644 Binary files /dev/null and b/images/struct.png differ diff --git a/images/yield.jpg b/images/yield.jpg new file mode 100644 Binary files /dev/null and b/images/yield.jpg differ diff --git a/images/yield_bin.png b/images/yield_bin.png new file mode 100644 Binary files /dev/null and b/images/yield_bin.png differ diff --git a/src/Graphics/Image.hs b/src/Graphics/Image.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE BangPatterns, FlexibleContexts #-} +-- | +-- Module : Graphics.Image.Unboxed +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : MIT +-- +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +-- Haskell Image Processing (HIP) library is a wrapper around any array like +-- data structure and is fully agnostic to the underlying representation. All of +-- the functionality in this library relies on few type classes that those +-- representations implement: +-- +-- * @__`Array` arr cs e__@ - this is a base class for every __@`Image`@ @arr@ @cs@ @e@__, +-- where @__arr__@ stands for an underlying array representation, @__cs__@ is the +-- `ColorSpace` of an image and @__e__@ is the type denoting precision of an +-- image. +-- +-- * @__`ManifestArray` arr cs e__@ - is a kind of array that is represented by an +-- actual data in memory. +-- +-- * @__`SequentialArray` arr cs e__@ - contains functionality that can only be +-- computed sequentially. +-- +-- * @__`MutableArray` arr cs e__@ - allows mutation on __@`MImage`@ @st@ @arr@ @cs@ @e@__, +-- which is `Image`'s mutable cousin. +-- +-- Array representation type and the above classes it is installed in determine +-- operations that can be done on the image with that representation. +-- +-- Representations using and +-- packages: +-- +-- * `VU` - Unboxed Vector representation. (Default) +-- * `RD` - Delayed Repa array representation. +-- * `RS` - Unboxed Repa array representation (computation is done sequentially). +-- * `RP` - Unboxed Repa array representation (computation is done in parallel). +-- +-- Images with `RD` type hold functions rather then actual data, so this +-- representation should be used for fusing computation together, and later +-- changed to `RS` or `RP` using `exchange`, which in turn performs the fused +-- computation. +-- +module Graphics.Image ( + -- * Color Space + -- $colorspace + module Graphics.Image.ColorSpace, + + -- * Creation + -- + -- If it is necessary to create an image in an other representation + -- or with some specific 'Pixel' precision, you can use 'makeImage' from + -- "Graphics.Image.Interface" module and manually specifying function's output + -- type, ex: + -- + -- @ makeImage (256, 256) (PixelY . fromIntegral . fst) :: Image RP Y Word8 @ + -- + makeImage, fromLists, + -- * IO + -- ** Reading + -- | Read any supported image file into an 'Image' with 'VU' (Vector Unboxed) + -- representation and pixels with 'Double' precision. In order to read an + -- image with different representation, color space and precision 'readImage' + -- or 'readImageExact' from can be + -- used. + readImageY, readImageYA, readImageRGB, readImageRGBA, readImageExact, + -- ** Writing + writeImage, writeImageExact, displayImage, + -- * Accessors + -- ** Dimensions + rows, cols, dims, + -- ** Indexing + index, defaultIndex, maybeIndex, + -- * Transformation + -- ** Pointwise + map, imap, zipWith, izipWith, + -- ** Geometric + traverse, traverse2, + transpose, backpermute, + (|*|), + -- * Reduction + fold, sum, product, maximum, minimum, normalize, + -- * Representations + exchange, + VU(..), RD(..), RS(..), RP(..), + ) where +import Prelude hiding (map, zipWith, sum, product, maximum, minimum) +import qualified Data.Foldable as F +import Graphics.Image.ColorSpace +import Graphics.Image.IO +import Graphics.Image.Interface +import Graphics.Image.Interface.Vector +import Graphics.Image.Interface.Repa (RD(..), RS(..), RP(..)) + +--import Graphics.Image.Processing +--import Graphics.Image.Processing.Complex +--import Graphics.Image.Processing.Binary + + + +-------------------------------------------------------------------------------- +---- Creation and Transformation ----------------------------------------------- +-------------------------------------------------------------------------------- + + + +-- | Get the number of rows in an image. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog +-- +-- >>> rows frog +-- 200 +-- +rows :: Array arr cs e => Image arr cs e -> Int +rows = fst . dims +{-# INLINE rows #-} + + +-- | Get the number of columns in an image. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog +-- +-- >>> cols frog +-- 320 +-- +cols :: Array arr cs e => Image arr cs e -> Int +cols = snd . dims +{-# INLINE cols #-} + + +-- | Sum all pixels in the image. +sum :: ManifestArray arr cs e => Image arr cs e -> Pixel cs e +sum = fold (+) 0 +{-# INLINE sum #-} + + +-- | Multiply all pixels in the image. +product :: ManifestArray arr cs e => Image arr cs e -> Pixel cs e +product = fold (+) 1 +{-# INLINE product #-} + + +-- | Retrieve the biggest pixel from an image +maximum :: (ManifestArray arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e +maximum !img = fold max (index img (0, 0)) img +{-# INLINE maximum #-} + + +-- | Retrieve the smallest pixel from an image +minimum :: (ManifestArray arr cs e, Ord (Pixel cs e)) => Image arr cs e -> Pixel cs e +minimum !img = fold min (index img (0, 0)) img +{-# INLINE minimum #-} + + +-- | Scales all of the pixels to be in the range @[0, 1]@. +normalize :: (ManifestArray arr cs e, ManifestArray arr Gray e, Fractional e, Ord e) => + Image arr cs e -> Image arr cs e +normalize !img = if l == s + then (if s < 0 then (*0) else if s > 1 then (*1) else id) img + else map normalizer img + where + !(PixelGray l, PixelGray s) = (maximum $ map (PixelGray . F.maximum) img, + minimum $ map (PixelGray . F.minimum) img) + normalizer !px = (px - pure s) / (pure (l - s)) + {-# INLINE normalizer #-} +{-# INLINE normalize #-} + + +-- $colorspace +-- Here is a list of default Pixels with their respective constructors: +-- +-- @ +-- * __'Pixel' 'Y' e = PixelY e__ - Luma, also commonly denoted as __Y'__. +-- * __'Pixel' 'YA' e = PixelYA e__ - Luma with alpha. +-- * __'Pixel' 'RGB' e = PixelRGB e__ - Red, Green and Blue. +-- * __'Pixel' 'RGBA' e = PixelRGBA e__ - RGB with alpha +-- * __'Pixel' 'HSI' e = PixelHSI e__ - Hue, Saturation and Intensity. +-- * __'Pixel' 'HSIA' e = PixelHSIA e__ - HSI with alpha +-- * __'Pixel' 'CMYK' e = PixelCMYK e__ - Cyan, Magenta, Yellow and Key (Black). +-- * __'Pixel' 'CMYKA' e = PixelCMYKA e__ - CMYK with alpha. +-- * __'Pixel' 'YCbCr' e = PixelYCbCr e__ - Luma, blue-difference and red-difference chromas. +-- * __'Pixel' 'YCbCrA' e = PixelYCbCrA e__ - YCbCr with alpha. +-- ------------------------------------------------------------------------------------------ +-- * __'Pixel' 'Binary' 'Bit' = 'on' | 'off'__ - Bi-tonal. +-- * __'Pixel' 'Gray' e = PixelGray e__ - Used for separating channels from other color spaces. +-- * __'Pixel' cs ('Complex' e) = ('Pixel' cs e) '+:' ('Pixel' cs e)__ - Complex pixels with any color space. +-- @ +-- +-- Every 'Pixel' is an instance of 'Functor', 'Applicative', 'F.Foldable' and +-- 'Num', as well as 'Floating' and 'Fractional' if __e__ is also an instance. +-- +-- All of the functionality related to every 'ColorSpace' is re-exported from here +-- for convenience. diff --git a/src/Graphics/Image/ColorSpace.hs b/src/Graphics/Image/ColorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace.hs @@ -0,0 +1,411 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, MultiWayIf, ViewPatterns #-} +module Graphics.Image.ColorSpace ( + -- * ColorSpace + ColorSpace(..), Alpha(..), + -- * Luma + module Graphics.Image.ColorSpace.Luma, + -- * RGB + module Graphics.Image.ColorSpace.RGB, + -- * HSI + module Graphics.Image.ColorSpace.HSI, + -- * CMYK + module Graphics.Image.ColorSpace.CMYK, + -- * YCbCr + module Graphics.Image.ColorSpace.YCbCr, + -- * Gray + module Graphics.Image.ColorSpace.Gray, + -- * Binary + Binary, Bit, on, off, isOn, isOff, fromBool, complement, + toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary, + -- * Complex + module Graphics.Image.ColorSpace.Complex, + -- * Re-exports + Applicative(..), (<$>), (<$), (<**>), liftA, liftA2, liftA3, + Word8, Word16, Word32, Word64 + ) where + + + +import Control.Applicative +import Data.Word +import GHC.Float +import Graphics.Image.Interface hiding (map) +import Graphics.Image.ColorSpace.Binary +import Graphics.Image.ColorSpace.Gray +import Graphics.Image.ColorSpace.Luma +import Graphics.Image.ColorSpace.RGB +import Graphics.Image.ColorSpace.HSI +import Graphics.Image.ColorSpace.CMYK +import Graphics.Image.ColorSpace.YCbCr +import Graphics.Image.ColorSpace.Complex +import qualified Graphics.Image.Interface as I (map) + + + + +-- Binary: + + +toPixelBinary :: (ColorSpace cs, Eq (Pixel cs e), Num e) => Pixel cs e -> Pixel Binary Bit +toPixelBinary px = if px == 0 then on else off +{-# INLINE toPixelBinary #-} + + +fromPixelBinary :: Pixel Binary Bit -> Pixel Y Word8 +fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound +{-# INLINE fromPixelBinary #-} + + +toImageBinary :: (Array arr cs e, Array arr Binary Bit, Eq (Pixel cs e)) => + Image arr cs e + -> Image arr Binary Bit +toImageBinary = I.map toPixelBinary +{-# INLINE toImageBinary #-} + + +fromImageBinary :: (Array arr Binary Bit, Array arr Y Word8) => + Image arr Binary Bit + -> Image arr Y Word8 +fromImageBinary = I.map fromPixelBinary +{-# INLINE fromImageBinary #-} + + +-- Conversion: + + +instance ToY Gray where + toPixelY (PixelGray y) = PixelY y + {-# INLINE toPixelY #-} + +-- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @ +instance ToY RGB where + toPixelY (PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b) + {-# INLINE toPixelY #-} + +instance ToYA RGBA where + +instance ToY HSI where + toPixelY = toPixelY . toPixelRGB + {-# INLINE toPixelY #-} + +instance ToYA HSIA where + +instance ToY CMYK where + toPixelY = toPixelY . toPixelRGB + {-# INLINE toPixelY #-} + + +instance ToY YCbCr where + toPixelY (PixelYCbCr y _ _) = PixelY y + {-# INLINE toPixelY #-} + +instance ToYA YCbCrA where + +instance ToRGB Y where + toPixelRGB (PixelY g) = fromChannel g + {-# INLINE toPixelRGB #-} + +instance ToRGBA YA where + +instance ToRGB HSI where + toPixelRGB (PixelHSI h s i) = + let !is = i*s + !second = i - is + getFirst !a !b = i + is*cos a/cos b + {-# INLINE getFirst #-} + getThird !v1 !v2 = i + 2*is + v1 - v2 + {-# INLINE getThird #-} + in if | h < 2*pi/3 -> let !r = getFirst h (pi/3 - h) + !b = second + !g = getThird b r + in PixelRGB r g b + | h < 4*pi/3 -> let !g = getFirst (h - 2*pi/3) (h + pi) + !r = second + !b = getThird r g + in PixelRGB r g b + | h < 2*pi -> let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h) + !g = second + !r = getThird g b + in PixelRGB r g b + | otherwise -> error ("HSI pixel is not properly scaled, Hue: "++show h) + {-# INLINE toPixelRGB #-} + +instance ToRGBA HSIA where + + +instance ToRGB YCbCr where + + toPixelRGB (PixelYCbCr y cb cr) = PixelRGB r g b where + !r = y + 1.402*(cr - 0.5) + !g = y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5) + !b = y + 1.772*(cb - 0.5) + {-# INLINE toPixelRGB #-} + +instance ToRGBA YCbCrA where + +instance ToRGB CMYK where + + toPixelRGB (PixelCMYK c m y k) = PixelRGB r g b where + !r = (1-c)*(1-k) + !g = (1-m)*(1-k) + !b = (1-y)*(1-k) + {-# INLINE toPixelRGB #-} + +instance ToRGBA CMYKA where + + +instance ToHSI Y where + toPixelHSI (PixelY g) = PixelHSI 0 0 g + {-# INLINE toPixelHSI #-} + +instance ToHSIA YA where + +instance ToHSI RGB where + toPixelHSI (PixelRGB r g b) = PixelHSI h s i where + !h' = atan2 y x + !h = if h' < 0 then h' + 2*pi else h' + !s = if i == 0 then 0 else 1 - minimum [r, g, b] / i + !i = (r + g + b) / 3 + !x = (2*r - g - b) / 2.449489742783178 + !y = (g - b) / 1.4142135623730951 + {-# INLINE toPixelHSI #-} + +instance ToHSIA RGBA where + + +instance ToYCbCr RGB where + + toPixelYCbCr (PixelRGB r g b) = PixelYCbCr y cb cr where + !y = 0.299*r + 0.587*g + 0.114*b + !cb = 0.5 - 0.168736*r - 0.331264*g + 0.5*b + !cr = 0.5 + 0.5*r - 0.418688*g - 0.081312*b + {-# INLINE toPixelYCbCr #-} + +instance ToYCbCrA RGBA where + + +instance ToCMYK RGB where + + toPixelCMYK (PixelRGB r g b) = PixelCMYK c m y k where + !c = (1 - r - k)/(1 - k) + !m = (1 - g - k)/(1 - k) + !y = (1 - b - k)/(1 - k) + !k = 1 - max r (max g b) + +instance ToCMYKA RGBA where + + +-- | Values are scaled to @[0, 255]@ range. +instance Elevator Word8 where + + toWord8 = id + {-# INLINE toWord8 #-} + + toWord16 = liftA toWord16' where + toWord16' !e = fromIntegral e * ((maxBound :: Word16) `div` fromIntegral (maxBound :: Word8)) + {-# INLINE toWord16' #-} + {-# INLINE toWord16 #-} + + toWord32 = liftA toWord32' where + toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word8)) + {-# INLINE toWord32' #-} + {-# INLINE toWord32 #-} + + toWord64 = liftA toWord64' where + toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word8)) + {-# INLINE toWord64' #-} + {-# INLINE toWord64 #-} + + toFloat = liftA toFloat' where + toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word8)) + {-# INLINE toFloat' #-} + {-# INLINE toFloat #-} + + toDouble = liftA toDouble' where + toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word8)) + {-# INLINE toDouble' #-} + {-# INLINE toDouble #-} + + fromDouble = toWord8 + {-# INLINE fromDouble #-} + + +-- | Values are scaled to @[0, 65535]@ range. +instance Elevator Word16 where + + toWord8 = liftA toWord8' where + toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word16) `div` + fromIntegral (maxBound :: Word8)) + {-# INLINE toWord8' #-} + {-# INLINE toWord8 #-} + + toWord16 = id + {-# INLINE toWord16 #-} + + toWord32 = liftA toWord32' where + toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word16)) + {-# INLINE toWord32' #-} + {-# INLINE toWord32 #-} + + toWord64 = liftA toWord64' where + toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word16)) + {-# INLINE toWord64' #-} + {-# INLINE toWord64 #-} + + toFloat = liftA toFloat' where + toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word16)) + {-# INLINE toFloat' #-} + {-# INLINE toFloat #-} + + toDouble = liftA toDouble' where + toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word16)) + {-# INLINE toDouble' #-} + {-# INLINE toDouble #-} + + fromDouble = toWord16 + {-# INLINE fromDouble #-} + + +-- | Values are scaled to @[0, 4294967295]@ range. +instance Elevator Word32 where + + toWord8 = liftA toWord8' where + toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div` + fromIntegral (maxBound :: Word8)) + {-# INLINE toWord8' #-} + {-# INLINE toWord8 #-} + + toWord16 = liftA toWord16' where + toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div` + fromIntegral (maxBound :: Word16)) + {-# INLINE toWord16' #-} + {-# INLINE toWord16 #-} + + toWord32 = id + {-# INLINE toWord32 #-} + + toWord64 = liftA toWord64' where + toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word32)) + {-# INLINE toWord64' #-} + {-# INLINE toWord64 #-} + + toFloat = liftA toFloat' where + toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word32)) + {-# INLINE toFloat' #-} + {-# INLINE toFloat #-} + + toDouble = liftA toDouble' where + toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word32)) + {-# INLINE toDouble' #-} + {-# INLINE toDouble #-} + + fromDouble = toWord32 + {-# INLINE fromDouble #-} + + +-- | Values are scaled to @[0, 18446744073709551615]@ range. +instance Elevator Word64 where + + toWord8 = liftA toWord8' where + toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div` + fromIntegral (maxBound :: Word8)) + {-# INLINE toWord8' #-} + {-# INLINE toWord8 #-} + + toWord16 = liftA toWord16' where + toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div` + fromIntegral (maxBound :: Word16)) + {-# INLINE toWord16' #-} + {-# INLINE toWord16 #-} + + toWord32 = liftA toWord32' where + toWord32' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div` + fromIntegral (maxBound :: Word32)) + {-# INLINE toWord32' #-} + {-# INLINE toWord32 #-} + + toWord64 = id + {-# INLINE toWord64 #-} + + toFloat = liftA toFloat' where + toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word64)) + {-# INLINE toFloat' #-} + {-# INLINE toFloat #-} + + toDouble = liftA toDouble' where + toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word64)) + {-# INLINE toDouble' #-} + {-# INLINE toDouble #-} + + fromDouble = toWord64 + {-# INLINE fromDouble #-} + + +-- | Values are scaled to @[0.0, 1.0]@ range. +instance Elevator Float where + + toWord8 = liftA toWord8' where + toWord8' !e = round (fromIntegral (maxBound :: Word8) * e) + {-# INLINE toWord8' #-} + {-# INLINE toWord8 #-} + + toWord16 = liftA toWord16' where + toWord16' !e = round (fromIntegral (maxBound :: Word16) * e) + {-# INLINE toWord16' #-} + {-# INLINE toWord16 #-} + + toWord32 = liftA toWord32' where + toWord32' !e = round (fromIntegral (maxBound :: Word32) * e) + {-# INLINE toWord32' #-} + {-# INLINE toWord32 #-} + + toWord64 = liftA toWord64' where + toWord64' !e = round (fromIntegral (maxBound :: Word64) * e) + {-# INLINE toWord64' #-} + {-# INLINE toWord64 #-} + + toFloat = id + {-# INLINE toFloat #-} + + toDouble = liftA float2Double + {-# INLINE toDouble #-} + + fromDouble = toFloat + {-# INLINE fromDouble #-} + + +-- | Values are scaled to @[0.0, 1.0]@ range. +instance Elevator Double where + + toWord8 = liftA toWord8' where + toWord8' !e = round (fromIntegral (maxBound :: Word8) * e) + {-# INLINE toWord8' #-} + {-# INLINE toWord8 #-} + + toWord16 = liftA toWord16' where + toWord16' !e = round (fromIntegral (maxBound :: Word16) * e) + {-# INLINE toWord16' #-} + {-# INLINE toWord16 #-} + + toWord32 = liftA toWord32' where + toWord32' !e = round (fromIntegral (maxBound :: Word32) * e) + {-# INLINE toWord32' #-} + {-# INLINE toWord32 #-} + + toWord64 = liftA toWord64' where + toWord64' !e = round (fromIntegral (maxBound :: Word64) * e) + {-# INLINE toWord64' #-} + {-# INLINE toWord64 #-} + + toFloat = liftA double2Float + {-# INLINE toFloat #-} + + toDouble = id + {-# INLINE toDouble #-} + + fromDouble = id + {-# INLINE fromDouble #-} + + diff --git a/src/Graphics/Image/ColorSpace/Binary.hs b/src/Graphics/Image/ColorSpace/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/Binary.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + TypeFamilies #-} +module Graphics.Image.ColorSpace.Binary ( + Binary(..), Bit(..), on, off, isOn, isOff, fromBool, complement + ) where + +import Prelude hiding (map) +import Data.Word (Word8) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend, mempty) + +-- | This is a Binary colorspace, pixel's of which can be created using +-- these __/constructors/__: +-- +-- [@'on'@] Represents value @1@ or 'True'. It's a foreground pixel and is +-- displayed in black. +-- +-- [@'off'@] Represents value @0@ or 'False'. It's a background pixel and is +-- displayed in white. +-- +-- Note, that values are inverted before writing to or reading from file, since +-- grayscale images represent black as a @0@ value and white as @1@ on a +-- @[0,1]@ scale. +-- +-- Binary pixels also behave as binary numbers with a size of 1-bit, for instance: +-- +-- >>> on + on -- equivalent to: 1 .|. 1 +-- +-- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0 +-- +-- >>> (on + on) - on +-- +-- +data Binary = Binary deriving (Eq, Enum, Show, Typeable) + + +-- | Under the hood, Binary pixels are represented as 'Word8' that can only take +-- values of @0@ or @1@. +newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable) + + +-- | Represents value 'True' or @1@ in binary. Often also called a foreground +-- pixel of an object. +on :: Pixel Binary Bit +on = PixelBinary (Bit 1) +{-# INLINE on #-} + + +-- | Represents value 'False' or @0@ in binary. Often also called a background +-- pixel. +off :: Pixel Binary Bit +off = PixelBinary (Bit 0) +{-# INLINE off #-} + + +-- | Convert a 'Bool' to a 'PixelBin' pixel. +-- +-- >>> isOn (fromBool True) +-- True +-- +fromBool :: Bool -> Pixel Binary Bit +fromBool False = off +fromBool True = on +{-# INLINE fromBool #-} + + +-- | Test if Pixel's value is 'on'. +isOn :: Pixel Binary Bit -> Bool +isOn (PixelBinary (Bit 0)) = False +isOn _ = True +{-# INLINE isOn #-} + + +-- | Test if Pixel's value is 'off'. +isOff :: Pixel Binary Bit -> Bool +isOff = not . isOn +{-# INLINE isOff #-} + + +-- | Invert value of a pixel. Equivalent of 'not' for Bool's. +complement :: Pixel Binary Bit -> Pixel Binary Bit +complement = fromBool . isOff +{-# INLINE complement #-} + + + +instance ColorSpace Binary where + type PixelElt Binary e = e + data Pixel Binary e = PixelBinary !e deriving Eq + + fromChannel = PixelBinary + {-# INLINE fromChannel #-} + + fromElt = PixelBinary + {-# INLINE fromElt #-} + + toElt (PixelBinary b) = b + {-# INLINE toElt #-} + + getPxCh (PixelBinary b) _ = b + {-# INLINE getPxCh #-} + + chOp !f (PixelBinary b) = PixelBinary (f Binary b) + {-# INLINE chOp #-} + + pxOp !f (PixelBinary b) = PixelBinary (f b) + {-# INLINE pxOp #-} + + chApp (PixelBinary f) (PixelBinary b) = PixelBinary (f b) + {-# INLINE chApp #-} + + pxFoldMap f (PixelBinary b) = f b `mappend` mempty + {-# INLINE pxFoldMap #-} + + +instance Show (Pixel Binary Bit) where + show (PixelBinary (Bit 0)) = "" + show _ = "" + + +instance Num Bit where + (Bit 0) + (Bit 0) = Bit 0 + _ + _ = Bit 1 + {-# INLINE (+) #-} + + _ - (Bit 1) = Bit 0 + _ - _ = Bit 1 + {-# INLINE (-) #-} + + _ * (Bit 0) = Bit 0 + (Bit 0) * _ = Bit 0 + _ * _ = Bit 1 + {-# INLINE (*) #-} + + abs = id + {-# INLINE abs #-} + + signum = id + {-# INLINE signum #-} + + fromInteger 0 = Bit 0 + fromInteger _ = Bit 1 + {-# INLINE fromInteger #-} diff --git a/src/Graphics/Image/ColorSpace/CMYK.hs b/src/Graphics/Image/ColorSpace/CMYK.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/CMYK.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + TypeFamilies #-} +module Graphics.Image.ColorSpace.CMYK ( + CMYK(..), CMYKA(..), Pixel(..), + ToCMYK(..), ToCMYKA(..) + ) where + +import Prelude hiding (map) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend) + +data CMYK = CyanCMYK -- ^ Cyan + | MagCMYK -- ^ Mahenta + | YelCMYK -- ^ Yellow + | KeyCMYK -- ^ Key (Black) + deriving (Eq, Enum, Typeable) + +data CMYKA = CyanCMYKA -- ^ Cyan + | MagCMYKA -- ^ Mahenta + | YelCMYKA -- ^ Yellow + | KeyCMYKA -- ^ Key (Black) + | AlphaCMYKA -- ^ Alpha + deriving (Eq, Enum, Typeable) + + +class ColorSpace cs => ToCMYK cs where + + toPixelCMYK :: Pixel cs Double -> Pixel CMYK Double + + toImageCMYK :: (Array arr cs Double, Array arr CMYK Double) => + Image arr cs Double + -> Image arr CMYK Double + toImageCMYK = map toPixelCMYK + {-# INLINE toImageCMYK #-} + + +class (ToCMYK (Opaque cs), Alpha cs) => ToCMYKA cs where + + toPixelCMYKA :: Pixel cs Double -> Pixel CMYKA Double + toPixelCMYKA px = addAlpha (getAlpha px) (toPixelCMYK (dropAlpha px)) + + toImageCMYKA :: (Array arr cs Double, Array arr CMYKA Double) => + Image arr cs Double + -> Image arr CMYKA Double + toImageCMYKA = map toPixelCMYKA + {-# INLINE toImageCMYKA #-} + + +instance ColorSpace CMYK where + type PixelElt CMYK e = (e, e, e, e) + data Pixel CMYK e = PixelCMYK !e !e !e !e deriving Eq + + fromChannel !e = PixelCMYK e e e e + {-# INLINE fromChannel #-} + + fromElt !(c, m, y, k) = PixelCMYK c m y k + {-# INLINE fromElt #-} + + toElt (PixelCMYK c m y k) = (c, m, y, k) + {-# INLINE toElt #-} + + getPxCh (PixelCMYK c _ _ _) CyanCMYK = c + getPxCh (PixelCMYK _ m _ _) MagCMYK = m + getPxCh (PixelCMYK _ _ y _) YelCMYK = y + getPxCh (PixelCMYK _ _ _ k) KeyCMYK = k + {-# INLINE getPxCh #-} + + chOp !f (PixelCMYK c m y k) = + PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k) + {-# INLINE chOp #-} + + pxOp !f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k) + {-# INLINE pxOp #-} + + chApp (PixelCMYK fc fm fy fk) (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k) + {-# INLINE chApp #-} + + pxFoldMap f (PixelCMYK c m y k) = f c `mappend` f m `mappend` f y `mappend` f k + {-# INLINE pxFoldMap #-} + + + +instance ColorSpace CMYKA where + type PixelElt CMYKA e = (e, e, e, e, e) + data Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq + + fromChannel !e = PixelCMYKA e e e e e + {-# INLINE fromChannel #-} + + fromElt (c, m, y, k, a) = PixelCMYKA c m y k a + {-# INLINE fromElt #-} + + toElt (PixelCMYKA c m y k a) = (c, m, y, k, a) + {-# INLINE toElt #-} + + getPxCh (PixelCMYKA c _ _ _ _) CyanCMYKA = c + getPxCh (PixelCMYKA _ m _ _ _) MagCMYKA = m + getPxCh (PixelCMYKA _ _ y _ _) YelCMYKA = y + getPxCh (PixelCMYKA _ _ _ k _) KeyCMYKA = k + getPxCh (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a + {-# INLINE getPxCh #-} + + chOp !f (PixelCMYKA c m y k a) = + PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a) + {-# INLINE chOp #-} + + pxOp !f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a) + {-# INLINE pxOp #-} + + chApp (PixelCMYKA fc fm fy fk fa) (PixelCMYKA c m y k a) = + PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a) + {-# INLINE chApp #-} + + pxFoldMap f (PixelCMYKA c m y k a) = f c `mappend` f m `mappend` f y `mappend` f k `mappend` f a + {-# INLINE pxFoldMap #-} + + +instance Alpha CMYKA where + type Opaque CMYKA = CMYK + + getAlpha (PixelCMYKA _ _ _ _ a) = a + {-# INLINE getAlpha #-} + + addAlpha !a (PixelCMYK c m y k) = PixelCMYKA c m y k a + {-# INLINE addAlpha #-} + + dropAlpha (PixelCMYKA c m y k _) = PixelCMYK c m y k + {-# INLINE dropAlpha #-} + + +instance Show CMYK where + show CyanCMYK = "Cyan" + show MagCMYK = "Magenta" + show YelCMYK = "Yellow" + show KeyCMYK = "Black" + +instance Show CMYKA where + show CyanCMYKA = "Cyan" + show MagCMYKA = "Magenta" + show YelCMYKA = "Yellow" + show KeyCMYKA = "Black" + show AlphaCMYKA = "Alpha" + +instance Show e => Show (Pixel CMYK e) where + show (PixelCMYK c m y k) = "" + + +instance Show e => Show (Pixel CMYKA e) where + show (PixelCMYKA c m y k a) = + "" + + + diff --git a/src/Graphics/Image/ColorSpace/Complex.hs b/src/Graphics/Image/ColorSpace/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/Complex.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE BangPatterns #-} +module Graphics.Image.ColorSpace.Complex ( + -- ** Rectangular form + Complex(..), (+:), realPart, imagPart, + -- ** Polar form + mkPolar, cis, polar, magnitude, phase, + -- ** Conjugate + conjugate + ) where + +import Graphics.Image.Interface (ColorSpace(..)) +import Control.Applicative +import Data.Complex (Complex(..)) +import qualified Data.Complex as C hiding (Complex(..)) + + + +infix 6 +: + +-- | Constrcut a complex pixel from two pixels containing real and imaginary parts. +-- +-- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @ +-- +(+:) :: ColorSpace cs => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) +(+:) = liftA2 (:+) +{-# INLINE (+:) #-} + +-- | Extracts the real part of a complex pixel. +realPart :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +realPart = liftA C.realPart +{-# INLINE realPart #-} + +-- | Extracts the imaginary part of a complex pixel. +imagPart :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +imagPart = liftA C.imagPart +{-# INLINE imagPart #-} + +-- | Form a complex pixel from polar components of magnitude and phase. +mkPolar :: (ColorSpace cs, RealFloat e) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) +mkPolar = liftA2 C.mkPolar +{-# INLINE mkPolar #-} + +-- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@). +cis :: (ColorSpace cs, RealFloat e) => Pixel cs e -> Pixel cs (Complex e) +cis = liftA C.cis +{-# INLINE cis #-} + +-- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase) +-- pair of pixels in canonical form: the magnitude is nonnegative, and the phase +-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase. +polar :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e) +polar !zPx = (magnitude zPx, phase zPx) +{-# INLINE polar #-} + +-- | The nonnegative magnitude of a complex pixel. +magnitude :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +magnitude = liftA C.magnitude +{-# INLINE magnitude #-} + +-- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the +-- magnitude is zero, then so is the phase. +phase :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +phase = liftA C.phase +{-# INLINE phase #-} + +-- | The conjugate of a complex pixel. +conjugate :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e) +conjugate = liftA C.conjugate +{-# INLINE conjugate #-} + + diff --git a/src/Graphics/Image/ColorSpace/Gray.hs b/src/Graphics/Image/ColorSpace/Gray.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/Gray.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + ScopedTypeVariables, TypeFamilies #-} +module Graphics.Image.ColorSpace.Gray ( + Gray(..), Pixel(..), toGrayImages, fromGrayImages + ) where + +import Prelude hiding (map, zipWith) +import qualified Prelude as P (map) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend, mempty) + +-- ^ This is a signgle channel colorspace, that is designed to hold any channel +-- from any other colorspace, hence it is not convertible to and from, but +-- rather is here to allow separation of channels from other multichannel +-- colorspaces. If you are looking for a true grayscale colorspace +-- 'Graphics.Image.ColorSpace.Luma.Y' should be used instead. +data Gray = Gray deriving (Eq, Enum, Show, Typeable) + + +-- | Separate an image into a list of images with 'Gray' pixels containing every +-- channel from the source image. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> let [frog_red, frog_green, frog_blue] = toGrayImages frog +-- >>> writeImage "images/frog_red.png" $ toImageY frog_red +-- >>> writeImage "images/frog_green.jpg" $ toImageY frog_green +-- >>> writeImage "images/frog_blue.jpg" $ toImageY frog_blue +-- +-- <> <> <> +-- +toGrayImages :: (Array arr cs e, Array arr Gray e) => Image arr cs e -> [Image arr Gray e] +toGrayImages !img = P.map getCh (enumFrom (toEnum 0)) where + getCh !ch = map (PixelGray . (`getPxCh` ch)) img + {-# INLINE getCh #-} +{-# INLINE toGrayImages #-} + + +-- | Combine a list of images with 'Gray' pixels into an image of any color +-- space, by supplying an order of color space channels. +-- +-- For example here is a frog with swapped 'BlueRGB' and 'GreenRGB' channels. +-- +-- >>> writeImage "images/frog_rbg.jpg" $ fromGrayImages [frog_red, frog_green, frog_blue] [RedRGB, BlueRGB, GreenRGB] +-- +-- <> <> +-- +-- It is worth noting though, that separating image channels can be sometimes +-- pretty useful, the same effect as above can be achieved in a much simpler and +-- more efficient way: +-- +-- @ map (\(PixelRGB r g b) -> PixelRGB r b g) frog @ +-- +fromGrayImages :: forall arr cs e . (Array arr Gray e, Array arr cs e) => + [Image arr Gray e] -> [cs] -> Image arr cs e +fromGrayImages imgs chs = + fromGrays (singleton (fromChannel 0)) imgs chs where + updateCh ch px (PixelGray e) = chOp (\ !ch' !e' -> if ch' == ch then e else e') px + {-# INLINE updateCh #-} + fromGrays img [] _ = img + fromGrays img _ [] = img + fromGrays img (i:is) (c:cs) = fromGrays (zipWith (updateCh c) img i) is cs + {-# INLINE fromGrays #-} +{-# INLINE fromGrayImages #-} + + +instance ColorSpace Gray where + type PixelElt Gray e = e + data Pixel Gray e = PixelGray !e deriving (Ord, Eq) + + fromChannel = PixelGray + {-# INLINE fromChannel #-} + + fromElt = PixelGray + {-# INLINE fromElt #-} + + toElt (PixelGray g) = g + {-# INLINE toElt #-} + + getPxCh (PixelGray g) _ = g + {-# INLINE getPxCh #-} + + chOp !f (PixelGray g) = PixelGray (f Gray g) + {-# INLINE chOp #-} + + pxOp !f (PixelGray g) = PixelGray (f g) + {-# INLINE pxOp #-} + + chApp (PixelGray f) (PixelGray g) = PixelGray (f g) + {-# INLINE chApp #-} + + pxFoldMap f (PixelGray g) = f g `mappend` mempty + {-# INLINE pxFoldMap #-} + + +instance Show e => Show (Pixel Gray e) where + show (PixelGray g) = "" + + diff --git a/src/Graphics/Image/ColorSpace/HSI.hs b/src/Graphics/Image/ColorSpace/HSI.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/HSI.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + TypeFamilies #-} +module Graphics.Image.ColorSpace.HSI ( + HSI(..), HSIA(..), Pixel(..), + ToHSI(..), ToHSIA(..) + ) where + +import Prelude hiding (map) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend) + +data HSI = HueHSI + | SatHSI + | IntHSI deriving (Eq, Enum, Typeable) + +data HSIA = HueHSIA + | SatHSIA + | IntHSIA + | AlphaHSIA deriving (Eq, Enum, Typeable) + + +class ColorSpace cs => ToHSI cs where + + toPixelHSI :: Pixel cs Double -> Pixel HSI Double + + toImageHSI :: (Array arr cs Double, Array arr HSI Double) => + Image arr cs Double + -> Image arr HSI Double + toImageHSI = map toPixelHSI + {-# INLINE toImageHSI #-} + + +class (ToHSI (Opaque cs), Alpha cs) => ToHSIA cs where + + toPixelHSIA :: Pixel cs Double -> Pixel HSIA Double + toPixelHSIA px = addAlpha (getAlpha px) (toPixelHSI (dropAlpha px)) + + toImageHSIA :: (Array arr cs Double, Array arr HSIA Double) => + Image arr cs Double + -> Image arr HSIA Double + toImageHSIA = map toPixelHSIA + {-# INLINE toImageHSIA #-} + + +instance ColorSpace HSI where + type PixelElt HSI e = (e, e, e) + data Pixel HSI e = PixelHSI !e !e !e deriving Eq + + fromChannel !e = PixelHSI e e e + {-# INLINE fromChannel #-} + + fromElt !(h, s, i) = PixelHSI h s i + {-# INLINE fromElt #-} + + toElt (PixelHSI h s i) = (h, s, i) + {-# INLINE toElt #-} + + getPxCh (PixelHSI h _ _) HueHSI = h + getPxCh (PixelHSI _ s _) SatHSI = s + getPxCh (PixelHSI _ _ i) IntHSI = i + {-# INLINE getPxCh #-} + + chOp !f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i) + {-# INLINE chOp #-} + + pxOp !f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i) + {-# INLINE pxOp #-} + + chApp (PixelHSI fh fs fi) (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i) + {-# INLINE chApp #-} + + pxFoldMap f (PixelHSI h s i) = f h `mappend` f s `mappend` f i + {-# INLINE pxFoldMap #-} + + + +instance ColorSpace HSIA where + type PixelElt HSIA e = (e, e, e, e) + data Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq + + fromChannel !e = PixelHSIA e e e e + {-# INLINE fromChannel #-} + + fromElt (h, s, i, a) = PixelHSIA h s i a + {-# INLINE fromElt #-} + + toElt (PixelHSIA h s i a) = (h, s, i, a) + {-# INLINE toElt #-} + + getPxCh (PixelHSIA r _ _ _) HueHSIA = r + getPxCh (PixelHSIA _ g _ _) SatHSIA = g + getPxCh (PixelHSIA _ _ b _) IntHSIA = b + getPxCh (PixelHSIA _ _ _ a) AlphaHSIA = a + {-# INLINE getPxCh #-} + + chOp !f (PixelHSIA h s i a) = + PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a) + {-# INLINE chOp #-} + + pxOp !f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a) + {-# INLINE pxOp #-} + + chApp (PixelHSIA fh fs fi fa) (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a) + {-# INLINE chApp #-} + + pxFoldMap f (PixelHSIA h s i a) = f h `mappend` f s `mappend` f i `mappend` f a + {-# INLINE pxFoldMap #-} + + +instance Alpha HSIA where + type Opaque HSIA = HSI + + getAlpha (PixelHSIA _ _ _ a) = a + {-# INLINE getAlpha #-} + + addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a + {-# INLINE addAlpha #-} + + dropAlpha (PixelHSIA h s i _) = PixelHSI h s i + {-# INLINE dropAlpha #-} + + +instance Show HSI where + show HueHSI = "Hue" + show SatHSI = "Saturation" + show IntHSI = "Intensity" + +instance Show HSIA where + show HueHSIA = "Hue" + show SatHSIA = "Saturation" + show IntHSIA = "Intensity" + show AlphaHSIA = "Alpha" + +instance Show e => Show (Pixel HSI e) where + show (PixelHSI h s i) = "" + + +instance Show e => Show (Pixel HSIA e) where + show (PixelHSIA h s i a) = "" + + + diff --git a/src/Graphics/Image/ColorSpace/Luma.hs b/src/Graphics/Image/ColorSpace/Luma.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/Luma.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + TypeFamilies #-} +module Graphics.Image.ColorSpace.Luma ( + Y(..), YA(..), Pixel(..), + ToY(..), ToYA(..) + ) where + +import Prelude hiding (map) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend, mempty) + +-- | Luma or brightness, that is usually denoted as @Y'@. +data Y = Y deriving (Eq, Enum, Typeable) + +-- | Luma with Alpha channel. +data YA = YA + | AlphaYA deriving (Eq, Enum, Typeable) + + +class ColorSpace cs => ToY cs where + + toPixelY :: Pixel cs Double -> Pixel Y Double + + toImageY :: (Array arr cs Double, Array arr Y Double) => + Image arr cs Double + -> Image arr Y Double + toImageY = map toPixelY + {-# INLINE toImageY #-} + + +class (ToY (Opaque cs), Alpha cs) => ToYA cs where + + toPixelYA :: Pixel cs Double -> Pixel YA Double + toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px)) + + toImageYA :: (Array arr cs Double, Array arr YA Double) => + Image arr cs Double + -> Image arr YA Double + toImageYA = map toPixelYA + {-# INLINE toImageYA #-} + + +instance ColorSpace Y where + type PixelElt Y e = e + data Pixel Y e = PixelY !e deriving (Ord, Eq) + + fromChannel = PixelY + {-# INLINE fromChannel #-} + + fromElt = PixelY + {-# INLINE fromElt #-} + + toElt (PixelY y) = y + {-# INLINE toElt #-} + + getPxCh (PixelY y) _ = y + {-# INLINE getPxCh #-} + + chOp !f (PixelY y) = PixelY (f Y y) + {-# INLINE chOp #-} + + pxOp !f (PixelY y) = PixelY (f y) + {-# INLINE pxOp #-} + + chApp (PixelY fy) (PixelY y) = PixelY (fy y) + {-# INLINE chApp #-} + + pxFoldMap f (PixelY y) = f y `mappend` mempty + {-# INLINE pxFoldMap #-} + + +instance ColorSpace YA where + type PixelElt YA e = (e, e) + data Pixel YA e = PixelYA !e !e deriving Eq + + fromChannel !e = PixelYA e e + {-# INLINE fromChannel #-} + + fromElt !(g, a) = PixelYA g a + {-# INLINE fromElt #-} + + toElt (PixelYA g a) = (g, a) + {-# INLINE toElt #-} + + getPxCh (PixelYA g _) YA = g + getPxCh (PixelYA _ a) AlphaYA = a + {-# INLINE getPxCh #-} + + chOp !f (PixelYA g a) = PixelYA (f YA g) (f AlphaYA a) + {-# INLINE chOp #-} + + pxOp !f (PixelYA g a) = PixelYA (f g) (f a) + {-# INLINE pxOp #-} + + chApp (PixelYA fy fa) (PixelYA y a) = PixelYA (fy y) (fa a) + {-# INLINE chApp #-} + + pxFoldMap f (PixelYA y a) = f y `mappend` f a + {-# INLINE pxFoldMap #-} + +instance Alpha YA where + type Opaque YA = Y + + getAlpha (PixelYA _ a) = a + {-# INLINE getAlpha #-} + + addAlpha !a (PixelY g) = PixelYA g a + {-# INLINE addAlpha #-} + + dropAlpha (PixelYA g _) = PixelY g + {-# INLINE dropAlpha #-} + + +instance Show Y where + show Y = "Luma" + + +instance Show YA where + show YA = "Luma" + show AlphaYA = "Alpha" + + +instance Show e => Show (Pixel Y e) where + show (PixelY g) = "" + + +instance Show e => Show (Pixel YA e) where + show (PixelYA g a) = "" + + diff --git a/src/Graphics/Image/ColorSpace/RGB.hs b/src/Graphics/Image/ColorSpace/RGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/RGB.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + TypeFamilies #-} +module Graphics.Image.ColorSpace.RGB ( + RGB(..), RGBA(..), Pixel(..), + ToRGB(..), ToRGBA(..) + ) where + +import Prelude hiding (map) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend) + + +data RGB = RedRGB + | GreenRGB + | BlueRGB deriving (Eq, Enum, Typeable) + +data RGBA = RedRGBA + | GreenRGBA + | BlueRGBA + | AlphaRGBA deriving (Eq, Enum, Typeable) + + +class ColorSpace cs => ToRGB cs where + + toPixelRGB :: Pixel cs Double -> Pixel RGB Double + + toImageRGB :: (Array arr cs Double, Array arr RGB Double) => + Image arr cs Double + -> Image arr RGB Double + toImageRGB = map toPixelRGB + {-# INLINE toImageRGB #-} + + +class (ToRGB (Opaque cs), Alpha cs) => ToRGBA cs where + + toPixelRGBA :: Pixel cs Double -> Pixel RGBA Double + toPixelRGBA px = addAlpha (getAlpha px) (toPixelRGB (dropAlpha px)) + + toImageRGBA :: (Array arr cs Double, Array arr RGBA Double) => + Image arr cs Double + -> Image arr RGBA Double + toImageRGBA = map toPixelRGBA + {-# INLINE toImageRGBA #-} + + +instance ColorSpace RGB where + type PixelElt RGB e = (e, e, e) + data Pixel RGB e = PixelRGB !e !e !e deriving Eq + + fromChannel !e = PixelRGB e e e + {-# INLINE fromChannel #-} + + fromElt !(r, g, b) = PixelRGB r g b + {-# INLINE fromElt #-} + + toElt (PixelRGB r g b) = (r, g, b) + {-# INLINE toElt #-} + + getPxCh (PixelRGB r _ _) RedRGB = r + getPxCh (PixelRGB _ g _) GreenRGB = g + getPxCh (PixelRGB _ _ b) BlueRGB = b + {-# INLINE getPxCh #-} + + chOp !f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b) + {-# INLINE chOp #-} + + pxOp !f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b) + {-# INLINE pxOp #-} + + chApp (PixelRGB fr fg fb) (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b) + {-# INLINE chApp #-} + + pxFoldMap f (PixelRGB r g b) = f r `mappend` f g `mappend` f b + {-# INLINE pxFoldMap #-} + + +instance ColorSpace RGBA where + type PixelElt RGBA e = (e, e, e, e) + data Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq + + fromChannel !e = PixelRGBA e e e e + {-# INLINE fromChannel #-} + + fromElt (r, g, b, a) = PixelRGBA r g b a + {-# INLINE fromElt #-} + + toElt (PixelRGBA r g b a) = (r, g, b, a) + {-# INLINE toElt #-} + + getPxCh (PixelRGBA r _ _ _) RedRGBA = r + getPxCh (PixelRGBA _ g _ _) GreenRGBA = g + getPxCh (PixelRGBA _ _ b _) BlueRGBA = b + getPxCh (PixelRGBA _ _ _ a) AlphaRGBA = a + {-# INLINE getPxCh #-} + + chOp !f (PixelRGBA r g b a) = + PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a) + {-# INLINE chOp #-} + + pxOp !f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a) + {-# INLINE pxOp #-} + + chApp (PixelRGBA fr fg fb fa) (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a) + {-# INLINE chApp #-} + + pxFoldMap f (PixelRGBA r g b a) = f r `mappend` f g `mappend` f b `mappend` f a + {-# INLINE pxFoldMap #-} + + +instance Alpha RGBA where + type Opaque RGBA = RGB + + getAlpha (PixelRGBA _ _ _ a) = a + {-# INLINE getAlpha #-} + + addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a + {-# INLINE addAlpha #-} + + dropAlpha (PixelRGBA r g b _) = PixelRGB r g b + {-# INLINE dropAlpha #-} + + +instance Show RGB where + show RedRGB = "Red" + show GreenRGB = "Green" + show BlueRGB = "Blue" + + +instance Show RGBA where + show RedRGBA = "Red" + show GreenRGBA = "Green" + show BlueRGBA = "Blue" + show AlphaRGBA = "Alpha" + + +instance Show e => Show (Pixel RGB e) where + show (PixelRGB r g b) = "" + + +instance Show e => Show (Pixel RGBA e) where + show (PixelRGBA r g b a) = "" + + + diff --git a/src/Graphics/Image/ColorSpace/YCbCr.hs b/src/Graphics/Image/ColorSpace/YCbCr.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/YCbCr.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + TypeFamilies #-} +module Graphics.Image.ColorSpace.YCbCr ( + YCbCr(..), YCbCrA(..), Pixel(..), + ToYCbCr(..), ToYCbCrA(..) + ) where + +import Prelude hiding (map) +import Graphics.Image.Interface +import Data.Typeable (Typeable) +import Data.Monoid (mappend) + +data YCbCr = LumaYCbCr + | CBlueYCbCr + | CRedYCbCr deriving (Eq, Enum, Typeable) + + +data YCbCrA = LumaYCbCrA + | CBlueYCbCrA + | CRedYCbCrA + | AlphaYCbCrA deriving (Eq, Enum, Typeable) + + +class ColorSpace cs => ToYCbCr cs where + + toPixelYCbCr :: Pixel cs Double -> Pixel YCbCr Double + + toImageYCbCr :: (Array arr cs Double, Array arr YCbCr Double) => + Image arr cs Double + -> Image arr YCbCr Double + toImageYCbCr = map toPixelYCbCr + {-# INLINE toImageYCbCr #-} + + +class (ToYCbCr (Opaque cs), Alpha cs) => ToYCbCrA cs where + + toPixelYCbCrA :: Pixel cs Double -> Pixel YCbCrA Double + toPixelYCbCrA px = addAlpha (getAlpha px) (toPixelYCbCr (dropAlpha px)) + + toImageYCbCrA :: (Array arr cs Double, Array arr YCbCrA Double) => + Image arr cs Double + -> Image arr YCbCrA Double + toImageYCbCrA = map toPixelYCbCrA + {-# INLINE toImageYCbCrA #-} + + +instance ColorSpace YCbCr where + type PixelElt YCbCr e = (e, e, e) + data Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq + + fromChannel !e = PixelYCbCr e e e + {-# INLINE fromChannel #-} + + fromElt !(y, b, r) = PixelYCbCr y b r + {-# INLINE fromElt #-} + + toElt (PixelYCbCr y b r) = (y, b, r) + {-# INLINE toElt #-} + + getPxCh (PixelYCbCr y _ _) LumaYCbCr = y + getPxCh (PixelYCbCr _ b _) CBlueYCbCr = b + getPxCh (PixelYCbCr _ _ r) CRedYCbCr = r + {-# INLINE getPxCh #-} + + chOp !f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r) + {-# INLINE chOp #-} + + pxOp !f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r) + {-# INLINE pxOp #-} + + chApp (PixelYCbCr fy fb fr) (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r) + {-# INLINE chApp #-} + + pxFoldMap f (PixelYCbCr y b r) = f y `mappend` f b `mappend` f r + {-# INLINE pxFoldMap #-} + + +instance ColorSpace YCbCrA where + type PixelElt YCbCrA e = (e, e, e, e) + data Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq + + fromChannel !e = PixelYCbCrA e e e e + {-# INLINE fromChannel #-} + + fromElt (y, b, r, a) = PixelYCbCrA y b r a + {-# INLINE fromElt #-} + + toElt (PixelYCbCrA y b r a) = (y, b, r, a) + {-# INLINE toElt #-} + + getPxCh (PixelYCbCrA y _ _ _) LumaYCbCrA = y + getPxCh (PixelYCbCrA _ b _ _) CBlueYCbCrA = b + getPxCh (PixelYCbCrA _ _ r _) CRedYCbCrA = r + getPxCh (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a + {-# INLINE getPxCh #-} + + chOp !f (PixelYCbCrA y b r a) = + PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a) + {-# INLINE chOp #-} + + pxOp !f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a) + {-# INLINE pxOp #-} + + chApp (PixelYCbCrA fy fb fr fa) (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a) + {-# INLINE chApp #-} + + pxFoldMap f (PixelYCbCrA y b r a) = f y `mappend` f b `mappend` f r `mappend` f a + {-# INLINE pxFoldMap #-} + + +instance Alpha YCbCrA where + type Opaque YCbCrA = YCbCr + + getAlpha (PixelYCbCrA _ _ _ a) = a + {-# INLINE getAlpha #-} + + addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a + {-# INLINE addAlpha #-} + + dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r + {-# INLINE dropAlpha #-} + + +instance Show YCbCr where + show LumaYCbCr = "Luma" + show CBlueYCbCr = "Blue Chroma" + show CRedYCbCr = "Red Chroma" + + +instance Show YCbCrA where + show LumaYCbCrA = "Luma" + show CBlueYCbCrA = "Blue Chroma" + show CRedYCbCrA = "Red Chroma" + show AlphaYCbCrA = "Alpha" + + +instance Show e => Show (Pixel YCbCr e) where + show (PixelYCbCr y b r) = "" + + +instance Show e => Show (Pixel YCbCrA e) where + show (PixelYCbCrA y b r a) = "" + + + diff --git a/src/Graphics/Image/IO.hs b/src/Graphics/Image/IO.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO.hs @@ -0,0 +1,313 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE BangPatterns, FlexibleContexts #-} +module Graphics.Image.IO ( + -- * Reading + readImage, readImageExact, + -- * Writing + writeImage, writeImageExact, + -- * Displaying + displayImage, setDisplayProgram, + --displayImageHistograms, displayHistograms, writeHistograms, + -- * Supported Image Formats + module Graphics.Image.IO.External + + -- $supported + + ) where + +import Prelude as P hiding (readFile, writeFile) +import qualified Control.Monad as M (foldM) +import Control.Concurrent -- (forkIO, ThreadId) +import Data.Char (toLower) +import Data.IORef +import Data.ByteString (readFile) +--import Graphics.EasyPlot hiding (TerminalType(..)) +--import qualified Graphics.EasyPlot as Plot (TerminalType(PNG)) +import Graphics.Image.ColorSpace +import Graphics.Image.Interface +import Graphics.Image.IO.Base +import Graphics.Image.IO.External +--import HIP.Histogram +import qualified Data.ByteString.Lazy as BL (writeFile, hPut) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath (takeExtension) +import System.IO (Handle, hFlush) +import System.IO.Temp (withSystemTempFile) +import System.IO.Unsafe (unsafePerformIO) +import System.Process (spawnProcess, waitForProcess, showCommandForUser) + + +guessFormat :: (ImageFormat f, Enum f) => FilePath -> Maybe f +guessFormat path = + headMaybe . dropWhile (not . isFormat e) . enumFrom . toEnum $ 0 + where e = P.map toLower . takeExtension $ path + headMaybe ls = if null ls then Nothing else Just $ head ls + +-- | This function will try to guess an image format from file's extension, +-- then it will attempt to read it as such. It will fall back onto the rest of +-- the supported formats and will try to read them regarless of file's +-- extension. Whenever image cannot be decoded, 'Left' containing all errors for +-- each attempted format will be returned, and 'Right' containing an image +-- otherwise. Image will be read into a type signature specified 'ColorSpace' +-- ('Graphics.Image.ColorSpace.Y', 'Graphics.Image.ColorSpace.YA', +-- 'Graphics.Image.ColorSpace.RGB' and 'Graphics.Image.ColorSpace.RGBA' only) +-- with 'Double' precision, while doing all necessary conversions. +readImage :: Readable (Image arr cs Double) InputFormat => + FilePath + -> IO (Either String (Image arr cs Double)) +readImage path = do + imgstr <- readFile path + let maybeFormat = (guessFormat path :: Maybe InputFormat) + formats = enumFrom . toEnum $ 0 + orderedFormats = maybe formats (\f -> f:(filter (/=f) formats)) maybeFormat + reader (Left err) format = + return $ either (Left . ((err++"\n")++)) Right (decode format imgstr) + reader img _ = return img + M.foldM reader (Left "") orderedFormats + +-- | This function allows for reading any supported image in the exact colorspace +-- and precision it is currently encoded in. For instance, frog image can be +-- read into it's 'Graphics.Image.ColorSpace.YCbCr' colorspace with +-- 'Graphics.Image.ColorSpace.Word8' precision and into any supported array +-- representation. +-- +-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RP YCbCr Word8)) +-- Right +-- +-- The drawback here is that colorspace and precision has to match exactly, +-- otherwise it will return an error: +-- +-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RD RGB Word8)) +-- Left "JuicyPixel decoding error: Input image is in YCbCr8 (Pixel YCbCr Word8), cannot convert it to RGB8 (Pixel RGB Word8) colorspace." +-- +-- Attempt to read an image in a particular color space that is not supported by +-- the format, will result in a compile error. Refer to 'Readable' class for all +-- images that can be decoded. +readImageExact :: Readable img format => + format + -- ^ A file format that an image should be read as. See + -- <#g:4 Supported Image Formats> + -> FilePath -- ^ Location of an image. + -> IO (Either String img) +readImageExact format path = fmap (decode format) (readFile path) + + +-- | Just like 'readImage', this function will guess an output file format from the +-- extension and write to file any image that is in one of 'Y', 'YA', 'RGB' or +-- 'RGBA' 'ColorSpace's with 'Double' precision. While doing necessary +-- conversions the choice will be given to the most suited color space supported +-- by the format, for instance, in case of a 'PNG' format, an ('Image' @arr@ +-- 'RGBA' 'Double') would be written as 'RGBA'16, hence preserving transparency +-- and using highest supported precision 'Word16'. At the same time, writing +-- that image in 'GIF' format would save it in @RGB8@, since 'Word8' is the +-- highest precision 'GIF' supports and it currently cannot be saved with +-- transparency. +writeImage :: (ManifestArray arr cs Double, Writable (Image arr cs Double) OutputFormat) => + FilePath -- ^ Location where an image should be written. + -> Image arr cs Double -- ^ An image to write. + -> IO () +writeImage path = BL.writeFile path . encode format [] where + format = maybe (error ("Could not guess output format. Use 'writeImageExact' "++ + "or supply a filename with supported format.")) + id (guessFormat path :: Maybe OutputFormat) + + +writeImageExact :: Writable img format => + format + -- ^ A file format that an image should be saved in. See + -- <#g:4 Supported Image Formats> + -> [SaveOption format] -- ^ A list of format specific options. + -> FilePath -- ^ Location where an image should be written. + -> img -- ^ An image to write. Can be a list of images in case + -- of formats supporting animation. + -> IO () +writeImageExact format opts path = BL.writeFile path . encode format opts + + +-- | Sets the program to be use when displaying an image, where 'Bool' +-- specifies if current thread should block until the program is closed when +-- calling 'displayImage' function. GPicView @("gpicview", False)@ is set as a +-- default program with a nonblocking flag. Here are some examples: +-- +-- >>> setDisplayProgram ("gpicview", True) -- use gpicview and block current thread. +-- >>> setDisplayProgram ("gimp", False) -- use gimp and don't block current thread. +-- >>> setDisplayProgram ("xv", False) +-- >>> setDisplayProgram ("display", False) +-- +setDisplayProgram :: (String, Bool) -> IO () +setDisplayProgram = writeIORef displayProgram + + +displayProgram :: IORef (String, Bool) +displayProgram = unsafePerformIO . newIORef $ ("gpicview", False) +{-# NOINLINE displayProgram #-} + + +{- | Makes a call to the current display program, which can be changed using +'setDisplayProgram'. An image is written as a @.tiff@ file into an operating +system's temporary directory and passed as an argument to the display +program. If a blocking flag was set to 'False' using 'setDisplayProgram', then +function will return immediately with ('Just' 'ThreadId'), otherwise it will +block current thread until external program is terminated, in which case +'Nothing' is returned. Temporary file is deleted, after a program displaying an +image is closed. + + >>> frog <- readImageRGB "images/frog.jpg" + >>> displayImage frog + Just ThreadId 505 + >>> setDisplayProgram ("gimp", True) + >>> displayImage frog -- will only return after gimp is closed. + Nothing + +-} +displayImage :: (ManifestArray arr cs e, Writable (Image arr cs e) TIF) => + Image arr cs e -- ^ Image to be displayed + -> IO (Maybe ThreadId) +displayImage img = do + (program, block) <- readIORef displayProgram + let displayAction = withSystemTempFile "tmp-img.tiff" (displayUsing img program) + if block + then displayAction >> return Nothing + else forkIO displayAction >>= (return . Just) + + +displayUsing :: (ManifestArray arr cs e, Writable (Image arr cs e) TIF) => + Image arr cs e -> String -> FilePath -> Handle -> IO () +displayUsing img program path h = do + BL.hPut h $ encode TIF [] img + hFlush h + ph <- spawnProcess program [path] + e <- waitForProcess ph + let printExit ExitSuccess = return () + printExit exitCode = do + putStrLn $ showCommandForUser program [path] + print exitCode + printExit e + + + +{- $supported +Encoding and decoding of images is done using + and + packages. + +List of image formats that are currently supported, and their exact +'ColorSpace's and precision for reading and writing: + +* 'BMP': + + * __in__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __out__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + +* 'GIF': + + * __in__: ('RGB' 'Word8'), ('RGBA' 'Word8') + * __out__: ('RGB' 'Word8') + * Also supports reading and writing animated images, when used as @['GIF']@ + +* 'HDR': + + * __in__: ('RGB' 'Float') + * __out__: ('RGB' 'Float') + +* 'JPG': + + * __in__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), + ('YCbCr', 'Word8') + * __out__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), + ('YCbCr', 'Word8') + +* 'PNG': + + * __in__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + * __out__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + +* 'TGA': + + * __in__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __out__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + +* 'TIF': + + * __in__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16'), + ('CMYK' 'Word8'), ('CMYK' 'Word16') + * __out__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + ('CMYK' 'Word8'), ('CMYK' 'Word16'), ('YCbCr' 'Word8') + +* 'PBM': + + * __in__: ('Binary' 'Bit') + * Also supports sequence of images in one file, when read as @['PBM']@ + +* 'PGM': + + * __in__: ('Y' 'Word8'), ('Y' 'Word16') + * Also supports sequence of images in one file, when read as @['PGM']@ + +* 'PPM': + + * __in__: ('RGB' 'Word8'), ('RGB' 'Word16') + * Also supports sequence of images in one file, when read as @['PPM']@ + +-} + + +{- +displayImageHistograms :: (Strategy strat img (Channel px), AImage img px, + Enum (Channel px), RealFrac (Channel px)) => + strat img (Channel px) + -> Int + -> img px + -> IO () +displayImageHistograms strat steps img = displayHistograms $ getHistograms strat steps img + + +-- | Displays a list of 'Histogram's supplied using an external program that can +-- be changed with 'setDisplayProgram'. +-- +-- >>> centaurus <- readImageRGB "images/centaurus.jpg" +-- >>> cluster <- readImageRGB "images/cluster.jpg" +-- >>> displayHistograms ((getHistograms 255 centaurus)++(getHistograms 255 cluster)) +-- +-- <> +-- +displayHistograms :: (Show a, Num a, Fractional a, Enum a) => [Histogram a] -> IO () +displayHistograms hists = do + program <- readIORef displayProgram + withSystemTempDirectory "hip_" (displayHistogramsUsing hists program) + + +displayHistogramsUsing :: (Show a, Num a, Fractional a, Enum a) => + [Histogram a] -> String -> FilePath -> IO () +displayHistogramsUsing hists program tmpDir = do + let path = tmpDir "tmp-hist.png" + wrote <- writeHistograms path hists + if wrote + then do ph <- runCommand (program ++ " " ++ path) + e <- waitForProcess ph + let printExit ExitSuccess = return () + printExit exitCode = print exitCode + printExit e + else print "Was unsuccessfull in using gnuplot." + + +-- | Writes histograms into a PNG file image. +-- +-- >>> centaurus <- readImageRGB "images/centaurus.jpg" +-- >>> cluster <- readImageRGB "images/cluster.jpg" +-- >>> let histograms = ((getHistograms 255 centaurus)++(getHistograms 255 cluster)) +-- >>> writeHistograms "images/centaurus_cluster_histogram.png" histograms +-- True +-- +writeHistograms :: (Show a, Num a, Fractional a, Enum a) => + FilePath -- ^ PNG image file name. + -> [Histogram a] -- ^ List of histograms to be plotted. + -> IO Bool -- ^ Returns 'True' in case of success. +writeHistograms path = plot (Plot.PNG path) + + +-} diff --git a/src/Graphics/Image/IO/Base.hs b/src/Graphics/Image/IO/Base.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/Base.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} +module Graphics.Image.IO.Base ( + ImageFormat(..), Readable(..), Writable(..), Convertible(..) + ) where + +import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Lazy as BL (ByteString) + + +class Convertible a b where + convert :: a -> b + + +class ImageFormat format where + data SaveOption format + + ext :: format -> String + + exts :: format -> [String] + exts f = [ext f] + + isFormat :: String -> format -> Bool + isFormat e f = e `elem` (exts f) + + +class ImageFormat format => Readable img format where + + decode :: format -> B.ByteString -> Either String img + + +class ImageFormat format => Writable img format where + + encode :: format -> [SaveOption format] -> img -> BL.ByteString + + + diff --git a/src/Graphics/Image/IO/External.hs b/src/Graphics/Image/IO/External.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/External.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + TypeFamilies, UndecidableInstances #-} +module Graphics.Image.IO.External ( + module Graphics.Image.IO.External.JuicyPixels, + module Graphics.Image.IO.External.Netpbm, + InputFormat, OutputFormat, + Readable(..), Writable(..), ImageFormat(..), + ) where + +import Graphics.Image.Interface +import Graphics.Image.IO.Base +import Graphics.Image.IO.External.JuicyPixels +import Graphics.Image.IO.External.Netpbm + + +-- | A collection of all image formats that can be read into HIP images with +-- 'Double' precision pixel channels. +data InputFormat = InputBMP + | InputGIF + | InputHDR + | InputJPG + | InputPNG + | InputTIF + | InputPNM + | InputTGA deriving (Show, Enum, Eq) + + +instance ImageFormat InputFormat where + data SaveOption InputFormat + + ext InputBMP = ext BMP + ext InputGIF = ext GIF + ext InputHDR = ext HDR + ext InputJPG = ext JPG + ext InputPNG = ext PNG + ext InputTGA = ext TGA + ext InputTIF = ext TIF + ext InputPNM = ext PPM + + exts InputBMP = exts BMP + exts InputGIF = exts GIF + exts InputHDR = exts HDR + exts InputJPG = exts JPG + exts InputPNG = exts PNG + exts InputTGA = exts TGA + exts InputTIF = exts TIF + exts InputPNM = [ext PBM, ext PGM, ext PPM] + + +instance (Readable (Image arr cs Double) BMP, + Readable (Image arr cs Double) GIF, + Readable (Image arr cs Double) HDR, + Readable (Image arr cs Double) JPG, + Readable (Image arr cs Double) PNG, + Readable (Image arr cs Double) TGA, + Readable (Image arr cs Double) TIF, + Readable (Image arr cs Double) PPM) => + Readable (Image arr cs Double) InputFormat where + decode InputBMP = decode BMP + decode InputGIF = decode GIF + decode InputHDR = decode HDR + decode InputJPG = decode JPG + decode InputPNG = decode PNG + decode InputTIF = decode TIF + decode InputPNM = decode PPM + decode InputTGA = decode TGA + + + +-- | A collection of all image formats that can be written from HIP images with +-- 'Double' precision pixel channels. +data OutputFormat = OutputBMP + | OutputGIF + | OutputHDR + | OutputJPG + | OutputPNG + | OutputTIF + | OutputTGA deriving (Show, Enum, Eq) + + +instance ImageFormat OutputFormat where + data SaveOption OutputFormat + ext OutputBMP = ext BMP + ext OutputGIF = ext GIF + ext OutputHDR = ext HDR + ext OutputJPG = ext JPG + ext OutputPNG = ext PNG + ext OutputTGA = ext TGA + ext OutputTIF = ext TIF + + +instance (Writable (Image arr cs Double) BMP, + Writable (Image arr cs Double) GIF, + Writable (Image arr cs Double) HDR, + Writable (Image arr cs Double) JPG, + Writable (Image arr cs Double) PNG, + Writable (Image arr cs Double) TGA, + Writable (Image arr cs Double) TIF) => + Writable (Image arr cs Double) OutputFormat where + encode OutputBMP _ = encode BMP [] + encode OutputGIF _ = encode GIF [] + encode OutputHDR _ = encode HDR [] + encode OutputJPG _ = encode JPG [] + encode OutputPNG _ = encode PNG [] + encode OutputTGA _ = encode TGA [] + encode OutputTIF _ = encode TIF [] diff --git a/src/Graphics/Image/IO/External/JuicyPixels.hs b/src/Graphics/Image/IO/External/JuicyPixels.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/External/JuicyPixels.hs @@ -0,0 +1,1077 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + TypeFamilies, ViewPatterns #-} +module Graphics.Image.IO.External.JuicyPixels ( + BMP(..), + GIF(..), JP.GifDelay, JP.GifLooping(..), JP.PaletteOptions(..), JP.PaletteCreationMethod(..), + HDR(..), JPG(..), PNG(..), TGA(..), TIF(..) + ) where + +import GHC.Float +import Data.Either +import Data.Monoid (mempty) +import Graphics.Image.ColorSpace +import Graphics.Image.Interface hiding (map) +import Graphics.Image.IO.Base +import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Codec.Picture as JP +import qualified Codec.Picture.Jpg as JP +import qualified Codec.Picture.Types as JP +import qualified Codec.Picture.ColorQuant as JP + + +data BMP = BMP -- ^ Bitmap image with @.bmp@ extension. + +instance ImageFormat BMP where + data SaveOption BMP + + ext _ = ".bmp" + + +data GIF = GIF -- ^ Graphics Interchange Format image with @.gif@ extension. + +instance ImageFormat GIF where + data SaveOption GIF = GIFPalette JP.PaletteOptions + + ext _ = ".gif" + +instance ImageFormat [GIF] where + data SaveOption [GIF] = GIFsPalette JP.PaletteOptions + | GIFsLooping JP.GifLooping + + ext _ = ext GIF + +data HDR = HDR -- ^ High-dynamic-range image with @.hdr@ extension. + +instance ImageFormat HDR where + data SaveOption HDR + + ext _ = ".hdr" + + exts _ = [".hdr", ".pic"] + + +data JPG = JPG -- ^ Joint Photographic Experts Group image with @.jpg@ or + -- @.jpeg@ extension. + +instance ImageFormat JPG where + data SaveOption JPG = JPGQuality Word8 + + ext _ = ".jpg" + + exts _ = [".jpg", ".jpeg"] + + +data PNG = PNG -- ^ Portable Network Graphics image with @.png@ extension. + +instance ImageFormat PNG where + data SaveOption PNG + + ext _ = ".png" + + +data TGA = TGA -- ^ Truevision Graphics Adapter image with .tga extension. + +instance ImageFormat TGA where + data SaveOption TGA + + ext _ = ".tga" + + +data TIF = TIF -- ^ Tagged Image File Format image with @.tif@ or @.tiff@ + -- extension. + +instance ImageFormat TIF where + data SaveOption TIF + + ext _ = ".tif" + + exts _ = [".tif", ".tiff"] + + +-------------------------------------------------------------------------------- +-- Converting to and from JuicyPixels ------------------------------------------ +-------------------------------------------------------------------------------- + +-- Y -> Y (Double) + +instance Convertible JP.Pixel8 (Pixel Y Double) where + convert = toDouble . PixelY + +instance Convertible JP.Pixel16 (Pixel Y Double) where + convert = toDouble . PixelY + +instance Convertible JP.PixelF (Pixel Y Double) where + convert = toDouble . PixelY + +instance Convertible JP.PixelYA8 (Pixel Y Double) where + convert = convert . JP.dropTransparency + +instance Convertible JP.PixelYA16 (Pixel Y Double) where + convert = convert . JP.dropTransparency + +instance Convertible JP.Pixel8 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.Pixel16 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelF (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelYA8 (Pixel YA Double) where + convert (JP.PixelYA8 y a) = toDouble (PixelYA y a) + +instance Convertible JP.PixelYA16 (Pixel YA Double) where + convert (JP.PixelYA16 y a) = toDouble (PixelYA y a) + + +-- Color -> Y (Double) + +instance Convertible JP.PixelRGB8 (Pixel Y Double) where + convert = toPixelY . (convert :: JP.PixelRGB8 -> Pixel RGB Double) + +instance Convertible JP.PixelRGB16 (Pixel Y Double) where + convert = toPixelY . (convert :: JP.PixelRGB16 -> Pixel RGB Double) + +instance Convertible JP.PixelRGBA8 (Pixel Y Double) where + convert = toPixelY . (convert :: JP.PixelRGBA8 -> Pixel RGB Double) + +instance Convertible JP.PixelRGBA16 (Pixel Y Double) where + convert = toPixelY . (convert :: JP.PixelRGBA16 -> Pixel RGB Double) + +instance Convertible JP.PixelRGBF (Pixel Y Double) where + convert = toPixelY . (convert :: JP.PixelRGBF -> Pixel RGB Double) + +instance Convertible JP.PixelCMYK8 (Pixel Y Double) where + convert = toPixelY . toDouble . (convert :: JP.PixelCMYK8 -> Pixel CMYK Word8) + +instance Convertible JP.PixelCMYK16 (Pixel Y Double) where + convert = toPixelY . toDouble . (convert :: JP.PixelCMYK16 -> Pixel CMYK Word16) + +instance Convertible JP.PixelYCbCr8 (Pixel Y Double) where + convert = convert . JP.computeLuma + +-- Color -> YA (Double) + +instance Convertible JP.PixelRGB8 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelRGB16 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelRGBF (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelCMYK8 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelCMYK16 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelYCbCr8 (Pixel YA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelRGBA8 (Pixel YA Double) where + convert = toPixelYA . (convert :: JP.PixelRGBA8 -> Pixel RGBA Double) + +instance Convertible JP.PixelRGBA16 (Pixel YA Double) where + convert = toPixelYA . (convert :: JP.PixelRGBA16 -> Pixel RGBA Double) + + + +-- Y -> RGB (Double) + +instance Convertible JP.Pixel8 (Pixel RGB Double) where + convert = toDouble . fromChannel + +instance Convertible JP.Pixel16 (Pixel RGB Double) where + convert = toDouble . fromChannel + +instance Convertible JP.PixelF (Pixel RGB Double) where + convert = toDouble . fromChannel + +instance Convertible JP.PixelYA8 (Pixel RGB Double) where + convert = convert . JP.dropTransparency + +instance Convertible JP.PixelYA16 (Pixel RGB Double) where + convert = convert . JP.dropTransparency + +-- Color -> RGB (Double) + +instance Convertible JP.PixelRGB8 (Pixel RGB Double) where + convert (JP.PixelRGB8 r g b) = toDouble $ PixelRGB r g b + +instance Convertible JP.PixelRGB16 (Pixel RGB Double) where + convert (JP.PixelRGB16 r g b) = toDouble $ PixelRGB r g b + +instance Convertible JP.PixelRGBA8 (Pixel RGB Double) where + convert = convert . JP.dropTransparency + +instance Convertible JP.PixelRGBA16 (Pixel RGB Double) where + convert = convert . JP.dropTransparency + +instance Convertible JP.PixelRGBF (Pixel RGB Double) where + convert (JP.PixelRGBF r g b) = + PixelRGB (float2Double r) (float2Double g) (float2Double b) + +instance Convertible JP.PixelYCbCr8 (Pixel RGB Double) where + convert = convert . (JP.convertPixel :: JP.PixelYCbCr8 -> JP.PixelRGB8) + +instance Convertible JP.PixelCMYK8 (Pixel RGB Double) where + convert = convert . (JP.convertPixel :: JP.PixelCMYK8 -> JP.PixelRGB8) + +instance Convertible JP.PixelCMYK16 (Pixel RGB Double) where + convert = convert . (JP.convertPixel :: JP.PixelCMYK16 -> JP.PixelRGB16) + +-- Y -> RGBA (Double) + +instance Convertible JP.Pixel8 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.Pixel16 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelF (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelYA8 (Pixel RGBA Double) where + convert = toPixelRGBA . (convert :: JP.PixelYA8 -> Pixel YA Double) + +instance Convertible JP.PixelYA16 (Pixel RGBA Double) where + convert = toPixelRGBA . (convert :: JP.PixelYA16 -> Pixel YA Double) + +-- Color -> RGBA (Double) + +instance Convertible JP.PixelRGB8 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelRGB16 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelRGBF (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelCMYK8 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelCMYK16 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelYCbCr8 (Pixel RGBA Double) where + convert = addAlpha 1 . convert + +instance Convertible JP.PixelRGBA8 (Pixel RGBA Double) where + convert (JP.PixelRGBA8 r g b a) = toDouble $ PixelRGBA r g b a + +instance Convertible JP.PixelRGBA16 (Pixel RGBA Double) where + convert (JP.PixelRGBA16 r g b a) = toDouble $ PixelRGBA r g b a + + +---- to JuicyPixels ----- + +---- Exact precision conversions + +instance Convertible JP.Pixel8 (Pixel Y Word8) where + convert = PixelY + +instance Convertible JP.Pixel16 (Pixel Y Word16) where + convert = PixelY + +instance Convertible JP.Pixel32 (Pixel Y Word32) where + convert = PixelY + +instance Convertible JP.PixelF (Pixel Y Float) where + convert = PixelY + +instance Convertible JP.PixelYA8 (Pixel YA Word8) where + convert (JP.PixelYA8 g a) = PixelYA g a + +instance Convertible JP.PixelYA16 (Pixel YA Word16) where + convert (JP.PixelYA16 g a) = PixelYA g a + +instance Convertible JP.PixelRGB8 (Pixel RGB Word8) where + convert (JP.PixelRGB8 r g b) = PixelRGB r g b + +instance Convertible JP.PixelRGB16 (Pixel RGB Word16) where + convert (JP.PixelRGB16 r g b) = PixelRGB r g b + +instance Convertible JP.PixelRGBF (Pixel RGB Float) where + convert (JP.PixelRGBF r g b) = PixelRGB r g b + +instance Convertible JP.PixelRGBA8 (Pixel RGBA Word8) where + convert (JP.PixelRGBA8 r g b a) = PixelRGBA r g b a + +instance Convertible JP.PixelRGBA16 (Pixel RGBA Word16) where + convert (JP.PixelRGBA16 r g b a) = PixelRGBA r g b a + +instance Convertible JP.PixelYCbCr8 (Pixel YCbCr Word8) where + convert (JP.PixelYCbCr8 y cb cr) = PixelYCbCr y cb cr + +instance Convertible JP.PixelCMYK8 (Pixel CMYK Word8) where + convert (JP.PixelCMYK8 c m y k) = PixelCMYK c m y k + +instance Convertible JP.PixelCMYK16 (Pixel CMYK Word16) where + convert (JP.PixelCMYK16 c m y k) = PixelCMYK c m y k + + + +instance Convertible (Pixel Y Word8) JP.Pixel8 where + convert (PixelY g) = g + +instance Convertible (Pixel Y Word16) JP.Pixel16 where + convert (PixelY g) = g + +instance Convertible (Pixel Y Word32) JP.Pixel32 where + convert (PixelY g) = g + +instance Convertible (Pixel Y Float) JP.PixelF where + convert (PixelY g) = g + +instance Convertible (Pixel YA Word8) JP.PixelYA8 where + convert (PixelYA g a) = JP.PixelYA8 g a + +instance Convertible (Pixel YA Word16) JP.PixelYA16 where + convert (PixelYA g a) = JP.PixelYA16 g a + +instance Convertible (Pixel RGB Word8) JP.PixelRGB8 where + convert (PixelRGB r g b) = JP.PixelRGB8 r g b + +instance Convertible (Pixel RGB Word16) JP.PixelRGB16 where + convert (PixelRGB r g b) = JP.PixelRGB16 r g b + +instance Convertible (Pixel RGB Float) JP.PixelRGBF where + convert (PixelRGB r g b) = JP.PixelRGBF r g b + +instance Convertible (Pixel RGBA Word8) JP.PixelRGBA8 where + convert (PixelRGBA r g b a) = JP.PixelRGBA8 r g b a + +instance Convertible (Pixel RGBA Word16) JP.PixelRGBA16 where + convert (PixelRGBA r g b a) = JP.PixelRGBA16 r g b a + + +instance Convertible (Pixel YCbCr Word8) JP.PixelYCbCr8 where + convert (PixelYCbCr y cb cr) = JP.PixelYCbCr8 y cb cr + +instance Convertible (Pixel CMYK Word8) JP.PixelCMYK8 where + convert (PixelCMYK c m y k) = JP.PixelCMYK8 c m y k + +instance Convertible (Pixel CMYK Word16) JP.PixelCMYK16 where + convert (PixelCMYK c m y k) = JP.PixelCMYK16 c m y k + + + +-------------------------------------------------------------------------------- +-- Decoding images using JuicyPixels ------------------------------------------ +-------------------------------------------------------------------------------- + + +-- BMP Format Reading + +instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) BMP where + decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeBitmap + +instance Array arr Y Word8 => Readable (Image arr Y Word8) BMP where + decode _ = jpImageY8ToImage . JP.decodeBitmap + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) BMP where + decode _ = jpImageRGB8ToImage . JP.decodeBitmap + +instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) BMP where + decode _ = jpImageRGBA8ToImage . JP.decodeBitmap + +instance Array arr Y Double => Readable (Image arr Y Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + +instance Array arr YA Double => Readable (Image arr YA Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + +instance Array arr RGB Double => Readable (Image arr RGB Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + + +-- GIF Format Reading + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) GIF where + decode _ = jpImageRGB8ToImage . JP.decodeGif + +instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) GIF where + decode _ = jpImageRGBA8ToImage . JP.decodeGif + +instance Array arr Y Double => Readable (Image arr Y Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +instance Array arr YA Double => Readable (Image arr YA Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +instance Array arr RGB Double => Readable (Image arr RGB Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +-- List of GIF Format frames Reading + +decodeGifs :: (Either String JP.DynamicImage -> Either String img) + -> B.ByteString -> Either String [img] +decodeGifs decoder = either Left decodeLS . JP.decodeGifImages where + decodeLS ls = if null errs then Right imgs else Left $ unlines errs where + (errs, imgs) = partitionEithers $ map (decoder . Right) ls + +instance Array arr RGB Word8 => Readable [Image arr RGB Word8] [GIF] where + decode _ = decodeGifs jpImageRGB8ToImage + +instance Array arr RGBA Word8 => Readable [Image arr RGBA Word8] [GIF] where + decode _ = decodeGifs jpImageRGBA8ToImage + +instance Array arr Y Double => Readable [Image arr Y Double] [GIF] where + decode _ = decodeGifs jpDynamicImageToImage + +instance Array arr YA Double => Readable [Image arr YA Double] [GIF] where + decode _ = decodeGifs jpDynamicImageToImage + +instance Array arr RGB Double => Readable [Image arr RGB Double] [GIF] where + decode _ = decodeGifs jpDynamicImageToImage + +instance Array arr RGBA Double => Readable [Image arr RGBA Double] [GIF] where + decode _ = decodeGifs jpDynamicImageToImage + + + +-- HDR Format Reading + +instance Array arr RGB Float => Readable (Image arr RGB Float) HDR where + decode _ = jpImageRGBFToImage . JP.decodeHDR + +instance Array arr Y Double => Readable (Image arr Y Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + +instance Array arr YA Double => Readable (Image arr YA Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + +instance Array arr RGB Double => Readable (Image arr RGB Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + + +-- JPG Format Reading + +instance Array arr Y Word8 => Readable (Image arr Y Word8) JPG where + decode _ = jpImageY8ToImage . JP.decodeJpeg + +instance Array arr YA Word8 => Readable (Image arr YA Word8) JPG where + decode _ = jpImageYA8ToImage . JP.decodeJpeg + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) JPG where + decode _ = jpImageRGB8ToImage . JP.decodeJpeg + +instance Array arr CMYK Word8 => Readable (Image arr CMYK Word8) JPG where + decode _ = jpImageCMYK8ToImage . JP.decodeJpeg + +instance Array arr YCbCr Word8 => Readable (Image arr YCbCr Word8) JPG where + decode _ = jpImageYCbCr8ToImage . JP.decodeJpeg + +instance Array arr Y Double => Readable (Image arr Y Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + +instance Array arr YA Double => Readable (Image arr YA Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + +instance Array arr RGB Double => Readable (Image arr RGB Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + + +-- PNG Format Reading + +instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) PNG where + decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodePng + +instance Array arr Y Word8 => Readable (Image arr Y Word8) PNG where + decode _ = jpImageY8ToImage . JP.decodePng + +instance Array arr Y Word16 => Readable (Image arr Y Word16) PNG where + decode _ = jpImageY16ToImage . JP.decodePng + +instance Array arr YA Word8 => Readable (Image arr YA Word8) PNG where + decode _ = jpImageYA8ToImage . JP.decodePng + +instance Array arr YA Word16 => Readable (Image arr YA Word16) PNG where + decode _ = jpImageYA16ToImage . JP.decodePng + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) PNG where + decode _ = jpImageRGB8ToImage . JP.decodePng + +instance Array arr RGB Word16 => Readable (Image arr RGB Word16) PNG where + decode _ = jpImageRGB16ToImage . JP.decodePng + +instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) PNG where + decode _ = jpImageRGBA8ToImage . JP.decodePng + +instance Array arr RGBA Word16 => Readable (Image arr RGBA Word16) PNG where + decode _ = jpImageRGBA16ToImage . JP.decodePng + +instance Array arr Y Double => Readable (Image arr Y Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + +instance Array arr YA Double => Readable (Image arr YA Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + +instance Array arr RGB Double => Readable (Image arr RGB Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + + +-- TGA Format Reading + +instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) TGA where + decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeTga + +instance Array arr Y Word8 => Readable (Image arr Y Word8) TGA where + decode _ = jpImageY8ToImage . JP.decodeTga + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) TGA where + decode _ = jpImageRGB8ToImage . JP.decodeTga + +instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) TGA where + decode _ = jpImageRGBA8ToImage . JP.decodeTga + +instance Array arr Y Double => Readable (Image arr Y Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + +instance Array arr YA Double => Readable (Image arr YA Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + +instance Array arr RGB Double => Readable (Image arr RGB Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + + +-- TIF Format Reading + +instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) TIF where + decode _ = either Left (Right . toImageBinary) . jpImageY8ToImage . JP.decodeTiff + +instance Array arr Y Word8 => Readable (Image arr Y Word8) TIF where + decode _ = jpImageY8ToImage . JP.decodeTiff + +instance Array arr Y Word16 => Readable (Image arr Y Word16) TIF where + decode _ = jpImageY16ToImage . JP.decodeTiff + +instance Array arr YA Word8 => Readable (Image arr YA Word8) TIF where + decode _ = jpImageYA8ToImage . JP.decodeTiff + +instance Array arr YA Word16 => Readable (Image arr YA Word16) TIF where + decode _ = jpImageYA16ToImage . JP.decodeTiff + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) TIF where + decode _ = jpImageRGB8ToImage . JP.decodeTiff + +instance Array arr RGB Word16 => Readable (Image arr RGB Word16) TIF where + decode _ = jpImageRGB16ToImage . JP.decodeTiff + +instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) TIF where + decode _ = jpImageRGBA8ToImage . JP.decodeTiff + +instance Array arr RGBA Word16 => Readable (Image arr RGBA Word16) TIF where + decode _ = jpImageRGBA16ToImage . JP.decodeTiff + +instance Array arr CMYK Word8 => Readable (Image arr CMYK Word8) TIF where + decode _ = jpImageCMYK8ToImage . JP.decodeTiff + +instance Array arr CMYK Word16 => Readable (Image arr CMYK Word16) TIF where + decode _ = jpImageCMYK16ToImage . JP.decodeTiff + + +instance Array arr Y Double => Readable (Image arr Y Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + +instance Array arr YA Double => Readable (Image arr YA Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + +instance Array arr RGB Double => Readable (Image arr RGB Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + + + +-- General decoding and helper functions + +jpImageToImage :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) => + JP.Image jpx -> Image arr cs e +jpImageToImage jimg = make (JP.imageHeight jimg, JP.imageWidth jimg) getPx + where getPx (y, x) = convert $ JP.pixelAt jimg x y + + +jpImageY8ToImage :: Array arr Y Word8 => + Either String JP.DynamicImage -> Either String (Image arr Y Word8) +jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImage jimg) +jpImageY8ToImage jimg = jpCSError "Y8 (Pixel Y Word8)" jimg + + +jpImageY16ToImage :: Array arr Y Word16 => + Either String JP.DynamicImage -> Either String (Image arr Y Word16) +jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImage jimg) +jpImageY16ToImage jimg = jpCSError "Y16 (Pixel Y Word16)" jimg + +{- -- No JuicyPixels images are actually read in this type +jpImageYFToImage :: Array arr Y Float => + Either String JP.DynamicImage -> Either String (Image arr Y Float) +jpImageYFToImage (Right (JP.ImageYF jimg)) = Right (jpImageToImage jimg) +jpImageYFToImage jimg = jpCSError "YF (Pixel Y Float)" jimg +-} + +jpImageYA8ToImage :: Array arr YA Word8 => + Either String JP.DynamicImage -> Either String (Image arr YA Word8) +jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImage jimg) +jpImageYA8ToImage jimg = jpCSError "YA8 (Pixel YA Word8)" jimg + + +jpImageYA16ToImage :: Array arr YA Word16 => + Either String JP.DynamicImage -> Either String (Image arr YA Word16) +jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImage jimg) +jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg + + +jpImageRGB8ToImage :: Array arr RGB Word8 => + Either String JP.DynamicImage -> Either String (Image arr RGB Word8) +jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImage jimg) +jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg + + +jpImageRGB16ToImage :: Array arr RGB Word16 => + Either String JP.DynamicImage -> Either String (Image arr RGB Word16) +jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImage jimg) +jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg + + +jpImageRGBFToImage :: Array arr RGB Float => + Either String JP.DynamicImage -> Either String (Image arr RGB Float) +jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImage jimg) +jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg + + +jpImageRGBA8ToImage :: Array arr RGBA Word8 => + Either String JP.DynamicImage -> Either String (Image arr RGBA Word8) +jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImage jimg) +jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg + + +jpImageRGBA16ToImage :: Array arr RGBA Word16 => + Either String JP.DynamicImage -> Either String (Image arr RGBA Word16) +jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImage jimg) +jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg + + +jpImageYCbCr8ToImage :: Array arr YCbCr Word8 => + Either String JP.DynamicImage -> Either String (Image arr YCbCr Word8) +jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImage jimg) +jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg + + +jpImageCMYK8ToImage :: Array arr CMYK Word8 => + Either String JP.DynamicImage -> Either String (Image arr CMYK Word8) +jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImage jimg) +jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg + + +jpImageCMYK16ToImage :: Array arr CMYK Word16 => + Either String JP.DynamicImage -> Either String (Image arr CMYK Word16) +jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImage jimg) +jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg + + +jpDynamicImageToImage' :: (Convertible JP.PixelCMYK16 (Pixel cs e), + Convertible JP.PixelCMYK8 (Pixel cs e), + Convertible JP.PixelRGB16 (Pixel cs e), + Convertible JP.PixelRGB8 (Pixel cs e), + Convertible JP.PixelRGBA16 (Pixel cs e), + Convertible JP.PixelRGBA8 (Pixel cs e), + Convertible JP.PixelRGBF (Pixel cs e), + Convertible JP.PixelYA16 (Pixel cs e), + Convertible JP.PixelYA8 (Pixel cs e), + Convertible JP.PixelYCbCr8 (Pixel cs e), + Convertible JP.Pixel16 (Pixel cs e), + Convertible JP.Pixel8 (Pixel cs e), + Convertible JP.PixelF (Pixel cs e), + Array arr cs e) => + JP.DynamicImage -> Image arr cs e +jpDynamicImageToImage' (JP.ImageY8 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageY16 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageYF jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageYA8 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageYA16 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageRGB8 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageRGB16 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageRGBF jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageRGBA8 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageRGBA16 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageCMYK8 jimg) = jpImageToImage jimg +jpDynamicImageToImage' (JP.ImageCMYK16 jimg) = jpImageToImage jimg + + +jpDynamicImageToImage :: (Convertible JP.PixelCMYK16 (Pixel cs e), + Convertible JP.PixelCMYK8 (Pixel cs e), + Convertible JP.PixelRGB16 (Pixel cs e), + Convertible JP.PixelRGB8 (Pixel cs e), + Convertible JP.PixelRGBA16 (Pixel cs e), + Convertible JP.PixelRGBA8 (Pixel cs e), + Convertible JP.PixelRGBF (Pixel cs e), + Convertible JP.PixelYA16 (Pixel cs e), + Convertible JP.PixelYA8 (Pixel cs e), + Convertible JP.PixelYCbCr8 (Pixel cs e), + Convertible JP.Pixel16 (Pixel cs e), + Convertible JP.Pixel8 (Pixel cs e), + Convertible JP.PixelF (Pixel cs e), Array arr cs e) => + Either String JP.DynamicImage -> Either String (Image arr cs e) +jpDynamicImageToImage = either jpError (Right . jpDynamicImageToImage') + + +jpImageShowCS :: JP.DynamicImage -> String +jpImageShowCS (JP.ImageY8 _) = "Y8 (Pixel Y Word8)" +jpImageShowCS (JP.ImageY16 _) = "Y16 (Pixel Y Word16)" +jpImageShowCS (JP.ImageYF _) = "YF (Pixel Y Float)" +jpImageShowCS (JP.ImageYA8 _) = "YA8 (Pixel YA Word8)" +jpImageShowCS (JP.ImageYA16 _) = "YA16 (Pixel YA Word16)" +jpImageShowCS (JP.ImageRGB8 _) = "RGB8 (Pixel RGB Word8)" +jpImageShowCS (JP.ImageRGB16 _) = "RGB16 (Pixel RGB Word16)" +jpImageShowCS (JP.ImageRGBF _) = "RGBF (Pixel RGB Float)" +jpImageShowCS (JP.ImageRGBA8 _) = "RGBA8 (Pixel RGBA Word8)" +jpImageShowCS (JP.ImageRGBA16 _) = "RGBA16 (Pixel RGBA Word16)" +jpImageShowCS (JP.ImageYCbCr8 _) = "YCbCr8 (Pixel YCbCr Word8)" +jpImageShowCS (JP.ImageCMYK8 _) = "CMYK8 (Pixel CMYK Word8)" +jpImageShowCS (JP.ImageCMYK16 _) = "CMYK16 (Pixel CMYK Word16)" + + +jpError :: String -> Either String a +jpError err = Left ("JuicyPixel decoding error: "++err) + + +jpCSError :: String -> Either String JP.DynamicImage -> Either String a +jpCSError _ (Left err) = jpError err +jpCSError cs (Right jimg) = jpError ("Input image is in "++(jpImageShowCS jimg)++ + ", cannot convert it to "++cs++" colorspace.") + + +-------------------------------------------------------------------------------- +-- Encoding images using JuicyPixels ------------------------------------------- +-------------------------------------------------------------------------------- + +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) + +instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) + +instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . fromPixelBinary) + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . toWord8) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . toWord8 . dropAlpha) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8) + +instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) + . toWord8) + +-- Writable GIF + +encodeGIF :: ManifestArray arr cs e => + [SaveOption GIF] -> (Pixel cs e -> JP.PixelRGB8) + -> Image arr cs e -> BL.ByteString +encodeGIF [] !conv = + either error id . uncurry JP.encodeGifImageWithPalette . + JP.palettize JP.defaultPaletteOptions . imageToJPImage conv +encodeGIF (GIFPalette palOpts:_) !conv = + either error id . uncurry JP.encodeGifImageWithPalette . + JP.palettize palOpts . imageToJPImage conv + + +instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) GIF where + encode _ opts = encodeGIF opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) GIF where + encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8 . toPixelRGB) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) GIF where + encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8 . toPixelRGB . dropAlpha) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) GIF where + encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8) + +instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) GIF where + encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8 . dropAlpha) + + +encodeGIFs :: ManifestArray arr cs e => + [SaveOption [GIF]] -> (Pixel cs e -> JP.PixelRGB8) + -> [(JP.GifDelay, Image arr cs e)] -> BL.ByteString +encodeGIFs !opts !conv = + either error id . JP.encodeGifImages (getGIFsLoop opts) . map palletizeGif where + getGIFsLoop [] = JP.LoopingNever + getGIFsLoop (GIFsLooping loop:_) = loop + getGIFsLoop (_:xs) = getGIFsLoop xs + getGIFsPal [] = JP.defaultPaletteOptions + getGIFsPal (GIFsPalette palOpts:_) = palOpts + getGIFsPal (_:xs) = getGIFsPal xs + palletizeGif !(d, img) = (p, d, jimg) where + !(jimg, p) = JP.palettize (getGIFsPal opts) $ imageToJPImage conv img + + +instance ManifestArray arr RGB Word8 => Writable [(JP.GifDelay, Image arr RGB Word8)] [GIF] where + encode _ opts = encodeGIFs opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr RGB Double => Writable [(JP.GifDelay, Image arr RGB Double)] [GIF] where + encode _ opts = encodeGIFs opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8) + +-- Writable HDR + +instance ManifestArray arr RGB Float => Writable (Image arr RGB Float) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage (convert :: Pixel RGB Float -> JP.PixelRGBF) + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) + . toFloat . toPixelRGB) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) + . toFloat . toPixelRGB . dropAlpha) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) + . toFloat) + +instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF) + . toFloat . dropAlpha) + + +-- Writable JPG + + +encodeJPG :: (JP.JpgEncodable px, ManifestArray arr cs e) => + [SaveOption JPG] -> (Pixel cs e -> px) -> Image arr cs e -> BL.ByteString +encodeJPG [] conv = + JP.encodeDirectJpegAtQualityWithMetadata 100 mempty . imageToJPImage conv +encodeJPG (JPGQuality q:_) conv = + JP.encodeDirectJpegAtQualityWithMetadata q mempty . imageToJPImage conv + + +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) JPG where + encode _ opts = encodeJPG opts (convert :: Pixel Y Word8 -> JP.Pixel8) + +instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) JPG where + encode _ opts = encodeJPG opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr CMYK Word8 => Writable (Image arr CMYK Word8) JPG where + encode _ opts = encodeJPG opts (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) + +instance ManifestArray arr YCbCr Word8 => Writable (Image arr YCbCr Word8) JPG where + encode _ opts = encodeJPG opts (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) JPG where + encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8) + . toWord8) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) JPG where + encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8) + . toWord8 . dropAlpha) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) JPG where + encode _ opts = encodeJPG opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8) + +instance ManifestArray arr CMYK Double => Writable (Image arr CMYK Double) JPG where + encode _ opts = encodeJPG opts ((convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) + . toWord8) + +instance ManifestArray arr YCbCr Double => Writable (Image arr YCbCr Double) JPG where + encode _ opts = encodeJPG opts ((convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) + . toWord8) + +-- Writable PNG + +instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) PNG where + encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . fromPixelBinary) + +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) + +instance ManifestArray arr Y Word16 => Writable (Image arr Y Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) + +instance ManifestArray arr YA Word8 => Writable (Image arr YA Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) + +instance ManifestArray arr YA Word16 => Writable (Image arr YA Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) + +instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr RGB Word16 => Writable (Image arr RGB Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) + +instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) + +instance ManifestArray arr RGBA Word16 => Writable (Image arr RGBA Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) + + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16) + . toWord16) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16) + . toWord16) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16) + . toWord16) + +instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) + . toWord16) + +-- Writable TGA + +instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) TGA where + encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . fromPixelBinary) + +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) + +instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) + + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . toWord8) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . toWord8 . dropAlpha) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8) + . toWord8) + +instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) + . toWord8) + +-- Writable TIF + +instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) + +instance ManifestArray arr Y Word16 => Writable (Image arr Y Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) + +instance ManifestArray arr YA Word8 => Writable (Image arr YA Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) + +instance ManifestArray arr YA Word16 => Writable (Image arr YA Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) + +instance ManifestArray arr RGB Word8 => Writable (Image arr RGB Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) + +instance ManifestArray arr RGB Word16 => Writable (Image arr RGB Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) + +instance ManifestArray arr RGBA Word8 => Writable (Image arr RGBA Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) + +instance ManifestArray arr RGBA Word16 => Writable (Image arr RGBA Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) + +instance ManifestArray arr YCbCr Word8 => Writable (Image arr YCbCr Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) + +instance ManifestArray arr CMYK Word8 => Writable (Image arr CMYK Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) + +instance ManifestArray arr CMYK Word16 => Writable (Image arr CMYK Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word16 -> JP.PixelCMYK16) + + +instance ManifestArray arr Binary Bit => Writable (Image arr Binary Bit) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) + . fromPixelBinary) + +instance ManifestArray arr Y Double => Writable (Image arr Y Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16) + . toWord16) + +instance ManifestArray arr YA Double => Writable (Image arr YA Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16) + . toWord16) + +instance ManifestArray arr RGB Double => Writable (Image arr RGB Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16) + . toWord16) + +instance ManifestArray arr RGBA Double => Writable (Image arr RGBA Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) + . toWord16) + +instance ManifestArray arr YCbCr Double => Writable (Image arr YCbCr Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) + . toWord8) + +instance ManifestArray arr CMYK Double => Writable (Image arr CMYK Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel CMYK Word16 -> JP.PixelCMYK16) + . toWord16) + + + +imageToJPImage :: (JP.Pixel a, ManifestArray arr cs e) => + (Pixel cs e -> a) -> Image arr cs e -> JP.Image a +imageToJPImage !f img@(dims -> (m, n)) = JP.generateImage g n m + where g !j !i = f (index img (i, j)) + {-# INLINE g #-} +{-# INLINE imageToJPImage #-} + + + diff --git a/src/Graphics/Image/IO/External/Netpbm.hs b/src/Graphics/Image/IO/External/Netpbm.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/External/Netpbm.hs @@ -0,0 +1,286 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} +module Graphics.Image.IO.External.Netpbm ( + PBM(..), PGM(..), PPM(..) + ) where + + +import Graphics.Image.ColorSpace +import Graphics.Image.Interface hiding (map) +import Graphics.Image.IO.Base +import Foreign.Storable (Storable) +import qualified Data.ByteString as B (ByteString) +import qualified Graphics.Netpbm as PNM +import qualified Data.Vector.Storable as VS ((!), Vector) + + +data PBM = PBM -- ^ Netpbm: portable bitmap image with .pbm extension. + +instance ImageFormat PBM where + data SaveOption PBM + + ext _ = ".pbm" + + +data PGM = PGM -- ^ Netpbm: portable graymap image with .pgm extension. + +instance ImageFormat PGM where + data SaveOption PGM + + ext _ = ".pgm" + + +data PPM = PPM -- ^ Netpbm: portable pixmap image with .ppm extension. + +instance ImageFormat PPM where + data SaveOption PPM + + ext _ = ".ppm" + + +instance ImageFormat [PBM] where + data SaveOption [PBM] + + ext _ = ".pbm" + + +instance ImageFormat [PGM] where + data SaveOption [PGM] + + ext _ = ".pgm" + + +instance ImageFormat [PPM] where + data SaveOption [PPM] + + ext _ = ".ppm" + + +-------------------------------------------------------------------------------- +-- Converting to and from Netpbm ----------------------------------------------- +-------------------------------------------------------------------------------- + +-- -> Y (Double) + +instance Convertible PNM.PbmPixel (Pixel Y Double) where + convert (PNM.PbmPixel bool) = PixelY $ if bool then 0 else 1 + +instance Convertible PNM.PgmPixel8 (Pixel Y Double) where + convert (PNM.PgmPixel8 w8) = toDouble . PixelY $ w8 + +instance Convertible PNM.PgmPixel16 (Pixel Y Double) where + convert (PNM.PgmPixel16 w16) = toDouble . PixelY $ w16 + +instance Convertible PNM.PpmPixelRGB8 (Pixel Y Double) where + convert (PNM.PpmPixelRGB8 r g b) = toPixelY . toDouble $ PixelRGB r g b + +instance Convertible PNM.PpmPixelRGB16 (Pixel Y Double) where + convert (PNM.PpmPixelRGB16 r g b) = toPixelY . toDouble $ PixelRGB r g b + +-- -> YA (Double) + +instance Convertible PNM.PbmPixel (Pixel YA Double) where + convert = addAlpha 1 . (convert :: PNM.PbmPixel -> Pixel Y Double) + +instance Convertible PNM.PgmPixel8 (Pixel YA Double) where + convert = addAlpha 1 . (convert :: PNM.PgmPixel8 -> Pixel Y Double) + +instance Convertible PNM.PgmPixel16 (Pixel YA Double) where + convert = addAlpha 1 . (convert :: PNM.PgmPixel16 -> Pixel Y Double) + +instance Convertible PNM.PpmPixelRGB8 (Pixel YA Double) where + convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB8 -> Pixel Y Double) + +instance Convertible PNM.PpmPixelRGB16 (Pixel YA Double) where + convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB16 -> Pixel Y Double) + +-- -> RGB (Double) + +instance Convertible PNM.PbmPixel (Pixel RGB Double) where + convert = toPixelRGB . (convert :: PNM.PbmPixel -> Pixel Y Double) + +instance Convertible PNM.PgmPixel8 (Pixel RGB Double) where + convert = toPixelRGB . (convert :: PNM.PgmPixel8 -> Pixel Y Double) + +instance Convertible PNM.PgmPixel16 (Pixel RGB Double) where + convert = toPixelRGB . (convert :: PNM.PgmPixel16 -> Pixel Y Double) + +instance Convertible PNM.PpmPixelRGB8 (Pixel RGB Double) where + convert (PNM.PpmPixelRGB8 r g b) = toDouble $ PixelRGB r g b + +instance Convertible PNM.PpmPixelRGB16 (Pixel RGB Double) where + convert (PNM.PpmPixelRGB16 r g b) = toDouble $ PixelRGB r g b + + +-- -> RGBA (Double) + +instance Convertible PNM.PbmPixel (Pixel RGBA Double) where + convert = addAlpha 1 . (convert :: PNM.PbmPixel -> Pixel RGB Double) + +instance Convertible PNM.PgmPixel8 (Pixel RGBA Double) where + convert = addAlpha 1 . (convert :: PNM.PgmPixel8 -> Pixel RGB Double) + +instance Convertible PNM.PgmPixel16 (Pixel RGBA Double) where + convert = addAlpha 1 . (convert :: PNM.PgmPixel16 -> Pixel RGB Double) + +instance Convertible PNM.PpmPixelRGB8 (Pixel RGBA Double) where + convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB8 -> Pixel RGB Double) + +instance Convertible PNM.PpmPixelRGB16 (Pixel RGBA Double) where + convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB16 -> Pixel RGB Double) + + +---- Exact precision conversions + + +instance Convertible PNM.PbmPixel (Pixel Binary Bit) where + convert (PNM.PbmPixel bool) = fromBool bool + +instance Convertible PNM.PgmPixel8 (Pixel Y Word8) where + convert (PNM.PgmPixel8 w8) = PixelY w8 + +instance Convertible PNM.PgmPixel16 (Pixel Y Word16) where + convert (PNM.PgmPixel16 w16) = PixelY w16 + +instance Convertible PNM.PpmPixelRGB8 (Pixel RGB Word8) where + convert (PNM.PpmPixelRGB8 r g b) = PixelRGB r g b + +instance Convertible PNM.PpmPixelRGB16 (Pixel RGB Word16) where + convert (PNM.PpmPixelRGB16 r g b) = PixelRGB r g b + + +-------------------------------------------------------------------------------- +-- Decoding images using Netpbm ------------------------------------------------ +-------------------------------------------------------------------------------- + + +-- BMP Format Reading (general) + +instance Array arr Y Double => Readable (Image arr Y Double) PBM where + decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm + +instance Array arr Y Double => Readable (Image arr Y Double) PGM where + decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm + +instance Array arr Y Double => Readable (Image arr Y Double) PPM where + decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm + +instance Array arr YA Double => Readable (Image arr YA Double) PPM where + decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm + +instance Array arr RGB Double => Readable (Image arr RGB Double) PPM where + decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage id) . head) . decodePnm + +instance Array arr RGBA Double => Readable (Image arr RGBA Double) PPM where + decode _ = either Left (Right . ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm + +-- BMP Format Reading (exact) + +instance Array arr Binary Bit => Readable (Image arr Binary Bit) PBM where + decode _ = either Left (ppmToImageUsing pnmDataPBMToImage . head) . decodePnm + +instance Array arr Y Word8 => Readable (Image arr Y Word8) PGM where + decode _ = either Left (ppmToImageUsing pnmDataPGM8ToImage . head) . decodePnm + +instance Array arr Y Word16 => Readable (Image arr Y Word16) PGM where + decode _ = either Left (ppmToImageUsing pnmDataPGM16ToImage . head) . decodePnm + +instance Array arr RGB Word8 => Readable (Image arr RGB Word8) PPM where + decode _ = either Left (ppmToImageUsing pnmDataPPM8ToImage . head) . decodePnm + +instance Array arr RGB Word16 => Readable (Image arr RGB Word16) PPM where + decode _ = either Left (ppmToImageUsing pnmDataPPM16ToImage . head) . decodePnm + + +instance Array arr Binary Bit => Readable [Image arr Binary Bit] [PBM] where + decode _ = pnmToImagesUsing pnmDataPBMToImage + +instance Array arr Y Word8 => Readable [Image arr Y Word8] [PGM] where + decode _ = pnmToImagesUsing pnmDataPGM8ToImage + +instance Array arr Y Word16 => Readable [Image arr Y Word16] [PGM] where + decode _ = pnmToImagesUsing pnmDataPGM16ToImage + +instance Array arr RGB Word8 => Readable [Image arr RGB Word8] [PPM] where + decode _ = pnmToImagesUsing pnmDataPPM8ToImage + +instance Array arr RGB Word16 => Readable [Image arr RGB Word16] [PPM] where + decode _ = pnmToImagesUsing pnmDataPPM16ToImage + + +pnmToImagesUsing :: (Int -> Int -> PNM.PpmPixelData -> Either [Char] b) + -> B.ByteString -> Either String [b] +pnmToImagesUsing conv = + either Left (Right . map (either error id . ppmToImageUsing conv)) . decodePnm + + +getPx :: (Storable a, Convertible a b) => VS.Vector a -> Int -> (Int, Int) -> b +getPx v w (i, j) = convert (v VS.! (i * w + j)) + + +pnmDataToImage :: (Array arr cs e, Convertible PNM.PbmPixel px, + Convertible PNM.PgmPixel16 px, Convertible PNM.PgmPixel8 px, + Convertible PNM.PpmPixelRGB16 px, Convertible PNM.PpmPixelRGB8 px) => + (px -> Pixel cs e) -> Int -> Int -> PNM.PpmPixelData -> Image arr cs e +pnmDataToImage conv w h (PNM.PbmPixelData v) = make (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PgmPixelData8 v) = make (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PgmPixelData16 v) = make (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PpmPixelDataRGB8 v) = make (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PpmPixelDataRGB16 v) = make (h, w) (conv . getPx v w) + + +pnmDataPBMToImage :: (Array arr cs e, Convertible PNM.PbmPixel (Pixel cs e)) => + Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) +pnmDataPBMToImage w h (PNM.PbmPixelData v) = Right $ make (h, w) (getPx v w) +pnmDataPBMToImage _ _ d = pnmCSError "Binary (Pixel Binary Bit)" d + +pnmDataPGM8ToImage :: (Array arr cs e, Convertible PNM.PgmPixel8 (Pixel cs e)) => + Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) +pnmDataPGM8ToImage w h (PNM.PgmPixelData8 v) = Right $ make (h, w) (getPx v w) +pnmDataPGM8ToImage _ _ d = pnmCSError "Y8 (Pixel Y Word8)" d + +pnmDataPGM16ToImage :: (Array arr cs e, Convertible PNM.PgmPixel16 (Pixel cs e)) => + Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) +pnmDataPGM16ToImage w h (PNM.PgmPixelData16 v) = Right $ make (h, w) (getPx v w) +pnmDataPGM16ToImage _ _ d = pnmCSError "Y16 (Pixel Y Word16)" d + +pnmDataPPM8ToImage :: (Array arr cs e, Convertible PNM.PpmPixelRGB8 (Pixel cs e)) => + Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) +pnmDataPPM8ToImage w h (PNM.PpmPixelDataRGB8 v) = Right $ make (h, w) (getPx v w) +pnmDataPPM8ToImage _ _ d = pnmCSError "RGB8 (Pixel RGB Word8)" d + +pnmDataPPM16ToImage :: (Array arr cs e, Convertible PNM.PpmPixelRGB16 (Pixel cs e)) => + Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) +pnmDataPPM16ToImage w h (PNM.PpmPixelDataRGB16 v) = Right $ make (h, w) (getPx v w) +pnmDataPPM16ToImage _ _ d = pnmCSError "RGB16 (Pixel RGB Word16)" d + + +ppmToImageUsing :: (Int -> Int -> PNM.PpmPixelData -> t) -> PNM.PPM -> t +ppmToImageUsing conv (PNM.PPM { PNM.ppmHeader = PNM.PPMHeader { PNM.ppmWidth = w + , PNM.ppmHeight = h } + , PNM.ppmData = ppmData }) = conv w h ppmData + + +decodePnm :: B.ByteString -> Either String [PNM.PPM] +decodePnm = pnmResultToImage . PNM.parsePPM where + pnmResultToImage (Right ([], _)) = pnmError "Unknown" + pnmResultToImage (Right (ppms, _)) = Right ppms + pnmResultToImage (Left err) = pnmError err + + + + +pnmError :: String -> Either String a +pnmError err = Left ("Netpbm decoding error: "++err) + + +pnmCSError :: String -> PNM.PpmPixelData -> Either String a +pnmCSError cs ppmData = pnmError ("Input image is in "++(pnmShowData ppmData)++ + ", cannot convert it to "++cs++" colorspace.") + +pnmShowData :: PNM.PpmPixelData -> String +pnmShowData (PNM.PbmPixelData _) = "Binary (Pixel Binary Bit)" +pnmShowData (PNM.PgmPixelData8 _) = "Y8 (Pixel Y Word8)" +pnmShowData (PNM.PgmPixelData16 _) = "Y16 (Pixel Y Word16)" +pnmShowData (PNM.PpmPixelDataRGB8 _) = "RGB8 (Pixel RGB Word8)" +pnmShowData (PNM.PpmPixelDataRGB16 _) = "RGB8 (Pixel RGB Word8)" diff --git a/src/Graphics/Image/Interface.hs b/src/Graphics/Image/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface.hs @@ -0,0 +1,561 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, ScopedTypeVariables, + TypeFamilies, UndecidableInstances, ViewPatterns #-} + +module Graphics.Image.Interface ( + ColorSpace(..), Alpha(..), Elevator(..), + Array(..), ManifestArray(..), SequentialArray(..), MutableArray(..), + Exchangable(..), + defaultIndex, maybeIndex, Border(..), borderIndex + ) where + +import Prelude hiding (and, map, zipWith, sum, product) +import GHC.Exts (Constraint) +import Data.Typeable (Typeable, showsTypeRep, typeOf) +import Data.Monoid (Monoid) +import Control.DeepSeq (NFData(rnf)) +import Data.Word +import Data.Foldable (Foldable(foldMap)) +import Control.Applicative +import Control.Monad.Primitive (PrimMonad (..)) + + +-- | This class has all included color spaces installed into it and is also +-- intended for implementing any other possible custom color spaces. Every +-- instance of this class automatically installs an associated 'Pixel' into +-- 'Num', 'Fractional', 'Floating', 'Functor', 'Applicative' and 'Foldable', +-- which in turn make it possible to be used by the rest of the library. +class (Eq cs, Enum cs, Show cs, Typeable cs) => ColorSpace cs where + + -- | Representation of a pixel, such that it can be an element of any + -- Array. Which is usally a tuple of channels or a channel itself for single + -- channel color spaces. + type PixelElt cs e + + -- | A concrete Pixel representation for a particular color space. + data Pixel cs e + + -- | Construt a pixel by replicating a same value among all of the channels. + fromChannel :: e -> Pixel cs e + + -- | Convert a Pixel to a representation suitable for storage as an unboxed + -- element, usually a tuple of channels. + toElt :: Pixel cs e -> PixelElt cs e + + -- | Convert from an elemnt representation back to a Pixel. + fromElt :: PixelElt cs e -> Pixel cs e + + -- | Retrieve Pixel's channel value + getPxCh :: Pixel cs e -> cs -> e + + -- | Map a channel aware function over all Pixel's channels. + chOp :: (cs -> e' -> e) -> Pixel cs e' -> Pixel cs e + + -- | Map a function over all Pixel's channels. + pxOp :: (e' -> e) -> Pixel cs e' -> Pixel cs e + + -- | Function application to a Pixel. + chApp :: Pixel cs (e' -> e) -> Pixel cs e' -> Pixel cs e + + -- | A pixel eqiuvalent of 'foldMap'. + pxFoldMap :: Monoid m => (e -> m) -> Pixel cs e -> m + + +class (ColorSpace (Opaque cs), ColorSpace cs) => Alpha cs where + -- | An opaque version of this color space. + type Opaque cs + + -- | Get an alpha channel of a transparant pixel. + getAlpha :: Pixel cs e -> e + + -- | Add an alpha channel of an opaque pixel. + -- + -- @ addAlpha 0 (PixelHSI 1 2 3) == PixelHSIA 1 2 3 0 @ + addAlpha :: e -> Pixel (Opaque cs) e -> Pixel cs e + + -- | Convert a transparent pixel to an opaque one by dropping the alpha + -- channel. + -- + -- @ dropAlpha (PixelRGBA 1 2 3 4) == PixelRGB 1 2 3 @ + -- + dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e + + + +-- | A class with a set of convenient functions that allow for changing precision of +-- channels within pixels, while scaling the values to keep them in an appropriate range. +-- +-- >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double +-- >>> toWord8 rgb +-- +-- +class Elevator e where + + toWord8 :: ColorSpace cs => Pixel cs e -> Pixel cs Word8 + + toWord16 :: ColorSpace cs => Pixel cs e -> Pixel cs Word16 + + toWord32 :: ColorSpace cs => Pixel cs e -> Pixel cs Word32 + + toWord64 :: ColorSpace cs => Pixel cs e -> Pixel cs Word64 + + toFloat :: ColorSpace cs => Pixel cs e -> Pixel cs Float + + toDouble :: ColorSpace cs => Pixel cs e -> Pixel cs Double + + fromDouble :: ColorSpace cs => Pixel cs Double -> Pixel cs e + + +class (Show arr, ColorSpace cs, Num (Pixel cs e), Num e, Typeable e, Elt arr cs e) => + Array arr cs e where + + type Elt arr cs e :: Constraint + type Elt arr cs e = () + data Image arr cs e + + -- | Create an Image by supplying it's dimensions and a pixel genrating + -- function. + make :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. + -> ((Int, Int) -> Pixel cs e) + -- ^ A function that takes (@i@-th row, and @j@-th column) as an + -- argument and returns a pixel for that location. + -> Image arr cs e + + -- | Create a singleton image, required for various operations on images with + -- a scalar. + singleton :: Pixel cs e -> Image arr cs e + + -- | Get dimensions of an image. + -- + -- >>> frog <- readImageRGB "images/frog.jpg" + -- >>> frog + -- + -- >>> dims frog + -- (200,320) + -- + dims :: Image arr cs e -> (Int, Int) + + -- | Map a function over a an image. + map :: Array arr cs' e' => + (Pixel cs' e' -> Pixel cs e) + -- ^ A function that takes a pixel of a source image and returns a pixel + -- for the result image a the same location. + -> Image arr cs' e' -- ^ Source image. + -> Image arr cs e -- ^ Result image. + + -- | Map an index aware function over each pixel in an image. + imap :: Array arr cs' e' => + ((Int, Int) -> Pixel cs' e' -> Pixel cs e) + -- ^ A function that takes an index @(i, j)@, a pixel at that location + -- and returns a new pixel at the same location for the result image. + -> Image arr cs' e' -- ^ Source image. + -> Image arr cs e -- ^ Result image. + + -- | Zip two images with a function + zipWith :: (Array arr cs1 e1, Array arr cs2 e2) => + (Pixel cs1 e1 -> Pixel cs2 e2 -> Pixel cs e) + -> Image arr cs1 e1 -> Image arr cs2 e2 -> Image arr cs e + + -- | Zip two images with an index aware function + izipWith :: (Array arr cs1 e1, Array arr cs2 e2) => + ((Int, Int) -> Pixel cs1 e1 -> Pixel cs2 e2 -> Pixel cs e) + -> Image arr cs1 e1 -> Image arr cs2 e2 -> Image arr cs e + + -- | Traverse an image + traverse :: Array arr cs' e' => + Image arr cs' e' -- ^ Source image. + -> ((Int, Int) -> (Int, Int)) + -- ^ Function that takes dimensions of a source image and returns + -- dimensions of a new image. + -> (((Int, Int) -> Pixel cs' e') -> + (Int, Int) -> Pixel cs e) + -- ^ Function that receives a pixel getter (a source image index + -- function), a location @(i, j)@ in a new image and returns a pixel + -- for that location. + -> Image arr cs e + + -- | Traverse two images. + traverse2 :: (Array arr cs1 e1, Array arr cs2 e2) => + Image arr cs1 e1 -- ^ First source image. + -> Image arr cs2 e2 -- ^ Second source image. + -> ((Int, Int) -> (Int, Int) -> (Int, Int)) + -- ^ Function that produces dimensions for the new image. + -> (((Int, Int) -> Pixel cs1 e1) -> + ((Int, Int) -> Pixel cs2 e2) -> + (Int, Int) -> Pixel cs e) + -- ^ Function that produces pixels for the new image. + -> Image arr cs e + + -- | Transpose an image + transpose :: Image arr cs e -> Image arr cs e + + -- | Backwards permutation of an image. + backpermute :: (Int, Int) -- ^ Dimensions of a result image. + -> ((Int, Int) -> (Int, Int)) + -- ^ Function that maps an index of a source image to an index + -- of a result image. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e -- ^ Result image. + + -- | Construct an image from a nested rectangular shaped list of pixels. + -- Length of an outer list will constitute @m@ rows, while the length of inner lists - + -- @n@ columns. All of the inner lists must be the same length and greater than @0@. + -- + -- >>> fromLists [[PixelY (fromIntegral (i*j) / 60000) | j <- [1..300]] | i <- [1..200]] :: Image VU Y Double + -- + -- + -- <> + -- + fromLists :: [[Pixel cs e]] + -> Image arr cs e + + +class Array arr cs e => ManifestArray arr cs e where + + -- | Get a pixel at @i@-th and @j@-th location. + -- + -- >>> let grad_gray = computeS $ makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200) + -- >>> index grad_gray (20, 30) == PixelY ((20*30) / (200*200)) + -- True + -- + index :: Image arr cs e -> (Int, Int) -> Pixel cs e + + -- | Make sure that an image is fully evaluated. + deepSeqImage :: Image arr cs e -> a -> a + + -- | Perform matrix multiplication on two images. Inner dimensions must agree. + (|*|) :: Image arr cs e -> Image arr cs e -> Image arr cs e + + -- | Undirected reduction of an image. + fold :: (Pixel cs e -> Pixel cs e -> Pixel cs e) -- ^ An associative folding function. + -> Pixel cs e -- ^ Initial element, that is neutral with respect to the folding function. + -> Image arr cs e -- ^ Source image. + -> Pixel cs e + + -- | Pixelwise equality function of two images. Images are + -- considered distinct if either images' dimensions or at least one pair of + -- corresponding pixels are not the same. Used in defining an in instance for + -- the 'Eq' typeclass. + eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool + + +class ManifestArray arr cs e => SequentialArray arr cs e where + + foldl :: (a -> Pixel cs e -> a) -> a -> Image arr cs e -> a + + foldr :: (Pixel cs e -> a -> a) -> a -> Image arr cs e -> a + + mapM :: (Array arr cs' e', Monad m) => + (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m (Image arr cs e) + + mapM_ :: (Array arr cs' e', Monad m) => + (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m () + + foldM :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m a + + foldM_ :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m () + + +class ManifestArray arr cs e => MutableArray arr cs e where + data MImage st arr cs e + + mdims :: MImage st arr cs e -> (Int, Int) + + thaw :: PrimMonad m => Image arr cs e -> m (MImage (PrimState m) arr cs e) + + freeze :: PrimMonad m => MImage (PrimState m) arr cs e -> m (Image arr cs e) + + new :: PrimMonad m => (Int, Int) -> m (MImage (PrimState m) arr cs e) + + read :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> m (Pixel cs e) + + write :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m () + + swap :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m () + + +class Exchangable arr' arr where + + -- | Exchange the underlying array representation of an image. + exchange :: (Array arr' cs e, Array arr cs e) => + arr -- ^ New representation of an image. + -> Image arr' cs e -- ^ Source image. + -> Image arr cs e + + +-- | Changing to the same array representation as before is disabled and `changeTo` +-- will behave simply as an identitity function. +instance Exchangable arr arr where + + exchange _ = id + {-# INLINE exchange #-} + + + +-- | Approach to be used near the border during transformations, which, besides a pixel +-- of interest, also use it's neighbors, consequently going out of bounds at the +-- edges of an image. +data Border px = + Fill !px -- ^ Fill in a constant pixel. + -- + -- @ + -- outside | Image | outside + -- ('Fill' 0) : 0 0 0 0 | 1 2 3 4 | 0 0 0 0 + -- @ + -- + | Wrap -- ^ Wrap around from the opposite border of the image. + -- + -- @ + -- outside | Image | outside + -- 'Wrap' : 1 2 3 4 | 1 2 3 4 | 1 2 3 4 + -- @ + -- + | Edge -- ^ Replicate the pixel at the edge. + -- + -- @ + -- outside | Image | outside + -- 'Edge' : 1 1 1 1 | 1 2 3 4 | 4 4 4 4 + -- @ + -- + | Reflect -- ^ Mirror like reflection. + -- + -- @ + -- outside | Image | outside + -- 'Reflect' : 4 3 2 1 | 1 2 3 4 | 4 3 2 1 + -- @ + -- + | Continue -- ^ Also mirror like reflection, but without repeating the edge pixel. + -- + -- @ + -- outside | Image | outside + -- 'Continue' : 1 4 3 2 | 1 2 3 4 | 3 2 1 4 + -- @ + -- + +-- | Border handling function. If @(i, j)@ location is within bounds, then supplied +-- lookup function will be used, otherwise it will be handled according to a +-- supplied border strategy. +borderIndex :: Border (Pixel cs e) -- ^ Border handling strategy. + -> (Int, Int) -- ^ Image dimensions + -> ((Int, Int) -> Pixel cs e) -- ^ Image's indexing function. + -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup. + -> Pixel cs e +borderIndex border !(m, n) !getPx !(i, j) = + if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else getPxB border where + getPxB (Fill px) = px + getPxB Wrap = getPx (i `mod` m, j `mod` n) + getPxB Edge = getPx (if i < 0 then 0 else if i >= m then m - 1 else i, + if j < 0 then 0 else if j >= n then n - 1 else j) + getPxB Reflect = getPx (if i < 0 then (abs i - 1) `mod` m else + if i >= m then (m - (i - m + 1)) `mod` m else i, + if j < 0 then (abs j - 1) `mod` n else + if j >= n then (n - (j - n + 1)) `mod` n else j) + getPxB Continue = getPx (if i < 0 then abs i `mod` m else + if i >= m then m - (i - m + 2) `mod` m else i, + if j < 0 then abs j `mod` n else + if j >= n then n - (j - n + 2) `mod` n else j) + {-# INLINE getPxB #-} +{-# INLINE borderIndex #-} + + +-- | Image indexing function that returns a default pixel if index is out of bounds. +defaultIndex :: ManifestArray arr cs e => + Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e +defaultIndex !px !img = borderIndex (Fill px) (dims img) (index img) +{-# INLINE defaultIndex #-} + + +-- | Image indexing function that returns 'Nothing' if index is out of bounds, +-- 'Just' pixel otherwise. +maybeIndex :: ManifestArray arr cs e => + Image arr cs e -> (Int, Int) -> Maybe (Pixel cs e) +maybeIndex !img@(dims -> (m, n)) !(i, j) = + if i >= 0 && j >= 0 && i < m && j < n then Just $ index img (i, j) else Nothing +{-# INLINE maybeIndex #-} + + + +instance ColorSpace cs => Functor (Pixel cs) where + + fmap = pxOp + +instance ColorSpace cs => Applicative (Pixel cs) where + + pure = fromChannel + + (<*>) = chApp + +instance ColorSpace cs => Foldable (Pixel cs) where + + foldMap = pxFoldMap + + +instance (ColorSpace cs, Num e) => Num (Pixel cs e) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + + (-) = liftA2 (-) + {-# INLINE (-) #-} + + (*) = liftA2 (*) + {-# INLINE (*) #-} + + abs = liftA abs + {-# INLINE abs #-} + + signum = liftA signum + {-# INLINE signum #-} + + fromInteger = pure . fromInteger + {-# INLINE fromInteger#-} + + +instance (ColorSpace cs, Fractional e) => Fractional (Pixel cs e) where + (/) = liftA2 (/) + {-# INLINE (/) #-} + + recip = liftA recip + {-# INLINE recip #-} + + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance (ColorSpace cs, Floating e) => Floating (Pixel cs e) where + pi = fromChannel pi + {-# INLINE pi #-} + + exp = liftA exp + {-# INLINE exp #-} + + log = liftA log + {-# INLINE log #-} + + sin = liftA sin + {-# INLINE sin #-} + + cos = liftA cos + {-# INLINE cos #-} + + asin = liftA asin + {-# INLINE asin #-} + + atan = liftA atan + {-# INLINE atan #-} + + acos = liftA acos + {-# INLINE acos #-} + + sinh = liftA sinh + {-# INLINE sinh #-} + + cosh = liftA cosh + {-# INLINE cosh #-} + + asinh = liftA asinh + {-# INLINE asinh #-} + + atanh = liftA atanh + {-# INLINE atanh #-} + + acosh = liftA acosh + {-# INLINE acosh #-} + + +instance (ManifestArray arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where + (==) = eq + {-# INLINE (==) #-} + + +instance Array arr cs e => Num (Image arr cs e) where + (+) = zipWith (+) + {-# INLINE (+) #-} + + (-) = zipWith (-) + {-# INLINE (-) #-} + + (*) = zipWith (*) + {-# INLINE (*) #-} + + abs = map abs + {-# INLINE abs #-} + + signum = map signum + {-# INLINE signum #-} + + fromInteger = singleton . fromInteger + {-# INLINE fromInteger#-} + + +instance (Fractional (Pixel cs e), Fractional e, Array arr cs e) => + Fractional (Image arr cs e) where + (/) = zipWith (/) + {-# INLINE (/) #-} + + fromRational = singleton . fromRational + {-# INLINE fromRational #-} + + +instance (Floating (Pixel cs e), Floating e, Array arr cs e) => + Floating (Image arr cs e) where + pi = singleton pi + {-# INLINE pi #-} + + exp = map exp + {-# INLINE exp #-} + + log = map log + {-# INLINE log#-} + + sin = map sin + {-# INLINE sin #-} + + cos = map cos + {-# INLINE cos #-} + + asin = map asin + {-# INLINE asin #-} + + atan = map atan + {-# INLINE atan #-} + + acos = map acos + {-# INLINE acos #-} + + sinh = map sinh + {-# INLINE sinh #-} + + cosh = map cosh + {-# INLINE cosh #-} + + asinh = map asinh + {-# INLINE asinh #-} + + atanh = map atanh + {-# INLINE atanh #-} + + acosh = map acosh + {-# INLINE acosh #-} + + +instance ManifestArray arr cs e => NFData (Image arr cs e) where + rnf img = img `deepSeqImage` () + {-# INLINE rnf #-} + + + +instance Array arr cs e => Show (Image arr cs e) where + show ((dims -> (m, n)) :: Image arr cs e) = + "") + + +instance MutableArray arr cs e => Show (MImage st arr cs e) where + show ((mdims -> (m, n)) :: MImage st arr cs e) = + "") + + diff --git a/src/Graphics/Image/Interface/Repa.hs b/src/Graphics/Image/Interface/Repa.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface/Repa.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Image.Interface.Repa ( + -- * Construction + makeImage, + -- * IO + readImageY, readImageYA, readImageRGB, readImageRGBA, + -- * Computation + computeS, computeP, delay, + -- * Representation + RD(..), RS(..), RP(..), + ) where + +import Graphics.Image.IO +import Graphics.Image.Interface +import Graphics.Image.Interface.Repa.Internal +import Graphics.Image.ColorSpace + + +-- | Create a delayed representation of an image. +makeImage :: Array RD cs Double => + (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. + -> ((Int, Int) -> Pixel cs Double) + -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument + -- and returns a pixel for that location. + -> Image RD cs Double +makeImage = make +{-# INLINE makeImage #-} + + +-- | Read image as luma (brightness). +readImageY :: FilePath -> IO (Image RD Y Double) +readImageY = fmap (either error id) . readImage +{-# INLINE readImageY #-} + + +-- | Read image as luma with 'Alpha' channel. +readImageYA :: FilePath -> IO (Image RD YA Double) +readImageYA = fmap (either error id) . readImage +{-# INLINE readImageYA #-} + + +-- | Read image in RGB colorspace. +readImageRGB :: FilePath -> IO (Image RD RGB Double) +readImageRGB = fmap (either error id) . readImage +{-# INLINE readImageRGB #-} + + +-- | Read image in RGB colorspace with 'Alpha' channel. +readImageRGBA :: FilePath -> IO (Image RD RGBA Double) +readImageRGBA = fmap (either error id) . readImage +{-# INLINE readImageRGBA #-} + diff --git a/src/Graphics/Image/Interface/Repa/Internal.hs b/src/Graphics/Image/Interface/Repa/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface/Repa/Internal.hs @@ -0,0 +1,476 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns, ConstraintKinds, GADTs, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, + UndecidableInstances, ViewPatterns #-} + +module Graphics.Image.Interface.Repa.Internal ( + RD(..), RP(..), RS(..), computeP, computeS, delay + ) where + +import Prelude hiding (map, zipWith, foldl, foldr, mapM, mapM_, read) +import qualified Prelude as P (map, mapM_) +import Graphics.Image.Interface +import Graphics.Image.ColorSpace.Binary (Bit(..)) +import Graphics.Image.Interface.Vector.Unboxed (VU(..), fromUnboxedVector, toUnboxedVector) +import Control.Monad (liftM) +import Data.Array.Repa.Repr.Unboxed (Unbox) +import qualified Data.Vector.Unboxed as V ((!)) +import Data.Function (on) +import Data.Typeable (Typeable) +import Data.Array.Repa hiding ( + Array, map, zipWith, rank, index, traverse, (++), computeP, computeS, delay, + traverse, traverse2, transpose, backpermute) +import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.Eval as R (Elt(..), suspendedComputeP) + + +-- | Repa 'D'elayed Array representation, which allows for fusion of computation. +data RD = RD + +-- | Repa 'U'nboxed Array representation, which is computed in parallel. +data RP = RP + +-- | Repa 'U'nboxed Array representation, which is computed sequentially. +data RS = RS + +instance Show RD where + show _ = "RepaDelayed" + +instance Show RP where + show _ = "RepaParallel" + +instance Show RS where + show _ = "RepaSequential" + +instance Elt RD cs e => Array RD cs e where + type Elt RD cs e = (ColorSpace cs, Num e, Typeable e, + R.Elt e, Unbox e, + R.Elt (PixelElt cs e), Unbox (PixelElt cs e), + R.Elt (Pixel cs e), Unbox (Pixel cs e)) + data Image RD cs e where + RScalar :: !(Pixel cs e) -> Image RD cs e + RUImage :: !(R.Array U DIM2 (Pixel cs e)) -> Image RD cs e + RDImage :: !(R.Array D DIM2 (Pixel cs e)) -> Image RD cs e + + dims (RScalar _ ) = (1, 1) + dims (RUImage (extent -> (Z :. m :. n))) = (m, n) + dims (RDImage (extent -> (Z :. m :. n))) = (m, n) + {-# INLINE dims #-} + + singleton = RScalar + {-# INLINE singleton #-} + + make !(m, n) !f = RDImage $ fromFunction (Z :. m :. n) (f . shT2) + {-# INLINE make #-} + + map f (RScalar px) = RScalar (f px) + map f (getDelayed -> arr) = RDImage (R.map f arr) + {-# INLINE map #-} + + imap f (RScalar px) = RScalar (f (0, 0) px) + imap f (getDelayed -> arr) = RDImage (R.zipWith f (R.fromFunction (extent arr) shT2) arr) + {-# INLINE imap #-} + + zipWith f (RScalar px1) (RScalar px2) = RScalar (f px1 px2) + zipWith f (RScalar px1) (getDelayed -> arr2) = RDImage (R.map (f px1) arr2) + zipWith f (getDelayed -> arr1) (RScalar px2) = RDImage (R.map (`f` px2) arr1) + zipWith f (getDelayed -> arr1) (getDelayed -> arr2) = RDImage (R.zipWith f arr1 arr2) + {-# INLINE zipWith #-} + + izipWith f (RScalar px1) (RScalar px2) = RScalar (f (0, 0) px1 px2) + izipWith f (RScalar px1) !img2 = imap (flip f px1) img2 + izipWith f !img1 (RScalar px2) = imap (\ !ix !px -> f ix px px2) img1 + izipWith f (getDelayed -> arr1) (getDelayed -> arr2) = + RDImage (R.traverse2 arr1 arr2 const getNewPx) where + getNewPx !getPx1 !getPx2 !sh = f (shT2 sh) (getPx1 sh) (getPx2 sh) + {-# INLINE getNewPx #-} + {-# INLINE izipWith #-} + + traverse (getDelayed -> arr) newDims newPx = + RDImage $ R.traverse arr (tSh2 . newDims . shT2) newPixel where + newPixel getPx = newPx (getPx . tSh2) . shT2 + {-# INLINE traverse #-} + + traverse2 (getDelayed -> arr1) (getDelayed -> arr2) newDims newPx = + RDImage $ R.traverse2 arr1 arr2 (((.).(.)) tSh2 (newDims `on` shT2)) newPixel where + newPixel getPx1 getPx2 = newPx (getPx1 . tSh2) (getPx2 . tSh2) . shT2 + {-# INLINE traverse2 #-} + + transpose (RDImage arr) = RDImage (R.transpose arr) + transpose (RUImage arr) = RDImage (R.transpose arr) + transpose img = img + {-# INLINE transpose #-} + + backpermute _ _ img@(RScalar _) = img + backpermute (tSh2 -> sh) g (getDelayed -> arr) = + RDImage (R.backpermute sh (tSh2 . g . shT2) arr) + {-# INLINE backpermute #-} + + fromLists !ls = if isSquare + then RUImage . R.fromListUnboxed (Z :. m :. n) . concat $ ls + else error "fromLists: Inner lists do not all have an equal length." + where + !(m, n) = (length ls, length $ head ls) + !isSquare = (n > 0) && all (==n) (P.map length ls) + {-# INLINE fromLists #-} + + + +instance Elt RS cs e => Array RS cs e where + type Elt RS cs e = (ColorSpace cs, + R.Elt e, Unbox e, Num e, Typeable e, + R.Elt (PixelElt cs e), Unbox (PixelElt cs e), + R.Elt (Pixel cs e), Unbox (Pixel cs e)) + + data Image RS cs e where + RSImage :: !(Image RD cs e) -> Image RS cs e + + dims (RSImage img) = dims img + {-# INLINE dims #-} + + make !ix !f = computeS $ (make ix f :: Image RD cs e) + {-# INLINE make #-} + + singleton = RSImage . singleton + {-# INLINE singleton #-} + + map !f (RSImage img) = computeS . map f $ img + {-# INLINE map #-} + + imap !f (RSImage img) = computeS . imap f $ img + {-# INLINE imap #-} + + zipWith !f (RSImage img1) (RSImage img2) = computeS . zipWith f img1 $ img2 + {-# INLINE zipWith #-} + + izipWith !f (RSImage img1) (RSImage img2) = computeS . izipWith f img1 $ img2 + {-# INLINE izipWith #-} + + traverse (RSImage img) newDims = computeS . traverse img newDims + {-# INLINE traverse #-} + + traverse2 (RSImage img1) (RSImage img2) newDims = computeS . traverse2 img1 img2 newDims + {-# INLINE traverse2 #-} + + transpose (RSImage img) = computeS . transpose $ img + {-# INLINE transpose #-} + + backpermute !f !g (RSImage img) = computeS $ backpermute f g img + {-# INLINE backpermute #-} + + fromLists = RSImage . fromLists + {-# INLINE fromLists #-} + + + +instance Elt RP cs e => Array RP cs e where + type Elt RP cs e = (ColorSpace cs, + R.Elt e, Unbox e, Num e, Typeable e, + R.Elt (PixelElt cs e), Unbox (PixelElt cs e), + R.Elt (Pixel cs e), Unbox (Pixel cs e)) + + data Image RP cs e where + RPImage :: !(Image RD cs e) -> Image RP cs e + + dims (RPImage img) = dims img + {-# INLINE dims #-} + + make !ix = suspendedComputeP . make ix + {-# INLINE make #-} + + singleton = RPImage . singleton + {-# INLINE singleton #-} + + map !f (RPImage img) = suspendedComputeP . map f $ img + {-# INLINE map #-} + + imap !f (RPImage img) = suspendedComputeP . imap f $ img + {-# INLINE imap #-} + + zipWith !f (RPImage img1) (RPImage img2) = suspendedComputeP . zipWith f img1 $ img2 + {-# INLINE zipWith #-} + + izipWith !f (RPImage img1) (RPImage img2) = suspendedComputeP . izipWith f img1 $ img2 + {-# INLINE izipWith #-} + + traverse (RPImage img) newDims = suspendedComputeP . traverse img newDims + {-# INLINE traverse #-} + + traverse2 (RPImage img1) (RPImage img2) newDims = + suspendedComputeP . traverse2 img1 img2 newDims + {-# INLINE traverse2 #-} + + transpose (RPImage img) = suspendedComputeP . transpose $ img + {-# INLINE transpose #-} + + backpermute !f !g (RPImage img) = suspendedComputeP $ backpermute f g img + {-# INLINE backpermute #-} + + fromLists = RPImage . fromLists + {-# INLINE fromLists #-} + + + +instance Array RS cs e => ManifestArray RS cs e where + + index (RSImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j) + index (RSImage (RScalar px)) (_, _) = px + index _ _ = _error_compute + {-# INLINE index #-} + + deepSeqImage (RSImage (RUImage arr)) = deepSeqArray arr + deepSeqImage (RSImage (RScalar px)) = seq px + deepSeqImage _ = _error_compute + {-# INLINE deepSeqImage #-} + + (|*|) i1@(RSImage img1) i2@(RSImage img2) = + i1 `deepSeqImage` i2 `deepSeqImage` computeS (mult img1 img2) + {-# INLINE (|*|) #-} + + fold !f !px0 (RSImage (RUImage arr)) = R.foldAllS f px0 $ arr + fold !f !px0 (RSImage (RScalar px)) = f px0 px + fold _ _ _ = _error_compute + {-# INLINE fold #-} + + eq (RSImage (RUImage arr1)) (RSImage (RUImage arr2)) = R.equalsS arr1 arr2 + eq _ _ = _error_compute + {-# INLINE eq #-} + + +instance Array RP cs e => ManifestArray RP cs e where + + index (RPImage (RUImage arr)) (i, j) = R.index arr (Z :. i :. j) + index (RPImage (RScalar px)) (0, 0) = px + index (RPImage (RScalar _)) (_, _) = error "Scalar Image can only be indexed at (0,0)." + index _ _ = _error_compute + {-# INLINE index #-} + + deepSeqImage (RPImage (RUImage arr)) = deepSeqArray arr + deepSeqImage (RPImage (RScalar px)) = seq px + deepSeqImage _ = _error_compute + {-# INLINE deepSeqImage #-} + + (|*|) i1@(RPImage img1) i2@(RPImage img2) = + i1 `deepSeqImage` i2 `deepSeqImage` suspendedComputeP (mult img1 img2) + {-# INLINE (|*|) #-} + + fold !f !px0 (RPImage (RUImage arr)) = head . R.foldAllP f px0 $ arr + fold !f !px0 (RPImage (RScalar px)) = f px0 px + fold _ _ _ = _error_compute + {-# INLINE fold #-} + + eq (RPImage (RUImage arr1)) (RPImage (RUImage arr2)) = head $ R.equalsP arr1 arr2 + eq _ _ = _error_compute + {-# INLINE eq #-} + + +instance ManifestArray RS cs e => SequentialArray RS cs e where + + foldl !f !a = foldl f a . exchange VU + {-# INLINE foldl #-} + + foldr !f !a = foldr f a . exchange VU + {-# INLINE foldr #-} + + mapM !f img = liftM (exchange RS) (mapM f (exchange VU img)) + {-# INLINE mapM #-} + + mapM_ !f img = mapM_ f (exchange VU img) + {-# INLINE mapM_ #-} + + foldM !f !a = foldM f a . exchange VU + {-# INLINE foldM #-} + + foldM_ !f !a = foldM_ f a . exchange VU + {-# INLINE foldM_ #-} + + +instance ManifestArray RS cs e => MutableArray RS cs e where + + data MImage st RS cs e where + MRSImage :: MImage st VU cs e -> MImage st RS cs e + + mdims (MRSImage (mdims -> sz)) = sz + {-# INLINE mdims #-} + + thaw img = liftM MRSImage (thaw (exchange VU img)) + {-# INLINE thaw #-} + + freeze (MRSImage mimg) = liftM (exchange RS) (freeze mimg) + {-# INLINE freeze #-} + + new sz = liftM MRSImage (new sz) + {-# INLINE new #-} + + read (MRSImage mimg) = read mimg + {-# INLINE read #-} + + write (MRSImage mimg) = write mimg + {-# INLINE write #-} + + swap (MRSImage mimg) = swap mimg + {-# INLINE swap #-} + + +-- | O(1) - Delays manifest array. +instance Exchangable RS RD where + + exchange _ (RSImage img) = img + {-# INLINE exchange #-} + + +-- | O(1) - Delays manifest array. +instance Exchangable RP RD where + + exchange _ (RPImage img) = img + {-# INLINE exchange #-} + +-- | Computes delayed array sequentially. +instance Exchangable RD RS where + + exchange _ (RDImage arr) = RSImage . RUImage . R.computeS $ arr + exchange _ img = RSImage img + {-# INLINE exchange #-} + + +-- | O(1) - Changes computation strategy. +instance Exchangable RP RS where + + exchange _ (RPImage img) = RSImage img + {-# INLINE exchange #-} + + +-- | Computes delayed array in parallel. +instance Exchangable RD RP where + + exchange _ (RDImage arr) = RPImage . RUImage . R.suspendedComputeP $ arr + exchange _ img = RPImage img + {-# INLINE exchange #-} + + +-- | O(1) - Changes computation strategy. +instance Exchangable RS RP where + + exchange _ (RSImage img) = RPImage img + {-# INLINE exchange #-} + +-- | O(1) - Changes to Repa representation. +instance Exchangable VU RS where + exchange _ img@(dims -> (1, 1)) = singleton (toUnboxedVector img V.! 0) + exchange _ img = RSImage . RUImage . R.fromUnboxed (tSh2 $ dims img) . toUnboxedVector $ img + {-# INLINE exchange #-} + + +-- | O(1) - Changes to Repa representation. +instance Exchangable VU RP where + exchange _ img@(dims -> (1, 1)) = singleton (toUnboxedVector img V.! 0) + exchange _ img = RPImage . RUImage . R.fromUnboxed (tSh2 $ dims img) . toUnboxedVector $ img + {-# INLINE exchange #-} + + +-- | O(1) - Changes to Vector representation. +instance Exchangable RS VU where + exchange _ img@(RSImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr) + exchange _ (RSImage (RScalar px)) = singleton px + exchange _ _ = _error_compute + {-# INLINE exchange #-} + + +-- | O(1) - Changes to Vector representation. +instance Exchangable RP VU where + exchange _ img@(RPImage (RUImage arr)) = fromUnboxedVector (dims img) (R.toUnboxed arr) + exchange _ (RPImage (RScalar px)) = singleton px + exchange _ _ = _error_compute + {-# INLINE exchange #-} + +-- | Computes an image in parallel and ensures that all elements are evaluated. +computeP :: (Array arr cs e, Array RP cs e, Exchangable arr RP) => + Image arr cs e -> Image RP cs e +computeP !img = head $ do + img' <- return $ exchange RP img + img' `deepSeqImage` return img' +{-# INLINE computeP #-} + +-- | Computes an image sequentially and ensures that all elements are evaluated. +computeS :: (Array arr cs e, Array RS cs e, Exchangable arr RS) => + Image arr cs e -> Image RS cs e +computeS !img = head $ do + img' <- return $ exchange RS img + img' `deepSeqImage` return img' +{-# INLINE computeS #-} + +-- | Delays an image, so further operations can be fused together. +delay :: (ManifestArray arr cs e, Array RD cs e, Exchangable arr RD) => + Image arr cs e -> Image RD cs e +delay = exchange RD +{-# INLINE delay #-} + + +mult :: Array RD cs e => Image RD cs e -> Image RD cs e -> Image RD cs e +mult img1@(RUImage arr1) img2@(RUImage arr2) = + if n1 /= m2 + then error ("Inner dimensions of multiplied images must be the same, but received: "++ + show img1 ++" X "++ show img2) + else RDImage . fromFunction (Z :. m1 :. n2) $ getPx where + (Z :. m1 :. n1) = extent arr1 + (Z :. m2 :. n2) = extent arr2 + getPx (Z :. i :. j) = + sumAllS (slice arr1 (Any :. (i :: Int) :. All) *^ slice arr2 (Any :. (j :: Int))) + {-# INLINE getPx #-} +mult _ _ = _error_compute +{-# INLINE mult #-} + + +shT2 :: DIM2 -> (Int, Int) +shT2 !(Z :. i :. j) = (i, j) +{-# INLINE shT2 #-} + +tSh2 :: (Int, Int) -> DIM2 +tSh2 !(i, j) = (Z :. i :. j) +{-# INLINE tSh2 #-} + + +suspendedComputeP :: Array RD cs e => + Image RD cs e -> Image RP cs e +suspendedComputeP (RDImage arr) = RPImage . RUImage . R.suspendedComputeP $ arr +suspendedComputeP !img = RPImage img +{-# INLINE suspendedComputeP #-} + + +getDelayed :: Array RD cs e => Image RD cs e -> R.Array D DIM2 (Pixel cs e) +getDelayed (RUImage arr) = R.delay arr +getDelayed (RDImage arr) = arr +getDelayed _ = error "Scalar image is not an array." +{-# INLINE getDelayed #-} + + +_error_compute :: t +_error_compute = error "Image should be computed at ths point. Please report this error" + +_error_scalar_op :: t +_error_scalar_op = + error "This operation is not allowed on scalar images." + + +instance R.Elt Bit where + touch (Bit w) = R.touch w + {-# INLINE touch #-} + + zero = 0 + {-# INLINE zero #-} + + one = 1 + {-# INLINE one #-} + + +instance (ColorSpace cs, R.Elt e, Num e) => R.Elt (Pixel cs e) where + touch !px = P.mapM_ (R.touch . getPxCh px) (enumFrom (toEnum 0)) + {-# INLINE touch #-} + + zero = 0 + {-# INLINE zero #-} + + one = 1 + {-# INLINE one #-} + + diff --git a/src/Graphics/Image/Interface/Vector.hs b/src/Graphics/Image/Interface/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface/Vector.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Image.Interface.Vector ( + -- * Construction + makeImage, fromUnboxedVector, toUnboxedVector, + -- * IO + readImageY, readImageYA, readImageRGB, readImageRGBA, + -- * Representation + VU(..), + ) where + +import Graphics.Image.IO +import Graphics.Image.Interface +import Graphics.Image.Interface.Vector.Unboxed +import Graphics.Image.ColorSpace + + +-- | Create an image with 'VU' (Vector Unboxed) representation and pixels of 'Double' +-- precision. Note, that for 'Double' precision pixels it is essential to keep values +-- normalized in the @[0, 1]@ range in order for an image to be written to file +-- properly. +-- +-- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY (fromIntegral i)/200 * (fromIntegral j)/200) +-- +-- Because all 'Pixel's and 'Image's are installed into 'Num', above is equivalent to: +-- +-- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200) +-- >>> writeImage "images/grad_gray.png" grad_gray +-- +-- Creating color images is just as easy. +-- +-- >>> let grad_color = makeImage (200, 200) (\(i, j) -> PixelRGB (fromIntegral i) (fromIntegral j) (fromIntegral (i + j))) / 400 +-- >>> writeImage "images/grad_color.png" grad_color +-- +-- <> <> +-- +makeImage :: Array VU cs Double => + (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. + -> ((Int, Int) -> Pixel cs Double) + -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument + -- and returns a pixel for that location. + -> Image VU cs Double +makeImage = make +{-# INLINE makeImage #-} + + +-- | Read luma (brightness) of an image. +readImageY :: FilePath -> IO (Image VU Y Double) +readImageY = fmap (either error id) . readImage +{-# INLINE readImageY #-} + + +-- | Read image as luma with 'Alpha' channel. +readImageYA :: FilePath -> IO (Image VU YA Double) +readImageYA = fmap (either error id) . readImage +{-# INLINE readImageYA #-} + + +-- | Read image in RGB colorspace. +readImageRGB :: FilePath -> IO (Image VU RGB Double) +readImageRGB = fmap (either error id) . readImage +{-# INLINE readImageRGB #-} + + +-- | Read image in RGB colorspace with 'Alpha' channel. +readImageRGBA :: FilePath -> IO (Image VU RGBA Double) +readImageRGBA = fmap (either error id) . readImage +{-# INLINE readImageRGBA #-} + diff --git a/src/Graphics/Image/Interface/Vector/Unboxed.hs b/src/Graphics/Image/Interface/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface/Vector/Unboxed.hs @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, FlexibleInstances, + GADTs, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, + UndecidableInstances, ViewPatterns #-} +module Graphics.Image.Interface.Vector.Unboxed ( + VU(..), Image(..), fromUnboxedVector, toUnboxedVector, fromIx, toIx + ) where + +import Prelude hiding (map, zipWith) +import qualified Prelude as P (map) +import Control.DeepSeq (deepseq) +import Control.Monad (liftM) +import Data.Word (Word8) +import Data.Typeable (Typeable) +import Data.Vector.Unboxed (Vector, Unbox) +import Data.Vector.Unboxed.Deriving +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as MV +import Graphics.Image.Interface +import Graphics.Image.ColorSpace.Binary (Bit(..)) + + +-- | Unboxed 'Vector' representation. +data VU = VU + + +instance Show VU where + show _ = "VectorUnboxed" + + +instance Elt VU cs e => Array VU cs e where + type Elt VU cs e = (ColorSpace cs, Num e, Unbox e, Typeable e, + Unbox (PixelElt cs e), Unbox (Pixel cs e)) + data Image VU cs e where + VScalar :: !(Pixel cs e) -> Image VU cs e + VUImage :: !Int -> !Int -> !(Vector (Pixel cs e)) -> Image VU cs e + + make !(m, n) !f = VUImage m n $ V.generate (m * n) (f . toIx n) + {-# INLINE make #-} + + singleton = VScalar + {-# INLINE singleton #-} + + dims (VUImage m n _) = (m, n) + dims _ = (1, 1) + {-# INLINE dims #-} + + map !f (VScalar px) = VScalar (f px) + map !f (VUImage m n v) = VUImage m n (V.map f v) + {-# INLINE map #-} + + imap !f (VScalar px) = VScalar (f (0, 0) px) + imap !f (VUImage m n v) = VUImage m n (V.imap (\ !k !px -> f (toIx n k) px) v) + {-# INLINE imap #-} + + zipWith !f (VScalar px1) (VScalar px2) = VScalar (f px1 px2) + zipWith !f (VScalar px1) (VUImage m n v2) = VUImage m n (V.map (f px1) v2) + zipWith !f (VUImage m n v1) (VScalar px2) = VUImage m n (V.map (`f` px2) v1) + zipWith !f img1@(VUImage m1 n1 v1) img2@(VUImage m2 n2 v2) = + if m1 /= m2 || n1 /= n2 + then error ("zipWith: Images must be of the same dimensions, received: "++ + show img1++" and "++show img2++".") + else VUImage m1 n1 (V.zipWith f v1 v2) + {-# INLINE zipWith #-} + + izipWith !f (VScalar px1) (VScalar px2) = VScalar (f (0, 0) px1 px2) + izipWith !f (VScalar px1) (VUImage m n v2) = + VUImage m n (V.imap (\ !k !px2 -> f (toIx n k) px1 px2) v2) + izipWith !f (VUImage m n v1) (VScalar px2) = + VUImage m n (V.imap (\ !k !px1 -> f (toIx n k) px1 px2) v1) + izipWith !f img1@(VUImage m1 n1 v1) img2@(VUImage m2 n2 v2) = + if m1 /= m2 || n1 /= n2 + then error ("izipWith: Images must be of the same dimensions, received: "++ + show img1++" and "++show img2++".") + else VUImage m1 n1 (V.izipWith (\ !k !px1 !px2 -> f (toIx n1 k) px1 px2) v1 v2) + {-# INLINE izipWith #-} + + traverse !img !getNewDims !getNewPx = make (getNewDims $ dims img) (getNewPx (index img)) + {-# INLINE traverse #-} + + traverse2 !img1 !img2 !getNewDims !getNewPx = + make (getNewDims (dims img1) (dims img2)) (getNewPx (index img1) (index img2)) + {-# INLINE traverse2 #-} + + transpose !img@(dims -> (m, n)) = make (n, m) getPx where + getPx !(i, j) = index img (j, i) + {-# INLINE getPx #-} + {-# INLINE transpose #-} + + backpermute !(m, n) !f (VUImage _ n' v) = + VUImage m n $ V.backpermute v $ V.generate (m*n) (fromIx n' . f . toIx n) + backpermute !sz _ (VScalar px) = + if sz == (1, 1) then VScalar px else make sz (const px) + {-# INLINE backpermute #-} + + fromLists !ls = if isSquare + then VUImage m n . V.fromList . concat $ ls + else error "fromLists: Inner lists are of different lengths." + where + !(m, n) = (length ls, length $ head ls) + !isSquare = (n > 0) && all (==n) (P.map length ls) + {-# INLINE fromLists #-} + + +instance Array VU cs e => ManifestArray VU cs e where + + index (VUImage _ n v) !ix = v V.! fromIx n ix + index (VScalar px) _ = px + {-# INLINE index #-} + + deepSeqImage (VUImage m n v) = m `seq` n `seq` deepseq v + deepSeqImage (VScalar px) = seq px + {-# INLINE deepSeqImage #-} + + fold !f !px0 (VUImage _ _ v) = V.foldl' f px0 v + fold !f !px0 (VScalar px) = f px0 px + {-# INLINE fold #-} + + (|*|) img1@(VUImage m1 n1 v1) !img2@(VUImage {}) = + if n1 /= m2 + then error ("Inner dimensions of multiplying images must be the same, but received: "++ + show img1 ++" X "++ show img2) + else + make (m1, n2) getPx where + VUImage n2 m2 v2 = transpose img2 + getPx !(i, j) = V.sum $ V.zipWith (*) (V.slice (i*n1) n1 v1) (V.slice (j*m2) m2 v2) + {-# INLINE getPx #-} + (|*|) (VScalar px1) (VScalar px2) = VScalar (px1 * px2) + (|*|) _ _ = error "Scalar Images cannot be multiplied." + {-# INLINE (|*|) #-} + + eq (VUImage m1 n1 v1) (VUImage m2 n2 v2) = + m1 == m2 && n1 == n2 && V.all id (V.zipWith (==) v1 v2) + eq (VScalar px1) (VScalar px2) = px1 == px2 + eq _ _ = False + {-# INLINE eq #-} + + +instance ManifestArray VU cs e => SequentialArray VU cs e where + + foldl !f !a (VUImage _ _ v) = V.foldl' f a v + foldl !f !a (VScalar px) = f a px + {-# INLINE foldl #-} + + foldr !f !a (VUImage _ _ v) = V.foldr' f a v + foldr !f !a (VScalar px) = f px a + {-# INLINE foldr #-} + + mapM !f (VUImage m n v) = liftM (VUImage m n) (V.mapM f v) + mapM !f (VScalar px) = liftM VScalar (f px) + {-# INLINE mapM #-} + + mapM_ !f (VUImage _ _ v) = V.mapM_ f v + mapM_ !f (VScalar px) = (f px) >> return () + {-# INLINE mapM_ #-} + + foldM !f !a (VUImage _ _ v) = V.foldM' f a v + foldM !f !a (VScalar px) = f a px + {-# INLINE foldM #-} + + foldM_ !f !a (VUImage _ _ v) = V.foldM'_ f a v + foldM_ !f !a (VScalar px) = f a px >> return () + {-# INLINE foldM_ #-} + + +instance ManifestArray VU cs e => MutableArray VU cs e where + + data MImage st VU cs e where + MVImage :: !Int -> !Int -> MV.MVector st (Pixel cs e) -> MImage st VU cs e + MVScalar :: MV.MVector st (Pixel cs e) -> MImage st VU cs e + + mdims (MVImage m n _) = (m, n) + mdims (MVScalar _) = (1, 1) + {-# INLINE mdims #-} + + thaw (VUImage m n v) = liftM (MVImage m n) (V.thaw v) + thaw (VScalar px) = liftM MVScalar (V.thaw (V.singleton px)) + {-# INLINE thaw #-} + + freeze (MVImage m n mv) = liftM (VUImage m n) (V.freeze mv) + freeze (MVScalar mv) = liftM (VScalar . (V.! 0)) (V.freeze mv) + {-# INLINE freeze #-} + + new (m, n) = liftM (MVImage m n) (MV.new (m*n)) + {-# INLINE new #-} + + read (MVImage _ n mv) ix = MV.read mv (fromIx n ix) + read (MVScalar mv) _ = MV.read mv 0 + {-# INLINE read #-} + + write (MVImage _ n mv) ix = MV.write mv (fromIx n ix) + write (MVScalar mv) _ = MV.write mv 0 + {-# INLINE write #-} + + swap (MVImage _ n mv) ix1 ix2 = MV.swap mv (fromIx n ix1) (fromIx n ix2) + swap _ _ _ = return () + {-# INLINE swap #-} + + +-- | Convert an image to a flattened Unboxed 'Vector'. It is a __O(1)__ opeartion. +-- +-- >>> toUnboxedVector $ makeImage (3, 2) (\(i, j) -> PixelY $ fromIntegral (i+j)) +-- fromList [,,,,,] +-- +toUnboxedVector :: Array VU cs e => Image VU cs e -> Vector (Pixel cs e) +toUnboxedVector (VUImage _ _ v) = v +toUnboxedVector (VScalar px) = V.singleton px + + +-- | Construct a two dimensional image with @m@ rows and @n@ columns from a flat +-- Unboxed 'Vector' of length @k@. It is a __O(1)__ opeartion. Make sure that @m * n = k@. +-- +-- >>> fromUnboxedVector (200, 300) $ generate 60000 (\i -> PixelY $ fromIntegral i / 60000) +-- +-- +-- <> +-- +fromUnboxedVector :: Array VU cs e => (Int, Int) -> Vector (Pixel cs e) -> Image VU cs e +fromUnboxedVector (m, n) v + | m * n == V.length v = VUImage m n v + | otherwise = error "fromUnboxedVector: m * n doesn't equal the length of a Vector." + + +fromIx :: Int -> (Int, Int) -> Int +fromIx !n !(i, j) = i * n + j +{-# INLINE fromIx #-} + + +toIx :: Int -> Int -> (Int, Int) +toIx !n !k = (k `div` n, k `mod` n) +{-# INLINE toIx #-} + + +derivingUnbox "Bit" + [t| Bit -> Word8 |] + [| \(Bit w) -> w |] + [| Bit |] + + +derivingUnbox "Pixel" + [t| (ColorSpace cs, Unbox (PixelElt cs e)) => (Pixel cs e) -> (PixelElt cs e) |] + [| toElt |] + [| fromElt |] + diff --git a/src/Graphics/Image/Processing.hs b/src/Graphics/Image/Processing.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} +module Graphics.Image.Processing ( + -- * Geometric + module Graphics.Image.Processing.Geometric, + -- * Interpolation + module Graphics.Image.Processing.Interpolation, + -- * Convolution + module Graphics.Image.Processing.Convolution, + -- * Tools + Border(..), pixelGrid + ) where + +import Data.Word (Word8) +import Graphics.Image.Interface +import Graphics.Image.Processing.Convolution +import Graphics.Image.Processing.Geometric +import Graphics.Image.Processing.Interpolation + + + +-- | This function magnifies an image by a positive factor and draws a grid +-- around the original pixels. It is here simply as useful inspection tool. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_eye_grid.png" $ pixelGrid 10 $ crop (51, 112) (20, 20) frog +-- +-- <> <> +-- +pixelGrid :: (Array arr cs e, Elevator e) => + Word8 -- ^ Magnification factor. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e +pixelGrid !(succ . fromIntegral -> k) !img = traverse img getNewDims getNewPx where + getNewDims !(m, n) = (1 + m*k, 1 + n*k) + {-# INLINE getNewDims #-} + getNewPx !getPx !(i, j) = if i `mod` k == 0 || j `mod` k == 0 + then fromDouble $ fromChannel 0.5 + else getPx ((i - 1) `div` k, (j - 1) `div` k) + {-# INLINE getNewPx #-} +{-# INLINE pixelGrid #-} + diff --git a/src/Graphics/Image/Processing/Binary.hs b/src/Graphics/Image/Processing/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing/Binary.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, FunctionalDependencies, + MultiParamTypeClasses #-} +module Graphics.Image.Processing.Binary ( + -- * Construction + toImageBinaryUsing, toImageBinaryUsing2, + thresholdWith, compareWith, + -- * Bitwise operations + (.&&.), (.||.), invert, + -- * Thresholding + Thresholding(..), + -- * Binary Morphology + -- $morphology + erode, dialate, open, close + ) where + +import Prelude hiding (map, zipWith) +import Graphics.Image.Interface +import Graphics.Image.ColorSpace +import Graphics.Image.Processing.Convolution + +import qualified Data.Foldable as F + +infix 4 .==., ./=., .<., .<=., .>=., .>. +infixr 3 .&&. +infixr 2 .||. + + +-- | 'Thresholding' contains a convenient set of functions for binary image +-- construction, which is done by comparing either a single pixel with every +-- pixel in an image or two same size images pointwise. +class Array arr Binary Bit => Thresholding a b arr | a b -> arr where + (.==.) :: (Eq (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + (./=.) :: (Eq (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + (.<.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + (.<=.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + (.>.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + (.>=.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + + + +instance Array arr Binary Bit => Thresholding (Image arr) (Image arr) arr where + (.==.) = toImageBinaryUsing2 (==) + {-# INLINE (.==.) #-} + + (./=.) = toImageBinaryUsing2 (/=) + {-# INLINE (./=.) #-} + + (.<.) = toImageBinaryUsing2 (<) + {-# INLINE (.<.) #-} + + (.<=.) = toImageBinaryUsing2 (<=) + {-# INLINE (.<=.) #-} + + (.>.) = toImageBinaryUsing2 (>) + {-# INLINE (.>.) #-} + + (.>=.) = toImageBinaryUsing2 (>=) + {-# INLINE (.>=.) #-} + + +instance Array arr Binary Bit => Thresholding Pixel (Image arr) arr where + (.==.) !px = toImageBinaryUsing (==px) + {-# INLINE (.==.) #-} + + (./=.) !px = toImageBinaryUsing (/=px) + {-# INLINE (./=.) #-} + + (.<.) !px = toImageBinaryUsing (< px) + {-# INLINE (.<.) #-} + + (.<=.) !px = toImageBinaryUsing (<=px) + {-# INLINE (.<=.) #-} + + (.>.) !px = toImageBinaryUsing (> px) + {-# INLINE (.>.) #-} + + (.>=.) !px = toImageBinaryUsing (>=px) + {-# INLINE (.>=.) #-} + + +instance Array arr Binary Bit => Thresholding (Image arr) Pixel arr where + (.==.) !img !px = toImageBinaryUsing (==px) img + {-# INLINE (.==.) #-} + + (./=.) !img !px = toImageBinaryUsing (/=px) img + {-# INLINE (./=.) #-} + + (.<.) !img !px = toImageBinaryUsing (< px) img + {-# INLINE (.<.) #-} + + (.<=.) !img !px = toImageBinaryUsing (<=px) img + {-# INLINE (.<=.) #-} + + (.>.) !img !px = toImageBinaryUsing (> px) img + {-# INLINE (.>.) #-} + + (.>=.) !img !px = toImageBinaryUsing (>=px) img + {-# INLINE (.>=.) #-} + + +-- | Pixel wise @AND@ operator on binary images. +(.&&.) :: Array arr Binary Bit => + Image arr Binary Bit -> Image arr Binary Bit -> Image arr Binary Bit +(.&&.) = zipWith (*) +{-# INLINE (.&&.) #-} + +-- | Pixel wise @OR@ operator on binary images. +(.||.) :: Array arr Binary Bit => + Image arr Binary Bit -> Image arr Binary Bit -> Image arr Binary Bit +(.||.) = zipWith (+) +{-# INLINE (.||.) #-} + + +-- | Complement each pixel in the image +invert :: Array arr Binary Bit => Image arr Binary Bit -> Image arr Binary Bit +invert = map complement +{-# INLINE invert #-} + + +-- | Construct a binary image using a predicate from a source image. +toImageBinaryUsing :: (Array arr cs e, Array arr Binary Bit) => + (Pixel cs e -> Bool) -- ^ Predicate + -> Image arr cs e -- ^ Source image. + -> Image arr Binary Bit +toImageBinaryUsing !f = map (fromBool . f) +{-# INLINE toImageBinaryUsing #-} + + +-- | Construct a binary image using a predicate from two source images. +toImageBinaryUsing2 :: (Array arr cs e, Array arr Binary Bit) => + (Pixel cs e -> Pixel cs e -> Bool) -- ^ Predicate + -> Image arr cs e -- ^ First source image. + -> Image arr cs e -- ^ Second source image. + -> Image arr Binary Bit +toImageBinaryUsing2 !f = zipWith (((.).(.)) fromBool f) +{-# INLINE toImageBinaryUsing2 #-} + + +-- | Threshold a source image with an applicative pixel. +-- +-- >>> yield <- readImageRGB "images/yield.jpg" +-- >>> writeImageExact PNG [] "images/yield_bin.png" $ thresholdWith (PixelRGB (>0.55) (<0.6) (<0.5)) yield +-- +-- <> <> +-- +thresholdWith :: (Array arr cs e, Array arr Binary Bit) => + Pixel cs (e -> Bool) + -- ^ Pixel containing a thresholding function per channel. + -> Image arr cs e -- ^ Source image. + -> Image arr Binary Bit +thresholdWith !f = map (fromBool . F.and . (f <*>)) +{-# INLINE thresholdWith #-} + + +-- | Compare two images with an applicative pixel. Works just like +-- 'thresholdWith', but on two images. +compareWith :: (Array arr cs e1, Array arr cs e2, Array arr Binary Bit) => + Pixel cs (e1 -> e2 -> Bool) + -- ^ Pixel containing a comparing function per channel. + -> Image arr cs e1 -- ^ First image. + -> Image arr cs e2 -- ^ second image. + -> Image arr Binary Bit +compareWith !f = zipWith (\ !px1 !px2 -> fromBool . F.and $ (f <*> px1 <*> px2)) +{-# INLINE compareWith #-} + + +{- $morphology In order to demonstrate how morphological operations work, a +/binary source image/ = __B__ constructed here together with a /structuring element/ = +__S__ will be used in examples that follow. + +@ +figure :: Image VU Binary Bit +figure = fromLists [[0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,1,1,0,0,0,0,0,1,1,1,0], + [0,0,0,0,0,0,0,1,0,0,0,0,1,1,0,0,0], + [0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0], + [0,0,0,0,1,1,1,1,1,1,1,0,0,0,0,0,0], + [0,0,0,0,1,1,1,1,1,1,1,0,0,0,0,0,0], + [0,0,0,0,0,0,1,1,1,1,1,0,0,0,0,0,0], + [0,0,0,0,0,0,1,1,1,1,0,0,0,1,0,0,0], + [0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,0,0], + [0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]] +struct :: Image VU Binary Bit +struct = fromLists [[0,1],[1,1],[0,1]] +@ +-} + + +-- | Erosion is defined as: __{E = B ⊖ S = {m,n|Sₘₙ⊆B}__ +-- +-- >>> writeImageExact PNG [] "images/figure_erode.png" $ pixelGrid 10 $ fromImageBinary $ erode struct figure +-- +-- <> eroded with <> is <> +-- +erode :: ManifestArray arr Binary Bit => + Image arr Binary Bit -- ^ Structuring element. + -> Image arr Binary Bit -- ^ Binary source image. + -> Image arr Binary Bit +erode !struc !img = invert $ convolve (Fill on) struc (invert img) +{-# INLINE erode #-} + + +-- | Dialation is defined as: __{D = B ⊕ S = {m,n|Sₘₙ∩B≠∅}__ +-- +-- >>> writeImageExact PNG [] "images/figure_dialate.png" $ pixelGrid 10 $ fromImageBinary $ dialate struct figure +-- +-- <> dialated with <> is <> +-- +dialate :: ManifestArray arr Binary Bit => + Image arr Binary Bit -- ^ Structuring element. + -> Image arr Binary Bit -- ^ Binary source image. + -> Image arr Binary Bit +dialate !struc !img = convolve (Fill off) struc img +{-# INLINE dialate #-} + + +-- | Opening is defined as: __{B ○ S = (B ⊖ S) ⊕ S}__ +-- +-- >>> writeImageExact PNG [] "images/figure_open.png" $ pixelGrid 10 $ fromImageBinary $ open struct figure +-- +-- <> opened with <> is <> +-- +open :: ManifestArray arr Binary Bit => + Image arr Binary Bit -- ^ Structuring element. + -> Image arr Binary Bit -- ^ Binary source image. + -> Image arr Binary Bit +open struc = dialate struc . erode struc +{-# INLINE open #-} + + +-- | Closing is defined as: __{B ● S = (B ⊕ S) ⊖ S}__ +-- +-- >>> writeImageExact PNG [] "images/figure_close.png" $ pixelGrid 10 $ fromImageBinary $ close struct figure +-- +-- <> closed with <> is <> +-- +close :: ManifestArray arr Binary Bit => + Image arr Binary Bit -- ^ Structuring element. + -> Image arr Binary Bit -- ^ Binary source image. + -> Image arr Binary Bit +close struc = erode struc . dialate struc +{-# INLINE close #-} + + diff --git a/src/Graphics/Image/Processing/Complex.hs b/src/Graphics/Image/Processing/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing/Complex.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, ViewPatterns #-} +module Graphics.Image.Processing.Complex ( + -- * Rectangular form + (!+!), realPart', imagPart', + -- * Polar form + mkPolar', cis', polar', magnitude', phase', + -- * Conjugate + conjugate', + -- * Processing + makeFilter, applyFilter, + -- ** Fourier Transform + fft, ifft + ) where + +import Prelude hiding (map, zipWith) +--import qualified Data.Complex as C +import Graphics.Image.Interface +import Graphics.Image.ColorSpace.Complex +import Graphics.Image.Processing.Complex.Fourier + + +infix 6 !+! + +-- | Constrcut a complex image from two images containing real and imaginary parts. +-- +-- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @ +-- +(!+!) :: (Array arr cs e, Array arr cs (Complex e)) => + Image arr cs e -> Image arr cs e -> Image arr cs (Complex e) +(!+!) = zipWith (+:) +{-# INLINE (!+!) #-} + +-- | Extracts the real part of a complex image. +realPart' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs (Complex e) -> Image arr cs e +realPart' = map realPart +{-# INLINE realPart' #-} + +-- | Extracts the imaginary part of a complex image. +imagPart' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs (Complex e) -> Image arr cs e +imagPart' = map imagPart +{-# INLINE imagPart' #-} + +-- | Form a complex image from polar components of magnitude and phase. +mkPolar' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs e -> Image arr cs e -> Image arr cs (Complex e) +mkPolar' = zipWith mkPolar +{-# INLINE mkPolar' #-} + +-- | @'cis'' t@ is a complex image with magnitude 1 and phase t (modulo @2*'pi'@). +cis' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs e -> Image arr cs (Complex e) +cis' = map cis +{-# INLINE cis' #-} + +-- | The function @'polar''@ takes a complex image and returns a (magnitude, phase) +-- pair of images in canonical form: the magnitude is nonnegative, and the phase +-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase. +polar' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs (Complex e) -> (Image arr cs e, Image arr cs e) +polar' !zImg = (magnitude' zImg, phase' zImg) +{-# INLINE polar' #-} + +-- | The nonnegative magnitude of a complex image. +magnitude' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs (Complex e) -> Image arr cs e +magnitude' = map magnitude +{-# INLINE magnitude' #-} + +-- | The phase of a complex image, in the range @(-'pi', 'pi']@. If the +-- magnitude is zero, then so is the phase. +phase' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs (Complex e) -> Image arr cs e +phase' = map phase +{-# INLINE phase' #-} + +-- | The conjugate of a complex image. +conjugate' :: (Array arr cs e, Array arr cs (Complex e), RealFloat e) => + Image arr cs (Complex e) -> Image arr cs (Complex e) +conjugate' = map conjugate +{-# INLINE conjugate' #-} + + +-- | Make a filter by using a function that works around a regular @(x, y)@ +-- coordinate system. +makeFilter :: (ManifestArray arr cs e, RealFloat e) => + (Int, Int) + -- ^ Dimensions of the filter. Both @m@ and @n@ have to be powers + -- of @2@, i.e. @m == 2^k@, where @k@ is some integer. + -> ((Int, Int) -> Pixel cs e) -> Image arr cs e +makeFilter !(m, n) !getPx + | isPowerOfTwo m && isPowerOfTwo n = make (m, n) getPx' + | otherwise = error " " + where getPx' (i, j) = getPx (if i < (m `div` 2) then i else i - m, + if j < (n `div` 2) then j else j - n) + {-# INLINE getPx' #-} +{-# INLINE makeFilter #-} + + +-- | Apply a filter to an image created by 'makeFilter'. +applyFilter :: (ManifestArray arr cs e, ManifestArray arr cs (Complex e), RealFloat e) => + Image arr cs e -- ^ Source image. + -> Image arr cs e -- ^ Filter. + -> Image arr cs e +applyFilter img filt = realPart' . ifft $ ((fft (img !+! 0)) * (filt !+! filt)) +{-# INLINE applyFilter #-} + +{- +gaussianBandpass :: (ManifestArray arr cs e, RealFloat e) => + Int -> e -> e -> Image arr cs e +gaussianBandpass n center variance = makeFilter (n, n) bandpass where + gaussian (x, y) = fromChannel $ exp (-(x^(2 :: Int) + y^(2 :: Int)) / (2*variance)) + bandpass (fromIntegral -> y, fromIntegral -> x) = gaussian (x', y') + where (x' :+ y') = C.mkPolar (mag - center) ph + (mag, ph) = C.polar (x :+ y) +-} + +{- +idealBandpass :: (ManifestArray arr cs e, RealFloat e) => + Int -> e -> e -> Image arr cs e +idealBandpass n width center = makeFilter (n, n) bandpass where + bandpass (fromIntegral -> r, fromIntegral -> c) + | center <= mag && mag <= (width + center) = 1 + | otherwise = 0 + where mag = C.magnitude (r :+ c) +-} diff --git a/src/Graphics/Image/Processing/Complex/Fourier.hs b/src/Graphics/Image/Processing/Complex/Fourier.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing/Complex/Fourier.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts #-} +module Graphics.Image.Processing.Complex.Fourier ( + fft, ifft, isPowerOfTwo + ) where + +import Prelude hiding (map) +import Data.Bits ((.&.)) +import Graphics.Image.Interface +import Graphics.Image.ColorSpace.Complex +import Graphics.Image.Processing.Geometric (leftToRight) + + +data Mode = Forward + | Inverse + +-- | Fast Fourier Transform +fft :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) => + Image arr cs (Complex e) + -> Image arr cs (Complex e) +fft = fft2d Forward +{-# INLINE fft #-} + + +-- | Inverse Fast Fourier Transform +ifft :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) => + Image arr cs (Complex e) + -> Image arr cs (Complex e) +ifft = fft2d Inverse +{-# INLINE ifft #-} + + +signOfMode :: Num a => Mode -> a +signOfMode Forward = -1 +signOfMode Inverse = 1 +{-# INLINE signOfMode #-} + + +-- | Check if `Int` is a power of two. +isPowerOfTwo :: Int -> Bool +isPowerOfTwo n = n /= 0 && (n .&. (n-1)) == 0 +{-# INLINE isPowerOfTwo #-} + + +-- | Compute the DFT of a matrix. Array dimensions must be powers of two else `error`. +fft2d :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) => + Mode + -> Image arr cs (Complex e) + -> Image arr cs (Complex e) +fft2d mode img = + let !(m, n) = dims img + !sign = signOfMode mode + !scale = fromIntegral (m * n) + in if not (isPowerOfTwo m && isPowerOfTwo n) + then error $ unlines + [ "fft" + , " Array dimensions must be powers of two," + , " but the provided image is " ++ show img ++ "." ] + else case mode of + Forward -> fftGeneral sign $ fftGeneral sign img + Inverse -> map (/ scale) $ fftGeneral sign $ fftGeneral sign img +{-# INLINE fft2d #-} + + +fftGeneral :: (ManifestArray arr cs (Complex e), Num e, RealFloat e) => + Pixel cs e + -> Image arr cs (Complex e) + -> Image arr cs (Complex e) +fftGeneral !sign !img = transpose $ go n 0 1 where + !(m, n) = dims img + go !len !offset !stride + | len == 2 = make (m, 2) swivel + | otherwise = combine len + (go (len `div` 2) offset (stride * 2)) + (go (len `div` 2) (offset + stride) (stride * 2)) + where + swivel (m', j) = case j of + 0 -> index img (m', offset) + index img (m', offset + stride) + 1 -> index img (m', offset) - index img (m', offset + stride) + _ -> error "FFT: Image must have exactly 2 columns. Please, report this bug." + combine !len' evens odds = + let odds' = traverse odds id + (\getPx (i, j) -> twiddle sign j len' * getPx (i, j)) + in leftToRight (evens + odds') (evens - odds') + + +-- Compute a twiddle factor. +twiddle :: (ColorSpace cs, Floating e) => + Pixel cs e + -> Int -- index + -> Int -- length + -> Pixel cs (Complex e) +twiddle sign k n = cos alpha +: sign * sin alpha where + !alpha = 2 * pi * fromIntegral k / fromIntegral n +{-# INLINE twiddle #-} diff --git a/src/Graphics/Image/Processing/Convolution.hs b/src/Graphics/Image/Processing/Convolution.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing/Convolution.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +module Graphics.Image.Processing.Convolution ( + convolve, convolveRows, convolveCols, + --convolve', convolveRows', convolveCols', + ) where + +import Prelude hiding (map) +import qualified Prelude as P (map) +import Graphics.Image.Interface +import Graphics.Image.Processing.Geometric + + + +convolve'' :: ManifestArray arr cs e => + Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e +convolve'' !border !kernel !img = + img `deepSeqImage` kernel `deepSeqImage` traverse2 kernel img (const . const sz) stencil + where + !(krnM, krnN) = dims kernel + !krnM2 = krnM `div` 2 + !krnN2 = krnN `div` 2 + !sz = dims img + getPxB !getPx !ix = borderIndex border sz getPx ix + {-# INLINE getPxB #-} + stencil !getKrnPx !getImgPx !(i, j) = integrate 0 0 0 where + !ikrnM = i - krnM2 + !jkrnN = j - krnN2 + integrate !ki !kj !acc + | kj == krnN = integrate (ki+1) 0 acc + | kj == 0 && ki == krnM = acc + | otherwise = let !krnPx = getKrnPx (ki, kj) + !imgPx = getPxB getImgPx (ki + ikrnM, kj + jkrnN) + in integrate ki (kj + 1) (acc + krnPx * imgPx) + {-# INLINE integrate #-} + {-# INLINE stencil #-} +{-# INLINE convolve'' #-} + +-- | Convolution of an image using a kernel. Border resolution technique is required. +convolve :: ManifestArray arr cs e => + Border (Pixel cs e) -- ^ Approach to be used near the borders. + -> Image arr cs e -- ^ Kernel image. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e +convolve !out = convolve'' out . rotate180 +{-# INLINE convolve #-} + +{- +-- | Strict version of convolution that operates on manifest array representations. +convolve' :: ManifestArray arr cs e => + Border (Pixel cs e) -- ^ Approach to be used near the borders. + -> Image arr cs e -- ^ Kernel image. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e +convolve' !out = convolve'' out . rotate180 +{-# INLINE convolve' #-} +-} +{- +-- | Convolve image's rows with a vector kernel represented by a list of pixels. +convolveRows :: Array arr cs e => + Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e +convolveRows !out = convolve out . fromLists . (:[]) . reverse +{-# INLINE convolveRows #-} + + +-- | Convolve image's columns with a vector kernel represented by a list of pixels. +convolveCols :: Array arr cs e => + Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e +convolveCols !out = convolve out . fromLists . P.map (:[]) . reverse +{-# INLINE convolveCols #-} +-} + +-- | Convolve image's rows with a vector kernel represented by a list of pixels. +convolveRows :: ManifestArray arr cs e => + Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e +convolveRows !out = convolve out . fromLists . (:[]) . reverse +{-# INLINE convolveRows #-} + + +-- | Convolve image's columns with a vector kernel represented by a list of pixels. +convolveCols :: ManifestArray arr cs e => + Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e +convolveCols !out = convolve out . fromLists . P.map (:[]) . reverse +{-# INLINE convolveCols #-} + diff --git a/src/Graphics/Image/Processing/Geometric.hs b/src/Graphics/Image/Processing/Geometric.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing/Geometric.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} +module Graphics.Image.Processing.Geometric ( + -- ** Sampling + downsampleRows, downsampleCols, downsample, + upsampleRows, upsampleCols, upsample, + -- ** Concatenation + leftToRight, topToBottom, + -- ** Canvas + crop, + -- ** Flipping + flipV, flipH, + -- ** Rotation + rotate90, rotate180, rotate270, + -- ** Scaling + resize, scale + ) where + +import Graphics.Image.Interface +import Graphics.Image.Processing.Interpolation + + + +downsampleF :: Array arr cs e => Int -> Int -> Image arr cs e -> Image arr cs e +downsampleF !fm !fn !img = traverse img + (\ !(m, n) -> (m `div` fm, n `div` fn)) + (\ !getPx !(i, j) -> getPx (i*fm, j*fn)) +{-# INLINE downsampleF #-} + + +upsampleF :: Array arr cs e => Int -> Int -> Image arr cs e -> Image arr cs e +upsampleF !fm !fn !img = traverse img + (\ !(m, n) -> (m*fm, n*fn)) + (\ !getPx !(i, j) -> + if i `mod` fm == 0 && j `mod` fn == 0 + then getPx (i `div` fm, j `div` fn) + else fromChannel 0) +{-# INLINE upsampleF #-} + + +-- | Downsample an image by discarding every odd row. +downsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e +downsampleRows = downsampleF 2 1 +{-# INLINE downsampleRows #-} + + +-- | Downsample an image by discarding every odd column. +downsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e +downsampleCols = downsampleF 1 2 +{-# INLINE downsampleCols #-} + + +-- | Downsample an image by discarding every odd row and column. +downsample :: Array arr cs e => Image arr cs e -> Image arr cs e +downsample = downsampleF 2 2 +{-# INLINE downsample #-} + + +-- | Upsample an image by inserting a row of back pixels after each row of a +-- source image. +upsampleRows :: Array arr cs e => Image arr cs e -> Image arr cs e +upsampleRows = upsampleF 2 1 +{-# INLINE upsampleRows #-} + + +-- | Upsample an image by inserting a column of back pixels after each column of a +-- source image. +upsampleCols :: Array arr cs e => Image arr cs e -> Image arr cs e +upsampleCols = upsampleF 1 2 +{-# INLINE upsampleCols #-} + + +-- | Upsample an image by inserting a row and a column of back pixels after each +-- row and a column of a source image. +upsample :: Array arr cs e => Image arr cs e -> Image arr cs e +upsample = upsampleF 2 2 +{-# INLINE upsample #-} + + +-- | Concatenate two images together into one. Both input images must have the +-- same number of rows. +leftToRight :: Array arr cs e => Image arr cs e -> Image arr cs e -> Image arr cs e +leftToRight !img1@(dims -> (_, n1)) !img2 = traverse2 img1 img2 newDims newPx where + newDims !(m1, _) !(m2, n2) + | m1 == m2 = (m1, n1 + n2) + | otherwise = error ("Images must agree in numer of rows, but received: " + ++ show img1 ++ " and " ++ show img2) + {-# INLINE newDims #-} + newPx !getPx1 !getPx2 !(i, j) = if j < n1 then getPx1 (i, j) else getPx2 (i, j-n1) + {-# INLINE newPx #-} +{-# INLINE leftToRight #-} + + +-- | Concatenate two images together into one. Both input images must have the +-- same number of columns. +topToBottom :: Array arr cs e => Image arr cs e -> Image arr cs e -> Image arr cs e +topToBottom !img1@(dims -> (m1, _)) !img2 = traverse2 img1 img2 newDims newPx where + newDims !(_, n1) !(m2, n2) + | n1 == n2 = (m1 + m2, n1) + | otherwise = error ("Images must agree in numer of columns, but received: " + ++ show img1 ++ " and " ++ show img2) + {-# INLINE newDims #-} + newPx !getPx1 !getPx2 !(i, j) = if i < m1 then getPx1 (i, j) else getPx2 (i-m1, j) + {-# INLINE newPx #-} +{-# INLINE topToBottom #-} + +-- | Crop an image, i.e. retrieves a sub-image image with @m@ rows and @n@ +-- columns. Make sure @(m + i, n + j)@ is not greater than dimensions of a +-- source image. +crop :: Array arr cs e => + (Int, Int) -- ^ @(i, j)@ starting index from within a source image. + -> (Int, Int) -- ^ @(m, n)@ dimensions of a new image. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e +crop !(i, j) sz = backpermute sz (\ !(i', j') -> (i' + i, j' + j)) +{-# INLINE crop #-} + + +flipUsing :: Array arr cs e => + ((Int, Int) -> (Int, Int) -> (Int, Int)) -> Image arr cs e -> Image arr cs e +flipUsing getNewIndex !img@(dims -> d) = backpermute d (getNewIndex d) img +{-# INLINE flipUsing #-} + + +-- | Flip an image vertically. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_flipV.jpg" (computeS $ flipV frog) +-- +-- <> <> +-- +flipV :: Array arr cs e => Image arr cs e -> Image arr cs e +flipV = flipUsing (\ (m, _) !(i, j) -> (m - 1 - i, j)) +{-# INLINE flipV #-} + + +-- | Flip an image horizontally. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_flipH.jpg" (flipH frog) +-- +-- <> <> +-- +flipH :: Array arr cs e => Image arr cs e -> Image arr cs e +flipH = flipUsing (\ (_, n) !(i, j) -> (i, n - 1 - j)) +{-# INLINE flipH #-} + + +-- | Rotate an image clockwise by 90°. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_rotate90.jpg" (rotate90 frog) +-- +-- <> <> +-- +rotate90 :: Array arr cs e => Image arr cs e -> Image arr cs e +rotate90 = transpose . flipV +{-# INLINE rotate90 #-} + + +-- | Rotate an image by 180°. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_rotate180.jpg" (rotate180 frog) +-- +-- <> <> +-- +rotate180 :: Array arr cs e => Image arr cs e -> Image arr cs e +rotate180 = flipUsing (\ !(m, n) !(i, j) -> (m - 1 - i, n - 1 - j)) +{-# INLINE rotate180 #-} + + +-- | Rotate an image clockwise by 270°. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_rotate270.jpg" (rotate270 frog) +-- +-- <> <> +-- +rotate270 :: Array arr cs e => Image arr cs e -> Image arr cs e +rotate270 = transpose . flipH +{-# INLINE rotate270 #-} + + +-- | Resize an image using an interpolation method. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeImage "images/frog_resize.jpg" (resize (Bilinear Edge) (100, 640) frog) +-- +-- <> +-- +resize :: (Interpolation method, Array arr cs e, Elevator e) => + method (Pixel cs e) -- ^ Interpolation method to be used during scaling. + -> (Int, Int) -- ^ Dimensions of a result image. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e -- ^ Reuslt image. +resize !method !sz'@(m', n') !img = traverse img (const sz') getNewPx where + !sz@(m, n) = dims img + !(fM, fN) = (fromIntegral m' / fromIntegral m, fromIntegral n' / fromIntegral n) + getNewPx !getPx !(i, j) = + interpolate method sz getPx ((fromIntegral i + 0.5) / fM - 0.5, (fromIntegral j + 0.5) / fN - 0.5) + {-# INLINE getNewPx #-} +{-# INLINE resize #-} + + +-- | Scale an image. Same as resize, except scaling factors are supplied +-- instead of new dimensions. +-- +-- @ scale ('Bilinear' 'Edge') (0.5, 2) frog == resize ('Bilinear' 'Edge') (100, 640) frog @ +-- +scale :: (Interpolation method, Array arr cs e, Elevator e) => + method (Pixel cs e) -- ^ Interpolation method to be used during scaling. + -> (Double, Double) -- ^ Positive scaling factors. + -> Image arr cs e -- ^ Source image. + -> Image arr cs e +scale !method !(fM, fN) !img@(dims -> (m, n)) = + if fM <= 0 || fN <= 0 + then error "scale: scaling factor must be greater than 0." + else resize method (round (fM * fromIntegral m), round (fN * fromIntegral n)) img +{-# INLINE scale #-} diff --git a/src/Graphics/Image/Processing/Interpolation.hs b/src/Graphics/Image/Processing/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Processing/Interpolation.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} +module Graphics.Image.Processing.Interpolation ( + Interpolation(..), Nearest(..), Bilinear(..) + ) where + +import Graphics.Image.Interface + + +class Interpolation method where + interpolate :: (Elevator e, Num e, ColorSpace cs) => + method (Pixel cs e) -- ^ Interpolation method + -> (Int, Int) -- ^ Image dimensions @m@ rows and @n@ columns. + -> ((Int, Int) -> Pixel cs e) + -- ^ Lookup function that returns a pixel at @i@th and @j@th + -- location. + -> (Double, Double) -- ^ real values of @i@ and @j@ index + -> Pixel cs e + + +-- | Nearest Neighbor interpolation method. +data Nearest px = Nearest + + +-- | Bilinear interpolation method. +data Bilinear px = Bilinear (Border px) + + +instance Interpolation Nearest where + interpolate _ !(m, n) !getPx !(round -> i, round -> j) = + if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else 0 + + +instance Interpolation Bilinear where + interpolate (Bilinear border) !sz !getPx !(i, j) = fi0 + jPx*(fi1-fi0) where + getPx' = borderIndex border sz getPx + !(i0, j0) = (floor i, floor j) + !(i1, j1) = (i0 + 1, j0 + 1) + !iPx = fromDouble $ fromChannel (i - fromIntegral i0) + !jPx = fromDouble $ fromChannel (j - fromIntegral j0) + !f00 = getPx' (i0, j0) + !f10 = getPx' (i1, j0) + !f01 = getPx' (i0, j1) + !f11 = getPx' (i1, j1) + !fi0 = f00 + iPx*(f10-f00) + !fi1 = f01 + iPx*(f11-f01) + {-# INLINE interpolate #-}