hip 1.4.0.1 → 1.5.0.0

raw patch · 36 files changed

+1237/−911 lines, 36 filesdep ~bytestringbinary-addedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• hip.cabal +5/−3
• images/frog_downsampled.jpg binary
• images/frog_upsampled.jpg binary
• src/Graphics/Image.hs +20/−17
• src/Graphics/Image/ColorSpace.hs +18/−9
• src/Graphics/Image/ColorSpace/Binary.hs +96/−21
• src/Graphics/Image/ColorSpace/CMYK.hs +20/−28
• src/Graphics/Image/ColorSpace/Gray.hs +0/−205
• src/Graphics/Image/ColorSpace/HSI.hs +21/−27
• src/Graphics/Image/ColorSpace/Luma.hs +0/−328
• src/Graphics/Image/ColorSpace/RGB.hs +48/−70
• src/Graphics/Image/ColorSpace/X.hs +206/−0
• src/Graphics/Image/ColorSpace/Y.hs +325/−0
• src/Graphics/Image/ColorSpace/YCbCr.hs +20/−27
• src/Graphics/Image/IO/Formats.hs +3/−3
• src/Graphics/Image/IO/Formats/JuicyPixels.hs +3/−3
• src/Graphics/Image/IO/Histogram.hs +8/−8
• src/Graphics/Image/Interface.hs +122/−31
• src/Graphics/Image/Interface/Repa.hs +48/−0
• src/Graphics/Image/Interface/Repa/Generic.hs +17/−17
• src/Graphics/Image/Interface/Repa/Storable.hs +8/−8
• src/Graphics/Image/Interface/Repa/Unboxed.hs +8/−8
• src/Graphics/Image/Interface/Vector/Generic.hs +4/−4
• src/Graphics/Image/Interface/Vector/Storable.hs +2/−2
• src/Graphics/Image/Interface/Vector/Unboxed.hs +2/−2
• src/Graphics/Image/Processing.hs +1/−1
• src/Graphics/Image/Processing/Binary.hs +18/−8
• src/Graphics/Image/Processing/Convolution.hs +1/−1
• src/Graphics/Image/Processing/Geometric.hs +72/−37
• src/Graphics/Image/Processing/Interpolation.hs +2/−2
• tests/Graphics/Image/ColorSpaceSpec.hs +22/−14
• tests/Graphics/Image/IO/FormatsSpec.hs +53/−0
• tests/Graphics/Image/InterfaceSpec.hs +10/−9
• tests/Graphics/Image/Processing/BinarySpec.hs +3/−1
• tests/Graphics/Image/ProcessingSpec.hs +39/−17

@@ -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 ======= 

@@ -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

binary file changed (absent → 59035 bytes)

binary file changed (absent → 210887 bytes)

@@ -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 <http://hackage.haskell.org/package/vector Vector> and -- <http://hackage.haskell.org/package/repa Repa> 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

@@ -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

@@ -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 -- <Binary:(0)> ---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)) = "<Binary:(0)>"   show _                     = "<Binary:(1)>"  +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 #-}  

@@ -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) =     "<CMYKA:("++show c++"|"++show m++"|"++show y++"|"++show k++"|"++show 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

@@ -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 <lehins@yandex.ru>--- 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) = "<Gray:("++show 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------ <<images/frog_red.jpg>> <<images/frog_green.jpg>> <<images/frog_blue.jpg>>----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]------ <<images/frog.jpg>> <<images/frog_rbg.jpg>>------ 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 #-}

@@ -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) = "<HSI:("++show h++"|"++show s++"|"++show 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) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show 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

@@ -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 <lehins@yandex.ru>--- 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) = "<Luma:("++show 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-

@@ -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 #-}  

@@ -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 <lehins@yandex.ru>+-- 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) = "<X:("++show 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+--+-- <<images/frog_red.jpg>> <<images/frog_green.jpg>> <<images/frog_blue.jpg>>+--+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]+--+-- <<images/frog.jpg>> <<images/frog_rbg.jpg>>+--+-- 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 #-}

@@ -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 <lehins@yandex.ru>+-- 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) = "<Luma:("++show 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+

@@ -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) = "<YCbCr:("++show y++"|"++show b++"|"++show 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) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show 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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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)

@@ -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 #-}

@@ -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 #-}

@@ -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

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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

@@ -72,7 +72,7 @@ -- -- Example using <https://en.wikipedia.org/wiki/Sobel_operator Sobel operator>: ----- >>> 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)

@@ -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+-- +-- <<images/frog.jpg>> <<images/frog_downsampled.jpg>>+-- +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+--+-- <<images/frog.jpg>> <<images/frog_upsampled.jpg>>+--+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. ----- <<images/haskell_40.png>>+-- <<images/logo_40.png>> -- -- 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:

@@ -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) 

@@ -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

@@ -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

@@ -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)

@@ -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]] 

@@ -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)