diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +1.5.1.0 +======= + +* Significantly improved convolution performance. +* Improved exchanging representation between images, by removing `Exchangable` + class, but keeping `exchange` function usage unchaged, thus it should be + backwards compatible up to a type signature. +* Created general `fromVector` to `toVector` functions +* Brought back `fromRepaArrayS` and `fromRepaArrayP` functions [#6] + 1.5.0.0 ======= diff --git a/benchmarks/Canny.hs b/benchmarks/Canny.hs --- a/benchmarks/Canny.hs +++ b/benchmarks/Canny.hs @@ -8,13 +8,13 @@ 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 - +import Data.Array.Repa.Eval as R +import Data.Array.Repa.Repr.Unboxed as R +import Data.Array.Repa.Stencil as R +import Data.Array.Repa.Stencil.Dim2 as R +import Data.Array.Repa.Algorithms.Convolve as R +-- import Graphics.Image.Interface.Vector sobelGx :: I.Array arr cs e => Image arr cs e -> Image arr cs e sobelGx = @@ -24,28 +24,19 @@ 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' = +sobelGxSep :: I.Array arr cs e => Image arr cs e -> Image arr cs e +sobelGxSep = 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' = +sobelGySep :: I.Array arr cs e => Image arr cs e -> Image arr cs e +sobelGySep = convolveCols Edge [1, 0, -1] . convolveRows Edge [1, 2, 1] +sobelGxRAlg :: (Unbox e, Num e, Monad m) => R.Array U DIM2 e -> m (R.Array U DIM2 e) +sobelGxRAlg = + convolveOutP outClamp (R.fromListUnboxed (Z :. 3 :. 3) [-1, 0, 1, -2, 0, 2, -1, 0, 1]) + sobelGxR :: (Source r e, Num e) => R.Array r DIM2 e -> R.Array PC5 DIM2 e @@ -85,77 +76,24 @@ main :: IO () main = do - img' <- readImageRGB RPU "images/downloaded/frog-1280x824.jpg" - let !imgU = compute img' - --let !imgS = exchange RPS imgU + -- img' <- readImageRGB RPU "images/frog.jpg" + -- let !imgU = compute img' + let !imgU = compute $ makeImage (1024, 768) + (\(i, j) -> fromIntegral ((min i j) `div` (1 + max i j ))) + :: Image RPU Y Word8 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 sobelSepU = sobelGxSep imgU let !imgR = toRepaArray imgU - --imgRDouble <- force $ R.map (`getPxCh` Y) imgR let sobelR = sobelGxR imgR - --let sobelRDouble = sobelGxR imgRDouble + let sobelRAlg = sobelGxRAlg imgR defaultMain [ bgroup "Sobel" - [ bench "naive U" $ whnf compute sobelU + [ + 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) + , bench "repa U Agorithms" $ whnfIO sobelRAlg + , bench "repa U Stencil" $ whnfIO (force sobelR) ] ] - -- 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) - -- ] - -- ] diff --git a/hip.cabal b/hip.cabal --- a/hip.cabal +++ b/hip.cabal @@ -1,5 +1,5 @@ Name: hip -Version: 1.5.0.0 +Version: 1.5.1.0 License: BSD3 License-File: LICENSE Author: Alexey Kuleshevich @@ -27,15 +27,15 @@ Default-Language: Haskell2010 HS-Source-Dirs: src - Build-Depends: base >= 4.5 && < 5 - , bytestring >= 0.9.0.4 - , Chart >= 1.5 + Build-Depends: Chart >= 1.5 , Chart-diagrams >= 1.5 + , JuicyPixels >= 3.2.7 + , base >= 4.5 && < 5 + , bytestring >= 0.9.0.4 , colour >= 2.3.3 , deepseq >= 1.1 , directory >= 1.2.2.0 , filepath >= 1.0 - , JuicyPixels >= 3.2.7 , netpbm >= 1.0.1 , primitive >= 0.4 , process >= 1.1.0.0 @@ -107,6 +107,7 @@ , Graphics.Image.Processing.BinarySpec , Graphics.Image.InterfaceSpec , Graphics.Image.Interface.VectorSpec + , Graphics.Image.Interface.RepaSpec , Graphics.Image.IO.FormatsSpec Build-Depends: base >= 4.5 && < 5 , bytestring @@ -117,55 +118,16 @@ GHC-Options: -Wall -threaded -with-rtsopts=-N --- 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: 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 + , repa-algorithms , hip default-language: Haskell2010 diff --git a/src/Graphics/Image.hs b/src/Graphics/Image.hs --- a/src/Graphics/Image.hs +++ b/src/Graphics/Image.hs @@ -237,7 +237,7 @@ -- | Check weather two images are equal within a tolerance. Useful for comparing -- images with `Float` or `Double` precision. eqTol - :: (Array arr Binary Bit, Array arr cs e, Ord e, Num e) => + :: (Array arr Binary Bit, Array arr cs e, Ord e) => e -> Image arr cs e -> Image arr cs e -> Bool eqTol !tol !img1 = IP.and . toImageBinaryUsing2 (eqTolPx tol) img1 {-# INLINE eqTol #-} diff --git a/src/Graphics/Image/ColorSpace.hs b/src/Graphics/Image/ColorSpace.hs --- a/src/Graphics/Image/ColorSpace.hs +++ b/src/Graphics/Image/ColorSpace.hs @@ -90,7 +90,7 @@ -- | Check weather two Pixels are equal within a tolerance. Useful for comparing -- pixels with `Float` or `Double` precision. -eqTolPx :: (ColorSpace cs e, Num e, Ord e) => +eqTolPx :: (ColorSpace cs e, Ord e) => e -> Pixel cs e -> Pixel cs e -> Bool eqTolPx !tol = foldlPx2 comp True where comp !acc !e1 !e2 = acc && max e1 e2 - min e1 e2 <= tol diff --git a/src/Graphics/Image/ColorSpace/Binary.hs b/src/Graphics/Image/ColorSpace/Binary.hs --- a/src/Graphics/Image/ColorSpace/Binary.hs +++ b/src/Graphics/Image/ColorSpace/Binary.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -19,13 +20,18 @@ ) where import Prelude hiding (map) +import Control.Monad import Data.Bits import Data.Word (Word8) import Graphics.Image.Interface import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed as U + -- | This is a Binary colorspace, pixel's of which can be created using -- these __/constructors/__: -- @@ -55,7 +61,7 @@ -- values of @0@ or @1@. newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable) -data instance Pixel Binary Bit = PixelBinary {-# UNPACK #-} !Bit deriving (Ord, Eq) +newtype instance Pixel Binary Bit = PixelBinary Bit deriving (Ord, Eq) instance Show (Pixel Binary Bit) where show (PixelBinary (Bit 0)) = "" @@ -247,21 +253,6 @@ {-# INLINE fromInteger #-} -instance Num (Pixel Binary Bit) where - (+) = liftPx2 (+) - {-# INLINE (+) #-} - (-) = liftPx2 (-) - {-# INLINE (-) #-} - (*) = liftPx2 (*) - {-# INLINE (*) #-} - abs = liftPx abs - {-# INLINE abs #-} - signum = liftPx signum - {-# INLINE signum #-} - fromInteger = promote . fromInteger - {-# INLINE fromInteger #-} - - instance Storable Bit where sizeOf _ = sizeOf (undefined :: Word8) @@ -286,3 +277,59 @@ poke p (PixelBinary b) = do q <- return $ castPtr p poke q b + + + +-- | Unboxing of a `Bit`. +instance U.Unbox Bit + +newtype instance U.MVector s Bit = MV_Bit (U.MVector s Word8) + +instance M.MVector U.MVector Bit where + basicLength (MV_Bit mvec) = M.basicLength mvec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (MV_Bit mvec) = MV_Bit (M.basicUnsafeSlice idx len mvec) + {-# INLINE basicUnsafeSlice #-} + basicOverlaps (MV_Bit mvec) (MV_Bit mvec') = M.basicOverlaps mvec mvec' + {-# INLINE basicOverlaps #-} + basicUnsafeNew len = MV_Bit `liftM` M.basicUnsafeNew len + {-# INLINE basicUnsafeNew #-} + basicUnsafeReplicate len (Bit w) = MV_Bit `liftM` M.basicUnsafeReplicate len w + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeRead (MV_Bit mvec) idx = Bit `liftM` M.basicUnsafeRead mvec idx + {-# INLINE basicUnsafeRead #-} + basicUnsafeWrite (MV_Bit mvec) idx (Bit w) = M.basicUnsafeWrite mvec idx w + {-# INLINE basicUnsafeWrite #-} + basicClear (MV_Bit mvec) = M.basicClear mvec + {-# INLINE basicClear #-} + basicSet (MV_Bit mvec) (Bit w) = M.basicSet mvec w + {-# INLINE basicSet #-} + basicUnsafeCopy (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeCopy mvec mvec' + {-# INLINE basicUnsafeCopy #-} + basicUnsafeMove (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeMove mvec mvec' + {-# INLINE basicUnsafeMove #-} + basicUnsafeGrow (MV_Bit mvec) len = MV_Bit `liftM` M.basicUnsafeGrow mvec len + {-# INLINE basicUnsafeGrow #-} +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_Bit mvec) = M.basicInitialize mvec + {-# INLINE basicInitialize #-} +#endif + + +newtype instance U.Vector Bit = V_Bit (U.Vector Word8) + +instance V.Vector U.Vector Bit where + basicUnsafeFreeze (MV_Bit mvec) = V_Bit `liftM` V.basicUnsafeFreeze mvec + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeThaw (V_Bit vec) = MV_Bit `liftM` V.basicUnsafeThaw vec + {-# INLINE basicUnsafeThaw #-} + basicLength (V_Bit vec) = V.basicLength vec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (V_Bit vec) = V_Bit (V.basicUnsafeSlice idx len vec) + {-# INLINE basicUnsafeSlice #-} + basicUnsafeIndexM (V_Bit vec) idx = Bit `liftM` V.basicUnsafeIndexM vec idx + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeCopy (MV_Bit mvec) (V_Bit vec) = V.basicUnsafeCopy mvec vec + {-# INLINE basicUnsafeCopy #-} + elemseq (V_Bit vec) (Bit w) = V.elemseq vec w + {-# INLINE elemseq #-} diff --git a/src/Graphics/Image/ColorSpace/CMYK.hs b/src/Graphics/Image/ColorSpace/CMYK.hs --- a/src/Graphics/Image/ColorSpace/CMYK.hs +++ b/src/Graphics/Image/ColorSpace/CMYK.hs @@ -95,59 +95,7 @@ {-# 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) @@ -281,59 +229,6 @@ 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 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 diff --git a/src/Graphics/Image/ColorSpace/HSI.hs b/src/Graphics/Image/ColorSpace/HSI.hs --- a/src/Graphics/Image/ColorSpace/HSI.hs +++ b/src/Graphics/Image/ColorSpace/HSI.hs @@ -90,59 +90,7 @@ 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) @@ -268,59 +216,6 @@ 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 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 Fractional e => Fractional (Pixel HSIA e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -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 diff --git a/src/Graphics/Image/ColorSpace/RGB.hs b/src/Graphics/Image/ColorSpace/RGB.hs --- a/src/Graphics/Image/ColorSpace/RGB.hs +++ b/src/Graphics/Image/ColorSpace/RGB.hs @@ -107,71 +107,20 @@ {-# 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 + peek !p = do + let !q = 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 !p (PixelRGB r g b) = do + let !q = castPtr p poke q r pokeElemOff q 1 g pokeElemOff q 2 b @@ -272,59 +221,6 @@ 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 diff --git a/src/Graphics/Image/ColorSpace/X.hs b/src/Graphics/Image/ColorSpace/X.hs --- a/src/Graphics/Image/ColorSpace/X.hs +++ b/src/Graphics/Image/ColorSpace/X.hs @@ -34,7 +34,7 @@ data X = X deriving (Eq, Enum, Bounded, Show, Typeable) -data instance Pixel X e = PixelX !e deriving (Ord, Eq) +newtype instance Pixel X e = PixelX e deriving (Ord, Eq) instance Show e => Show (Pixel X e) where @@ -90,64 +90,6 @@ (>>=) (PixelX g) f = f g {-# INLINE (>>=) #-} - - -instance Num e => Num (Pixel X e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - - (-) = liftA2 (-) - {-# INLINE (-) #-} - - (*) = liftA2 (*) - {-# INLINE (*) #-} - - abs = liftA abs - {-# INLINE abs #-} - - signum = liftA signum - {-# INLINE signum #-} - - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - - -instance Fractional e => Fractional (Pixel X e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance Floating e => Floating (Pixel X e) where - pi = pure pi - {-# INLINE pi #-} - exp = liftA exp - {-# INLINE exp #-} - log = liftA log - {-# INLINE log #-} - sin = liftA sin - {-# INLINE sin #-} - cos = liftA cos - {-# INLINE cos #-} - asin = liftA asin - {-# INLINE asin #-} - atan = liftA atan - {-# INLINE atan #-} - acos = liftA acos - {-# INLINE acos #-} - sinh = liftA sinh - {-# INLINE sinh #-} - cosh = liftA cosh - {-# INLINE cosh #-} - asinh = liftA asinh - {-# INLINE asinh #-} - atanh = liftA atanh - {-# INLINE atanh #-} - acosh = liftA acosh - {-# INLINE acosh #-} instance Storable e => Storable (Pixel X e) where diff --git a/src/Graphics/Image/ColorSpace/Y.hs b/src/Graphics/Image/ColorSpace/Y.hs --- a/src/Graphics/Image/ColorSpace/Y.hs +++ b/src/Graphics/Image/ColorSpace/Y.hs @@ -35,7 +35,7 @@ data Y = LumaY deriving (Eq, Enum, Show, Bounded, Typeable) -data instance Pixel Y e = PixelY !e deriving (Ord, Eq) +newtype instance Pixel Y e = PixelY e deriving (Ord, Eq) -- | Conversion to Luma color space. class ColorSpace cs Double => ToY cs where @@ -103,59 +103,7 @@ {-# INLINE (>>=) #-} -instance Num e => Num (Pixel Y e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - abs = liftA abs - {-# INLINE abs #-} - signum = liftA signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional e => Fractional (Pixel Y e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance Floating e => Floating (Pixel Y e) where - pi = pure pi - {-# INLINE pi #-} - exp = liftA exp - {-# INLINE exp #-} - log = liftA log - {-# INLINE log #-} - sin = liftA sin - {-# INLINE sin #-} - cos = liftA cos - {-# INLINE cos #-} - asin = liftA asin - {-# INLINE asin #-} - atan = liftA atan - {-# INLINE atan #-} - acos = liftA acos - {-# INLINE acos #-} - sinh = liftA sinh - {-# INLINE sinh #-} - cosh = liftA cosh - {-# INLINE cosh #-} - asinh = liftA asinh - {-# INLINE asinh #-} - atanh = liftA atanh - {-# INLINE atanh #-} - acosh = liftA acosh - {-# INLINE acosh #-} - - instance Storable e => Storable (Pixel Y e) where sizeOf _ = sizeOf (undefined :: e) @@ -250,63 +198,6 @@ instance Foldable (Pixel YA) where foldr f !z (PixelYA y a) = f y (f a z) {-# INLINE foldr #-} - - -instance Num e => Num (Pixel YA e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - - (-) = liftA2 (-) - {-# INLINE (-) #-} - - (*) = liftA2 (*) - {-# INLINE (*) #-} - - abs = liftA abs - {-# INLINE abs #-} - - signum = liftA signum - {-# INLINE signum #-} - - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional e => Fractional (Pixel YA e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = liftA recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance Floating e => Floating (Pixel YA e) where - pi = pure pi - {-# INLINE pi #-} - exp = liftA exp - {-# INLINE exp #-} - log = liftA log - {-# INLINE log #-} - sin = liftA sin - {-# INLINE sin #-} - cos = liftA cos - {-# INLINE cos #-} - asin = liftA asin - {-# INLINE asin #-} - atan = liftA atan - {-# INLINE atan #-} - acos = liftA acos - {-# INLINE acos #-} - sinh = liftA sinh - {-# INLINE sinh #-} - cosh = liftA cosh - {-# INLINE cosh #-} - asinh = liftA asinh - {-# INLINE asinh #-} - atanh = liftA atanh - {-# INLINE atanh #-} - acosh = liftA acosh - {-# INLINE acosh #-} instance Storable e => Storable (Pixel YA e) where diff --git a/src/Graphics/Image/ColorSpace/YCbCr.hs b/src/Graphics/Image/ColorSpace/YCbCr.hs --- a/src/Graphics/Image/ColorSpace/YCbCr.hs +++ b/src/Graphics/Image/ColorSpace/YCbCr.hs @@ -93,60 +93,6 @@ {-# 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) @@ -273,59 +219,6 @@ 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 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 diff --git a/src/Graphics/Image/IO.hs b/src/Graphics/Image/IO.hs --- a/src/Graphics/Image/IO.hs +++ b/src/Graphics/Image/IO.hs @@ -88,7 +88,7 @@ imgstr <- B.readFile path let maybeFormat = guessFormat path :: Maybe InputFormat formats = enumFrom . toEnum $ 0 - orderedFormats = maybe formats (\f -> f:filter (/=f) formats) maybeFormat + orderedFormats = maybe formats (\f -> f:P.filter (/=f) formats) maybeFormat reader (Left err) format = return $ either (Left . ((err++"\n")++)) Right (decode format imgstr) reader img _ = return img @@ -132,7 +132,7 @@ -- highest precision 'GIF' supports and it currently cannot be saved with -- transparency. writeImage :: (Array VS cs e, Array arr cs e, - Exchangable arr VS, Writable (Image VS cs e) OutputFormat) => + Writable (Image VS cs e) OutputFormat) => FilePath -- ^ Location where an image should be written. -> Image arr cs e -- ^ An image to write. -> IO () @@ -197,7 +197,7 @@ -} displayImage :: (Array VS cs e, Array arr cs e, - Exchangable arr VS, Writable (Image VS cs e) TIF) => + Writable (Image VS cs e) TIF) => Image arr cs e -- ^ Image to be displayed -> IO () displayImage = displayImageUsing defaultViewer False . exchange VS diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels.hs b/src/Graphics/Image/IO/Formats/JuicyPixels.hs --- a/src/Graphics/Image/IO/Formats/JuicyPixels.hs +++ b/src/Graphics/Image/IO/Formats/JuicyPixels.hs @@ -647,7 +647,7 @@ 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 +jpImageToImageUnsafe (JP.Image n m v) = fromVector (m, n) $ V.unsafeCast v @@ -1068,7 +1068,7 @@ 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 +imageToJPImage _ f !img = JP.Image n m $ V.unsafeCast $ toVector $ I.map f img where !(m, n) = dims img {-# INLINE imageToJPImage #-} diff --git a/src/Graphics/Image/IO/Formats/Netpbm.hs b/src/Graphics/Image/IO/Formats/Netpbm.hs --- a/src/Graphics/Image/IO/Formats/Netpbm.hs +++ b/src/Graphics/Image/IO/Formats/Netpbm.hs @@ -247,7 +247,7 @@ makeImageUnsafe :: (Storable a, Array VS cs e) => (Int, Int) -> V.Vector a -> Image VS cs e -makeImageUnsafe sz = fromStorableVector sz . V.unsafeCast +makeImageUnsafe sz = fromVector sz . V.unsafeCast pnmDataPBMToImage :: Int -> Int -> PNM.PpmPixelData -> Either String (Image VS Binary Bit) diff --git a/src/Graphics/Image/Interface.hs b/src/Graphics/Image/Interface.hs --- a/src/Graphics/Image/Interface.hs +++ b/src/Graphics/Image/Interface.hs @@ -23,7 +23,7 @@ module Graphics.Image.Interface ( Pixel, ColorSpace(..), AlphaSpace(..), Elevator(..), BaseArray(..), Array(..), MArray(..), - Exchangable(..), exchangeFrom, exchangeThrough, + exchange, defaultIndex, borderIndex, maybeIndex, Border(..), handleBorderIndex, fromIx, toIx, checkDims #if !MIN_VERSION_base(4,8,0) @@ -36,21 +36,23 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif +import Control.Monad.Primitive (PrimMonad (..)) import Data.Maybe (fromMaybe) import Data.Foldable import GHC.Exts (Constraint) import Data.Typeable (Typeable, showsTypeRep, typeOf) import Control.DeepSeq (NFData(rnf), deepseq) import Data.Word - -import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Unboxed as VU -- | A Pixel family with a color space and a precision of elements. data family Pixel cs e :: * -class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs, Elevator e, Typeable e) +class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs, Elevator e, Typeable e, + Eq (Pixel cs e), VU.Unbox (Components cs e)) => ColorSpace cs e where type Components cs e @@ -133,7 +135,7 @@ -- >>> toWord8 rgb -- -- -class Elevator e where +class (Eq e, Num e, VU.Unbox e) => Elevator e where -- | Values are scaled to @[0, 255]@ range. toWord8 :: e -> Word8 @@ -158,13 +160,11 @@ -- | Base array like representation for an image. -class (Show arr, ColorSpace cs e, Num (Pixel cs e), - SuperClass arr cs e) => +class (Show arr, ColorSpace cs e, SuperClass arr cs e) => BaseArray arr cs e where -- | Required array specific constraints for an array element. type SuperClass arr cs e :: Constraint - type SuperClass arr cs e = () -- | Underlying image representation. data Image arr cs e @@ -179,11 +179,13 @@ -- dims :: Image arr cs e -> (Int, Int) -class (MArray (Manifest arr) cs e, BaseArray arr cs e) => Array arr cs e where +class (VG.Vector (Vector arr) (Pixel cs e), + MArray (Manifest arr) cs e, BaseArray arr cs e) => Array arr cs e where type Manifest arr :: * - + type Vector arr :: * -> * + -- | Create an Image by supplying it's dimensions and a pixel generating -- function. makeImage :: (Int, Int) -- ^ (@m@ rows, @n@ columns) - dimensions of a new image. @@ -305,16 +307,39 @@ -- the 'Eq' typeclass. eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool + -- | `Array` class does not enforce an image to be represented as concrete + -- array of pixels in memory, but if at any time it is desired for the image + -- to be brought to a computed state, this function can be used. compute :: Image arr cs e -> Image arr cs e + -- | Each array has a sibling `Manifest` array representation, which toManifest :: Image arr cs e -> Image (Manifest arr) cs e - + -- | Convert an image to a flattened 'Vector'. For all current representations + -- it is a __O(1)__ opeartion. + -- + -- >>> toVector $ makeImage (3, 2) (\(i, j) -> PixelY $ fromIntegral (i+j)) + -- fromList [,,,,,] + -- + toVector :: Image arr cs e -> Vector arr (Pixel cs e) + + -- | Construct a two dimensional image with @m@ rows and @n@ columns from a + -- flat 'Vector' of length @k@. For all current representations it is a + -- __O(1)__ opeartion. Make sure that @m * n = k@. + -- + -- >>> fromVector (200, 300) $ generate 60000 (\i -> PixelY $ fromIntegral i / 60000) + -- + -- + -- <> + -- + fromVector :: (Int, Int) -> Vector arr (Pixel cs e) -> Image arr cs e + + -- | Array representation that is actually has real data stored in memory, hence -- allowing for image indexing, forcing pixels into computed state etc. -class BaseArray arr cs e => MArray arr cs e where +class (BaseArray arr cs e) => MArray arr cs e where data MImage s arr cs e - + unsafeIndex :: Image arr cs e -> (Int, Int) -> Pixel cs e -- | Get a pixel at @i@-th and @j@-th location. @@ -386,43 +411,19 @@ MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m () --- | Allows for changing an underlying image representation. -class Exchangable arr' arr where - - -- | Exchange the underlying array representation of an image. - exchange :: (Array arr' cs e, Array arr cs e) => - arr -- ^ New representation of an image. - -> Image arr' cs e -- ^ Source image. - -> Image arr cs e - --- | Changing to the same array representation as before is disabled and `exchange` --- will behave simply as an identitity function. -instance Exchangable arr arr where - - exchange _ !img = img - {-# INLINE exchange #-} - - --- | `exchange` function that allows restricting representation type of the --- source image. -exchangeFrom :: (Exchangable arr' arr, Array arr' cs e, Array arr cs e) => - arr' - -> arr -- ^ New representation of an image. - -> Image arr' cs e -- ^ Source image. - -> Image arr cs e -exchangeFrom _ to !img = exchange to img -{-# INLINE exchangeFrom #-} +-- | Exchange the underlying array representation of an image. +exchange :: (Array arr' cs e, Array arr cs e) => + arr -- ^ New representation of an image. + -> Image arr' cs e -- ^ Source image. + -> Image arr cs e +exchange _ img@(dims -> (1, 1)) = scalar $ index00 img +exchange _ img = fromVector (dims img) $ VG.convert $ toVector img +{-# INLINE[0] exchange #-} --- | `exchange` an image representation through an intermediate one. -exchangeThrough :: (Exchangable arr2 arr1, Exchangable arr1 arr, - Array arr2 cs e, Array arr1 cs e, Array arr cs e) => - arr1 - -> arr -- ^ New representation of an image. - -> Image arr2 cs e -- ^ Source image. - -> Image arr cs e -exchangeThrough through to = exchange to . exchange through -{-# INLINE exchangeThrough #-} +{-# RULES +"exchange/id" forall arr. exchange arr = id + #-} -- | Approach to be used near the borders during various transformations. @@ -467,31 +468,7 @@ -- deriving Show --- handleBorderIndex' :: Border px -- ^ Border handling strategy. --- -> (Int, Int) -- ^ Image dimensions --- -> ((Int, Int) -> px) -- ^ Image's indexing function. --- -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup. --- -> px --- handleBorderIndex' border !(m, n) !getPx !(i, j) = --- if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else getPxB border where --- getPxB (Fill px) = px --- getPxB Wrap = getPx (i `mod` m, j `mod` n) --- getPxB Edge = getPx (if i < 0 then 0 else if i >= m then m - 1 else i, --- if j < 0 then 0 else if j >= n then n - 1 else j) --- getPxB Reflect = getPx (if i < 0 then (abs i - 1) `mod` m else --- if i >= m then (m - (i - m + 1)) `mod` m else i, --- if j < 0 then (abs j - 1) `mod` n else --- if j >= n then (n - (j - n + 1)) `mod` n else j) --- getPxB Continue = getPx (if i < 0 then abs i `mod` m else --- if i >= m then (m - (i - m + 2)) `mod` m else i, --- if j < 0 then abs j `mod` n else --- if j >= n then (n - (j - n + 2)) `mod` n else j) --- {-# INLINE getPxB #-} --- {-# INLINE handleBorderIndex' #-} - - - -- | Border handling function. If @(i, j)@ location is within bounds, then supplied -- lookup function will be used, otherwise it will be handled according to a -- supplied border strategy. @@ -500,7 +477,7 @@ -> ((Int, Int) -> px) -- ^ Image's indexing function. -> (Int, Int) -- ^ @(i, j)@ location of a pixel lookup. -> px -handleBorderIndex border !(m, n) !getPx !(i, j) = +handleBorderIndex border !(m, n) getPx !(i, j) = if north || east || south || west then case border of Fill px -> px @@ -515,61 +492,15 @@ if south then (-i - 2) `mod` m else i, if west then abs j `mod` n else if east then (-j - 2) `mod` n else j) - -- Reflect -> getPx (if north then (abs i - 1) `mod` m else - -- if south then (m - (i - m + 1)) `mod` m else i, - -- if west then (abs j - 1) `mod` n else - -- if east then (n - (j - n + 1)) `mod` n else j) - -- Continue -> getPx (if north then abs i `mod` m else - -- if south then (m - (i - m + 2)) `mod` m else i, - -- if west then abs j `mod` n else - -- if east then (n - (j - n + 2)) `mod` n else j) else getPx (i, j) where - north = i < 0 - {-# INLINE north #-} - south = i >= m - {-# INLINE south #-} - west = j < 0 - {-# INLINE west #-} - east = j >= n - {-# INLINE east #-} + !north = i < 0 + !south = i >= m + !west = j < 0 + !east = j >= n {-# INLINE handleBorderIndex #-} - --- handleBorderIndex' border !(m, n) getPx !(i, j) = --- case (i < 0, i >= m, j < 0, j >= n) of --- (False, False, False, False) -> getPx (i, j) --- (False, False, False, True) -> --- case border of --- Fill px -> px --- Wrap -> getPx (i, j `mod` n) --- Edge -> getPx (i, n-1) --- Reflect -> getPx (i, (n - (j - n + 1)) `mod` n) --- Continue -> getPx (i, (n - (j - n + 2)) `mod` n) --- (False, False, True, False) -> --- case border of --- Fill px -> px --- Wrap -> getPx (i, j `mod` n) --- Edge -> getPx (i, 0) --- Reflect -> getPx (i, (abs j - 1) `mod` n) --- Continue -> getPx (i, abs j `mod` n) --- (False, True, False, False) -> --- case border of --- Fill px -> px --- Wrap -> getPx (i, j `mod` n) --- Edge -> getPx (i, 0) --- Reflect -> getPx (i, (abs j - 1) `mod` n) --- Continue -> getPx (i, abs j `mod` n) - --((False, False, False, True), Edge) -> getPx (i, j `mod` n) - - -- case (i >= 0, j >= 0, i < m, j < n) of - -- (True, True, True, True) -> getPx (i, j) - -- (True, True, True, True) -> getPx (i, j) - -- then getPx (i, j) else getPxB border where - - - -- | Image indexing function that returns a default pixel if index is out of bounds. defaultIndex :: MArray arr cs e => Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e @@ -621,11 +552,64 @@ {-# INLINE checkDims #-} -instance (Applicative (Pixel cs), Bounded e) => Bounded (Pixel cs e) where - maxBound = pure maxBound +instance (ColorSpace cs e, Num e) => Num (Pixel cs e) where + (+) = liftPx2 (+) + {-# INLINE (+) #-} + (-) = liftPx2 (-) + {-# INLINE (-) #-} + (*) = liftPx2 (*) + {-# INLINE (*) #-} + abs = liftPx abs + {-# INLINE abs #-} + signum = liftPx signum + {-# INLINE signum #-} + fromInteger = promote . fromInteger + {-# INLINE fromInteger #-} + + +instance (ColorSpace cs e, Fractional e) => Fractional (Pixel cs e) where + (/) = liftPx2 (/) + {-# INLINE (/) #-} + recip = liftPx recip + {-# INLINE recip #-} + fromRational = promote . fromRational + {-# INLINE fromRational #-} + + +instance (ColorSpace cs e, Floating e) => Floating (Pixel cs e) where + pi = promote pi + {-# INLINE pi #-} + exp = liftPx exp + {-# INLINE exp #-} + log = liftPx log + {-# INLINE log #-} + sin = liftPx sin + {-# INLINE sin #-} + cos = liftPx cos + {-# INLINE cos #-} + asin = liftPx asin + {-# INLINE asin #-} + atan = liftPx atan + {-# INLINE atan #-} + acos = liftPx acos + {-# INLINE acos #-} + sinh = liftPx sinh + {-# INLINE sinh #-} + cosh = liftPx cosh + {-# INLINE cosh #-} + asinh = liftPx asinh + {-# INLINE asinh #-} + atanh = liftPx atanh + {-# INLINE atanh #-} + acosh = liftPx acosh + {-# INLINE acosh #-} + + +instance (ColorSpace cs e, Bounded e) => Bounded (Pixel cs e) where + maxBound = promote maxBound {-# INLINE maxBound #-} - minBound = pure minBound + minBound = promote minBound {-# INLINE minBound #-} diff --git a/src/Graphics/Image/Interface/Repa.hs b/src/Graphics/Image/Interface/Repa.hs --- a/src/Graphics/Image/Interface/Repa.hs +++ b/src/Graphics/Image/Interface/Repa.hs @@ -11,7 +11,7 @@ -- module Graphics.Image.Interface.Repa ( -- * Conversion - --fromRepaArrayS, fromRepaArrayP, + fromRepaArrayS, fromRepaArrayP, toRepaArray, -- * Representation RSU(..), RPU(..), RSS(..), RPS(..) @@ -19,108 +19,25 @@ import Data.Array.Repa.Index import qualified Data.Array.Repa as R +import qualified Data.Vector.Generic as VG import Graphics.Image.Interface import Graphics.Image.Interface.Repa.Generic import Graphics.Image.Interface.Repa.Storable import Graphics.Image.Interface.Repa.Unboxed -import Graphics.Image.Interface.Vector --- | Makes a copy of an image into a Storable Vector representation. -instance Exchangable VU RSS where - exchange = exchangeThrough VS - {-# INLINE exchange #-} - --- | Makes a copy of an image into a Storable Vector representation. -instance Exchangable VU RPS where - exchange = exchangeThrough VS - {-# INLINE exchange #-} - - - --- | Makes a copy of an image into a Storable Vector representation. -instance Exchangable VS RSU where - exchange = exchangeThrough VU - {-# INLINE exchange #-} - - --- | Makes a copy of an image into a Storable Vector representation. -instance Exchangable VS RPU where - exchange = exchangeThrough VU - {-# INLINE exchange #-} - - --- | Makes a copy of an image into a Storable Vector representation. -instance Exchangable RSU VS where - exchange _ = exchange VS . toManifest - {-# INLINE exchange #-} - - --- | Makes a copy of an image into a Storable Vector representation. -instance Exchangable RPU VS where - exchange _ = exchange VS . toManifest - {-# INLINE exchange #-} - - - --- | Makes a copy of an image into a Unboxed Vector representation. -instance Exchangable RSS VU where - exchange _ = exchange VU . toManifest - {-# INLINE exchange #-} - - --- | Makes a copy of an image into a Unboxed Vector representation. -instance Exchangable RPS VU where - exchange _ = exchange VU . toManifest - {-# INLINE exchange #-} - - --- | Makes a copy of an image into a Storable representation sequentially. -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 unboxed image from a 2D Repa delayed array. +fromRepaArrayS :: R.Source r (Pixel cs e) => R.Array r DIM2 (Pixel cs e) -> Image RSU cs e +fromRepaArrayS = SUImage . SDImage . R.delay --- -- | 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 unboxed image from a 2D Repa delayed array. +fromRepaArrayP :: R.Source r (Pixel cs e) => R.Array r DIM2 (Pixel cs e) -> Image RPU cs e +fromRepaArrayP = PUImage . PDImage . R.delay --- -- | 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 +-- | Convert into Repa Unboxed array from an image. +toRepaArray :: Array arr cs e => Image arr cs e -> R.Array R.U DIM2 (Pixel cs e) +toRepaArray img = R.fromUnboxed (ix2sh (dims img)) $ VG.convert $ toVector img diff --git a/src/Graphics/Image/Interface/Repa/Generic.hs b/src/Graphics/Image/Interface/Repa/Generic.hs --- a/src/Graphics/Image/Interface/Repa/Generic.hs +++ b/src/Graphics/Image/Interface/Repa/Generic.hs @@ -26,11 +26,11 @@ import Data.Array.Repa.Index import qualified Data.Array.Repa as R import qualified Data.Array.Repa.Eval as R +import qualified Data.Vector.Generic as VG 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 @@ -56,13 +56,12 @@ 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)) + (Show r, ColorSpace cs e, R.Elt (Pixel cs e), R.Elt e, + R.Target (Repr r) (Pixel cs e), R.Source (Repr r) (Pixel cs e), + BaseArray r cs e) data Image (RS r) cs e = SScalar !(Pixel cs e) - | STImage !(R.Array (Repr (RS r)) R.DIM2 (Pixel cs e)) + | STImage !(R.Array (Repr r) R.DIM2 (Pixel cs e)) | SDImage !(R.Array R.D R.DIM2 (Pixel cs e)) dims (SScalar _ ) = (1, 1) @@ -71,10 +70,13 @@ {-# INLINE dims #-} -instance (BaseArray (RS r) cs e) => Array (RS r) cs e where +instance (VG.Vector (Vector r) (Pixel cs e), + MArray (Manifest r) cs e, BaseArray (RS r) cs e) => Array (RS r) cs e where - type Manifest (RS r) = Manifest (IVG.V r) + type Manifest (RS r) = Manifest r + type Vector (RS r) = Vector r + makeImage !(checkDims "RS.makeImage" -> (m, n)) f = SDImage $ R.fromFunction (Z :. m :. n) (f . sh2ix) {-# INLINE makeImage #-} @@ -163,10 +165,17 @@ {-# INLINE (|*|) #-} toManifest _ = error $ "RS.toManifest: Cannot convert generic Repa " ++ - "representation to a generic Vector." + "representation to a generic Vector representation." {-# INLINE toManifest #-} + toVector _ = error $ "RS.toVector: Cannot convert generic Repa " ++ + "representation to a generic Vector." + {-# INLINE toVector #-} + fromVector _ = error $ "RS.fromVector: Cannot convert to generic Repa " ++ + "from a generic Vector." + {-# INLINE fromVector #-} + --------------------- -- Parallel Arrays -- --------------------- @@ -175,13 +184,13 @@ 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)) + Show r, ColorSpace cs e, + R.Target (Repr r) (Pixel cs e), R.Source (Repr r) (Pixel cs e), + BaseArray r 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)) + | PTImage !(R.Array (Repr r) R.DIM2 (Pixel cs e)) | PDImage !(R.Array R.D R.DIM2 (Pixel cs e)) dims (PScalar _ ) = (1, 1) @@ -190,10 +199,13 @@ {-# INLINE dims #-} -instance (BaseArray (RP r) cs e) => Array (RP r) cs e where +instance (VG.Vector (Vector r) (Pixel cs e), + MArray (Manifest r) cs e, BaseArray (RP r) cs e) => Array (RP r) cs e where - type Manifest (RP r) = Manifest (IVG.V r) - + type Manifest (RP r) = Manifest r + + type Vector (RP r) = Vector r + makeImage !(checkDims "RP.makeImage" -> (m, n)) f = PDImage $ R.fromFunction (Z :. m :. n) (f . sh2ix) {-# INLINE makeImage #-} @@ -294,8 +306,16 @@ "representation to a generic Vector." {-# INLINE toManifest #-} + toVector _ = error $ "RP.toVector: Cannot convert generic Repa " ++ + "representation to a generic Vector." + {-# INLINE toVector #-} + fromVector _ = error $ "RP.fromVector: Cannot convert to generic Repa " ++ + "from a generic Vector." + {-# INLINE fromVector #-} + + ---------------------- -- Helper functions -- ---------------------- @@ -309,12 +329,12 @@ {-# INLINE ix2sh #-} -toRS :: Repr (RP r) ~ Repr (RS r) => Image (RP r) cs e -> Image (RS r) cs e +toRS :: 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 :: 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 @@ -356,6 +376,8 @@ {-# INLINE getNewE #-} {-# INLINE traverseR #-} + + traverse2R :: (R.Source r2 c1, R.Source r1 c) => R.Array r1 DIM2 c @@ -398,7 +420,7 @@ multR - :: (ColorSpace cs e, IVU.Unbox (Components cs e), Num (Pixel cs e), R.Elt (Pixel cs e), + :: (ColorSpace 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 = @@ -466,7 +488,7 @@ foldIxS - :: (R.Elt b, R.Source r2 b, IVU.Unbox b) => + :: (R.Elt b, IVU.Unbox b, R.Source r2 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 diff --git a/src/Graphics/Image/Interface/Repa/Storable.hs b/src/Graphics/Image/Interface/Repa/Storable.hs --- a/src/Graphics/Image/Interface/Repa/Storable.hs +++ b/src/Graphics/Image/Interface/Repa/Storable.hs @@ -30,10 +30,10 @@ 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 @@ -47,27 +47,26 @@ show RPS = "RepaParallelStorable" -type instance Repr (RS IVS.S) = R.F - -type instance Repr (RP IVS.S) = R.F +type instance Repr IVS.VS = R.F instance SuperClass RSS cs e => BaseArray RSS cs e where type SuperClass RSS cs e = - (ColorSpace cs e, Num (Pixel cs e), + (ColorSpace 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) + newtype Image RSS cs e = SSImage (Image (RS IVS.VS) cs e) dims (SSImage img) = dims img {-# INLINE dims #-} -instance (BaseArray RSS cs e) => Array RSS cs e where +instance BaseArray RSS cs e => Array RSS cs e where type Manifest RSS = IVS.VS + + type Vector RSS = Vector IVS.VS makeImage !sz f = SSImage (makeImage sz f) {-# INLINE makeImage #-} @@ -128,24 +127,30 @@ toManifest !img = toManifest (compute img) {-# INLINE toManifest #-} + toVector = I.toVector . toManifest + {-# INLINE toVector #-} + fromVector !sz = SSImage . STImage . fromVectorStorable sz + {-# INLINE fromVector #-} + instance SuperClass RPS cs e => BaseArray RPS cs e where type SuperClass RPS cs e = - (ColorSpace cs e, Num (Pixel cs e), + (ColorSpace 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) + newtype Image RPS cs e = PSImage (Image (RP IVS.VS) cs e) dims (PSImage img) = dims img {-# INLINE dims #-} -instance (BaseArray RPS cs e) => Array RPS cs e where +instance BaseArray RPS cs e => Array RPS cs e where type Manifest RPS = IVS.VS + + type Vector RPS = Vector IVS.VS makeImage !sz f = PSImage (makeImage sz f) {-# INLINE makeImage #-} @@ -201,52 +206,16 @@ (|*|) (PSImage img1) (PSImage img2) = PSImage (img1 |*| img2) {-# INLINE (|*|) #-} - toManifest (PSImage (PScalar px)) = scalar px + toManifest (PSImage (PScalar px)) = scalar 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)) = scalar (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)) = scalar (index00 img) - exchange _ !img = - PSImage . PTImage . toRepaArrayStorable $ img - {-# INLINE exchange #-} - - --- | Changes to Vector representation. -instance Exchangable RSS IVS.VS where - exchange _ = toManifest - {-# INLINE exchange #-} - + toVector = I.toVector . toManifest + {-# INLINE toVector #-} --- | Changes to Vector representation. -instance Exchangable RPS IVS.VS where - exchange _ = toManifest - {-# INLINE exchange #-} + fromVector !sz = PSImage . PTImage . fromVectorStorable sz + {-# INLINE fromVector #-} fromRepaArrayStorable @@ -254,22 +223,20 @@ 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 + fromVector (sh2ix (R.extent arr)) $ + VS.unsafeFromForeignPtr0 (R.toForeignPtr arr) (m * n) where - !sz = sizeOf (undefined :: Pixel cs e) * m * n (Z :. m :. n) = R.extent arr -toRepaArrayStorable +fromVectorStorable :: 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: " ++ + Storable (Pixel cs e) + => (Int, Int) -> VS.Vector (Pixel cs e) -> R.Array R.F DIM2 (Pixel cs e) +fromVectorStorable !(m, n) !v + | sz == sz' = R.fromForeignPtr (ix2sh (m, n)) fp + | otherwise = error $ "fromVectorStorable: (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 + !(fp, sz) = VS.unsafeToForeignPtr0 v + !sz' = m * n diff --git a/src/Graphics/Image/Interface/Repa/Unboxed.hs b/src/Graphics/Image/Interface/Repa/Unboxed.hs --- a/src/Graphics/Image/Interface/Repa/Unboxed.hs +++ b/src/Graphics/Image/Interface/Repa/Unboxed.hs @@ -41,18 +41,15 @@ show RPU = "RepaParallelUnboxed" -type instance Repr (RS IVU.U) = R.U - -type instance Repr (RP IVU.U) = R.U +type instance Repr IVU.VU = 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), + (ColorSpace cs e, R.Elt e, R.Elt (Pixel cs e)) - data Image RSU cs e = SUImage !(Image (RS IVU.U) cs e) + newtype Image RSU cs e = SUImage (Image (RS IVU.VU) cs e) dims (SUImage img) = dims img {-# INLINE dims #-} @@ -61,6 +58,8 @@ instance (BaseArray RSU cs e) => Array RSU cs e where type Manifest RSU = IVU.VU + + type Vector RSU = Vector IVU.VU makeImage !sz f = SUImage (makeImage sz f) {-# INLINE makeImage #-} @@ -118,28 +117,33 @@ toManifest (SUImage (SScalar px)) = scalar px toManifest (SUImage (STImage arr)) = - IVU.fromUnboxedVector (sh2ix (R.extent arr)) (R.toUnboxed arr) + fromVector (sh2ix (R.extent arr)) (R.toUnboxed arr) toManifest !img = toManifest (compute img) {-# INLINE toManifest #-} + toVector = I.toVector . toManifest + {-# INLINE toVector #-} + fromVector sz = SUImage . STImage . R.fromUnboxed (ix2sh sz) + {-# INLINE fromVector #-} + 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)) + (ColorSpace cs e, R.Elt e, R.Elt (Pixel cs e)) - data Image RPU cs e = PUImage !(Image (RP IVU.U) cs e) + newtype Image RPU cs e = PUImage (Image (RP IVU.VU) cs e) dims (PUImage img) = dims img {-# INLINE dims #-} -instance (BaseArray RPU cs e) => Array RPU cs e where +instance BaseArray RPU cs e => Array RPU cs e where type Manifest RPU = IVU.VU + type Vector RPU = Vector IVU.VU + makeImage !sz f = PUImage (makeImage sz f) {-# INLINE makeImage #-} @@ -196,48 +200,12 @@ toManifest (PUImage (PScalar px)) = scalar px toManifest (PUImage (PTImage arr)) = - IVU.fromUnboxedVector (sh2ix (R.extent arr)) (R.toUnboxed arr) + fromVector (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)) = scalar (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)) = scalar (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 #-} - + toVector = I.toVector . toManifest + {-# INLINE toVector #-} --- | Changes to Vector representation. -instance Exchangable RPU IVU.VU where - exchange _ = toManifest - {-# INLINE exchange #-} + fromVector sz = PUImage . PTImage . R.fromUnboxed (ix2sh sz) + {-# INLINE fromVector #-} diff --git a/src/Graphics/Image/Interface/Vector.hs b/src/Graphics/Image/Interface/Vector.hs --- a/src/Graphics/Image/Interface/Vector.hs +++ b/src/Graphics/Image/Interface/Vector.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Graphics.Image.Interface.Vector @@ -11,25 +13,38 @@ module Graphics.Image.Interface.Vector ( -- * Representation VU(..), VS(..), - -- * Conversion - fromUnboxedVector, toUnboxedVector, - fromStorableVector, toStorableVector, + -- * Filtering + filter, ifilter, -- * Linear index conversion toIx, fromIx ) where -import Data.Vector as V (convert) -import Graphics.Image.Interface -import Graphics.Image.Interface.Vector.Generic +import Prelude hiding (filter) +import qualified Data.Vector.Unboxed as U +import Graphics.Image.Interface as I import Graphics.Image.Interface.Vector.Unboxed import Graphics.Image.Interface.Vector.Storable -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)) +-- | Filter out Pixels from an image that do not satisfy the predicate and +-- convert a result into a flat unboxed vector with indexed Pixels. +filter :: Array arr cs e => + (Pixel cs e -> Bool) -- ^ The predicate + -> Image arr cs e -- ^ Source image + -> U.Vector ((Int, Int), Pixel cs e) +filter f !img = U.filter (f . snd) $ U.imap addIx $ U.convert $ toVector img where + (_, n) = dims img + addIx !k !px = (toIx n k, px) -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)) +-- | Filter out Pixels from an image that do not satisfy the index aware +-- predicate and convert a result into a flat unboxed vector with indexed +-- Pixels. +ifilter :: Array arr cs e => + ((Int, Int) -> Pixel cs e -> Bool) -- ^ The predicate + -> Image arr cs e -- ^ Source image + -> U.Vector ((Int, Int), Pixel cs e) +ifilter f !img = U.filter (uncurry f) $ U.imap addIx $ U.convert $ toVector img where + (_, n) = dims img + addIx !k !px = (toIx n k, px) + diff --git a/src/Graphics/Image/Interface/Vector/Generic.hs b/src/Graphics/Image/Interface/Vector/Generic.hs --- a/src/Graphics/Image/Interface/Vector/Generic.hs +++ b/src/Graphics/Image/Interface/Vector/Generic.hs @@ -18,7 +18,7 @@ -- Portability : non-portable -- module Graphics.Image.Interface.Vector.Generic ( - V(..), Repr, Image(..), fromVector, toVector + G(..), Image(..), fromVector ) where import Prelude hiding (map, zipWith) @@ -36,49 +36,53 @@ import Graphics.Image.Interface as I -- | Generic 'Vector' representation. -data V r = V r +data G r = G r -type family Repr arr :: * -> * -instance Show r => Show (V r) where - show (V r) = "Vector " ++ show r +instance Show r => Show (G r) where + show (G r) = "Vector " ++ show r -instance SuperClass (V r) cs e => BaseArray (V r) cs e where - type SuperClass (V r) cs e = (Show r, ColorSpace cs e, Num (Pixel cs e), - VG.Vector (Repr (V r)) (Pixel cs e), VG.Vector (Repr (V r)) Int, - VG.Vector (Repr (V r)) Bool, NFData ((Repr (V r)) (Pixel cs e))) +instance SuperClass (G r) cs e => BaseArray (G r) cs e where + type SuperClass (G r) cs e = + (Show r, ColorSpace cs e, + VG.Vector (Vector r) Int, VG.Vector (Vector r) Bool, + VG.Vector (Vector r) (Pixel cs e), NFData ((Vector r) (Pixel cs e))) - data Image (V r) cs e = VScalar !(Pixel cs e) + data Image (G r) cs e = VScalar !(Pixel cs e) | VImage {-# UNPACK #-} !Int {-# UNPACK #-} !Int - !((Repr (V r)) (Pixel cs e)) + !((Vector (G r)) (Pixel cs e)) dims (VImage m n _) = (m, n) dims (VScalar _) = (1, 1) {-# INLINE dims #-} -instance (MArray (V r) cs e, BaseArray (V r) cs e) => Array (V r) cs e where +instance (VG.Vector (Vector r) (Pixel cs e), + MArray (G r) cs e, BaseArray (G r) cs e) => Array (G r) cs e where - type Manifest (V r) = V r + type Manifest (G r) = G r - makeImage !(checkDims "(V r).makeImage" -> (m, n)) f = + type Vector (G r) = Vector r + + makeImage !(checkDims "(G r).makeImage" -> (m, n)) f = VImage m n $ VG.generate (m * n) (f . toIx n) {-# INLINE makeImage #-} - makeImageWindowed sz !((it, jt), (ib, jb)) getWindowPx getBorderPx = + -- TODO: add checkWithin + makeImageWindowed !sz !((it, jt), (ib, jb)) getWindowPx getBorderPx = VImage m n $ VG.create generate where - !(m, n) = checkDims "(V r).makeImageWindowed" sz - nestedLoop :: (VG.Mutable (Repr (V r))) s (Pixel cs e) + !(m, n) = checkDims "(G r).makeImageWindowed" sz + nestedLoop :: (VG.Mutable (Vector r)) s (Pixel cs e) -> ((Int, Int) -> Pixel cs e) -> Int -> Int -> Int -> Int -> ST s () nestedLoop !mv !getPx !fi !fj !ti !tj = do - VU.forM_ (VU.enumFromN fi (ti-1)) $ \i -> - VU.forM_ (VU.enumFromN fj (tj-1)) $ \j -> - MVG.write mv (fromIx n (i,j)) (getPx (i, j)) + VU.forM_ (VU.enumFromN fi (ti-fi)) $ \i -> + VU.forM_ (VU.enumFromN fj (tj-fj)) $ \j -> + MVG.unsafeWrite mv (fromIx n (i, j)) (getPx (i, j)) {-# INLINE nestedLoop #-} - generate :: ST s ((VG.Mutable (Repr (V r))) s (Pixel cs e)) + generate :: ST s ((VG.Mutable (Vector (G r))) s (Pixel cs e)) generate = do mv <- MVG.unsafeNew (m*n) nestedLoop mv getBorderPx 0 0 ib n @@ -142,7 +146,7 @@ {-# INLINE transpose #-} -- TODO: add index verification and switch to VG.unsafeBackpermute - backpermute !(checkDims "(V r).backpermute" -> (m, n)) !f (VImage _ n' v) = + backpermute !(checkDims "(G r).backpermute" -> (m, n)) !f (VImage _ n' v) = VImage m n $ VG.backpermute v $ VG.generate (m*n) (fromIx n' . f . toIx n) backpermute !sz _ (VScalar px) = makeImage sz (const px) {-# INLINE backpermute #-} @@ -151,7 +155,7 @@ then VImage m n . VG.fromList . concat $ ls else error "fromLists: Inner lists are of different lengths." where - !(m, n) = checkDims "(V r).fromLists" (length ls, length $ head ls) + !(m, n) = checkDims "(G r).fromLists" (length ls, length $ head ls) {-# INLINE fromLists #-} fold !f !px0 (VImage _ _ v) = VG.foldl' f px0 v @@ -184,20 +188,30 @@ eq _ _ = False {-# INLINE eq #-} - compute (VImage m n v) = m `seq` n `seq` v `deepseq` (VImage m n v) - compute (VScalar px) = px `seq` (VScalar px) + compute (VImage m n v) = v `deepseq` (VImage m n v) + compute (VScalar px) = px `seq` (VScalar px) {-# INLINE compute #-} toManifest = id {-# INLINE toManifest #-} + toVector (VImage _ _ v) = VG.convert v + toVector (VScalar px) = VG.singleton px + {-# INLINE[1] toVector #-} -instance BaseArray (V r) cs e => MArray (V r) cs e where + fromVector !(m, n) !v + | m * n /= VG.length v = + error $ "fromVector: m * n doesn't equal the length of a Vector: " ++ + show m ++ " * " ++ show n ++ " /= " ++ show (VG.length v) + | m == 1 && n == 1 = VScalar (VG.unsafeIndex v 0) + | otherwise = VImage m n v + {-# INLINE fromVector #-} + +instance (BaseArray (G r) cs e) => MArray (G r) cs e where - data MImage s (V r) cs e = MVImage !Int !Int ((VG.Mutable (Repr (V r))) s (Pixel cs e)) + data MImage s (G r) cs e = MVImage !Int !Int ((VG.Mutable (Vector (G r))) s (Pixel cs e)) | MVScalar (MutVar s (Pixel cs e)) - - + unsafeIndex (VImage _ n v) !ix = VG.unsafeIndex v (fromIx n ix) unsafeIndex (VScalar px) _ = px {-# INLINE unsafeIndex #-} @@ -213,7 +227,7 @@ foldr f !a (VScalar px) = f px a {-# INLINE foldr #-} - makeImageM !(checkDims "(V r).makeImageM" -> (m, n)) !f = + makeImageM !(checkDims "(G r).makeImageM" -> (m, n)) !f = VImage m n <$> VG.generateM (m * n) (f . toIx n) {-# INLINE makeImageM #-} @@ -264,29 +278,3 @@ swap (MVImage _ n mv) !ix1 !ix2 = MVG.swap mv (fromIx n ix1) (fromIx n ix2) swap _ _ _ = return () {-# INLINE swap #-} - - --- | Convert an image to a flattened 'Vector'. It is a __O(1)__ opeartion. --- --- >>> toVector $ makeImage (3, 2) (\(i, j) -> PixelY $ fromIntegral (i+j)) --- fromList [,,,,,] --- -toVector :: VG.Vector (Repr (V r)) (Pixel cs e) => Image (V r) cs e -> (Repr (V r)) (Pixel cs e) -toVector (VImage _ _ v) = v -toVector (VScalar px) = VG.singleton px -{-# INLINE toVector #-} - - --- | Construct a two dimensional image with @m@ rows and @n@ columns from a flat --- 'Vector' of length @k@. It is a __O(1)__ opeartion. Make sure that @m * n = k@. --- --- >>> fromVector (200, 300) $ generate 60000 (\i -> PixelY $ fromIntegral i / 60000) --- --- --- <> --- -fromVector :: (Array (V r) cs e, VG.Vector (Repr (V r)) (Pixel cs e)) => (Int, Int) -> (Repr (V r)) (Pixel cs e) -> Image (V r) cs e -fromVector !(m, n) !v - | m * n == VG.length v = VImage m n v - | otherwise = error "fromVector: m * n doesn't equal the length of a Vector." -{-# INLINE fromVector #-} diff --git a/src/Graphics/Image/Interface/Vector/Storable.hs b/src/Graphics/Image/Interface/Vector/Storable.hs --- a/src/Graphics/Image/Interface/Vector/Storable.hs +++ b/src/Graphics/Image/Interface/Vector/Storable.hs @@ -18,7 +18,7 @@ -- Portability : non-portable -- module Graphics.Image.Interface.Vector.Storable ( - VS(..), S, Image(..), fromStorableVector, toStorableVector, fromIx, toIx, checkDims + VS(..), Image(..) ) where import Prelude hiding (map, zipWith) @@ -34,21 +34,14 @@ -- | Storable 'Vector' representation. data VS = VS -data S - -type instance Repr (V S) = VS.Vector - -instance Show S where - show _ = "Storable" - instance Show VS where show _ = "VectorStorable" instance SuperClass VS cs e => BaseArray VS cs e where type SuperClass VS cs e = - (ColorSpace cs e, Num (Pixel cs e), VS.Storable (Pixel cs e)) + (ColorSpace cs e, VS.Storable (Pixel cs e)) - data Image VS cs e = VSImage !(Image (V S) cs e) + newtype Image VS cs e = VSImage (Image (G VS) cs e) dims (VSImage img) = dims img {-# INLINE dims #-} @@ -58,6 +51,8 @@ instance (MArray VS cs e, BaseArray VS cs e) => Array VS cs e where type Manifest VS = VS + + type Vector VS = VS.Vector makeImage !sh = VSImage . makeImage sh {-# INLINE makeImage #-} @@ -110,19 +105,24 @@ eq (VSImage img1) (VSImage img2) = img1 == img2 {-# INLINE eq #-} - compute (VSImage img) = VSImage $! compute img + compute (VSImage img) = VSImage (compute img) {-# INLINE compute #-} toManifest = id {-# INLINE toManifest #-} + toVector (VSImage (VImage _ _ v)) = v + toVector (VSImage (VScalar px)) = VS.singleton px + {-# INLINE toVector #-} + fromVector !sz = VSImage . fromVector sz + {-# INLINE fromVector #-} + instance BaseArray VS cs e => MArray VS cs e where - data MImage s VS cs e = MVSImage (MImage s (V S) cs e) + newtype MImage s VS cs e = MVSImage (MImage s (G VS) cs e) - unsafeIndex (VSImage img) = unsafeIndex img {-# INLINE unsafeIndex #-} @@ -170,27 +170,3 @@ swap (MVSImage img) = I.swap img {-# INLINE swap #-} - - - --- | Convert an image to a flattened Storable 'VS.Vector'. It is a __O(1)__ opeartion. --- --- >>> toStorableVector $ makeImage (3, 2) (\(i, j) -> PixelY $ fromIntegral (i+j)) --- fromList [,,,,,] --- -toStorableVector :: Array VS cs e => Image VS cs e -> VS.Vector (Pixel cs e) -toStorableVector (VSImage img) = toVector img -{-# INLINE toStorableVector #-} - - --- | Construct a two dimensional image with @m@ rows and @n@ columns from a flat --- Storable 'VS.Vector' of length @k@. It is a __O(1)__ opeartion. Make sure that @m * n = k@. --- --- >>> fromStorableVector (200, 300) $ generate 60000 (\i -> PixelY $ fromIntegral i / 60000) --- --- --- <> --- -fromStorableVector :: Array VS cs e => (Int, Int) -> VS.Vector (Pixel cs e) -> Image VS cs e -fromStorableVector !sz !v = VSImage $ fromVector sz v -{-# INLINE fromStorableVector #-} diff --git a/src/Graphics/Image/Interface/Vector/Unboxed.hs b/src/Graphics/Image/Interface/Vector/Unboxed.hs --- a/src/Graphics/Image/Interface/Vector/Unboxed.hs +++ b/src/Graphics/Image/Interface/Vector/Unboxed.hs @@ -18,7 +18,7 @@ -- Portability : non-portable -- module Graphics.Image.Interface.Vector.Unboxed ( - U, VU(..), VU.Unbox, Image(..), fromUnboxedVector, toUnboxedVector, fromIx, toIx, checkDims + VU(..), VU.Unbox, Image(..) ) where import Prelude hiding (map, zipWith) @@ -35,21 +35,14 @@ -- | Unboxed 'Vector' representation. data VU = VU -data U - -type instance Repr (V U) = VU.Vector - -instance Show U where - show _ = "Unboxed" - instance Show VU where show _ = "VectorUnboxed" instance SuperClass VU cs e => BaseArray VU cs e where type SuperClass VU cs e = - (ColorSpace cs e, Num (Pixel cs e), VU.Unbox (Components cs e)) + (ColorSpace cs e, VU.Unbox (Components cs e)) - data Image VU cs e = VUImage !(Image (V U) cs e) + newtype Image VU cs e = VUImage (Image (G VU) cs e) dims (VUImage img) = dims img {-# INLINE dims #-} @@ -60,6 +53,8 @@ type Manifest VU = VU + type Vector VU = VU.Vector + makeImage !sh = VUImage . makeImage sh {-# INLINE makeImage #-} @@ -111,18 +106,24 @@ eq (VUImage img1) (VUImage img2) = img1 == img2 {-# INLINE eq #-} - compute (VUImage img) = VUImage $! compute img + compute (VUImage img) = VUImage (compute img) {-# INLINE compute #-} toManifest = id {-# INLINE toManifest #-} + toVector (VUImage (VImage _ _ v)) = v + toVector (VUImage (VScalar px)) = VU.singleton px + {-# INLINE toVector #-} + fromVector !sz = VUImage . fromVector sz + {-# INLINE fromVector #-} + + instance BaseArray VU cs e => MArray VU cs e where - data MImage s VU cs e = MVUImage (MImage s (V U) cs e) + newtype MImage s VU cs e = MVUImage (MImage s (G VU) cs e) - unsafeIndex (VUImage img) = unsafeIndex img {-# INLINE unsafeIndex #-} @@ -171,26 +172,3 @@ swap (MVUImage img) = I.swap img {-# INLINE swap #-} - - --- | Convert an image to a flattened Unboxed 'VU.Vector'. It is a __O(1)__ opeartion. --- --- >>> toUnboxedVector $ makeImage (3, 2) (\(i, j) -> PixelY $ fromIntegral (i+j)) --- fromList [,,,,,] --- -toUnboxedVector :: Array VU cs e => Image VU cs e -> VU.Vector (Pixel cs e) -toUnboxedVector (VUImage img) = toVector img -{-# INLINE toUnboxedVector #-} - - --- | Construct a two dimensional image with @m@ rows and @n@ columns from a flat --- Unboxed 'VU.Vector' of length @k@. It is a __O(1)__ opeartion. Make sure that @m * n = k@. --- --- >>> fromUnboxedVector (200, 300) $ generate 60000 (\i -> PixelY $ fromIntegral i / 60000) --- --- --- <> --- -fromUnboxedVector :: Array VU cs e => (Int, Int) -> VU.Vector (Pixel cs e) -> Image VU cs e -fromUnboxedVector !sz !v = VUImage $ fromVector sz v -{-# INLINE fromUnboxedVector #-} diff --git a/src/Graphics/Image/Interface/Vector/Unboxing.hs b/src/Graphics/Image/Interface/Vector/Unboxing.hs --- a/src/Graphics/Image/Interface/Vector/Unboxing.hs +++ b/src/Graphics/Image/Interface/Vector/Unboxing.hs @@ -6,7 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Image.Interface.Vector.Unboxing --- Copyright : (c) Alexey Kuleshevich 2016 +-- Copyright : (c) Alexey Kuleshevich 2017 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -14,76 +14,19 @@ -- module Graphics.Image.Interface.Vector.Unboxing where -import Data.Word -import Graphics.Image.Interface -import Graphics.Image.ColorSpace.Binary (Bit(..)) -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Unboxed as U import Control.Monad - --- | Unboxing of a `Bit`. -instance U.Unbox Bit - -newtype instance U.MVector s Bit = MV_Bit (U.MVector s Word8) - -instance M.MVector U.MVector Bit where - basicLength (MV_Bit mvec) = M.basicLength mvec - {-# INLINE basicLength #-} - basicUnsafeSlice idx len (MV_Bit mvec) = MV_Bit (M.basicUnsafeSlice idx len mvec) - {-# INLINE basicUnsafeSlice #-} - basicOverlaps (MV_Bit mvec) (MV_Bit mvec') = M.basicOverlaps mvec mvec' - {-# INLINE basicOverlaps #-} - basicUnsafeNew len = MV_Bit `liftM` M.basicUnsafeNew len - {-# INLINE basicUnsafeNew #-} - basicUnsafeReplicate len (Bit w) = MV_Bit `liftM` M.basicUnsafeReplicate len w - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeRead (MV_Bit mvec) idx = Bit `liftM` M.basicUnsafeRead mvec idx - {-# INLINE basicUnsafeRead #-} - basicUnsafeWrite (MV_Bit mvec) idx (Bit w) = M.basicUnsafeWrite mvec idx w - {-# INLINE basicUnsafeWrite #-} - basicClear (MV_Bit mvec) = M.basicClear mvec - {-# INLINE basicClear #-} - basicSet (MV_Bit mvec) (Bit w) = M.basicSet mvec w - {-# INLINE basicSet #-} - basicUnsafeCopy (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeCopy mvec mvec' - {-# INLINE basicUnsafeCopy #-} - basicUnsafeMove (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeMove mvec mvec' - {-# INLINE basicUnsafeMove #-} - basicUnsafeGrow (MV_Bit mvec) len = MV_Bit `liftM` M.basicUnsafeGrow mvec len - {-# INLINE basicUnsafeGrow #-} -#if MIN_VERSION_vector(0,11,0) - basicInitialize (MV_Bit mvec) = M.basicInitialize mvec - {-# INLINE basicInitialize #-} -#endif - - -newtype instance U.Vector Bit = V_Bit (U.Vector Word8) - -instance V.Vector U.Vector Bit where - basicUnsafeFreeze (MV_Bit mvec) = V_Bit `liftM` V.basicUnsafeFreeze mvec - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeThaw (V_Bit vec) = MV_Bit `liftM` V.basicUnsafeThaw vec - {-# INLINE basicUnsafeThaw #-} - basicLength (V_Bit vec) = V.basicLength vec - {-# INLINE basicLength #-} - basicUnsafeSlice idx len (V_Bit vec) = V_Bit (V.basicUnsafeSlice idx len vec) - {-# INLINE basicUnsafeSlice #-} - basicUnsafeIndexM (V_Bit vec) idx = Bit `liftM` V.basicUnsafeIndexM vec idx - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeCopy (MV_Bit mvec) (V_Bit vec) = V.basicUnsafeCopy mvec vec - {-# INLINE basicUnsafeCopy #-} - elemseq (V_Bit vec) (Bit w) = V.elemseq vec w - {-# INLINE elemseq #-} - +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed as U +import Graphics.Image.Interface -- | Unboxing of a `Pixel`. -instance (ColorSpace cs e, U.Unbox (Components cs e)) => U.Unbox (Pixel cs e) +instance ColorSpace cs e => U.Unbox (Pixel cs e) newtype instance U.MVector s (Pixel cs e) = MV_Pixel (U.MVector s (Components cs e)) -instance (ColorSpace cs e, U.Unbox (Components cs e)) => M.MVector U.MVector (Pixel cs e) where +instance ColorSpace cs e => M.MVector U.MVector (Pixel cs e) where basicLength (MV_Pixel mvec) = M.basicLength mvec {-# INLINE basicLength #-} basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (M.basicUnsafeSlice idx len mvec) @@ -116,7 +59,7 @@ newtype instance U.Vector (Pixel cs e) = V_Pixel (U.Vector (Components cs e)) -instance (ColorSpace cs e, U.Unbox (Components cs e)) => V.Vector U.Vector (Pixel cs e) where +instance (ColorSpace cs e) => V.Vector U.Vector (Pixel cs e) where basicUnsafeFreeze (MV_Pixel mvec) = V_Pixel `liftM` V.basicUnsafeFreeze mvec {-# INLINE basicUnsafeFreeze #-} basicUnsafeThaw (V_Pixel vec) = MV_Pixel `liftM` V.basicUnsafeThaw vec diff --git a/src/Graphics/Image/Processing/Binary.hs b/src/Graphics/Image/Processing/Binary.hs --- a/src/Graphics/Image/Processing/Binary.hs +++ b/src/Graphics/Image/Processing/Binary.hs @@ -51,8 +51,8 @@ -- >>> frog .<. flipH frog -- (or: flipH frog .>. frog) -- class Array arr Binary Bit => Thresholding a b arr | a b -> arr where - (.==.) :: (Eq (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit - (./=.) :: (Eq (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit + (.==.) :: Array arr cs e => a cs e -> b cs e -> Image arr Binary Bit + (./=.) :: Array arr cs e => a cs e -> b cs e -> Image arr Binary Bit (.<.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit (.<=.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit (.>.) :: (Ord (Pixel cs e), Array arr cs e) => a cs e -> b cs e -> Image arr Binary Bit diff --git a/src/Graphics/Image/Processing/Complex/Fourier.hs b/src/Graphics/Image/Processing/Complex/Fourier.hs --- a/src/Graphics/Image/Processing/Complex/Fourier.hs +++ b/src/Graphics/Image/Processing/Complex/Fourier.hs @@ -31,7 +31,7 @@ -- | Fast Fourier Transform fft :: (Applicative (Pixel cs), - Array arr cs (Complex e), + Array arr cs (Complex e), ColorSpace cs e, Fractional (Pixel cs (Complex e)), Floating (Pixel cs e), RealFloat e) => Image arr cs (Complex e) -> Image arr cs (Complex e) @@ -41,7 +41,7 @@ -- | Inverse Fast Fourier Transform ifft :: (Applicative (Pixel cs), - Array arr cs (Complex e), + Array arr cs (Complex e), ColorSpace cs e, Fractional (Pixel cs (Complex e)), Floating (Pixel cs e), RealFloat e) => Image arr cs (Complex e) -> Image arr cs (Complex e) @@ -63,7 +63,7 @@ -- | Compute the DFT of a matrix. Array dimensions must be powers of two else `error`. fft2d :: (Applicative (Pixel cs), - Array arr cs (Complex e), + Array arr cs (Complex e), ColorSpace cs e, Fractional (Pixel cs (Complex e)), Floating (Pixel cs e), RealFloat e) => Mode -> Image arr cs (Complex e) @@ -84,7 +84,7 @@ fftGeneral :: (Applicative (Pixel cs), - Array arr cs (Complex e), + Array arr cs (Complex e), ColorSpace cs e, Floating (Pixel cs e), RealFloat e) => Pixel cs e -> Image arr cs (Complex e) @@ -109,8 +109,7 @@ -- Compute a twiddle factor. -twiddle :: (Applicative (Pixel cs), - Floating (Pixel cs e)) => +twiddle :: (Applicative (Pixel cs), Floating (Pixel cs e)) => Pixel cs e -> Int -- index -> Int -- length diff --git a/src/Graphics/Image/Processing/Convolution.hs b/src/Graphics/Image/Processing/Convolution.hs --- a/src/Graphics/Image/Processing/Convolution.hs +++ b/src/Graphics/Image/Processing/Convolution.hs @@ -9,63 +9,42 @@ -- Portability : non-portable -- module Graphics.Image.Processing.Convolution ( - convolve, convolveRows, convolveCols + convolve, convolveRows, convolveCols, correlate ) where import Prelude as P + +import Graphics.Image.ColorSpace import Graphics.Image.Interface as I ---import Graphics.Image.Interface.Vector.Sparse import Graphics.Image.Processing.Geometric -convolve' :: Array arr cs e => - Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e -convolve' !border !kernel !img = - traverse2 (compute kernel) (compute img) (const . const sz) stencil + +-- | Correlate an image using a kernel. Border resolution technique is required. +correlate :: I.Array arr cs e => + Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e +correlate !border !kernel !img = + I.traverse (compute img) (const sz) stencil where - !(krnM, krnN) = dims kernel - !krnM2 = krnM `div` 2 - !krnN2 = krnN `div` 2 - !sz = dims img - getPxB !getPx !ix = handleBorderIndex border sz getPx ix + !kernelM = toManifest kernel + !(krnM, krnN) = dims kernelM + !krnM2 = krnM `div` 2 + !krnN2 = krnN `div` 2 + !sz = dims img + getPxB getPx !ix = handleBorderIndex border sz getPx ix {-# INLINE getPxB #-} - stencil !getKrnPx !getImgPx !(i, j) = integrate 0 0 0 where + stencil getImgPx !(i, j) = integrate 0 0 0 where !ikrnM = i - krnM2 !jkrnN = j - krnN2 integrate !ki !kj !acc | kj == krnN = integrate (ki+1) 0 acc | kj == 0 && ki == krnM = acc - | otherwise = let !krnPx = getKrnPx (ki, kj) + | otherwise = let !krnPx = I.unsafeIndex kernelM (ki, kj) !imgPx = getPxB getImgPx (ki + ikrnM, kj + jkrnN) in integrate ki (kj + 1) (acc + krnPx * imgPx) {-# INLINE stencil #-} -{-# INLINE convolve' #-} - --- convolveSparse :: (Exchangable arr VS, Array arr cs e, Array VS cs e) => --- Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e --- convolveSparse !border !kernel !img = --- makeImageWindowed --- sz --- ((krnM2, krnN2), (m - krnM2, n - krnN2)) --- (stencil (unsafeIndex imgM)) --- (stencil (borderIndex border imgM)) --- where --- !imgM = toManifest img --- !kernel' = exchange VS $ compute kernel --- -- !kernel' = exchange VS kernel -- deadlock?!?!? --- !(krnM, krnN) = dims kernel' --- !krnM2 = krnM `div` 2 --- !krnN2 = krnN `div` 2 --- !sz@(m, n) = dims img --- stencil getPx !(i, j) = foldIx integral 0 kernel' --- where --- integral !acc !(ki, kj) !px = px * (getPx (ki + ikrnM, kj + jkrnN)) + acc --- {-# INLINE integral #-} --- !ikrnM = i - krnM2 --- !jkrnN = j - krnN2 --- {-# INLINE stencil #-} --- {-# INLINE convolveSparse #-} +{-# INLINE correlate #-} -- | Convolution of an image using a kernel. Border resolution technique is required. @@ -84,7 +63,7 @@ -> Image arr cs e -- ^ Kernel image. -> Image arr cs e -- ^ Source image. -> Image arr cs e -convolve !out = convolve' out . rotate180 +convolve !out = correlate out . rotate180 {-# INLINE convolve #-} diff --git a/src/Graphics/Image/Processing/Interpolation.hs b/src/Graphics/Image/Processing/Interpolation.hs --- a/src/Graphics/Image/Processing/Interpolation.hs +++ b/src/Graphics/Image/Processing/Interpolation.hs @@ -19,7 +19,7 @@ class Interpolation method where -- | Construct a new pixel by using information from neighboring pixels. - interpolate :: (Num (Pixel cs e), ColorSpace cs e) => + interpolate :: ColorSpace cs e => method -- ^ Interpolation method -> Border (Pixel cs e) -- ^ Border resolution strategy -> (Int, Int) -- ^ Image dimensions @m@ rows and @n@ columns. diff --git a/src/Graphics/Image/Types.hs b/src/Graphics/Image/Types.hs --- a/src/Graphics/Image/Types.hs +++ b/src/Graphics/Image/Types.hs @@ -11,7 +11,7 @@ module Graphics.Image.ColorSpace, module Graphics.Image.IO.Formats, Array, Image, MArray, MImage, - Exchangable, Border(..), + Border(..), VU(..), VS(..), RSU(..), RPU(..), RSS(..), RPS(..) ) where @@ -83,6 +83,7 @@ ---{-# RULES ---"I.map/id" forall img. I.map id img = img --- #-} +-- {-# RULES +-- "I.map/id" forall img. I.map id img = img +-- "I.map/I.makeImage" forall f g sz. I.map f (I.makeImage sz g) = I.makeImage sz (f . g) +-- #-} diff --git a/tests/Graphics/Image/Interface/RepaSpec.hs b/tests/Graphics/Image/Interface/RepaSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Image/Interface/RepaSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Image.Interface.RepaSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import Graphics.Image as I +import Graphics.Image.Interface.Repa + +import Graphics.Image.InterfaceSpec () + +prop_toFromRepaS + :: Image RSU Y Word8 -> Bool +prop_toFromRepaS img = img == fromRepaArrayS (toRepaArray img) + +prop_toFromRepaP + :: Image RSU Y Word8 -> Bool +prop_toFromRepaP img = img == fromRepaArrayS (toRepaArray img) + + +spec :: Spec +spec = do + describe "Vector Representation Properties" $ do + it "toFromRepaS" $ property $ prop_toFromRepaS + it "toFromRepaP" $ property $ prop_toFromRepaP diff --git a/tests/Graphics/Image/Interface/VectorSpec.hs b/tests/Graphics/Image/Interface/VectorSpec.hs --- a/tests/Graphics/Image/Interface/VectorSpec.hs +++ b/tests/Graphics/Image/Interface/VectorSpec.hs @@ -4,8 +4,7 @@ import Test.Hspec import Test.QuickCheck -import Graphics.Image as I -import Graphics.Image.Interface.Vector +import Graphics.Image.Interface as I import Graphics.Image.InterfaceSpec () @@ -16,13 +15,8 @@ prop_toFromIx :: Positive Int -> NonNegative Int -> Bool prop_toFromIx (Positive n) (NonNegative k) = k == fromIx n (toIx n k) -prop_toFromVector - :: Image VU Y Word8 -> Bool -prop_toFromVector img = img == fromUnboxedVector (dims img) (toUnboxedVector img) - spec :: Spec spec = do - describe "Vector Representation Properties" $ do + describe "Vector Index Properties" $ do it "fromToIx" $ property $ prop_fromToIx it "toFromIx" $ property $ prop_toFromIx - it "toFromVector" $ property $ prop_toFromVector diff --git a/tests/Graphics/Image/InterfaceSpec.hs b/tests/Graphics/Image/InterfaceSpec.hs --- a/tests/Graphics/Image/InterfaceSpec.hs +++ b/tests/Graphics/Image/InterfaceSpec.hs @@ -45,11 +45,16 @@ instance Arbitrary (Pixel RGB Double) where arbitrary = PixelRGB <$> arbitraryDouble <*> arbitraryDouble <*> arbitraryDouble -instance (Array arr cs e, MArray arr cs e, Arbitrary (Pixel cs e)) => +instance (Array arr cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image arr cs e) where arbitrary = do (Positive (Small m), Positive (Small n)) <- arbitrary - I.makeImageM (m, n) (const arbitrary) + getPx <- arbitrary + if (m, n) == (1, 1) + then do + elements [I.makeImage (m, n) getPx, I.scalar (getPx (0, 0))] + else + return $ I.makeImage (m, n) getPx shrink img | dims img == (1,1) = [] | rows img == 1 = [downsampleCols img] @@ -166,25 +171,25 @@ prop_sameDims _ (Identical img1 img2) = I.dims img1 == I.dims img2 prop_sameImage - :: (Exchangable arr VU, Array arr RGB Word8) + :: Array arr RGB Word8 => arr -> Identical VU arr RGB Word8 -> Bool prop_sameImage _ (Identical img1 img2) = img1 == I.exchange VU img2 prop_sameMap - :: (Exchangable arr RSU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> (Pixel Y Word8 -> Pixel Y Word8) -> Identical VU arr Y Word8 -> Bool prop_sameMap _ f (Identical img1 img2) = I.exchange RSU (I.map f img1) == I.exchange RSU (I.map f img2) prop_sameImap - :: (Exchangable arr RPU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8) -> Identical VU arr Y Word8 -> Bool prop_sameImap _ f (Identical img1 img2) = I.exchange RPU (I.imap f img1) == I.exchange RPU (I.imap f img2) prop_sameZipWith - :: (Exchangable arr RPU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> (Pixel Y Word8 -> Pixel Y Word8) -> (Pixel Y Word8 -> Pixel Y Word8 -> Pixel Y Word8) @@ -198,7 +203,7 @@ img2' = I.map g img2 prop_sameIZipWith - :: (Exchangable arr RPU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> (Pixel Y Word8 -> Pixel Y Word8) -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8 -> Pixel Y Word8) @@ -212,7 +217,7 @@ img2' = I.map g img2 prop_sameTraverse - :: (Exchangable arr RSU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> ((Int, Int) -> (Positive (Small Int), Positive (Small Int))) -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8) @@ -228,7 +233,7 @@ prop_sameTraverse2 - :: (Exchangable arr RSU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> ((Int, Int) -> (Int, Int) -> (Positive (Small Int), Positive (Small Int))) -> ((Int, Int) -> Pixel Y Word8 -> Pixel Y Word8 -> Pixel Y Word8) @@ -249,7 +254,7 @@ prop_sameTranspose - :: (Exchangable arr RSU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> Identical VU arr Y Word8 -> Bool @@ -258,7 +263,7 @@ prop_sameBackpermute - :: (Exchangable arr RPU, Array arr Y Word8) + :: Array arr Y Word8 => arr -> (Positive (Small Int), Positive (Small Int)) -> ((Int, Int) -> (Int, Int)) @@ -275,12 +280,22 @@ prop_toFormLists :: (Array arr Y Word8, MArray arr Y Word8) => arr -> Image arr Y Word8 -> Bool prop_toFormLists _ img = img == I.fromLists (I.toLists img) +prop_toFromVector :: Array arr Y Word8 => arr -> Image arr Y Word8 -> Bool +prop_toFromVector _ img = img == fromVector (dims img) (toVector img) + spec :: Spec spec = do describe "Interface Properties" $ do it "borderIndex" $ property prop_borderIndex - it "toFormLists" $ property $ prop_toFormLists VU + it "toFormLists VU" $ property $ prop_toFormLists VU + it "toFormLists VS" $ property $ prop_toFormLists VS + it "toFromVector VU" $ property $ prop_toFromVector VU + it "toFromVector VS" $ property $ prop_toFromVector VS + it "toFromVector RPU" $ property $ prop_toFromVector RPU + it "toFromVector RSU" $ property $ prop_toFromVector RSU + it "toFromVector RPS" $ property $ prop_toFromVector RPS + it "toFromVector RSS" $ property $ prop_toFromVector RSS describe "Representation Properties" $ do it "sameDims VS" $ property $ prop_sameDims VS it "sameDims RSU" $ property $ prop_sameDims RSU @@ -288,27 +303,27 @@ it "sameImage VS" $ property $ prop_sameImage VS it "sameImage RSU" $ property $ prop_sameImage RSU it "sameImage RPU" $ property $ prop_sameImage RPU - --it "sameMap VS" $ property $ prop_sameMap VS + it "sameMap VS" $ property $ prop_sameMap VS it "sameMap RSU" $ property $ prop_sameMap RSU it "sameMap RPU" $ property $ prop_sameMap RPU - --it "sameImap VS" $ property $ prop_sameImap VS + it "sameImap VS" $ property $ prop_sameImap VS it "sameImap RSU" $ property $ prop_sameImap RSU it "sameImap RPU" $ property $ prop_sameImap RPU - --it "sameZipWith VS" $ property $ prop_sameZipWith VS + it "sameZipWith VS" $ property $ prop_sameZipWith VS it "sameZipWith RSU" $ property $ prop_sameZipWith RSU it "sameZipWith RPU" $ property $ prop_sameZipWith RPU - --it "sameIZipWith VS" $ property $ prop_sameIZipWith VS + it "sameIZipWith VS" $ property $ prop_sameIZipWith VS it "sameIZipWith RSU" $ property $ prop_sameIZipWith RSU it "sameIZipWith RPU" $ property $ prop_sameIZipWith RPU - --it "sameTraverse VS" $ property $ prop_sameTraverse VS + it "sameTraverse VS" $ property $ prop_sameTraverse VS it "sameTraverse RSU" $ property $ prop_sameTraverse RSU it "sameTraverse RPU" $ property $ prop_sameTraverse RPU - --it "sameTraverse2 VS" $ property $ prop_sameTraverse2 VS + it "sameTraverse2 VS" $ property $ prop_sameTraverse2 VS it "sameTraverse2 RSU" $ property $ prop_sameTraverse2 RSU it "sameTraverse2 RPU" $ property $ prop_sameTraverse2 RPU - --it "sameTranspose VS" $ property $ prop_sameTranspose VS + it "sameTranspose VS" $ property $ prop_sameTranspose VS it "sameTranspose RSU" $ property $ prop_sameTranspose RSU it "sameTranspose RPU" $ property $ prop_sameTranspose RPU - --it "sameBackpermute VS" $ property $ prop_sameBackpermute VS + it "sameBackpermute VS" $ property $ prop_sameBackpermute VS it "sameBackpermute RSU" $ property $ prop_sameBackpermute RSU it "sameBackpermute RPU" $ property $ prop_sameBackpermute RPU