hip 1.3.0.0 → 1.4.0.0

raw patch · 49 files changed

+4939/−2358 lines, 49 filesdep ~repadep ~vectorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: repa, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• README.md +3/−3
• benchmarks/Canny.hs +161/−0
• benchmarks/Interface.hs +0/−75
• hip.cabal +52/−6
• images/figure_close.png binary
• images/figure_dialate.png binary
• images/figure_erode.png binary
• images/figure_open.png binary
• images/struct.png binary
• src/Graphics/Image.hs +75/−47
• src/Graphics/Image/ColorSpace.hs +169/−138
• src/Graphics/Image/ColorSpace/Binary.hs +93/−38
• src/Graphics/Image/ColorSpace/CMYK.hs +273/−97
• src/Graphics/Image/ColorSpace/Complex.hs +12/−10
• src/Graphics/Image/ColorSpace/Gray.hs +143/−59
• src/Graphics/Image/ColorSpace/HSI.hs +273/−104
• src/Graphics/Image/ColorSpace/Luma.hs +251/−92
• src/Graphics/Image/ColorSpace/RGB.hs +431/−89
• src/Graphics/Image/ColorSpace/YCbCr.hs +272/−96
• src/Graphics/Image/IO.hs +11/−11
• src/Graphics/Image/IO/Formats/JuicyPixels.hs +375/−400
• src/Graphics/Image/IO/Formats/Netpbm.hs +36/−34
• src/Graphics/Image/IO/Histogram.hs +79/−10
• src/Graphics/Image/Interface.hs +129/−147
• src/Graphics/Image/Interface/Repa.hs +59/−38
• src/Graphics/Image/Interface/Repa/Generic.hs +494/−0
• src/Graphics/Image/Interface/Repa/Helpers.hs +39/−0
• src/Graphics/Image/Interface/Repa/Internal.hs +0/−490
• src/Graphics/Image/Interface/Repa/Storable.hs +275/−0
• src/Graphics/Image/Interface/Repa/Unboxed.hs +243/−0
• src/Graphics/Image/Interface/Vector.hs +17/−48
• src/Graphics/Image/Interface/Vector/Generic.hs +292/−0
• src/Graphics/Image/Interface/Vector/Storable.hs +196/−0
• src/Graphics/Image/Interface/Vector/Unboxed.hs +68/−154
• src/Graphics/Image/Interface/Vector/Unboxing.hs +11/−11
• src/Graphics/Image/Processing.hs +2/−2
• src/Graphics/Image/Processing/Binary.hs +9/−5
• src/Graphics/Image/Processing/Complex.hs +32/−50
• src/Graphics/Image/Processing/Complex/Fourier.hs +14/−5
• src/Graphics/Image/Processing/Convolution.hs +37/−11
• src/Graphics/Image/Processing/Geometric.hs +6/−6
• src/Graphics/Image/Processing/Interpolation.hs +6/−5
• src/Graphics/Image/Types.hs +70/−4
• tests/Graphics/Image/ColorSpaceSpec.hs +4/−4
• tests/Graphics/Image/Interface/VectorSpec.hs +5/−6
• tests/Graphics/Image/InterfaceSpec.hs +71/−63
• tests/Graphics/Image/Processing/BinarySpec.hs +132/−0
• tests/Graphics/Image/ProcessingSpec.hs +1/−0

@@ -1,3 +1,21 @@+1.4.0.0+=======++Major rewrite, with most of functionality is still backwards compatible, but+with a some extra features.++* Storable Repa and Vector representations through generic implementations+* `ColorSpace` is more general allowing for non polymorphic Pixel types+* `Elevator` works on base types rather than on pixels+* Conversions from JuicyPixels and NetPbm is done through casting a Vector+  rather than through an explicit conversion.++Major API changes:++  * Renaming `RS` and `RP` Repa representations into `RSU` and `RPU`.+  * Addition `VS` Storable Vector representationas well as `RSS` and `RPS`+    Storable Repa representations.+     1.3.0.0 ======= 

@@ -19,7 +19,7 @@  * `$ stack install hip` -In order to be able to view images in GHCi and external image viewer is used. On-Linux I recommend `GPicView`, but you can use any viewer that accepts a filename-as an argument, so by default OS specific image viewer is used.+In order to be able to view images in GHCi an external image viewer is used. You+can use any viewer that accepts a filename as an argument, and by default, image+viewer specified by the OS is used. 

@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+module Main where++import Prelude as P+import Criterion.Main+import Graphics.Image as I+import Graphics.Image.Interface as I+import Graphics.Image.Interface.Repa+++import Data.Array.Repa as R+import Data.Array.Repa.Eval+import Data.Array.Repa.Repr.Unboxed+import Data.Array.Repa.Stencil+import Data.Array.Repa.Stencil.Dim2+++sobelGx :: I.Array arr cs e => Image arr cs e -> Image arr cs e+sobelGx =+  convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]])++sobelGy :: I.Array arr cs e => Image arr cs e -> Image arr cs e+sobelGy =+  convolve Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]])++-- sobelSGx :: (Exchangable arr VS, I.Array arr cs e, I.Array VS cs e) => Image arr cs e -> Image arr cs e+-- sobelSGx =+--   convolveSparse Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]])++-- sobelSGy :: (Exchangable arr VS, I.Array arr cs e, I.Array VS cs e) => Image arr cs e -> Image arr cs e+-- sobelSGy =+--   convolveSparse Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]])+++-- sobelSGx' :: (Exchangable arr VS, I.Array arr cs e, I.Array VS cs e) => Image arr cs e -> Image arr cs e+-- sobelSGx' =+--   convolveSparse Edge (fromLists [[1], [2], [1]]) . convolveSparse Edge (fromLists [[1, 0, -1]])++sobelGx' :: I.Array arr cs e => Image arr cs e -> Image arr cs e+sobelGx' =+  convolveCols Edge [1, 2, 1] . convolveRows Edge [1, 0, -1]++sobelGy' :: I.Array arr cs e => Image arr cs e -> Image arr cs e+sobelGy' =+  convolveCols Edge [1, 0, -1] . convolveRows Edge [1, 2, 1]+++sobelGxR+  :: (Source r e, Num e) => R.Array r DIM2 e+     -> R.Array PC5 DIM2 e+sobelGxR = mapStencil2 BoundClamp stencil +  where stencil = makeStencil2 3 3+                  (\ix -> case ix of+                      Z :. -1 :. -1  -> Just (-1)+                      Z :.  0 :. -1  -> Just (-2)+                      Z :.  1 :. -1  -> Just (-1)+                      Z :. -1 :.  1  -> Just 1+                      Z :.  0 :.  1  -> Just 2+                      Z :.  1 :.  1  -> Just 1+                      _              -> Nothing)++sobelGyR+  :: (Source r e, Num e) => R.Array r DIM2 e+     -> R.Array PC5 DIM2 e+sobelGyR = mapStencil2 BoundClamp stencil +  where stencil = makeStencil2 3 3+                  (\ix -> case ix of+                      Z :.  1 :. -1  -> Just (-1)+                      Z :.  1 :.  0  -> Just (-2)+                      Z :.  1 :.  1  -> Just (-1)+                      Z :. -1 :. -1  -> Just 1+                      Z :. -1 :.  0  -> Just 2+                      Z :. -1 :.  1  -> Just 1+                      _              -> Nothing)++force+  :: (Load r1 sh e, Unbox e, Monad m)+  => R.Array r1 sh e -> m (R.Array U sh e)+force arr = do+    forcedArr <- computeUnboxedP arr+    forcedArr `deepSeqArray` return forcedArr++++main :: IO ()+main = do+  img' <- readImageRGB RPU "images/downloaded/frog-1280x824.jpg"+  let !imgU = compute img'+  --let !imgS = exchange RPS imgU+  let sobelU = sobelGx imgU+  let sobelSepU = sobelGx' imgU+  -- let sobelS = sobelGx imgS+  -- let sobelSepS = sobelGx' imgS+  -- let sobelSepVS = sobelSGx' img+  -- let sobelVS = sobelSGx img+  -- let sobelMS = sobelMSGx img+  -- let sobelIMS = sobelIMSGx img+  -- let sobelHMS = sobelHMSGx img+  let !imgR = toRepaArray imgU+  --imgRDouble <- force $ R.map (`getPxCh` Y) imgR+  let sobelR = sobelGxR imgR+  --let sobelRDouble = sobelGxR imgRDouble+  defaultMain+    [ bgroup+        "Sobel"+        [ bench "naive U" $ whnf compute sobelU+        , bench "separated U" $ whnf compute sobelSepU+        -- , bench "naive S" $ whnf compute sobelS+        -- , bench "separated S" $ whnf compute sobelSepS+        -- , bench "separated VS" $ whnf compute sobelSepVS+        -- , bench "sparse VS" $ whnf compute sobelVS+        -- , bench "sparse MS" $ whnf compute sobelMS+        -- , bench "sparse IMS" $ whnf compute sobelIMS+        -- , bench "sparse HMS" $ whnf compute sobelHMS+        --, bench "repa" $ whnf (compute . fromRepaArrayP) sobelR+        , bench "repa RGB" $ whnfIO (force sobelR)+        --, bench "repa Double" $ whnfIO (force sobelRDouble)+        ]+    ]+  -- img' <- readImageY RS "images/downloaded/frog-1280x824.jpg"+  -- let !imgR = compute img'+  -- let !imgV = toManifest imgR+  -- -- let sobel = sobelGx imgV+  -- -- let sobel' = sobelGx' imgV+  -- -- let sobel'' = sobelSGx imgV+  -- let arrR = toRepaArray imgR+  -- let sobelR = sobelGxR arrR+  -- defaultMain+  --   [ bgroup+  --       "Sobel"+  --       [ bench "naive" $ nf sobelGx imgV+  --       , bench "separated" $ nf sobelGx' imgV+  --       , bench "sparse" $ nf sobelSGx imgV+  --       --, bench "repa" $ whnf (compute . fromRepaArrayP) sobelR+  --       , bench "repa" $ whnfIO (force sobelR)+  --       ]+  --   ]++  -- let sobel = sqrt (sobelGx img ^ (2 :: Int) + sobelGy img ^ (2 :: Int))+  -- let sobel' = sqrt (sobelGx' img ^ (2 :: Int) + sobelGy' img ^ (2 :: Int))+  -- let sobel'' = sqrt (sobelSGx img ^ (2 :: Int) + sobelSGy img ^ (2 :: Int))+  -- let sobel''' = sqrt (sobelMSGx img ^ (2 :: Int) + sobelMSGy img ^ (2 :: Int))+  -- let imgR = toRepaArray img+  -- let sobelR =+  --       R.map+  --         sqrt+  --         (R.map (^ (2 :: Int)) (sobelGxR imgR) +^+  --          R.map (^ (2 :: Int)) (sobelGyR imgR))+  -- defaultMain+  --   [ bgroup+  --       "Sobel"+  --       [ bench "naive" $ whnf compute sobel+  --       , bench "separated" $ whnf compute sobel'+  --       , bench "sparse VS" $ whnf compute sobel''+  --       , bench "sparse MS" $ whnf compute sobel'''+  --       --, bench "repa" $ whnf (compute . fromRepaArrayP) sobelR+  --       , bench "repa" $ whnfIO (force sobelR)+  --       ]+  --   ]+

@@ -1,75 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Main where--import Prelude as P-import Criterion.Main-import Graphics.Image.Interface as I---import Graphics.Image.Processing----import qualified Graphics.Image.Interface.Vector as V-import Graphics.Image.Types--main :: IO ()-main = do-  defaultMain-    [ bgroup-        "RP fusion"-        [ bench "native" $-          whnf-            (compute  . (noFusion :: (Int, Int) -> Image RP Y Double))-            (1000, 1000)-        , bench "RP fusion" $-          whnf-            (compute  . (fusion :: (Int, Int) -> Image RP Y Double))-            (1000, 1000)-        ]-    , bgroup-        "RS fusion"-        [ bench "native" $-          whnf-            (compute . (noFusion :: (Int, Int) -> Image RS Y Double))-            (1000, 1000)-        , bench "RS fusion" $-          whnf-            (compute . (fusion :: (Int, Int) -> Image RS Y Double))-            (1000, 1000)-        ]-    , bgroup-        "VU fusion"-        [ bench "no fusion" $-          nf (noFusion :: (Int, Int) -> Image VU Y Double) (1000, 1000)-        , bench "VU fusion" $-          nf (fusion :: (Int, Int) -> Image VU Y Double) (1000, 1000)-        ]-    ]---frog <- V.readImageY "images/frog.jpg"---     [ bgroup---         ("makeImage big " ++ show bigDims)---         [ bench "makeImage VU" $ nf (`V.makeImage` getPxY) bigDims---         , bench "computeS" $ nf R.computeS (R.makeImage bigDims getPxY)---           -- parallel---         , bench "computeP" $ nf R.computeP (R.makeImage bigDims getPxY)---         ]---     , bgroup---         "Sobel operator"---         [ bench "sobel VU" $ nf sobel frog---         , bench "sobel RS" $ nf (sobel . exchange RS) frog---           -- parallel---         , bench "sobel RP" $ nf (sobel . R.computeP . exchange RP) frog---         ]---     ]-    where---     bigDims = (2000, 2000)-      getPxY :: (Int, Int) -> Pixel Y Double-      getPxY (i, j) = fromIntegral (i * j)-      noFusion ds = makeImage ds getPx-        where getPx :: (Int, Int) -> Pixel Y Double-              getPx (i, j) = (getPxY (i, j) / 5 - fromIntegral i) * 21-      fusion ds = imap (\ (i, _) px -> (px - fromIntegral i) * 21) $ (makeImage ds getPxY / 5)----- sobel :: ManifestArray arr cs Double => Image arr cs Double -> Image arr cs Double--- sobel img = sqrt (imgX ^ (2 :: Int) + imgY ^ (2 :: Int))---   where---     imgX = convolve Edge (fromLists [[-1, 0, 1], [-2, 0, 2], [-1, 0, 1]]) img---     imgY = convolve Edge (fromLists [[-1,-2,-1], [ 0, 0, 0], [ 1, 2, 1]]) img

@@ -1,5 +1,5 @@ Name:              hip-Version:           1.3.0.0+Version:           1.4.0.0 License:           BSD3 License-File:      LICENSE Author:            Alexey Kuleshevich@@ -76,7 +76,12 @@                  , Graphics.Image.IO.Base                  , Graphics.Image.IO.Formats.JuicyPixels                  , Graphics.Image.IO.Formats.Netpbm-                 , Graphics.Image.Interface.Repa.Internal+                 , Graphics.Image.Interface.Repa.Generic+                 , Graphics.Image.Interface.Repa.Storable+                 , Graphics.Image.Interface.Repa.Unboxed+                 , Graphics.Image.Interface.Repa.Helpers+                 , Graphics.Image.Interface.Vector.Generic+                 , Graphics.Image.Interface.Vector.Storable                  , Graphics.Image.Interface.Vector.Unboxed                  , Graphics.Image.Interface.Vector.Unboxing                  , Graphics.Image.Processing.Convolution@@ -99,6 +104,7 @@   Main-Is:            Spec.hs   Other-Modules:      Graphics.Image.ColorSpaceSpec                     , Graphics.Image.ProcessingSpec+                    , Graphics.Image.Processing.BinarySpec                     , Graphics.Image.InterfaceSpec                     , Graphics.Image.Interface.VectorSpec   Build-Depends:      base            >= 4.5 && < 5@@ -109,16 +115,56 @@   GHC-Options:        -Wall -threaded -with-rtsopts=-N  -benchmark interface-benchmarks+-- benchmark pixels-benchmarks+--   type:                exitcode-stdio-1.0+--   hs-source-dirs:      benchmarks+--   main-is:             Pixels.hs+--   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2+--   build-depends:       base+--                      , criterion+--                      , deepseq+--                      , hip+--                      , vector+--   default-language:    Haskell2010++-- benchmark pixels-memory+--   type:                exitcode-stdio-1.0+--   hs-source-dirs:      benchmarks/memory+--   main-is:             Pixels.hs+--   ghc-options:         -O2+--                        -- -threaded -rtsopts -with-rtsopts=-N+--   build-depends:       base+--                      , criterion+--                      , deepseq+--                      , hip+--                      , weigh+--                      , vector+--                      , repa+--   default-language:    Haskell2010++-- benchmark interface-benchmarks+--   type:                exitcode-stdio-1.0+--   hs-source-dirs:      benchmarks+--   main-is:             Interface.hs+--   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2+--   build-depends:       base+--                      , criterion+--                      , deepseq+--                      , hip+--                      , vector+--   default-language:    Haskell2010++benchmark convolution-benchmarks   type:                exitcode-stdio-1.0   hs-source-dirs:      benchmarks-  main-is:             Interface.hs-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  main-is:             Canny.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2+  --ghc-options:         -Odph -rtsopts -with-rtsopts=-N -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -fllvm -optlo-O3   build-depends:       base                      , criterion                      , deepseq+                     , repa                      , hip-                     , vector   default-language:    Haskell2010  Source-Repository head

binary file changed (384 → 382 bytes)

binary file changed (390 → 395 bytes)

binary file changed (411 → 414 bytes)

binary file changed (404 → 409 bytes)

binary file changed (94 → 102 bytes)

