diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +1.5.0.0 +======= + +* Refactored `Gray` color space to be `X`, in order to reflect it's generality +* Renamed few core functions: + * `mapPx` -> `liftPx`, + * `zipWithPx` -> `liftPx2`, + * `broadcastC` -> `promote`, + * `singleton` -> `scalar`. +* `upsample`/`downsample` functions are now a lot more general. + + 1.4.0.1 ======= diff --git a/hip.cabal b/hip.cabal --- a/hip.cabal +++ b/hip.cabal @@ -1,5 +1,5 @@ Name: hip -Version: 1.4.0.1 +Version: 1.5.0.0 License: BSD3 License-File: LICENSE Author: Alexey Kuleshevich @@ -68,10 +68,10 @@ 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.X + , Graphics.Image.ColorSpace.Y , Graphics.Image.ColorSpace.YCbCr , Graphics.Image.IO.Base , Graphics.Image.IO.Formats.JuicyPixels @@ -107,7 +107,9 @@ , Graphics.Image.Processing.BinarySpec , Graphics.Image.InterfaceSpec , Graphics.Image.Interface.VectorSpec + , Graphics.Image.IO.FormatsSpec Build-Depends: base >= 4.5 && < 5 + , bytestring , hip , hspec , QuickCheck diff --git a/images/frog_downsampled.jpg b/images/frog_downsampled.jpg new file mode 100644 Binary files /dev/null and b/images/frog_downsampled.jpg differ diff --git a/images/frog_upsampled.jpg b/images/frog_upsampled.jpg new file mode 100644 Binary files /dev/null and b/images/frog_upsampled.jpg differ diff --git a/src/Graphics/Image.hs b/src/Graphics/Image.hs --- a/src/Graphics/Image.hs +++ b/src/Graphics/Image.hs @@ -23,9 +23,6 @@ -- constant time and allows monadic operations and 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: -- @@ -36,11 +33,11 @@ -- * `RSS` - Repa Sequential Storable array representation (computation is done sequentially). -- * `RPS` - Repa Parallel Storable array representation (computation is done in parallel). -- --- Images with `RSU` and `RPU` types, most of the time hold functions rather then --- actual data, this way computation can be fused together, and later changed to --- `VU` using `toManifest`, which in turn performs the fused computation. If at --- any time computation needs to be forced, `compute` can be used for that --- purpose. +-- Images with `RSU`, `RSS`, `RPU` and `RPS` types, most of the time, hold +-- functions rather than an actual data, this way computation can be fused +-- together, and later changed to `VU` or `VS` using `toManifest`, which in turn +-- performs the fused computation. If at any time computation needs to be +-- forced, `compute` can be used for that purpose. -- -- Many of the function names exported by this module will clash with the ones -- from "Prelude", hence it can be more convenient to import like this: @@ -102,7 +99,7 @@ transpose, backpermute, (|*|), -- * Reduction - fold, sum, product, maximum, minimum, normalize, + fold, sum, product, maximum, minimum, normalize, eqTol, -- * Representations exchange, module IP @@ -226,20 +223,26 @@ -- | Scales all of the pixels to be in the range @[0, 1]@. -normalize :: (Array arr cs e, Array arr Gray e, Fractional e, - Fractional (Pixel cs e), Ord e) => +normalize :: (Array arr cs e, Array arr X 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 I.map normalizer img + else I.map (liftPx (\ !e -> (e - s) / (l - s))) img where - !(PixelGray l, PixelGray s) = (maximum (I.map (PixelGray . foldl1Px max) img), - minimum (I.map (PixelGray . foldl1Px min) img)) - normalizer !px = (px - broadcastC s) / broadcastC (l - s) - {-# INLINE normalizer #-} + !(PixelX l, PixelX s) = (maximum (I.map (PixelX . foldl1Px max) img), + minimum (I.map (PixelX . foldl1Px min) img)) {-# INLINE normalize #-} +-- | Check weather two images are equal within a tolerance. Useful for comparing +-- images with `Float` or `Double` precision. +eqTol + :: (Array arr Binary Bit, Array arr cs e, Ord e, Num e) => + e -> Image arr cs e -> Image arr cs e -> Bool +eqTol !tol !img1 = IP.and . toImageBinaryUsing2 (eqTolPx tol) img1 +{-# INLINE eqTol #-} + + -- | Type restricted version of `fromLists` that constructs an image using -- supplied representation. fromListsR :: Array arr cs e => arr -> [[Pixel cs e]] -> Image arr cs e @@ -269,7 +272,7 @@ -- ------------------------------------------------------------------------------------------ -- * __'Pixel' 'Binary' 'Bit' = 'on' | 'off'__ - Bi-tonal. -- * __'Pixel' cs ('Complex' e) = ('Pixel' cs e) '+:' ('Pixel' cs e)__ - Complex pixels with any color space. --- * __'Pixel' 'Gray' e = PixelGray g__ - Used for separating channels from other color spaces. +-- * __'Pixel' 'X' e = PixelX g__ - Used for separating channels from other color spaces. -- @ -- -- Every 'Pixel' is an instance of 'Functor', 'Applicative', 'F.Foldable' and diff --git a/src/Graphics/Image/ColorSpace.hs b/src/Graphics/Image/ColorSpace.hs --- a/src/Graphics/Image/ColorSpace.hs +++ b/src/Graphics/Image/ColorSpace.hs @@ -19,8 +19,10 @@ module Graphics.Image.ColorSpace ( -- * ColorSpace ColorSpace, Pixel(..), AlphaSpace(..), Elevator(..), + -- * Operations on Pixels + eqTolPx, -- * Luma - module Graphics.Image.ColorSpace.Luma, + module Graphics.Image.ColorSpace.Y, -- * RGB module Graphics.Image.ColorSpace.RGB, -- * HSI @@ -29,8 +31,8 @@ module Graphics.Image.ColorSpace.CMYK, -- * YCbCr module Graphics.Image.ColorSpace.YCbCr, - -- * Gray - module Graphics.Image.ColorSpace.Gray, + -- * Gray level + module Graphics.Image.ColorSpace.X, -- * Binary Binary, Bit, on, off, isOn, isOff, fromBool, complement, toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary, @@ -46,11 +48,11 @@ 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.X +import Graphics.Image.ColorSpace.Y import Graphics.Image.ColorSpace.YCbCr import Graphics.Image.ColorSpace.Complex import qualified Graphics.Image.Interface as I (map) @@ -86,11 +88,18 @@ {-# INLINE fromImageBinary #-} --- Conversion: +-- | Check weather two Pixels are equal within a tolerance. Useful for comparing +-- pixels with `Float` or `Double` precision. +eqTolPx :: (ColorSpace cs e, Num e, Ord e) => + e -> Pixel cs e -> Pixel cs e -> Bool +eqTolPx !tol = foldlPx2 comp True + where comp !acc !e1 !e2 = acc && max e1 e2 - min e1 e2 <= tol + {-# INLINE comp #-} +{-# INLINE eqTolPx #-} -instance ToY Gray where - toPixelY (PixelGray y) = PixelY y +instance ToY X where + toPixelY (PixelX y) = PixelY y {-# INLINE toPixelY #-} -- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @ @@ -118,7 +127,7 @@ instance ToYA YCbCrA where instance ToRGB Y where - toPixelRGB (PixelY g) = broadcastC g + toPixelRGB (PixelY g) = promote g {-# INLINE toPixelRGB #-} instance ToRGBA YA where diff --git a/src/Graphics/Image/ColorSpace/Binary.hs b/src/Graphics/Image/ColorSpace/Binary.hs --- a/src/Graphics/Image/ColorSpace/Binary.hs +++ b/src/Graphics/Image/ColorSpace/Binary.hs @@ -14,10 +14,12 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.Binary ( - Binary(..), Bit(..), on, off, isOn, isOff, fromBool, complement + Binary(..), Bit(..), on, off, isOn, isOff, fromBool, + module Data.Bits ) where import Prelude hiding (map) +import Data.Bits import Data.Word (Word8) import Graphics.Image.Interface import Data.Typeable (Typeable) @@ -46,20 +48,92 @@ -- >>> (on + on) - on -- -- -data Binary = Binary deriving (Eq, Enum, Show, Typeable) +data Binary = Binary deriving (Eq, Enum, Bounded, Show, Typeable) --- | Under the hood, Binary pixels are represented as 'Word8' that can only take +-- | Under the hood, Binary pixels are represented as 'Word8', but can only take -- values of @0@ or @1@. newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable) -data instance Pixel Binary e = PixelBinary !e deriving (Ord, Eq) +data instance Pixel Binary Bit = PixelBinary {-# UNPACK #-} !Bit deriving (Ord, Eq) instance Show (Pixel Binary Bit) where show (PixelBinary (Bit 0)) = "" show _ = "" +instance Bits Bit where + (.&.) = (*) + {-# INLINE (.&.) #-} + + (.|.) = (+) + {-# INLINE (.|.) #-} + + (Bit 0) `xor` (Bit 0) = Bit 0 + (Bit 1) `xor` (Bit 1) = Bit 0 + _ `xor` _ = Bit 1 + {-# INLINE xor #-} + + complement (Bit 0) = Bit 1 + complement _ = Bit 0 + + shift !b 0 = b + shift _ _ = Bit 0 + + rotate !b _ = b + + zeroBits = Bit 0 + + bit 0 = Bit 1 + bit _ = Bit 0 + + testBit (Bit 1) 0 = True + testBit _ _ = False + + bitSizeMaybe _ = Just 1 + + bitSize _ = 1 + + isSigned _ = False + + popCount (Bit 0) = 0 + popCount _ = 1 + + + +instance Bits (Pixel Binary Bit) where + (.&.) = liftPx2 (.&.) + {-# INLINE (.&.) #-} + + (.|.) = liftPx2 (.|.) + {-# INLINE (.|.) #-} + + xor = liftPx2 xor + {-# INLINE xor #-} + + complement = liftPx complement + + shift !b !n = liftPx (`shift` n) b + + rotate !b !n = liftPx (`rotate` n) b + + zeroBits = promote zeroBits + + bit = promote . bit + + testBit (PixelBinary (Bit 1)) 0 = True + testBit _ _ = False + + bitSizeMaybe _ = Just 1 + + bitSize _ = 1 + + isSigned _ = False + + popCount (PixelBinary (Bit 0)) = 0 + popCount _ = 1 + + -- | Represents value 'True' or @1@ in binary. Often also called a foreground -- pixel of an object. on :: Pixel Binary Bit @@ -98,17 +172,12 @@ {-# 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 Bit where type Components Binary Bit = Bit - broadcastC = PixelBinary - {-# INLINE broadcastC #-} + promote = PixelBinary + {-# INLINE promote #-} fromComponents = PixelBinary {-# INLINE fromComponents #-} toComponents (PixelBinary b) = b @@ -119,12 +188,14 @@ {-# INLINE setPxC #-} mapPxC f (PixelBinary b) = PixelBinary (f Binary b) {-# INLINE mapPxC #-} - mapPx f (PixelBinary b) = PixelBinary (f b) - {-# INLINE mapPx #-} - zipWithPx f (PixelBinary b1) (PixelBinary b2) = PixelBinary (f b1 b2) - {-# INLINE zipWithPx #-} + liftPx f (PixelBinary b) = PixelBinary (f b) + {-# INLINE liftPx #-} + liftPx2 f (PixelBinary b1) (PixelBinary b2) = PixelBinary (f b1 b2) + {-# INLINE liftPx2 #-} foldrPx f z (PixelBinary b) = f b z {-# INLINE foldrPx #-} + foldlPx2 f !z (PixelBinary b1) (PixelBinary b2) = f z b1 b2 + {-# INLINE foldlPx2 #-} instance Elevator Bit where @@ -156,6 +227,10 @@ (Bit 0) + (Bit 0) = Bit 0 _ + _ = Bit 1 {-# INLINE (+) #-} + -- 0 - 0 = 0 + -- 0 - 1 = 0 + -- 1 - 0 = 1 + -- 1 - 1 = 0 _ - (Bit 1) = Bit 0 _ - _ = Bit 1 {-# INLINE (-) #-} @@ -173,17 +248,17 @@ instance Num (Pixel Binary Bit) where - (+) = zipWithPx (+) + (+) = liftPx2 (+) {-# INLINE (+) #-} - (-) = zipWithPx (-) + (-) = liftPx2 (-) {-# INLINE (-) #-} - (*) = zipWithPx (*) + (*) = liftPx2 (*) {-# INLINE (*) #-} - abs = mapPx abs + abs = liftPx abs {-# INLINE abs #-} - signum = mapPx signum + signum = liftPx signum {-# INLINE signum #-} - fromInteger = broadcastC . fromInteger + fromInteger = promote . fromInteger {-# INLINE fromInteger #-} diff --git a/src/Graphics/Image/ColorSpace/CMYK.hs b/src/Graphics/Image/ColorSpace/CMYK.hs --- a/src/Graphics/Image/ColorSpace/CMYK.hs +++ b/src/Graphics/Image/ColorSpace/CMYK.hs @@ -36,13 +36,7 @@ | MagCMYK -- ^ Magenta | YelCMYK -- ^ Yellow | KeyCMYK -- ^ Key (Black) - deriving (Eq, Enum, Typeable) - -instance Show CMYK where - show CyanCMYK = "Cyan" - show MagCMYK = "Magenta" - show YelCMYK = "Yellow" - show KeyCMYK = "Black" + deriving (Eq, Enum, Show, Bounded, Typeable) instance Show e => Show (Pixel CMYK e) where @@ -58,8 +52,8 @@ {-# INLINE fromComponents #-} toComponents (PixelCMYK c m y k) = (c, m, y, k) {-# INLINE toComponents #-} - broadcastC !e = PixelCMYK e e e e - {-# INLINE broadcastC #-} + promote !e = PixelCMYK e e e e + {-# INLINE promote #-} getPxC (PixelCMYK c _ _ _) CyanCMYK = c getPxC (PixelCMYK _ m _ _) MagCMYK = m getPxC (PixelCMYK _ _ y _) YelCMYK = y @@ -73,12 +67,15 @@ mapPxC f (PixelCMYK c m y k) = PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k) {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelCMYK c1 m1 y1 k1) (PixelCMYK c2 m2 y2 k2) = + f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2 + {-# INLINE foldlPx2 #-} instance Functor (Pixel CMYK) where @@ -179,7 +176,7 @@ | YelCMYKA -- ^ Yellow | KeyCMYKA -- ^ Key (Black) | AlphaCMYKA -- ^ Alpha - deriving (Eq, Enum, Typeable) + deriving (Eq, Enum, Show, Bounded, Typeable) -- | Conversion to `CMYK` color space. @@ -215,14 +212,6 @@ data instance Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq -instance Show CMYKA where - show CyanCMYKA = "Cyan" - show MagCMYKA = "Magenta" - show YelCMYKA = "Yellow" - show KeyCMYKA = "Black" - show AlphaCMYKA = "Alpha" - - instance Show e => Show (Pixel CMYKA e) where show (PixelCMYKA c m y k a) = "" @@ -235,8 +224,8 @@ {-# INLINE fromComponents #-} toComponents (PixelCMYKA c m y k a) = (c, m, y, k, a) {-# INLINE toComponents #-} - broadcastC !e = PixelCMYKA e e e e e - {-# INLINE broadcastC #-} + promote !e = PixelCMYKA e e e e e + {-# INLINE promote #-} getPxC (PixelCMYKA c _ _ _ _) CyanCMYKA = c getPxC (PixelCMYKA _ m _ _ _) MagCMYKA = m getPxC (PixelCMYKA _ _ y _ _) YelCMYKA = y @@ -252,12 +241,15 @@ mapPxC f (PixelCMYKA c m y k a) = PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a) {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelCMYKA c1 m1 y1 k1 a1) (PixelCMYKA c2 m2 y2 k2 a2) = + f (f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2) a1 a2 + {-# INLINE foldlPx2 #-} instance (Elevator e, Typeable e) => AlphaSpace CMYKA e where diff --git a/src/Graphics/Image/ColorSpace/Gray.hs b/src/Graphics/Image/ColorSpace/Gray.hs deleted file mode 100644 --- a/src/Graphics/Image/ColorSpace/Gray.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.Image.ColorSpace.Gray --- Copyright : (c) Alexey Kuleshevich 2016 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.Image.ColorSpace.Gray ( - Gray(..), Pixel(..), toGrayImages, fromGrayImages - ) where - -import Prelude as P -import Control.Applicative -import Data.Foldable -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable - -import Graphics.Image.Interface as I - --- ^ This is a single channel colorspace, that is designed to separate Gray --- level values from other types of colorspace, hence it is not convertible to --- or from, but rather is here to allow operation on arbirtary single channel --- images. 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) - - -data instance Pixel Gray e = PixelGray !e deriving (Ord, Eq) - - -instance Show e => Show (Pixel Gray e) where - show (PixelGray g) = "" - - -instance (Elevator e, Typeable e) => ColorSpace Gray e where - type Components Gray e = e - - broadcastC = PixelGray - {-# INLINE broadcastC #-} - fromComponents = PixelGray - {-# INLINE fromComponents #-} - toComponents (PixelGray g) = g - {-# INLINE toComponents #-} - getPxC (PixelGray g) Gray = g - {-# INLINE getPxC #-} - setPxC (PixelGray _) Gray g = PixelGray g - {-# INLINE setPxC #-} - mapPxC f (PixelGray g) = PixelGray (f Gray g) - {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} - foldlPx = foldl' - {-# INLINE foldlPx #-} - - -instance Functor (Pixel Gray) where - fmap f (PixelGray g) = PixelGray (f g) - {-# INLINE fmap #-} - - -instance Applicative (Pixel Gray) where - pure = PixelGray - {-# INLINE pure #-} - (PixelGray fg) <*> (PixelGray g) = PixelGray (fg g) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel Gray) where - foldr f !z (PixelGray g) = f g z - {-# INLINE foldr #-} - - -instance Monad (Pixel Gray) where - - return = PixelGray - {-# INLINE return #-} - - (>>=) (PixelGray g) f = f g - {-# INLINE (>>=) #-} - - -instance Num e => Num (Pixel Gray e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - - (-) = liftA2 (-) - {-# INLINE (-) #-} - - (*) = liftA2 (*) - {-# INLINE (*) #-} - - abs = liftA abs - {-# INLINE abs #-} - - signum = liftA signum - {-# INLINE signum #-} - - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - - -instance Fractional e => Fractional (Pixel Gray e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance Floating e => Floating (Pixel Gray e) where - pi = pure 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 Storable e => Storable (Pixel Gray e) where - - sizeOf _ = sizeOf (undefined :: e) - alignment _ = alignment (undefined :: e) - peek p = do - q <- return $ castPtr p - g <- peek q - return (PixelGray g) - poke p (PixelGray g) = do - q <- return $ castPtr p - poke q g - --- | 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 = I.map (PixelGray . (`getPxC` 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, despite that separating image channels can be sometimes --- pretty useful, the same effect as above can be achieved in a much simpler and --- a 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 = fromGrays 0 where - updateCh ch px (PixelGray e) = setPxC px ch e - {-# INLINE updateCh #-} - fromGrays img [] _ = img - fromGrays img _ [] = img - fromGrays img (i:is) (c:cs) = fromGrays (I.zipWith (updateCh c) img i) is cs - {-# INLINE fromGrays #-} -{-# INLINE fromGrayImages #-} diff --git a/src/Graphics/Image/ColorSpace/HSI.hs b/src/Graphics/Image/ColorSpace/HSI.hs --- a/src/Graphics/Image/ColorSpace/HSI.hs +++ b/src/Graphics/Image/ColorSpace/HSI.hs @@ -35,15 +35,10 @@ data HSI = HueHSI -- ^ Hue | SatHSI -- ^ Saturation | IntHSI -- ^ Intensity - deriving (Eq, Enum, Typeable) + deriving (Eq, Enum, Show, Bounded, Typeable) data instance Pixel HSI e = PixelHSI !e !e !e deriving Eq - -instance Show HSI where - show HueHSI = "Hue" - show SatHSI = "Saturation" - show IntHSI = "Intensity" instance Show e => Show (Pixel HSI e) where show (PixelHSI h s i) = "" @@ -56,8 +51,8 @@ {-# INLINE toComponents #-} fromComponents !(h, s, i) = PixelHSI h s i {-# INLINE fromComponents #-} - broadcastC = pure - {-# INLINE broadcastC #-} + promote = pure + {-# INLINE promote #-} getPxC (PixelHSI h _ _) HueHSI = h getPxC (PixelHSI _ s _) SatHSI = s getPxC (PixelHSI _ _ i) IntHSI = i @@ -68,12 +63,15 @@ {-# INLINE setPxC #-} mapPxC f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i) {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelHSI h1 s1 i1) (PixelHSI h2 s2 i2) = + f (f (f z h1 h2) s1 s2) i1 i2 + {-# INLINE foldlPx2 #-} instance Functor (Pixel HSI) where @@ -170,7 +168,7 @@ | SatHSIA -- ^ Saturation | IntHSIA -- ^ Intensity | AlphaHSIA -- ^ Alpha - deriving (Eq, Enum, Typeable) + deriving (Eq, Enum, Show, Bounded, Typeable) data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq @@ -190,14 +188,7 @@ {-# INLINE toImageHSI #-} - -instance Show HSIA where - show HueHSIA = "Hue" - show SatHSIA = "Saturation" - show IntHSIA = "Intensity" - show AlphaHSIA = "Alpha" - - + instance Show e => Show (Pixel HSIA e) where show (PixelHSIA h s i a) = "" @@ -209,8 +200,8 @@ {-# INLINE toComponents #-} fromComponents !(h, s, i, a) = PixelHSIA h s i a {-# INLINE fromComponents #-} - broadcastC = pure - {-# INLINE broadcastC #-} + promote = pure + {-# INLINE promote #-} getPxC (PixelHSIA h _ _ _) HueHSIA = h getPxC (PixelHSIA _ s _ _) SatHSIA = s getPxC (PixelHSIA _ _ i _) IntHSIA = i @@ -224,12 +215,15 @@ mapPxC f (PixelHSIA h s i a) = PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a) {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelHSIA h1 s1 i1 a1) (PixelHSIA h2 s2 i2 a2) = + f (f (f (f z h1 h2) s1 s2) i1 i2) a1 a2 + {-# INLINE foldlPx2 #-} instance (Elevator e, Typeable e) => AlphaSpace HSIA e where diff --git a/src/Graphics/Image/ColorSpace/Luma.hs b/src/Graphics/Image/ColorSpace/Luma.hs deleted file mode 100644 --- a/src/Graphics/Image/ColorSpace/Luma.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.Image.ColorSpace.Luma --- Copyright : (c) Alexey Kuleshevich 2016 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.Image.ColorSpace.Luma ( - Y(..), YA(..), Pixel(..), - ToY(..), ToYA(..) - ) where - -import Prelude hiding (map) -import Control.Applicative -import Data.Foldable -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable - -import Graphics.Image.Interface - ---------- ---- Y --- ---------- - --- | Luma or brightness, which is usually denoted as @Y'@. -data Y = LumaY deriving (Eq, Enum, Typeable) - - -data instance Pixel Y e = PixelY !e deriving (Ord, Eq) - --- | Conversion to Luma color space. -class ColorSpace cs Double => ToY cs where - - -- | Convert a pixel to Luma pixel. - toPixelY :: Pixel cs Double -> Pixel Y Double - - -- | Convert an image to Luma image. - toImageY :: (Array arr cs Double, Array arr Y Double) => - Image arr cs Double - -> Image arr Y Double - toImageY = map toPixelY - {-# INLINE toImageY #-} - -instance Show Y where - show LumaY = "Luma" - -instance Show e => Show (Pixel Y e) where - show (PixelY g) = "" - -instance (Elevator e, Typeable e) => ColorSpace Y e where - type Components Y e = e - broadcastC = PixelY - {-# INLINE broadcastC #-} - fromComponents = PixelY - {-# INLINE fromComponents #-} - toComponents (PixelY y) = y - {-# INLINE toComponents #-} - getPxC (PixelY y) LumaY = y - {-# INLINE getPxC #-} - setPxC _ LumaY y = PixelY y - {-# INLINE setPxC #-} - mapPxC f (PixelY y) = PixelY (f LumaY y) - {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} - foldlPx = foldl' - {-# INLINE foldlPx #-} - - -instance Functor (Pixel Y) where - fmap f (PixelY y) = PixelY (f y) - {-# INLINE fmap #-} - - -instance Applicative (Pixel Y) where - pure = PixelY - {-# INLINE pure #-} - (PixelY fy) <*> (PixelY y) = PixelY (fy y) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel Y) where - foldr f !z (PixelY y) = f y z - {-# INLINE foldr #-} - - -instance Monad (Pixel Y) where - - return = PixelY - {-# INLINE return #-} - - (>>=) (PixelY y) f = f y - {-# INLINE (>>=) #-} - - -instance Num e => Num (Pixel Y e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - abs = liftA abs - {-# INLINE abs #-} - signum = liftA signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - - -instance Fractional e => Fractional (Pixel Y e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance Floating e => Floating (Pixel Y e) where - pi = pure 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 Storable e => Storable (Pixel Y e) where - - sizeOf _ = sizeOf (undefined :: e) - alignment _ = alignment (undefined :: e) - peek p = do - q <- return $ castPtr p - y <- peek q - return (PixelY y) - poke p (PixelY y) = do - q <- return $ castPtr p - poke q y - - - - ----------- ---- YA --- ----------- - --- | Luma with Alpha channel. -data YA = LumaYA -- ^ Luma - | AlphaYA -- ^ Alpha channel - deriving (Eq, Enum, Typeable) - -data instance Pixel YA e = PixelYA !e !e deriving Eq - --- | Conversion to Luma from another color space with Alpha channel. -class (ToY (Opaque cs), AlphaSpace cs Double) => ToYA cs where - - -- | Convert a pixel to Luma pixel with Alpha. - toPixelYA :: Pixel cs Double -> Pixel YA Double - toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px)) - {-# INLINE toPixelYA #-} - - -- | Convert an image to Luma image with Alpha. - toImageYA :: (Array arr cs Double, Array arr YA Double) => - Image arr cs Double - -> Image arr YA Double - toImageYA = map toPixelYA - {-# INLINE toImageYA #-} - - -instance Show YA where - show LumaYA = "Luma" - show AlphaYA = "Alpha" - -instance (Elevator e, Typeable e) => ColorSpace YA e where - type Components YA e = (e, e) - broadcastC e = PixelYA e e - {-# INLINE broadcastC #-} - fromComponents (y, a) = PixelYA y a - {-# INLINE fromComponents #-} - toComponents (PixelYA y a) = (y, a) - {-# INLINE toComponents #-} - getPxC (PixelYA y _) LumaYA = y - getPxC (PixelYA _ a) AlphaYA = a - {-# INLINE getPxC #-} - setPxC (PixelYA _ a) LumaYA y = PixelYA y a - setPxC (PixelYA y _) AlphaYA a = PixelYA y a - {-# INLINE setPxC #-} - mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a) - {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} - foldlPx = foldl' - {-# INLINE foldlPx #-} - - -instance (Elevator e, Typeable e) => AlphaSpace YA e where - type Opaque YA = Y - - getAlpha (PixelYA _ a) = a - {-# INLINE getAlpha #-} - addAlpha !a (PixelY y) = PixelYA y a - {-# INLINE addAlpha #-} - dropAlpha (PixelYA y _) = PixelY y - {-# INLINE dropAlpha #-} - - -instance Functor (Pixel YA) where - fmap f (PixelYA y a) = PixelYA (f y) (f a) - {-# INLINE fmap #-} - - -instance Applicative (Pixel YA) where - pure !e = PixelYA e e - {-# INLINE pure #-} - (PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel YA) where - foldr f !z (PixelYA y a) = f y (f a z) - {-# INLINE foldr #-} - - -instance Num e => Num (Pixel YA e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - - (-) = liftA2 (-) - {-# INLINE (-) #-} - - (*) = liftA2 (*) - {-# INLINE (*) #-} - - abs = liftA abs - {-# INLINE abs #-} - - signum = liftA signum - {-# INLINE signum #-} - - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional e => Fractional (Pixel YA e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance Floating e => Floating (Pixel YA e) where - pi = pure 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 Storable e => Storable (Pixel YA e) where - - sizeOf _ = 2 * sizeOf (undefined :: e) - alignment _ = alignment (undefined :: e) - peek p = do - q <- return $ castPtr p - y <- peekElemOff q 0 - a <- peekElemOff q 1 - return (PixelYA y a) - poke p (PixelYA y a) = do - q <- return $ castPtr p - pokeElemOff q 0 y - pokeElemOff q 1 a - diff --git a/src/Graphics/Image/ColorSpace/RGB.hs b/src/Graphics/Image/ColorSpace/RGB.hs --- a/src/Graphics/Image/ColorSpace/RGB.hs +++ b/src/Graphics/Image/ColorSpace/RGB.hs @@ -16,7 +16,6 @@ module Graphics.Image.ColorSpace.RGB ( RGB(..), RGBA(..), Pixel(..), ToRGB(..), ToRGBA(..), - -- RGB16 -- Experimental ) where import Prelude hiding (map) @@ -35,12 +34,7 @@ -- | Red, Green and Blue color space. data RGB = RedRGB | GreenRGB - | BlueRGB deriving (Eq, Enum, Typeable) - -instance Show RGB where - show RedRGB = "Red" - show GreenRGB = "Green" - show BlueRGB = "Blue" + | BlueRGB deriving (Eq, Enum, Show, Bounded, Typeable) data instance Pixel RGB e = PixelRGB !e !e !e deriving Eq @@ -69,34 +63,29 @@ toComponents (PixelRGB r g b) = (r, g, b) {-# INLINE toComponents #-} - fromComponents !(r, g, b) = PixelRGB r g b {-# INLINE fromComponents #-} - - broadcastC = pure - {-# INLINE broadcastC #-} - + promote = pure + {-# INLINE promote #-} getPxC (PixelRGB r _ _) RedRGB = r getPxC (PixelRGB _ g _) GreenRGB = g getPxC (PixelRGB _ _ b) BlueRGB = b {-# INLINE getPxC #-} - setPxC (PixelRGB _ g b) RedRGB r = PixelRGB r g b setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b setPxC (PixelRGB r g _) BlueRGB b = PixelRGB r g b {-# INLINE setPxC #-} - mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b) {-# INLINE mapPxC #-} - - mapPx = fmap - {-# INLINE mapPx #-} - - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} - + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelRGB r1 g1 b1) (PixelRGB r2 g2 b2) = + f (f (f z r1 r2) g1 g2) b1 b2 + {-# INLINE foldlPx2 #-} @@ -199,13 +188,7 @@ data RGBA = RedRGBA | GreenRGBA | BlueRGBA - | AlphaRGBA deriving (Eq, Enum, Typeable) - -instance Show RGBA where - show RedRGBA = "Red" - show GreenRGBA = "Green" - show BlueRGBA = "Blue" - show AlphaRGBA = "Alpha" + | AlphaRGBA deriving (Eq, Enum, Show, Bounded, Typeable) data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq @@ -235,37 +218,32 @@ toComponents (PixelRGBA r g b a) = (r, g, b, a) {-# INLINE toComponents #-} - fromComponents !(r, g, b, a) = PixelRGBA r g b a {-# INLINE fromComponents #-} - - broadcastC = pure - {-# INLINE broadcastC #-} - + promote = pure + {-# INLINE promote #-} getPxC (PixelRGBA r _ _ _) RedRGBA = r getPxC (PixelRGBA _ g _ _) GreenRGBA = g getPxC (PixelRGBA _ _ b _) BlueRGBA = b getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a {-# INLINE getPxC #-} - setPxC (PixelRGBA _ g b a) RedRGBA r = PixelRGBA r g b a setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a setPxC (PixelRGBA r g _ a) BlueRGBA b = PixelRGBA r g b a setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a {-# INLINE setPxC #-} - mapPxC f (PixelRGBA r g b a) = PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a) {-# INLINE mapPxC #-} - - mapPx = fmap - {-# INLINE mapPx #-} - - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} - + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelRGBA r1 g1 b1 a1) (PixelRGBA r2 g2 b2 a2) = + f (f (f (f z r1 r2) g1 g2) b1 b2) a1 a2 + {-# INLINE foldlPx2 #-} instance (Elevator e, Typeable e) => AlphaSpace RGBA e where @@ -389,8 +367,8 @@ -- instance ColorSpace RGB16 Word16 where -- type Components RGB16 Word16 = (Word16, Word16, Word16) --- broadcastC !e = PixelRGB16 e e e --- {-# INLINE broadcastC #-} +-- promote !e = PixelRGB16 e e e +-- {-# INLINE promote #-} -- toComponents (PixelRGB16 r g b) = (r, g, b) -- {-# INLINE toComponents #-} @@ -412,84 +390,84 @@ -- mapPxC f (PixelRGB16 r g b) = PixelRGB16 (f RedRGB16 r) (f GreenRGB16 g) (f BlueRGB16 b) -- {-# INLINE mapPxC #-} --- mapPx f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) --- {-# INLINE mapPx #-} +-- liftPx f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) +-- {-# INLINE liftPx #-} --- zipWithPx f (PixelRGB16 r1 g1 b1) (PixelRGB16 r2 g2 b2) = +-- liftPx2 f (PixelRGB16 r1 g1 b1) (PixelRGB16 r2 g2 b2) = -- PixelRGB16 (f r1 r2) (f g1 g2) (f b1 b2) --- {-# INLINE zipWithPx #-} +-- {-# INLINE liftPx2 #-} -- foldlPx f !acc (PixelRGB16 r g b) = f (f (f acc r) g) b -- instance Num (Pixel RGB16 Word16) where --- (+) = zipWithPx (+) +-- (+) = liftPx2 (+) --- (-) = zipWithPx (-) +-- (-) = liftPx2 (-) -- {-# INLINE (-) #-} --- (*) = zipWithPx (*) +-- (*) = liftPx2 (*) -- {-# INLINE (*) #-} --- abs = mapPx abs +-- abs = liftPx abs -- {-# INLINE abs #-} --- signum = mapPx signum +-- signum = liftPx signum -- {-# INLINE signum #-} --- fromInteger = broadcastC . fromInteger +-- fromInteger = promote . fromInteger -- {-# INLINE fromInteger #-} -- -- instance Fractional (Pixel RGB16 Word16) where --- -- (/) = zipWithPx (/) +-- -- (/) = liftPx2 (/) -- -- {-# INLINE (/) #-} --- -- recip = mapPx recip +-- -- recip = liftPx recip -- -- {-# INLINE recip #-} --- -- fromRational = broadcastC . fromRational +-- -- fromRational = promote . fromRational -- -- {-# INLINE fromRational #-} -- -- instance Floating (Pixel RGB16 Word16) where --- -- pi = broadcastC pi +-- -- pi = promote pi -- -- {-# INLINE pi #-} --- -- exp = mapPx exp +-- -- exp = liftPx exp -- -- {-# INLINE exp #-} --- -- log = mapPx log +-- -- log = liftPx log -- -- {-# INLINE log #-} --- -- sin = mapPx sin +-- -- sin = liftPx sin -- -- {-# INLINE sin #-} --- -- cos = mapPx cos +-- -- cos = liftPx cos -- -- {-# INLINE cos #-} --- -- asin = mapPx asin +-- -- asin = liftPx asin -- -- {-# INLINE asin #-} --- -- atan = mapPx atan +-- -- atan = liftPx atan -- -- {-# INLINE atan #-} --- -- acos = mapPx acos +-- -- acos = liftPx acos -- -- {-# INLINE acos #-} --- -- sinh = mapPx sinh +-- -- sinh = liftPx sinh -- -- {-# INLINE sinh #-} --- -- cosh = mapPx cosh +-- -- cosh = liftPx cosh -- -- {-# INLINE cosh #-} --- -- asinh = mapPx asinh +-- -- asinh = liftPx asinh -- -- {-# INLINE asinh #-} --- -- atanh = mapPx atanh +-- -- atanh = liftPx atanh -- -- {-# INLINE atanh #-} --- -- acosh = mapPx acosh +-- -- acosh = liftPx acosh -- -- {-# INLINE acosh #-} diff --git a/src/Graphics/Image/ColorSpace/X.hs b/src/Graphics/Image/ColorSpace/X.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/X.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.X +-- Copyright : (c) Alexey Kuleshevich 2017 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.ColorSpace.X ( + X(..), Pixel(..), toImagesX, fromImagesX + ) where + +import Prelude as P +import Control.Applicative +import Data.Foldable +import Data.Typeable (Typeable) +import Foreign.Ptr +import Foreign.Storable + +import Graphics.Image.Interface as I + +-- ^ This is a single channel colorspace, that is designed to separate Gray +-- level values from other types of colorspace, hence it is not convertible to +-- or from, but rather is here to allow operation on arbirtary single channel +-- images. If you are looking for a true grayscale colorspace +-- 'Graphics.Image.ColorSpace.Luma.Y' should be used instead. +data X = X deriving (Eq, Enum, Bounded, Show, Typeable) + + +data instance Pixel X e = PixelX !e deriving (Ord, Eq) + + +instance Show e => Show (Pixel X e) where + show (PixelX g) = "" + + +instance (Elevator e, Typeable e) => ColorSpace X e where + type Components X e = e + + promote = PixelX + {-# INLINE promote #-} + fromComponents = PixelX + {-# INLINE fromComponents #-} + toComponents (PixelX g) = g + {-# INLINE toComponents #-} + getPxC (PixelX g) X = g + {-# INLINE getPxC #-} + setPxC (PixelX _) X g = PixelX g + {-# INLINE setPxC #-} + mapPxC f (PixelX g) = PixelX (f X g) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelX g1) (PixelX g2) = f z g1 g2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel X) where + fmap f (PixelX g) = PixelX (f g) + {-# INLINE fmap #-} + + +instance Applicative (Pixel X) where + pure = PixelX + {-# INLINE pure #-} + (PixelX fg) <*> (PixelX g) = PixelX (fg g) + {-# INLINE (<*>) #-} + + +instance Foldable (Pixel X) where + foldr f !z (PixelX g) = f g z + {-# INLINE foldr #-} + + +instance Monad (Pixel X) where + + return = PixelX + {-# INLINE return #-} + + (>>=) (PixelX g) f = f g + {-# INLINE (>>=) #-} + + +instance Num e => Num (Pixel X e) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + + (-) = liftA2 (-) + {-# INLINE (-) #-} + + (*) = liftA2 (*) + {-# INLINE (*) #-} + + abs = liftA abs + {-# INLINE abs #-} + + signum = liftA signum + {-# INLINE signum #-} + + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional e => Fractional (Pixel X e) where + (/) = liftA2 (/) + {-# INLINE (/) #-} + recip = liftA recip + {-# INLINE recip #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance Floating e => Floating (Pixel X e) where + pi = pure 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 Storable e => Storable (Pixel X e) where + + sizeOf _ = sizeOf (undefined :: e) + alignment _ = alignment (undefined :: e) + peek p = do + q <- return $ castPtr p + g <- peek q + return (PixelX g) + poke p (PixelX g) = do + q <- return $ castPtr p + poke q g + +-- | Separate an image into a list of images with 'X' pixels containing every +-- channel from the source image. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> let [frog_red, frog_green, frog_blue] = toImagesX 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 +-- +-- <> <> <> +-- +toImagesX :: (Array arr cs e, Array arr X e) => Image arr cs e -> [Image arr X e] +toImagesX !img = P.map getCh (enumFrom minBound) where + getCh !ch = I.map (PixelX . (`getPxC` ch)) img + {-# INLINE getCh #-} +{-# INLINE toImagesX #-} + + +-- | Combine a list of images with 'X' 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" $ fromImagesX [frog_red, frog_green, frog_blue] [RedRGB, BlueRGB, GreenRGB] +-- +-- <> <> +-- +-- It is worth noting though, despite that separating image channels can be +-- sometimes pretty useful, exactly the same effect as in example above can be +-- achieved in a much simpler and a more efficient way: +-- +-- @ map (\(PixelRGB r g b) -> PixelRGB r b g) frog @ +-- +fromImagesX :: forall arr cs e . (Array arr X e, Array arr cs e) => + [(cs, Image arr X e)] -> Image arr cs e +fromImagesX = fromXs 0 where + updateCh ch px (PixelX e) = setPxC px ch e + {-# INLINE updateCh #-} + fromXs img [] = img + fromXs img ((c, i):xs) = fromXs (I.zipWith (updateCh c) img i) xs + {-# INLINE fromXs #-} +{-# INLINE fromImagesX #-} diff --git a/src/Graphics/Image/ColorSpace/Y.hs b/src/Graphics/Image/ColorSpace/Y.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/ColorSpace/Y.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.Y +-- Copyright : (c) Alexey Kuleshevich 2017 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.ColorSpace.Y ( + Y(..), YA(..), Pixel(..), + ToY(..), ToYA(..) + ) where + +import Prelude hiding (map) +import Control.Applicative +import Data.Foldable +import Data.Typeable (Typeable) +import Foreign.Ptr +import Foreign.Storable + +import Graphics.Image.Interface + +--------- +--- Y --- +--------- + +-- | Luma or brightness, which is usually denoted as @Y'@. +data Y = LumaY deriving (Eq, Enum, Show, Bounded, Typeable) + + +data instance Pixel Y e = PixelY !e deriving (Ord, Eq) + +-- | Conversion to Luma color space. +class ColorSpace cs Double => ToY cs where + + -- | Convert a pixel to Luma pixel. + toPixelY :: Pixel cs Double -> Pixel Y Double + + -- | Convert an image to Luma image. + toImageY :: (Array arr cs Double, Array arr Y Double) => + Image arr cs Double + -> Image arr Y Double + toImageY = map toPixelY + {-# INLINE toImageY #-} + +instance Show e => Show (Pixel Y e) where + show (PixelY g) = "" + +instance (Elevator e, Typeable e) => ColorSpace Y e where + type Components Y e = e + promote = PixelY + {-# INLINE promote #-} + fromComponents = PixelY + {-# INLINE fromComponents #-} + toComponents (PixelY y) = y + {-# INLINE toComponents #-} + getPxC (PixelY y) LumaY = y + {-# INLINE getPxC #-} + setPxC _ LumaY y = PixelY y + {-# INLINE setPxC #-} + mapPxC f (PixelY y) = PixelY (f LumaY y) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelY y1) (PixelY y2) = f z y1 y2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel Y) where + fmap f (PixelY y) = PixelY (f y) + {-# INLINE fmap #-} + + +instance Applicative (Pixel Y) where + pure = PixelY + {-# INLINE pure #-} + (PixelY fy) <*> (PixelY y) = PixelY (fy y) + {-# INLINE (<*>) #-} + + +instance Foldable (Pixel Y) where + foldr f !z (PixelY y) = f y z + {-# INLINE foldr #-} + + +instance Monad (Pixel Y) where + + return = PixelY + {-# INLINE return #-} + + (>>=) (PixelY y) f = f y + {-# INLINE (>>=) #-} + + +instance Num e => Num (Pixel Y e) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + (-) = liftA2 (-) + {-# INLINE (-) #-} + (*) = liftA2 (*) + {-# INLINE (*) #-} + abs = liftA abs + {-# INLINE abs #-} + signum = liftA signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional e => Fractional (Pixel Y e) where + (/) = liftA2 (/) + {-# INLINE (/) #-} + recip = liftA recip + {-# INLINE recip #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance Floating e => Floating (Pixel Y e) where + pi = pure 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 Storable e => Storable (Pixel Y e) where + + sizeOf _ = sizeOf (undefined :: e) + alignment _ = alignment (undefined :: e) + peek p = do + q <- return $ castPtr p + y <- peek q + return (PixelY y) + poke p (PixelY y) = do + q <- return $ castPtr p + poke q y + + + + +---------- +--- YA --- +---------- + +-- | Luma with Alpha channel. +data YA = LumaYA -- ^ Luma + | AlphaYA -- ^ Alpha channel + deriving (Eq, Enum, Show, Bounded, Typeable) + +data instance Pixel YA e = PixelYA !e !e deriving Eq + +-- | Conversion to Luma from another color space with Alpha channel. +class (ToY (Opaque cs), AlphaSpace cs Double) => ToYA cs where + + -- | Convert a pixel to Luma pixel with Alpha. + toPixelYA :: Pixel cs Double -> Pixel YA Double + toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px)) + {-# INLINE toPixelYA #-} + + -- | Convert an image to Luma image with Alpha. + toImageYA :: (Array arr cs Double, Array arr YA Double) => + Image arr cs Double + -> Image arr YA Double + toImageYA = map toPixelYA + {-# INLINE toImageYA #-} + + +instance (Elevator e, Typeable e) => ColorSpace YA e where + type Components YA e = (e, e) + promote e = PixelYA e e + {-# INLINE promote #-} + fromComponents (y, a) = PixelYA y a + {-# INLINE fromComponents #-} + toComponents (PixelYA y a) = (y, a) + {-# INLINE toComponents #-} + getPxC (PixelYA y _) LumaYA = y + getPxC (PixelYA _ a) AlphaYA = a + {-# INLINE getPxC #-} + setPxC (PixelYA _ a) LumaYA y = PixelYA y a + setPxC (PixelYA y _) AlphaYA a = PixelYA y a + {-# INLINE setPxC #-} + mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2 + {-# INLINE foldlPx2 #-} + + +instance (Elevator e, Typeable e) => AlphaSpace YA e where + type Opaque YA = Y + + getAlpha (PixelYA _ a) = a + {-# INLINE getAlpha #-} + addAlpha !a (PixelY y) = PixelYA y a + {-# INLINE addAlpha #-} + dropAlpha (PixelYA y _) = PixelY y + {-# INLINE dropAlpha #-} + + +instance Functor (Pixel YA) where + fmap f (PixelYA y a) = PixelYA (f y) (f a) + {-# INLINE fmap #-} + + +instance Applicative (Pixel YA) where + pure !e = PixelYA e e + {-# INLINE pure #-} + (PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a) + {-# INLINE (<*>) #-} + + +instance Foldable (Pixel YA) where + foldr f !z (PixelYA y a) = f y (f a z) + {-# INLINE foldr #-} + + +instance Num e => Num (Pixel YA e) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + + (-) = liftA2 (-) + {-# INLINE (-) #-} + + (*) = liftA2 (*) + {-# INLINE (*) #-} + + abs = liftA abs + {-# INLINE abs #-} + + signum = liftA signum + {-# INLINE signum #-} + + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Fractional e => Fractional (Pixel YA e) where + (/) = liftA2 (/) + {-# INLINE (/) #-} + recip = liftA recip + {-# INLINE recip #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance Floating e => Floating (Pixel YA e) where + pi = pure 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 Storable e => Storable (Pixel YA e) where + + sizeOf _ = 2 * sizeOf (undefined :: e) + alignment _ = alignment (undefined :: e) + peek p = do + q <- return $ castPtr p + y <- peekElemOff q 0 + a <- peekElemOff q 1 + return (PixelYA y a) + poke p (PixelYA y a) = do + q <- return $ castPtr p + pokeElemOff q 0 y + pokeElemOff q 1 a + diff --git a/src/Graphics/Image/ColorSpace/YCbCr.hs b/src/Graphics/Image/ColorSpace/YCbCr.hs --- a/src/Graphics/Image/ColorSpace/YCbCr.hs +++ b/src/Graphics/Image/ColorSpace/YCbCr.hs @@ -37,17 +37,11 @@ data YCbCr = LumaYCbCr -- ^ Luma component (commonly denoted as __Y'__) | CBlueYCbCr -- ^ Blue difference chroma component | CRedYCbCr -- ^ Red difference chroma component - deriving (Eq, Enum, Typeable) + deriving (Eq, Enum, Show, Bounded, Typeable) data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq -instance Show YCbCr where - show LumaYCbCr = "Luma" - show CBlueYCbCr = "Blue Chroma" - show CRedYCbCr = "Red Chroma" - - instance Show e => Show (Pixel YCbCr e) where show (PixelYCbCr y b r) = "" @@ -55,8 +49,8 @@ instance (Elevator e, Typeable e) => ColorSpace YCbCr e where type Components YCbCr e = (e, e, e) - broadcastC !e = PixelYCbCr e e e - {-# INLINE broadcastC #-} + promote !e = PixelYCbCr e e e + {-# INLINE promote #-} fromComponents !(y, b, r) = PixelYCbCr y b r {-# INLINE fromComponents #-} toComponents (PixelYCbCr y b r) = (y, b, r) @@ -71,12 +65,15 @@ {-# INLINE setPxC #-} mapPxC f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r) {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelYCbCr y1 b1 r1) (PixelYCbCr y2 b2 r2) = + f (f (f z y1 y2) b1 b2) r1 r2 + {-# INLINE foldlPx2 #-} instance Functor (Pixel YCbCr) where @@ -177,17 +174,10 @@ | CBlueYCbCrA -- ^ Blue difference chroma component | CRedYCbCrA -- ^ Red difference chroma component | AlphaYCbCrA -- ^ Alpha component. - deriving (Eq, Enum, Typeable) + deriving (Eq, Enum, Show, Bounded, Typeable) data instance Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq - -instance Show YCbCrA where - show LumaYCbCrA = "Luma" - show CBlueYCbCrA = "Blue Chroma" - show CRedYCbCrA = "Red Chroma" - show AlphaYCbCrA = "Alpha" - instance Show e => Show (Pixel YCbCrA e) where show (PixelYCbCrA y b r a) = "" @@ -196,8 +186,8 @@ instance (Elevator e, Typeable e) => ColorSpace YCbCrA e where type Components YCbCrA e = (e, e, e, e) - broadcastC !e = PixelYCbCrA e e e e - {-# INLINE broadcastC #-} + promote !e = PixelYCbCrA e e e e + {-# INLINE promote #-} fromComponents !(y, b, r, a) = PixelYCbCrA y b r a {-# INLINE fromComponents #-} toComponents (PixelYCbCrA y b r a) = (y, b, r, a) @@ -215,12 +205,15 @@ mapPxC f (PixelYCbCrA y b r a) = PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a) {-# INLINE mapPxC #-} - mapPx = fmap - {-# INLINE mapPx #-} - zipWithPx = liftA2 - {-# INLINE zipWithPx #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} foldlPx = foldl' {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelYCbCrA y1 b1 r1 a1) (PixelYCbCrA y2 b2 r2 a2) = + f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2 + {-# INLINE foldlPx2 #-} -- | Conversion to `YCbCr` color space. diff --git a/src/Graphics/Image/IO/Formats.hs b/src/Graphics/Image/IO/Formats.hs --- a/src/Graphics/Image/IO/Formats.hs +++ b/src/Graphics/Image/IO/Formats.hs @@ -15,7 +15,7 @@ module Graphics.Image.IO.Formats ( module Graphics.Image.IO.Formats.JuicyPixels, module Graphics.Image.IO.Formats.Netpbm, - InputFormat, OutputFormat, + InputFormat(..), OutputFormat(..), Readable(..), Writable(..), ImageFormat(..), ) where @@ -37,7 +37,7 @@ | InputPNG | InputTIF | InputPNM - | InputTGA deriving (Show, Enum, Eq) + | InputTGA deriving (Eq, Show, Enum, Bounded) instance ImageFormat InputFormat where @@ -90,7 +90,7 @@ | OutputJPG | OutputPNG | OutputTIF - | OutputTGA deriving (Show, Enum, Eq) + | OutputTGA deriving (Eq, Show, Enum, Bounded) instance ImageFormat OutputFormat where diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels.hs b/src/Graphics/Image/IO/Formats/JuicyPixels.hs --- a/src/Graphics/Image/IO/Formats/JuicyPixels.hs +++ b/src/Graphics/Image/IO/Formats/JuicyPixels.hs @@ -208,13 +208,13 @@ -- Y -> RGB (Double) instance Convertible JP.Pixel8 (Pixel RGB Double) where - convert = broadcastC . toDouble + convert = promote . toDouble instance Convertible JP.Pixel16 (Pixel RGB Double) where - convert = broadcastC . toDouble + convert = promote . toDouble instance Convertible JP.PixelF (Pixel RGB Double) where - convert = broadcastC . toDouble + convert = promote . toDouble instance Convertible JP.PixelYA8 (Pixel RGB Double) where convert = convert . JP.dropTransparency diff --git a/src/Graphics/Image/IO/Histogram.hs b/src/Graphics/Image/IO/Histogram.hs --- a/src/Graphics/Image/IO/Histogram.hs +++ b/src/Graphics/Image/IO/Histogram.hs @@ -65,24 +65,24 @@ type Histograms = [Histogram] -- | Create a histogram per channel with 256 bins each. -getHistograms :: forall arr cs e . (ChannelColour cs, MArray arr Gray e, Array arr Gray e, +getHistograms :: forall arr cs e . (ChannelColour cs, MArray arr X e, Array arr X e, MArray arr cs e, Array arr cs e) => Image arr cs e -> Histograms -getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toGrayImages +getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toImagesX where setCh cs h = h { hName = show cs , hColour = csColour cs } -- | Generate a histogram with 256 bins for a single channel Gray image. -getHistogram :: MArray arr Gray e => - Image arr Gray e +getHistogram :: MArray arr X e => + Image arr X e -> Histogram getHistogram img = Histogram { hBins = V.modify countBins $ V.replicate (1 + fromIntegral (maxBound :: Word8)) (0 :: Int) - , hName = show Gray - , hColour = csColour Gray } where - incBin v (PixelGray g) = modify v (+1) $ fromIntegral (toWord8 g) + , hName = show X + , hColour = csColour X } where + incBin v (PixelX g) = modify v (+1) $ fromIntegral (toWord8 g) countBins v = I.mapM_ (incBin v) img @@ -128,7 +128,7 @@ then display else void $ forkIO display -instance ChannelColour Gray where +instance ChannelColour X where csColour _ = C.opaque C.darkgray instance ChannelColour Y where diff --git a/src/Graphics/Image/Interface.hs b/src/Graphics/Image/Interface.hs --- a/src/Graphics/Image/Interface.hs +++ b/src/Graphics/Image/Interface.hs @@ -23,7 +23,7 @@ module Graphics.Image.Interface ( Pixel, ColorSpace(..), AlphaSpace(..), Elevator(..), BaseArray(..), Array(..), MArray(..), - Exchangable(..), exchangeFrom, + Exchangable(..), exchangeFrom, exchangeThrough, defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex, fromIx, toIx, checkDims #if !MIN_VERSION_base(4,8,0) @@ -50,7 +50,8 @@ data family Pixel cs e :: * -class (Eq cs, Enum cs, Show cs, Typeable cs, Elevator e, Typeable e) => ColorSpace cs e where +class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs, Elevator e, Typeable e) + => ColorSpace cs e where type Components cs e @@ -61,8 +62,8 @@ -- | Convert from an elemnt representation back to a Pixel. fromComponents :: Components cs e -> Pixel cs e - -- | Construt a pixel by replicating a same value among all of the components. - broadcastC :: e -> Pixel cs e + -- | Construt a Pixel by replicating the same value across all of the components. + promote :: e -> Pixel cs e -- | Retrieve Pixel's component value getPxC :: Pixel cs e -> cs -> e @@ -74,11 +75,13 @@ mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e -- | Map a function over all Pixel's componenets. - mapPx :: (e -> e) -> Pixel cs e -> Pixel cs e + liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e -- | Zip two Pixels with a function. - zipWithPx :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e + liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e + foldlPx2 :: (b -> e -> e -> b) -> b -> Pixel cs e -> Pixel cs e -> b + -- | Right fold over all Pixel's components. foldrPx :: (e -> b -> b) -> b -> Pixel cs e -> b foldrPx f !z0 !xs = foldlPx f' id xs z0 @@ -90,7 +93,7 @@ where f' x k !z = k $! f z x foldl1Px :: (e -> e -> e) -> Pixel cs e -> e - foldl1Px f !xs = fromMaybe (error "foldl1: empty Pixel") + foldl1Px f !xs = fromMaybe (error "foldl1Px: empty Pixel") (foldlPx mf Nothing xs) where mf m !y = Just (case m of @@ -197,9 +200,9 @@ -- ^ Function that generates border pixels -> Image arr cs e - -- | Create a singleton image, required for various operations on images with + -- | Create a scalar image, required for various operations on images with -- a scalar. - singleton :: Pixel cs e -> Image arr cs e + scalar :: Pixel cs e -> Image arr cs e -- | Retrieves a pixel at @(0, 0)@ index. Useful together with `fold`, when -- arbitrary initial pixel is needed. @@ -411,6 +414,17 @@ {-# INLINE exchangeFrom #-} +-- | `exchange` an image representation through an intermediate one. +exchangeThrough :: (Exchangable arr2 arr1, Exchangable arr1 arr, + Array arr2 cs e, Array arr1 cs e, Array arr cs e) => + arr1 + -> arr -- ^ New representation of an image. + -> Image arr2 cs e -- ^ Source image. + -> Image arr cs e +exchangeThrough through to = exchange to . exchange through +{-# INLINE exchangeThrough #-} + + -- | Approach to be used near the borders during various transformations. -- Whenever a function needs information not only about a pixel of interest, but -- also about it's neighbours, it will go out of bounds around the image edges, @@ -453,32 +467,109 @@ -- deriving Show +-- handleBorderIndex' :: Border px -- ^ Border handling strategy. +-- -> (Int, Int) -- ^ Image dimensions +-- -> ((Int, Int) -> px) -- ^ Image's indexing function. +-- -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup. +-- -> px +-- handleBorderIndex' 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 handleBorderIndex' #-} + + + + -- | 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. handleBorderIndex :: Border px -- ^ Border handling strategy. - -> (Int, Int) -- ^ Image dimensions - -> ((Int, Int) -> px) -- ^ Image's indexing function. - -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup. - -> px + -> (Int, Int) -- ^ Image dimensions + -> ((Int, Int) -> px) -- ^ Image's indexing function. + -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup. + -> px handleBorderIndex 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 #-} + if north || east || south || west + then case border of + Fill px -> px + Wrap -> getPx (i `mod` m, j `mod` n) + Edge -> getPx (if north then 0 else if south then m - 1 else i, + if west then 0 else if east then n - 1 else j) + Reflect -> getPx (if north then (abs i - 1) `mod` m else + if south then (-i - 1) `mod` m else i, + if west then (abs j - 1) `mod` n else + if east then (-j - 1) `mod` n else j) + Continue -> getPx (if north then abs i `mod` m else + if south then (-i - 2) `mod` m else i, + if west then abs j `mod` n else + if east then (-j - 2) `mod` n else j) + -- Reflect -> getPx (if north then (abs i - 1) `mod` m else + -- if south then (m - (i - m + 1)) `mod` m else i, + -- if west then (abs j - 1) `mod` n else + -- if east then (n - (j - n + 1)) `mod` n else j) + -- Continue -> getPx (if north then abs i `mod` m else + -- if south then (m - (i - m + 2)) `mod` m else i, + -- if west then abs j `mod` n else + -- if east then (n - (j - n + 2)) `mod` n else j) + else getPx (i, j) + where + north = i < 0 + {-# INLINE north #-} + south = i >= m + {-# INLINE south #-} + west = j < 0 + {-# INLINE west #-} + east = j >= n + {-# INLINE east #-} {-# INLINE handleBorderIndex #-} + +-- handleBorderIndex' border !(m, n) getPx !(i, j) = +-- case (i < 0, i >= m, j < 0, j >= n) of +-- (False, False, False, False) -> getPx (i, j) +-- (False, False, False, True) -> +-- case border of +-- Fill px -> px +-- Wrap -> getPx (i, j `mod` n) +-- Edge -> getPx (i, n-1) +-- Reflect -> getPx (i, (n - (j - n + 1)) `mod` n) +-- Continue -> getPx (i, (n - (j - n + 2)) `mod` n) +-- (False, False, True, False) -> +-- case border of +-- Fill px -> px +-- Wrap -> getPx (i, j `mod` n) +-- Edge -> getPx (i, 0) +-- Reflect -> getPx (i, (abs j - 1) `mod` n) +-- Continue -> getPx (i, abs j `mod` n) +-- (False, True, False, False) -> +-- case border of +-- Fill px -> px +-- Wrap -> getPx (i, j `mod` n) +-- Edge -> getPx (i, 0) +-- Reflect -> getPx (i, (abs j - 1) `mod` n) +-- Continue -> getPx (i, abs j `mod` n) + --((False, False, False, True), Edge) -> getPx (i, j `mod` n) + + -- case (i >= 0, j >= 0, i < m, j < n) of + -- (True, True, True, True) -> getPx (i, j) + -- (True, True, True, True) -> getPx (i, j) + -- then getPx (i, j) else getPxB border where + + + -- | Image indexing function that returns a default pixel if index is out of bounds. defaultIndex :: MArray arr cs e => Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e @@ -525,7 +616,7 @@ checkDims err !ds@(m, n) | m <= 0 || n <= 0 = error $ - show err ++ ": Image dimensions are expected to be non-negative: " ++ show ds + show err ++ ": Image dimensions are expected to be positive: " ++ show ds | otherwise = ds {-# INLINE checkDims #-} @@ -565,7 +656,7 @@ signum = map signum {-# INLINE signum #-} - fromInteger = singleton . fromInteger + fromInteger = scalar . fromInteger {-# INLINE fromInteger #-} @@ -574,13 +665,13 @@ (/) = zipWith (/) {-# INLINE (/) #-} - fromRational = singleton . fromRational + fromRational = scalar . fromRational {-# INLINE fromRational #-} instance (Floating (Pixel cs e), Array arr cs e) => Floating (Image arr cs e) where - pi = singleton pi + pi = scalar pi {-# INLINE pi #-} exp = map exp diff --git a/src/Graphics/Image/Interface/Repa.hs b/src/Graphics/Image/Interface/Repa.hs --- a/src/Graphics/Image/Interface/Repa.hs +++ b/src/Graphics/Image/Interface/Repa.hs @@ -24,9 +24,57 @@ import Graphics.Image.Interface.Repa.Generic import Graphics.Image.Interface.Repa.Storable import Graphics.Image.Interface.Repa.Unboxed +import Graphics.Image.Interface.Vector +-- | Makes a copy of an image into a Storable Vector representation. +instance Exchangable VU RSS where + exchange = exchangeThrough VS + {-# INLINE exchange #-} + +-- | Makes a copy of an image into a Storable Vector representation. +instance Exchangable VU RPS where + exchange = exchangeThrough VS + {-# INLINE exchange #-} + + + +-- | Makes a copy of an image into a Storable Vector representation. +instance Exchangable VS RSU where + exchange = exchangeThrough VU + {-# INLINE exchange #-} + + +-- | Makes a copy of an image into a Storable Vector representation. +instance Exchangable VS RPU where + exchange = exchangeThrough VU + {-# INLINE exchange #-} + + +-- | Makes a copy of an image into a Storable Vector representation. +instance Exchangable RSU VS where + exchange _ = exchange VS . toManifest + {-# INLINE exchange #-} + + +-- | Makes a copy of an image into a Storable Vector representation. +instance Exchangable RPU VS where + exchange _ = exchange VS . toManifest + {-# INLINE exchange #-} + + + +-- | Makes a copy of an image into a Unboxed Vector representation. +instance Exchangable RSS VU where + exchange _ = exchange VU . toManifest + {-# INLINE exchange #-} + + +-- | Makes a copy of an image into a Unboxed Vector representation. +instance Exchangable RPS VU where + exchange _ = exchange VU . toManifest + {-# INLINE exchange #-} -- | Makes a copy of an image into a Storable representation sequentially. diff --git a/src/Graphics/Image/Interface/Repa/Generic.hs b/src/Graphics/Image/Interface/Repa/Generic.hs --- a/src/Graphics/Image/Interface/Repa/Generic.hs +++ b/src/Graphics/Image/Interface/Repa/Generic.hs @@ -84,8 +84,8 @@ (R.fromFunction (Z :. m :. n) (getWindowPx . sh2ix)) (R.fromFunction (Z :. m :. n) (getBorderPx . sh2ix)) - singleton = SScalar - {-# INLINE singleton #-} + scalar = SScalar + {-# INLINE scalar #-} index00 (SScalar px) = px index00 (STImage arr) = R.index arr (Z :. 0 :. 0) @@ -132,7 +132,7 @@ backpermute !newDims g !img = SDImage (backpermuteR (getDelayedS img) newDims g) {-# INLINE backpermute #-} - fromLists = STImage . fromListsR + fromLists = STImage . fromListsRepa {-# INLINE fromLists #-} fold f !px0 (SDImage arr) = R.foldAllS f px0 arr @@ -158,8 +158,8 @@ SDImage (multR (show img1 ++ " X " ++ show img2) arr1 arr2) (|*|) img1@(SDImage _) !img2 = compute img1 |*| img2 (|*|) !img1 img2@(SDImage _) = img1 |*| compute img2 - (|*|) (SScalar px1) !img2 = STImage (singletonR px1) |*| img2 - (|*|) !img1 (SScalar px2) = img1 |*| STImage (singletonR px2) + (|*|) (SScalar px1) !img2 = STImage (scalarR px1) |*| img2 + (|*|) !img1 (SScalar px2) = img1 |*| STImage (scalarR px2) {-# INLINE (|*|) #-} toManifest _ = error $ "RS.toManifest: Cannot convert generic Repa " ++ @@ -203,8 +203,8 @@ (R.fromFunction (Z :. m :. n) (getWindowPx . sh2ix)) (R.fromFunction (Z :. m :. n) (getBorderPx . sh2ix)) - singleton = PScalar - {-# INLINE singleton #-} + scalar = PScalar + {-# INLINE scalar #-} index00 (PScalar px) = px index00 (PTImage arr) = R.index arr (Z :. 0 :. 0) @@ -251,7 +251,7 @@ backpermute !newDims g !img = PDImage (backpermuteR (getDelayedP img) newDims g) {-# INLINE backpermute #-} - fromLists = PTImage . fromListsR + fromLists = PTImage . fromListsRepa {-# INLINE fromLists #-} fold f !px0 (PScalar px) = f px0 px @@ -286,8 +286,8 @@ PDImage (multR (show img1 ++ " X " ++ show img2) arr1 arr2) (|*|) img1@(PDImage _) !img2 = compute img1 |*| img2 (|*|) !img1 img2@(PDImage _) = img1 |*| compute img2 - (|*|) (PScalar px1) !img2 = PTImage (singletonR px1) |*| img2 - (|*|) !img1 (PScalar px2) = img1 |*| PTImage (singletonR px2) + (|*|) (PScalar px1) !img2 = PTImage (scalarR px1) |*| img2 + (|*|) !img1 (PScalar px2) = img1 |*| PTImage (scalarR px2) {-# INLINE (|*|) #-} toManifest _ = error $ "RP.toManifest: Cannot convert generic Repa " ++ @@ -386,14 +386,14 @@ {-# INLINE backpermuteR #-} -fromListsR :: (R.Target r e) => [[e]] -> R.Array r DIM2 e -fromListsR ls = +fromListsRepa :: (R.Target r e) => [[e]] -> R.Array r DIM2 e +fromListsRepa ls = if all (== n) (P.map length ls) then R.fromList (Z :. m :. n) . concat $ ls - else error "fromListsR: Inner lists do not all have an equal length." + else error "fromListsRepa: Inner lists do not all have an equal length." where - !(m, n) = checkDims "fromListsR" (length ls, length $ head ls) -{-# INLINE fromListsR #-} + !(m, n) = checkDims "fromListsRepa" (length ls, length $ head ls) +{-# INLINE fromListsRepa #-} @@ -417,8 +417,8 @@ {-# INLINE multR #-} -singletonR :: (IVU.Unbox a, R.Target r a) => a -> R.Array r DIM2 a -singletonR !px = R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px +scalarR :: (IVU.Unbox a, R.Target r a) => a -> R.Array r DIM2 a +scalarR !px = R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px getDelayedS :: Array (RS r) cs e => Image (RS r) cs e -> R.Array R.D DIM2 (Pixel cs e) diff --git a/src/Graphics/Image/Interface/Repa/Storable.hs b/src/Graphics/Image/Interface/Repa/Storable.hs --- a/src/Graphics/Image/Interface/Repa/Storable.hs +++ b/src/Graphics/Image/Interface/Repa/Storable.hs @@ -75,8 +75,8 @@ makeImageWindowed !sz !w f = SSImage . makeImageWindowed sz w f {-# INLINE makeImageWindowed #-} - singleton = SSImage . I.singleton - {-# INLINE singleton #-} + scalar = SSImage . I.scalar + {-# INLINE scalar #-} index00 (SSImage img) = index00 img {-# INLINE index00 #-} @@ -123,7 +123,7 @@ (|*|) (SSImage img1) (SSImage img2) = SSImage (img1 |*| img2) {-# INLINE (|*|) #-} - toManifest (SSImage (SScalar px)) = I.singleton px + toManifest (SSImage (SScalar px)) = I.scalar px toManifest (SSImage (STImage arr)) = fromRepaArrayStorable arr toManifest !img = toManifest (compute img) {-# INLINE toManifest #-} @@ -153,8 +153,8 @@ makeImageWindowed !sz !w f = PSImage . makeImageWindowed sz w f {-# INLINE makeImageWindowed #-} - singleton = PSImage . singleton - {-# INLINE singleton #-} + scalar = PSImage . scalar + {-# INLINE scalar #-} index00 (PSImage img) = index00 img {-# INLINE index00 #-} @@ -201,7 +201,7 @@ (|*|) (PSImage img1) (PSImage img2) = PSImage (img1 |*| img2) {-# INLINE (|*|) #-} - toManifest (PSImage (PScalar px)) = singleton px + toManifest (PSImage (PScalar px)) = scalar px toManifest (PSImage (PTImage arr)) = fromRepaArrayStorable arr toManifest !img = toManifest (compute img) {-# INLINE toManifest #-} @@ -223,7 +223,7 @@ -- | O(1) - Changes to Repa representation. instance Exchangable IVS.VS RSS where - exchange _ !img@(dims -> (1, 1)) = singleton (index00 img) + exchange _ !img@(dims -> (1, 1)) = scalar (index00 img) exchange _ !img = SSImage . STImage . toRepaArrayStorable $ img {-# INLINE exchange #-} @@ -231,7 +231,7 @@ -- | O(1) - Changes to Repa representation. instance Exchangable IVS.VS RPS where - exchange _ !img@(dims -> (1, 1)) = singleton (index00 img) + exchange _ !img@(dims -> (1, 1)) = scalar (index00 img) exchange _ !img = PSImage . PTImage . toRepaArrayStorable $ img {-# INLINE exchange #-} diff --git a/src/Graphics/Image/Interface/Repa/Unboxed.hs b/src/Graphics/Image/Interface/Repa/Unboxed.hs --- a/src/Graphics/Image/Interface/Repa/Unboxed.hs +++ b/src/Graphics/Image/Interface/Repa/Unboxed.hs @@ -68,8 +68,8 @@ makeImageWindowed !sz !w f = SUImage . makeImageWindowed sz w f {-# INLINE makeImageWindowed #-} - singleton = SUImage . singleton - {-# INLINE singleton #-} + scalar = SUImage . scalar + {-# INLINE scalar #-} index00 (SUImage img) = index00 img {-# INLINE index00 #-} @@ -116,7 +116,7 @@ (|*|) (SUImage img1) (SUImage img2) = SUImage (img1 |*| img2) {-# INLINE (|*|) #-} - toManifest (SUImage (SScalar px)) = singleton px + toManifest (SUImage (SScalar px)) = scalar px toManifest (SUImage (STImage arr)) = IVU.fromUnboxedVector (sh2ix (R.extent arr)) (R.toUnboxed arr) toManifest !img = toManifest (compute img) @@ -146,8 +146,8 @@ makeImageWindowed !sz !w f = PUImage . makeImageWindowed sz w f {-# INLINE makeImageWindowed #-} - singleton = PUImage . singleton - {-# INLINE singleton #-} + scalar = PUImage . scalar + {-# INLINE scalar #-} index00 (PUImage img) = index00 img {-# INLINE index00 #-} @@ -194,7 +194,7 @@ (|*|) (PUImage img1) (PUImage img2) = PUImage (img1 |*| img2) {-# INLINE (|*|) #-} - toManifest (PUImage (PScalar px)) = singleton px + toManifest (PUImage (PScalar px)) = scalar px toManifest (PUImage (PTImage arr)) = IVU.fromUnboxedVector (sh2ix (R.extent arr)) (R.toUnboxed arr) toManifest !img = toManifest (compute img) @@ -217,7 +217,7 @@ -- | O(1) - Changes to Repa representation. instance Exchangable IVU.VU RSU where - exchange _ img@(dims -> (1, 1)) = singleton (index00 img) + exchange _ img@(dims -> (1, 1)) = scalar (index00 img) exchange _ img = SUImage . STImage . R.fromUnboxed (ix2sh $ dims img) . IVU.toUnboxedVector $ img {-# INLINE exchange #-} @@ -225,7 +225,7 @@ -- | O(1) - Changes to Repa representation. instance Exchangable IVU.VU RPU where - exchange _ img@(dims -> (1, 1)) = singleton (index00 img) + exchange _ img@(dims -> (1, 1)) = scalar (index00 img) exchange _ img = PUImage . PTImage . R.fromUnboxed (ix2sh $ dims img) . IVU.toUnboxedVector $ img {-# INLINE exchange #-} diff --git a/src/Graphics/Image/Interface/Vector/Generic.hs b/src/Graphics/Image/Interface/Vector/Generic.hs --- a/src/Graphics/Image/Interface/Vector/Generic.hs +++ b/src/Graphics/Image/Interface/Vector/Generic.hs @@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -41,7 +41,7 @@ type family Repr arr :: * -> * instance Show r => Show (V r) where - show r = "Vector " ++ show r + show (V r) = "Vector " ++ show r instance SuperClass (V r) cs e => BaseArray (V r) cs e where type SuperClass (V r) cs e = (Show r, ColorSpace cs e, Num (Pixel cs e), @@ -90,8 +90,8 @@ {-# INLINE generate #-} {-# INLINE makeImageWindowed #-} - singleton = VScalar - {-# INLINE singleton #-} + scalar = VScalar + {-# INLINE scalar #-} index00 (VScalar px) = px index00 (VImage _ _ v) = v VG.! 0 diff --git a/src/Graphics/Image/Interface/Vector/Storable.hs b/src/Graphics/Image/Interface/Vector/Storable.hs --- a/src/Graphics/Image/Interface/Vector/Storable.hs +++ b/src/Graphics/Image/Interface/Vector/Storable.hs @@ -65,8 +65,8 @@ makeImageWindowed !sh !window f g = VSImage $ makeImageWindowed sh window f g {-# INLINE makeImageWindowed #-} - singleton = VSImage . singleton - {-# INLINE singleton #-} + scalar = VSImage . scalar + {-# INLINE scalar #-} index00 (VSImage img) = index00 img {-# INLINE index00 #-} diff --git a/src/Graphics/Image/Interface/Vector/Unboxed.hs b/src/Graphics/Image/Interface/Vector/Unboxed.hs --- a/src/Graphics/Image/Interface/Vector/Unboxed.hs +++ b/src/Graphics/Image/Interface/Vector/Unboxed.hs @@ -66,8 +66,8 @@ makeImageWindowed !sh !window f g = VUImage $ makeImageWindowed sh window f g {-# INLINE makeImageWindowed #-} - singleton = VUImage . singleton - {-# INLINE singleton #-} + scalar = VUImage . scalar + {-# INLINE scalar #-} index00 (VUImage img) = index00 img {-# INLINE index00 #-} diff --git a/src/Graphics/Image/Processing.hs b/src/Graphics/Image/Processing.hs --- a/src/Graphics/Image/Processing.hs +++ b/src/Graphics/Image/Processing.hs @@ -47,7 +47,7 @@ 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 broadcastC $ fromDouble 0.5 + then promote $ fromDouble 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 --- a/src/Graphics/Image/Processing/Binary.hs +++ b/src/Graphics/Image/Processing/Binary.hs @@ -20,7 +20,7 @@ toImageBinaryUsing, toImageBinaryUsing2, thresholdWith, compareWith, -- * Bitwise operations - (.&&.), (.||.), invert, + or, and, (.&&.), (.||.), invert, -- * Thresholding Thresholding(..), -- * Binary Morphology @@ -28,10 +28,8 @@ erode, dialate, open, close ) where -import Prelude hiding (map, zipWith) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<*>)) -#endif +import Prelude hiding (map, zipWith, and, or) +import Data.Bits import Graphics.Image.Interface import Graphics.Image.ColorSpace import Graphics.Image.Processing.Convolution @@ -146,7 +144,7 @@ (Pixel cs e -> Bool) -- ^ Predicate -> Image arr cs e -- ^ Source image. -> Image arr Binary Bit -toImageBinaryUsing !f = map (fromBool . f) +toImageBinaryUsing f = map (fromBool . f) {-# INLINE toImageBinaryUsing #-} @@ -156,7 +154,7 @@ -> Image arr cs e -- ^ First source image. -> Image arr cs e -- ^ Second source image. -> Image arr Binary Bit -toImageBinaryUsing2 !f = zipWith (((.).(.)) fromBool f) +toImageBinaryUsing2 f = zipWith (((.).(.)) fromBool f) {-# INLINE toImageBinaryUsing2 #-} @@ -173,7 +171,7 @@ -- ^ Pixel containing a thresholding function per channel. -> Image arr cs e -- ^ Source image. -> Image arr Binary Bit -thresholdWith !f = map (fromBool . F.and . (f <*>)) +thresholdWith f = map (fromBool . F.and . (f <*>)) {-# INLINE thresholdWith #-} @@ -188,6 +186,18 @@ -> Image arr Binary Bit compareWith !f = zipWith (\ !px1 !px2 -> fromBool . F.and $ (f <*> px1 <*> px2)) {-# INLINE compareWith #-} + + +-- | Disjunction of all pixels in a Binary image +or :: Array arr Binary Bit => Image arr Binary Bit -> Bool +or = isOn . fold (.|.) off +{-# INLINE or #-} + + +-- | Conjunction of all pixels in a Binary image +and :: Array arr Binary Bit => Image arr Binary Bit -> Bool +and = isOn . fold (.&.) on +{-# INLINE and #-} {- $morphology In order to demonstrate how morphological operations work, a diff --git a/src/Graphics/Image/Processing/Convolution.hs b/src/Graphics/Image/Processing/Convolution.hs --- a/src/Graphics/Image/Processing/Convolution.hs +++ b/src/Graphics/Image/Processing/Convolution.hs @@ -72,7 +72,7 @@ -- -- Example using : -- --- >>> frog <- readImageY RP "images/frog.jpg" +-- >>> frog <- readImageY RPU "images/frog.jpg" -- >>> let frogX = convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]]) frog -- >>> let frogY = convolve Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]]) frog -- >>> displayImage $ normalize $ sqrt (frogX ^ 2 + frogY ^ 2) diff --git a/src/Graphics/Image/Processing/Geometric.hs b/src/Graphics/Image/Processing/Geometric.hs --- a/src/Graphics/Image/Processing/Geometric.hs +++ b/src/Graphics/Image/Processing/Geometric.hs @@ -11,8 +11,8 @@ -- module Graphics.Image.Processing.Geometric ( -- ** Sampling - downsampleRows, downsampleCols, downsample, downsampleF, - upsampleRows, upsampleCols, upsample, upsampleF, + downsampleRows, downsampleCols, downsample, + upsampleRows, upsampleCols, upsample, -- ** Concatenation leftToRight, topToBottom, -- ** Canvas @@ -31,69 +31,104 @@ import Graphics.Image.Interface import Graphics.Image.Processing.Interpolation +import qualified Data.Vector as V -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 #-} +-- | Downsample an image. Drop all rows and colums that satisfy the +-- predicates. For example, in order to discard every 5th row and keep every +-- even indexed column: +-- +-- >>> frog <- readImageRGB RPU "images/frog.jpg" +-- >>> displayImage $ downsample ((0 ==) . (`mod` 5)) odd frog +-- +-- <> <> +-- +downsample :: Array arr cs e => + (Int -> Bool) -- ^ Rows predicate + -> (Int -> Bool) -- ^ Columns predicate + -> Image arr cs e -- ^ Source image + -> Image arr cs e +downsample mPred nPred !img = + traverse img (const (V.length rowsIx, V.length colsIx)) getNewPx where + !(m, n) = dims img + !rowsIx = V.filter (not . mPred) $ V.enumFromN 0 m + !colsIx = V.filter (not . nPred) $ V.enumFromN 0 n + getNewPx getPx !(i, j) = getPx (V.unsafeIndex rowsIx i, V.unsafeIndex colsIx j) +{-# INLINE downsample #-} --- | Upsample an image by a positive factor. Every -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 0) -{-# INLINE upsampleF #-} +-- | Upsample an image by inserting rows and columns with zero valued pixels +-- into an image. Supplied functions specify how many rows/columns shoud be +-- inserted @(before, after)@ a particular row/column. Returning a negative +-- value in a tuple will result in an error. E.g. insert 2 columns before and 4 +-- columns after every 10th column, while leaving rows count unchanged: +-- +-- >>> frog <- readImageRGB RPU "images/frog.jpg" +-- >>> displayImage $ upsample (const (0, 0)) (\ k -> if k `mod` 10 == 0 then (2, 4) else (0, 0)) frog +-- +-- <> <> +-- +upsample :: Array arr cs e => + (Int -> (Int, Int)) + -> (Int -> (Int, Int)) + -> Image arr cs e + -> Image arr cs e +upsample mAdd nAdd !img = traverse img (const (newM, newN)) getNewPx where + !(m, n) = dims img + validate !p@(pre, post) + | pre < 0 || post < 0 = + error $ "upsample: negative values are not accepted: " ++ show p + | otherwise = p + !rowsIx = V.unfoldr (spread (V.map (validate . mAdd) $ V.enumFromN 0 m)) (0, Nothing, Nothing) + !colsIx = V.unfoldr (spread (V.map (validate . nAdd) $ V.enumFromN 0 n)) (0, Nothing, Nothing) + !newM = V.length rowsIx + !newN = V.length colsIx + spread !v !params = + case params of + (k, Nothing, Nothing) | k == V.length v -> Nothing + (k, Nothing, Nothing) -> + let (pre, post) = v V.! k in spread v (k, Just pre, Just post) + (k, Just 0, my) -> Just (Just k, (k, Nothing, my)) + (k, Just x, my) -> Just (Nothing, (k, Just (x-1), my)) + (k, Nothing, Just 0) -> spread v (k+1, Nothing, Nothing) + (k, Nothing, Just y) -> Just (Nothing, (k, Nothing, Just (y-1))) + {-# INLINE spread #-} + getNewPx getPx !(i, j) = + case (V.unsafeIndex rowsIx i, V.unsafeIndex colsIx j) of + (Just i', Just j') -> getPx (i', j') + _ -> 0 + {-# INLINE getNewPx #-} +{-# INLINE upsample #-} + -- | 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) +downsampleRows = downsample odd (const False) {-# 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) +downsampleCols = downsample (const False) odd {-# 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) +upsampleRows = upsample (const (0, 1)) (const (0, 0))-- 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) +upsampleCols = upsample (const (0, 0)) (const (0, 1))-- upsampleF (2, 1) {-# 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 @@ -150,7 +185,7 @@ -- except the ones outside the border, which are handled according to supplied -- resolution strategy. -- --- <> +-- <> -- -- For example, it can be used to make a tile from the image above, or simply -- scale the canvas and place it in a middle: diff --git a/src/Graphics/Image/Processing/Interpolation.hs b/src/Graphics/Image/Processing/Interpolation.hs --- a/src/Graphics/Image/Processing/Interpolation.hs +++ b/src/Graphics/Image/Processing/Interpolation.hs @@ -52,8 +52,8 @@ {-# INLINE getPx' #-} !(i0, j0) = (floor i, floor j) !(i1, j1) = (i0 + 1, j0 + 1) - !iPx = broadcastC $ fromDouble (i - fromIntegral i0) - !jPx = broadcastC $ fromDouble (j - fromIntegral j0) + !iPx = promote $ fromDouble (i - fromIntegral i0) + !jPx = promote $ fromDouble (j - fromIntegral j0) !f00 = getPx' (i0, j0) !f10 = getPx' (i1, j0) !f01 = getPx' (i0, j1) diff --git a/tests/Graphics/Image/ColorSpaceSpec.hs b/tests/Graphics/Image/ColorSpaceSpec.hs --- a/tests/Graphics/Image/ColorSpaceSpec.hs +++ b/tests/Graphics/Image/ColorSpaceSpec.hs @@ -1,34 +1,42 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Graphics.Image.ColorSpaceSpec (spec) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Test.Hspec import Test.QuickCheck import Graphics.Image as I import Graphics.Image.Interface as II -import Graphics.Image.ColorSpace -instance Arbitrary RGB where - arbitrary = do - NonNegative c <- arbitrary - return $ toEnum (c `mod` 3) +instance Arbitrary (Pixel Binary Bit) where + arbitrary = elements [on, off] -instance Arbitrary e => Arbitrary (Pixel RGB e) where - arbitrary = PixelRGB <$> arbitrary <*> arbitrary <*> arbitrary +instance (ColorSpace Y e, Arbitrary e) => Arbitrary (Pixel Y e) where + arbitrary = fromComponents <$> arbitrary +instance (ColorSpace YA e, Arbitrary e) => Arbitrary (Pixel YA e) where + arbitrary = fromComponents <$> arbitrary -instance (MArray VU RGB e, Arbitrary e) => Arbitrary (Image VU RGB e) where +instance (ColorSpace RGB e, Arbitrary e) => Arbitrary (Pixel RGB e) where + arbitrary = fromComponents <$> arbitrary + +instance (ColorSpace RGBA e, Arbitrary e) => Arbitrary (Pixel RGBA e) where + arbitrary = fromComponents <$> arbitrary + + +instance (MArray VU cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image VU cs e) where arbitrary = do (Positive m, Positive n) <- arbitrary - II.mapM (const arbitrary) $ I.makeImage (m, n) (const $ PixelGray (0 :: Double)) - + II.makeImageM (m, n) (const arbitrary) + + +instance (MArray VS cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image VS cs e) where + arbitrary = do + (Positive m, Positive n) <- arbitrary + II.makeImageM (m, n) (const arbitrary) + prop_ToFromComponents :: (ColorSpace cs e, Eq (Pixel cs e)) => Pixel cs e -> Bool diff --git a/tests/Graphics/Image/IO/FormatsSpec.hs b/tests/Graphics/Image/IO/FormatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Image/IO/FormatsSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Graphics.Image.IO.FormatsSpec + ( spec ) where + +import Prelude as P +import qualified Data.ByteString.Lazy as BL +import Test.Hspec +import Test.QuickCheck hiding (Result(..)) +import Test.QuickCheck.Property + +import Graphics.Image as I + +import Graphics.Image.InterfaceSpec() + + +data EncDec a b = EncDec a b deriving Show + +instance Arbitrary (EncDec InputFormat OutputFormat) where + arbitrary = elements $ fmap (uncurry EncDec) + [ (InputBMP, OutputBMP) + , (InputHDR, OutputHDR) + , (InputPNG, OutputPNG) + , (InputTIF, OutputTIF) + , (InputTGA, OutputTGA) + ] + + + +prop_EncodeDecode :: Image VS RGB Word8 -> EncDec InputFormat OutputFormat -> Result +prop_EncodeDecode imgWord8 (EncDec input output) = + case decode input (BL.toStrict (encode output [] (I.map (fmap toDouble) imgWord8))) of + Left err -> + failed + { reason = err + } + Right (img' :: Image VS RGB Double) -> + let imgWord8' = I.map (fmap toWord8) img' in + if eqTol 2 imgWord8 imgWord8' + then succeeded + else failed + { reason = + "Original img <" ++ show input ++ ">: \n" ++ + show (toLists imgWord8) ++ + "\n differes from decoded img: \n" ++ show (toLists imgWord8') + } + + +spec :: Spec +spec = do + describe "Encode/Decode" $ do + it "Input/Output Formats" $ property prop_EncodeDecode diff --git a/tests/Graphics/Image/InterfaceSpec.hs b/tests/Graphics/Image/InterfaceSpec.hs --- a/tests/Graphics/Image/InterfaceSpec.hs +++ b/tests/Graphics/Image/InterfaceSpec.hs @@ -30,13 +30,9 @@ -- | Generator for values in range @[0, 1]@ arbitraryDouble :: Gen Double -arbitraryDouble = do - Positive v <- arbitrary - let v' = v - fromInteger (floor v) - if v' == 0 - then choose (0, 1) - else return v' +arbitraryDouble = toDouble <$> (arbitrary :: Gen Word64) + instance Arbitrary (Pixel Y Word8) where arbitrary = PixelY <$> arbitrary @@ -49,11 +45,16 @@ instance Arbitrary (Pixel RGB Double) where arbitrary = PixelRGB <$> arbitraryDouble <*> arbitraryDouble <*> arbitraryDouble -instance (MArray arr cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image arr cs e) where +instance (Array arr cs e, MArray arr cs e, Arbitrary (Pixel cs e)) => + Arbitrary (Image arr cs e) where arbitrary = do (Positive (Small m), Positive (Small n)) <- arbitrary I.makeImageM (m, n) (const arbitrary) + shrink img | dims img == (1,1) = [] + | rows img == 1 = [downsampleCols img] + | cols img == 1 = [downsampleRows img] + | otherwise = [downsample even even img, downsample odd odd img] instance (Array arr1 cs e, Array arr2 cs e, Arbitrary (Pixel cs e)) => Arbitrary (Identical arr1 arr2 cs e) where @@ -62,8 +63,8 @@ getPx <- arbitrary if (m, n) == (1, 1) then do - img1 <- elements [I.makeImage (m, n) getPx, I.singleton (getPx (0, 0))] - img2 <- elements [I.makeImage (m, n) getPx, I.singleton (getPx (0, 0))] + img1 <- elements [I.makeImage (m, n) getPx, I.scalar (getPx (0, 0))] + img2 <- elements [I.makeImage (m, n) getPx, I.scalar (getPx (0, 0))] return $ Identical img1 img2 else return $ Identical (I.makeImage (m, n) getPx) (I.makeImage (m, n) getPx) diff --git a/tests/Graphics/Image/Processing/BinarySpec.hs b/tests/Graphics/Image/Processing/BinarySpec.hs --- a/tests/Graphics/Image/Processing/BinarySpec.hs +++ b/tests/Graphics/Image/Processing/BinarySpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -module Graphics.Image.Processing.BinarySpec (spec) where +module Graphics.Image.Processing.BinarySpec (spec, struct) where import Test.Hspec @@ -27,6 +27,8 @@ , [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,0],[1,1,0],[0,1,0]] diff --git a/tests/Graphics/Image/ProcessingSpec.hs b/tests/Graphics/Image/ProcessingSpec.hs --- a/tests/Graphics/Image/ProcessingSpec.hs +++ b/tests/Graphics/Image/ProcessingSpec.hs @@ -1,15 +1,14 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} module Graphics.Image.ProcessingSpec (spec) where import Test.Hspec import Test.QuickCheck -import qualified Graphics.Image.Interface as I -import Graphics.Image.Types -import Graphics.Image.Processing +import Graphics.Image as I import Graphics.Image.InterfaceSpec (translateWrap, dummyImage10x20) ---import Graphics.Image.Processing.BinarySpec +import Graphics.Image.Processing.BinarySpec (struct) data Interpol = I1 Nearest @@ -34,9 +33,25 @@ prop_sampleCols :: Image VU Y Double -> Bool prop_sampleCols img = img == downsampleCols (upsampleCols img) -prop_sample :: Image VU Y Double -> Bool -prop_sample img = img == downsample (upsample img) +prop_upsampleNegative :: NonNegative Int -> NonNegative Int + -> NonNegative Int -> NonNegative Int + -> Image VU Y Double -> Property +prop_upsampleNegative (NonNegative p1) (NonNegative p2) (NonNegative p3) (NonNegative p4) img = + p1 /= 0 && p2 /= 0 && p3 /= 0 && p4 /= 0 ==> + expectFailure (upsample (const (-p1, -p2)) (const (-p3, -p4)) img `seq` True) +prop_upsampleId :: Image VU Y Double -> Bool +prop_upsampleId img = img == upsample (const (0,0)) (const (0,0)) img + +prop_downsampleId :: Image VU Y Double -> Bool +prop_downsampleId img = img == downsample (const False) (const False) img + +prop_sampleEven :: Image VU Y Double -> Bool +prop_sampleEven img = img == downsample even even (upsample (const (1,0)) (const (1,0)) img) + +prop_sampleOdd :: Image VU Y Double -> Bool +prop_sampleOdd img = img == downsample odd odd (upsample (const (0,1)) (const (0,1)) img) + prop_translateWrap :: (Int, Int) -> Image VU RGB Double -> Bool prop_translateWrap shift img = translateWrap shift img == translate Wrap shift img @@ -76,9 +91,11 @@ spec :: Spec spec = do describe "Processing Properties" $ - do it "sampleRows" $ property prop_sampleRows - it "sampleCols" $ property prop_sampleCols - it "sample" $ property prop_sample + do it "[up/down]sampleRows" $ property prop_sampleRows + it "[up/down]sampleCols" $ property prop_sampleCols + it "[up/down]sampleId" $ property $ conjoin [prop_upsampleId, prop_downsampleId] + it "[up/down]sampleEven" $ property prop_sampleEven + it "[up/down]sampleOdd" $ property prop_sampleOdd it "translateWrap" $ property prop_translateWrap it "cropSuperimpose" $ property prop_cropSuperimpose it "concatRotate" $ property prop_concatRotate @@ -86,6 +103,13 @@ it "rotate180" $ property prop_rotate180 it "rotate270" $ property prop_rotate270 it "rotate360" $ property prop_rotate360 + describe "Processing Unit Tests" $ + do it "upsampleRows" $ upsampleRows struct `shouldBe` + I.fromLists [[0,1,0],[0,0,0],[1,1,0],[0,0,0],[0,1,0],[0,0,0]] + it "upsampleCols" $ upsampleCols struct `shouldBe` + I.fromLists [[0,0,1,0,0,0],[1,0,1,0,0,0],[0,0,1,0,0,0]] + it "downsampleRows" $ downsampleRows struct `shouldBe` I.fromLists [[0,1,0],[0,1,0]] + it "downsampleCols" $ downsampleCols struct `shouldBe` I.fromLists [[0,0],[1,0],[0,0]] describe "Processing Errors" $ do it "crop start index outside" $ do shouldThrow (return $! crop (-1, -1) (1, 1) dummyImage10x20) anyException @@ -98,14 +122,12 @@ it "crop negative dimensions" $ do shouldThrow (return $! crop (1, 1) (-5, 15) dummyImage10x20) anyException shouldThrow (return $! crop (1, 1) (5, -15) dummyImage10x20) anyException - it "upsample non-positive" $ - do shouldThrow (return $! upsampleF (0, 1) dummyImage10x20) anyException - shouldThrow (return $! upsampleF (1, 0) dummyImage10x20) anyException - shouldThrow (return $! upsampleF (-1, -1) dummyImage10x20) anyException - it "downsample non-positive" $ - do shouldThrow (return $! downsampleF (0, 1) dummyImage10x20) anyException - shouldThrow (return $! downsampleF (1, 0) dummyImage10x20) anyException - shouldThrow (return $! downsampleF (-1, -1) dummyImage10x20) anyException + it "upsampleNegative" $ property prop_upsampleNegative + it "downsample all" $ + do shouldThrow (return $! downsample (const True) even dummyImage10x20) anyException + shouldThrow (return $! downsample even (const True) dummyImage10x20) anyException + shouldThrow (return $! downsample (const True) (const True) dummyImage10x20) + anyException it "concat dimension mismatch" $ do shouldThrow (return $! leftToRight dummyImage10x20 $ I.transpose dummyImage10x20)