diff --git a/hip.cabal b/hip.cabal --- a/hip.cabal +++ b/hip.cabal @@ -1,5 +1,5 @@ Name: hip -Version: 1.0.0.0 +Version: 1.0.1 License: BSD3 License-File: LICENSE Author: Alexey Kuleshevich @@ -13,7 +13,7 @@ . Processing can be done sequentially as well as in parallel, with an inherited fusion capabily, all through and packages. It is highly extendable, with an ability to add custom color spaces or use some other underlying data structure. . - It is capable of reading and writing a number of popular image formats by using and packages. Being a pure Haskell library it does not require any external programs, but it can display images using a program of your choice. + It is capable of reading and writing a number of popular image formats by using and packages. Being a pure Haskell library it does not require any external programs, although it can display images using a program of your choice. Homepage: https://github.com/lehins/hip Bug-Reports: https://github.com/lehins/hip/issues Cabal-Version: >= 1.10 @@ -27,27 +27,26 @@ Build-Depends: base >= 4.5 && < 5 , bytestring >= 0.9.0.4 , deepseq >= 1.1 --- , easyplot >= 1.0 , filepath >= 1.0 , JuicyPixels >= 3.2.7 , netpbm >= 1.0.1 + , Chart >= 1.5 + , Chart-cairo >= 1.5 + , colour >= 2.3.3 , primitive >= 0.4 , process >= 1.1.0.0 , repa >= 3.2.1.1 && < 4 , temporary >= 1.1.1 - , vector >= 0.9 && < 0.11 - , vector-th-unbox >= 0.2.1.0 + , vector >= 0.10 && < 0.11 Other-Extensions: BangPatterns , ConstraintKinds - , GADTs + , CPP , FlexibleContexts , FlexibleInstances , FunctionalDependencies , MultiParamTypeClasses - , MultiWayIf , ScopedTypeVariables - , TemplateHaskell , TypeFamilies , UndecidableInstances , ViewPatterns @@ -56,12 +55,14 @@ , Graphics.Image.ColorSpace , Graphics.Image.IO , Graphics.Image.IO.External + , Graphics.Image.IO.Histogram , Graphics.Image.Interface , Graphics.Image.Interface.Repa , Graphics.Image.Interface.Vector , Graphics.Image.Processing , Graphics.Image.Processing.Binary , Graphics.Image.Processing.Complex + , Graphics.Image.Types Other-Modules: Graphics.Image.ColorSpace.Binary , Graphics.Image.ColorSpace.CMYK @@ -76,6 +77,7 @@ , Graphics.Image.IO.External.Netpbm , Graphics.Image.Interface.Repa.Internal , Graphics.Image.Interface.Vector.Unboxed + , Graphics.Image.Interface.Vector.Unboxing , Graphics.Image.Processing.Convolution , Graphics.Image.Processing.Complex.Fourier , Graphics.Image.Processing.Geometric diff --git a/images/frog_histogram.png b/images/frog_histogram.png new file mode 100644 Binary files /dev/null and b/images/frog_histogram.png differ diff --git a/src/Graphics/Image.hs b/src/Graphics/Image.hs --- a/src/Graphics/Image.hs +++ b/src/Graphics/Image.hs @@ -1,23 +1,22 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# LANGUAGE BangPatterns, FlexibleContexts #-} +{-# LANGUAGE CPP, BangPatterns, FlexibleContexts #-} -- | --- Module : Graphics.Image.Unboxed +-- Module : Graphics.Image -- Copyright : (c) Alexey Kuleshevich 2016 --- License : MIT --- +-- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental -- Portability : non-portable -- -- Haskell Image Processing (HIP) library is a wrapper around any array like -- data structure and is fully agnostic to the underlying representation. All of --- the functionality in this library relies on few type classes that those --- representations implement: +-- the functionality in this library relies on few type classes that +-- corresponding representation types are instances of: -- --- * @__`Array` arr cs e__@ - this is a base class for every __@`Image`@ @arr@ @cs@ @e@__, --- where @__arr__@ stands for an underlying array representation, @__cs__@ is the --- `ColorSpace` of an image and @__e__@ is the type denoting precision of an --- image. +-- * @__`Graphics.Image.Types.Array` arr cs e__@ - this is a base class for every +-- __@`Graphics.Image.Types.Image`@ @arr@ @cs@ @e@__, where @__arr__@ stands for an underlying array +-- representation, @__cs__@ is the `ColorSpace` of an image and @__e__@ is the +-- type denoting precision of an image. -- -- * @__`ManifestArray` arr cs e__@ - is a kind of array that is represented by an -- actual data in memory. @@ -43,16 +42,30 @@ -- representation should be used for fusing computation together, and later -- changed to `RS` or `RP` using `exchange`, which in turn performs the fused -- computation. --- +-- +-- Just as it is mentioned above, Vector representation is a default one, so in +-- order to create images with Repa representation +-- "Graphics.Image.Interface.Repa" module can be used. It should be imported as +-- qualified, since it contains image generating functions with same names as +-- here. +-- +-- Many of the function names exported by this module will clash with the ones +-- from "Prelude", hence it can be more convenient to import it qualified and +-- all relevenat types import using "Graphics.Image.Types" module: +-- +-- @ +-- import qualified Graphics.Image as I +-- import Graphics.Image.Types +-- @ +-- module Graphics.Image ( -- * Color Space -- $colorspace - module Graphics.Image.ColorSpace, -- * Creation -- -- If it is necessary to create an image in an other representation - -- or with some specific 'Pixel' precision, you can use 'makeImage' from + -- or with some specific 'Pixel' precision, you can use 'make' from -- "Graphics.Image.Interface" module and manually specifying function's output -- type, ex: -- @@ -87,31 +100,33 @@ exchange, VU(..), RD(..), RS(..), RP(..), ) where + +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (map, zipWith, sum, product, maximum, minimum, traverse) +#else import Prelude hiding (map, zipWith, sum, product, maximum, minimum) +#endif import qualified Data.Foldable as F import Graphics.Image.ColorSpace import Graphics.Image.IO -import Graphics.Image.Interface +import Graphics.Image.Interface hiding (makeImage, fromLists) import Graphics.Image.Interface.Vector import Graphics.Image.Interface.Repa (RD(..), RS(..), RP(..)) ---import Graphics.Image.Processing ---import Graphics.Image.Processing.Complex + +import Graphics.Image.Processing +import Graphics.Image.Processing.Complex --import Graphics.Image.Processing.Binary +import Graphics.Image.IO.Histogram --------------------------------------------------------------------------------- ----- Creation and Transformation ----------------------------------------------- --------------------------------------------------------------------------------- - - -- | Get the number of rows in an image. -- -- >>> frog <- readImageRGB "images/frog.jpg" -- >>> frog --- +-- -- >>> rows frog -- 200 -- @@ -124,7 +139,7 @@ -- -- >>> frog <- readImageRGB "images/frog.jpg" -- >>> frog --- +-- -- >>> cols frog -- 320 -- @@ -166,7 +181,7 @@ where !(PixelGray l, PixelGray s) = (maximum $ map (PixelGray . F.maximum) img, minimum $ map (PixelGray . F.minimum) img) - normalizer !px = (px - pure s) / (pure (l - s)) + normalizer !px = (px - pure s) / pure (l - s) {-# INLINE normalizer #-} {-# INLINE normalize #-} @@ -187,12 +202,12 @@ -- * __'Pixel' 'YCbCrA' e = PixelYCbCrA e__ - YCbCr with alpha. -- ------------------------------------------------------------------------------------------ -- * __'Pixel' 'Binary' 'Bit' = 'on' | 'off'__ - Bi-tonal. --- * __'Pixel' 'Gray' e = PixelGray e__ - Used for separating channels from other color spaces. -- * __'Pixel' cs ('Complex' e) = ('Pixel' cs e) '+:' ('Pixel' cs e)__ - Complex pixels with any color space. +-- * __'Pixel' 'Gray' e = PixelGray e__ - Used for separating channels from other color spaces. -- @ -- -- Every 'Pixel' is an instance of 'Functor', 'Applicative', 'F.Foldable' and -- 'Num', as well as 'Floating' and 'Fractional' if __e__ is also an instance. -- --- All of the functionality related to every 'ColorSpace' is re-exported from here --- for convenience. +-- All of the functionality related to every 'ColorSpace' is re-exported by +-- "Graphics.Image.Types" module. diff --git a/src/Graphics/Image/ColorSpace.hs b/src/Graphics/Image/ColorSpace.hs --- a/src/Graphics/Image/ColorSpace.hs +++ b/src/Graphics/Image/ColorSpace.hs @@ -1,9 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, - MultiParamTypeClasses, MultiWayIf, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +-- | +-- Module : Graphics.Image.ColorSpace +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace ( -- * ColorSpace - ColorSpace(..), Alpha(..), + ColorSpace, Pixel(..), Alpha, Opaque, Elevator(..), -- * Luma module Graphics.Image.ColorSpace.Luma, -- * RGB @@ -22,13 +29,10 @@ -- * Complex module Graphics.Image.ColorSpace.Complex, -- * Re-exports - Applicative(..), (<$>), (<$), (<**>), liftA, liftA2, liftA3, Word8, Word16, Word32, Word64 ) where - -import Control.Applicative import Data.Word import GHC.Float import Graphics.Image.Interface hiding (map) @@ -44,30 +48,31 @@ - -- Binary: - +-- | Convert any pixel to binary pixel. toPixelBinary :: (ColorSpace cs, Eq (Pixel cs e), Num e) => Pixel cs e -> Pixel Binary Bit toPixelBinary px = if px == 0 then on else off {-# INLINE toPixelBinary #-} - +-- | Convert a Binary pixel to Luma pixel fromPixelBinary :: Pixel Binary Bit -> Pixel Y Word8 fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound {-# INLINE fromPixelBinary #-} +-- | Convert any image to binary image. toImageBinary :: (Array arr cs e, Array arr Binary Bit, Eq (Pixel cs e)) => - Image arr cs e - -> Image arr Binary Bit + Image arr cs e + -> Image arr Binary Bit toImageBinary = I.map toPixelBinary {-# INLINE toImageBinary #-} +-- | Convert a Binary image to Luma image fromImageBinary :: (Array arr Binary Bit, Array arr Y Word8) => - Image arr Binary Bit - -> Image arr Y Word8 + Image arr Binary Bit + -> Image arr Y Word8 fromImageBinary = I.map fromPixelBinary {-# INLINE fromImageBinary #-} @@ -110,26 +115,28 @@ instance ToRGBA YA where instance ToRGB HSI where - toPixelRGB (PixelHSI h s i) = - let !is = i*s - !second = i - is - getFirst !a !b = i + is*cos a/cos b - {-# INLINE getFirst #-} - getThird !v1 !v2 = i + 2*is + v1 - v2 - {-# INLINE getThird #-} - in if | h < 2*pi/3 -> let !r = getFirst h (pi/3 - h) - !b = second - !g = getThird b r - in PixelRGB r g b - | h < 4*pi/3 -> let !g = getFirst (h - 2*pi/3) (h + pi) - !r = second - !b = getThird r g - in PixelRGB r g b - | h < 2*pi -> let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h) - !g = second - !r = getThird g b - in PixelRGB r g b - | otherwise -> error ("HSI pixel is not properly scaled, Hue: "++show h) + toPixelRGB (PixelHSI h' s i) = getRGB (h'*2*pi) where + !is = i*s + !second = i - is + getFirst !a !b = i + is*cos a/cos b + {-# INLINE getFirst #-} + getThird !v1 !v2 = i + 2*is + v1 - v2 + {-# INLINE getThird #-} + getRGB h + | h < 2*pi/3 = let !r = getFirst h (pi/3 - h) + !b = second + !g = getThird b r + in PixelRGB r g b + | h < 4*pi/3 = let !g = getFirst (h - 2*pi/3) (h + pi) + !r = second + !b = getThird r g + in PixelRGB r g b + | h < 2*pi = let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h) + !g = second + !r = getThird g b + in PixelRGB r g b + | otherwise = error ("HSI pixel is not properly scaled, Hue: "++show h') + {-# INLINE getRGB #-} {-# INLINE toPixelRGB #-} instance ToRGBA HSIA where @@ -165,7 +172,7 @@ instance ToHSI RGB where toPixelHSI (PixelRGB r g b) = PixelHSI h s i where !h' = atan2 y x - !h = if h' < 0 then h' + 2*pi else h' + !h = (if h' < 0 then h' + 2*pi else h') / (2*pi) !s = if i == 0 then 0 else 1 - minimum [r, g, b] / i !i = (r + g + b) / 3 !x = (2*r - g - b) / 2.449489742783178 @@ -219,12 +226,12 @@ {-# INLINE toWord64 #-} toFloat = liftA toFloat' where - toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word8)) + toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word8) {-# INLINE toFloat' #-} {-# INLINE toFloat #-} toDouble = liftA toDouble' where - toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word8)) + toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word8) {-# INLINE toDouble' #-} {-# INLINE toDouble #-} @@ -255,12 +262,12 @@ {-# INLINE toWord64 #-} toFloat = liftA toFloat' where - toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word16)) + toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word16) {-# INLINE toFloat' #-} {-# INLINE toFloat #-} toDouble = liftA toDouble' where - toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word16)) + toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word16) {-# INLINE toDouble' #-} {-# INLINE toDouble #-} @@ -292,12 +299,12 @@ {-# INLINE toWord64 #-} toFloat = liftA toFloat' where - toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word32)) + toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word32) {-# INLINE toFloat' #-} {-# INLINE toFloat #-} toDouble = liftA toDouble' where - toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word32)) + toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word32) {-# INLINE toDouble' #-} {-# INLINE toDouble #-} @@ -330,12 +337,12 @@ {-# INLINE toWord64 #-} toFloat = liftA toFloat' where - toFloat' !e = fromIntegral e / (fromIntegral (maxBound :: Word64)) + toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word64) {-# INLINE toFloat' #-} {-# INLINE toFloat #-} toDouble = liftA toDouble' where - toDouble' !e = fromIntegral e / (fromIntegral (maxBound :: Word64)) + toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word64) {-# INLINE toDouble' #-} {-# INLINE toDouble #-} diff --git a/src/Graphics/Image/ColorSpace/Binary.hs b/src/Graphics/Image/ColorSpace/Binary.hs --- a/src/Graphics/Image/ColorSpace/Binary.hs +++ b/src/Graphics/Image/ColorSpace/Binary.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.Binary +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.Binary ( Binary(..), Bit(..), on, off, isOn, isOff, fromBool, complement ) where @@ -8,7 +16,8 @@ import Data.Word (Word8) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend, mempty) +import qualified Data.Monoid as M (mappend, mempty) +import qualified Data.Colour as C -- | This is a Binary colorspace, pixel's of which can be created using -- these __/constructors/__: @@ -110,8 +119,10 @@ chApp (PixelBinary f) (PixelBinary b) = PixelBinary (f b) {-# INLINE chApp #-} - pxFoldMap f (PixelBinary b) = f b `mappend` mempty + pxFoldMap f (PixelBinary b) = f b `M.mappend` M.mempty {-# INLINE pxFoldMap #-} + + csColour _ = C.opaque C.black instance Show (Pixel Binary Bit) where diff --git a/src/Graphics/Image/ColorSpace/CMYK.hs b/src/Graphics/Image/ColorSpace/CMYK.hs --- a/src/Graphics/Image/ColorSpace/CMYK.hs +++ b/src/Graphics/Image/ColorSpace/CMYK.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.CMYK +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.CMYK ( CMYK(..), CMYKA(..), Pixel(..), ToCMYK(..), ToCMYKA(..) @@ -8,26 +16,33 @@ import Prelude hiding (map) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend) +import qualified Data.Monoid as M (mappend) +import qualified Data.Colour as C +import qualified Data.Colour.Names as C +-- | Cyan, Magenta, Yellow and Black color space. data CMYK = CyanCMYK -- ^ Cyan - | MagCMYK -- ^ Mahenta + | MagCMYK -- ^ Magenta | YelCMYK -- ^ Yellow | KeyCMYK -- ^ Key (Black) deriving (Eq, Enum, Typeable) +-- | Cyan, Magenta, Yellow and Black color space with Alpha channel. data CMYKA = CyanCMYKA -- ^ Cyan - | MagCMYKA -- ^ Mahenta + | MagCMYKA -- ^ Magenta | YelCMYKA -- ^ Yellow | KeyCMYKA -- ^ Key (Black) | AlphaCMYKA -- ^ Alpha deriving (Eq, Enum, Typeable) +-- | Conversion to `CMYK` color space. class ColorSpace cs => ToCMYK cs where + -- | Convert to a `CMYK` pixel. toPixelCMYK :: Pixel cs Double -> Pixel CMYK Double + -- | Convert to a `CMYK` image. toImageCMYK :: (Array arr cs Double, Array arr CMYK Double) => Image arr cs Double -> Image arr CMYK Double @@ -35,11 +50,15 @@ {-# INLINE toImageCMYK #-} +-- | Conversion to `CMYKA` from another color space with Alpha channel. class (ToCMYK (Opaque cs), Alpha cs) => ToCMYKA cs where + -- | Convert to a `CMYKA` pixel. toPixelCMYKA :: Pixel cs Double -> Pixel CMYKA Double toPixelCMYKA px = addAlpha (getAlpha px) (toPixelCMYK (dropAlpha px)) + {-# INLINE toPixelCMYKA #-} + -- | Convert to a `CMYKA` image. toImageCMYKA :: (Array arr cs Double, Array arr CMYKA Double) => Image arr cs Double -> Image arr CMYKA Double @@ -76,9 +95,13 @@ chApp (PixelCMYK fc fm fy fk) (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k) {-# INLINE chApp #-} - pxFoldMap f (PixelCMYK c m y k) = f c `mappend` f m `mappend` f y `mappend` f k + pxFoldMap f (PixelCMYK c m y k) = f c `M.mappend` f m `M.mappend` f y `M.mappend` f k {-# INLINE pxFoldMap #-} + csColour CyanCMYK = C.opaque C.cyan + csColour MagCMYK = C.opaque C.magenta + csColour YelCMYK = C.opaque C.yellow + csColour KeyCMYK = C.opaque C.black instance ColorSpace CMYKA where @@ -112,10 +135,14 @@ PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a) {-# INLINE chApp #-} - pxFoldMap f (PixelCMYKA c m y k a) = f c `mappend` f m `mappend` f y `mappend` f k `mappend` f a + pxFoldMap f (PixelCMYKA c m y k a) = + f c `M.mappend` f m `M.mappend` f y `M.mappend` f k `M.mappend` f a {-# INLINE pxFoldMap #-} + csColour AlphaCMYKA = C.opaque C.grey + csColour ch = csColour $ opaque ch + instance Alpha CMYKA where type Opaque CMYKA = CMYK @@ -128,6 +155,12 @@ dropAlpha (PixelCMYKA c m y k _) = PixelCMYK c m y k {-# INLINE dropAlpha #-} + opaque CyanCMYKA = CyanCMYK + opaque MagCMYKA = MagCMYK + opaque YelCMYKA = YelCMYK + opaque KeyCMYKA = KeyCMYK + opaque AlphaCMYKA = error "Data.Image.ColorSpace.CMYK (Alpha.opaque)" + instance Show CMYK where show CyanCMYK = "Cyan" @@ -135,12 +168,11 @@ show YelCMYK = "Yellow" show KeyCMYK = "Black" + instance Show CMYKA where - show CyanCMYKA = "Cyan" - show MagCMYKA = "Magenta" - show YelCMYKA = "Yellow" - show KeyCMYKA = "Black" show AlphaCMYKA = "Alpha" + show ch = show $ opaque ch + instance Show e => Show (Pixel CMYK e) where show (PixelCMYK c m y k) = "" diff --git a/src/Graphics/Image/ColorSpace/Complex.hs b/src/Graphics/Image/ColorSpace/Complex.hs --- a/src/Graphics/Image/ColorSpace/Complex.hs +++ b/src/Graphics/Image/ColorSpace/Complex.hs @@ -1,4 +1,12 @@ {-# LANGUAGE BangPatterns #-} +-- | +-- Module : Graphics.Image.ColorSpace.Complex +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.Complex ( -- ** Rectangular form Complex(..), (+:), realPart, imagPart, @@ -17,7 +25,7 @@ infix 6 +: --- | Constrcut a complex pixel from two pixels containing real and imaginary parts. +-- | Constrcut a complex pixel from two pixels representing real and imaginary parts. -- -- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @ -- diff --git a/src/Graphics/Image/ColorSpace/Gray.hs b/src/Graphics/Image/ColorSpace/Gray.hs --- a/src/Graphics/Image/ColorSpace/Gray.hs +++ b/src/Graphics/Image/ColorSpace/Gray.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.Gray +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.Gray ( Gray(..), Pixel(..), toGrayImages, fromGrayImages ) where @@ -8,7 +16,9 @@ import qualified Prelude as P (map) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend, mempty) +import qualified Data.Monoid as M (mappend, mempty) +import qualified Data.Colour as C +import qualified Data.Colour.Names as C -- ^ This is a signgle channel colorspace, that is designed to hold any channel -- from any other colorspace, hence it is not convertible to and from, but @@ -53,14 +63,13 @@ -- fromGrayImages :: forall arr cs e . (Array arr Gray e, Array arr cs e) => [Image arr Gray e] -> [cs] -> Image arr cs e -fromGrayImages imgs chs = - fromGrays (singleton (fromChannel 0)) imgs chs where - updateCh ch px (PixelGray e) = chOp (\ !ch' !e' -> if ch' == ch then e else e') px - {-# INLINE updateCh #-} - fromGrays img [] _ = img - fromGrays img _ [] = img - fromGrays img (i:is) (c:cs) = fromGrays (zipWith (updateCh c) img i) is cs - {-# INLINE fromGrays #-} +fromGrayImages = fromGrays (singleton (fromChannel 0)) where + updateCh ch px (PixelGray e) = chOp (\ !ch' !e' -> if ch' == ch then e else e') px + {-# INLINE updateCh #-} + fromGrays img [] _ = img + fromGrays img _ [] = img + fromGrays img (i:is) (c:cs) = fromGrays (zipWith (updateCh c) img i) is cs + {-# INLINE fromGrays #-} {-# INLINE fromGrayImages #-} @@ -89,11 +98,20 @@ chApp (PixelGray f) (PixelGray g) = PixelGray (f g) {-# INLINE chApp #-} - pxFoldMap f (PixelGray g) = f g `mappend` mempty + pxFoldMap f (PixelGray g) = f g `M.mappend` M.mempty {-# INLINE pxFoldMap #-} + csColour _ = C.opaque C.gray + instance Show e => Show (Pixel Gray e) where show (PixelGray g) = "" +instance Monad (Pixel Gray) where + + return = PixelGray + {-# INLINE return #-} + + (>>=) (PixelGray g) f = f g + {-# INLINE (>>=) #-} diff --git a/src/Graphics/Image/ColorSpace/HSI.hs b/src/Graphics/Image/ColorSpace/HSI.hs --- a/src/Graphics/Image/ColorSpace/HSI.hs +++ b/src/Graphics/Image/ColorSpace/HSI.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.HSI +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.HSI ( HSI(..), HSIA(..), Pixel(..), ToHSI(..), ToHSIA(..) @@ -8,34 +16,47 @@ import Prelude hiding (map) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend) +import qualified Data.Monoid as M (mappend) +import qualified Data.Colour as C +import qualified Data.Colour.Names as C -data HSI = HueHSI - | SatHSI - | IntHSI deriving (Eq, Enum, Typeable) +-- | Hue, Saturation and Intensity color space. +data HSI = HueHSI -- ^ Hue + | SatHSI -- ^ Saturation + | IntHSI -- ^ Intensity + deriving (Eq, Enum, Typeable) -data HSIA = HueHSIA - | SatHSIA - | IntHSIA - | AlphaHSIA deriving (Eq, Enum, Typeable) +-- | Hue, Saturation and Intensity color space with Alpha channel. +data HSIA = HueHSIA -- ^ Hue + | SatHSIA -- ^ Saturation + | IntHSIA -- ^ Intensity + | AlphaHSIA -- ^ Alpha + deriving (Eq, Enum, Typeable) +-- | Conversion to `HSI` color space. class ColorSpace cs => ToHSI cs where + -- | Convert to an `HSI` pixel. toPixelHSI :: Pixel cs Double -> Pixel HSI Double + -- | Convert to an `HSI` image. toImageHSI :: (Array arr cs Double, Array arr HSI Double) => Image arr cs Double -> Image arr HSI Double toImageHSI = map toPixelHSI {-# INLINE toImageHSI #-} - + +-- | Conversion to `HSIA` from another color space with Alpha channel. class (ToHSI (Opaque cs), Alpha cs) => ToHSIA cs where + -- | Convert to an `HSIA` pixel. toPixelHSIA :: Pixel cs Double -> Pixel HSIA Double toPixelHSIA px = addAlpha (getAlpha px) (toPixelHSI (dropAlpha px)) + {-# INLINE toPixelHSIA #-} + -- | Convert to an `HSIA` image. toImageHSIA :: (Array arr cs Double, Array arr HSIA Double) => Image arr cs Double -> Image arr HSIA Double @@ -70,11 +91,15 @@ chApp (PixelHSI fh fs fi) (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i) {-# INLINE chApp #-} - pxFoldMap f (PixelHSI h s i) = f h `mappend` f s `mappend` f i + pxFoldMap f (PixelHSI h s i) = f h `M.mappend` f s `M.mappend` f i {-# INLINE pxFoldMap #-} + csColour HueHSI = C.opaque C.purple + csColour SatHSI = C.opaque C.orange + csColour IntHSI = C.opaque C.darkblue + instance ColorSpace HSIA where type PixelElt HSIA e = (e, e, e, e) data Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq @@ -104,9 +129,12 @@ chApp (PixelHSIA fh fs fi fa) (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a) {-# INLINE chApp #-} - pxFoldMap f (PixelHSIA h s i a) = f h `mappend` f s `mappend` f i `mappend` f a + pxFoldMap f (PixelHSIA h s i a) = f h `M.mappend` f s `M.mappend` f i `M.mappend` f a {-# INLINE pxFoldMap #-} + csColour AlphaHSIA = C.opaque C.gray + csColour ch = csColour $ opaque ch + instance Alpha HSIA where type Opaque HSIA = HSI @@ -120,18 +148,23 @@ dropAlpha (PixelHSIA h s i _) = PixelHSI h s i {-# INLINE dropAlpha #-} + opaque HueHSIA = HueHSI + opaque SatHSIA = SatHSI + opaque IntHSIA = IntHSI + opaque _ = error "Data.Image.ColorSpace.HSI (Alpha.opaque)" + instance Show HSI where show HueHSI = "Hue" show SatHSI = "Saturation" show IntHSI = "Intensity" + instance Show HSIA where - show HueHSIA = "Hue" - show SatHSIA = "Saturation" - show IntHSIA = "Intensity" show AlphaHSIA = "Alpha" - + show ch = show $ opaque ch + + instance Show e => Show (Pixel HSI e) where show (PixelHSI h s i) = "" diff --git a/src/Graphics/Image/ColorSpace/Luma.hs b/src/Graphics/Image/ColorSpace/Luma.hs --- a/src/Graphics/Image/ColorSpace/Luma.hs +++ b/src/Graphics/Image/ColorSpace/Luma.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.Luma +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.Luma ( Y(..), YA(..), Pixel(..), ToY(..), ToYA(..) @@ -8,32 +16,43 @@ import Prelude hiding (map) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend, mempty) +import qualified Data.Monoid as M (mappend, mempty) +import qualified Data.Colour as C +import qualified Data.Colour.Names as C -- | Luma or brightness, that is usually denoted as @Y'@. data Y = Y deriving (Eq, Enum, Typeable) + -- | Luma with Alpha channel. -data YA = YA - | AlphaYA deriving (Eq, Enum, Typeable) +data YA = YA -- ^ Luma + | AlphaYA -- ^ Alpha channel + deriving (Eq, Enum, Typeable) +-- | Conversion to Luma color space. class ColorSpace cs => 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 #-} - + +-- | Conversion to Luma from another color space with Alpha channel. class (ToY (Opaque cs), Alpha cs) => 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 @@ -66,9 +85,11 @@ chApp (PixelY fy) (PixelY y) = PixelY (fy y) {-# INLINE chApp #-} - pxFoldMap f (PixelY y) = f y `mappend` mempty + pxFoldMap f (PixelY y) = f y `M.mappend` M.mempty {-# INLINE pxFoldMap #-} + csColour _ = C.opaque C.darkgray + instance ColorSpace YA where type PixelElt YA e = (e, e) @@ -96,9 +117,13 @@ chApp (PixelYA fy fa) (PixelYA y a) = PixelYA (fy y) (fa a) {-# INLINE chApp #-} - pxFoldMap f (PixelYA y a) = f y `mappend` f a + pxFoldMap f (PixelYA y a) = f y `M.mappend` f a {-# INLINE pxFoldMap #-} + + csColour AlphaYA = C.opaque C.gray + csColour ch = csColour $ opaque ch + instance Alpha YA where type Opaque YA = Y @@ -111,14 +136,17 @@ dropAlpha (PixelYA g _) = PixelY g {-# INLINE dropAlpha #-} + opaque YA = Y + opaque _ = error "Data.Image.ColorSpace.Luma (Alpha.opaque)" + instance Show Y where show Y = "Luma" instance Show YA where - show YA = "Luma" show AlphaYA = "Alpha" + show ch = show $ opaque ch instance Show e => Show (Pixel Y e) where @@ -129,3 +157,10 @@ show (PixelYA g a) = "" +instance Monad (Pixel Y) where + + return = PixelY + {-# INLINE return #-} + + (>>=) (PixelY y) f = f y + {-# INLINE (>>=) #-} diff --git a/src/Graphics/Image/ColorSpace/RGB.hs b/src/Graphics/Image/ColorSpace/RGB.hs --- a/src/Graphics/Image/ColorSpace/RGB.hs +++ b/src/Graphics/Image/ColorSpace/RGB.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.RGB +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.RGB ( RGB(..), RGBA(..), Pixel(..), ToRGB(..), ToRGBA(..) @@ -8,23 +16,30 @@ import Prelude hiding (map) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend) +import qualified Data.Monoid as M (mappend) +import qualified Data.Colour as C +import qualified Data.Colour.Names as C +-- | Red, Green and Blue color space. data RGB = RedRGB | GreenRGB | BlueRGB deriving (Eq, Enum, Typeable) +-- | Red, Green and Blue color space with Alpha channel. data RGBA = RedRGBA | GreenRGBA | BlueRGBA | AlphaRGBA deriving (Eq, Enum, Typeable) +-- | Conversion to `RGB` color space. class ColorSpace cs => ToRGB cs where + -- | Convert to an `RGB` pixel. toPixelRGB :: Pixel cs Double -> Pixel RGB Double + -- | Convert to an `RGB` image. toImageRGB :: (Array arr cs Double, Array arr RGB Double) => Image arr cs Double -> Image arr RGB Double @@ -32,11 +47,15 @@ {-# INLINE toImageRGB #-} +-- | Conversion to `RGBA` from another color space with Alpha channel. class (ToRGB (Opaque cs), Alpha cs) => ToRGBA cs where + -- | Convert to an `RGBA` pixel. toPixelRGBA :: Pixel cs Double -> Pixel RGBA Double toPixelRGBA px = addAlpha (getAlpha px) (toPixelRGB (dropAlpha px)) + {-# INLINE toPixelRGBA #-} + -- | Convert to an `RGBA` image. toImageRGBA :: (Array arr cs Double, Array arr RGBA Double) => Image arr cs Double -> Image arr RGBA Double @@ -71,9 +90,13 @@ chApp (PixelRGB fr fg fb) (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b) {-# INLINE chApp #-} - pxFoldMap f (PixelRGB r g b) = f r `mappend` f g `mappend` f b + pxFoldMap f (PixelRGB r g b) = f r `M.mappend` f g `M.mappend` f b {-# INLINE pxFoldMap #-} + csColour RedRGB = C.opaque C.red + csColour GreenRGB = C.opaque C.green + csColour BlueRGB = C.opaque C.blue + instance ColorSpace RGBA where type PixelElt RGBA e = (e, e, e, e) @@ -104,10 +127,13 @@ chApp (PixelRGBA fr fg fb fa) (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a) {-# INLINE chApp #-} - pxFoldMap f (PixelRGBA r g b a) = f r `mappend` f g `mappend` f b `mappend` f a + pxFoldMap f (PixelRGBA r g b a) = f r `M.mappend` f g `M.mappend` f b `M.mappend` f a {-# INLINE pxFoldMap #-} + csColour AlphaRGBA = C.opaque C.gray + csColour ch = csColour $ opaque ch + instance Alpha RGBA where type Opaque RGBA = RGB @@ -120,7 +146,12 @@ dropAlpha (PixelRGBA r g b _) = PixelRGB r g b {-# INLINE dropAlpha #-} + opaque RedRGBA = RedRGB + opaque GreenRGBA = GreenRGB + opaque BlueRGBA = BlueRGB + opaque AlphaRGBA = error "Data.Image.ColorSpace.RGB (Alpha.opaque)" + instance Show RGB where show RedRGB = "Red" show GreenRGB = "Green" @@ -128,10 +159,8 @@ instance Show RGBA where - show RedRGBA = "Red" - show GreenRGBA = "Green" - show BlueRGBA = "Blue" show AlphaRGBA = "Alpha" + show ch = show $ opaque ch instance Show e => Show (Pixel RGB e) where diff --git a/src/Graphics/Image/ColorSpace/YCbCr.hs b/src/Graphics/Image/ColorSpace/YCbCr.hs --- a/src/Graphics/Image/ColorSpace/YCbCr.hs +++ b/src/Graphics/Image/ColorSpace/YCbCr.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +-- | +-- Module : Graphics.Image.ColorSpace.YCbCr +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.ColorSpace.YCbCr ( YCbCr(..), YCbCrA(..), Pixel(..), ToYCbCr(..), ToYCbCrA(..) @@ -8,23 +16,33 @@ import Prelude hiding (map) import Graphics.Image.Interface import Data.Typeable (Typeable) -import Data.Monoid (mappend) +import qualified Data.Monoid as M (mappend) +import qualified Data.Colour as C +import qualified Data.Colour.Names as C -data YCbCr = LumaYCbCr - | CBlueYCbCr - | CRedYCbCr deriving (Eq, Enum, Typeable) +-- | Color space is used to encode RGB information and is used in JPEG compression. +data YCbCr = LumaYCbCr -- ^ Luma component (commonly denoted as __Y'__) + | CBlueYCbCr -- ^ Blue difference chroma component + | CRedYCbCr -- ^ Red difference chroma component + deriving (Eq, Enum, Typeable) -data YCbCrA = LumaYCbCrA - | CBlueYCbCrA - | CRedYCbCrA - | AlphaYCbCrA deriving (Eq, Enum, Typeable) +-- | YCbCr color space with Alpha channel. +data YCbCrA = LumaYCbCrA -- ^ Luma component (commonly denoted as __Y'__) + | CBlueYCbCrA -- ^ Blue difference chroma component + | CRedYCbCrA -- ^ Red difference chroma component + | AlphaYCbCrA -- ^ Alpha component. + deriving (Eq, Enum, Typeable) + +-- | Conversion to `YCbCr` color space. class ColorSpace cs => ToYCbCr cs where + -- | Convert to an `YCbCr` pixel. toPixelYCbCr :: Pixel cs Double -> Pixel YCbCr Double + -- | Convert to an `YCbCr` image. toImageYCbCr :: (Array arr cs Double, Array arr YCbCr Double) => Image arr cs Double -> Image arr YCbCr Double @@ -32,11 +50,15 @@ {-# INLINE toImageYCbCr #-} +-- | Conversion to `YCbCrA` from another color space with Alpha channel. class (ToYCbCr (Opaque cs), Alpha cs) => ToYCbCrA cs where + -- | Convert to an `YCbCrA` pixel. toPixelYCbCrA :: Pixel cs Double -> Pixel YCbCrA Double toPixelYCbCrA px = addAlpha (getAlpha px) (toPixelYCbCr (dropAlpha px)) + {-# INLINE toPixelYCbCrA #-} + -- | Convert to an `YCbCrA` image. toImageYCbCrA :: (Array arr cs Double, Array arr YCbCrA Double) => Image arr cs Double -> Image arr YCbCrA Double @@ -71,9 +93,13 @@ chApp (PixelYCbCr fy fb fr) (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r) {-# INLINE chApp #-} - pxFoldMap f (PixelYCbCr y b r) = f y `mappend` f b `mappend` f r + pxFoldMap f (PixelYCbCr y b r) = f y `M.mappend` f b `M.mappend` f r {-# INLINE pxFoldMap #-} + csColour LumaYCbCr = C.opaque C.darkgray + csColour CBlueYCbCr = C.opaque C.darkblue + csColour CRedYCbCr = C.opaque C.darkred + instance ColorSpace YCbCrA where type PixelElt YCbCrA e = (e, e, e, e) @@ -104,10 +130,13 @@ chApp (PixelYCbCrA fy fb fr fa) (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a) {-# INLINE chApp #-} - pxFoldMap f (PixelYCbCrA y b r a) = f y `mappend` f b `mappend` f r `mappend` f a + pxFoldMap f (PixelYCbCrA y b r a) = f y `M.mappend` f b `M.mappend` f r `M.mappend` f a {-# INLINE pxFoldMap #-} + csColour AlphaYCbCrA = C.opaque C.gray + csColour ch = csColour $ opaque ch + instance Alpha YCbCrA where type Opaque YCbCrA = YCbCr @@ -120,7 +149,12 @@ dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r {-# INLINE dropAlpha #-} + opaque LumaYCbCrA = LumaYCbCr + opaque CBlueYCbCrA = CBlueYCbCr + opaque CRedYCbCrA = CRedYCbCr + opaque AlphaYCbCrA = error "Data.Image.ColorSpace.YCbCr (Alpha.opaque)" + instance Show YCbCr where show LumaYCbCr = "Luma" show CBlueYCbCr = "Blue Chroma" @@ -128,10 +162,8 @@ instance Show YCbCrA where - show LumaYCbCrA = "Luma" - show CBlueYCbCrA = "Blue Chroma" - show CRedYCbCrA = "Red Chroma" show AlphaYCbCrA = "Alpha" + show ch = show $ opaque ch instance Show e => Show (Pixel YCbCr e) where diff --git a/src/Graphics/Image/IO.hs b/src/Graphics/Image/IO.hs --- a/src/Graphics/Image/IO.hs +++ b/src/Graphics/Image/IO.hs @@ -1,5 +1,13 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# LANGUAGE BangPatterns, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +-- | +-- Module : Graphics.Image.IO +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.IO ( -- * Reading readImage, readImageExact, @@ -7,7 +15,6 @@ writeImage, writeImageExact, -- * Displaying displayImage, setDisplayProgram, - --displayImageHistograms, displayHistograms, writeHistograms, -- * Supported Image Formats module Graphics.Image.IO.External @@ -17,24 +24,21 @@ import Prelude as P hiding (readFile, writeFile) import qualified Control.Monad as M (foldM) -import Control.Concurrent -- (forkIO, ThreadId) +import Control.Concurrent (forkIO, ThreadId) import Data.Char (toLower) +import Data.Maybe (fromMaybe) import Data.IORef import Data.ByteString (readFile) ---import Graphics.EasyPlot hiding (TerminalType(..)) ---import qualified Graphics.EasyPlot as Plot (TerminalType(PNG)) import Graphics.Image.ColorSpace import Graphics.Image.Interface import Graphics.Image.IO.Base import Graphics.Image.IO.External ---import HIP.Histogram import qualified Data.ByteString.Lazy as BL (writeFile, hPut) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (takeExtension) import System.IO (Handle, hFlush) import System.IO.Temp (withSystemTempFile) -import System.IO.Unsafe (unsafePerformIO) -import System.Process (spawnProcess, waitForProcess, showCommandForUser) +import System.Process (waitForProcess, showCommandForUser) guessFormat :: (ImageFormat f, Enum f) => FilePath -> Maybe f @@ -57,9 +61,9 @@ -> IO (Either String (Image arr cs Double)) readImage path = do imgstr <- readFile path - let maybeFormat = (guessFormat path :: Maybe InputFormat) + let maybeFormat = guessFormat path :: Maybe InputFormat formats = enumFrom . toEnum $ 0 - orderedFormats = maybe formats (\f -> f:(filter (/=f) formats)) maybeFormat + orderedFormats = maybe formats (\f -> f:filter (/=f) formats) maybeFormat reader (Left err) format = return $ either (Left . ((err++"\n")++)) Right (decode format imgstr) reader img _ = return img @@ -72,7 +76,7 @@ -- representation. -- -- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RP YCbCr Word8)) --- Right +-- Right -- -- The drawback here is that colorspace and precision has to match exactly, -- otherwise it will return an error: @@ -107,11 +111,15 @@ -> Image arr cs Double -- ^ An image to write. -> IO () writeImage path = BL.writeFile path . encode format [] where - format = maybe (error ("Could not guess output format. Use 'writeImageExact' "++ + format = fromMaybe (error ("Could not guess output format. Use 'writeImageExact' "++ "or supply a filename with supported format.")) - id (guessFormat path :: Maybe OutputFormat) + (guessFormat path :: Maybe OutputFormat) - + +-- | Write an image in a specific format, while supplying any format specific +-- options. Precision and color space that an image will be written is decided +-- from image's type. Attempt to write image file in a format that does not +-- support color space and precision combination will result in a compile error. writeImageExact :: Writable img format => format -- ^ A file format that an image should be saved in. See @@ -138,11 +146,6 @@ setDisplayProgram = writeIORef displayProgram -displayProgram :: IORef (String, Bool) -displayProgram = unsafePerformIO . newIORef $ ("gpicview", False) -{-# NOINLINE displayProgram #-} - - {- | Makes a call to the current display program, which can be changed using 'setDisplayProgram'. An image is written as a @.tiff@ file into an operating system's temporary directory and passed as an argument to the display @@ -168,7 +171,7 @@ let displayAction = withSystemTempFile "tmp-img.tiff" (displayUsing img program) if block then displayAction >> return Nothing - else forkIO displayAction >>= (return . Just) + else Just <$> forkIO displayAction displayUsing :: (ManifestArray arr cs e, Writable (Image arr cs e) TIF) => @@ -255,59 +258,3 @@ -} - -{- -displayImageHistograms :: (Strategy strat img (Channel px), AImage img px, - Enum (Channel px), RealFrac (Channel px)) => - strat img (Channel px) - -> Int - -> img px - -> IO () -displayImageHistograms strat steps img = displayHistograms $ getHistograms strat steps img - - --- | Displays a list of 'Histogram's supplied using an external program that can --- be changed with 'setDisplayProgram'. --- --- >>> centaurus <- readImageRGB "images/centaurus.jpg" --- >>> cluster <- readImageRGB "images/cluster.jpg" --- >>> displayHistograms ((getHistograms 255 centaurus)++(getHistograms 255 cluster)) --- --- <> --- -displayHistograms :: (Show a, Num a, Fractional a, Enum a) => [Histogram a] -> IO () -displayHistograms hists = do - program <- readIORef displayProgram - withSystemTempDirectory "hip_" (displayHistogramsUsing hists program) - - -displayHistogramsUsing :: (Show a, Num a, Fractional a, Enum a) => - [Histogram a] -> String -> FilePath -> IO () -displayHistogramsUsing hists program tmpDir = do - let path = tmpDir "tmp-hist.png" - wrote <- writeHistograms path hists - if wrote - then do ph <- runCommand (program ++ " " ++ path) - e <- waitForProcess ph - let printExit ExitSuccess = return () - printExit exitCode = print exitCode - printExit e - else print "Was unsuccessfull in using gnuplot." - - --- | Writes histograms into a PNG file image. --- --- >>> centaurus <- readImageRGB "images/centaurus.jpg" --- >>> cluster <- readImageRGB "images/cluster.jpg" --- >>> let histograms = ((getHistograms 255 centaurus)++(getHistograms 255 cluster)) --- >>> writeHistograms "images/centaurus_cluster_histogram.png" histograms --- True --- -writeHistograms :: (Show a, Num a, Fractional a, Enum a) => - FilePath -- ^ PNG image file name. - -> [Histogram a] -- ^ List of histograms to be plotted. - -> IO Bool -- ^ Returns 'True' in case of success. -writeHistograms path = plot (Plot.PNG path) - - --} diff --git a/src/Graphics/Image/IO/Base.hs b/src/Graphics/Image/IO/Base.hs --- a/src/Graphics/Image/IO/Base.hs +++ b/src/Graphics/Image/IO/Base.hs @@ -1,36 +1,70 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} +-- | +-- Module : Graphics.Image.IO.Base +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.IO.Base ( - ImageFormat(..), Readable(..), Writable(..), Convertible(..) + ImageFormat(..), Readable(..), Writable(..), Convertible(..), + displayProgram, spawnProcess ) where import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import System.Process (proc, createProcess, ProcessHandle) +-- | Used during converting pixels between libraries. class Convertible a b where convert :: a -> b - +-- | Image file format. Helps in guessing image format using a file extension, +-- as well as supplying format specific options during saving an image. class ImageFormat format where + -- | Options that can be used during writing an image in this format. data SaveOption format + -- | Default file extension for this image format. ext :: format -> String + -- | Known extensions for this image format. exts :: format -> [String] exts f = [ext f] + -- | Returns `True` if a file extension (ex. @".png"@) corresponds to this format. isFormat :: String -> format -> Bool - isFormat e f = e `elem` (exts f) + isFormat e f = e `elem` exts f +-- | Image formats that can be read from file. class ImageFormat format => Readable img format where + -- | Decode an image from `BL.ByteString`. decode :: format -> B.ByteString -> Either String img +-- | Image formats that can be written to file. class ImageFormat format => Writable img format where + -- | Encode an image to `BL.ByteString`. encode :: format -> [SaveOption format] -> img -> BL.ByteString + +-- | Global variable for setting display program. +displayProgram :: IORef (String, Bool) +displayProgram = unsafePerformIO . newIORef $ ("gpicview", False) +{-# NOINLINE displayProgram #-} + + +-- | Implemented here for backwards compatibility with `process < 1.2.0.0` +spawnProcess :: FilePath -> [String] -> IO ProcessHandle +spawnProcess cmd args = do + (_,_,_,p) <- createProcess (proc cmd args) + return p diff --git a/src/Graphics/Image/IO/External.hs b/src/Graphics/Image/IO/External.hs --- a/src/Graphics/Image/IO/External.hs +++ b/src/Graphics/Image/IO/External.hs @@ -1,5 +1,13 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +-- | +-- Module : Graphics.Image.IO.External +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.IO.External ( module Graphics.Image.IO.External.JuicyPixels, module Graphics.Image.IO.External.Netpbm, diff --git a/src/Graphics/Image/IO/External/JuicyPixels.hs b/src/Graphics/Image/IO/External/JuicyPixels.hs --- a/src/Graphics/Image/IO/External/JuicyPixels.hs +++ b/src/Graphics/Image/IO/External/JuicyPixels.hs @@ -1,6 +1,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, ViewPatterns #-} +-- | +-- Module : Graphics.Image.IO.External.JuicyPixels +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.IO.External.JuicyPixels ( BMP(..), GIF(..), JP.GifDelay, JP.GifLooping(..), JP.PaletteOptions(..), JP.PaletteCreationMethod(..), @@ -9,7 +17,7 @@ import GHC.Float import Data.Either -import Data.Monoid (mempty) +import qualified Data.Monoid as M (mempty) import Graphics.Image.ColorSpace import Graphics.Image.Interface hiding (map) import Graphics.Image.IO.Base @@ -21,7 +29,8 @@ import qualified Codec.Picture.ColorQuant as JP -data BMP = BMP -- ^ Bitmap image with @.bmp@ extension. +-- | Bitmap image with @.bmp@ extension. +data BMP = BMP instance ImageFormat BMP where data SaveOption BMP @@ -29,7 +38,8 @@ ext _ = ".bmp" -data GIF = GIF -- ^ Graphics Interchange Format image with @.gif@ extension. +-- | Graphics Interchange Format image with @.gif@ extension. +data GIF = GIF instance ImageFormat GIF where data SaveOption GIF = GIFPalette JP.PaletteOptions @@ -42,7 +52,8 @@ ext _ = ext GIF -data HDR = HDR -- ^ High-dynamic-range image with @.hdr@ extension. +-- | High-dynamic-range image with @.hdr@ or @.pic@ extension. +data HDR = HDR instance ImageFormat HDR where data SaveOption HDR @@ -52,8 +63,8 @@ exts _ = [".hdr", ".pic"] -data JPG = JPG -- ^ Joint Photographic Experts Group image with @.jpg@ or - -- @.jpeg@ extension. +-- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension. +data JPG = JPG instance ImageFormat JPG where data SaveOption JPG = JPGQuality Word8 @@ -63,7 +74,8 @@ exts _ = [".jpg", ".jpeg"] -data PNG = PNG -- ^ Portable Network Graphics image with @.png@ extension. +-- | Portable Network Graphics image with @.png@ extension. +data PNG = PNG instance ImageFormat PNG where data SaveOption PNG @@ -71,7 +83,8 @@ ext _ = ".png" -data TGA = TGA -- ^ Truevision Graphics Adapter image with .tga extension. +-- | Truevision Graphics Adapter image with .tga extension. +data TGA = TGA instance ImageFormat TGA where data SaveOption TGA @@ -79,8 +92,8 @@ ext _ = ".tga" -data TIF = TIF -- ^ Tagged Image File Format image with @.tif@ or @.tiff@ - -- extension. +-- | Tagged Image File Format image with @.tif@ or @.tiff@ extension. +data TIF = TIF instance ImageFormat TIF where data SaveOption TIF @@ -613,7 +626,7 @@ jpImageToImage :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) => JP.Image jpx -> Image arr cs e -jpImageToImage jimg = make (JP.imageHeight jimg, JP.imageWidth jimg) getPx +jpImageToImage jimg = makeImage (JP.imageHeight jimg, JP.imageWidth jimg) getPx where getPx (y, x) = convert $ JP.pixelAt jimg x y @@ -884,9 +897,9 @@ encodeJPG :: (JP.JpgEncodable px, ManifestArray arr cs e) => [SaveOption JPG] -> (Pixel cs e -> px) -> Image arr cs e -> BL.ByteString encodeJPG [] conv = - JP.encodeDirectJpegAtQualityWithMetadata 100 mempty . imageToJPImage conv + JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage conv encodeJPG (JPGQuality q:_) conv = - JP.encodeDirectJpegAtQualityWithMetadata q mempty . imageToJPImage conv + JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage conv instance ManifestArray arr Y Word8 => Writable (Image arr Y Word8) JPG where diff --git a/src/Graphics/Image/IO/External/Netpbm.hs b/src/Graphics/Image/IO/External/Netpbm.hs --- a/src/Graphics/Image/IO/External/Netpbm.hs +++ b/src/Graphics/Image/IO/External/Netpbm.hs @@ -1,5 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} +-- | +-- Module : Graphics.Image.IO.External.Netpbm +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.IO.External.Netpbm ( PBM(..), PGM(..), PPM(..) ) where @@ -14,7 +22,8 @@ import qualified Data.Vector.Storable as VS ((!), Vector) -data PBM = PBM -- ^ Netpbm: portable bitmap image with .pbm extension. +-- | Netpbm: portable bitmap image with @.pbm@ extension. +data PBM = PBM instance ImageFormat PBM where data SaveOption PBM @@ -22,7 +31,8 @@ ext _ = ".pbm" -data PGM = PGM -- ^ Netpbm: portable graymap image with .pgm extension. +-- | Netpbm: portable graymap image with @.pgm@ extension. +data PGM = PGM instance ImageFormat PGM where data SaveOption PGM @@ -30,7 +40,8 @@ ext _ = ".pgm" -data PPM = PPM -- ^ Netpbm: portable pixmap image with .ppm extension. +-- | Netpbm: portable pixmap image with @.ppm@ extension. +data PPM = PPM instance ImageFormat PPM where data SaveOption PPM @@ -222,36 +233,36 @@ Convertible PNM.PgmPixel16 px, Convertible PNM.PgmPixel8 px, Convertible PNM.PpmPixelRGB16 px, Convertible PNM.PpmPixelRGB8 px) => (px -> Pixel cs e) -> Int -> Int -> PNM.PpmPixelData -> Image arr cs e -pnmDataToImage conv w h (PNM.PbmPixelData v) = make (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PgmPixelData8 v) = make (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PgmPixelData16 v) = make (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PpmPixelDataRGB8 v) = make (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PpmPixelDataRGB16 v) = make (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PbmPixelData v) = makeImage (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PgmPixelData8 v) = makeImage (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PgmPixelData16 v) = makeImage (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PpmPixelDataRGB8 v) = makeImage (h, w) (conv . getPx v w) +pnmDataToImage conv w h (PNM.PpmPixelDataRGB16 v) = makeImage (h, w) (conv . getPx v w) pnmDataPBMToImage :: (Array arr cs e, Convertible PNM.PbmPixel (Pixel cs e)) => Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) -pnmDataPBMToImage w h (PNM.PbmPixelData v) = Right $ make (h, w) (getPx v w) +pnmDataPBMToImage w h (PNM.PbmPixelData v) = Right $ makeImage (h, w) (getPx v w) pnmDataPBMToImage _ _ d = pnmCSError "Binary (Pixel Binary Bit)" d pnmDataPGM8ToImage :: (Array arr cs e, Convertible PNM.PgmPixel8 (Pixel cs e)) => Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) -pnmDataPGM8ToImage w h (PNM.PgmPixelData8 v) = Right $ make (h, w) (getPx v w) +pnmDataPGM8ToImage w h (PNM.PgmPixelData8 v) = Right $ makeImage (h, w) (getPx v w) pnmDataPGM8ToImage _ _ d = pnmCSError "Y8 (Pixel Y Word8)" d pnmDataPGM16ToImage :: (Array arr cs e, Convertible PNM.PgmPixel16 (Pixel cs e)) => Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) -pnmDataPGM16ToImage w h (PNM.PgmPixelData16 v) = Right $ make (h, w) (getPx v w) +pnmDataPGM16ToImage w h (PNM.PgmPixelData16 v) = Right $ makeImage (h, w) (getPx v w) pnmDataPGM16ToImage _ _ d = pnmCSError "Y16 (Pixel Y Word16)" d pnmDataPPM8ToImage :: (Array arr cs e, Convertible PNM.PpmPixelRGB8 (Pixel cs e)) => Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) -pnmDataPPM8ToImage w h (PNM.PpmPixelDataRGB8 v) = Right $ make (h, w) (getPx v w) +pnmDataPPM8ToImage w h (PNM.PpmPixelDataRGB8 v) = Right $ makeImage (h, w) (getPx v w) pnmDataPPM8ToImage _ _ d = pnmCSError "RGB8 (Pixel RGB Word8)" d pnmDataPPM16ToImage :: (Array arr cs e, Convertible PNM.PpmPixelRGB16 (Pixel cs e)) => Int -> Int -> PNM.PpmPixelData -> Either String (Image arr cs e) -pnmDataPPM16ToImage w h (PNM.PpmPixelDataRGB16 v) = Right $ make (h, w) (getPx v w) +pnmDataPPM16ToImage w h (PNM.PpmPixelDataRGB16 v) = Right $ makeImage (h, w) (getPx v w) pnmDataPPM16ToImage _ _ d = pnmCSError "RGB16 (Pixel RGB Word16)" d diff --git a/src/Graphics/Image/IO/Histogram.hs b/src/Graphics/Image/IO/Histogram.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/Histogram.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns #-} +-- | +-- Module : Graphics.Image.IO.Histogram +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.IO.Histogram ( + Histogram(..), getHistograms, getHistogram, + displayHistograms, writeHistograms + ) where + +import Prelude hiding (map, mapM_, zipWith) +import qualified Prelude as P (map, mapM_, zipWith) +import Control.Monad.Primitive (PrimMonad (..)) +import Graphics.Image.Interface +import Graphics.Image.ColorSpace +import Graphics.Image.IO.Base (displayProgram, spawnProcess) +import Graphics.Rendering.Chart.Easy +import Graphics.Rendering.Chart.Backend.Cairo +import qualified Data.Colour as C +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as MV +import Data.IORef +import Control.Concurrent (forkIO, ThreadId) +import System.Exit (ExitCode(ExitSuccess)) +import System.Process (waitForProcess, showCommandForUser) +import System.IO.Temp (withSystemTempDirectory) +import System.FilePath (()) + +-- | A single channel histogram of an image. +data Histogram = Histogram { hBins :: V.Vector Int + -- ^ Vector containing pixel counts. Index of a + -- vector serves as an original pixel value. + , hName :: String + -- ^ Name of the channel that will be displayed in + -- the legend. + , hColour :: C.AlphaColour Double + -- ^ Color of a plotted line. + } + + +-- | Create a histogram per channel with 256 bins each. +getHistograms :: forall arr cs e . (SequentialArray arr Gray e, + SequentialArray arr cs e, Elevator e) => + Image arr cs e + -> [Histogram] +getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toGrayImages + where setCh cs h = h { hName = show cs + , hColour = csColour cs } + +-- | Generate a histogram with 256 bins for a single channel Gray image. +getHistogram :: (SequentialArray arr Gray e, Elevator e) => + Image arr Gray 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 (toWord8 -> (PixelGray g)) = modify v (+1) $ fromIntegral g + countBins v = mapM_ (incBin v) img + + +-- | Write histograms into a PNG image file. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> writeHistograms "images/frog_histogram.png" $ getHistograms frog +-- +-- <> +-- +writeHistograms :: FilePath -> [Histogram] -> IO () +writeHistograms fileName hists = toFile def fileName $ do + layout_title .= "Histogram" + setColors $ P.map hColour hists + let axis = set la_nTicks 20 . set la_nLabels 14 + layout_x_axis . laxis_generate .= scaledIntAxis (axis defaultIntAxis) (0, 260) + P.mapM_ plotHist hists where + plotHist h = plot (line (hName h) [V.toList $ V.imap (,) $ hBins h]) + + +-- | Display image histograms using an external program. Works the same way as +-- `Graphics.Image.IO.displayImage`. +-- +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> displayHistograms $ getHistograms frog +-- +displayHistograms :: [Histogram] -> IO (Maybe ThreadId) +displayHistograms hists = do + (program, block) <- readIORef displayProgram + let displayAction = withSystemTempDirectory "hip" (displayUsing hists program) + if block + then displayAction >> return Nothing + else Just <$> forkIO displayAction + + +-- | IO action that writes histogram to file into a system temporary directory +-- and spawns an external program that displays it. File is deleted after +-- program is closed. +displayUsing :: [Histogram] -> String -> FilePath -> IO () +displayUsing hists program path = do + let path' = path "tmp-hist.png" + writeHistograms path' hists + ph <- spawnProcess program [path'] + e <- waitForProcess ph + let printExit ExitSuccess = return () + printExit exitCode = do + putStrLn $ showCommandForUser program [path'] + print exitCode + printExit e + + +-- | Used for backwards compatibility with vector. +modify :: (PrimMonad m, V.Unbox a) => MV.MVector (PrimState m) a -> (a -> a) -> Int -> m () +modify v f idx = do + e <- MV.read v idx + MV.write v idx $ f e diff --git a/src/Graphics/Image/Interface.hs b/src/Graphics/Image/Interface.hs --- a/src/Graphics/Image/Interface.hs +++ b/src/Graphics/Image/Interface.hs @@ -1,24 +1,34 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, - MultiParamTypeClasses, ScopedTypeVariables, - TypeFamilies, UndecidableInstances, ViewPatterns #-} - +{-# LANGUAGE CPP, BangPatterns, ConstraintKinds, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, + UndecidableInstances, ViewPatterns #-} +-- | +-- Module : Graphics.Image.Interface +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Interface ( ColorSpace(..), Alpha(..), Elevator(..), Array(..), ManifestArray(..), SequentialArray(..), MutableArray(..), Exchangable(..), - defaultIndex, maybeIndex, Border(..), borderIndex + defaultIndex, maybeIndex, Border(..), borderIndex, + Applicative(..), (<$>), (<$), (<**>), liftA, liftA2, liftA3, ) where import Prelude hiding (and, map, zipWith, sum, product) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid) +import Data.Foldable (Foldable(foldMap)) +#endif import GHC.Exts (Constraint) import Data.Typeable (Typeable, showsTypeRep, typeOf) -import Data.Monoid (Monoid) import Control.DeepSeq (NFData(rnf)) import Data.Word -import Data.Foldable (Foldable(foldMap)) import Control.Applicative import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.Colour as C -- | This class has all included color spaces installed into it and is also @@ -60,10 +70,14 @@ -- | A pixel eqiuvalent of 'foldMap'. pxFoldMap :: Monoid m => (e -> m) -> Pixel cs e -> m + + -- | Get a pure colour representation of a channel. + csColour :: cs -> C.AlphaColour Double +-- | A color space that supports transparency. class (ColorSpace (Opaque cs), ColorSpace cs) => Alpha cs where - -- | An opaque version of this color space. + -- | An corresponding opaque version of this color space. type Opaque cs -- | Get an alpha channel of a transparant pixel. @@ -81,6 +95,8 @@ -- dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e + -- | Get a corresponding opaque channel type. + opaque :: cs -> Opaque cs -- | A class with a set of convenient functions that allow for changing precision of @@ -106,21 +122,27 @@ fromDouble :: ColorSpace cs => Pixel cs Double -> Pixel cs e - -class (Show arr, ColorSpace cs, Num (Pixel cs e), Num e, Typeable e, Elt arr cs e) => + +-- | Base array like representation for an image. +class (Show arr, ColorSpace cs, Num (Pixel cs e), + Functor (Pixel cs), Applicative (Pixel cs), Foldable (Pixel cs), + Num e, Typeable e, Elt arr cs e) => Array arr cs e where - + + -- | Required array specific constraints for an array element. type Elt arr cs e :: Constraint type Elt arr cs e = () + + -- | Underlying image representation. data Image arr cs e - -- | Create an Image by supplying it's dimensions and a pixel genrating + -- | Create an Image by supplying it's dimensions and a pixel generating -- function. - make :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. - -> ((Int, Int) -> Pixel cs e) - -- ^ A function that takes (@i@-th row, and @j@-th column) as an - -- argument and returns a pixel for that location. - -> Image arr cs e + makeImage :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. + -> ((Int, Int) -> Pixel cs e) + -- ^ A function that takes (@i@-th row, and @j@-th column) as an + -- argument and returns a pixel for that location. + -> Image arr cs e -- | Create a singleton image, required for various operations on images with -- a scalar. @@ -130,7 +152,7 @@ -- -- >>> frog <- readImageRGB "images/frog.jpg" -- >>> frog - -- + -- -- >>> dims frog -- (200,320) -- @@ -201,21 +223,17 @@ -- | Construct an image from a nested rectangular shaped list of pixels. -- Length of an outer list will constitute @m@ rows, while the length of inner lists - -- @n@ columns. All of the inner lists must be the same length and greater than @0@. - -- - -- >>> fromLists [[PixelY (fromIntegral (i*j) / 60000) | j <- [1..300]] | i <- [1..200]] :: Image VU Y Double - -- - -- - -- <> - -- fromLists :: [[Pixel cs e]] -> Image arr cs e +-- | Array representation that is actually has real data stored in memory, hence +-- allowing for image indexing, forcing pixels into computed state etc. class Array arr cs e => ManifestArray arr cs e where -- | Get a pixel at @i@-th and @j@-th location. -- - -- >>> let grad_gray = computeS $ makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200) + -- >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200) -- >>> index grad_gray (20, 30) == PixelY ((20*30) / (200*200)) -- True -- @@ -240,41 +258,57 @@ eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool +-- | Array representation that allows computation, which depends on some specific +-- order, consequently making it possible to be computed only sequentially. class ManifestArray arr cs e => SequentialArray arr cs e where + -- | Fold an image from the left in a row major order. foldl :: (a -> Pixel cs e -> a) -> a -> Image arr cs e -> a + -- | Fold an image from the right in a row major order. foldr :: (Pixel cs e -> a -> a) -> a -> Image arr cs e -> a - mapM :: (Array arr cs' e', Monad m) => + -- | Monading mapping over an image. + mapM :: (SequentialArray arr cs' e', Functor m, Monad m) => (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m (Image arr cs e) - mapM_ :: (Array arr cs' e', Monad m) => - (Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m () + -- | Monading mapping over an image. Result is discarded. + mapM_ :: (Functor m, Monad m) => (Pixel cs e -> m b) -> Image arr cs e -> m () - foldM :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m a + foldM :: (Functor m, Monad m) => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m a - foldM_ :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m () + foldM_ :: (Functor m, Monad m) => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m () +-- | Array representation that supports mutation. class ManifestArray arr cs e => MutableArray arr cs e where data MImage st arr cs e + -- | Get dimensions of a mutable image. mdims :: MImage st arr cs e -> (Int, Int) - thaw :: PrimMonad m => Image arr cs e -> m (MImage (PrimState m) arr cs e) + -- | Yield a mutable copy of an image. + thaw :: (Functor m, PrimMonad m) => Image arr cs e -> m (MImage (PrimState m) arr cs e) - freeze :: PrimMonad m => MImage (PrimState m) arr cs e -> m (Image arr cs e) + -- | Yield an immutable copy of an image. + freeze :: (Functor m, PrimMonad m) => MImage (PrimState m) arr cs e -> m (Image arr cs e) - new :: PrimMonad m => (Int, Int) -> m (MImage (PrimState m) arr cs e) + -- | Create a mutable image with given dimensions. Pixels are uninitialized. + new :: (Functor m, PrimMonad m) => (Int, Int) -> m (MImage (PrimState m) arr cs e) - read :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> m (Pixel cs e) + -- | Yield the pixel at a given location. + read :: (Functor m, PrimMonad m) => MImage (PrimState m) arr cs e -> (Int, Int) -> m (Pixel cs e) - write :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m () + -- | Set a pixel at a given location. + write :: (Functor m, PrimMonad m) => + MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m () - swap :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m () + -- | Swap pixels at given locations. + swap :: (Functor m, PrimMonad m) => + MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m () +-- | Allows for changing an underlying image representation. class Exchangable arr' arr where -- | Exchange the underlying array representation of an image. @@ -379,16 +413,21 @@ instance ColorSpace cs => Functor (Pixel cs) where fmap = pxOp + {-# INLINE fmap #-} instance ColorSpace cs => Applicative (Pixel cs) where pure = fromChannel + {-# INLINE pure #-} (<*>) = chApp + {-# INLINE (<*>) #-} + instance ColorSpace cs => Foldable (Pixel cs) where foldMap = pxFoldMap + {-# INLINE foldMap #-} instance (ColorSpace cs, Num e) => Num (Pixel cs e) where diff --git a/src/Graphics/Image/Interface/Repa.hs b/src/Graphics/Image/Interface/Repa.hs --- a/src/Graphics/Image/Interface/Repa.hs +++ b/src/Graphics/Image/Interface/Repa.hs @@ -1,7 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} +-- | +-- Module : Graphics.Image.Interface.Repa +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Interface.Repa ( -- * Construction - makeImage, + makeImage, fromLists, -- * IO readImageY, readImageYA, readImageRGB, readImageRGBA, -- * Computation @@ -11,7 +19,8 @@ ) where import Graphics.Image.IO -import Graphics.Image.Interface +import Graphics.Image.Interface hiding (makeImage, fromLists) +import qualified Graphics.Image.Interface as I (makeImage, fromLists) import Graphics.Image.Interface.Repa.Internal import Graphics.Image.ColorSpace @@ -23,8 +32,16 @@ -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument -- and returns a pixel for that location. -> Image RD cs Double -makeImage = make +makeImage = I.makeImage {-# INLINE makeImage #-} + + +-- | Construct an image from a nested rectangular shaped list of pixels. +fromLists :: Array RD cs e => + [[Pixel cs e]] + -> Image RD cs e +fromLists = I.fromLists +{-# INLINE fromLists #-} -- | Read image as luma (brightness). diff --git a/src/Graphics/Image/Interface/Repa/Internal.hs b/src/Graphics/Image/Interface/Repa/Internal.hs --- a/src/Graphics/Image/Interface/Repa/Internal.hs +++ b/src/Graphics/Image/Interface/Repa/Internal.hs @@ -1,13 +1,24 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE BangPatterns, ConstraintKinds, GADTs, FlexibleContexts, FlexibleInstances, +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE CPP, BangPatterns, ConstraintKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, ViewPatterns #-} - +-- | +-- Module : Graphics.Image.Interface.Repa.Internal +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Interface.Repa.Internal ( RD(..), RP(..), RS(..), computeP, computeS, delay ) where +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (map, zipWith, foldl, foldr, mapM, mapM_, read, traverse) +#else import Prelude hiding (map, zipWith, foldl, foldr, mapM, mapM_, read) +#endif import qualified Prelude as P (map, mapM_) import Graphics.Image.Interface import Graphics.Image.ColorSpace.Binary (Bit(..)) @@ -43,14 +54,13 @@ show _ = "RepaSequential" instance Elt RD cs e => Array RD cs e where - type Elt RD cs e = (ColorSpace cs, Num e, Typeable e, - R.Elt e, Unbox e, + type Elt RD cs e = (ColorSpace cs, Num e, Typeable e, R.Elt e, Unbox e, R.Elt (PixelElt cs e), Unbox (PixelElt cs e), R.Elt (Pixel cs e), Unbox (Pixel cs e)) - data Image RD cs e where - RScalar :: !(Pixel cs e) -> Image RD cs e - RUImage :: !(R.Array U DIM2 (Pixel cs e)) -> Image RD cs e - RDImage :: !(R.Array D DIM2 (Pixel cs e)) -> Image RD cs e + + data Image RD cs e = RScalar !(Pixel cs e) + | RUImage !(R.Array U DIM2 (Pixel cs e)) + | RDImage !(R.Array D DIM2 (Pixel cs e)) dims (RScalar _ ) = (1, 1) dims (RUImage (extent -> (Z :. m :. n))) = (m, n) @@ -60,8 +70,8 @@ singleton = RScalar {-# INLINE singleton #-} - make !(m, n) !f = RDImage $ fromFunction (Z :. m :. n) (f . shT2) - {-# INLINE make #-} + makeImage !(m, n) !f = RDImage $ fromFunction (Z :. m :. n) (f . shT2) + {-# INLINE makeImage #-} map f (RScalar px) = RScalar (f px) map f (getDelayed -> arr) = RDImage (R.map f arr) @@ -122,14 +132,13 @@ R.Elt (PixelElt cs e), Unbox (PixelElt cs e), R.Elt (Pixel cs e), Unbox (Pixel cs e)) - data Image RS cs e where - RSImage :: !(Image RD cs e) -> Image RS cs e + data Image RS cs e = RSImage !(Image RD cs e) dims (RSImage img) = dims img {-# INLINE dims #-} - make !ix !f = computeS $ (make ix f :: Image RD cs e) - {-# INLINE make #-} + makeImage !ix !f = computeS (makeImage ix f :: Image RD cs e) + {-# INLINE makeImage #-} singleton = RSImage . singleton {-# INLINE singleton #-} @@ -169,14 +178,13 @@ R.Elt (PixelElt cs e), Unbox (PixelElt cs e), R.Elt (Pixel cs e), Unbox (Pixel cs e)) - data Image RP cs e where - RPImage :: !(Image RD cs e) -> Image RP cs e + data Image RP cs e = RPImage !(Image RD cs e) dims (RPImage img) = dims img {-# INLINE dims #-} - make !ix = suspendedComputeP . make ix - {-# INLINE make #-} + makeImage !ix = suspendedComputeP . makeImage ix + {-# INLINE makeImage #-} singleton = RPImage . singleton {-# INLINE singleton #-} @@ -287,8 +295,7 @@ instance ManifestArray RS cs e => MutableArray RS cs e where - data MImage st RS cs e where - MRSImage :: MImage st VU cs e -> MImage st RS cs e + data MImage st RS cs e = MRSImage !(MImage st VU cs e) mdims (MRSImage (mdims -> sz)) = sz {-# INLINE mdims #-} diff --git a/src/Graphics/Image/Interface/Vector.hs b/src/Graphics/Image/Interface/Vector.hs --- a/src/Graphics/Image/Interface/Vector.hs +++ b/src/Graphics/Image/Interface/Vector.hs @@ -1,7 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} +-- | +-- Module : Graphics.Image.Interface.Vector +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Interface.Vector ( -- * Construction - makeImage, fromUnboxedVector, toUnboxedVector, + makeImage, fromLists, fromUnboxedVector, toUnboxedVector, -- * IO readImageY, readImageYA, readImageRGB, readImageRGBA, -- * Representation @@ -9,7 +17,8 @@ ) where import Graphics.Image.IO -import Graphics.Image.Interface +import Graphics.Image.Interface hiding (makeImage, fromLists) +import qualified Graphics.Image.Interface as I (makeImage, fromLists) import Graphics.Image.Interface.Vector.Unboxed import Graphics.Image.ColorSpace @@ -39,11 +48,27 @@ -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument -- and returns a pixel for that location. -> Image VU cs Double -makeImage = make +makeImage = I.makeImage {-# INLINE makeImage #-} --- | Read luma (brightness) of an image. +-- | Construct an image from a nested rectangular shaped list of pixels. +-- Length of an outer list will constitute @m@ rows, while the length of inner lists - +-- @n@ columns. All of the inner lists must be the same length and greater than @0@. +-- +-- >>> fromLists [[PixelY (fromIntegral (i*j) / 60000) | j <- [1..300]] | i <- [1..200]] +-- +-- +-- <> +-- +fromLists :: Array VU cs e => + [[Pixel cs e]] + -> Image VU cs e +fromLists = I.fromLists +{-# INLINE fromLists #-} + + +-- | Read image as luma (brightness). readImageY :: FilePath -> IO (Image VU Y Double) readImageY = fmap (either error id) . readImage {-# INLINE readImageY #-} diff --git a/src/Graphics/Image/Interface/Vector/Unboxed.hs b/src/Graphics/Image/Interface/Vector/Unboxed.hs --- a/src/Graphics/Image/Interface/Vector/Unboxed.hs +++ b/src/Graphics/Image/Interface/Vector/Unboxed.hs @@ -1,7 +1,14 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, FlexibleInstances, - GADTs, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, - UndecidableInstances, ViewPatterns #-} + MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances, + ViewPatterns #-} +-- | +-- Module : Graphics.Image.Interface.Vector.Unboxed +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Interface.Vector.Unboxed ( VU(..), Image(..), fromUnboxedVector, toUnboxedVector, fromIx, toIx ) where @@ -9,15 +16,13 @@ import Prelude hiding (map, zipWith) import qualified Prelude as P (map) import Control.DeepSeq (deepseq) -import Control.Monad (liftM) -import Data.Word (Word8) +import Control.Monad (void) import Data.Typeable (Typeable) import Data.Vector.Unboxed (Vector, Unbox) -import Data.Vector.Unboxed.Deriving import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as MV import Graphics.Image.Interface -import Graphics.Image.ColorSpace.Binary (Bit(..)) +import Graphics.Image.Interface.Vector.Unboxing() -- | Unboxed 'Vector' representation. @@ -31,12 +36,12 @@ instance Elt VU cs e => Array VU cs e where type Elt VU cs e = (ColorSpace cs, Num e, Unbox e, Typeable e, Unbox (PixelElt cs e), Unbox (Pixel cs e)) - data Image VU cs e where - VScalar :: !(Pixel cs e) -> Image VU cs e - VUImage :: !Int -> !Int -> !(Vector (Pixel cs e)) -> Image VU cs e + + data Image VU cs e = VScalar !(Pixel cs e) + | VUImage !Int !Int !(Vector (Pixel cs e)) - make !(m, n) !f = VUImage m n $ V.generate (m * n) (f . toIx n) - {-# INLINE make #-} + makeImage !(m, n) !f = VUImage m n $ V.generate (m * n) (f . toIx n) + {-# INLINE makeImage #-} singleton = VScalar {-# INLINE singleton #-} @@ -75,14 +80,14 @@ else VUImage m1 n1 (V.izipWith (\ !k !px1 !px2 -> f (toIx n1 k) px1 px2) v1 v2) {-# INLINE izipWith #-} - traverse !img !getNewDims !getNewPx = make (getNewDims $ dims img) (getNewPx (index img)) + traverse !img !getNewDims !getNewPx = makeImage (getNewDims $ dims img) (getNewPx (index img)) {-# INLINE traverse #-} traverse2 !img1 !img2 !getNewDims !getNewPx = - make (getNewDims (dims img1) (dims img2)) (getNewPx (index img1) (index img2)) + makeImage (getNewDims (dims img1) (dims img2)) (getNewPx (index img1) (index img2)) {-# INLINE traverse2 #-} - transpose !img@(dims -> (m, n)) = make (n, m) getPx where + transpose !img@(dims -> (m, n)) = makeImage (n, m) getPx where getPx !(i, j) = index img (j, i) {-# INLINE getPx #-} {-# INLINE transpose #-} @@ -90,7 +95,7 @@ backpermute !(m, n) !f (VUImage _ n' v) = VUImage m n $ V.backpermute v $ V.generate (m*n) (fromIx n' . f . toIx n) backpermute !sz _ (VScalar px) = - if sz == (1, 1) then VScalar px else make sz (const px) + if sz == (1, 1) then VScalar px else makeImage sz (const px) {-# INLINE backpermute #-} fromLists !ls = if isSquare @@ -116,12 +121,12 @@ fold !f !px0 (VScalar px) = f px0 px {-# INLINE fold #-} - (|*|) img1@(VUImage m1 n1 v1) !img2@(VUImage {}) = + (|*|) img1@(VUImage m1 n1 v1) !img2@VUImage {} = if n1 /= m2 then error ("Inner dimensions of multiplying images must be the same, but received: "++ show img1 ++" X "++ show img2) else - make (m1, n2) getPx where + makeImage (m1, n2) getPx where VUImage n2 m2 v2 = transpose img2 getPx !(i, j) = V.sum $ V.zipWith (*) (V.slice (i*n1) n1 v1) (V.slice (j*m2) m2 v2) {-# INLINE getPx #-} @@ -146,12 +151,12 @@ foldr !f !a (VScalar px) = f px a {-# INLINE foldr #-} - mapM !f (VUImage m n v) = liftM (VUImage m n) (V.mapM f v) - mapM !f (VScalar px) = liftM VScalar (f px) + mapM !f (VUImage m n v) = VUImage m n <$> V.mapM f v + mapM !f (VScalar px) = VScalar <$> f px {-# INLINE mapM #-} mapM_ !f (VUImage _ _ v) = V.mapM_ f v - mapM_ !f (VScalar px) = (f px) >> return () + mapM_ !f (VScalar px) = void $ f px {-# INLINE mapM_ #-} foldM !f !a (VUImage _ _ v) = V.foldM' f a v @@ -159,29 +164,28 @@ {-# INLINE foldM #-} foldM_ !f !a (VUImage _ _ v) = V.foldM'_ f a v - foldM_ !f !a (VScalar px) = f a px >> return () + foldM_ !f !a (VScalar px) = void $ f a px {-# INLINE foldM_ #-} instance ManifestArray VU cs e => MutableArray VU cs e where - data MImage st VU cs e where - MVImage :: !Int -> !Int -> MV.MVector st (Pixel cs e) -> MImage st VU cs e - MVScalar :: MV.MVector st (Pixel cs e) -> MImage st VU cs e + data MImage st VU cs e = MVImage !Int !Int (MV.MVector st (Pixel cs e)) + | MVScalar (MV.MVector st (Pixel cs e)) mdims (MVImage m n _) = (m, n) mdims (MVScalar _) = (1, 1) {-# INLINE mdims #-} - thaw (VUImage m n v) = liftM (MVImage m n) (V.thaw v) - thaw (VScalar px) = liftM MVScalar (V.thaw (V.singleton px)) + thaw (VUImage m n v) = MVImage m n <$> V.thaw v + thaw (VScalar px) = MVScalar <$> V.thaw (V.singleton px) {-# INLINE thaw #-} - freeze (MVImage m n mv) = liftM (VUImage m n) (V.freeze mv) - freeze (MVScalar mv) = liftM (VScalar . (V.! 0)) (V.freeze mv) + freeze (MVImage m n mv) = VUImage m n <$> V.freeze mv + freeze (MVScalar mv) = VScalar . (V.! 0) <$> V.freeze mv {-# INLINE freeze #-} - new (m, n) = liftM (MVImage m n) (MV.new (m*n)) + new (m, n) = MVImage m n <$> MV.new (m*n) {-# INLINE new #-} read (MVImage _ n mv) ix = MV.read mv (fromIx n ix) @@ -221,24 +225,14 @@ | otherwise = error "fromUnboxedVector: m * n doesn't equal the length of a Vector." +-- | 2D index conversion to a flat vector index. fromIx :: Int -> (Int, Int) -> Int fromIx !n !(i, j) = i * n + j {-# INLINE fromIx #-} +-- | Vector to 2D index conversion. toIx :: Int -> Int -> (Int, Int) toIx !n !k = (k `div` n, k `mod` n) {-# INLINE toIx #-} - - -derivingUnbox "Bit" - [t| Bit -> Word8 |] - [| \(Bit w) -> w |] - [| Bit |] - - -derivingUnbox "Pixel" - [t| (ColorSpace cs, Unbox (PixelElt cs e)) => (Pixel cs e) -> (PixelElt cs e) |] - [| toElt |] - [| fromElt |] diff --git a/src/Graphics/Image/Interface/Vector/Unboxing.hs b/src/Graphics/Image/Interface/Vector/Unboxing.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface/Vector/Unboxing.hs @@ -0,0 +1,123 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +-- | +-- Module : Graphics.Image.Interface.Vector.Unboxing +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.Interface.Vector.Unboxing where + +import Data.Word +import Graphics.Image.Interface +import Graphics.Image.ColorSpace.Binary (Bit(..)) +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed as U +import Control.Monad + +-- | Unboxing of a `Bit`. +instance U.Unbox Bit + +newtype instance U.MVector s Bit = MV_Bit (U.MVector s Word8) + +instance M.MVector U.MVector Bit where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeMove #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Bit mvec) = M.basicLength mvec + basicUnsafeSlice idx len (MV_Bit mvec) = MV_Bit (M.basicUnsafeSlice idx len mvec) + basicOverlaps (MV_Bit mvec) (MV_Bit mvec') = M.basicOverlaps mvec mvec' + basicUnsafeNew len = MV_Bit `liftM` M.basicUnsafeNew len + basicUnsafeReplicate len (Bit w) = MV_Bit `liftM` M.basicUnsafeReplicate len w + basicUnsafeRead (MV_Bit mvec) idx = Bit `liftM` M.basicUnsafeRead mvec idx + basicUnsafeWrite (MV_Bit mvec) idx (Bit w) = M.basicUnsafeWrite mvec idx w + basicClear (MV_Bit mvec) = M.basicClear mvec + basicSet (MV_Bit mvec) (Bit w) = M.basicSet mvec w + basicUnsafeCopy (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeCopy mvec mvec' + basicUnsafeMove (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeMove mvec mvec' + basicUnsafeGrow (MV_Bit mvec) len = MV_Bit `liftM` M.basicUnsafeGrow mvec len + + +newtype instance U.Vector Bit = V_Bit (U.Vector Word8) + +instance V.Vector U.Vector Bit where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Bit mvec) = V_Bit `liftM` V.basicUnsafeFreeze mvec + basicUnsafeThaw (V_Bit vec) = MV_Bit `liftM` V.basicUnsafeThaw vec + basicLength (V_Bit vec) = V.basicLength vec + basicUnsafeSlice idx len (V_Bit vec) = V_Bit (V.basicUnsafeSlice idx len vec) + basicUnsafeIndexM (V_Bit vec) idx = Bit `liftM` V.basicUnsafeIndexM vec idx + basicUnsafeCopy (MV_Bit mvec) (V_Bit vec) = V.basicUnsafeCopy mvec vec + elemseq (V_Bit vec) (Bit w) = V.elemseq vec w + + + + +-- | Unboxing of a `Pixel`. +instance (ColorSpace cs, U.Unbox (PixelElt cs e)) => U.Unbox (Pixel cs e) + +newtype instance U.MVector s (Pixel cs e) = MV_Pixel (U.MVector s (PixelElt cs e)) + +instance (ColorSpace cs_aOSR, U.Unbox (PixelElt cs_aOSR e)) + => M.MVector U.MVector (Pixel cs_aOSR e) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeMove #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Pixel mvec) = M.basicLength mvec + basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (M.basicUnsafeSlice idx len mvec) + basicOverlaps (MV_Pixel mvec) (MV_Pixel mvec') = M.basicOverlaps mvec mvec' + basicUnsafeNew len = MV_Pixel `liftM` M.basicUnsafeNew len + basicUnsafeReplicate len val = MV_Pixel `liftM` M.basicUnsafeReplicate len (toElt val) + basicUnsafeRead (MV_Pixel mvec) idx = fromElt `liftM` M.basicUnsafeRead mvec idx + basicUnsafeWrite (MV_Pixel mvec) idx val = M.basicUnsafeWrite mvec idx (toElt val) + basicClear (MV_Pixel mvec) = M.basicClear mvec + basicSet (MV_Pixel mvec) val = M.basicSet mvec (toElt val) + basicUnsafeCopy (MV_Pixel mvec) (MV_Pixel mvec') = M.basicUnsafeCopy mvec mvec' + basicUnsafeMove (MV_Pixel mvec) (MV_Pixel mvec') = M.basicUnsafeMove mvec mvec' + basicUnsafeGrow (MV_Pixel mvec) len = MV_Pixel `liftM` M.basicUnsafeGrow mvec len + + +newtype instance U.Vector (Pixel cs_aOSR e) = V_Pixel (U.Vector (PixelElt cs_aOSR e)) + +instance (ColorSpace cs, U.Unbox (PixelElt cs e)) => V.Vector U.Vector (Pixel cs e) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Pixel mvec) = V_Pixel `liftM` V.basicUnsafeFreeze mvec + basicUnsafeThaw (V_Pixel vec) = MV_Pixel `liftM` V.basicUnsafeThaw vec + basicLength (V_Pixel vec) = V.basicLength vec + basicUnsafeSlice idx len (V_Pixel vec) = V_Pixel (V.basicUnsafeSlice idx len vec) + basicUnsafeIndexM (V_Pixel vec) idx = fromElt `liftM` V.basicUnsafeIndexM vec idx + basicUnsafeCopy (MV_Pixel mvec) (V_Pixel vec) = V.basicUnsafeCopy mvec vec + elemseq (V_Pixel vec) val = V.elemseq vec (toElt val) diff --git a/src/Graphics/Image/Processing.hs b/src/Graphics/Image/Processing.hs --- a/src/Graphics/Image/Processing.hs +++ b/src/Graphics/Image/Processing.hs @@ -1,4 +1,12 @@ -{-# LANGUAGE BangPatterns, ViewPatterns #-} +{-# LANGUAGE CPP, BangPatterns, ViewPatterns #-} +-- | +-- Module : Graphics.Image.Processing +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing ( -- * Geometric module Graphics.Image.Processing.Geometric, @@ -10,6 +18,9 @@ Border(..), pixelGrid ) where +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (traverse) +#endif import Data.Word (Word8) import Graphics.Image.Interface import Graphics.Image.Processing.Convolution diff --git a/src/Graphics/Image/Processing/Binary.hs b/src/Graphics/Image/Processing/Binary.hs --- a/src/Graphics/Image/Processing/Binary.hs +++ b/src/Graphics/Image/Processing/Binary.hs @@ -1,5 +1,13 @@ {-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses #-} +-- | +-- Module : Graphics.Image.Processing.Binary +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing.Binary ( -- * Construction toImageBinaryUsing, toImageBinaryUsing2, diff --git a/src/Graphics/Image/Processing/Complex.hs b/src/Graphics/Image/Processing/Complex.hs --- a/src/Graphics/Image/Processing/Complex.hs +++ b/src/Graphics/Image/Processing/Complex.hs @@ -1,4 +1,12 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleContexts #-} +-- | +-- Module : Graphics.Image.Processing.Complex +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing.Complex ( -- * Rectangular form (!+!), realPart', imagPart', @@ -13,7 +21,6 @@ ) where import Prelude hiding (map, zipWith) ---import qualified Data.Complex as C import Graphics.Image.Interface import Graphics.Image.ColorSpace.Complex import Graphics.Image.Processing.Complex.Fourier @@ -21,9 +28,13 @@ infix 6 !+! --- | Constrcut a complex image from two images containing real and imaginary parts. +-- | Constrcut a complex image from two images representing real and imaginary parts. -- --- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @ +-- >>> frog <- readImageRGB "images/frog.jpg" +-- >>> frog !+! 0 +-- +-- >>> frog !+! frog +-- -- (!+!) :: (Array arr cs e, Array arr cs (Complex e)) => Image arr cs e -> Image arr cs e -> Image arr cs (Complex e) @@ -90,7 +101,7 @@ -- of @2@, i.e. @m == 2^k@, where @k@ is some integer. -> ((Int, Int) -> Pixel cs e) -> Image arr cs e makeFilter !(m, n) !getPx - | isPowerOfTwo m && isPowerOfTwo n = make (m, n) getPx' + | isPowerOfTwo m && isPowerOfTwo n = makeImage (m, n) getPx' | otherwise = error " " where getPx' (i, j) = getPx (if i < (m `div` 2) then i else i - m, if j < (n `div` 2) then j else j - n) @@ -103,7 +114,7 @@ Image arr cs e -- ^ Source image. -> Image arr cs e -- ^ Filter. -> Image arr cs e -applyFilter img filt = realPart' . ifft $ ((fft (img !+! 0)) * (filt !+! filt)) +applyFilter img filt = realPart' . ifft $ (fft (img !+! 0) * (filt !+! filt)) {-# INLINE applyFilter #-} {- diff --git a/src/Graphics/Image/Processing/Complex/Fourier.hs b/src/Graphics/Image/Processing/Complex/Fourier.hs --- a/src/Graphics/Image/Processing/Complex/Fourier.hs +++ b/src/Graphics/Image/Processing/Complex/Fourier.hs @@ -1,9 +1,21 @@ -{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts #-} +{-# LANGUAGE CPP, BangPatterns, ConstraintKinds, FlexibleContexts #-} +-- | +-- Module : Graphics.Image.Processing.Complex.Fourier +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing.Complex.Fourier ( fft, ifft, isPowerOfTwo ) where +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (map, traverse) +#else import Prelude hiding (map) +#endif import Data.Bits ((.&.)) import Graphics.Image.Interface import Graphics.Image.ColorSpace.Complex @@ -68,7 +80,7 @@ fftGeneral !sign !img = transpose $ go n 0 1 where !(m, n) = dims img go !len !offset !stride - | len == 2 = make (m, 2) swivel + | len == 2 = makeImage (m, 2) swivel | otherwise = combine len (go (len `div` 2) offset (stride * 2)) (go (len `div` 2) (offset + stride) (stride * 2)) @@ -86,9 +98,10 @@ -- Compute a twiddle factor. twiddle :: (ColorSpace cs, Floating e) => Pixel cs e - -> Int -- index - -> Int -- length - -> Pixel cs (Complex e) + -> Int -- index + -> Int -- length + -> Pixel cs (Complex e) twiddle sign k n = cos alpha +: sign * sin alpha where !alpha = 2 * pi * fromIntegral k / fromIntegral n {-# INLINE twiddle #-} + diff --git a/src/Graphics/Image/Processing/Convolution.hs b/src/Graphics/Image/Processing/Convolution.hs --- a/src/Graphics/Image/Processing/Convolution.hs +++ b/src/Graphics/Image/Processing/Convolution.hs @@ -1,7 +1,14 @@ {-# LANGUAGE BangPatterns #-} +-- | +-- Module : Graphics.Image.Processing.Convolution +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing.Convolution ( convolve, convolveRows, convolveCols, - --convolve', convolveRows', convolveCols', ) where import Prelude hiding (map) @@ -44,30 +51,6 @@ convolve !out = convolve'' out . rotate180 {-# INLINE convolve #-} -{- --- | Strict version of convolution that operates on manifest array representations. -convolve' :: ManifestArray arr cs e => - Border (Pixel cs e) -- ^ Approach to be used near the borders. - -> Image arr cs e -- ^ Kernel image. - -> Image arr cs e -- ^ Source image. - -> Image arr cs e -convolve' !out = convolve'' out . rotate180 -{-# INLINE convolve' #-} --} -{- --- | Convolve image's rows with a vector kernel represented by a list of pixels. -convolveRows :: Array arr cs e => - Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e -convolveRows !out = convolve out . fromLists . (:[]) . reverse -{-# INLINE convolveRows #-} - - --- | Convolve image's columns with a vector kernel represented by a list of pixels. -convolveCols :: Array arr cs e => - Border (Pixel cs e) -> [Pixel cs e] -> Image arr cs e -> Image arr cs e -convolveCols !out = convolve out . fromLists . P.map (:[]) . reverse -{-# INLINE convolveCols #-} --} -- | Convolve image's rows with a vector kernel represented by a list of pixels. convolveRows :: ManifestArray arr cs e => diff --git a/src/Graphics/Image/Processing/Geometric.hs b/src/Graphics/Image/Processing/Geometric.hs --- a/src/Graphics/Image/Processing/Geometric.hs +++ b/src/Graphics/Image/Processing/Geometric.hs @@ -1,4 +1,12 @@ -{-# LANGUAGE BangPatterns, ViewPatterns #-} +{-# LANGUAGE CPP, BangPatterns, ViewPatterns #-} +-- | +-- Module : Graphics.Image.Processing.Geometric +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing.Geometric ( -- ** Sampling downsampleRows, downsampleCols, downsample, @@ -14,6 +22,10 @@ -- ** Scaling resize, scale ) where + +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (traverse) +#endif import Graphics.Image.Interface import Graphics.Image.Processing.Interpolation diff --git a/src/Graphics/Image/Processing/Interpolation.hs b/src/Graphics/Image/Processing/Interpolation.hs --- a/src/Graphics/Image/Processing/Interpolation.hs +++ b/src/Graphics/Image/Processing/Interpolation.hs @@ -1,38 +1,52 @@ {-# LANGUAGE BangPatterns, ViewPatterns #-} +-- | +-- Module : Graphics.Image.Processing.Interpolation +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- module Graphics.Image.Processing.Interpolation ( Interpolation(..), Nearest(..), Bilinear(..) ) where import Graphics.Image.Interface - +-- | Implementation for an interpolation method. class Interpolation method where + + -- | Construct a new pixel by using information from neighboring pixels. interpolate :: (Elevator e, Num e, ColorSpace cs) => method (Pixel cs e) -- ^ Interpolation method -> (Int, Int) -- ^ Image dimensions @m@ rows and @n@ columns. -> ((Int, Int) -> Pixel cs e) -- ^ Lookup function that returns a pixel at @i@th and @j@th -- location. - -> (Double, Double) -- ^ real values of @i@ and @j@ index + -> (Double, Double) -- ^ Real values of @i@ and @j@ index -> Pixel cs e -- | Nearest Neighbor interpolation method. -data Nearest px = Nearest +data Nearest px = Nearest !(Border px) -- | Bilinear interpolation method. -data Bilinear px = Bilinear (Border px) +data Bilinear px = Bilinear !(Border px) instance Interpolation Nearest where - interpolate _ !(m, n) !getPx !(round -> i, round -> j) = - if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else 0 + interpolate (Nearest border) !sz !getPx !(round -> i, round -> j) = + borderIndex border sz getPx (i, j) + {-# INLINE interpolate #-} + instance Interpolation Bilinear where + interpolate (Bilinear border) !sz !getPx !(i, j) = fi0 + jPx*(fi1-fi0) where getPx' = borderIndex border sz getPx + {-# INLINE getPx' #-} !(i0, j0) = (floor i, floor j) !(i1, j1) = (i0 + 1, j0 + 1) !iPx = fromDouble $ fromChannel (i - fromIntegral i0) diff --git a/src/Graphics/Image/Types.hs b/src/Graphics/Image/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Types.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Graphics.Image.Types +-- Copyright : (c) Alexey Kuleshevich 2016 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.Types ( + module Graphics.Image.ColorSpace, + Array, Image, ManifestArray, SequentialArray, MutableArray, MImage, + Exchangable, Border(..), + VU(..), RD(..), RS(..), RP(..), + ) where + + +import Graphics.Image.ColorSpace +import Graphics.Image.Interface +import Graphics.Image.Interface.Vector (VU(..)) +import Graphics.Image.Interface.Repa (RD(..), RS(..), RP(..))