@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module      : Graphics.Image@@ -18,11 +17,11 @@ -- * @__`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.+-- type denoting precision of an image (@Int@, @Word@, @Double@, etc.) . -- -- * @__`MArray` arr cs e__@ - is a kind of array, that can be indexed in--- constant time and allows monadic operations and mutation on __@`MImage`@ @st@--- @arr@ @cs@ @e@__, which is `Image`'s mutable cousin.+-- constant time and allows monadic operations and mutation on+-- __@`MImage`@ @st@ @arr@ @cs@ @e@__, which is `Image`'s mutable cousin. -- -- Array representation type and the above classes it is installed in determine -- operations that can be done on the image with that representation.@@ -30,27 +29,25 @@ -- Representations using <http://hackage.haskell.org/package/vector Vector> and -- <http://hackage.haskell.org/package/repa Repa> packages: ----- * `VU` - Unboxed Vector representation. (Default)--- * `RS` - Unboxed Repa array representation (computation is done sequentially).--- * `RP` - Unboxed Repa array representation (computation is done in parallel).+-- * `VU` - Vector Unboxed representation.+-- * `VS` - Vector Storable representation.+-- * `RSU` - Repa Sequential Unboxed array representation (computation is done sequentially).+-- * `RPU` - Repa Parallel Unboxed array representation (computation is done in parallel).+-- * `RSS` - Repa Sequential Storable array representation (computation is done sequentially).+-- * `RPS` - Repa Parallel Storable array representation (computation is done in parallel). ----- Images with `RS` and `RP` types, most of the time hold functions rather then+-- Images with `RSU` and `RPU` types, most of the time hold functions rather then -- actual data, this way computation can be fused together, and later changed to -- `VU` using `toManifest`, which in turn performs the fused computation. If at -- any time computation needs to be forced, `compute` can be used for that -- purpose. ----- 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 should be used.--- -- 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:+-- from "Prelude", hence it can be more convenient to import like this: -- -- @--- import qualified Graphics.Image as I--- import Graphics.Image.Types+-- import Prelude as P+-- import Graphics.Image as I -- @ -- module Graphics.Image (@@ -59,14 +56,17 @@    -- * Creation   ---  -- If it is necessary to create an image in an other representation-  -- or with some specific 'Pixel' precision, you can use 'make' from-  -- "Graphics.Image.Interface" module and manually specifying function's output-  -- type, ex:+  -- `makeImageR` is a type restricted version of `makeImage` function, which+  -- simplifies creation of images with `Double` precision and a particular+  -- representation through an extra argument.   ---  -- @ makeImage (256, 256) (PixelY . fromIntegral . fst) :: Image RP Y Word8 @+  -- If it is necessary to create an image with an arbitrary precision and+  -- representation, `makeImage` function can be used with a manual type+  -- specification of result image, eg:   ---  makeImage, makeImageS, makeImageP, fromLists, fromListsS, fromListsP, toLists,+  -- @ makeImage (256, 256) (PixelY . fromIntegral . fst) :: Image RPU Y Word8 @+  --+  makeImageR, makeImage, fromListsR, fromLists, toLists,   -- * IO   -- ** Reading   -- | Read supported files into an 'Image' with pixels in 'Double'@@ -74,15 +74,15 @@   -- space or precision, use 'readImage' or 'readImageExact' from   -- <Graphics-Image-IO.html Graphics.Image.IO> instead. While reading an   -- image, it's underlying representation can be specified by passing one of-  -- `VU`, `RS` or `RP` as the first argument to @readImage*@ functions. Here is+  -- `VU`, `RSU` or `RPU` as the first argument to @readImage*@ functions. Here is   -- a quick demonstration of how two images can be read as different   -- representations and later easily combined as their average.   ---  -- >>> cluster <- readImageRGB RP "images/cluster.jpg"+  -- >>> cluster <- readImageRGB RPU "images/cluster.jpg"   -- >>> displayImage cluster   -- >>> centaurus <- readImageRGB VU "images/centaurus.jpg"   -- >>> displayImage centaurus-  -- >>> displayImage ((cluster + exchange RP centaurus) / 2)+  -- >>> displayImage ((cluster + exchange RPU centaurus) / 2)   --   -- <<images/cluster.jpg>> <<images/centaurus.jpg>> <<images/centaurus_and_cluster.jpg>>   --@@ -96,38 +96,60 @@   index, maybeIndex, defaultIndex, borderIndex,   -- * Transformation   -- ** Pointwise-  map, imap, zipWith, izipWith,+  I.map, imap, I.zipWith, izipWith,   -- ** Geometric-  traverse, traverse2,+  I.traverse, traverse2,   transpose, backpermute,   (|*|),    -- * Reduction   fold, sum, product, maximum, minimum, normalize,   -- * Representations   exchange,-  VU(..), RS(..), RP(..),+  module IP   ) 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)-import Control.Applicative (pure)-#endif+import Prelude as P hiding (maximum, minimum, sum, product) import qualified Data.Foldable as F import Graphics.Image.ColorSpace import Graphics.Image.IO-import Graphics.Image.Interface as I hiding (makeImage, fromLists)-import Graphics.Image.Interface.Vector-import Graphics.Image.Interface.Repa+import Graphics.Image.Interface as I+import Graphics.Image.Types as IP +import Graphics.Image.Processing as IP+import Graphics.Image.Processing.Binary as IP+import Graphics.Image.Processing.Complex as IP+import Graphics.Image.Processing.Geometric as IP+import Graphics.Image.IO.Histogram as IP -import Graphics.Image.Processing-import Graphics.Image.Processing.Binary-import Graphics.Image.Processing.Complex-import Graphics.Image.Processing.Geometric-import Graphics.Image.IO.Histogram +-- | Create an image with a specified representation and pixels of 'Double'+-- precision. Note, that it is essential for 'Double' precision pixels to keep values+-- normalized in the @[0, 1]@ range in order for an image to be written to file+-- properly.+--+-- >>> let grad_gray = makeImageR VU (200, 200) (\(i, j) -> PixelY (fromIntegral i) / 200 * (fromIntegral j) / 200)+--+-- Because all 'Pixel's and 'Image's are installed into 'Num', above is equivalent to:+--+-- >>> let grad_gray = makeImageR RPU (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200)+-- >>> writeImage "images/grad_gray.png" grad_gray+--+-- Creating color images is just as easy.+--+-- >>> let grad_color = makeImageR VU (200, 200) (\(i, j) -> PixelRGB (fromIntegral i) (fromIntegral j) (fromIntegral (i + j))) / 400+-- >>> writeImage "images/grad_color.png" grad_color+--+-- <<images/grad_gray.png>> <<images/grad_color.png>>+--+makeImageR :: Array arr cs Double =>+              arr -- ^ Underlying image representation.+           -> (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.+           -> ((Int, Int) -> Pixel cs Double)+           -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument+           -- and returns a pixel for that location.+           -> Image arr cs Double+makeImageR _ = I.makeImage+{-# INLINE makeImageR #-}  -- | Read image as luma (brightness). readImageY :: Array arr Y Double => arr -> FilePath -> IO (Image arr Y Double)@@ -204,18 +226,24 @@   -- | Scales all of the pixels to be in the range @[0, 1]@.-normalize :: (Array arr cs e, Array arr Gray e, Fractional e, Ord e) =>+normalize :: (Array arr cs e, Array arr Gray e, Fractional e,+              Fractional (Pixel cs e), Ord e) =>              Image arr cs e -> Image arr cs e normalize !img = if l == s                  then (if s < 0 then (*0) else if s > 1 then (*1) else id) img-                 else map normalizer img+                 else I.map normalizer img   where-    !(PixelGray l, PixelGray s) = (maximum $ map (PixelGray . F.maximum) img,-                                   minimum $ map (PixelGray . F.minimum) img)-    normalizer !px = (px - pure s) / pure (l - s)+    !(PixelGray l, PixelGray s) = (maximum (I.map (PixelGray . foldl1Px max) img),+                                   minimum (I.map (PixelGray . foldl1Px min) img))+    normalizer !px = (px - broadcastC s) / broadcastC (l - s)     {-# INLINE normalizer #-} {-# INLINE normalize #-} ++-- | Type restricted version of `fromLists` that constructs an image using+-- supplied representation.+fromListsR :: Array arr cs e => arr -> [[Pixel cs e]] -> Image arr cs e+fromListsR _ = fromLists  -- | Generates a nested list of pixels from an image. --

@@ -3,9 +3,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module      : Graphics.Image.ColorSpace--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -13,7 +14,7 @@ -- module Graphics.Image.ColorSpace (   -- * ColorSpace-  ColorSpace, Pixel(..), Alpha, Opaque, Elevator(..),+  ColorSpace, Pixel(..), AlphaSpace(..), Elevator(..),   -- * Luma   module Graphics.Image.ColorSpace.Luma,   -- * RGB@@ -36,6 +37,7 @@   ) where  import Data.Word+import Data.Int import GHC.Float import Graphics.Image.Interface hiding (map) import Graphics.Image.ColorSpace.Binary@@ -49,11 +51,11 @@ import qualified Graphics.Image.Interface as I (map)  - -- Binary:  -- | Convert any pixel to binary pixel.-toPixelBinary :: (ColorSpace cs, Eq (Pixel cs e), Num e) => Pixel cs e -> Pixel Binary Bit+toPixelBinary :: (Eq (Pixel cs e), Num (Pixel cs e))+                 => Pixel cs e -> Pixel Binary Bit toPixelBinary px = if px == 0 then on else off {-# INLINE toPixelBinary #-} @@ -111,7 +113,7 @@ instance ToYA YCbCrA where    instance ToRGB Y where-  toPixelRGB (PixelY g) = fromChannel g+  toPixelRGB (PixelY g) = broadcastC g   {-# INLINE toPixelRGB #-}  instance ToRGBA YA where@@ -125,6 +127,7 @@     getThird !v1 !v2 = i + 2*is + v1 - v2     {-# INLINE getThird #-}     getRGB h+      | h < 0      = error ("HSI pixel is not properly scaled, Hue: "++show h')       | h < 2*pi/3 = let !r = getFirst h (pi/3 - h)                          !b = second                          !g = getThird b r@@ -205,216 +208,244 @@  instance ToCMYKA RGBA where -  --- | Values are scaled to @[0, 255]@ range.++dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b+dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div`+                                                   fromIntegral (maxBound :: b)) +{-# INLINE dropDown #-}++raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b+raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a))+{-# INLINE raiseUp #-}+++squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b+squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a)+{-# INLINE squashTo1 #-}++stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b+stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e)+++-- | Clamp a value to @[0, 1]@ range.+clamp01 :: (Ord a, Floating a) => a -> a+clamp01 !x = min (max 0 x) 1+{-# INLINE clamp01 #-}++ instance Elevator Word8 where    toWord8 = id   {-# INLINE toWord8 #-}--  toWord16 = fmap toWord16' where-    toWord16' !e = fromIntegral e * ((maxBound :: Word16) `div` fromIntegral (maxBound :: Word8)) -    {-# INLINE toWord16' #-}+  toWord16 = raiseUp   {-# INLINE toWord16 #-}--  toWord32 = fmap toWord32' where-    toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word8)) -    {-# INLINE toWord32' #-}+  toWord32 = raiseUp   {-# INLINE toWord32 #-}--  toWord64 = fmap toWord64' where-    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word8))-    {-# INLINE toWord64' #-}+  toWord64 = raiseUp   {-# INLINE toWord64 #-}--  toFloat = fmap toFloat' where-    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word8)-    {-# INLINE toFloat' #-}+  toFloat = squashTo1   {-# INLINE toFloat #-}--  toDouble = fmap toDouble' where-    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word8)-    {-# INLINE toDouble' #-}+  toDouble = squashTo1   {-# INLINE toDouble #-}-   fromDouble = toWord8   {-# INLINE fromDouble #-}  --- | Values are scaled to @[0, 65535]@ range. instance Elevator Word16 where -  toWord8 = fmap toWord8' where-    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word16) `div`-                                                      fromIntegral (maxBound :: Word8)) -    {-# INLINE toWord8' #-}+  toWord8 = dropDown   {-# INLINE toWord8 #-}-   toWord16 = id   {-# INLINE toWord16 #-}-  -  toWord32 = fmap toWord32' where-    toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word16)) -    {-# INLINE toWord32' #-}+  toWord32 = raiseUp   {-# INLINE toWord32 #-}--  toWord64 = fmap toWord64' where-    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word16))-    {-# INLINE toWord64' #-}+  toWord64 = raiseUp   {-# INLINE toWord64 #-}--  toFloat = fmap toFloat' where-    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word16)-    {-# INLINE toFloat' #-}+  toFloat = squashTo1   {-# INLINE toFloat #-}--  toDouble = fmap toDouble' where-    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word16)-    {-# INLINE toDouble' #-}+  toDouble = squashTo1   {-# INLINE toDouble #-}-   fromDouble = toWord16   {-# INLINE fromDouble #-}  --- | Values are scaled to @[0, 4294967295]@ range. instance Elevator Word32 where -  toWord8 = fmap toWord8' where-    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div`-                                                       fromIntegral (maxBound :: Word8)) -    {-# INLINE toWord8' #-}+  toWord8 = dropDown   {-# INLINE toWord8 #-}--  toWord16 = fmap toWord16' where-    toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div`-                                                        fromIntegral (maxBound :: Word16)) -    {-# INLINE toWord16' #-}+  toWord16 = dropDown   {-# INLINE toWord16 #-}-   toWord32 = id   {-# INLINE toWord32 #-}--  toWord64 = fmap toWord64' where-    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word32))-    {-# INLINE toWord64' #-}+  toWord64 = raiseUp   {-# INLINE toWord64 #-}--  toFloat = fmap toFloat' where-    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word32)-    {-# INLINE toFloat' #-}+  toFloat = squashTo1   {-# INLINE toFloat #-}--  toDouble = fmap toDouble' where-    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word32)-    {-# INLINE toDouble' #-}+  toDouble = squashTo1   {-# INLINE toDouble #-}-   fromDouble = toWord32   {-# INLINE fromDouble #-}  --- | Values are scaled to @[0, 18446744073709551615]@ range. instance Elevator Word64 where -  toWord8 = fmap toWord8' where-    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`-                                                       fromIntegral (maxBound :: Word8)) -    {-# INLINE toWord8' #-}+  toWord8 = dropDown   {-# INLINE toWord8 #-}--  toWord16 = fmap toWord16' where-    toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`-                                                        fromIntegral (maxBound :: Word16)) -    {-# INLINE toWord16' #-}+  toWord16 = dropDown   {-# INLINE toWord16 #-}--  toWord32 = fmap toWord32' where-    toWord32' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`-                                                        fromIntegral (maxBound :: Word32)) -    {-# INLINE toWord32' #-}+  toWord32 = dropDown   {-# INLINE toWord32 #-}-   toWord64 = id   {-# INLINE toWord64 #-}--  toFloat = fmap toFloat' where-    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word64)-    {-# INLINE toFloat' #-}+  toFloat = squashTo1   {-# INLINE toFloat #-}--  toDouble = fmap toDouble' where-    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word64)-    {-# INLINE toDouble' #-}+  toDouble = squashTo1   {-# INLINE toDouble #-}-   fromDouble = toWord64   {-# INLINE fromDouble #-}  --- | Values are scaled to @[0.0, 1.0]@ range.-instance Elevator Float where+instance Elevator Word where -  toWord8 = fmap toWord8' where-    toWord8' !e = round (fromIntegral (maxBound :: Word8) * e)-    {-# INLINE toWord8' #-}+  toWord8 = dropDown   {-# INLINE toWord8 #-}--  toWord16 = fmap toWord16' where-    toWord16' !e = round (fromIntegral (maxBound :: Word16) * e)-    {-# INLINE toWord16' #-}+  toWord16 = dropDown   {-# INLINE toWord16 #-}--  toWord32 = fmap toWord32' where-    toWord32' !e = round (fromIntegral (maxBound :: Word32) * e)-    {-# INLINE toWord32' #-}+  toWord32 = dropDown   {-# INLINE toWord32 #-}--  toWord64 = fmap toWord64' where-    toWord64' !e = round (fromIntegral (maxBound :: Word64) * e)-    {-# INLINE toWord64' #-}+  toWord64 = fromIntegral   {-# INLINE toWord64 #-}--  toFloat = id+  toFloat = squashTo1   {-# INLINE toFloat #-}--  toDouble = fmap float2Double+  toDouble = squashTo1   {-# INLINE toDouble #-}+  fromDouble = stretch . clamp01+  {-# INLINE fromDouble #-} -  fromDouble = toFloat++instance Elevator Int8 where++  toWord8 = fromIntegral . (max 0)+  {-# INLINE toWord8 #-}+  toWord16 = raiseUp . (max 0)+  {-# INLINE toWord16 #-}+  toWord32 = raiseUp . (max 0)+  {-# INLINE toWord32 #-}+  toWord64 = raiseUp . (max 0)+  {-# INLINE toWord64 #-}+  toFloat = squashTo1 . (max 0)+  {-# INLINE toFloat #-}+  toDouble = squashTo1 . (max 0)+  {-# INLINE toDouble #-}+  fromDouble = stretch . clamp01   {-# INLINE fromDouble #-}  --- | Values are scaled to @[0.0, 1.0]@ range.-instance Elevator Double where+instance Elevator Int16 where -  toWord8 = fmap toWord8' where-    toWord8' !e = round (fromIntegral (maxBound :: Word8) * e)-    {-# INLINE toWord8' #-}+  toWord8 = dropDown . (max 0)   {-# INLINE toWord8 #-}+  toWord16 = fromIntegral . (max 0)+  {-# INLINE toWord16 #-}+  toWord32 = raiseUp . (max 0)+  {-# INLINE toWord32 #-}+  toWord64 = raiseUp . (max 0)+  {-# INLINE toWord64 #-}+  toFloat = squashTo1 . (max 0)+  {-# INLINE toFloat #-}+  toDouble = squashTo1 . (max 0)+  {-# INLINE toDouble #-}+  fromDouble = stretch . clamp01+  {-# INLINE fromDouble #-} -  toWord16 = fmap toWord16' where-    toWord16' !e = round (fromIntegral (maxBound :: Word16) * e)-    {-# INLINE toWord16' #-}++instance Elevator Int32 where++  toWord8 = dropDown . (max 0)+  {-# INLINE toWord8 #-}+  toWord16 = dropDown . (max 0)   {-# INLINE toWord16 #-}+  toWord32 = fromIntegral . (max 0)+  {-# INLINE toWord32 #-}+  toWord64 = raiseUp . (max 0)+  {-# INLINE toWord64 #-}+  toFloat = squashTo1 . (max 0)+  {-# INLINE toFloat #-}+  toDouble = squashTo1 . (max 0)+  {-# INLINE toDouble #-}+  fromDouble = stretch . clamp01+  {-# INLINE fromDouble #-} -  toWord32 = fmap toWord32' where-    toWord32' !e = round (fromIntegral (maxBound :: Word32) * e)-    {-# INLINE toWord32' #-}++instance Elevator Int64 where++  toWord8 = dropDown . (max 0)+  {-# INLINE toWord8 #-}+  toWord16 = dropDown . (max 0)+  {-# INLINE toWord16 #-}+  toWord32 = dropDown . (max 0)   {-# INLINE toWord32 #-}+  toWord64 = fromIntegral . (max 0)+  {-# INLINE toWord64 #-}+  toFloat = squashTo1 . (max 0)+  {-# INLINE toFloat #-}+  toDouble = squashTo1 . (max 0)+  {-# INLINE toDouble #-}+  fromDouble = stretch . clamp01+  {-# INLINE fromDouble #-} -  toWord64 = fmap toWord64' where-    toWord64' !e = round (fromIntegral (maxBound :: Word64) * e)-    {-# INLINE toWord64' #-}++instance Elevator Int where++  toWord8 = dropDown . (max 0)+  {-# INLINE toWord8 #-}+  toWord16 = dropDown . (max 0)+  {-# INLINE toWord16 #-}+  toWord32 = dropDown . (max 0)+  {-# INLINE toWord32 #-}+  toWord64 = fromIntegral . (max 0)   {-# INLINE toWord64 #-}+  toFloat = squashTo1 . (max 0)+  {-# INLINE toFloat #-}+  toDouble = squashTo1 . (max 0)+  {-# INLINE toDouble #-}+  fromDouble = stretch . clamp01+  {-# INLINE fromDouble #-} -  toFloat = fmap double2Float++instance Elevator Float where+  toWord8 = stretch . clamp01+  {-# INLINE toWord8 #-}+  toWord16 = stretch . clamp01+  {-# INLINE toWord16 #-}+  toWord32 = stretch . clamp01+  {-# INLINE toWord32 #-}+  toWord64 = stretch . clamp01+  {-# INLINE toWord64 #-}+  toFloat = id   {-# INLINE toFloat #-}+  toDouble = float2Double+  {-# INLINE toDouble #-}+  fromDouble = toFloat+  {-# INLINE fromDouble #-} +instance Elevator Double where+  toWord8 = stretch . clamp01+  {-# INLINE toWord8 #-}+  toWord16 = stretch . clamp01+  {-# INLINE toWord16 #-}+  toWord32 = stretch . clamp01+  {-# INLINE toWord32 #-}+  toWord64 = stretch . clamp01+  {-# INLINE toWord64 #-}+  toFloat = double2Float+  {-# INLINE toFloat #-}   toDouble = id   {-# INLINE toDouble #-}-   fromDouble = id   {-# INLINE fromDouble #-}+++  

@@ -2,6 +2,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Image.ColorSpace.Binary@@ -19,8 +21,8 @@ import Data.Word (Word8) import Graphics.Image.Interface import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend, mempty)-import qualified Data.Colour as C+import Foreign.Ptr+import Foreign.Storable  -- | This is a Binary colorspace, pixel's of which can be created using -- these __/constructors/__:@@ -51,7 +53,13 @@ -- values of @0@ or @1@. newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable) +data instance Pixel Binary e = PixelBinary !e deriving (Ord, Eq) +instance Show (Pixel Binary Bit) where+  show (PixelBinary (Bit 0)) = "<Binary:(0)>"+  show _                     = "<Binary:(1)>"++ -- | Represents value 'True' or @1@ in binary. Often also called a foreground -- pixel of an object. on :: Pixel Binary Bit@@ -96,63 +104,110 @@ {-# INLINE complement #-}  +instance ColorSpace Binary Bit where+  type Components Binary Bit = Bit -instance ColorSpace Binary where-  type PixelElt Binary e = e-  data Pixel Binary e = PixelBinary !e deriving (Ord, Eq)+  broadcastC = PixelBinary+  {-# INLINE broadcastC #-}+  fromComponents = PixelBinary+  {-# INLINE fromComponents #-}+  toComponents (PixelBinary b) = b+  {-# INLINE toComponents #-}+  getPxC (PixelBinary b) _ = b+  {-# INLINE getPxC #-}+  setPxC (PixelBinary _) _ b = PixelBinary b+  {-# INLINE setPxC #-}  +  mapPxC f (PixelBinary b) = PixelBinary (f Binary b)+  {-# INLINE mapPxC #-}+  mapPx f (PixelBinary b) = PixelBinary (f b)+  {-# INLINE mapPx #-}+  zipWithPx f (PixelBinary b1) (PixelBinary b2) = PixelBinary (f b1 b2)+  {-# INLINE zipWithPx #-}+  foldrPx f z (PixelBinary b) = f b z+  {-# INLINE foldrPx #-} -  fromChannel = PixelBinary-  {-# INLINE fromChannel #-} -  fromElt = PixelBinary-  {-# INLINE fromElt #-}--  toElt (PixelBinary b) = b-  {-# INLINE toElt #-}+instance Elevator Bit where+  toWord8 (Bit 0) = 0+  toWord8 _       = maxBound+  {-# INLINE toWord8 #-}+  toWord16 (Bit 0) = 0+  toWord16 _       = maxBound+  {-# INLINE toWord16 #-}+  toWord32 (Bit 0) = 0+  toWord32 _       = maxBound+  {-# INLINE toWord32 #-}+  toWord64 (Bit 0) = 0+  toWord64 _       = maxBound+  {-# INLINE toWord64 #-}+  toFloat (Bit 0) = 0+  toFloat _       = 1+  {-# INLINE toFloat #-}+  toDouble (Bit 0) = 0+  toDouble _       = 1+  {-# INLINE toDouble #-}+  fromDouble 0 = Bit 0+  fromDouble _ = Bit 1+  {-# INLINE fromDouble #-} -  getPxCh (PixelBinary b) _ = b-  {-# INLINE getPxCh #-}   -  chOp !f (PixelBinary b) = PixelBinary (f Binary b)-  {-# INLINE chOp #-} -  pxOp !f (PixelBinary b) = PixelBinary (f b)-  {-# INLINE pxOp #-}--  chApp (PixelBinary f) (PixelBinary b) = PixelBinary (f b)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelBinary b) = f b `M.mappend` M.mempty-  {-# INLINE pxFoldMap #-}--  csColour _ = C.opaque C.black---instance Show (Pixel Binary Bit) where-  show (PixelBinary (Bit 0)) = "<Binary:(0)>"-  show _                     = "<Binary:(1)>"-- instance Num Bit where   (Bit 0) + (Bit 0) = Bit 0   _       + _       = Bit 1   {-# INLINE (+) #-}-     _ - (Bit 1) = Bit 0   _ - _       = Bit 1   {-# INLINE (-) #-}-     _       * (Bit 0) = Bit 0   (Bit 0) * _       = Bit 0   _       * _       = Bit 1   {-# INLINE (*) #-}-     abs         = id   {-# INLINE abs #-}-     signum      = id   {-# INLINE signum #-}-     fromInteger 0 = Bit 0   fromInteger _ = Bit 1   {-# INLINE fromInteger #-}+++instance Num (Pixel Binary Bit) where+  (+)         = zipWithPx (+)+  {-# INLINE (+) #-}+  (-)         = zipWithPx (-)+  {-# INLINE (-) #-}+  (*)         = zipWithPx (*)+  {-# INLINE (*) #-}+  abs         = mapPx abs+  {-# INLINE abs #-}+  signum      = mapPx signum+  {-# INLINE signum #-}+  fromInteger = broadcastC . fromInteger+  {-# INLINE fromInteger #-}+++instance Storable Bit where++  sizeOf _ = sizeOf (undefined :: Word8)+  alignment _ = alignment (undefined :: Word8)+  peek p = do+    q <- return $ castPtr p+    b <- peek q+    return (Bit b)+  poke p (Bit b) = do+    q <- return $ castPtr p+    poke q b+++instance Storable (Pixel Binary Bit) where++  sizeOf _ = sizeOf (undefined :: Bit)+  alignment _ = alignment (undefined :: Bit)+  peek p = do+    q <- return $ castPtr p+    b <- peek q+    return (PixelBinary b)+  poke p (PixelBinary b) = do+    q <- return $ castPtr p+    poke q b

@@ -2,10 +2,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Image.ColorSpace.CMYK--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -17,12 +19,18 @@   ) where  import Prelude hiding (map)-import Graphics.Image.Interface+import Control.Applicative+import Data.Foldable import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C+import Foreign.Ptr+import Foreign.Storable +import Graphics.Image.Interface++------------+--- CMYK ---+------------+ -- | Cyan, Magenta, Yellow and Black color space. data CMYK = CyanCMYK -- ^ Cyan           | MagCMYK  -- ^ Magenta@@ -30,6 +38,141 @@           | KeyCMYK  -- ^ Key (Black)           deriving (Eq, Enum, Typeable) +instance Show CMYK where+  show CyanCMYK = "Cyan"+  show MagCMYK  = "Magenta"+  show YelCMYK  = "Yellow"+  show KeyCMYK  = "Black"+++instance Show e => Show (Pixel CMYK e) where+  show (PixelCMYK c m y k) = "<CMYK:("++show c++"|"++show m++"|"++show y++"|"++show k++")>"+++data instance Pixel CMYK e = PixelCMYK !e !e !e !e deriving Eq++instance (Elevator e, Typeable e) => ColorSpace CMYK e where+  type Components CMYK e = (e, e, e, e)+  +  fromComponents !(c, m, y, k) = PixelCMYK c m y k+  {-# INLINE fromComponents #-}+  toComponents (PixelCMYK c m y k) = (c, m, y, k)+  {-# INLINE toComponents #-}+  broadcastC !e = PixelCMYK e e e e+  {-# INLINE broadcastC #-}+  getPxC (PixelCMYK c _ _ _) CyanCMYK = c+  getPxC (PixelCMYK _ m _ _) MagCMYK  = m+  getPxC (PixelCMYK _ _ y _) YelCMYK  = y+  getPxC (PixelCMYK _ _ _ k) KeyCMYK  = k+  {-# INLINE setPxC #-}+  setPxC (PixelCMYK _ m y k) CyanCMYK c = PixelCMYK c m y k+  setPxC (PixelCMYK c _ y k) MagCMYK  m = PixelCMYK c m y k+  setPxC (PixelCMYK c m _ k) YelCMYK  y = PixelCMYK c m y k+  setPxC (PixelCMYK c m y _) KeyCMYK  k = PixelCMYK c m y k+  {-# INLINE getPxC #-}+  mapPxC f (PixelCMYK c m y k) =+    PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}+++instance Functor (Pixel CMYK) where+  fmap f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k)+  {-# INLINE fmap #-}+++instance Applicative (Pixel CMYK) where+  pure !e = PixelCMYK e e e e+  {-# INLINE pure #-}+  (PixelCMYK fc fm fy fk) <*> (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k)+  {-# INLINE (<*>) #-}+++instance Foldable (Pixel CMYK) where+  foldr f !z (PixelCMYK c m y k) = f c (f m (f y (f k z)))+  {-# INLINE foldr #-}+++instance Num e => Num (Pixel CMYK e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}+++instance Fractional e => Fractional (Pixel CMYK e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel CMYK e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance Storable e => Storable (Pixel CMYK e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    c <- peek q+    m <- peekElemOff q 1+    y <- peekElemOff q 2+    k <- peekElemOff q 3+    return (PixelCMYK c m y k)+  poke p (PixelCMYK c m y k) = do+    q <- return $ castPtr p+    poke q c+    pokeElemOff q 1 m+    pokeElemOff q 2 y+    pokeElemOff q 3 k++-------------+--- CMYKA ---+-------------+ -- | Cyan, Magenta, Yellow and Black color space with Alpha channel. data CMYKA = CyanCMYKA  -- ^ Cyan            | MagCMYKA   -- ^ Magenta@@ -40,7 +183,7 @@   -- | Conversion to `CMYK` color space.-class ColorSpace cs => ToCMYK cs where+class ColorSpace cs Double => ToCMYK cs where    -- | Convert to a `CMYK` pixel.   toPixelCMYK :: Pixel cs Double -> Pixel CMYK Double@@ -53,8 +196,9 @@   {-# INLINE toImageCMYK #-}  + -- | Conversion to `CMYKA` from another color space with Alpha channel.-class (ToCMYK (Opaque cs), Alpha cs) => ToCMYKA cs where+class (ToCMYK (Opaque cs), AlphaSpace cs Double) => ToCMYKA cs where    -- | Convert to a `CMYKA` pixel.   toPixelCMYKA :: Pixel cs Double -> Pixel CMYKA Double@@ -68,85 +212,55 @@   toImageCMYKA = map toPixelCMYKA   {-# INLINE toImageCMYKA #-} -  -instance ColorSpace CMYK where-  type PixelElt CMYK e = (e, e, e, e)-  data Pixel CMYK e = PixelCMYK !e !e !e !e deriving Eq+data instance Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq -  fromChannel !e = PixelCMYK e e e e-  {-# INLINE fromChannel #-} -  fromElt !(c, m, y, k) = PixelCMYK c m y k-  {-# INLINE fromElt #-}--  toElt (PixelCMYK c m y k) = (c, m, y, k)-  {-# INLINE toElt #-}--  getPxCh (PixelCMYK c _ _ _) CyanCMYK = c-  getPxCh (PixelCMYK _ m _ _) MagCMYK  = m-  getPxCh (PixelCMYK _ _ y _) YelCMYK  = y-  getPxCh (PixelCMYK _ _ _ k) KeyCMYK  = k-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelCMYK c m y k) =-    PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k)-  {-# INLINE chOp #-}--  pxOp !f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k)-  {-# INLINE pxOp #-}--  chApp (PixelCMYK fc fm fy fk) (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelCMYK c m y k) = f c `M.mappend` f m `M.mappend` f y `M.mappend` f k-  {-# INLINE pxFoldMap #-}+instance Show CMYKA where+  show CyanCMYKA  = "Cyan"+  show MagCMYKA   = "Magenta"+  show YelCMYKA   = "Yellow"+  show KeyCMYKA   = "Black"+  show AlphaCMYKA = "Alpha"+  -  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 Show e => Show (Pixel CMYKA e) where+  show (PixelCMYKA c m y k a) =+    "<CMYKA:("++show c++"|"++show m++"|"++show y++"|"++show k++"|"++show a++")>"  -instance ColorSpace CMYKA where-  type PixelElt CMYKA e = (e, e, e, e, e)-  data Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq--  fromChannel !e = PixelCMYKA e e e e e-  {-# INLINE fromChannel #-}--  fromElt (c, m, y, k, a) = PixelCMYKA c m y k a-  {-# INLINE fromElt #-}--  toElt (PixelCMYKA c m y k a) = (c, m, y, k, a)-  {-# INLINE toElt #-}--  getPxCh (PixelCMYKA c _ _ _ _) CyanCMYKA  = c-  getPxCh (PixelCMYKA _ m _ _ _) MagCMYKA   = m-  getPxCh (PixelCMYKA _ _ y _ _) YelCMYKA   = y-  getPxCh (PixelCMYKA _ _ _ k _) KeyCMYKA   = k-  getPxCh (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a-  {-# INLINE getPxCh #-}+instance (Elevator e, Typeable e) => ColorSpace CMYKA e where+  type Components CMYKA e = (e, e, e, e, e)   -  chOp !f (PixelCMYKA c m y k a) =+  fromComponents !(c, m, y, k, a) = PixelCMYKA c m y k a+  {-# INLINE fromComponents #-}+  toComponents (PixelCMYKA c m y k a) = (c, m, y, k, a)+  {-# INLINE toComponents #-}+  broadcastC !e = PixelCMYKA e e e e e+  {-# INLINE broadcastC #-}+  getPxC (PixelCMYKA c _ _ _ _) CyanCMYKA  = c+  getPxC (PixelCMYKA _ m _ _ _) MagCMYKA   = m+  getPxC (PixelCMYKA _ _ y _ _) YelCMYKA   = y+  getPxC (PixelCMYKA _ _ _ k _) KeyCMYKA   = k+  getPxC (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a+  {-# INLINE getPxC #-}+  setPxC (PixelCMYKA _ m y k a) CyanCMYKA  c = PixelCMYKA c m y k a+  setPxC (PixelCMYKA c _ y k a) MagCMYKA   m = PixelCMYKA c m y k a+  setPxC (PixelCMYKA c m _ k a) YelCMYKA   y = PixelCMYKA c m y k a+  setPxC (PixelCMYKA c m y _ a) KeyCMYKA   k = PixelCMYKA c m y k a+  setPxC (PixelCMYKA c m y k _) AlphaCMYKA a = PixelCMYKA c m y k a+  {-# INLINE setPxC #-}+  mapPxC f (PixelCMYKA c m y k a) =     PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a)-  {-# INLINE chOp #-}--  pxOp !f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a)-  {-# INLINE pxOp #-}--  chApp (PixelCMYKA fc fm fy fk fa) (PixelCMYKA c m y k a) =-    PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelCMYKA c m y k a) =-    f c `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+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}  -instance Alpha CMYKA where+instance (Elevator e, Typeable e) => AlphaSpace CMYKA e where   type Opaque CMYKA = CMYK    getAlpha (PixelCMYKA _ _ _ _ a) = a@@ -158,32 +272,94 @@   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"-  show MagCMYK  = "Magenta"-  show YelCMYK  = "Yellow"-  show KeyCMYK  = "Black"+instance Functor (Pixel CMYKA) where+  fmap f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a)+  {-# INLINE fmap #-}  -instance Show CMYKA where-  show AlphaCMYKA = "Alpha"-  show ch         = show $ opaque ch+instance Applicative (Pixel CMYKA) where+  pure !e = PixelCMYKA e e e e e+  {-# INLINE pure #-}+  (PixelCMYKA fc fm fy fk fa) <*> (PixelCMYKA c m y k a) =+    PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a)+  {-# INLINE (<*>) #-} -  -instance Show e => Show (Pixel CMYK e) where-  show (PixelCMYK c m y k) = "<CMYK:("++show c++"|"++show m++"|"++show y++"|"++show k++")>" +instance Foldable (Pixel CMYKA) where+  foldr f !z (PixelCMYKA c m y k a) = f c (f m (f y (f k (f a z))))+  {-# INLINE foldr #-} -instance Show e => Show (Pixel CMYKA e) where-  show (PixelCMYKA c m y k a) =-    "<CMYKA:("++show c++"|"++show m++"|"++show y++"|"++show k++"|"++show a++")>" +instance Num e => Num (Pixel CMYKA e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}  +instance Fractional e => Fractional (Pixel CMYKA e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel CMYKA e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance Storable e => Storable (Pixel CMYKA e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    c <- peek q+    m <- peekElemOff q 1+    y <- peekElemOff q 2+    k <- peekElemOff q 3+    a <- peekElemOff q 4+    return (PixelCMYKA c m y k a)+  poke p (PixelCMYKA c m y k a) = do+    q <- return $ castPtr p+    poke q c+    pokeElemOff q 1 m+    pokeElemOff q 2 y+    pokeElemOff q 3 k+    pokeElemOff q 4 a

@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 800   {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif@@ -20,7 +21,7 @@   conjugate   ) where -import Graphics.Image.Interface (ColorSpace(..))+import Graphics.Image.Interface (Pixel) import Control.Applicative import Data.Complex (Complex(..)) import qualified Data.Complex as C hiding (Complex(..))@@ -33,50 +34,51 @@ -- -- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @ ---(+:) :: ColorSpace cs => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)+(+:) :: Applicative (Pixel cs) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) (+:) = liftA2 (:+) {-# INLINE (+:) #-}  -- | Extracts the real part of a complex pixel.-realPart :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+realPart :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e realPart = liftA C.realPart {-# INLINE realPart #-}  -- | Extracts the imaginary part of a complex pixel.-imagPart :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+imagPart :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e imagPart = liftA C.imagPart {-# INLINE imagPart #-}  -- | Form a complex pixel from polar components of magnitude and phase.-mkPolar :: (ColorSpace cs, RealFloat e) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)+mkPolar :: (Applicative (Pixel cs), RealFloat e) =>+           Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) mkPolar = liftA2 C.mkPolar {-# INLINE mkPolar #-}  -- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@).-cis :: (ColorSpace cs, RealFloat e) => Pixel cs e -> Pixel cs (Complex e)+cis :: (Applicative (Pixel cs), RealFloat e) => Pixel cs e -> Pixel cs (Complex e) cis = liftA C.cis {-# INLINE cis #-}  -- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase) -- pair of pixels in canonical form: the magnitude is nonnegative, and the phase -- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.-polar :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e)+polar :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e) polar !zPx = (magnitude zPx, phase zPx) {-# INLINE polar #-}  -- | The nonnegative magnitude of a complex pixel.-magnitude :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+magnitude :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e magnitude = liftA C.magnitude {-# INLINE magnitude #-}  -- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the -- magnitude is zero, then so is the phase.-phase :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+phase :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e phase = liftA C.phase {-# INLINE phase #-}  -- | The conjugate of a complex pixel.-conjugate :: (ColorSpace cs, RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e)+conjugate :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e) conjugate = liftA C.conjugate {-# INLINE conjugate #-} 

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- |@@ -16,22 +17,149 @@   Gray(..), Pixel(..), toGrayImages, fromGrayImages   ) where -import Prelude hiding (map, zipWith)-import qualified Prelude as P (map)-import Graphics.Image.Interface+import Prelude as P+import Control.Applicative+import Data.Foldable import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend, mempty)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C+import Foreign.Ptr+import Foreign.Storable --- ^ This is a signgle channel colorspace, that is designed to hold any channel--- from any other colorspace, hence it is not convertible to and from, but--- rather is here to allow separation of channels from other multichannel--- colorspaces. If you are looking for a true grayscale colorspace+import Graphics.Image.Interface as I++-- ^ This is a single channel colorspace, that is designed to separate Gray+-- level values from other types of colorspace, hence it is not convertible to+-- or from, but rather is here to allow operation on arbirtary single channel+-- images. If you are looking for a true grayscale colorspace -- 'Graphics.Image.ColorSpace.Luma.Y' should be used instead. data Gray = Gray deriving (Eq, Enum, Show, Typeable)  +data instance Pixel Gray e = PixelGray !e deriving (Ord, Eq)+++instance Show e => Show (Pixel Gray e) where+  show (PixelGray g) = "<Gray:("++show g++")>"+++instance (Elevator e, Typeable e) => ColorSpace Gray e where+  type Components Gray e = e++  broadcastC = PixelGray+  {-# INLINE broadcastC #-}+  fromComponents = PixelGray+  {-# INLINE fromComponents #-}+  toComponents (PixelGray g) = g+  {-# INLINE toComponents #-}+  getPxC (PixelGray g) Gray = g+  {-# INLINE getPxC #-}+  setPxC (PixelGray _) Gray g = PixelGray g+  {-# INLINE setPxC #-}+  mapPxC f (PixelGray g) = PixelGray (f Gray g)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}+++instance Functor (Pixel Gray) where+  fmap f (PixelGray g) = PixelGray (f g)+  {-# INLINE fmap #-}+++instance Applicative (Pixel Gray) where+  pure = PixelGray+  {-# INLINE pure #-}+  (PixelGray fg) <*> (PixelGray g) = PixelGray (fg g)+  {-# INLINE (<*>) #-}+++instance Foldable (Pixel Gray) where+  foldr f !z (PixelGray g) = f g z+  {-# INLINE foldr #-}+++instance Monad (Pixel Gray) where++  return = PixelGray+  {-# INLINE return #-}++  (>>=) (PixelGray g) f = f g+  {-# INLINE (>>=) #-}+++instance Num e => Num (Pixel Gray e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  +  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  +  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  +  abs         = liftA abs+  {-# INLINE abs #-}+  +  signum      = liftA signum+  {-# INLINE signum #-}+  +  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}+++instance Fractional e => Fractional (Pixel Gray e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel Gray e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance Storable e => Storable (Pixel Gray e) where++  sizeOf _ = sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    g <- peek q+    return (PixelGray g)+  poke p (PixelGray g) = do+    q <- return $ castPtr p+    poke q g+ -- | Separate an image into a list of images with 'Gray' pixels containing every -- channel from the source image. --@@ -45,7 +173,7 @@ -- toGrayImages :: (Array arr cs e, Array arr Gray e) => Image arr cs e -> [Image arr Gray e] toGrayImages !img = P.map getCh (enumFrom (toEnum 0)) where-  getCh !ch = map (PixelGray . (`getPxCh` ch)) img+  getCh !ch = I.map (PixelGray . (`getPxC` ch)) img   {-# INLINE getCh #-} {-# INLINE toGrayImages #-} @@ -61,61 +189,17 @@ -- -- It is worth noting though, despite that separating image channels can be sometimes -- pretty useful, the same effect as above can be achieved in a much simpler and--- more efficient way:+-- a more efficient way: -- -- @ map (\(PixelRGB r g b) -> PixelRGB r b g) frog @ -- fromGrayImages :: forall arr cs e . (Array arr Gray e, Array arr cs e) =>                   [Image arr Gray e] -> [cs] -> Image arr cs e-fromGrayImages = fromGrays (singleton (fromChannel 0)) where-  updateCh ch px (PixelGray e) = chOp (\ !ch' !e' -> if ch' == ch then e else e') px+fromGrayImages = fromGrays 0 where+  updateCh ch px (PixelGray e) = setPxC px ch e   {-# INLINE updateCh #-}   fromGrays img []     _      = img   fromGrays img _      []     = img-  fromGrays img (i:is) (c:cs) = fromGrays (zipWith (updateCh c) img i) is cs+  fromGrays img (i:is) (c:cs) = fromGrays (I.zipWith (updateCh c) img i) is cs   {-# INLINE fromGrays #-} {-# INLINE fromGrayImages #-}---instance ColorSpace Gray where-  type PixelElt Gray e = e-  data Pixel Gray e = PixelGray !e deriving (Ord, Eq)--  fromChannel = PixelGray-  {-# INLINE fromChannel #-}--  fromElt = PixelGray-  {-# INLINE fromElt #-}--  toElt (PixelGray g) = g-  {-# INLINE toElt #-}--  getPxCh (PixelGray g) _ = g-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelGray g) = PixelGray (f Gray g)-  {-# INLINE chOp #-}-  -  pxOp !f (PixelGray g) = PixelGray (f g)-  {-# INLINE pxOp #-}--  chApp (PixelGray f) (PixelGray g) = PixelGray (f g)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelGray g) = f g `M.mappend` M.mempty-  {-# INLINE pxFoldMap #-}--  csColour _ = C.opaque C.gray--  -instance Show e => Show (Pixel Gray e) where-  show (PixelGray g) = "<Gray:("++show g++")>"---instance Monad (Pixel Gray) where--  return = PixelGray-  {-# INLINE return #-}--  (>>=) (PixelGray g) f = f g-  {-# INLINE (>>=) #-}

@@ -2,10 +2,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Image.ColorSpace.HSI--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -17,18 +19,152 @@   ) where  import Prelude hiding (map)-import Graphics.Image.Interface+import Control.Applicative+import Data.Foldable import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C+import Foreign.Ptr+import Foreign.Storable +import Graphics.Image.Interface++-----------+--- HSI ---+-----------+ -- | Hue, Saturation and Intensity color space. data HSI = HueHSI -- ^ Hue          | SatHSI -- ^ Saturation           | IntHSI -- ^ Intensity          deriving (Eq, Enum, Typeable) +data instance Pixel HSI e = PixelHSI !e !e !e deriving Eq+++instance Show HSI where+  show HueHSI = "Hue"+  show SatHSI = "Saturation"+  show IntHSI = "Intensity"+  +instance Show e => Show (Pixel HSI e) where+  show (PixelHSI h s i) = "<HSI:("++show h++"|"++show s++"|"++show i++")>"+++instance (Elevator e, Typeable e) => ColorSpace HSI e where+  type Components HSI e = (e, e, e)++  toComponents (PixelHSI h s i) = (h, s, i)+  {-# INLINE toComponents #-}+  fromComponents !(h, s, i) = PixelHSI h s i+  {-# INLINE fromComponents #-}+  broadcastC = pure+  {-# INLINE broadcastC #-}+  getPxC (PixelHSI h _ _) HueHSI = h+  getPxC (PixelHSI _ s _) SatHSI = s+  getPxC (PixelHSI _ _ i) IntHSI = i+  {-# INLINE getPxC #-}+  setPxC (PixelHSI _ s i) HueHSI h = PixelHSI h s i+  setPxC (PixelHSI h _ i) SatHSI s = PixelHSI h s i+  setPxC (PixelHSI h s _) IntHSI i = PixelHSI h s i+  {-# INLINE setPxC #-}+  mapPxC f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}+++instance Functor (Pixel HSI) where+  fmap f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i)+  {-# INLINE fmap #-}+++instance Applicative (Pixel HSI) where+  pure !e = PixelHSI e e e+  {-# INLINE pure #-}+  (PixelHSI fh fs fi) <*> (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i)+  {-# INLINE (<*>) #-}+++instance Foldable (Pixel HSI) where+  foldr f !z (PixelHSI h s i) = f h (f s (f i z))+  {-# INLINE foldr #-}++instance Num e => Num (Pixel HSI e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}+  ++instance Fractional e => Fractional (Pixel HSI e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel HSI e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance Storable e => Storable (Pixel HSI e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    r <- peek q+    g <- peekElemOff q 1+    b <- peekElemOff q 2+    return (PixelHSI r g b)+  poke p (PixelHSI r g b) = do+    q <- return $ castPtr p+    poke q r+    pokeElemOff q 1 g+    pokeElemOff q 2 b++------------+--- HSIA ---+------------+ -- | Hue, Saturation and Intensity color space with Alpha channel. data HSIA = HueHSIA   -- ^ Hue           | SatHSIA   -- ^ Saturation@@ -37,8 +173,11 @@           deriving (Eq, Enum, Typeable)  +data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq++ -- | Conversion to `HSI` color space.-class ColorSpace cs => ToHSI cs where+class ColorSpace cs Double => ToHSI cs where    -- | Convert to an `HSI` pixel.   toPixelHSI :: Pixel cs Double -> Pixel HSI Double@@ -49,10 +188,63 @@              -> Image arr HSI Double   toImageHSI = map toPixelHSI   {-# INLINE toImageHSI #-}++++instance Show HSIA where+  show HueHSIA   = "Hue"+  show SatHSIA   = "Saturation"+  show IntHSIA   = "Intensity"+  show AlphaHSIA = "Alpha"+   +instance Show e => Show (Pixel HSIA e) where+  show (PixelHSIA h s i a) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show a++")>" ++instance (Elevator e, Typeable e) => ColorSpace HSIA e where+  type Components HSIA e = (e, e, e, e)++  toComponents (PixelHSIA h s i a) = (h, s, i, a)+  {-# INLINE toComponents #-}+  fromComponents !(h, s, i, a) = PixelHSIA h s i a+  {-# INLINE fromComponents #-}+  broadcastC = pure+  {-# INLINE broadcastC #-}+  getPxC (PixelHSIA h _ _ _) HueHSIA   = h+  getPxC (PixelHSIA _ s _ _) SatHSIA   = s+  getPxC (PixelHSIA _ _ i _) IntHSIA   = i+  getPxC (PixelHSIA _ _ _ a) AlphaHSIA = a+  {-# INLINE getPxC #-}+  setPxC (PixelHSIA _ s i a) HueHSIA h   = PixelHSIA h s i a+  setPxC (PixelHSIA h _ i a) SatHSIA s   = PixelHSIA h s i a+  setPxC (PixelHSIA h s _ a) IntHSIA i   = PixelHSIA h s i a+  setPxC (PixelHSIA h s i _) AlphaHSIA a = PixelHSIA h s i a+  {-# INLINE setPxC #-}+  mapPxC f (PixelHSIA h s i a) =+    PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}+++instance (Elevator e, Typeable e) => AlphaSpace HSIA e where+  type Opaque HSIA = HSI++  getAlpha (PixelHSIA _ _ _ a) = a+  {-# INLINE getAlpha #-}+  addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a+  {-# INLINE addAlpha #-}+  dropAlpha (PixelHSIA h s i _) = PixelHSI h s i+  {-# INLINE dropAlpha #-}++ -- | Conversion to `HSIA` from another color space with Alpha channel.-class (ToHSI (Opaque cs), Alpha cs) => ToHSIA cs where+class (ToHSI (Opaque cs), AlphaSpace cs Double) => ToHSIA cs where    -- | Convert to an `HSIA` pixel.   toPixelHSIA :: Pixel cs Double -> Pixel HSIA Double@@ -66,114 +258,91 @@   toImageHSIA = map toPixelHSIA   {-# INLINE toImageHSIA #-} -  -instance ColorSpace HSI where-  type PixelElt HSI e = (e, e, e)-  data Pixel HSI e = PixelHSI !e !e !e deriving Eq -  fromChannel !e = PixelHSI e e e-  {-# INLINE fromChannel #-}+instance Functor (Pixel HSIA) where+  fmap f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a)+  {-# INLINE fmap #-} -  fromElt !(h, s, i) = PixelHSI h s i-  {-# INLINE fromElt #-} -  toElt (PixelHSI h s i) = (h, s, i)-  {-# INLINE toElt #-}+instance Applicative (Pixel HSIA) where+  pure !e = PixelHSIA e e e e+  {-# INLINE pure #-}+  (PixelHSIA fh fs fi fa) <*> (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a)+  {-# INLINE (<*>) #-} -  getPxCh (PixelHSI h _ _) HueHSI   = h-  getPxCh (PixelHSI _ s _) SatHSI = s-  getPxCh (PixelHSI _ _ i) IntHSI  = i-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i)-  {-# INLINE chOp #-} -  pxOp !f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i)-  {-# INLINE pxOp #-}--  chApp (PixelHSI fh fs fi) (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelHSI h s i) = f h `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 Foldable (Pixel HSIA) where+  foldr f !z (PixelHSIA h s i a) = f h (f s (f i (f a z)))+  {-# INLINE foldr #-}  -instance ColorSpace HSIA where-  type PixelElt HSIA e = (e, e, e, e)-  data Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq--  fromChannel !e = PixelHSIA e e e e-  {-# INLINE fromChannel #-}--  fromElt (h, s, i, a) = PixelHSIA h s i a-  {-# INLINE fromElt #-}--  toElt (PixelHSIA h s i a) = (h, s, i, a)-  {-# INLINE toElt #-}--  getPxCh (PixelHSIA r _ _ _) HueHSIA   = r-  getPxCh (PixelHSIA _ g _ _) SatHSIA = g-  getPxCh (PixelHSIA _ _ b _) IntHSIA  = b-  getPxCh (PixelHSIA _ _ _ a) AlphaHSIA = a-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelHSIA h s i a) =-    PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a)-  {-# INLINE chOp #-}--  pxOp !f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a)-  {-# INLINE pxOp #-}--  chApp (PixelHSIA fh fs fi fa) (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelHSIA h s i a) = f h `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--  getAlpha (PixelHSIA _ _ _ a) = a-  {-# INLINE getAlpha #-}-  -  addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a-  {-# INLINE addAlpha #-}--  dropAlpha (PixelHSIA h s i _) = PixelHSI h s i-  {-# INLINE dropAlpha #-}--  opaque HueHSIA = HueHSI-  opaque SatHSIA = SatHSI-  opaque IntHSIA = IntHSI-  opaque _       = error "Data.Image.ColorSpace.HSI (Alpha.opaque)"+instance Num e => Num (Pixel HSIA e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}  -instance Show HSI where-  show HueHSI = "Hue"-  show SatHSI = "Saturation"-  show IntHSI = "Intensity"-  --instance Show HSIA where-  show AlphaHSIA = "Alpha"-  show ch        = show $ opaque ch--  -instance Show e => Show (Pixel HSI e) where-  show (PixelHSI h s i) = "<HSI:("++show h++"|"++show s++"|"++show i++")>"+instance Fractional e => Fractional (Pixel HSIA e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}  -instance Show e => Show (Pixel HSIA e) where-  show (PixelHSIA h s i a) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show a++")>"+instance Floating e => Floating (Pixel HSIA e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}  +instance Storable e => Storable (Pixel HSIA e) where +  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    h <- peek q+    s <- peekElemOff q 1+    i <- peekElemOff q 2+    a <- peekElemOff q 3+    return (PixelHSIA h s i a)+  poke p (PixelHSIA h s i a) = do+    q <- return $ castPtr p+    poke q h+    pokeElemOff q 1 s+    pokeElemOff q 2 i+    pokeElemOff q 3 a

@@ -2,6 +2,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Image.ColorSpace.Luma@@ -17,24 +19,26 @@   ) where  import Prelude hiding (map)-import Graphics.Image.Interface+import Control.Applicative+import Data.Foldable import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend, mempty)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C+import Foreign.Ptr+import Foreign.Storable --- | Luma or brightness, that is usually denoted as @Y'@.-data Y = Y deriving (Eq, Enum, Typeable)+import Graphics.Image.Interface +---------+--- Y ---+--------- --- | Luma with Alpha channel.-data YA = YA      -- ^ Luma-        | AlphaYA -- ^ Alpha channel-        deriving (Eq, Enum, Typeable)+-- | Luma or brightness, which is usually denoted as @Y'@.+data Y = LumaY deriving (Eq, Enum, Typeable)  +data instance Pixel Y e = PixelY !e deriving (Ord, Eq)+ -- | Conversion to Luma color space.-class ColorSpace cs => ToY cs where+class ColorSpace cs Double => ToY cs where    -- | Convert a pixel to Luma pixel.   toPixelY :: Pixel cs Double -> Pixel Y Double@@ -46,124 +50,279 @@   toImageY = map toPixelY   {-# INLINE toImageY #-} -  --- | Conversion to Luma from another color space with Alpha channel.-class (ToY (Opaque cs), Alpha cs) => ToYA cs where+instance Show Y where+  show LumaY = "Luma" -  -- | 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 #-}+instance Show e => Show (Pixel Y e) where+  show (PixelY g) = "<Luma:("++show g++")>" -  -- | Convert an image to Luma image with Alpha.-  toImageYA :: (Array arr cs Double, Array arr YA Double) =>-               Image arr cs Double-            -> Image arr YA Double-  toImageYA = map toPixelYA-  {-# INLINE toImageYA #-}+instance (Elevator e, Typeable e) => ColorSpace Y e where+  type Components Y e = e+  broadcastC = PixelY+  {-# INLINE broadcastC #-}+  fromComponents = PixelY+  {-# INLINE fromComponents #-}+  toComponents (PixelY y) = y+  {-# INLINE toComponents #-}+  getPxC (PixelY y) LumaY = y+  {-# INLINE getPxC #-}+  setPxC _ LumaY y = PixelY y+  {-# INLINE setPxC #-}+  mapPxC f (PixelY y) = PixelY (f LumaY y)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}  -instance ColorSpace Y where-  type PixelElt Y e = e-  data Pixel Y e = PixelY !e deriving (Ord, Eq)+instance Functor (Pixel Y) where+  fmap f (PixelY y) = PixelY (f y)+  {-# INLINE fmap #-} -  fromChannel = PixelY-  {-# INLINE fromChannel #-} -  fromElt = PixelY-  {-# INLINE fromElt #-}+instance Applicative (Pixel Y) where+  pure = PixelY+  {-# INLINE pure #-}+  (PixelY fy) <*> (PixelY y) = PixelY (fy y)+  {-# INLINE (<*>) #-} -  toElt (PixelY y) = y-  {-# INLINE toElt #-} -  getPxCh (PixelY y) _ = y-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelY y) = PixelY (f Y y)-  {-# INLINE chOp #-}- -  pxOp !f (PixelY y) = PixelY (f y)-  {-# INLINE pxOp #-}+instance Foldable (Pixel Y) where+  foldr f !z (PixelY y) = f y z+  {-# INLINE foldr #-} -  chApp (PixelY fy) (PixelY y) = PixelY (fy y)-  {-# INLINE chApp #-} -  pxFoldMap f (PixelY y) = f y `M.mappend` M.mempty-  {-# INLINE pxFoldMap #-}+instance Monad (Pixel Y) where -  csColour _ = C.opaque C.darkgray+  return = PixelY+  {-# INLINE return #-}++  (>>=) (PixelY y) f = f y+  {-# INLINE (>>=) #-}+++instance Num e => Num (Pixel Y e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}    -instance ColorSpace YA where-  type PixelElt YA e = (e, e)-  data Pixel YA e = PixelYA !e !e deriving Eq+instance Fractional e => Fractional (Pixel Y e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-} -  fromChannel !e = PixelYA e e -  {-# INLINE fromChannel #-} -  fromElt !(g, a) = PixelYA g a-  {-# INLINE fromElt #-}+instance Floating e => Floating (Pixel Y e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-} -  toElt (PixelYA g a) = (g, a)-  {-# INLINE toElt  #-} -  getPxCh (PixelYA g _) YA      = g-  getPxCh (PixelYA _ a) AlphaYA = a-  {-# INLINE getPxCh  #-}-  -  chOp !f (PixelYA g a) = PixelYA (f YA g) (f AlphaYA a)-  {-# INLINE chOp #-}-  -  pxOp !f (PixelYA g a) = PixelYA (f g) (f a)-  {-# INLINE pxOp #-}+instance Storable e => Storable (Pixel Y e) where -  chApp (PixelYA fy fa) (PixelYA y a) = PixelYA (fy y) (fa a)-  {-# INLINE chApp #-}+  sizeOf _ = sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    y <- peek q+    return (PixelY y)+  poke p (PixelY y) = do+    q <- return $ castPtr p+    poke q y -  pxFoldMap f (PixelYA y a) = f y `M.mappend` f a-  {-# INLINE pxFoldMap #-} -  csColour AlphaYA = C.opaque C.gray-  csColour ch      = csColour $ opaque ch+++----------+--- YA ---+----------++-- | Luma with Alpha channel.+data YA = LumaYA  -- ^ Luma+        | AlphaYA -- ^ Alpha channel+        deriving (Eq, Enum, Typeable)++data instance Pixel YA e = PixelYA !e !e deriving Eq++-- | Conversion to Luma from another color space with Alpha channel.+class (ToY (Opaque cs), AlphaSpace cs Double) => ToYA cs where++  -- | Convert a pixel to Luma pixel with Alpha.+  toPixelYA :: Pixel cs Double -> Pixel YA Double+  toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px))+  {-# INLINE toPixelYA #-}++  -- | Convert an image to Luma image with Alpha.+  toImageYA :: (Array arr cs Double, Array arr YA Double) =>+               Image arr cs Double+            -> Image arr YA Double+  toImageYA = map toPixelYA+  {-# INLINE toImageYA #-}+++instance Show YA where+  show LumaYA  = "Luma"+  show AlphaYA = "Alpha"++instance (Elevator e, Typeable e) => ColorSpace YA e where+  type Components YA e = (e, e)+  broadcastC e = PixelYA e e+  {-# INLINE broadcastC #-}+  fromComponents (y, a) = PixelYA y a+  {-# INLINE fromComponents #-}+  toComponents (PixelYA y a) = (y, a)+  {-# INLINE toComponents #-}+  getPxC (PixelYA y _)  LumaYA = y+  getPxC (PixelYA _ a) AlphaYA = a+  {-# INLINE getPxC #-}+  setPxC (PixelYA _ a) LumaYA  y = PixelYA y a+  setPxC (PixelYA y _) AlphaYA a = PixelYA y a+  {-# INLINE setPxC #-}+  mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}      -instance Alpha YA where+instance (Elevator e, Typeable e) => AlphaSpace YA e where   type Opaque YA = Y    getAlpha (PixelYA _ a) = a   {-# INLINE getAlpha  #-}-  -  addAlpha !a (PixelY g) = PixelYA g a+  addAlpha !a (PixelY y) = PixelYA y a   {-# INLINE addAlpha #-}--  dropAlpha (PixelYA g _) = PixelY g+  dropAlpha (PixelYA y _) = PixelY y   {-# INLINE dropAlpha #-} -  opaque YA = Y-  opaque _  = error "Data.Image.ColorSpace.Luma (Alpha.opaque)"+  +instance Functor (Pixel YA) where+  fmap f (PixelYA y a) = PixelYA (f y) (f a)+  {-# INLINE fmap #-}  -instance Show Y where-  show Y = "Luma"-  +instance Applicative (Pixel YA) where+  pure !e = PixelYA e e+  {-# INLINE pure #-}+  (PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a)+  {-# INLINE (<*>) #-} -instance Show YA where-  show AlphaYA = "Alpha"-  show ch      = show $ opaque ch++instance Foldable (Pixel YA) where+  foldr f !z (PixelYA y a) = f y (f a z)+  {-# INLINE foldr #-}+++instance Num e => Num (Pixel YA e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}   +  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  +  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  +  abs         = liftA abs+  {-# INLINE abs #-}+  +  signum      = liftA signum+  {-# INLINE signum #-}+  +  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-} -instance Show e => Show (Pixel Y e) where-  show (PixelY g) = "<Luma:("++show g++")>"+instance Fractional e => Fractional (Pixel YA e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}  -instance Show e => Show (Pixel YA e) where-  show (PixelYA g a) = "<LumaA:("++show g++"|"++show a++")>"+instance Floating e => Floating (Pixel YA e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}  -instance Monad (Pixel Y) where+instance Storable e => Storable (Pixel YA e) where -  return = PixelY-  {-# INLINE return #-}+  sizeOf _ = 2 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    y <- peekElemOff q 0+    a <- peekElemOff q 1+    return (PixelYA y a)+  poke p (PixelYA y a) = do+    q <- return $ castPtr p+    pokeElemOff q 0 y+    pokeElemOff q 1 a -  (>>=) (PixelY y) f = f y-  {-# INLINE (>>=) #-}

@@ -2,42 +2,55 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Image.ColorSpace.RGB--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Graphics.Image.ColorSpace.RGB (-  RGB(..), RGBA(..), Pixel(..), -  ToRGB(..), ToRGBA(..)+  RGB(..), RGBA(..), Pixel(..),+  ToRGB(..), ToRGBA(..),+  -- RGB16 -- Experimental     ) where  import Prelude hiding (map)-import Graphics.Image.Interface+import Control.Applicative+import Foreign.Ptr+import Foreign.Storable+import Data.Foldable import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C +import Graphics.Image.Interface +-----------+--- RGB ---+-----------+ -- | 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)+instance Show RGB where+  show RedRGB   = "Red"+  show GreenRGB = "Green"+  show BlueRGB  = "Blue"  +data instance Pixel RGB e = PixelRGB !e !e !e deriving Eq++instance Show e => Show (Pixel RGB e) where+  show (PixelRGB r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"++ -- | Conversion to `RGB` color space.-class ColorSpace cs => ToRGB cs where+class ColorSpace cs Double => ToRGB cs where    -- | Convert to an `RGB` pixel.   toPixelRGB :: Pixel cs Double -> Pixel RGB Double@@ -50,8 +63,159 @@   {-# INLINE toImageRGB #-}  ++instance (Elevator e, Typeable e) => ColorSpace RGB e where+  type Components RGB e = (e, e, e)++  toComponents (PixelRGB r g b) = (r, g, b)+  {-# INLINE toComponents #-}+  +  fromComponents !(r, g, b) = PixelRGB r g b+  {-# INLINE fromComponents #-}++  broadcastC = pure+  {-# INLINE broadcastC #-}++  getPxC (PixelRGB r _ _) RedRGB   = r+  getPxC (PixelRGB _ g _) GreenRGB = g+  getPxC (PixelRGB _ _ b) BlueRGB  = b+  {-# INLINE getPxC #-}++  setPxC (PixelRGB _ g b) RedRGB   r = PixelRGB r g b+  setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b+  setPxC (PixelRGB r g _) BlueRGB  b = PixelRGB r g b+  {-# INLINE setPxC #-}++  mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b)+  {-# INLINE mapPxC #-}++  mapPx = fmap+  {-# INLINE mapPx #-}++  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}++  foldlPx = foldl'+  {-# INLINE foldlPx #-}+++++instance Functor (Pixel RGB) where+  fmap f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b)+  {-# INLINE fmap #-}+++instance Applicative (Pixel RGB) where+  pure !e = PixelRGB e e e+  {-# INLINE pure #-}+  (PixelRGB fr fg fb) <*> (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b)+  {-# INLINE (<*>) #-}+++instance Foldable (Pixel RGB) where+  foldr f !z (PixelRGB r g b) = f r (f g (f b z))+  {-# INLINE foldr #-}+++instance Num e => Num (Pixel RGB e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}+  ++instance Fractional e => Fractional (Pixel RGB e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel RGB e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance Storable e => Storable (Pixel RGB e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    r <- peek q+    g <- peekElemOff q 1+    b <- peekElemOff q 2+    return (PixelRGB r g b)+  poke p (PixelRGB r g b) = do+    q <- return $ castPtr p+    poke q r+    pokeElemOff q 1 g+    pokeElemOff q 2 b+++++------------+--- RGBA ---+------------+++-- | Red, Green and Blue color space with Alpha channel.+data RGBA = RedRGBA+          | GreenRGBA+          | BlueRGBA+          | AlphaRGBA deriving (Eq, Enum, Typeable)++instance Show RGBA where+  show RedRGBA   = "Red"+  show GreenRGBA = "Green"+  show BlueRGBA  = "Blue"+  show AlphaRGBA = "Alpha"++data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq+++instance Show e => Show (Pixel RGBA e) where+  show (PixelRGBA r g b a) = "<RGBA:("++show r++"|"++show g++"|"++show b++"|"++show a++")>"++ -- | Conversion to `RGBA` from another color space with Alpha channel.-class (ToRGB (Opaque cs), Alpha cs) => ToRGBA cs where+class (ToRGB (Opaque cs), AlphaSpace cs Double) => ToRGBA cs where    -- | Convert to an `RGBA` pixel.   toPixelRGBA :: Pixel cs Double -> Pixel RGBA Double@@ -65,113 +229,291 @@   toImageRGBA = map toPixelRGBA   {-# INLINE toImageRGBA #-} ++instance (Elevator e, Typeable e) => ColorSpace RGBA e where+  type Components RGBA e = (e, e, e, e)++  toComponents (PixelRGBA r g b a) = (r, g, b, a)+  {-# INLINE toComponents #-}   -instance ColorSpace RGB where-  type PixelElt RGB e = (e, e, e)-  data Pixel RGB e = PixelRGB !e !e !e deriving Eq+  fromComponents !(r, g, b, a) = PixelRGBA r g b a+  {-# INLINE fromComponents #-} -  fromChannel !e = PixelRGB e e e-  {-# INLINE fromChannel #-}+  broadcastC = pure+  {-# INLINE broadcastC #-} -  fromElt !(r, g, b) = PixelRGB r g b-  {-# INLINE fromElt #-}+  getPxC (PixelRGBA r _ _ _) RedRGBA   = r+  getPxC (PixelRGBA _ g _ _) GreenRGBA = g+  getPxC (PixelRGBA _ _ b _) BlueRGBA  = b+  getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a+  {-# INLINE getPxC #-} -  toElt (PixelRGB r g b) = (r, g, b)-  {-# INLINE toElt #-}+  setPxC (PixelRGBA _ g b a) RedRGBA   r = PixelRGBA r g b a+  setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a+  setPxC (PixelRGBA r g _ a) BlueRGBA  b = PixelRGBA r g b a+  setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a+  {-# INLINE setPxC #-} -  getPxCh (PixelRGB r _ _) RedRGB   = r-  getPxCh (PixelRGB _ g _) GreenRGB = g-  getPxCh (PixelRGB _ _ b) BlueRGB  = b-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b)-  {-# INLINE chOp #-}+  mapPxC f (PixelRGBA r g b a) =+    PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a)+  {-# INLINE mapPxC #-} -  pxOp !f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b)-  {-# INLINE pxOp #-}+  mapPx = fmap+  {-# INLINE mapPx #-} -  chApp (PixelRGB fr fg fb) (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b)-  {-# INLINE chApp #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-} -  pxFoldMap f (PixelRGB r g b) = f r `M.mappend` f g `M.mappend` f b-  {-# INLINE pxFoldMap #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-} -  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)-  data Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq+instance (Elevator e, Typeable e) => AlphaSpace RGBA e where+  type Opaque RGBA = RGB -  fromChannel !e = PixelRGBA e e e e-  {-# INLINE fromChannel #-}+  getAlpha (PixelRGBA _ _ _ a) = a+  {-# INLINE getAlpha #-}+  addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a+  {-# INLINE addAlpha #-}+  dropAlpha (PixelRGBA r g b _) = PixelRGB r g b+  {-# INLINE dropAlpha #-} -  fromElt (r, g, b, a) = PixelRGBA r g b a-  {-# INLINE fromElt #-} -  toElt (PixelRGBA r g b a) = (r, g, b, a)-  {-# INLINE toElt #-} -  getPxCh (PixelRGBA r _ _ _) RedRGBA   = r-  getPxCh (PixelRGBA _ g _ _) GreenRGBA = g-  getPxCh (PixelRGBA _ _ b _) BlueRGBA  = b-  getPxCh (PixelRGBA _ _ _ a) AlphaRGBA = a-  {-# INLINE getPxCh #-}+instance Functor (Pixel RGBA) where+  fmap f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a)+  {-# INLINE fmap #-}++instance Applicative (Pixel RGBA) where+  pure !e = PixelRGBA e e e e+  {-# INLINE pure #-}+  (PixelRGBA fr fg fb fa) <*> (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a)+  {-# INLINE (<*>) #-}++instance Foldable (Pixel RGBA) where+  foldr f !z (PixelRGBA r g b a) = f r (f g (f b (f a z)))+  {-# INLINE foldr #-}++++instance Num e => Num (Pixel RGBA e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}+++instance Fractional e => Fractional (Pixel RGBA e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel RGBA e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}++ +instance Storable e => Storable (Pixel RGBA e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    r <- peek q+    g <- peekElemOff q 1+    b <- peekElemOff q 2+    a <- peekElemOff q 3+    return (PixelRGBA r g b a)+  poke p (PixelRGBA r g b a) = do+    q <- return $ castPtr p+    poke q r+    pokeElemOff q 1 g+    pokeElemOff q 2 b+    pokeElemOff q 3 a++++++------------------------------------------------++-- -- | Red, Green and Blue color space.+-- data RGB16 = RedRGB16+--           | GreenRGB16+--           | BlueRGB16 deriving (Eq, Enum, Typeable, Show)+++-- --data instance Pixel RGB16 Word16 = PixelRGB16 !Word16 !Word16 !Word16 deriving Eq+-- data instance Pixel RGB16 Word16 = PixelRGB16+--                                    {-# UNPACK #-} !Word16+--                                    {-# UNPACK #-} !Word16+--                                    {-# UNPACK #-} !Word16 deriving Eq+-- --data instance Pixel RGB16 Word16 = PixelRGB16 ++-- instance ColorSpace RGB16 Word16 where+--   type Components RGB16 Word16 = (Word16, Word16, Word16)++--   broadcastC !e = PixelRGB16 e e e+--   {-# INLINE broadcastC #-}++--   toComponents (PixelRGB16 r g b) = (r, g, b)+--   {-# INLINE toComponents #-}   -  chOp !f (PixelRGBA r g b a) =-    PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a)-  {-# INLINE chOp #-}+--   fromComponents !(r, g, b) = PixelRGB16 r g b+--   {-# INLINE fromComponents #-} -  pxOp !f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a)-  {-# INLINE pxOp #-} -  chApp (PixelRGBA fr fg fb fa) (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a)-  {-# INLINE chApp #-}+--   getPxC (PixelRGB16 r _ _) RedRGB16   = r+--   getPxC (PixelRGB16 _ g _) GreenRGB16 = g+--   getPxC (PixelRGB16 _ _ b) BlueRGB16  = b+--   {-# INLINE getPxC #-} -  pxFoldMap f (PixelRGBA r g b a) = f r `M.mappend` f g `M.mappend` f b `M.mappend` f a-  {-# INLINE pxFoldMap #-}+--   setPxC (PixelRGB16 _ g b) RedRGB16   r = PixelRGB16 r g b+--   setPxC (PixelRGB16 r _ b) GreenRGB16 g = PixelRGB16 r g b+--   setPxC (PixelRGB16 r g _) BlueRGB16  b = PixelRGB16 r g b+--   {-# INLINE setPxC #-} -  csColour AlphaRGBA = C.opaque C.gray-  csColour ch        = csColour $ opaque ch+--   mapPxC f (PixelRGB16 r g b) = PixelRGB16 (f RedRGB16 r) (f GreenRGB16 g) (f BlueRGB16 b)+--   {-# INLINE mapPxC #-} +--   mapPx f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b)+--   {-# INLINE mapPx #-} -instance Alpha RGBA where-  type Opaque RGBA = RGB+--   zipWithPx f (PixelRGB16 r1 g1 b1) (PixelRGB16 r2 g2 b2) =+--     PixelRGB16 (f r1 r2) (f g1 g2) (f b1 b2)+--   {-# INLINE zipWithPx #-} -  getAlpha (PixelRGBA _ _ _ a) = a-  {-# INLINE getAlpha #-}+--   foldlPx f !acc (PixelRGB16 r g b) = f (f (f acc r) g) b+++-- instance Num (Pixel RGB16 Word16) where+--   (+)         = zipWithPx (+)   -  addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a-  {-# INLINE addAlpha #-}+--   (-)         = zipWithPx (-)+--   {-# INLINE (-) #-}+  +--   (*)         = zipWithPx (*)+--   {-# INLINE (*) #-}+  +--   abs         = mapPx abs+--   {-# INLINE abs #-}+  +--   signum      = mapPx signum+--   {-# INLINE signum #-}+  +--   fromInteger = broadcastC . fromInteger+--   {-# INLINE fromInteger #-} -  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 Fractional (Pixel RGB16 Word16) where+-- --   (/)          = zipWithPx (/)+-- --   {-# INLINE (/) #-}+  +-- --   recip        = mapPx recip+-- --   {-# INLINE recip #-} +-- --   fromRational = broadcastC . fromRational+-- --   {-# INLINE fromRational #-} -instance Show RGB where-  show RedRGB   = "Red"-  show GreenRGB = "Green"-  show BlueRGB  = "Blue" +-- -- instance Floating (Pixel RGB16 Word16) where+-- --   pi      = broadcastC pi+-- --   {-# INLINE pi #-} -instance Show RGBA where-  show AlphaRGBA = "Alpha"-  show ch        = show $ opaque ch+-- --   exp     = mapPx exp+-- --   {-# INLINE exp #-} - -instance Show e => Show (Pixel RGB e) where-  show (PixelRGB r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"+-- --   log     = mapPx log+-- --   {-# INLINE log #-}+  +-- --   sin     = mapPx sin+-- --   {-# INLINE sin #-}+  +-- --   cos     = mapPx cos+-- --   {-# INLINE cos #-}+  +-- --   asin    = mapPx asin+-- --   {-# INLINE asin #-}+  +-- --   atan    = mapPx atan+-- --   {-# INLINE atan #-}+  +-- --   acos    = mapPx acos+-- --   {-# INLINE acos #-}+  +-- --   sinh    = mapPx sinh+-- --   {-# INLINE sinh #-}+  +-- --   cosh    = mapPx cosh+-- --   {-# INLINE cosh #-}+  +-- --   asinh   = mapPx asinh+-- --   {-# INLINE asinh #-}+  +-- --   atanh   = mapPx atanh+-- --   {-# INLINE atanh #-}+  +-- --   acosh   = mapPx acosh+-- --   {-# INLINE acosh #-}  -instance Show e => Show (Pixel RGBA e) where-  show (PixelRGBA r g b a) = "<RGBA:("++show r++"|"++show g++"|"++show b++"|"++show a++")>"+-- -- instance Show RGB16 where+-- --   show RedRGB16   = "Red"+-- --   show GreenRGB16 = "Green"+-- --   show BlueRGB16  = "Blue" +-- -- instance Show (Pixel RGB16 Word16) where+-- --   show (PixelRGB16 r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"  +-- -- instance Storable (Pixel RGB16 Word16) where++-- --   sizeOf _ = 3 * sizeOf (undefined :: Word16)+-- --   alignment _ = alignment (undefined :: Word16)+-- --   peek p = do+-- --     q <- return $ castPtr p+-- --     r <- peek q+-- --     g <- peekElemOff q 1+-- --     b <- peekElemOff q 2+-- --     return (PixelRGB16 r g b)+-- --   poke p (PixelRGB16 r g b) = do+-- --     q <- return $ castPtr p+-- --     poke q r+-- --     pokeElemOff q 1 g+-- --     pokeElemOff q 2 b

@@ -2,10 +2,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Image.ColorSpace.YCbCr--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -17,20 +19,159 @@   ) where  import Prelude hiding (map)-import Graphics.Image.Interface+import Control.Applicative+import Data.Foldable import Data.Typeable (Typeable)-import qualified Data.Monoid as M (mappend)-import qualified Data.Colour as C-import qualified Data.Colour.Names as C+import Foreign.Ptr+import Foreign.Storable +import Graphics.Image.Interface ++-------------+--- YCbCr ---+-------------++ -- | 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 instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq ++instance Show YCbCr where+  show LumaYCbCr  = "Luma"+  show CBlueYCbCr = "Blue Chroma"+  show CRedYCbCr  = "Red Chroma"+++instance Show e => Show (Pixel YCbCr e) where+  show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>"+++instance (Elevator e, Typeable e) => ColorSpace YCbCr e where+  type Components YCbCr e = (e, e, e)++  broadcastC !e = PixelYCbCr e e e+  {-# INLINE broadcastC #-}+  fromComponents !(y, b, r) = PixelYCbCr y b r+  {-# INLINE fromComponents #-}+  toComponents (PixelYCbCr y b r) = (y, b, r)+  {-# INLINE toComponents #-}+  getPxC (PixelYCbCr y _ _) LumaYCbCr  = y+  getPxC (PixelYCbCr _ b _) CBlueYCbCr = b+  getPxC (PixelYCbCr _ _ r) CRedYCbCr  = r+  {-# INLINE getPxC #-}+  setPxC (PixelYCbCr _ b r) LumaYCbCr  y = PixelYCbCr y b r+  setPxC (PixelYCbCr y _ r) CBlueYCbCr b = PixelYCbCr y b r+  setPxC (PixelYCbCr y b _) CRedYCbCr  r = PixelYCbCr y b r+  {-# INLINE setPxC #-}+  mapPxC f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}+++instance Functor (Pixel YCbCr) where+  fmap f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r)+  {-# INLINE fmap #-}+++instance Applicative (Pixel YCbCr) where+  pure !e = PixelYCbCr e e e+  {-# INLINE pure #-}+  (PixelYCbCr fy fb fr) <*> (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r)+  {-# INLINE (<*>) #-}+++instance Foldable (Pixel YCbCr) where+  foldr f !z (PixelYCbCr y b r) = f y (f b (f r z))+  {-# INLINE foldr #-}+++instance Num e => Num (Pixel YCbCr e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}+++instance Fractional e => Fractional (Pixel YCbCr e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel YCbCr e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}++++instance Storable e => Storable (Pixel YCbCr e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    y <- peek q+    b <- peekElemOff q 1+    r <- peekElemOff q 2+    return (PixelYCbCr y b r)+  poke p (PixelYCbCr y b r) = do+    q <- return $ castPtr p+    pokeElemOff q 0 y+    pokeElemOff q 1 b+    pokeElemOff q 2 r+++--------------+--- YCbCrA ---+--------------++ -- | YCbCr color space with Alpha channel. data YCbCrA = LumaYCbCrA  -- ^ Luma component (commonly denoted as __Y'__)             | CBlueYCbCrA -- ^ Blue difference chroma component@@ -38,9 +179,52 @@             | AlphaYCbCrA -- ^ Alpha component.             deriving (Eq, Enum, Typeable) +data instance Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq ++instance Show YCbCrA where+  show LumaYCbCrA  = "Luma"+  show CBlueYCbCrA = "Blue Chroma"+  show CRedYCbCrA  = "Red Chroma"+  show AlphaYCbCrA = "Alpha"++ +instance Show e => Show (Pixel YCbCrA e) where+  show (PixelYCbCrA y b r a) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show a++")>"+++instance (Elevator e, Typeable e) => ColorSpace YCbCrA e where+  type Components YCbCrA e = (e, e, e, e)++  broadcastC !e = PixelYCbCrA e e e e+  {-# INLINE broadcastC #-}+  fromComponents !(y, b, r, a) = PixelYCbCrA y b r a+  {-# INLINE fromComponents #-}+  toComponents (PixelYCbCrA y b r a) = (y, b, r, a)+  {-# INLINE toComponents #-}+  getPxC (PixelYCbCrA y _ _ _) LumaYCbCrA  = y+  getPxC (PixelYCbCrA _ b _ _) CBlueYCbCrA = b+  getPxC (PixelYCbCrA _ _ r _) CRedYCbCrA  = r+  getPxC (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a+  {-# INLINE getPxC #-}+  setPxC (PixelYCbCrA _ b r a) LumaYCbCrA  y = PixelYCbCrA y b r a+  setPxC (PixelYCbCrA y _ r a) CBlueYCbCrA b = PixelYCbCrA y b r a+  setPxC (PixelYCbCrA y b _ a) CRedYCbCrA  r = PixelYCbCrA y b r a+  setPxC (PixelYCbCrA y b r _) AlphaYCbCrA a = PixelYCbCrA y b r a+  {-# INLINE setPxC #-}+  mapPxC f (PixelYCbCrA y b r a) =+    PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a)+  {-# INLINE mapPxC #-}+  mapPx = fmap+  {-# INLINE mapPx #-}+  zipWithPx = liftA2+  {-# INLINE zipWithPx #-}+  foldlPx = foldl'+  {-# INLINE foldlPx #-}++   -- | Conversion to `YCbCr` color space.-class ColorSpace cs => ToYCbCr cs where+class ColorSpace cs Double => ToYCbCr cs where    -- | Convert to an `YCbCr` pixel.   toPixelYCbCr :: Pixel cs Double -> Pixel YCbCr Double@@ -54,7 +238,7 @@   -- | Conversion to `YCbCrA` from another color space with Alpha channel.-class (ToYCbCr (Opaque cs), Alpha cs) => ToYCbCrA cs where+class (ToYCbCr (Opaque cs), AlphaSpace cs Double) => ToYCbCrA cs where    -- | Convert to an `YCbCrA` pixel.   toPixelYCbCrA :: Pixel cs Double -> Pixel YCbCrA Double@@ -69,112 +253,104 @@   {-# INLINE toImageYCbCrA #-}    -instance ColorSpace YCbCr where-  type PixelElt YCbCr e = (e, e, e)-  data Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq -  fromChannel !e = PixelYCbCr e e e-  {-# INLINE fromChannel #-}--  fromElt !(y, b, r) = PixelYCbCr y b r-  {-# INLINE fromElt #-}--  toElt (PixelYCbCr y b r) = (y, b, r)-  {-# INLINE toElt #-}--  getPxCh (PixelYCbCr y _ _) LumaYCbCr  = y-  getPxCh (PixelYCbCr _ b _) CBlueYCbCr = b-  getPxCh (PixelYCbCr _ _ r) CRedYCbCr  = r-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r)-  {-# INLINE chOp #-}--  pxOp !f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r)-  {-# INLINE pxOp #-}--  chApp (PixelYCbCr fy fb fr) (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelYCbCr y b r) = f y `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)-  data Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq--  fromChannel !e = PixelYCbCrA e e e e-  {-# INLINE fromChannel #-}--  fromElt (y, b, r, a) = PixelYCbCrA y b r a-  {-# INLINE fromElt #-}--  toElt (PixelYCbCrA y b r a) = (y, b, r, a)-  {-# INLINE toElt #-}--  getPxCh (PixelYCbCrA y _ _ _) LumaYCbCrA  = y-  getPxCh (PixelYCbCrA _ b _ _) CBlueYCbCrA = b-  getPxCh (PixelYCbCrA _ _ r _) CRedYCbCrA  = r-  getPxCh (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a-  {-# INLINE getPxCh #-}-  -  chOp !f (PixelYCbCrA y b r a) =-    PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a)-  {-# INLINE chOp #-}--  pxOp !f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a)-  {-# INLINE pxOp #-}--  chApp (PixelYCbCrA fy fb fr fa) (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a)-  {-# INLINE chApp #-}--  pxFoldMap f (PixelYCbCrA y b r a) = f y `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+instance (Elevator e, Typeable e) => AlphaSpace YCbCrA e where   type Opaque YCbCrA = YCbCr    getAlpha (PixelYCbCrA _ _ _ a) = a   {-# INLINE getAlpha #-}-     addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a   {-# INLINE addAlpha #-}-   dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r   {-# INLINE dropAlpha #-} -  opaque LumaYCbCrA  = LumaYCbCr-  opaque CBlueYCbCrA = CBlueYCbCr-  opaque CRedYCbCrA  = CRedYCbCr-  opaque AlphaYCbCrA = error "Data.Image.ColorSpace.YCbCr (Alpha.opaque)" +instance Functor (Pixel YCbCrA) where+  fmap f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a)+  {-# INLINE fmap #-} -instance Show YCbCr where-  show LumaYCbCr  = "Luma"-  show CBlueYCbCr = "Blue Chroma"-  show CRedYCbCr  = "Red Chroma" +instance Applicative (Pixel YCbCrA) where+  pure !e = PixelYCbCrA e e e e+  {-# INLINE pure #-}+  (PixelYCbCrA fy fb fr fa) <*> (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a)+  {-# INLINE (<*>) #-} -instance Show YCbCrA where-  show AlphaYCbCrA = "Alpha"-  show ch          = show $ opaque ch - -instance Show e => Show (Pixel YCbCr e) where-  show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>"+instance Foldable (Pixel YCbCrA) where+  foldr f !z (PixelYCbCrA y b r a) = f y (f b (f r (f a z)))+  {-# INLINE foldr #-}  -instance Show e => Show (Pixel YCbCrA e) where-  show (PixelYCbCrA y b r a) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show a++")>"+instance Num e => Num (Pixel YCbCrA e) where+  (+)         = liftA2 (+)+  {-# INLINE (+) #-}+  (-)         = liftA2 (-)+  {-# INLINE (-) #-}+  (*)         = liftA2 (*)+  {-# INLINE (*) #-}+  abs         = liftA abs+  {-# INLINE abs #-}+  signum      = liftA signum+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-} ++instance Fractional e => Fractional (Pixel YCbCrA e) where+  (/)          = liftA2 (/)+  {-# INLINE (/) #-}+  recip        = liftA recip+  {-# INLINE recip #-}+  fromRational = pure . fromRational+  {-# INLINE fromRational #-}+++instance Floating e => Floating (Pixel YCbCrA e) where+  pi      = pure pi+  {-# INLINE pi #-}+  exp     = liftA exp+  {-# INLINE exp #-}+  log     = liftA log+  {-# INLINE log #-}+  sin     = liftA sin+  {-# INLINE sin #-}+  cos     = liftA cos+  {-# INLINE cos #-}+  asin    = liftA asin+  {-# INLINE asin #-}+  atan    = liftA atan+  {-# INLINE atan #-}+  acos    = liftA acos+  {-# INLINE acos #-}+  sinh    = liftA sinh+  {-# INLINE sinh #-}+  cosh    = liftA cosh+  {-# INLINE cosh #-}+  asinh   = liftA asinh+  {-# INLINE asinh #-}+  atanh   = liftA atanh+  {-# INLINE atanh #-}+  acosh   = liftA acosh+  {-# INLINE acosh #-}+++instance Storable e => Storable (Pixel YCbCrA e) where++  sizeOf _ = 3 * sizeOf (undefined :: e)+  alignment _ = alignment (undefined :: e)+  peek p = do+    q <- return $ castPtr p+    y <- peekElemOff q 0+    b <- peekElemOff q 1+    r <- peekElemOff q 2+    a <- peekElemOff q 3+    return (PixelYCbCrA y b r a)+  poke p (PixelYCbCrA y b r a) = do+    q <- return $ castPtr p+    poke q y+    pokeElemOff q 1 b+    pokeElemOff q 2 r+    pokeElemOff q 3 a  

@@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module      : Graphics.Image.IO--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -41,10 +41,6 @@ import Data.Maybe (fromMaybe)  import qualified Data.ByteString as B (readFile)-import Graphics.Image.ColorSpace-import Graphics.Image.Interface-import Graphics.Image.IO.Base-import Graphics.Image.IO.Formats import qualified Data.ByteString.Lazy as BL (writeFile, hPut) import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) import System.FilePath (takeExtension, (</>))@@ -52,6 +48,10 @@ import System.Process (readProcess) import Control.Exception (bracket) +import Graphics.Image.ColorSpace+import Graphics.Image.Interface+import Graphics.Image.IO.Base+import Graphics.Image.IO.Formats  -- | External viewing application to use for displaying images. data ExternalViewer =@@ -111,12 +111,12 @@ -- Attempt to read an image in a particular color space that is not supported by -- the format, will result in a compile error. Refer to 'Readable' class for all -- images that can be decoded.-readImageExact :: Readable img format =>+readImageExact :: Readable (Image arr cs e) format =>                   format                   -- ^ A file format that an image should be read as. See                    -- <#g:4 Supported Image Formats>                -> FilePath -- ^ Location of an image.-               -> IO (Either String img)+               -> IO (Either String (Image arr cs e)) readImageExact format path = fmap (decode format) (B.readFile path)  @@ -144,20 +144,20 @@ -- options. Precision and color space, that an image will be written as, 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 =>+writeImageExact :: Writable (Image arr cs e) format =>                    format                    -- ^ A file format that an image should be saved in. See                    -- <#g:4 Supported Image Formats>                 -> [SaveOption format] -- ^ A list of format specific options.                 -> FilePath -- ^ Location where an image should be written.-                -> img -- ^ An image to write. Can be a list of images in case+                -> (Image arr cs e) -- ^ An image to write. Can be a list of images in case                        -- of formats supporting animation.                 -> IO () writeImageExact format opts path = BL.writeFile path . encode format opts    -{- | An image is written as a @.tiff@ file into an operating system's temporary-directory and passed as an argument to the external viewer program. -}+-- | An image is written as a @.tiff@ file into an operating system's temporary+-- directory and passed as an argument to the external viewer program. displayImageUsing :: Writable (Image arr cs e) TIF =>                      ExternalViewer -- ^ External viewer to use                   -> Bool -- ^ Should the call be blocking

@@ -24,11 +24,13 @@   SaveOption(..),   ) where +import Prelude as P import GHC.Float import Data.Either import qualified Data.Monoid as M (mempty) import Graphics.Image.ColorSpace-import Graphics.Image.Interface hiding (map)+import Graphics.Image.Interface as I+import Graphics.Image.Interface.Vector import Graphics.Image.IO.Base import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)@@ -36,7 +38,7 @@ import qualified Codec.Picture.Jpg as JP import qualified Codec.Picture.Types as JP import qualified Codec.Picture.ColorQuant as JP-+import qualified Data.Vector.Storable as V  -- | Bitmap image with @.bmp@ extension. data BMP = BMP@@ -119,13 +121,13 @@ -- Y -> Y (Double)  instance Convertible JP.Pixel8 (Pixel Y Double) where-  convert = toDouble . PixelY+  convert = fmap toDouble . PixelY  instance Convertible JP.Pixel16 (Pixel Y Double) where-  convert = toDouble . PixelY+  convert = fmap toDouble . PixelY  instance Convertible JP.PixelF (Pixel Y Double) where-  convert = toDouble . PixelY+  convert = fmap toDouble . PixelY  instance Convertible JP.PixelYA8 (Pixel Y Double) where   convert = convert . JP.dropTransparency@@ -143,10 +145,10 @@   convert = addAlpha 1 . convert  instance Convertible JP.PixelYA8 (Pixel YA Double) where-  convert (JP.PixelYA8 y a) = toDouble (PixelYA y a)+  convert (JP.PixelYA8 y a) = fmap toDouble (PixelYA y a)  instance Convertible JP.PixelYA16 (Pixel YA Double) where-  convert (JP.PixelYA16 y a) = toDouble (PixelYA y a)+  convert (JP.PixelYA16 y a) = fmap toDouble (PixelYA y a)   -- Color -> Y (Double)@@ -167,10 +169,10 @@   convert = toPixelY . (convert :: JP.PixelRGBF -> Pixel RGB Double)  instance Convertible JP.PixelCMYK8 (Pixel Y Double) where-  convert = toPixelY . toDouble . (convert :: JP.PixelCMYK8 -> Pixel CMYK Word8)+  convert = toPixelY . fmap toDouble . (convert :: JP.PixelCMYK8 -> Pixel CMYK Word8)  instance Convertible JP.PixelCMYK16 (Pixel Y Double) where-  convert = toPixelY . toDouble . (convert :: JP.PixelCMYK16 -> Pixel CMYK Word16)+  convert = toPixelY . fmap toDouble . (convert :: JP.PixelCMYK16 -> Pixel CMYK Word16)  instance Convertible JP.PixelYCbCr8 (Pixel Y Double) where   convert = convert . JP.computeLuma@@ -206,13 +208,13 @@ -- Y -> RGB (Double)  instance Convertible JP.Pixel8 (Pixel RGB Double) where-  convert = toDouble . fromChannel+  convert = broadcastC . toDouble  instance Convertible JP.Pixel16 (Pixel RGB Double) where-  convert = toDouble . fromChannel+  convert = broadcastC . toDouble  instance Convertible JP.PixelF (Pixel RGB Double) where-  convert = toDouble . fromChannel+  convert = broadcastC . toDouble  instance Convertible JP.PixelYA8 (Pixel RGB Double) where   convert = convert . JP.dropTransparency@@ -223,10 +225,10 @@ -- Color -> RGB (Double)  instance Convertible JP.PixelRGB8 (Pixel RGB Double) where-  convert (JP.PixelRGB8 r g b) = toDouble $ PixelRGB r g b+  convert (JP.PixelRGB8 r g b) = fmap toDouble $ PixelRGB r g b  instance Convertible JP.PixelRGB16 (Pixel RGB Double) where-  convert (JP.PixelRGB16 r g b) = toDouble $ PixelRGB r g b+  convert (JP.PixelRGB16 r g b) = fmap toDouble $ PixelRGB r g b  instance Convertible JP.PixelRGBA8 (Pixel RGB Double) where   convert = convert . JP.dropTransparency@@ -285,10 +287,10 @@   convert = addAlpha 1 . convert    instance Convertible JP.PixelRGBA8 (Pixel RGBA Double) where-  convert (JP.PixelRGBA8 r g b a) = toDouble $ PixelRGBA r g b a+  convert (JP.PixelRGBA8 r g b a) = fmap toDouble $ PixelRGBA r g b a    instance Convertible JP.PixelRGBA16 (Pixel RGBA Double) where-  convert (JP.PixelRGBA16 r g b a) = toDouble $ PixelRGBA r g b a+  convert (JP.PixelRGBA16 r g b a) = fmap toDouble $ PixelRGBA r g b a   ---- to JuicyPixels -----@@ -391,232 +393,242 @@  -- BMP Format Reading -instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) BMP where+instance Readable (Image VS Binary Bit) BMP where   decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeBitmap -instance Array arr Y Word8 => Readable (Image arr Y Word8) BMP where+instance Readable (Image VS Y Word8) BMP where   decode _ = jpImageY8ToImage . JP.decodeBitmap -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) BMP where+instance Readable (Image VS RGB Word8) BMP where   decode _ = jpImageRGB8ToImage . JP.decodeBitmap -instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) BMP where+instance Readable (Image VS RGBA Word8) BMP where   decode _ = jpImageRGBA8ToImage . JP.decodeBitmap -instance Array arr Y Double => Readable (Image arr Y Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap -instance Array arr YA Double => Readable (Image arr YA Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap -instance Array arr RGB Double => Readable (Image arr RGB Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap--instance Array arr RGBA Double => Readable (Image arr RGBA Double) BMP where-  decode _ = jpDynamicImageToImage . JP.decodeBitmap-- -- GIF Format Reading -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) GIF where+instance Readable (Image VS RGB Word8) GIF where   decode _ = jpImageRGB8ToImage . JP.decodeGif -instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) GIF where+instance Readable (Image VS RGBA Word8) GIF where   decode _ = jpImageRGBA8ToImage . JP.decodeGif -instance Array arr Y Double => Readable (Image arr Y Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif -instance Array arr YA Double => Readable (Image arr YA Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif--instance Array arr RGB Double => Readable (Image arr RGB Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif--instance Array arr RGBA Double => Readable (Image arr RGBA Double) GIF where-  decode _ = jpDynamicImageToImage . JP.decodeGif- -- List of GIF Format frames Reading  decodeGifs :: (Either String JP.DynamicImage -> Either String img)            -> B.ByteString -> Either String [img] decodeGifs decoder = either Left decodeLS . JP.decodeGifImages where     decodeLS ls = if null errs then Right imgs else Left $ unlines errs where-      (errs, imgs) = partitionEithers $ map (decoder . Right) ls+      (errs, imgs) = partitionEithers $ P.map (decoder . Right) ls -instance Array arr RGB Word8 => Readable [Image arr RGB Word8] [GIF] where+instance Readable [Image VS RGB Word8] [GIF] where   decode _ = decodeGifs jpImageRGB8ToImage -instance Array arr RGBA Word8 => Readable [Image arr RGBA Word8] [GIF] where+instance Readable [Image VS RGBA Word8] [GIF] where   decode _ = decodeGifs jpImageRGBA8ToImage -instance Array arr Y Double => Readable [Image arr Y Double] [GIF] where-  decode _ = decodeGifs jpDynamicImageToImage -instance Array arr YA Double => Readable [Image arr YA Double] [GIF] where-  decode _ = decodeGifs jpDynamicImageToImage--instance Array arr RGB Double => Readable [Image arr RGB Double] [GIF] where-  decode _ = decodeGifs jpDynamicImageToImage--instance Array arr RGBA Double => Readable [Image arr RGBA Double] [GIF] where-  decode _ = decodeGifs jpDynamicImageToImage-  -- -- HDR Format Reading -instance Array arr RGB Float => Readable (Image arr RGB Float) HDR where+instance Readable (Image VS RGB Float) HDR where   decode _ = jpImageRGBFToImage . JP.decodeHDR -instance Array arr Y Double => Readable (Image arr Y Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR -instance Array arr YA Double => Readable (Image arr YA Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR--instance Array arr RGB Double => Readable (Image arr RGB Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR--instance Array arr RGBA Double => Readable (Image arr RGBA Double) HDR where-  decode _ = jpDynamicImageToImage . JP.decodeHDR-- -- JPG Format Reading -instance Array arr Y Word8 => Readable (Image arr Y Word8) JPG where+instance Readable (Image VS Y Word8) JPG where   decode _ = jpImageY8ToImage . JP.decodeJpeg -instance Array arr YA Word8 => Readable (Image arr YA Word8) JPG where+instance Readable (Image VS YA Word8) JPG where   decode _ = jpImageYA8ToImage . JP.decodeJpeg -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) JPG where+instance Readable (Image VS RGB Word8) JPG where   decode _ = jpImageRGB8ToImage . JP.decodeJpeg -instance Array arr CMYK Word8 => Readable (Image arr CMYK Word8) JPG where+instance Readable (Image VS CMYK Word8) JPG where   decode _ = jpImageCMYK8ToImage . JP.decodeJpeg -instance Array arr YCbCr Word8 => Readable (Image arr YCbCr Word8) JPG where+instance Readable (Image VS YCbCr Word8) JPG where   decode _ = jpImageYCbCr8ToImage . JP.decodeJpeg -instance Array arr Y Double => Readable (Image arr Y Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg -instance Array arr YA Double => Readable (Image arr YA Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg--instance Array arr RGB Double => Readable (Image arr RGB Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg--instance Array arr RGBA Double => Readable (Image arr RGBA Double) JPG where-  decode _ = jpDynamicImageToImage . JP.decodeJpeg-- -- PNG Format Reading -instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) PNG where+instance Readable (Image VS Binary Bit) PNG where   decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodePng -instance Array arr Y Word8 => Readable (Image arr Y Word8) PNG where+instance Readable (Image VS Y Word8) PNG where   decode _ = jpImageY8ToImage . JP.decodePng -instance Array arr Y Word16 => Readable (Image arr Y Word16) PNG where+instance Readable (Image VS Y Word16) PNG where   decode _ = jpImageY16ToImage . JP.decodePng -instance Array arr YA Word8 => Readable (Image arr YA Word8) PNG where+instance Readable (Image VS YA Word8) PNG where   decode _ = jpImageYA8ToImage . JP.decodePng -instance Array arr YA Word16 => Readable (Image arr YA Word16) PNG where+instance Readable (Image VS YA Word16) PNG where   decode _ = jpImageYA16ToImage . JP.decodePng -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) PNG where+instance Readable (Image VS RGB Word8) PNG where   decode _ = jpImageRGB8ToImage . JP.decodePng -instance Array arr RGB Word16 => Readable (Image arr RGB Word16) PNG where+instance Readable (Image VS RGB Word16) PNG where   decode _ = jpImageRGB16ToImage . JP.decodePng -instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) PNG where+instance Readable (Image VS RGBA Word8) PNG where   decode _ = jpImageRGBA8ToImage . JP.decodePng -instance Array arr RGBA Word16 => Readable (Image arr RGBA Word16) PNG where+instance Readable (Image VS RGBA Word16) PNG where   decode _ = jpImageRGBA16ToImage . JP.decodePng -instance Array arr Y Double => Readable (Image arr Y Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng -instance Array arr YA Double => Readable (Image arr YA Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng--instance Array arr RGB Double => Readable (Image arr RGB Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng--instance Array arr RGBA Double => Readable (Image arr RGBA Double) PNG where-  decode _ = jpDynamicImageToImage . JP.decodePng-- -- TGA Format Reading -instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) TGA where+instance Readable (Image VS Binary Bit) TGA where   decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTga -instance Array arr Y Word8 => Readable (Image arr Y Word8) TGA where+instance Readable (Image VS Y Word8) TGA where   decode _ = jpImageY8ToImage . JP.decodeTga -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) TGA where+instance Readable (Image VS RGB Word8) TGA where   decode _ = jpImageRGB8ToImage . JP.decodeTga -instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) TGA where+instance Readable (Image VS RGBA Word8) TGA where   decode _ = jpImageRGBA8ToImage . JP.decodeTga -instance Array arr Y Double => Readable (Image arr Y Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga -instance Array arr YA Double => Readable (Image arr YA Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga--instance Array arr RGB Double => Readable (Image arr RGB Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga--instance Array arr RGBA Double => Readable (Image arr RGBA Double) TGA where-  decode _ = jpDynamicImageToImage . JP.decodeTga-- -- TIF Format Reading -instance (Array arr Y Word8, Array arr Binary Bit) => Readable (Image arr Binary Bit) TIF where+instance Readable (Image VS Binary Bit) TIF where   decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTiff -instance Array arr Y Word8 => Readable (Image arr Y Word8) TIF where+instance Readable (Image VS Y Word8) TIF where   decode _ = jpImageY8ToImage . JP.decodeTiff -instance Array arr Y Word16 => Readable (Image arr Y Word16) TIF where+instance Readable (Image VS Y Word16) TIF where   decode _ = jpImageY16ToImage . JP.decodeTiff -instance Array arr YA Word8 => Readable (Image arr YA Word8) TIF where+instance Readable (Image VS YA Word8) TIF where   decode _ = jpImageYA8ToImage . JP.decodeTiff -instance Array arr YA Word16 => Readable (Image arr YA Word16) TIF where+instance Readable (Image VS YA Word16) TIF where   decode _ = jpImageYA16ToImage . JP.decodeTiff -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) TIF where+instance Readable (Image VS RGB Word8) TIF where   decode _ = jpImageRGB8ToImage . JP.decodeTiff -instance Array arr RGB Word16 => Readable (Image arr RGB Word16) TIF where+instance Readable (Image VS RGB Word16) TIF where   decode _ = jpImageRGB16ToImage . JP.decodeTiff -instance Array arr RGBA Word8 => Readable (Image arr RGBA Word8) TIF where+instance Readable (Image VS RGBA Word8) TIF where   decode _ = jpImageRGBA8ToImage . JP.decodeTiff -instance Array arr RGBA Word16 => Readable (Image arr RGBA Word16) TIF where+instance Readable (Image VS RGBA Word16) TIF where   decode _ = jpImageRGBA16ToImage . JP.decodeTiff -instance Array arr CMYK Word8 => Readable (Image arr CMYK Word8) TIF where+instance Readable (Image VS CMYK Word8) TIF where   decode _ = jpImageCMYK8ToImage . JP.decodeTiff -instance Array arr CMYK Word16 => Readable (Image arr CMYK Word16) TIF where+instance Readable (Image VS CMYK Word16) TIF where   decode _ = jpImageCMYK16ToImage . JP.decodeTiff  +-- To Double precision safe conversion++instance Array arr Y Double => Readable (Image arr Y Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap++instance Array arr YA Double => Readable (Image arr YA Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap++instance Array arr RGB Double => Readable (Image arr RGB Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap++instance Array arr RGBA Double => Readable (Image arr RGBA Double) BMP where+  decode _ = jpDynamicImageToImage . JP.decodeBitmap+++instance Array arr Y Double => Readable (Image arr Y Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++instance Array arr YA Double => Readable (Image arr YA Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++instance Array arr RGB Double => Readable (Image arr RGB Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif++instance Array arr RGBA Double => Readable (Image arr RGBA Double) GIF where+  decode _ = jpDynamicImageToImage . JP.decodeGif+++instance Array arr Y Double => Readable [Image arr Y Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage++instance Array arr YA Double => Readable [Image arr YA Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage++instance Array arr RGB Double => Readable [Image arr RGB Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage++instance Array arr RGBA Double => Readable [Image arr RGBA Double] [GIF] where+  decode _ = decodeGifs jpDynamicImageToImage+++instance Array arr Y Double => Readable (Image arr Y Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR++instance Array arr YA Double => Readable (Image arr YA Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR++instance Array arr RGB Double => Readable (Image arr RGB Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR++instance Array arr RGBA Double => Readable (Image arr RGBA Double) HDR where+  decode _ = jpDynamicImageToImage . JP.decodeHDR+++instance Array arr Y Double => Readable (Image arr Y Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg++instance Array arr YA Double => Readable (Image arr YA Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg++instance Array arr RGB Double => Readable (Image arr RGB Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg++instance Array arr RGBA Double => Readable (Image arr RGBA Double) JPG where+  decode _ = jpDynamicImageToImage . JP.decodeJpeg+++instance Array arr Y Double => Readable (Image arr Y Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng++instance Array arr YA Double => Readable (Image arr YA Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng++instance Array arr RGB Double => Readable (Image arr RGB Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng++instance Array arr RGBA Double => Readable (Image arr RGBA Double) PNG where+  decode _ = jpDynamicImageToImage . JP.decodePng+++instance Array arr Y Double => Readable (Image arr Y Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++instance Array arr YA Double => Readable (Image arr YA Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++instance Array arr RGB Double => Readable (Image arr RGB Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++instance Array arr RGBA Double => Readable (Image arr RGBA Double) TGA where+  decode _ = jpDynamicImageToImage . JP.decodeTga++ instance Array arr Y Double => Readable (Image arr Y Double) TIF where   decode _ = jpDynamicImageToImage . JP.decodeTiff @@ -633,118 +645,111 @@  -- General decoding and helper functions -jpImageToImage :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) =>-                  JP.Image jpx -> Image arr cs e-jpImageToImage jimg = makeImage (JP.imageHeight jimg, JP.imageWidth jimg) getPx+jpImageToImageUnsafe :: (Array VS cs e, JP.Pixel jpx) =>+                  JP.Image jpx -> Image VS cs e+jpImageToImageUnsafe (JP.Image n m v) = fromStorableVector (m, n) $ V.unsafeCast v++++jpImageToImageSafe :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) =>+                      JP.Image jpx -> Image arr cs e+jpImageToImageSafe jimg = makeImage (JP.imageHeight jimg, JP.imageWidth jimg) getPx   where getPx (y, x) = convert $ JP.pixelAt jimg x y  -jpImageY8ToImage :: Array arr Y Word8 =>-                    Either String JP.DynamicImage -> Either String (Image arr Y Word8)-jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImage jimg)+jpImageY8ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word8)+jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageY8ToImage jimg = jpCSError "Y8 (Pixel Y Word8)" jimg  -jpImageY16ToImage :: Array arr Y Word16 =>-                     Either String JP.DynamicImage -> Either String (Image arr Y Word16)-jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImage jimg)+jpImageY16ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word16)+jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageY16ToImage jimg = jpCSError "Y16 (Pixel Y Word16)" jimg  {- -- No JuicyPixels images are actually read in this type-jpImageYFToImage :: Array arr Y Float =>-                     Either String JP.DynamicImage -> Either String (Image arr Y Float)+jpImageYFToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Float) jpImageYFToImage (Right (JP.ImageYF jimg)) = Right (jpImageToImage jimg) jpImageYFToImage jimg = jpCSError "YF (Pixel Y Float)" jimg -} -jpImageYA8ToImage :: Array arr YA Word8 =>-                    Either String JP.DynamicImage -> Either String (Image arr YA Word8)-jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImage jimg)+jpImageYA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word8)+jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageYA8ToImage jimg = jpCSError "YA8 (Pixel YA Word8)" jimg  -jpImageYA16ToImage :: Array arr YA Word16 =>-                     Either String JP.DynamicImage -> Either String (Image arr YA Word16)-jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImage jimg)+jpImageYA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word16)+jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg  -jpImageRGB8ToImage :: Array arr RGB Word8 =>-                      Either String JP.DynamicImage -> Either String (Image arr RGB Word8)-jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImage jimg)+jpImageRGB8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word8)+jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg  -jpImageRGB16ToImage :: Array arr RGB Word16 =>-                       Either String JP.DynamicImage -> Either String (Image arr RGB Word16)-jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImage jimg)+jpImageRGB16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word16)+jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg  -jpImageRGBFToImage :: Array arr RGB Float =>-                       Either String JP.DynamicImage -> Either String (Image arr RGB Float)-jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImage jimg)+jpImageRGBFToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Float)+jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImageUnsafe jimg) jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg  -jpImageRGBA8ToImage :: Array arr RGBA Word8 =>-                      Either String JP.DynamicImage -> Either String (Image arr RGBA Word8)-jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImage jimg)+jpImageRGBA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word8)+jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg  -jpImageRGBA16ToImage :: Array arr RGBA Word16 =>-                       Either String JP.DynamicImage -> Either String (Image arr RGBA Word16)-jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImage jimg)+jpImageRGBA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word16)+jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg  -jpImageYCbCr8ToImage :: Array arr YCbCr Word8 =>-                      Either String JP.DynamicImage -> Either String (Image arr YCbCr Word8)-jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImage jimg)+jpImageYCbCr8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YCbCr Word8)+jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg  -jpImageCMYK8ToImage :: Array arr CMYK Word8 =>-                      Either String JP.DynamicImage -> Either String (Image arr CMYK Word8)-jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImage jimg)+jpImageCMYK8ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word8)+jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg  -jpImageCMYK16ToImage :: Array arr CMYK Word16 =>-                      Either String JP.DynamicImage -> Either String (Image arr CMYK Word16)-jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImage jimg)+jpImageCMYK16ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word16)+jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImageUnsafe jimg) jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg   jpDynamicImageToImage' :: (Convertible JP.PixelCMYK16 (Pixel cs e),-                          Convertible JP.PixelCMYK8 (Pixel cs e),-                          Convertible JP.PixelRGB16 (Pixel cs e),-                          Convertible JP.PixelRGB8 (Pixel cs e),-                          Convertible JP.PixelRGBA16 (Pixel cs e),-                          Convertible JP.PixelRGBA8 (Pixel cs e),-                          Convertible JP.PixelRGBF (Pixel cs e),-                          Convertible JP.PixelYA16 (Pixel cs e),-                          Convertible JP.PixelYA8 (Pixel cs e),-                          Convertible JP.PixelYCbCr8 (Pixel cs e),-                          Convertible JP.Pixel16 (Pixel cs e),-                          Convertible JP.Pixel8 (Pixel cs e),-                          Convertible JP.PixelF (Pixel cs e),-                          Array arr cs e) =>-                         JP.DynamicImage -> Image arr cs e-jpDynamicImageToImage' (JP.ImageY8 jimg)     = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageY16 jimg)    = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageYF jimg)     = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageYA8 jimg)    = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageYA16 jimg)   = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageRGB8 jimg)   = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageRGB16 jimg)  = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageRGBF jimg)   = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageRGBA8 jimg)  = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageRGBA16 jimg) = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageCMYK8 jimg)  = jpImageToImage jimg-jpDynamicImageToImage' (JP.ImageCMYK16 jimg) = jpImageToImage jimg+                           Convertible JP.PixelCMYK8 (Pixel cs e),+                           Convertible JP.PixelRGB16 (Pixel cs e),+                           Convertible JP.PixelRGB8 (Pixel cs e),+                           Convertible JP.PixelRGBA16 (Pixel cs e),+                           Convertible JP.PixelRGBA8 (Pixel cs e),+                           Convertible JP.PixelRGBF (Pixel cs e),+                           Convertible JP.PixelYA16 (Pixel cs e),+                           Convertible JP.PixelYA8 (Pixel cs e),+                           Convertible JP.PixelYCbCr8 (Pixel cs e),+                           Convertible JP.Pixel16 (Pixel cs e),+                           Convertible JP.Pixel8 (Pixel cs e),+                           Convertible JP.PixelF (Pixel cs e),+                           Array arr cs e) =>+                          JP.DynamicImage -> Image arr cs e+jpDynamicImageToImage' (JP.ImageY8 jimg)     = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageY16 jimg)    = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageYF jimg)     = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageYA8 jimg)    = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageYA16 jimg)   = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageRGB8 jimg)   = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageRGB16 jimg)  = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageRGBF jimg)   = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageRGBA8 jimg)  = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageRGBA16 jimg) = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageCMYK8 jimg)  = jpImageToImageSafe jimg+jpDynamicImageToImage' (JP.ImageCMYK16 jimg) = jpImageToImageSafe jimg   jpDynamicImageToImage :: (Convertible JP.PixelCMYK16 (Pixel cs e),@@ -796,73 +801,65 @@ -- Encoding images using JuicyPixels ------------------------------------------- -------------------------------------------------------------------------------- -instance Array arr Y Word8 => Writable (Image arr Y Word8) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) +instance Writable (Image VS Y Word8) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) id -instance Array arr RGB Word8 => Writable (Image arr RGB Word8) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) +instance Writable (Image VS RGB Word8) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) id -instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) +instance Writable (Image VS RGBA Word8) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) id -instance Array arr Binary Bit => Writable (Image arr Binary Bit) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                                 . fromPixelBinary)+instance Writable (Image VS Binary Bit) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary -instance Array arr Y Double => Writable (Image arr Y Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                                 . toWord8)+instance Writable (Image VS Y Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8) -instance Array arr YA Double => Writable (Image arr YA Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                                 . toWord8 . dropAlpha)+instance Writable (Image VS YA Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8)+                                                ((fmap toWord8) . dropAlpha) -instance Array arr RGB Double => Writable (Image arr RGB Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                                 . toWord8)+instance Writable (Image VS RGB Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) BMP where-  encode _ _ = JP.encodeBitmap . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8)-                                                 . toWord8)+instance Writable (Image VS RGBA Double) BMP where+  encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8)  -- Writable GIF -encodeGIF :: Array arr cs e =>-             [SaveOption GIF] -> (Pixel cs e -> JP.PixelRGB8)-             -> Image arr cs e -> BL.ByteString+encodeGIF :: (Array VS cs' e, Array VS cs Word8) =>+             [SaveOption GIF] -> (Pixel cs' e -> Pixel cs Word8)+             -> Image VS cs' e -> BL.ByteString encodeGIF []                     !conv =   either error id . uncurry JP.encodeGifImageWithPalette .-  JP.palettize JP.defaultPaletteOptions . imageToJPImage conv+  JP.palettize JP.defaultPaletteOptions . imageToJPImage (undefined :: JP.PixelRGB8) conv encodeGIF (GIFPalette palOpts:_) !conv =   either error id . uncurry JP.encodeGifImageWithPalette .-  JP.palettize palOpts . imageToJPImage conv+  JP.palettize palOpts . imageToJPImage (undefined :: JP.PixelRGB8) conv  -instance Array arr RGB Word8 => Writable (Image arr RGB Word8) GIF where-  encode _ opts = encodeGIF opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8)+instance Writable (Image VS RGB Word8) GIF where+  encode _ opts = encodeGIF opts id   -instance Array arr Y Double => Writable (Image arr Y Double) GIF where-  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                  . toWord8 . toPixelRGB)+instance Writable (Image VS Y Double) GIF where+  encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB)     -instance Array arr YA Double => Writable (Image arr YA Double) GIF where-  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                  . toWord8 . toPixelRGB . dropAlpha)+instance Writable (Image VS YA Double) GIF where+  encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB . dropAlpha) -instance Array arr RGB Double => Writable (Image arr RGB Double) GIF where-  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                  . toWord8)+instance Writable (Image VS RGB Double) GIF where+  encode _ opts = encodeGIF opts (fmap toWord8) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) GIF where-  encode _ opts = encodeGIF opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                  . toWord8 . dropAlpha)+instance Writable (Image VS RGBA Double) GIF where+  encode _ opts = encodeGIF opts ((fmap toWord8) . dropAlpha)  -encodeGIFs :: Array arr cs e =>-              [SaveOption [GIF]] -> (Pixel cs e -> JP.PixelRGB8)-           -> [(JP.GifDelay, Image arr cs e)] -> BL.ByteString+encodeGIFs :: (Array VS cs' e, Array VS cs Word8) =>+              [SaveOption [GIF]] -> (Pixel cs' e -> Pixel cs Word8)+           -> [(JP.GifDelay, Image VS cs' e)] -> BL.ByteString encodeGIFs !opts !conv =-  either error id . JP.encodeGifImages (getGIFsLoop opts) . map palletizeGif where+  either error id . JP.encodeGifImages (getGIFsLoop opts) . P.map palletizeGif where     getGIFsLoop []                   = JP.LoopingNever     getGIFsLoop (GIFsLooping loop:_) = loop     getGIFsLoop (_:xs)               = getGIFsLoop xs    @@ -870,231 +867,209 @@     getGIFsPal (GIFsPalette palOpts:_) = palOpts     getGIFsPal (_:xs)                  = getGIFsPal xs     palletizeGif !(d, img) = (p, d, jimg) where  -      !(jimg, p) = JP.palettize (getGIFsPal opts) $ imageToJPImage conv img+      !(jimg, p) = JP.palettize (getGIFsPal opts) $+                   imageToJPImage (undefined :: JP.PixelRGB8) conv img  -instance Array arr RGB Word8 => Writable [(JP.GifDelay, Image arr RGB Word8)] [GIF] where-  encode _ opts = encodeGIFs opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8)--instance Array arr RGB Double => Writable [(JP.GifDelay, Image arr RGB Double)] [GIF] where-  encode _ opts = encodeGIFs opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                   . toWord8)+instance Writable [(JP.GifDelay, Image VS RGB Word8)] [GIF] where+  encode _ opts = encodeGIFs opts id +instance Writable [(JP.GifDelay, Image VS RGB Double)] [GIF] where+  encode _ opts = encodeGIFs opts (fmap toWord8) -- Writable HDR -instance Array arr RGB Float => Writable (Image arr RGB Float) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage (convert :: Pixel RGB Float -> JP.PixelRGBF) +instance Writable (Image VS RGB Float) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) id -instance Array arr Y Double => Writable (Image arr Y Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)-                                              . toFloat . toPixelRGB)+instance Writable (Image VS Y Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF)+                                             (fmap toFloat . toPixelRGB) -instance Array arr YA Double => Writable (Image arr YA Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)-                                              . toFloat . toPixelRGB . dropAlpha)+instance Writable (Image VS YA Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF)+                                             (fmap toFloat . toPixelRGB . dropAlpha) -instance Array arr RGB Double => Writable (Image arr RGB Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)-                                              . toFloat)+instance Writable (Image VS RGB Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) (fmap toFloat) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) HDR where-  encode _ _ = JP.encodeHDR . imageToJPImage ((convert :: Pixel RGB Float -> JP.PixelRGBF)-                                              . toFloat . dropAlpha)+instance Writable (Image VS RGBA Double) HDR where+  encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF)+                                             (fmap toFloat . dropAlpha)    -- Writable JPG  -encodeJPG :: (JP.JpgEncodable px, Array arr cs e) =>-             [SaveOption JPG] -> (Pixel cs e -> px) -> Image arr cs e -> BL.ByteString-encodeJPG []               conv =-  JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage conv-encodeJPG (JPGQuality q:_) conv =-  JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage conv+encodeJPG+  :: (JP.JpgEncodable px, Array VS cs' e, Array VS cs (JP.PixelBaseComponent px)) =>+     [SaveOption JPG]+     -> px+     -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent px))+     -> Image VS cs' e+     -> BL.ByteString+encodeJPG []               t conv =+  JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage t conv+encodeJPG (JPGQuality q:_) t conv =+  JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage t conv  -instance Array arr Y Word8 => Writable (Image arr Y Word8) JPG where-  encode _ opts = encodeJPG opts (convert :: Pixel Y Word8 -> JP.Pixel8)+instance Writable (Image VS Y Word8) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) id -instance Array arr RGB Word8 => Writable (Image arr RGB Word8) JPG where-  encode _ opts = encodeJPG opts (convert :: Pixel RGB Word8 -> JP.PixelRGB8) +instance Writable (Image VS RGB Word8) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) id -instance Array arr CMYK Word8 => Writable (Image arr CMYK Word8) JPG where-  encode _ opts = encodeJPG opts (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) +instance Writable (Image VS CMYK Word8) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.PixelCMYK8) id                -instance Array arr YCbCr Word8 => Writable (Image arr YCbCr Word8) JPG where-  encode _ opts = encodeJPG opts (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8) +instance Writable (Image VS YCbCr Word8) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.PixelYCbCr8) id -instance Array arr Y Double => Writable (Image arr Y Double) JPG where-  encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                  . toWord8) +instance Writable (Image VS Y Double) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) (fmap toWord8) -instance Array arr YA Double => Writable (Image arr YA Double) JPG where-  encode _ opts = encodeJPG opts ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                  . toWord8 . dropAlpha) +instance Writable (Image VS YA Double) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha)  -instance Array arr RGB Double => Writable (Image arr RGB Double) JPG where-  encode _ opts = encodeJPG opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                  . toWord8) +instance Writable (Image VS RGB Double) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) (fmap toWord8) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) JPG where-  encode _ opts = encodeJPG opts ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                  . toWord8 . dropAlpha) +instance Writable (Image VS RGBA Double) JPG where+  encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) ((fmap toWord8) . dropAlpha)    -- Writable PNG -instance Array arr Binary Bit => Writable (Image arr Binary Bit) PNG where-  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8) -                                              . fromPixelBinary)+instance Writable (Image VS Binary Bit) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary   -instance Array arr Y Word8 => Writable (Image arr Y Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) +instance Writable (Image VS Y Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) id -instance Array arr Y Word16 => Writable (Image arr Y Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) +instance Writable (Image VS Y Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) id -instance Array arr YA Word8 => Writable (Image arr YA Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) +instance Writable (Image VS YA Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA8) id -instance Array arr YA Word16 => Writable (Image arr YA Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) +instance Writable (Image VS YA Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) id -instance Array arr RGB Word8 => Writable (Image arr RGB Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) +instance Writable (Image VS RGB Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB8) id -instance Array arr RGB Word16 => Writable (Image arr RGB Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) +instance Writable (Image VS RGB Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) id -instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) +instance Writable (Image VS RGBA Word8) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA8) id -instance Array arr RGBA Word16 => Writable (Image arr RGBA Word16) PNG where-  encode _ _ = JP.encodePng . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) +instance Writable (Image VS RGBA Word16) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) id  -instance Array arr Y Double => Writable (Image arr Y Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16)-                                              . toWord16)+instance Writable (Image VS Y Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16) -instance Array arr YA Double => Writable (Image arr YA Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16)-                                              . toWord16)+instance Writable (Image VS YA Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16) -instance Array arr RGB Double => Writable (Image arr RGB Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16)-                                              . toWord16)+instance Writable (Image VS RGB Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) PNG where-  encode _ _ = JP.encodePng . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16)-                                              . toWord16)+instance Writable (Image VS RGBA Double) PNG where+  encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16)  -- Writable TGA -instance Array arr Binary Bit => Writable (Image arr Binary Bit) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                              . fromPixelBinary)+instance Writable (Image VS Binary Bit) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary   -instance Array arr Y Word8 => Writable (Image arr Y Word8) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) +instance Writable (Image VS Y Word8) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) id -instance Array arr RGB Word8 => Writable (Image arr RGB Word8) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) +instance Writable (Image VS RGB Word8) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) id -instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) +instance Writable (Image VS RGBA Word8) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) id  -instance Array arr Y Double => Writable (Image arr Y Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                              . toWord8)+instance Writable (Image VS Y Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8) -instance Array arr YA Double => Writable (Image arr YA Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                              . toWord8 . dropAlpha)+instance Writable (Image VS YA Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha) -instance Array arr RGB Double => Writable (Image arr RGB Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGB Word8 -> JP.PixelRGB8)-                                              . toWord8)+instance Writable (Image VS RGB Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) TGA where-  encode _ _ = JP.encodeTga . imageToJPImage ((convert :: Pixel RGBA Word8 -> JP.PixelRGBA8)-                                              . toWord8)+instance Writable (Image VS RGBA Double) TGA where+  encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8)  -- Writable TIF -instance Array arr Y Word8 => Writable (Image arr Y Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word8 -> JP.Pixel8) +instance Writable (Image VS Y Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) id -instance Array arr Y Word16 => Writable (Image arr Y Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel Y Word16 -> JP.Pixel16) +instance Writable (Image VS Y Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) id -instance Array arr YA Word8 => Writable (Image arr YA Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word8 -> JP.PixelYA8) +instance Writable (Image VS YA Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA8) id -instance Array arr YA Word16 => Writable (Image arr YA Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YA Word16 -> JP.PixelYA16) +instance Writable (Image VS YA Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) id -instance Array arr RGB Word8 => Writable (Image arr RGB Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word8 -> JP.PixelRGB8) +instance Writable (Image VS RGB Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB8) id -instance Array arr RGB Word16 => Writable (Image arr RGB Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGB Word16 -> JP.PixelRGB16) +instance Writable (Image VS RGB Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) id -instance Array arr RGBA Word8 => Writable (Image arr RGBA Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word8 -> JP.PixelRGBA8) +instance Writable (Image VS RGBA Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA8) id -instance Array arr RGBA Word16 => Writable (Image arr RGBA Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel RGBA Word16 -> JP.PixelRGBA16) +instance Writable (Image VS RGBA Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) id -instance Array arr YCbCr Word8 => Writable (Image arr YCbCr Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8)+instance Writable (Image VS YCbCr Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) id   -instance Array arr CMYK Word8 => Writable (Image arr CMYK Word8) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word8 -> JP.PixelCMYK8) +instance Writable (Image VS CMYK Word8) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK8) id -instance Array arr CMYK Word16 => Writable (Image arr CMYK Word16) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage (convert :: Pixel CMYK Word16 -> JP.PixelCMYK16) +instance Writable (Image VS CMYK Word16) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) id  -instance Array arr Binary Bit => Writable (Image arr Binary Bit) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word8 -> JP.Pixel8)-                                               . fromPixelBinary)+instance Writable (Image VS Binary Bit) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary   -instance Array arr Y Double => Writable (Image arr Y Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel Y Word16 -> JP.Pixel16)-                                               . toWord16)+instance Writable (Image VS Y Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16) -instance Array arr YA Double => Writable (Image arr YA Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YA Word16 -> JP.PixelYA16)-                                               . toWord16)+instance Writable (Image VS YA Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16) -instance Array arr RGB Double => Writable (Image arr RGB Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGB Word16 -> JP.PixelRGB16)-                                               . toWord16)+instance Writable (Image VS RGB Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16) -instance Array arr RGBA Double => Writable (Image arr RGBA Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel RGBA Word16 -> JP.PixelRGBA16)-                                               . toWord16)+instance Writable (Image VS RGBA Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16) -instance Array arr YCbCr Double => Writable (Image arr YCbCr Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel YCbCr Word8 -> JP.PixelYCbCr8)-                                               . toWord8)+instance Writable (Image VS YCbCr Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) (fmap toWord8) -instance Array arr CMYK Double => Writable (Image arr CMYK Double) TIF where-  encode _ _ = JP.encodeTiff . imageToJPImage ((convert :: Pixel CMYK Word16 -> JP.PixelCMYK16)-                                               . toWord16)+instance Writable (Image VS CMYK Double) TIF where+  encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) (fmap toWord16)   -imageToJPImage :: (JP.Pixel a, Array arr cs e) =>-                  (Pixel cs e -> a) -> Image arr cs e -> JP.Image a-imageToJPImage !f !imgD = JP.generateImage g n m-  where-    !(m, n) = dims imgD-    !img = toManifest imgD-    g !j !i = f (index img (i, j))-    {-# INLINE g #-}+imageToJPImage :: (JP.Pixel a, Array VS cs' e, Array VS cs (JP.PixelBaseComponent a)) =>+                  a -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent a)) -> Image VS cs' e -> JP.Image a+imageToJPImage _ f !img = JP.Image n m $ V.unsafeCast $ toStorableVector $ I.map f img where+  !(m, n) = dims img {-# INLINE imageToJPImage #-}  

@@ -18,11 +18,12 @@  import Graphics.Image.ColorSpace import Graphics.Image.Interface hiding (map)+import Graphics.Image.Interface.Vector import Graphics.Image.IO.Base import Foreign.Storable (Storable) import qualified Data.ByteString as B (ByteString) import qualified Graphics.Netpbm as PNM-import qualified Data.Vector.Storable as VS ((!), Vector)+import qualified Data.Vector.Storable as V   -- | Netpbm: portable bitmap image with @.pbm@ extension.@@ -80,16 +81,16 @@   convert (PNM.PbmPixel bool) = PixelY $ if bool then 0 else 1    instance Convertible PNM.PgmPixel8 (Pixel Y Double) where-  convert (PNM.PgmPixel8 w8) = toDouble . PixelY $ w8+  convert (PNM.PgmPixel8 w8) = PixelY $ toDouble w8  instance Convertible PNM.PgmPixel16 (Pixel Y Double) where-  convert (PNM.PgmPixel16 w16) = toDouble . PixelY $ w16+  convert (PNM.PgmPixel16 w16) = PixelY $ toDouble w16  instance Convertible PNM.PpmPixelRGB8 (Pixel Y Double) where-  convert (PNM.PpmPixelRGB8 r g b) = toPixelY . toDouble $ PixelRGB r g b+  convert (PNM.PpmPixelRGB8 r g b) = toPixelY . fmap toDouble $ PixelRGB r g b  instance Convertible PNM.PpmPixelRGB16 (Pixel Y Double) where-  convert (PNM.PpmPixelRGB16 r g b) = toPixelY . toDouble $ PixelRGB r g b+  convert (PNM.PpmPixelRGB16 r g b) = toPixelY . fmap toDouble $ PixelRGB r g b  -- -> YA (Double) @@ -120,10 +121,10 @@   convert = toPixelRGB . (convert :: PNM.PgmPixel16 -> Pixel Y Double)  instance Convertible PNM.PpmPixelRGB8 (Pixel RGB Double) where-  convert (PNM.PpmPixelRGB8 r g b) = toDouble $ PixelRGB r g b+  convert (PNM.PpmPixelRGB8 r g b) = fmap toDouble $ PixelRGB r g b  instance Convertible PNM.PpmPixelRGB16 (Pixel RGB Double) where-  convert (PNM.PpmPixelRGB16 r g b) = toDouble $ PixelRGB r g b+  convert (PNM.PpmPixelRGB16 r g b) = fmap toDouble $ PixelRGB r g b   -- -> RGBA (Double)@@ -190,35 +191,35 @@  -- BMP Format Reading (exact) -instance Array arr Binary Bit => Readable (Image arr Binary Bit) PBM where+instance Readable (Image VS Binary Bit) PBM where   decode _ = either Left (ppmToImageUsing pnmDataPBMToImage . head) . decodePnm -instance Array arr Y Word8 => Readable (Image arr Y Word8) PGM where+instance Readable (Image VS Y Word8) PGM where   decode _ = either Left (ppmToImageUsing pnmDataPGM8ToImage . head) . decodePnm -instance Array arr Y Word16 => Readable (Image arr Y Word16) PGM where+instance Readable (Image VS Y Word16) PGM where   decode _ = either Left (ppmToImageUsing pnmDataPGM16ToImage . head) . decodePnm -instance Array arr RGB Word8 => Readable (Image arr RGB Word8) PPM where+instance Readable (Image VS RGB Word8) PPM where   decode _ = either Left (ppmToImageUsing pnmDataPPM8ToImage . head) . decodePnm -instance Array arr RGB Word16 => Readable (Image arr RGB Word16) PPM where+instance Readable (Image VS RGB Word16) PPM where   decode _ = either Left (ppmToImageUsing pnmDataPPM16ToImage . head) . decodePnm  -instance Array arr Binary Bit => Readable [Image arr Binary Bit] [PBM] where+instance Readable [Image VS Binary Bit] [PBM] where   decode _ = pnmToImagesUsing pnmDataPBMToImage -instance Array arr Y Word8 => Readable [Image arr Y Word8] [PGM] where+instance Readable [Image VS Y Word8] [PGM] where   decode _ = pnmToImagesUsing pnmDataPGM8ToImage -instance Array arr Y Word16 => Readable [Image arr Y Word16] [PGM] where+instance Readable [Image VS Y Word16] [PGM] where   decode _ = pnmToImagesUsing pnmDataPGM16ToImage -instance Array arr RGB Word8 => Readable [Image arr RGB Word8] [PPM] where+instance Readable [Image VS RGB Word8] [PPM] where   decode _ = pnmToImagesUsing pnmDataPPM8ToImage -instance Array arr RGB Word16 => Readable [Image arr RGB Word16] [PPM] where+instance Readable [Image VS RGB Word16] [PPM] where   decode _ = pnmToImagesUsing pnmDataPPM16ToImage  @@ -228,8 +229,8 @@   fmap (map (either error id . ppmToImageUsing conv)) . decodePnm  -getPx :: (Storable a, Convertible a b) => VS.Vector a -> Int -> (Int, Int) -> b-getPx v w (i, j) = convert (v VS.! (i * w + j))+getPx :: (Storable a, Convertible a b) => V.Vector a -> Int -> (Int, Int) -> b+getPx v w (i, j) = convert (v V.! (i * w + j))   pnmDataToImage :: (Array arr cs e, Convertible PNM.PbmPixel px,@@ -243,29 +244,30 @@ 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 $ makeImage (h, w) (getPx v w)+makeImageUnsafe+  :: (Storable a, Array VS cs e)+  => (Int, Int) -> V.Vector a -> Image VS cs e+makeImageUnsafe sz = fromStorableVector sz . V.unsafeCast+++pnmDataPBMToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS Binary Bit)+pnmDataPBMToImage w h (PNM.PbmPixelData v) = Right $ makeImageUnsafe (h, w) v 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 $ makeImage (h, w) (getPx v w)+pnmDataPGM8ToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS Y Word8)+pnmDataPGM8ToImage w h (PNM.PgmPixelData8 v) = Right $ makeImageUnsafe (h, w) v 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 $ makeImage (h, w) (getPx v w)+pnmDataPGM16ToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS Y Word16)+pnmDataPGM16ToImage w h (PNM.PgmPixelData16 v) = Right $ makeImageUnsafe (h, w) v 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 $ makeImage (h, w) (getPx v w)+pnmDataPPM8ToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS RGB Word8)+pnmDataPPM8ToImage w h (PNM.PpmPixelDataRGB8 v) = Right $ makeImageUnsafe (h, w) v 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 $ makeImage (h, w) (getPx v w)+pnmDataPPM16ToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS RGB Word16)+pnmDataPPM16ToImage w h (PNM.PpmPixelDataRGB16 v) = Right $ makeImageUnsafe (h, w) v pnmDataPPM16ToImage _ _ d                         = pnmCSError "RGB16 (Pixel RGB Word16)" d  

@@ -11,24 +11,26 @@ -- Portability : non-portable -- module Graphics.Image.IO.Histogram (-  Histogram(..), Histograms, getHistograms, getHistogram,+  Histogram(..), Histograms, ChannelColour(..), getHistograms, getHistogram,   displayHistograms, writeHistograms   ) where  import Prelude as P  import Control.Concurrent (forkIO) import Control.Monad (void)-import Graphics.Image.Interface as I-import Graphics.Image.IO-import Graphics.Image.ColorSpace-import Graphics.Rendering.Chart.Easy-import Graphics.Rendering.Chart.Backend.Diagrams import qualified Data.Colour as C+import qualified Data.Colour.Names as C import qualified Data.Vector.Unboxed as V import System.Directory (getTemporaryDirectory) import System.FilePath ((</>)) import System.IO.Temp (createTempDirectory) +import Graphics.Image.Interface as I+import Graphics.Image.IO+import Graphics.Image.ColorSpace+import Graphics.Rendering.Chart.Easy+import Graphics.Rendering.Chart.Backend.Diagrams+ #if MIN_VERSION_vector(0,11,0) import Data.Vector.Unboxed.Mutable (modify) #else@@ -42,6 +44,12 @@ #endif  +class ChannelColour cs where+ +  -- | Get a pure colour representation of a channel.+  csColour :: cs -> C.AlphaColour Double++ -- | A single channel histogram of an image. data Histogram = Histogram { hBins :: V.Vector Int                              -- ^ Vector containing pixel counts. Index of a@@ -57,8 +65,8 @@ type Histograms = [Histogram]  -- | Create a histogram per channel with 256 bins each.-getHistograms :: forall arr cs e . (MArray arr Gray e, Array arr Gray e, -                                    MArray arr cs e, Array arr cs e, Elevator e) =>+getHistograms :: forall arr cs e . (ChannelColour cs, MArray arr Gray e, Array arr Gray e, +                                    MArray arr cs e, Array arr cs e) =>                  Image arr cs e               -> Histograms getHistograms = P.zipWith setCh (enumFrom (toEnum 0) :: [cs]) . P.map getHistogram . toGrayImages@@ -66,7 +74,7 @@                        , hColour = csColour cs }  -- | Generate a histogram with 256 bins for a single channel Gray image.-getHistogram :: (MArray arr Gray e, Elevator e) =>+getHistogram :: MArray arr Gray e =>                 Image arr Gray e              -> Histogram getHistogram img = Histogram { hBins = V.modify countBins $@@ -74,7 +82,7 @@                                        (1 + fromIntegral (maxBound :: Word8)) (0 :: Int)                              , hName = show Gray                              , hColour = csColour Gray } where-  incBin v (toWord8 -> PixelGray g) = modify v (+1) $ fromIntegral g+  incBin v (PixelGray g) = modify v (+1) $ fromIntegral (toWord8 g)   countBins v = I.mapM_ (incBin v) img    @@ -119,3 +127,64 @@   if block     then display     else void $ forkIO display++instance ChannelColour Gray where+  csColour _ = C.opaque C.darkgray++instance ChannelColour Y where+  csColour _ = C.opaque C.darkgray++instance ChannelColour YA where+  csColour LumaYA  = csColour LumaY+  csColour AlphaYA = C.opaque C.gray+++instance ChannelColour RGB where+  csColour RedRGB   = C.opaque C.red+  csColour GreenRGB = C.opaque C.green+  csColour BlueRGB  = C.opaque C.blue++instance ChannelColour RGBA where+  csColour RedRGBA   = C.opaque C.red+  csColour GreenRGBA = C.opaque C.green+  csColour BlueRGBA  = C.opaque C.blue+  csColour AlphaRGBA = C.opaque C.gray+++instance ChannelColour HSI where+  csColour HueHSI = C.opaque C.purple+  csColour SatHSI = C.opaque C.orange+  csColour IntHSI = C.opaque C.darkblue++instance ChannelColour HSIA where+  csColour HueHSIA = C.opaque C.purple+  csColour SatHSIA = C.opaque C.orange+  csColour IntHSIA = C.opaque C.darkblue+  csColour AlphaHSIA = C.opaque C.gray+++instance ChannelColour CMYK where+  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 ChannelColour CMYKA where+  csColour CyanCMYKA  = csColour CyanCMYK+  csColour MagCMYKA   = csColour MagCMYK+  csColour YelCMYKA   = csColour YelCMYK+  csColour KeyCMYKA   = csColour KeyCMYK+  csColour AlphaCMYKA = C.opaque C.grey+++instance ChannelColour YCbCr where+  csColour LumaYCbCr  = C.opaque C.darkgray+  csColour CBlueYCbCr = C.opaque C.darkblue+  csColour CRedYCbCr  = C.opaque C.darkred+++instance ChannelColour YCbCrA where+  csColour LumaYCbCrA  = csColour LumaYCbCr+  csColour CBlueYCbCrA = csColour CBlueYCbCr+  csColour CRedYCbCrA  = csColour CRedYCbCr+  csColour AlphaYCbCrA = C.opaque C.gray

@@ -8,86 +8,103 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800-  {-# OPTIONS_GHC -Wno-redundant-constraints #-}-  {-# LANGUAGE UndecidableSuperClasses #-}+    {-# OPTIONS_GHC -Wno-redundant-constraints #-}+    {-# LANGUAGE UndecidableSuperClasses #-} #endif {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Image.Interface--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Graphics.Image.Interface (-  ColorSpace(..), Alpha(..), Elevator(..),+  Pixel, ColorSpace(..), AlphaSpace(..), Elevator(..),   BaseArray(..), Array(..), MArray(..),   Exchangable(..), exchangeFrom,   defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex,+  fromIx, toIx, checkDims+#if !MIN_VERSION_base(4,8,0)+  , module Control.Applicative+  , Foldable+#endif   ) 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))+import Control.Applicative #endif+import Data.Maybe (fromMaybe)+import Data.Foldable import GHC.Exts (Constraint) import Data.Typeable (Typeable, showsTypeRep, typeOf)-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq (NFData(rnf), deepseq) import Data.Word-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--- intended for implementing any other possible custom color spaces. Every--- instance of this class automatically installs an associated 'Pixel' into--- 'Num', 'Fractional', 'Floating', 'Functor', 'Applicative' and 'Foldable',--- which in turn make it possible to be used by the rest of the library.-class (Eq cs, Enum cs, Show cs, Typeable cs) => ColorSpace cs where-  -  -- | Representation of a pixel, such that it can be an element of any-  -- Array. Which is usally a tuple of channels or a channel itself for single-  -- channel color spaces.-  type PixelElt cs e+-- | A Pixel family with a color space and a precision of elements.+data family Pixel cs e :: * -  -- | A concrete Pixel representation for a particular color space.-  data Pixel cs e -  -- | Construt a pixel by replicating a same value among all of the channels.-  fromChannel :: e -> Pixel cs e+class (Eq cs, Enum cs, Show cs, Typeable cs, Elevator e, Typeable e) => ColorSpace cs e where+  +  type Components cs e    -- | Convert a Pixel to a representation suitable for storage as an unboxed   -- element, usually a tuple of channels.-  toElt :: Pixel cs e -> PixelElt cs e+  toComponents :: Pixel cs e -> Components cs e    -- | Convert from an elemnt representation back to a Pixel.-  fromElt :: PixelElt cs e -> Pixel cs e+  fromComponents :: Components cs e -> Pixel cs e -  -- | Retrieve Pixel's channel value-  getPxCh :: Pixel cs e -> cs -> e+  -- | Construt a pixel by replicating a same value among all of the components.+  broadcastC :: e -> Pixel cs e++  -- | Retrieve Pixel's component value+  getPxC :: Pixel cs e -> cs -> e   -  -- | Map a channel aware function over all Pixel's channels.-  chOp :: (cs -> e' -> e) -> Pixel cs e' -> Pixel cs e +  -- | Set Pixel's component value+  setPxC :: Pixel cs e -> cs -> e -> Pixel cs e+  +  -- | Map a channel aware function over all Pixel's components.+  mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e  -  -- | Map a function over all Pixel's channels.-  pxOp :: (e' -> e) -> Pixel cs e' -> Pixel cs e+  -- | Map a function over all Pixel's componenets.+  mapPx :: (e -> e) -> Pixel cs e -> Pixel cs e -  -- | Function application to a Pixel.-  chApp :: Pixel cs (e' -> e) -> Pixel cs e' -> Pixel cs e+  -- | Zip two Pixels with a function.+  zipWithPx :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e -  -- | A pixel eqiuvalent of 'foldMap'.-  pxFoldMap :: Monoid m => (e -> m) -> Pixel cs e -> m+  -- | Right fold over all Pixel's components.+  foldrPx :: (e -> b -> b) -> b -> Pixel cs e -> b+  foldrPx f !z0 !xs = foldlPx f' id xs z0+      where f' k x !z = k $! f x z -  -- | Get a pure colour representation of a channel.-  csColour :: cs -> C.AlphaColour Double+  -- | Left strict fold over all Pixel's components.+  foldlPx :: (b -> e -> b) -> b -> Pixel cs e -> b+  foldlPx f !z0 !xs = foldrPx f' id xs z0+      where f' x k !z = k $! f z x++  foldl1Px :: (e -> e -> e) -> Pixel cs e -> e+  foldl1Px f !xs = fromMaybe (error "foldl1: empty Pixel")+                  (foldlPx mf Nothing xs)+      where+        mf m !y = Just (case m of+                           Nothing -> y+                           Just x  -> f x y)+  toListPx :: Pixel cs e -> [e]+  toListPx !px = foldr' f [] (enumFrom (toEnum 0))+    where f !cs !ls = getPxC px cs:ls+     -- | A color space that supports transparency.-class (ColorSpace (Opaque cs), ColorSpace cs) => Alpha cs where-  -- | An corresponding opaque version of this color space.+class (ColorSpace (Opaque cs) e, ColorSpace cs e) => AlphaSpace cs e where+  -- | A corresponding opaque version of this color space.   type Opaque cs    -- | Get an alpha channel of a transparant pixel. @@ -105,10 +122,7 @@   --   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 -- channels within pixels, while scaling the values to keep them in an appropriate range. --@@ -118,30 +132,36 @@ -- class Elevator e where -  toWord8 :: ColorSpace cs => Pixel cs e -> Pixel cs Word8+  -- | Values are scaled to @[0, 255]@ range.+  toWord8 :: e -> Word8 -  toWord16 :: ColorSpace cs => Pixel cs e -> Pixel cs Word16+  -- | Values are scaled to @[0, 65535]@ range.+  toWord16 :: e -> Word16 -  toWord32 :: ColorSpace cs => Pixel cs e -> Pixel cs Word32+  -- | Values are scaled to @[0, 4294967295]@ range.+  toWord32 :: e -> Word32 -  toWord64 :: ColorSpace cs => Pixel cs e -> Pixel cs Word64+  -- | Values are scaled to @[0, 18446744073709551615]@ range.+  toWord64 :: e -> Word64 -  toFloat :: ColorSpace cs => Pixel cs e -> Pixel cs Float+  -- | Values are scaled to @[0.0, 1.0]@ range.+  toFloat :: e -> Float -  toDouble :: ColorSpace cs => Pixel cs e -> Pixel cs Double+  -- | Values are scaled to @[0.0, 1.0]@ range.+  toDouble :: e -> Double -  fromDouble :: ColorSpace cs => Pixel cs Double -> Pixel cs e+  -- | Values are scaled from @[0.0, 1.0]@ range.+  fromDouble :: Double -> 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) =>+class (Show arr, ColorSpace cs e, Num (Pixel cs e),+       SuperClass arr cs e) =>       BaseArray arr cs e where    -- | Required array specific constraints for an array element.-  type Elt arr cs e :: Constraint-  type Elt arr cs e = ()+  type SuperClass arr cs e :: Constraint+  type SuperClass arr cs e = ()    -- | Underlying image representation.   data Image arr cs e@@ -169,6 +189,14 @@                -- argument and returns a pixel for that location.             -> Image arr cs e +  makeImageWindowed :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.+                    -> ((Int, Int), (Int, Int))+                    -> ((Int, Int) -> Pixel cs e)+                       -- ^ Function that generates inner pixels.+                    -> ((Int, Int) -> Pixel cs e)+                       -- ^ Function that generates border pixels+                    -> Image arr cs e+   -- | Create a singleton image, required for various operations on images with   -- a scalar.   singleton :: Pixel cs e -> Image arr cs e@@ -242,18 +270,32 @@   -- | 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 VectorUnboxed Y (Double): 200x300>+  --+  -- <<images/grad_fromLists.png>>+  --   fromLists :: [[Pixel cs e]]             -> Image arr cs e    -- | Perform matrix multiplication on two images. Inner dimensions must agree.   (|*|) :: Image arr cs e -> Image arr cs e -> Image arr cs e -  -- | Undirected reduction of an image.+  -- | Undirected reduction of an image.    fold :: (Pixel cs e -> Pixel cs e -> Pixel cs e) -- ^ An associative folding function.        -> Pixel cs e -- ^ Initial element, that is neutral with respect to the folding function.        -> Image arr cs e -- ^ Source image.        -> Pixel cs e +  -- | Undirected reduction of an image with an index aware function.+  foldIx :: (Pixel cs e -> (Int, Int) -> Pixel cs e -> Pixel cs e)+            -- ^ Function that takes an accumulator, index, a pixel at that+            -- index and returns a new accumulator pixel.+         -> Pixel cs e -- ^ Initial element, that is neutral with respect to the folding function.+         -> Image arr cs e -- ^ Source image.+         -> Pixel cs e+   -- | Pixelwise equality function of two images. Images are   -- considered distinct if either images' dimensions or at least one pair of   -- corresponding pixels are not the same. Used in defining an in instance for@@ -268,7 +310,7 @@ -- | Array representation that is actually has real data stored in memory, hence -- allowing for image indexing, forcing pixels into computed state etc. class BaseArray arr cs e => MArray arr cs e  where-  data MImage st arr cs e+  data MImage s arr cs e    unsafeIndex :: Image arr cs e -> (Int, Int) -> Pixel cs e   @@ -314,7 +356,7 @@   foldM_ :: (Functor m, Monad m) => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m ()    -- | Get dimensions of a mutable image.-  mdims :: MImage st arr cs e -> (Int, Int)+  mdims :: MImage s arr cs e -> (Int, Int)    -- | Yield a mutable copy of an image.   thaw :: (Functor m, PrimMonad m) =>@@ -461,105 +503,45 @@ {-# INLINE maybeIndex #-}  +-- | 2D to a flat vector index conversion.+--+-- __Note__: There is an implicit assumption that @j < n@+fromIx :: Int -- ^ @n@ columns+       -> (Int, Int) -- ^ @(i, j)@ row, column index+       -> Int -- ^ Flat vector index+fromIx !n !(i, j) = n * i + j+{-# INLINE fromIx #-} -instance ColorSpace cs => Functor (Pixel cs) where -  fmap = pxOp-  {-# INLINE fmap #-}-  -instance ColorSpace cs => Applicative (Pixel cs) where--  pure = fromChannel-  {-# INLINE pure #-}--  (<*>) = chApp-  {-# INLINE (<*>) #-}+-- | Flat vector to 2D index conversion.+toIx :: Int -- ^ @n@ columns+     -> Int -- ^ Flat vector index+     -> (Int, Int) -- ^ @(i, j)@ row, column index+toIx !n !k = divMod k n+{-# INLINE toIx #-}  -instance ColorSpace cs => Foldable (Pixel cs) where--  foldMap = pxFoldMap-  {-# INLINE foldMap #-}+checkDims :: String -> (Int, Int) -> (Int, Int)+checkDims err !ds@(m, n)+  | m <= 0 || n <= 0 = +    error $+    show err ++ ": Image dimensions are expected to be non-negative: " ++ show ds+  | otherwise = ds+{-# INLINE checkDims #-}  -instance (ColorSpace cs, Num e) => Num (Pixel cs e) where-  (+)         = liftA2 (+)-  {-# INLINE (+) #-}-  -  (-)         = liftA2 (-)-  {-# INLINE (-) #-}-  -  (*)         = liftA2 (*)-  {-# INLINE (*) #-}-  -  abs         = liftA abs-  {-# INLINE abs #-}-  -  signum      = liftA signum-  {-# INLINE signum #-}-  -  fromInteger = pure . fromInteger-  {-# INLINE fromInteger #-}-  --instance (ColorSpace cs, Fractional e) => Fractional (Pixel cs e) where-  (/)          = liftA2 (/)-  {-# INLINE (/) #-}+instance (Applicative (Pixel cs), Bounded e) => Bounded (Pixel cs e) where+  maxBound = pure maxBound+  {-# INLINE maxBound #-}   -  recip        = liftA recip-  {-# INLINE recip #-}--  fromRational = pure . fromRational-  {-# INLINE fromRational #-}+  minBound = pure minBound+  {-# INLINE minBound #-}  -instance (ColorSpace cs, Floating e) => Floating (Pixel cs e) where-  pi      = fromChannel pi-  {-# INLINE pi #-}--  exp     = liftA exp-  {-# INLINE exp #-}--  log     = liftA log-  {-# INLINE log #-}-  -  sin     = liftA sin-  {-# INLINE sin #-}-  -  cos     = liftA cos-  {-# INLINE cos #-}-  -  asin    = liftA asin-  {-# INLINE asin #-}-  -  atan    = liftA atan-  {-# INLINE atan #-}-  -  acos    = liftA acos-  {-# INLINE acos #-}-  -  sinh    = liftA sinh-  {-# INLINE sinh #-}-  -  cosh    = liftA cosh-  {-# INLINE cosh #-}-  -  asinh   = liftA asinh-  {-# INLINE asinh #-}-  -  atanh   = liftA atanh-  {-# INLINE atanh #-}-  -  acosh   = liftA acosh-  {-# INLINE acosh #-}-+instance (Foldable (Pixel cs), NFData e) => NFData (Pixel cs e) where -instance (ColorSpace cs, Bounded e) => Bounded (Pixel cs e) where-  maxBound = fromChannel maxBound-  {-# INLINE maxBound #-}-  -  minBound = fromChannel minBound-  {-# INLINE minBound #-}+  rnf = foldr' deepseq ()+  {-# INLINE rnf #-}   instance (Array arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where

@@ -1,4 +1,6 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module      : Graphics.Image.Interface.Repa -- Copyright   : (c) Alexey Kuleshevich 2016@@ -8,50 +10,69 @@ -- Portability : non-portable -- module Graphics.Image.Interface.Repa (-  -- * Construction-  makeImageS, makeImageP, fromListsS, fromListsP,-  -- * Representation-  RS(..), RP(..),   -- * Conversion-  fromRepaArrayS, fromRepaArrayP, toRepaArray+  --fromRepaArrayS, fromRepaArrayP,+  toRepaArray,+  -- * Representation+  RSU(..), RPU(..), RSS(..), RPS(..)   ) where -import Graphics.Image.Interface hiding (makeImage, fromLists)-import qualified Graphics.Image.Interface as I (makeImage, fromLists)-import Graphics.Image.Interface.Repa.Internal+import Data.Array.Repa.Index+import qualified Data.Array.Repa as R +import Graphics.Image.Interface+import Graphics.Image.Interface.Repa.Generic+import Graphics.Image.Interface.Repa.Storable+import Graphics.Image.Interface.Repa.Unboxed --- | Create an image with sequential array representation.-makeImageS :: Array RS cs Double =>-             (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.-          -> ((Int, Int) -> Pixel cs Double)-             -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument-             -- and returns a pixel for that location.-          -> Image RS cs Double-makeImageS = I.makeImage-{-# INLINE makeImageS #-} --- | Create an image with parallel array representation.-makeImageP :: Array RP cs Double =>-             (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.-          -> ((Int, Int) -> Pixel cs Double)-             -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument-             -- and returns a pixel for that location.-          -> Image RP cs Double-makeImageP = I.makeImage-{-# INLINE makeImageP #-}  --- | Construct an image from a nested rectangular shaped list of pixels sequentially.-fromListsS-  :: Array RS cs e-  => [[Pixel cs e]] -> Image RS cs e-fromListsS = I.fromLists-{-# INLINE fromListsS #-} --- | Construct an image from a nested rectangular shaped list of pixels in parallel.-fromListsP-  :: Array RP cs e-  => [[Pixel cs e]] -> Image RP cs e-fromListsP = I.fromLists-{-# INLINE fromListsP #-}+-- | Makes a copy of an image into a Storable representation sequentially.+instance Exchangable RSU RSS where+  exchange _ (SUImage (SScalar px)) = SSImage (SScalar px)+  exchange _ (SUImage img)          = SSImage . compute . SDImage . getDelayedS $ img+  {-# INLINE exchange #-}+++-- | Makes a copy of an image into a Storable representation sequentially.+instance Exchangable RPU RPS where+  exchange _ (PUImage (PScalar px)) = PSImage (PScalar px)+  exchange _ (PUImage img)          = PSImage . compute . PDImage . getDelayedP $ img+  {-# INLINE exchange #-}+++-- | Makes a copy of an image into a Unboxed representation sequentially.+instance Exchangable RSS RSU where+  exchange _ (SSImage (SScalar px)) = SUImage (SScalar px)+  exchange _ (SSImage img)          = SUImage . compute . SDImage . getDelayedS $ img+  {-# INLINE exchange #-}+++-- | Makes a copy of an image into a Unboxed representation sequentially.+instance Exchangable RPS RPU where+  exchange _ (PSImage (PScalar px)) = PUImage (PScalar px)+  exchange _ (PSImage img)          = PUImage . compute . PDImage . getDelayedP $ img+  {-# INLINE exchange #-}++++-- -- | Create a sequential image from a 2D Repa delayed array.+-- fromRepaArrayS :: R.Array R.D DIM2 (Pixel cs e) -> Image RS cs e+-- fromRepaArrayS = SDImage+++-- -- | Create a parallel image from a 2D Repa delayed array.+-- fromRepaArrayP :: R.Array R.D DIM2 (Pixel cs e) -> Image RP cs e+-- fromRepaArrayP = PDImage++-- | Retrieve an underlying Repa array from an image.+toRepaArray+  :: (Array arr cs e, Array RSU cs e, Exchangable arr RSU)+  => Image arr cs e -> R.Array R.U DIM2 (Pixel cs e)+toRepaArray img =+  case exchange RSU img of+    (SUImage (STImage arr)) -> arr+    (SUImage (SDImage arr)) -> R.computeS arr+    (SUImage (SScalar px))  -> R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px

@@ -0,0 +1,494 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ >= 800+    {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+#endif+-- |+-- Module      : Graphics.Image.Interface.Repa.Generic+-- Copyright   : (c) Alexey Kuleshevich 2017+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Graphics.Image.Interface.Repa.Generic where++import Prelude as P+import Data.Array.Repa.Index+import qualified Data.Array.Repa as R+import qualified Data.Array.Repa.Eval as R++import Graphics.Image.ColorSpace.Binary (Bit(..))+import Graphics.Image.Interface as I+import qualified Graphics.Image.Interface.Vector.Unboxed as IVU+import qualified Graphics.Image.Interface.Vector.Generic as IVG+import Graphics.Image.Interface.Repa.Helpers+++type family Repr arr :: *+++-- | Repa Array representation, which is computed in parallel.+data RP r = RP r++-- | Repa Array representation, which is computed sequentially. +data RS r = RS r++instance Show r => Show (RP r) where+  show (RP r) = "RepaParallel " ++ show r+  +instance Show r => Show (RS r) where+  show (RS r) = "RepaSequential " ++ show r+++-----------------------+-- Sequential Arrays --+-----------------------++instance SuperClass (RS r) cs e => BaseArray (RS r) cs e where+  type SuperClass (RS r) cs e =+    (Show r, ColorSpace cs e, Num (Pixel cs e), R.Elt (Pixel cs e), R.Elt e, +     R.Target (Repr (RS r)) (Pixel cs e), R.Source (Repr (RS r)) (Pixel cs e),+     IVU.Unbox e, IVU.Unbox (Components cs e), +     BaseArray (IVG.V r) cs e, Repr (RP r) ~ Repr (RS r))+  +  data Image (RS r) cs e = SScalar !(Pixel cs e)+                         | STImage !(R.Array (Repr (RS r)) R.DIM2 (Pixel cs e))+                         | SDImage !(R.Array R.D R.DIM2 (Pixel cs e))+                       +  dims (SScalar _                          ) = (1, 1)+  dims (STImage (R.extent -> (Z :. m :. n))) = (m, n)+  dims (SDImage (R.extent -> (Z :. m :. n))) = (m, n)+  {-# INLINE dims #-}+++instance (BaseArray (RS r) cs e) => Array (RS r) cs e where++  type Manifest (RS r) = Manifest (IVG.V r)+  +  makeImage !(checkDims "RS.makeImage" -> (m, n)) f =+    SDImage $ R.fromFunction (Z :. m :. n) (f . sh2ix)+  {-# INLINE makeImage #-}+  +  makeImageWindowed !(checkDims "RS.makeImage" -> (m, n)) !window getWindowPx getBorderPx  =+    SDImage $ R.delay $ makeWindowed (Z :. m :. n) window+    (R.fromFunction (Z :. m :. n) (getWindowPx . sh2ix))+     (R.fromFunction (Z :. m :. n) (getBorderPx . sh2ix))+    +  singleton = SScalar+  {-# INLINE singleton #-}++  index00 (SScalar px)  = px+  index00 (STImage arr) = R.index arr (Z :. 0 :. 0)+  index00 (SDImage arr) = R.index arr (Z :. 0 :. 0)+  {-# INLINE index00 #-}++  map f (SScalar px)  = SScalar (f px)+  map f (STImage arr) = SDImage (R.map f arr)+  map f (SDImage arr) = SDImage (R.map f arr)+  {-# INLINE map #-}++  imap f (SScalar px)  = SScalar (f (0, 0) px)+  imap f (STImage arr) = SDImage (imapR f arr)+  imap f (SDImage arr) = SDImage (imapR f arr)+  {-# INLINE imap #-}++  zipWith f (SScalar px1) (SScalar px2) = SScalar (f px1 px2)+  zipWith f (SScalar px1) !img2         = I.map (f px1) img2+  zipWith f !img1         (SScalar px2) = I.map (`f` px2) img1+  zipWith f !img1         !img2         =+    SDImage (R.zipWith f (getDelayedS img1) (getDelayedS img2))+  {-# INLINE zipWith #-}++  izipWith f (SScalar px1) (SScalar px2) = SScalar (f (0, 0) px1 px2)+  izipWith f (SScalar px1) !img2         = imap (`f` px1) img2+  izipWith f !img1         (SScalar px2) = imap (\ !ix !px -> f ix px px2) img1+  izipWith f !img1         !img2         =+    SDImage (izipWithR f (getDelayedS img1) (getDelayedS img2))+  {-# INLINE izipWith #-}+  +  traverse !img getNewDims getNewPx =+    SDImage (traverseR (getDelayedS img) getNewDims getNewPx)+  {-# INLINE traverse #-}++  traverse2 !img1 !img2 getNewDims getNewPx =+    SDImage (traverse2R (getDelayedS img1) (getDelayedS img2) getNewDims getNewPx)+  {-# INLINE traverse2 #-}++  transpose (SDImage arr) = SDImage (R.transpose arr)+  transpose (STImage arr) = SDImage (R.transpose arr)+  transpose !img          = img+  {-# INLINE transpose #-}++  backpermute !newDims g !img = SDImage (backpermuteR (getDelayedS img) newDims g)+  {-# INLINE backpermute #-}++  fromLists = STImage . fromListsR+  {-# INLINE fromLists #-}++  fold f !px0 (SDImage arr) = R.foldAllS f px0 arr+  fold f !px0 (STImage arr) = R.foldAllS f px0 arr+  fold f !px0 (SScalar px)  = f px px0+  {-# INLINE fold #-}++  foldIx f !px0 (SDImage arr) = foldIxS f px0 arr+  foldIx f !px0 (STImage arr) = foldIxS f px0 arr+  foldIx f !px0 (SScalar px)  = f px0 (0, 0) px+  {-# INLINE foldIx #-}++  eq (SScalar px1) (SScalar px2) = px1 == px2+  eq !img1 !img2 = R.equalsS (getDelayedS img1) (getDelayedS img2)+  {-# INLINE eq #-}++  compute !img@(SScalar _) = img+  compute !img@(STImage _) = img+  compute (SDImage arr)    = STImage (R.computeS arr)+  {-# INLINE compute #-}++  (|*|) img1@(STImage arr1) img2@(STImage arr2) =+     SDImage (multR (show img1 ++ " X " ++ show img2) arr1 arr2)+  (|*|) img1@(SDImage _) !img2            = compute img1 |*| img2+  (|*|) !img1            img2@(SDImage _) = img1 |*| compute img2+  (|*|) (SScalar px1)    !img2            = STImage (singletonR px1) |*| img2+  (|*|) !img1            (SScalar px2)    = img1 |*| STImage (singletonR px2)+  {-# INLINE (|*|) #-}++  toManifest _ = error $ "RS.toManifest: Cannot convert generic Repa " +++                         "representation to a generic Vector."+  {-# INLINE toManifest #-}+++---------------------+-- Parallel Arrays --+---------------------++++instance SuperClass (RP r) cs e => BaseArray (RP r) cs e where+  type SuperClass (RP r) cs e = (+    Show r, ColorSpace cs e, Num (Pixel cs e),+    R.Target (Repr (RP r)) (Pixel cs e), R.Source (Repr (RP r)) (Pixel cs e),+    BaseArray (IVG.V r) cs e, Repr (RP r) ~ Repr (RS r),+    IVU.Unbox e, IVU.Unbox (Components cs e), R.Elt e, R.Elt (Pixel cs e))+  +  data Image (RP r) cs e = PScalar !(Pixel cs e)+                         | PTImage !(R.Array (Repr (RP r)) R.DIM2 (Pixel cs e))+                         | PDImage !(R.Array R.D R.DIM2 (Pixel cs e))+                       +  dims (PScalar _                          ) = (1, 1)+  dims (PTImage (R.extent -> (Z :. m :. n))) = (m, n)+  dims (PDImage (R.extent -> (Z :. m :. n))) = (m, n)+  {-# INLINE dims #-}+++instance (BaseArray (RP r) cs e) => Array (RP r) cs e where++  type Manifest (RP r) = Manifest (IVG.V r)+  +  makeImage !(checkDims "RP.makeImage" -> (m, n)) f =+    PDImage $ R.fromFunction (Z :. m :. n) (f . sh2ix)+  {-# INLINE makeImage #-}+  +  makeImageWindowed !(checkDims "RP.makeImage" -> (m, n)) !window getWindowPx getBorderPx  =+    PDImage $ R.delay $ makeWindowed (Z :. m :. n) window+    (R.fromFunction (Z :. m :. n) (getWindowPx . sh2ix))+     (R.fromFunction (Z :. m :. n) (getBorderPx . sh2ix))+    +  singleton = PScalar+  {-# INLINE singleton #-}++  index00 (PScalar px)  = px+  index00 (PTImage arr) = R.index arr (Z :. 0 :. 0)+  index00 (PDImage arr) = R.index arr (Z :. 0 :. 0)+  {-# INLINE index00 #-}++  map f (PScalar px)  = PScalar (f px)+  map f (PTImage arr) = PDImage (R.map f arr)+  map f (PDImage arr) = PDImage (R.map f arr)+  {-# INLINE map #-}++  imap f (PScalar px)  = PScalar (f (0, 0) px)+  imap f (PTImage arr) = PDImage (imapR f arr)+  imap f (PDImage arr) = PDImage (imapR f arr)+  {-# INLINE imap #-}++  zipWith f (PScalar px1) (PScalar px2) = PScalar (f px1 px2)+  zipWith f (PScalar px1) !img2         = I.map (f px1) img2+  zipWith f !img1         (PScalar px2) = I.map (`f` px2) img1+  zipWith f !img1         !img2         =+    PDImage (R.zipWith f (getDelayedP img1) (getDelayedP img2))+  {-# INLINE zipWith #-}++  izipWith f (PScalar px1) (PScalar px2) = PScalar (f (0, 0) px1 px2)+  izipWith f (PScalar px1) !img2         = imap (`f` px1) img2+  izipWith f !img1         (PScalar px2) = imap (\ !ix !px -> f ix px px2) img1+  izipWith f !img1         !img2         =+    PDImage (izipWithR f (getDelayedP img1) (getDelayedP img2))+  {-# INLINE izipWith #-}+  +  traverse !img getNewDims getNewPx =+    PDImage (traverseR (getDelayedP img) getNewDims getNewPx)+  {-# INLINE traverse #-}++  traverse2 !img1 !img2 getNewDims getNewPx =+    PDImage (traverse2R (getDelayedP img1) (getDelayedP img2) getNewDims getNewPx)+  {-# INLINE traverse2 #-}++  transpose (PDImage arr) = PDImage (R.transpose arr)+  transpose (PTImage arr) = PDImage (R.transpose arr)+  transpose !img          = img+  {-# INLINE transpose #-}++  backpermute !newDims g !img = PDImage (backpermuteR (getDelayedP img) newDims g)+  {-# INLINE backpermute #-}++  fromLists = PTImage . fromListsR+  {-# INLINE fromLists #-}++  fold f !px0 (PScalar px) = f px0 px+  fold f !px0 img =+    case R.foldAllP f px0 (getDelayedP img) of+      Just e  -> e+      Nothing -> error $ "RP.fold: impossible happened."+  {-# INLINE fold #-}++  foldIx f !px0 (PScalar px) = f px0 (0, 0) px+  foldIx f !px0 img =+    case foldIxPUnboxed f px0 (getDelayedP img) of+      Just e  -> e+      Nothing -> error $ "RP.foldIx: impossible happened."+  {-# INLINE foldIx #-}+++  eq (PScalar px1) (PScalar px2) = px1 == px2+  eq !img1 !img2 =+    case R.equalsP (getDelayedP img1) (getDelayedP img2) of+      Just e  -> e+      Nothing -> error $ "RP.eq: impossible happened."+  {-# INLINE eq #-}++  compute !img@(PScalar _) = img+  compute !img@(PTImage _) = img+  compute (PDImage arr)    = arrManifest `R.deepSeqArray` PTImage arrManifest+     where arrManifest = R.suspendedComputeP arr+  {-# INLINE compute #-}++  (|*|) img1@(PTImage arr1) img2@(PTImage arr2) =+     PDImage (multR (show img1 ++ " X " ++ show img2) arr1 arr2)+  (|*|) img1@(PDImage _) !img2            = compute img1 |*| img2+  (|*|) !img1            img2@(PDImage _) = img1 |*| compute img2+  (|*|) (PScalar px1)    !img2            = PTImage (singletonR px1) |*| img2+  (|*|) !img1            (PScalar px2)    = img1 |*| PTImage (singletonR px2)+  {-# INLINE (|*|) #-}++  toManifest _ = error $ "RP.toManifest: Cannot convert generic Repa " +++                         "representation to a generic Vector."+  {-# INLINE toManifest #-}++++----------------------+-- Helper functions --+----------------------++sh2ix :: DIM2 -> (Int, Int)+sh2ix (Z :. i :. j) = (i, j)+{-# INLINE sh2ix #-}++ix2sh :: (Int, Int) -> DIM2+ix2sh !(i, j) = Z :. i :. j +{-# INLINE ix2sh #-}+++toRS :: Repr (RP r) ~ Repr (RS r) => Image (RP r) cs e -> Image (RS r) cs e+toRS (PScalar px)  = SScalar px+toRS (PDImage img) = SDImage img+toRS (PTImage img) = STImage img++toRP :: Repr (RP r) ~ Repr (RS r) => Image (RS r) cs e -> Image (RP r) cs e+toRP (SScalar px)  = PScalar px+toRP (SDImage img) = PDImage img+toRP (STImage img) = PTImage img+++imapR+  :: R.Source r2 b =>+     ((Int, Int) -> b -> c) -> R.Array r2 DIM2 b -> R.Array R.D DIM2 c+imapR f !arr = R.zipWith f (R.fromFunction (R.extent arr) sh2ix) arr+++-- | Combine two arrays, element-wise, with index aware operator. If the extent of+-- the two array arguments differ, then the resulting array's extent is their+-- intersection.+izipWithR+  :: (R.Source r2 t1, R.Source r1 t)+  => ((Int, Int) -> t -> t1 -> c)+  -> R.Array r1 DIM2 t+  -> R.Array r2 DIM2 t1+  -> R.Array R.D DIM2 c+izipWithR f !arr1 !arr2 =+  (R.traverse2 arr1 arr2 getNewDims getNewPx) where+    getNewPx !getPx1 !getPx2 !sh = f (sh2ix sh) (getPx1 sh) (getPx2 sh)+    getNewDims (Z :. m1 :. n1) (Z :. m2 :. n2) = Z :. min m1 m2 :. min n1 n2+    {-# INLINE getNewPx #-}+{-# INLINE izipWithR #-}+++traverseR+  :: R.Source r c+  => R.Array r DIM2 c+  -> ((Int, Int) -> (Int, Int))+  -> (((Int, Int) -> c) -> (Int, Int) -> b)+  -> R.Array R.D DIM2 b+traverseR !arr getNewDims getNewPx =+  R.traverse arr (ix2sh . checkDims "traverseR" . getNewDims . sh2ix) getNewE+  where+    getNewE getPx = getNewPx (getPx . ix2sh) . sh2ix+    {-# INLINE getNewE #-}+{-# INLINE traverseR #-}++traverse2R+  :: (R.Source r2 c1, R.Source r1 c)+  => R.Array r1 DIM2 c+  -> R.Array r2 DIM2 c1+  -> ((Int, Int) -> (Int, Int) -> (Int, Int))+  -> (((Int, Int) -> c) -> ((Int, Int) -> c1) -> (Int, Int) -> c2)+  -> R.Array R.D DIM2 c2+traverse2R !arr1 !arr2 getNewDims getNewPx =+  R.traverse2 arr1 arr2 getNewSh getNewE+  where getNewE getPx1 getPx2 = getNewPx (getPx1 . ix2sh) (getPx2 . ix2sh) . sh2ix+        {-# INLINE getNewE #-}+        getNewSh !sh1 !sh2 =+          ix2sh . checkDims "traverse2R" $ getNewDims (sh2ix sh1) (sh2ix sh2)+        {-# INLINE getNewSh #-}+{-# INLINE traverse2R #-}++backpermuteR+  :: R.Source r e+  => R.Array r DIM2 e+  -> (Int, Int)+  -> ((Int, Int) -> (Int, Int))+  -> R.Array R.D DIM2 e+backpermuteR !arr newDims g =+  R.backpermute+    (ix2sh (checkDims "backpermuteR" newDims))+    (ix2sh . g . sh2ix)+    arr+{-# INLINE backpermuteR #-}+++fromListsR :: (R.Target r e) => [[e]] -> R.Array r DIM2 e+fromListsR ls =+  if all (== n) (P.map length ls)+    then R.fromList (Z :. m :. n) . concat $ ls+    else error "fromListsR: Inner lists do not all have an equal length."+  where+    !(m, n) = checkDims "fromListsR" (length ls, length $ head ls)+{-# INLINE fromListsR #-}++++multR+  :: (ColorSpace cs e, IVU.Unbox (Components cs e), Num (Pixel cs e), R.Elt (Pixel cs e),+      R.Target r (Pixel cs e), R.Source r (Pixel cs e))+  => String -> R.Array r DIM2 (Pixel cs e) -> R.Array r DIM2 (Pixel cs e) -> R.Array R.D DIM2 (Pixel cs e)+multR errMsg !arr1 !arr2 =+  if n1 /= m2+    then error $+         "Inner dimensions of multiplied images must be the same, but received: " ++ errMsg+    else R.fromFunction (Z :. m1 :. n2) $ getPx+  where+    (Z :. m1 :. n1) = R.extent arr1+    (Z :. m2 :. n2) = R.extent arr2+    getPx (Z :. i :. j) =+      R.sumAllS+        (R.slice arr1 (R.Any :. (i :: Int) :. R.All) R.*^+         R.slice arr2 (R.Any :. (j :: Int)))+    {-# INLINE getPx #-}+{-# INLINE multR #-}+++singletonR :: (IVU.Unbox a, R.Target r a) => a -> R.Array r DIM2 a+singletonR !px = R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px+++getDelayedS :: Array (RS r) cs e => Image (RS r) cs e -> R.Array R.D DIM2 (Pixel cs e)+getDelayedS (STImage arr) = R.delay arr+getDelayedS (SDImage arr) = arr+getDelayedS (SScalar px)  = R.fromFunction (Z :. 1 :. 1) (const px)+{-# INLINE getDelayedS #-}++getDelayedP :: Array (RP r) cs e => Image (RP r) cs e -> R.Array R.D DIM2 (Pixel cs e)+getDelayedP (PTImage arr) = R.delay arr+getDelayedP (PDImage arr) = arr+getDelayedP (PScalar px)  = R.fromFunction (Z :. 1 :. 1) (const px)+{-# INLINE getDelayedP #-}+++instance R.Elt Bit where+  touch (Bit w) = R.touch w+  {-# INLINE touch #-}+  +  zero     = 0+  {-# INLINE zero #-}+  +  one      = 1+  {-# INLINE one #-}+++instance (ColorSpace cs e, R.Elt e, Num (Pixel cs e)) => R.Elt (Pixel cs e) where+  touch !px = P.mapM_ (R.touch . getPxC px) (enumFrom (toEnum 0)) +  {-# INLINE touch #-}+  +  zero     = 0+  {-# INLINE zero #-}+  +  one      = 1+  {-# INLINE one #-}+++addIxArr+  :: R.Source r2 b =>+     R.Array r2 DIM2 b -> R.Array R.D DIM2 ((Int, Int), b)+addIxArr !arr = R.zipWith (,) arrIx arr+  where+    !arrIx = R.fromFunction (R.extent arr) sh2ix+{-# INLINE addIxArr #-}+++foldIxS+  :: (R.Elt b, R.Source r2 b, IVU.Unbox b) =>+     (b -> (Int, Int) -> b -> b) -> b -> R.Array r2 DIM2 b -> b+foldIxS f !acc !arr = snd $ R.foldAllS g ((-1, 0), acc) arr'+  where+    !arr' = addIxArr arr+    g (accIx@(-1, _), acc') !(ix, px) = (accIx, f acc' ix px)+    g !(ix, px) (accIx@(-1, _), acc') = (accIx, f acc' ix px)+    g (acc1Ix, _) (acc2Ix, _) =+      error $ "foldIxS: Impossible happened. Received: " ++ show acc1Ix ++ " " ++ show acc2Ix+    {-# INLINE g #-}+{-# INLINE foldIxS #-}+++foldIxPUnboxed+  :: (R.Source r2 b, IVU.Unbox b, R.Elt b, Functor m, Monad m)+  => (b -> (Int, Int) -> b -> b) -> b -> R.Array r2 DIM2 b -> m b+foldIxPUnboxed f !acc !arr = snd <$> R.foldAllP g ((-1, 0), acc) arr'+  where+    !arr' = addIxArr arr+    g (accIx@(-1, _), acc') !(ix, px) = (accIx, f acc' ix px)+    g !(ix, px) (accIx@(-1, _), acc') = (accIx, f acc' ix px)+    g (acc1Ix, _) (acc2Ix, _) =+      error $ "foldIxPUnboxed: Impossible happened. Received: " ++ show acc1Ix ++ " " ++ show acc2Ix+    {-# INLINE g #-}+{-# INLINE foldIxPUnboxed #-}+

@@ -0,0 +1,39 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+module Graphics.Image.Interface.Repa.Helpers where++import Data.Array.Repa+import Data.Array.Repa.Repr.Partitioned+import Data.Array.Repa.Repr.Undefined++-- | Make a 2D windowed array from two others, one to produce the elements in+--   the internal region, and one to produce elements in the border region. The+--   two arrays must have the same extent.+--+makeWindowed+        :: (Source r1 a, Source r2 a)+        => DIM2                 -- ^ Extent of array.+        -> ((Int, Int), (Int, Int))  -- ^ Window points.+        -> Array r1 DIM2 a      -- ^ Array for internal elements.+        -> Array r2 DIM2 a      -- ^ Array for border elements.+        -> Array (P r1 (P r2 (P r2 (P r2 (P r2 X))))) DIM2 a+makeWindowed sh@(_ :. m :. n) !((it, jt), (ib, jb)) arrWindow arrBorder =+  checkDims `seq`+  let inInternal (Z :. i :. j) = i >= it && i < ib && j >= jt && j < jb+      {-# INLINE inInternal #-}+      inBorder = not . inInternal+      {-# INLINE inBorder #-}+  in APart sh (Range (Z :. it :. jt) (Z :. (ib - it) :. (jb - jt)) inInternal) arrWindow $+     APart sh (Range (Z :. 0 :.  0 ) (Z :. it        :. n        ) inBorder  ) arrBorder $+     APart sh (Range (Z :. it :. 0 ) (Z :. (ib - it) :. jt       ) inBorder  ) arrBorder $+     APart sh (Range (Z :. it :. jb) (Z :. (ib - it) :. (n - jb) ) inBorder  ) arrBorder $+     APart sh (Range (Z :. ib :. 0 ) (Z :. (m - ib)  :. n        ) inBorder  ) arrBorder $+     AUndefined sh+  where+    checkDims =+      if extent arrWindow == extent arrBorder+        then ()+        else error+               "makeWindowed: internal and border arrays have different extents"+    {-# NOINLINE checkDims #-}+{-# INLINE makeWindowed #-}

@@ -1,490 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--- |--- Module      : Graphics.Image.Interface.Repa.Internal--- Copyright   : (c) Alexey Kuleshevich 2016--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.Image.Interface.Repa.Internal (-  RP(..), RS(..),-  fromRepaArrayS, fromRepaArrayP, toRepaArray-  ) 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(..))-import Graphics.Image.Interface.Vector.Unboxed-       (VU(..), fromUnboxedVector, toUnboxedVector, checkDims)-import Data.Array.Repa.Repr.Unboxed (Unbox)-import qualified Data.Vector.Unboxed as V (singleton)--import Data.Typeable (Typeable)-import Data.Array.Repa.Index-import qualified Data.Array.Repa as R -import qualified Data.Array.Repa.Eval as R (Elt(..), suspendedComputeP)----- | Repa 'U'nboxed Array representation, which is computed in parallel.-data RP = RP---- | Repa 'U'nboxed Array representation, which is computed sequentially. -data RS = RS--instance Show RP where-  show _ = "RepaParallel"-  -instance Show RS where-  show _ = "RepaSequential"----instance Elt RS cs e => BaseArray RS cs e where-  type Elt RS cs e = (ColorSpace cs, -                      R.Elt e, Unbox e, Num e, Typeable e,-                      R.Elt (PixelElt cs e), Unbox (PixelElt cs e),-                      R.Elt (Pixel cs e), Unbox (Pixel cs e))-  -  data Image RS cs e = SScalar !(Pixel cs e)-                     | SUImage !(R.Array R.U R.DIM2 (Pixel cs e))-                     | SDImage !(R.Array R.D R.DIM2 (Pixel cs e))-                       -  dims (SScalar _                          ) = (1, 1)-  dims (SUImage (R.extent -> (Z :. m :. n))) = (m, n)-  dims (SDImage (R.extent -> (Z :. m :. n))) = (m, n)-  {-# INLINE dims #-}---instance (BaseArray RS cs e) => Array RS cs e where--  type Manifest RS = VU-  -  makeImage !(checkDims "RS.makeImage" -> (m, n)) !f =-    SDImage $ R.fromFunction (Z :. m :. n) (f . sh2dims)-  {-# INLINE makeImage #-}-  -  singleton = SScalar-  {-# INLINE singleton #-}--  index00 (SScalar px)  = px-  index00 (SUImage arr) = R.index arr (Z :. 0 :. 0)-  index00 (SDImage arr) = R.index arr (Z :. 0 :. 0)-  {-# INLINE index00 #-}--  map !f (SScalar px)  = SScalar (f px)-  map !f (SUImage arr) = SDImage (R.map f arr)-  map !f (SDImage arr) = SDImage (R.map f arr)-  {-# INLINE map #-}--  imap !f (SScalar px)  = SScalar (f (0, 0) px)-  imap !f (SUImage arr) = SDImage (imapR f arr)-  imap !f (SDImage arr) = SDImage (imapR f arr)-  {-# INLINE imap #-}--  zipWith f (SScalar px1)  (SScalar px2)  = SScalar (f px1 px2)-  zipWith f (SScalar px1)  img2           = map (f px1) img2-  zipWith f img1           (SScalar px2)  = map (`f` px2) img1-  zipWith f img1           img2           =-    SDImage (R.zipWith f (getDelayedS img1) (getDelayedS img2))-  {-# INLINE zipWith #-}--  izipWith f (SScalar px1)  (SScalar px2)  = SScalar (f (0, 0) px1 px2)-  izipWith f (SScalar px1)  img2           = imap (`f` px1) img2-  izipWith f img1           (SScalar px2)  = imap (\ !ix !px -> f ix px px2) img1-  izipWith f img1           img2           =-    SDImage (izipWithR f (getDelayedS img1) (getDelayedS img2))-  {-# INLINE izipWith #-}-  -  -- traverse (SScalar px) getNewDims getNewPx =-  --   makeImage (getNewDims (1, 1)) (getNewPx (const px))-  traverse img          getNewDims getNewPx =-    SDImage (traverseR (getDelayedS img) getNewDims getNewPx)-  {-# INLINE traverse #-}--  -- traverse2 (SScalar px1) (SScalar px2) getNewDims getNewPx =-  --   makeImage (getNewDims (1, 1) (1, 1)) (getNewPx (const px1) (const px2))-  traverse2 img1 img2 getNewDims getNewPx =-    SDImage (traverse2R (getDelayedS img1) (getDelayedS img2) getNewDims getNewPx)-  {-# INLINE traverse2 #-}--  transpose (SDImage arr) = SDImage (R.transpose arr)-  transpose (SUImage arr) = SDImage (R.transpose arr)-  transpose !img          = img-  {-# INLINE transpose #-}--  -- backpermute !newDims _ (SScalar px) =-  --   SDImage $ R.fromFunction (dims2sh $ checkDims "RS.backpermute" newDims) (const px)-  backpermute !newDims g !img = SDImage (backpermuteR (getDelayedS img) newDims g)-  {-# INLINE backpermute #-}--  fromLists = SUImage . fromListsR-  {-# INLINE fromLists #-}--  fold f !px0 (SDImage arr) = R.foldAllS f px0 arr-  fold f !px0 (SUImage arr) = R.foldAllS f px0 arr-  fold f !px0 (SScalar px)  = f px0 px-  {-# INLINE fold #-}--  eq (SScalar px1) (SScalar px2) = px1 == px2-  eq img1 img2 = R.equalsS (getDelayedS img1) (getDelayedS img2)-  {-# INLINE eq #-}--  compute img@(SScalar _) = img-  compute img@(SUImage _) = img-  compute (SDImage arr)   = SUImage $ R.computeS arr-  {-# INLINE compute #-}--  (SUImage arr1)   |*| (SUImage arr2)   = SDImage (multR arr1 arr2)-  img1@(SDImage _) |*| img2             = compute img1 |*| img2-  img1             |*| img2@(SDImage _) = img1 |*| compute img2-  (SScalar px1)    |*| img2             = SUImage (singletonR px1) |*| img2-  img1             |*| (SScalar px2)    = img1 |*| SUImage (singletonR px2)-  {-# INLINE (|*|) #-}--  toManifest img@(SUImage arr) = fromUnboxedVector (dims img) (R.toUnboxed arr)-  toManifest (SScalar px)      = singleton px-  toManifest img               = toManifest (compute img)-  {-# INLINE toManifest #-}-------------------------- Parallel Arrays --------------------------instance Elt RP cs e => BaseArray RP cs e where-  type Elt RP cs e = (ColorSpace cs, -                      R.Elt e, Unbox e, Num e, Typeable e,-                      R.Elt (PixelElt cs e), Unbox (PixelElt cs e),-                      R.Elt (Pixel cs e), Unbox (Pixel cs e))-  -  data Image RP cs e = PScalar !(Pixel cs e)-                     | PUImage !(R.Array R.U R.DIM2 (Pixel cs e))-                     | PDImage !(R.Array R.D R.DIM2 (Pixel cs e))-                       -  dims (PScalar _                          ) = (1, 1)-  dims (PUImage (R.extent -> (Z :. m :. n))) = (m, n)-  dims (PDImage (R.extent -> (Z :. m :. n))) = (m, n)-  {-# INLINE dims #-}---instance (BaseArray RP cs e) => Array RP cs e where--  type Manifest RP = VU-  -  makeImage !(checkDims "RP.makeImage" -> (m, n)) !f =-    PDImage $ R.fromFunction (Z :. m :. n) (f . sh2dims)-  {-# INLINE makeImage #-}-  -  singleton = PScalar-  {-# INLINE singleton #-}--  index00 (PScalar px)  = px-  index00 (PUImage arr) = R.index arr (Z :. 0 :. 0)-  index00 (PDImage arr) = R.index arr (Z :. 0 :. 0)-  {-# INLINE index00 #-}--  map !f (PScalar px)  = PScalar (f px)-  map !f (PUImage arr) = PDImage (R.map f arr)-  map !f (PDImage arr) = PDImage (R.map f arr)-  {-# INLINE map #-}--  imap !f (PScalar px)  = PScalar (f (0, 0) px)-  imap !f (PUImage arr) = PDImage (imapR f arr)-  imap !f (PDImage arr) = PDImage (imapR f arr)-  {-# INLINE imap #-}--  zipWith f (PScalar px1)  (PScalar px2)  = PScalar (f px1 px2)-  zipWith f (PScalar px1)  img2           = map (f px1) img2-  zipWith f img1           (PScalar px2)  = map (`f` px2) img1-  zipWith f img1           img2           =-    PDImage (R.zipWith f (getDelayedP img1) (getDelayedP img2))-  {-# INLINE zipWith #-}--  izipWith f (PScalar px1)  (PScalar px2)  = PScalar (f (0, 0) px1 px2)-  izipWith f (PScalar px1)  img2           = imap (`f` px1) img2-  izipWith f img1           (PScalar px2)  = imap (\ !ix !px -> f ix px px2) img1-  izipWith f img1           img2           =-    PDImage (izipWithR f (getDelayedP img1) (getDelayedP img2))-  {-# INLINE izipWith #-}-  -  -- traverse (PScalar px) getNewDims getNewPx =-  --   makeImage (getNewDims (1, 1)) (getNewPx (const px))-  traverse img          getNewDims getNewPx =-    PDImage (traverseR (getDelayedP img) getNewDims getNewPx)-  {-# INLINE traverse #-}--  -- traverse2 (PScalar px1) (PScalar px2) getNewDims getNewPx =-  --   makeImage (getNewDims (1, 1) (1, 1)) (getNewPx (const px1) (const px2))-  traverse2 img1 img2 getNewDims getNewPx =-    PDImage (traverse2R (getDelayedP img1) (getDelayedP img2) getNewDims getNewPx)-  {-# INLINE traverse2 #-}--  transpose (PDImage arr) = PDImage (R.transpose arr)-  transpose (PUImage arr) = PDImage (R.transpose arr)-  transpose !img          = img-  {-# INLINE transpose #-}--  -- backpermute !newDims _ (PScalar px) =-  --   PDImage $ R.fromFunction (dims2sh $ checkDims "RS.backpermute" newDims) (const px)-  backpermute !newDims g !img = PDImage (backpermuteR (getDelayedP img) newDims g)-  {-# INLINE backpermute #-}--  fromLists = PUImage . fromListsR-  {-# INLINE fromLists #-}--  fold f !px0 (PDImage arr) = head $ R.foldAllP f px0 arr-  fold f !px0 (PUImage arr) = head $ R.foldAllP f px0 arr-  fold f !px0 (PScalar px)  = f px0 px-  {-# INLINE fold #-}--  eq (PScalar px1) (PScalar px2) = px1 == px2-  eq img1 img2 = R.equalsS (getDelayedP img1) (getDelayedP img2)-  {-# INLINE eq #-}--  compute img@(PScalar _) = img-  compute img@(PUImage _) = img-  compute (PDImage arr)   = arrU `R.deepSeqArray` PUImage arrU-    where arrU = R.suspendedComputeP arr-  {-# INLINE compute #-}--  (PUImage arr1)   |*| (PUImage arr2)   = PDImage (multR arr1 arr2)-  img1@(PDImage _) |*| img2             = compute img1 |*| img2-  img1             |*| img2@(PDImage _) = img1 |*| compute img2-  (PScalar px1)    |*| img2             = PUImage (singletonR px1) |*| img2-  img1             |*| (PScalar px2)    = img1 |*| PUImage (singletonR px2)-  {-# INLINE (|*|) #-}--  toManifest img@(PUImage arr) = fromUnboxedVector (dims img) (R.toUnboxed arr)-  toManifest (PScalar px)      = singleton px-  toManifest img               = toManifest (compute img)-  {-# INLINE toManifest #-}---------------------------- Helper functions ---------------------------sh2dims :: DIM2 -> (Int, Int)-sh2dims (Z :. i :. j) = (i, j)-{-# INLINE sh2dims #-}--dims2sh :: (Int, Int) -> DIM2-dims2sh !(i, j) = Z :. i :. j -{-# INLINE dims2sh #-}---imapR-  :: R.Source r2 b =>-     ((Int, Int) -> b -> c) -> R.Array r2 DIM2 b -> R.Array R.D DIM2 c-imapR f arr = R.zipWith f (R.fromFunction (R.extent arr) sh2dims) arr----- | Combine two arrays, element-wise, with index aware operator. If the extent of--- the two array arguments differ, then the resulting array's extent is their--- intersection.-izipWithR-  :: (R.Source r2 t1, R.Source r1 t)-  => ((Int, Int) -> t -> t1 -> c)-  -> R.Array r1 DIM2 t-  -> R.Array r2 DIM2 t1-  -> R.Array R.D DIM2 c-izipWithR f arr1 arr2 =-  (R.traverse2 arr1 arr2 getNewDims getNewPx) where-    getNewPx !getPx1 !getPx2 !sh = f (sh2dims sh) (getPx1 sh) (getPx2 sh)-    getNewDims (Z :. m1 :. n1) (Z :. m2 :. n2) = Z :. min m1 m2 :. min n1 n2-    {-# INLINE getNewPx #-}-{-# INLINE izipWithR #-}---traverseR-  :: R.Source r c-  => R.Array r DIM2 c-  -> ((Int, Int) -> (Int, Int))-  -> (((Int, Int) -> c) -> (Int, Int) -> b)-  -> R.Array R.D DIM2 b-traverseR arr getNewDims getNewPx =-  R.traverse arr (dims2sh . checkDims "traverseR" . getNewDims . sh2dims) getNewE-  where-    getNewE getPx = getNewPx (getPx . dims2sh) . sh2dims-    {-# INLINE getNewE #-}-{-# INLINE traverseR #-}--traverse2R-  :: (R.Source r2 c1, R.Source r1 c)-  => R.Array r1 DIM2 c-  -> R.Array r2 DIM2 c1-  -> ((Int, Int) -> (Int, Int) -> (Int, Int))-  -> (((Int, Int) -> c) -> ((Int, Int) -> c1) -> (Int, Int) -> c2)-  -> R.Array R.D DIM2 c2-traverse2R arr1 arr2 getNewDims getNewPx =-  R.traverse2 arr1 arr2 getNewSh getNewE-  where getNewE getPx1 getPx2 = getNewPx (getPx1 . dims2sh) (getPx2 . dims2sh) . sh2dims-        {-# INLINE getNewE #-}-        getNewSh !sh1 !sh2 =-          dims2sh . checkDims "traverse2R" $ getNewDims (sh2dims sh1) (sh2dims sh2)-        {-# INLINE getNewSh #-}-{-# INLINE traverse2R #-}--backpermuteR-  :: R.Source r e-  => R.Array r DIM2 e-  -> (Int, Int)-  -> ((Int, Int) -> (Int, Int))-  -> R.Array R.D DIM2 e-backpermuteR arr newDims g =-  R.backpermute-    (dims2sh (checkDims "backpermuteR" newDims))-    (dims2sh . g . sh2dims)-    arr-{-# INLINE backpermuteR #-}---fromListsR :: Unbox a => [[a]] -> R.Array R.U DIM2 a-fromListsR ls =-  if all (== n) (P.map length ls)-    then R.fromListUnboxed (Z :. m :. n) . concat $ ls-    else error "fromListsR: Inner lists do not all have an equal length."-  where-    !(m, n) = checkDims "fromListsR" (length ls, length $ head ls)-{-# INLINE fromListsR #-}----multR-  :: (Num a, Unbox a, R.Elt a)-  => R.Array R.U DIM2 a -> R.Array R.U DIM2 a -> R.Array R.D DIM2 a-multR arr1 arr2 =-  if n1 /= m2-    then error $-         "Inner dimensions of multiplied images must be the same, but received: " ++ ""-         --show img1 ++ " X " ++ show img2-    else R.fromFunction (Z :. m1 :. n2) $ getPx-  where-    (Z :. m1 :. n1) = R.extent arr1-    (Z :. m2 :. n2) = R.extent arr2-    getPx (Z :. i :. j) =-      R.sumAllS-        (R.slice arr1 (R.Any :. (i :: Int) :. R.All) R.*^-         R.slice arr2 (R.Any :. (j :: Int)))-    {-# INLINE getPx #-}-{-# INLINE multR #-}---singletonR :: Unbox e => e -> R.Array R.U DIM2 e-singletonR px = R.fromUnboxed (Z :. 1 :. 1) $ V.singleton px---getDelayedS :: Array RS cs e => Image RS cs e -> R.Array R.D DIM2 (Pixel cs e)-getDelayedS (SUImage arr) = R.delay arr-getDelayedS (SDImage arr) = arr-getDelayedS (SScalar px)  = R.fromFunction (Z :. 1 :. 1) (const px)-{-# INLINE getDelayedS #-}--getDelayedP :: Array RP cs e => Image RP cs e -> R.Array R.D DIM2 (Pixel cs e)-getDelayedP (PUImage arr) = R.delay arr-getDelayedP (PDImage arr) = arr-getDelayedP (PScalar px)  = R.fromFunction (Z :. 1 :. 1) (const px)-{-# INLINE getDelayedP #-}----- | Changes computation strategy. Will casue all fused operations to be computed.-instance Exchangable RP RS where-  -  exchange _ (PScalar px)   = SScalar px-  exchange _ (PUImage arr)  = SUImage arr-  exchange r img@(PDImage _) = exchange r (compute img)-  {-# INLINE exchange #-}----- | Changes computation strategy. Will casue all fused operations to be computed.-instance Exchangable RS RP where-  -  exchange _ (SScalar px)   = PScalar px-  exchange _ (SUImage arr)  = PUImage arr-  exchange r img@(SDImage _) = exchange r (compute img)-  {-# INLINE exchange #-}----- | O(1) - Changes to Repa representation.-instance Exchangable VU RS where-  exchange _ img@(dims -> (1, 1)) = singleton (img `index` (0, 0))-  exchange _ img = SUImage . R.fromUnboxed (dims2sh $ dims img) . toUnboxedVector $ img-  {-# INLINE exchange #-}----- | O(1) - Changes to Repa representation.-instance Exchangable VU RP where-  exchange _ img@(dims -> (1, 1)) = singleton (img `index` (0, 0))-  exchange _ img = PUImage . R.fromUnboxed (dims2sh $ dims img) . toUnboxedVector $ img-  {-# INLINE exchange #-}----- | O(1) - Changes to Vector representation.-instance Exchangable RS VU where-  exchange _ = toManifest-  {-# INLINE exchange #-}----- | O(1) - Changes to Vector representation.-instance Exchangable RP VU where-  exchange _ = toManifest-  {-# INLINE exchange #-}----- | Create a sequential image from a 2D Repa delayed array.-fromRepaArrayS :: R.Array R.D DIM2 (Pixel cs e) -> Image RS cs e-fromRepaArrayS = SDImage----- | Create a parallel image from a 2D Repa delayed array.-fromRepaArrayP :: R.Array R.D DIM2 (Pixel cs e) -> Image RP cs e-fromRepaArrayP = PDImage----- | Retrieve an underlying Repa array from an image.-toRepaArray-  :: (Array arr cs e, Array RS cs e, Exchangable arr RS)-  => Image arr cs e -> R.Array R.U DIM2 (Pixel cs e)-toRepaArray img =-  case compute (exchange RS img) of-    SUImage arr -> arr-    SDImage arr -> R.computeS arr -- shouldn't occur, but for completeness-    SScalar px -> R.computeS $ R.fromFunction (Z :. 1 :. 1) $ const px--instance R.Elt Bit where-  touch (Bit w) = R.touch w-  {-# INLINE touch #-}-  -  zero     = 0-  {-# INLINE zero #-}-  -  one      = 1-  {-# INLINE one #-}---instance (ColorSpace cs, R.Elt e, Num e) => R.Elt (Pixel cs e) where-  touch !px = P.mapM_ (R.touch . getPxCh px) (enumFrom (toEnum 0)) -  {-# INLINE touch #-}-  -  zero     = 0-  {-# INLINE zero #-}-  -  one      = 1-  {-# INLINE one #-}--

@@ -0,0 +1,275 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module      : Graphics.Image.Interface.Repa.Storable+-- Copyright   : (c) Alexey Kuleshevich 2017+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Graphics.Image.Interface.Repa.Storable (+  RSS(..), RPS(..), Image(..)+  ) where++import Prelude as P+import Data.Array.Repa.Index+import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.Eval as R+import qualified Data.Array.Repa.Repr.ForeignPtr as R+import qualified Data.Vector.Storable as VS+import Foreign.Storable++import Graphics.Image.Interface as I+import Graphics.Image.Interface.Repa.Generic+import qualified Graphics.Image.Interface.Vector.Storable as IVS+import qualified Graphics.Image.Interface.Vector.Unboxed as IVU++++-- | Repa Array representation backed by Storable Vector, which is computed sequentially. +data RSS = RSS++-- | Repa Array representation backed by Storable Vector, which is computed in parallel.+data RPS = RPS++instance Show RSS where+  show RSS = "RepaSequentialStorable"++instance Show RPS where+  show RPS = "RepaParallelStorable"+  ++type instance Repr (RS IVS.S) = R.F++type instance Repr (RP IVS.S) = R.F+++instance SuperClass RSS cs e => BaseArray RSS cs e where+  type SuperClass RSS cs e =+    (ColorSpace cs e, Num (Pixel cs e),+     Storable e, Storable (Pixel cs e),+     IVU.Unbox e, IVU.Unbox (Components cs e), +     R.Elt e, R.Elt (Pixel cs e))+  +  data Image RSS cs e = SSImage !(Image (RS IVS.S) cs e)+                       +  dims (SSImage img) = dims img+  {-# INLINE dims #-}+++instance (BaseArray RSS cs e) => Array RSS cs e where++  type Manifest RSS = IVS.VS+  +  makeImage !sz f = SSImage (makeImage sz f)+  {-# INLINE makeImage #-}+ +  makeImageWindowed !sz !w f = SSImage . makeImageWindowed sz w f+  {-# INLINE makeImageWindowed #-}+ +  singleton = SSImage . I.singleton+  {-# INLINE singleton #-}++  index00 (SSImage img) = index00 img+  {-# INLINE index00 #-}++  map f (SSImage img) = SSImage (I.map f img)+  {-# INLINE map #-}++  imap f (SSImage img) = SSImage (I.imap f img)+  {-# INLINE imap #-}++  zipWith f (SSImage img1) (SSImage img2) = SSImage (I.zipWith f img1 img2)+  {-# INLINE zipWith #-}++  izipWith f (SSImage img1) (SSImage img2) = SSImage (I.izipWith f img1 img2)+  {-# INLINE izipWith #-}++  traverse (SSImage img) f g = SSImage (I.traverse img f g)+  {-# INLINE traverse #-}++  traverse2 (SSImage img1) (SSImage img2) f g = SSImage (I.traverse2 img1 img2 f g)+  {-# INLINE traverse2 #-}++  transpose (SSImage img) = SSImage (I.transpose img)+  {-# INLINE transpose #-}++  backpermute !sz g (SSImage img) = SSImage (I.backpermute sz g img)+  {-# INLINE backpermute #-}++  fromLists = SSImage . fromLists+  {-# INLINE fromLists #-}++  fold f !px0 (SSImage img) = fold f px0 img+  {-# INLINE fold #-}++  foldIx f !px0 (SSImage img) = foldIx f px0 img+  {-# INLINE foldIx #-}++  eq (SSImage img1) (SSImage img2) = img1 == img2+  {-# INLINE eq #-}++  compute (SSImage img) = SSImage (compute img)+  {-# INLINE compute #-}++  (|*|) (SSImage img1) (SSImage img2) = SSImage (img1 |*| img2)+  {-# INLINE (|*|) #-}++  toManifest (SSImage (SScalar px)) = I.singleton px+  toManifest (SSImage (STImage arr)) = fromRepaArrayStorable arr+  toManifest !img = toManifest (compute img)+  {-# INLINE toManifest #-}++++instance SuperClass RPS cs e => BaseArray RPS cs e where+  type SuperClass RPS cs e =+    (ColorSpace cs e, Num (Pixel cs e),+     Storable e, Storable (Pixel cs e),+     IVU.Unbox e, IVU.Unbox (Components cs e),+     R.Elt e, R.Elt (Pixel cs e))+  +  data Image RPS cs e = PSImage !(Image (RP IVS.S) cs e)+                       +  dims (PSImage img) = dims img+  {-# INLINE dims #-}+++instance (BaseArray RPS cs e) => Array RPS cs e where++  type Manifest RPS = IVS.VS+  +  makeImage !sz f = PSImage (makeImage sz f)+  {-# INLINE makeImage #-}+ +  makeImageWindowed !sz !w f = PSImage . makeImageWindowed sz w f+  {-# INLINE makeImageWindowed #-}+ +  singleton = PSImage . singleton+  {-# INLINE singleton #-}++  index00 (PSImage img) = index00 img+  {-# INLINE index00 #-}++  map f (PSImage img) = PSImage (I.map f img)+  {-# INLINE map #-}++  imap f (PSImage img) = PSImage (I.imap f img)+  {-# INLINE imap #-}++  zipWith f (PSImage img1) (PSImage img2) = PSImage (I.zipWith f img1 img2)+  {-# INLINE zipWith #-}++  izipWith f (PSImage img1) (PSImage img2) = PSImage (I.izipWith f img1 img2)+  {-# INLINE izipWith #-}++  traverse (PSImage img) f g = PSImage (I.traverse img f g)+  {-# INLINE traverse #-}++  traverse2 (PSImage img1) (PSImage img2) f g = PSImage (I.traverse2 img1 img2 f g)+  {-# INLINE traverse2 #-}++  transpose (PSImage img) = PSImage (I.transpose img)+  {-# INLINE transpose #-}++  backpermute !sz g (PSImage img) = PSImage (backpermute sz g img)+  {-# INLINE backpermute #-}++  fromLists = PSImage . fromLists+  {-# INLINE fromLists #-}++  fold f !px0 (PSImage img) = I.fold f px0 img+  {-# INLINE fold #-}++  foldIx f !px0 (PSImage img) = I.foldIx f px0 img+  {-# INLINE foldIx #-}++  eq (PSImage img1) (PSImage img2) = img1 == img2+  {-# INLINE eq #-}++  compute (PSImage img) = PSImage (compute img)+  {-# INLINE compute #-}++  (|*|) (PSImage img1) (PSImage img2) = PSImage (img1 |*| img2)+  {-# INLINE (|*|) #-}++  toManifest (PSImage (PScalar px)) = singleton px+  toManifest (PSImage (PTImage arr)) = fromRepaArrayStorable arr+  toManifest !img = toManifest (compute img)+  {-# INLINE toManifest #-}+++-- | Changes computation strategy. Will casue all fused operations to be computed.+instance Exchangable RPS RSS where+  +  exchange _ (PSImage img) = SSImage (toRS img)+  {-# INLINE exchange #-}+++-- | Changes computation strategy. Will casue all fused operations to be computed.+instance Exchangable RSS RPS where+  +  exchange _ (SSImage img) = PSImage (toRP img)+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Repa representation.+instance Exchangable IVS.VS RSS where+  exchange _ !img@(dims -> (1, 1)) = singleton (index00 img)+  exchange _ !img =+    SSImage . STImage . toRepaArrayStorable $ img+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Repa representation.+instance Exchangable IVS.VS RPS where+  exchange _ !img@(dims -> (1, 1)) = singleton (index00 img)+  exchange _ !img =+    PSImage . PTImage . toRepaArrayStorable $ img+  {-# INLINE exchange #-}+++-- | Changes to Vector representation.+instance Exchangable RSS IVS.VS where+  exchange _ = toManifest+  {-# INLINE exchange #-}+++-- | Changes to Vector representation.+instance Exchangable RPS IVS.VS where+  exchange _ = toManifest+  {-# INLINE exchange #-}+++fromRepaArrayStorable+  :: forall cs e.+     Array IVS.VS cs e+  => R.Array R.F DIM2 (Pixel cs e) -> Image IVS.VS cs e+fromRepaArrayStorable !arr =+  IVS.fromStorableVector (sh2ix (R.extent arr)) $+  VS.unsafeFromForeignPtr0 (R.toForeignPtr arr) sz+  where+    !sz = sizeOf (undefined :: Pixel cs e) * m * n+    (Z :. m :. n) = R.extent arr+++toRepaArrayStorable+  :: forall cs e.+     Array IVS.VS cs e+  => Image IVS.VS cs e -> R.Array R.F DIM2 (Pixel cs e)+toRepaArrayStorable !img+  | sz == sz' = R.fromForeignPtr (ix2sh (dims img)) fp+  | otherwise = error $ "toRepaArrayStorable: (impossible) Vector size mismatch: " +++                show sz ++ " vs " ++ show sz'+  where+    !(fp, sz) = VS.unsafeToForeignPtr0 $ IVS.toStorableVector img+    !sz' = sizeOf (undefined :: Pixel cs e) * m * n+    !(m, n) = dims img

@@ -0,0 +1,243 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module      : Graphics.Image.Interface.Repa.Unboxed+-- Copyright   : (c) Alexey Kuleshevich 2017+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Graphics.Image.Interface.Repa.Unboxed (+  RSU(..), RPU(..), Image(..)+  ) where++import Prelude as P+import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.Eval as R++import Graphics.Image.Interface as I+import Graphics.Image.Interface.Repa.Generic+import qualified Graphics.Image.Interface.Vector.Unboxed as IVU+++-- | Repa Array representation backed by Unboxed Vector, which is computed sequentially. +data RSU = RSU++-- | Repa Array representation backed by Unboxed Vector, which is computed in parallel.+data RPU = RPU++instance Show RSU where+  show RSU = "RepaSequentialUnboxed"++instance Show RPU where+  show RPU = "RepaParallelUnboxed"+  ++type instance Repr (RS IVU.U) = R.U++type instance Repr (RP IVU.U) = R.U+++instance SuperClass RSU cs e => BaseArray RSU cs e where+  type SuperClass RSU cs e =+    (ColorSpace cs e, Num (Pixel cs e),+     IVU.Unbox e, IVU.Unbox (Components cs e),+     R.Elt e, R.Elt (Pixel cs e))+  +  data Image RSU cs e = SUImage !(Image (RS IVU.U) cs e)+                       +  dims (SUImage img) = dims img+  {-# INLINE dims #-}+++instance (BaseArray RSU cs e) => Array RSU cs e where++  type Manifest RSU = IVU.VU+  +  makeImage !sz f = SUImage (makeImage sz f)+  {-# INLINE makeImage #-}+ +  makeImageWindowed !sz !w f = SUImage . makeImageWindowed sz w f+  {-# INLINE makeImageWindowed #-}+ +  singleton = SUImage . singleton+  {-# INLINE singleton #-}++  index00 (SUImage img) = index00 img+  {-# INLINE index00 #-}++  map f (SUImage img) = SUImage (I.map f img)+  {-# INLINE map #-}++  imap f (SUImage img) = SUImage (I.imap f img)+  {-# INLINE imap #-}++  zipWith f (SUImage img1) (SUImage img2) = SUImage (I.zipWith f img1 img2)+  {-# INLINE zipWith #-}++  izipWith f (SUImage img1) (SUImage img2) = SUImage (I.izipWith f img1 img2)+  {-# INLINE izipWith #-}++  traverse (SUImage img) f g = SUImage (I.traverse img f g)+  {-# INLINE traverse #-}++  traverse2 (SUImage img1) (SUImage img2) f g = SUImage (I.traverse2 img1 img2 f g)+  {-# INLINE traverse2 #-}++  transpose (SUImage img) = SUImage (I.transpose img)+  {-# INLINE transpose #-}++  backpermute !sz g (SUImage img) = SUImage (backpermute sz g img)+  {-# INLINE backpermute #-}++  fromLists = SUImage . fromLists+  {-# INLINE fromLists #-}++  fold f !px0 (SUImage img) = fold f px0 img+  {-# INLINE fold #-}++  foldIx f !px0 (SUImage img) = foldIx f px0 img+  {-# INLINE foldIx #-}++  eq (SUImage img1) (SUImage img2) = img1 == img2+  {-# INLINE eq #-}++  compute (SUImage img) = SUImage (compute img)+  {-# INLINE compute #-}++  (|*|) (SUImage img1) (SUImage img2) = SUImage (img1 |*| img2)+  {-# INLINE (|*|) #-}++  toManifest (SUImage (SScalar px)) = singleton px+  toManifest (SUImage (STImage arr)) =+    IVU.fromUnboxedVector (sh2ix (R.extent arr)) (R.toUnboxed arr)+  toManifest !img = toManifest (compute img)+  {-# INLINE toManifest #-}++++instance SuperClass RPU cs e => BaseArray RPU cs e where+  type SuperClass RPU cs e =+    (ColorSpace cs e, Num (Pixel cs e),+     IVU.Unbox e, IVU.Unbox (Components cs e),+     R.Elt e, R.Elt (Pixel cs e))+  +  data Image RPU cs e = PUImage !(Image (RP IVU.U) cs e)+                       +  dims (PUImage img) = dims img+  {-# INLINE dims #-}+++instance (BaseArray RPU cs e) => Array RPU cs e where++  type Manifest RPU = IVU.VU+  +  makeImage !sz f = PUImage (makeImage sz f)+  {-# INLINE makeImage #-}+ +  makeImageWindowed !sz !w f = PUImage . makeImageWindowed sz w f+  {-# INLINE makeImageWindowed #-}+ +  singleton = PUImage . singleton+  {-# INLINE singleton #-}++  index00 (PUImage img) = index00 img+  {-# INLINE index00 #-}++  map f (PUImage img) = PUImage (I.map f img)+  {-# INLINE map #-}++  imap f (PUImage img) = PUImage (I.imap f img)+  {-# INLINE imap #-}++  zipWith f (PUImage img1) (PUImage img2) = PUImage (I.zipWith f img1 img2)+  {-# INLINE zipWith #-}++  izipWith f (PUImage img1) (PUImage img2) = PUImage (I.izipWith f img1 img2)+  {-# INLINE izipWith #-}++  traverse (PUImage img) f g = PUImage (I.traverse img f g)+  {-# INLINE traverse #-}++  traverse2 (PUImage img1) (PUImage img2) f g = PUImage (I.traverse2 img1 img2 f g)+  {-# INLINE traverse2 #-}++  transpose (PUImage img) = PUImage (I.transpose img)+  {-# INLINE transpose #-}++  backpermute !sz g (PUImage img) = PUImage (backpermute sz g img)+  {-# INLINE backpermute #-}++  fromLists = PUImage . fromLists+  {-# INLINE fromLists #-}++  fold f !px0 (PUImage img) = I.fold f px0 img+  {-# INLINE fold #-}++  foldIx f !px0 (PUImage img) = I.foldIx f px0 img+  {-# INLINE foldIx #-}++  eq (PUImage img1) (PUImage img2) = img1 == img2+  {-# INLINE eq #-}++  compute (PUImage img) = PUImage (compute img)+  {-# INLINE compute #-}++  (|*|) (PUImage img1) (PUImage img2) = PUImage (img1 |*| img2)+  {-# INLINE (|*|) #-}++  toManifest (PUImage (PScalar px)) = singleton px+  toManifest (PUImage (PTImage arr)) =+    IVU.fromUnboxedVector (sh2ix (R.extent arr)) (R.toUnboxed arr)+  toManifest !img = toManifest (compute img)+  {-# INLINE toManifest #-}+++-- | Changes computation strategy. Will casue all fused operations to be computed.+instance Exchangable RPU RSU where+  +  exchange _ (PUImage img)  = SUImage (toRS img)+  {-# INLINE exchange #-}+++-- | Changes computation strategy. Will casue all fused operations to be computed.+instance Exchangable RSU RPU where+  +  exchange _ (SUImage img)  = PUImage (toRP img)+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Repa representation.+instance Exchangable IVU.VU RSU where+  exchange _ img@(dims -> (1, 1)) = singleton (index00 img)+  exchange _ img =+    SUImage . STImage . R.fromUnboxed (ix2sh $ dims img) . IVU.toUnboxedVector $ img+  {-# INLINE exchange #-}+++-- | O(1) - Changes to Repa representation.+instance Exchangable IVU.VU RPU where+  exchange _ img@(dims -> (1, 1)) = singleton (index00 img)+  exchange _ img =+    PUImage . PTImage . R.fromUnboxed (ix2sh $ dims img) . IVU.toUnboxedVector $ img+  {-# INLINE exchange #-}+++-- | Changes to Vector representation.+instance Exchangable RSU IVU.VU where+  exchange _ = toManifest+  {-# INLINE exchange #-}+++-- | Changes to Vector representation.+instance Exchangable RPU IVU.VU where+  exchange _ = toManifest+  {-# INLINE exchange #-}

@@ -1,66 +1,35 @@-{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module      : Graphics.Image.Interface.Vector--- Copyright   : (c) Alexey Kuleshevich 2016+-- Copyright   : (c) Alexey Kuleshevich 2017 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Graphics.Image.Interface.Vector (-  -- * Construction-  makeImage, fromLists, fromUnboxedVector, toUnboxedVector,   -- * Representation-  VU(..),+  VU(..), VS(..),+  -- * Conversion+  fromUnboxedVector, toUnboxedVector,+  fromStorableVector, toStorableVector,   -- * Linear index conversion   toIx, fromIx   ) where -import Graphics.Image.Interface hiding (makeImage, fromLists)-import qualified Graphics.Image.Interface as I (makeImage, fromLists)+import Data.Vector as V (convert)+import Graphics.Image.Interface+import Graphics.Image.Interface.Vector.Generic import Graphics.Image.Interface.Vector.Unboxed+import Graphics.Image.Interface.Vector.Storable  --- | Create an image with 'VU' (Vector Unboxed) representation and pixels of 'Double'--- precision. Note, that it is essential for 'Double' precision pixels to keep values--- normalized in the @[0, 1]@ range in order for an image to be written to file--- properly.------ >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY (fromIntegral i)/200 * (fromIntegral j)/200)------ Because all 'Pixel's and 'Image's are installed into 'Num', above is equivalent to:------ >>> let grad_gray = makeImage (200, 200) (\(i, j) -> PixelY $ fromIntegral (i*j)) / (200*200)--- >>> writeImage "images/grad_gray.png" grad_gray------ Creating color images is just as easy.------ >>> let grad_color = makeImage (200, 200) (\(i, j) -> PixelRGB (fromIntegral i) (fromIntegral j) (fromIntegral (i + j))) / 400--- >>> writeImage "images/grad_color.png" grad_color------ <<images/grad_gray.png>> <<images/grad_color.png>>----makeImage :: Array VU cs Double =>-             (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image.-          -> ((Int, Int) -> Pixel cs Double)-             -- ^ A function that takes (@i@-th row, and @j@-th column) as an argument-             -- and returns a pixel for that location.-          -> Image VU cs Double-makeImage = I.makeImage-{-# INLINE makeImage #-}+instance Exchangable VU VS where+  exchange _ (VUImage (VScalar px))   = VSImage (VScalar px)+  exchange _ (VUImage (VImage m n v)) = VSImage (VImage m n (V.convert v))  --- | 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 VectorUnboxed Y (Double): 200x300>------ <<images/grad_fromLists.png>>----fromLists :: Array VU cs e =>-             [[Pixel cs e]]-          -> Image VU cs e-fromLists = I.fromLists-{-# INLINE fromLists #-}+instance Exchangable VS VU where+  exchange _ (VSImage (VScalar px))   = VUImage (VScalar px)+  exchange _ (VSImage (VImage m n v)) = VUImage (VImage m n (V.convert v))