diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 0.2.0 + +* Switch to `MonadIO` +* Write files with durability and atomicity guarantees +* Switch to `encodeM` and `decodeM`, as well as corresponding `encodeImageM` and `decodeImageM` +* Addition of `decodeWithMetadataM` +* Addition of `ConvertError`, `DecodeError` and `EncodeError`. +* Got rid of `ReadOptions` +* Switch to `Color` package for pixels and color space coversion + # 0.1.9 * Fix `HDR` decoding, i.e. `.hdr` and `.pic` file reading. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Alexey Kuleshevich (c) 2017 +Copyright Alexey Kuleshevich (c) 2017-2020 All rights reserved. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + import Distribution.Simple + +main :: IO () main = defaultMain + +#endif diff --git a/files/_frog.jpg b/files/_frog.jpg new file mode 100644 Binary files /dev/null and b/files/_frog.jpg differ diff --git a/files/frog.jpg b/files/frog.jpg new file mode 100644 Binary files /dev/null and b/files/frog.jpg differ diff --git a/massiv-io.cabal b/massiv-io.cabal --- a/massiv-io.cabal +++ b/massiv-io.cabal @@ -1,5 +1,5 @@ name: massiv-io -version: 0.1.9.0 +version: 0.2.0.0 synopsis: Import/export of Image files into massiv Arrays description: This package contains functionality for import/export of arrays into the real world. For now it only has the ability to read/write @@ -9,41 +9,46 @@ license-file: LICENSE author: Alexey Kuleshevich maintainer: alexey@kuleshevi.ch -copyright: 2018-2019 Alexey Kuleshevich +copyright: 2018-2020 Alexey Kuleshevich category: Data, Data Structures -build-type: Simple +build-type: Custom +extra-doc-files: files/*.jpg extra-source-files: README.md , CHANGELOG.md -cabal-version: >=1.10 +cabal-version: >=1.18 +custom-setup + setup-depends: + base + , Cabal + , cabal-doctest >=1.0.6 library hs-source-dirs: src - exposed-modules: Graphics.ColorSpace - , Graphics.ColorSpace.Binary - , Graphics.ColorSpace.CMYK - , Graphics.ColorSpace.Complex - , Graphics.ColorSpace.HSI - , Graphics.ColorSpace.RGB - , Graphics.ColorSpace.X - , Graphics.ColorSpace.Y - , Graphics.ColorSpace.YCbCr - , Data.Massiv.Array.IO - other-modules: Graphics.ColorSpace.Elevator - , Graphics.ColorSpace.Internal - , Data.Massiv.Array.IO.Base + exposed-modules: Data.Massiv.Array.IO + , Graphics.ColorModel + other-modules: Data.Massiv.Array.IO.Base , Data.Massiv.Array.IO.Image , Data.Massiv.Array.IO.Image.JuicyPixels + , Data.Massiv.Array.IO.Image.JuicyPixels.Base + , Data.Massiv.Array.IO.Image.JuicyPixels.BMP + , Data.Massiv.Array.IO.Image.JuicyPixels.GIF + , Data.Massiv.Array.IO.Image.JuicyPixels.HDR + , Data.Massiv.Array.IO.Image.JuicyPixels.JPG + , Data.Massiv.Array.IO.Image.JuicyPixels.PNG + , Data.Massiv.Array.IO.Image.JuicyPixels.TGA + , Data.Massiv.Array.IO.Image.JuicyPixels.TIF , Data.Massiv.Array.IO.Image.Netpbm build-depends: base >= 4.8 && < 5 , bytestring + , Color >= 0.1.2 , data-default-class , deepseq - , directory - , filepath >= 1.0 - , massiv >= 0.1.1 - , process - , JuicyPixels >= 3.2.7 + , exceptions + , filepath + , massiv >= 0.3 + , JuicyPixels >= 3.3 , netpbm + , unliftio >= 0.2.12 , vector >= 0.10 default-language: Haskell2010 ghc-options: -Wall @@ -55,6 +60,42 @@ else if os(darwin) CPP-options: -DOS_Mac + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Data.Massiv.Array.IOSpec + , Spec + build-depends: JuicyPixels + , QuickCheck + , base + , bytestring + , hspec + , massiv + , massiv-io + , massiv-test + , random + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded + -freduction-depth=0 + + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base + , doctest >=0.15 + , QuickCheck + , template-haskell + default-language: Haskell2010 source-repository head type: git diff --git a/src/Data/Massiv/Array/IO.hs b/src/Data/Massiv/Array/IO.hs --- a/src/Data/Massiv/Array/IO.hs +++ b/src/Data/Massiv/Array/IO.hs @@ -8,16 +8,21 @@ {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Massiv.Array.IO --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental -- Portability : non-portable -- module Data.Massiv.Array.IO - ( -- $supported + ( -- * Supported Image Formats + module Graphics.Pixel.ColorSpace + , Image + -- $supported + -- * Reading - readArray + , readArray + , readArrayWithMetadata , readImage , readImageAuto -- * Writing @@ -36,27 +41,37 @@ , fehViewer , gimpViewer -- * Supported Image Formats - , module Data.Massiv.Array.IO.Base , module Data.Massiv.Array.IO.Image + -- * All other common reading/writing components + , module Base ) where -import Control.Concurrent (forkIO) -import Control.Exception (bracket) import Control.Monad (void) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Massiv.Array as A -import Data.Massiv.Array.IO.Base hiding (convertEither, fromEitherDecode, - fromMaybeEncode, toProxy) +import Data.Massiv.Array.IO.Base (Image) +import Data.Massiv.Array.IO.Base as Base (Auto(..), ConvertError(..), + DecodeError(..), EncodeError(..), + FileFormat(..), MonadThrow(..), + Readable(..), Sequence(..), + Writable(..), convertEither, + convertImage, decode', decodeError, + defaultWriteOptions, encode', + encodeError, fromImageBaseModel, + fromMaybeDecode, fromMaybeEncode, + toImageBaseModel, toProxy) import Data.Massiv.Array.IO.Image -import Graphics.ColorSpace +import Graphics.Pixel.ColorSpace +import Prelude import Prelude as P hiding (readFile, writeFile) -import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) -import System.FilePath -import System.IO (hClose, openBinaryTempFile) -import System.Process (readProcess) - - +import System.FilePath (()) +import System.IO (IOMode(..), hClose, openBinaryTempFile) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.Directory (createDirectoryIfMissing, getTemporaryDirectory) +import UnliftIO.Exception (bracket) +import UnliftIO.IO.File +import UnliftIO.Process (readProcess) -- | External viewing application to use for displaying images. @@ -72,136 +87,217 @@ --- | Read an array from one of the supported file formats. -readArray :: Readable f arr => +-- | Read an array from one of the supported `Readable` file formats. +-- +-- For example `readImage` assumes all images to be in sRGB color space, but if you know +-- that the image is actually encoded in some other color space, for example `AdobeRGB`, +-- then you can read it in manually into a matching color model and then cast into a color +-- space you know it is encoded in: +-- +-- >>> import qualified Graphics.ColorModel as CM +-- >>> frogRGB <- readArray JPG "files/_frog.jpg" :: IO (Image S CM.RGB Word8) +-- >>> let frogAdobeRGB = (fromImageBaseModel frogRGB :: Image S AdobeRGB Word8) +-- +-- @since 0.1.0 +readArray :: (Readable f arr, MonadIO m) => f -- ^ File format that should be used while decoding the file - -> ReadOptions f -- ^ Any file format related decoding options. Use `def` for default. -> FilePath -- ^ Path to the file - -> IO arr -readArray format opts path = decode format opts <$> B.readFile path + -> m arr +readArray format path = liftIO (B.readFile path >>= decodeM format) {-# INLINE readArray #-} +-- | Read an array from one of the supported file formats. Some formats are capable of +-- preducing format specific metadata. +-- +-- @since 0.2.0 +readArrayWithMetadata :: + (Readable f arr, MonadIO m) + => f -- ^ File format that should be used while decoding the file + -> FilePath -- ^ Path to the file + -> m (arr, Metadata f) +readArrayWithMetadata format path = liftIO (B.readFile path >>= decodeWithMetadataM format) +{-# INLINE readArrayWithMetadata #-} -writeArray :: Writable f arr => +writeLazyAtomically :: FilePath -> BL.ByteString -> IO () +writeLazyAtomically filepath bss = + withBinaryFileDurableAtomic filepath WriteMode $ \h -> Prelude.mapM_ (B.hPut h) (BL.toChunks bss) +{-# INLINE writeLazyAtomically #-} + +-- | Write an array to disk. +-- +-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (YCbCr SRGB) Word8) +-- >>> frogAdobeRGB = convertImage frogYCbCr :: Image D AdobeRGB Word8 +-- >>> writeArray JPG def "files/_frog.jpg" $ toImageBaseModel $ computeAs S frogAdobeRGB +-- +-- /Note/ - On UNIX operating systems writing will happen with guarantees of atomicity and +-- durability, see `withBinaryFileDurableAtomic`. +-- +-- @since 0.2.0 +writeArray :: (Writable f arr, MonadIO m) => f -- ^ Format to use while encoding the array -> WriteOptions f -- ^ Any file format related encoding options. Use `def` for default. -> FilePath - -> arr -> IO () -writeArray format opts path arr = BL.writeFile path (encode format opts arr) + -> arr + -> m () +writeArray format opts filepath arr = + liftIO (encodeM format opts arr >>= writeLazyAtomically filepath) {-# INLINE writeArray #-} --- | Try to guess an image format from file's extension, then attempt to decode it as such. In order --- to supply the format manually and thus avoid this guessing technique, use `readArray` --- instead. Color space and precision of the result array must match exactly that of the actual --- image, in order to apply auto conversion use `readImageAuto` instead. +-- | Tries to guess an image format from file's extension, then attempts to decode it as +-- such. It also assumes an image is encoded in sRGB color space or its alternate +-- representation. In order to supply the format manually or choose a different color +-- space, eg. `AdobeRGB`, use `readArray` instead. Color space and precision of the result +-- image must match exactly that of the actual image. -- --- Might throw `ConvertError`, `DecodeError` and other standard errors related to file IO. +-- May throw `ConvertError`, `DecodeError` and other standard errors related to file IO. -- --- Result image will be read as specified by the type signature: +-- Resulting image will be read as specified by the type signature: -- --- >>> frog <- readImage "files/frog.jpg" :: IO (Image S YCbCr Word8) --- >>> displayImage frog +-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S (YCbCr SRGB) Word8) +-- >>> size frog +-- Sz (200 :. 320) -- --- In case when the result image type does not match the color space or precision of the actual --- image file, `ConvertError` will be thrown. +-- @__>>> displayImage frog__ @ -- --- >>> frog <- readImage "files/frog.jpg" :: IO (Image S CMYK Word8) --- >>> displayImage frog --- *** Exception: ConvertError "Cannot decode JPG image as " +-- ![frog](files/frog.jpg) -- --- Whenever image is not in the color space or precision that we need, either use `readImageAuto` or --- manually convert to the desired one by using the appropriate conversion functions: +-- In case when the result image type does not match the color space or precision of the +-- actual image file, `ConvertError` will be thrown. -- --- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S CMYK Double) --- >>> displayImage frogCMYK +-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S SRGB Word8) +-- *** Exception: ConvertError "Cannot decode JPG image as " -- -readImage :: (Source S Ix2 (Pixel cs e), ColorSpace cs e) => - FilePath -- ^ File path for an image - -> IO (Image S cs e) -readImage path = decodeImage imageReadFormats path <$> B.readFile path +-- Whenever image is not in the color space or precision that we need, either use +-- `readImageAuto` or manually convert to the desired one by using the appropriate +-- conversion functions: +-- +-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (YCbCr SRGB) Word8) +-- >>> let frogSRGB = convertImage frogYCbCr :: Image D SRGB Word8 +-- +-- A simpler approach to achieve the same effect would be to use `readImageAuto`: +-- +-- >>> frogSRGB' <- readImageAuto "files/frog.jpg" :: IO (Image S SRGB Word8) +-- >>> compute frogSRGB == frogSRGB' +-- True +-- +-- @since 0.1.0 +readImage :: + (ColorSpace cs i e, MonadIO m) + => FilePath -- ^ File path for an image + -> m (Image S cs e) +readImage path = liftIO (B.readFile path >>= decodeImageM imageReadFormats path) {-# INLINE readImage #-} --- | Same as `readImage`, but will perform any possible color space and --- precision conversions in order to match the result image type. Very useful --- whenever image format isn't known at compile time. -readImageAuto :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - FilePath -- ^ File path for an image - -> IO (Image r cs e) -readImageAuto path = decodeImage imageReadAutoFormats path <$> B.readFile path +-- | Similar to `readImage`, but works will perform all necessary color space conversion +-- and precision adjustment in order to match the result image type. Very useful whenever +-- image format isn't known at compile time. +-- +-- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S (CMYK SRGB) Double) +-- >>> size frogCMYK +-- Sz (200 :. 320) +-- +-- @since 0.1.0 +readImageAuto :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadIO m) + => FilePath -- ^ File path for an image + -> m (Image r cs e) +readImageAuto path = liftIO (B.readFile path >>= decodeImageM imageReadAutoFormats path) {-# INLINE readImageAuto #-} --- | This function will guess an output file format from the file extension and will write to file --- any image with the colorspace that is supported by that format. Precision of the image might be --- adjusted using `Elevator` if precision of the source array is not supported by the image file --- format. For instance an @(`Image` r `RGBA` `Double`)@ being saved as `PNG` file would be written as --- @(`Image` r `RGBA` `Word16`)@, thus using highest supported precision `Word16` for that --- format. If automatic colors space is also desired, `writeImageAuto` can be used instead. +-- | This function will guess an output file format from the file extension and will write +-- to file any image with the color model that is supported by that format. In case that +-- automatic precision adjustment or colors space conversion is also desired, +-- `writeImageAuto` can be used instead. -- -- Can throw `ConvertError`, `EncodeError` and other usual IO errors. -- -writeImage :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) => - FilePath -> Image r cs e -> IO () -writeImage path = BL.writeFile path . encodeImage imageWriteFormats path +-- /Note/ - On UNIX operating systems writing will happen with guarantees of atomicity and +-- durability, see `withBinaryFileDurableAtomic`. +-- +-- @since 0.1.0 +writeImage :: + (Source r Ix2 (Pixel cs e), ColorSpace cs i e, MonadIO m) => FilePath -> Image r cs e -> m () +writeImage path img = liftIO (encodeImageM imageWriteFormats path img >>= writeLazyAtomically path) --- | Write an image to file while performing all necessary precisiona and color space conversions. -writeImageAuto - :: ( Source r Ix2 (Pixel cs e) - , ColorSpace cs e - , ToYA cs e - , ToRGBA cs e - , ToYCbCr cs e - , ToCMYK cs e - ) - => FilePath -> Image r cs e -> IO () -writeImageAuto path = BL.writeFile path . encodeImage imageWriteAutoFormats path +-- | Write an image encoded in sRGB color space into a file while performing all necessary +-- precision and color space conversions. If a file supports color model that the image is +-- on then it will be encoded as such. For example writing a TIF file in CMYK color model, +-- 8bit precision and an sRGB color space: +-- +-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (YCbCr SRGB) Word8) +-- >>> writeImageAuto "files/frog.tiff" (convertImage frogYCbCr :: Image D (CMYK AdobeRGB) Word8) +-- +-- Regardless that the color space supplied was `AdobeRGB` auto conversion will ensure it +-- is stored as `SRGB`, except in `CM.CMYK` color model, since `TIF` file format supports it. +-- +-- @since 0.1.0 +writeImageAuto :: + (Source r Ix2 (Pixel cs e), ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, MonadIO m) + => FilePath + -> Image r cs e + -> m () +writeImageAuto path img = + liftIO (encodeImageM imageWriteAutoFormats path img >>= writeLazyAtomically path) -- | An image is written as a @.tiff@ file into an operating system's temporary -- directory and passed as an argument to the external viewer program. +-- +-- @since 0.1.0 displayImageUsing :: - Writable (Auto TIF) (Image r cs e) + (Writable (Auto TIF) (Image r cs e), MonadIO m) => ExternalViewer -- ^ Image viewer program - -> Bool -- ^ Should the function block the current thread until viewer is closed. - -> Image r cs e - -> IO () + -> Bool -- ^ Should this function block the current thread until viewer is + -- closed. Supplying `False` is only safe in the ghci session. + -> Image r cs e -- ^ Image to display + -> m () displayImageUsing viewer block img = - if block - then display - else img `seq` void (forkIO display) + liftIO $ do + bs <- encodeM (Auto TIF) () img + (if block then id else void . forkIO) $ display bs where - display = do + display bs = do tmpDir <- fmap ( "massiv-io") getTemporaryDirectory createDirectoryIfMissing True tmpDir bracket (openBinaryTempFile tmpDir "tmp-img.tiff") (hClose . snd) (\(imgPath, imgHandle) -> do - BL.hPut imgHandle (encode (Auto TIF) () img) + BL.hPut imgHandle bs hClose imgHandle displayImageFile viewer imgPath) - --- | Displays an image file by calling an external image viewer. -displayImageFile :: ExternalViewer -> FilePath -> IO () +-- | Displays an image file by calling an external image viewer. It will block until the +-- external viewer is closed. +-- +-- @since 0.1.0 +displayImageFile :: MonadIO m => ExternalViewer -> FilePath -> m () displayImageFile (ExternalViewer exe args ix) imgPath = - void $ readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) "" + void $ liftIO $ readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) "" where (argsBefore, argsAfter) = P.splitAt ix args --- | Makes a call to an external viewer that is set as a default image viewer by --- the OS. This is a non-blocking function call, so it might take some time --- before an image will appear. -displayImage :: Writable (Auto TIF) (Image r cs e) => Image r cs e -> IO () +-- | Writes an image to a temporary file and makes a call to an external viewer that is +-- set as a default image viewer by the OS. This is a non-blocking function call, so it +-- might take some time before an image will appear. +-- +-- /Note/ - This function should only be used in ghci, otherwise use @`displayImage` +-- `defaultViewer` `True`@ +-- +-- @since 0.1.0 +displayImage :: (Writable (Auto TIF) (Image r cs e), MonadIO m) => Image r cs e -> m () displayImage = displayImageUsing defaultViewer False -- | Default viewer is inferred from the operating system. +-- +-- @since 0.1.0 defaultViewer :: ExternalViewer defaultViewer = #if defined(OS_Win32) @@ -215,28 +311,28 @@ #endif --- | @eog \/tmp\/hip\/img.tiff@ +-- | @eog \/tmp\/massiv\/img.tiff@ -- -- eogViewer :: ExternalViewer eogViewer = ExternalViewer "eog" [] 0 --- | @feh --fullscreen --auto-zoom \/tmp\/hip\/img.tiff@ +-- | @feh --fullscreen --auto-zoom \/tmp\/massiv\/img.tiff@ -- -- fehViewer :: ExternalViewer fehViewer = ExternalViewer "feh" ["--fullscreen", "--auto-zoom"] 2 --- | @gpicview \/tmp\/hip\/img.tiff@ +-- | @gpicview \/tmp\/massiv\/img.tiff@ -- -- gpicviewViewer :: ExternalViewer gpicviewViewer = ExternalViewer "gpicview" [] 0 --- | @gimp \/tmp\/hip\/img.tiff@ +-- | @gimp \/tmp\/massiv\/img.tiff@ -- -- gimpViewer :: ExternalViewer @@ -249,67 +345,70 @@ and packages. -List of image formats that are currently supported, and their exact -'ColorSpace's and precision for reading and writing without an implicit -conversion: +List of image formats that are currently supported, and their exact 'ColorModel's with +precision for reading and writing without any conversion: * 'BMP': - * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') - * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __read__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8') + * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8') * 'GIF': - * __read__: ('RGB' 'Word8'), ('RGBA' 'Word8') - * __write__: ('RGB' 'Word8') + * __read__: ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8') + * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8') * Also supports reading and writing animated images * 'HDR': - * __read__: ('RGB' 'Float') - * __write__: ('RGB' 'Float') + * __read__: ('PixelRGB' 'Float') + * __write__: ('PixelRGB' 'Float') * 'JPG': - * __read__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), - ('YCbCr', 'Word8') - * __write__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), - ('YCbCr', 'Word8') + * __read__: ('PixelY' 'Word8'), ('PixelYA' 'Word8'), ('PixelRGB' 'Word8'), ('PixelCMYK' 'Word8'), + ('PixelYCbCr', 'Word8') + * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelCMYK' 'Word8'), + ('PixelYCbCr', 'Word8') * 'PNG': - * __read__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') - * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + * __read__: ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelYA' 'Word8'), ('PixelYA' 'Word16'), + ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16') + * __write__: ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelYA' 'Word8'), ('PixelYA' 'Word16'), + ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16') * 'TGA': - * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') - * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __read__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8') + * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8') * 'TIF': - * __read__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16'), - ('CMYK' 'Word8'), ('CMYK' 'Word16') - * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') - ('CMYK' 'Word8'), ('CMYK' 'Word16'), ('YCbCr' 'Word8') + * __read__: + ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelY' 'Word32'), ('PixelY' 'Float'), + ('PixelYA' 'Word8'), ('PixelYA' 'Word16'), + ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16'), + ('PixelCMYK' 'Word8'), ('PixelCMYK' 'Word16') + * __write__: + ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelY' 'Word32'), ('PixelY' 'Float'), + ('PixelYA' 'Word8'), ('PixelYA' 'Word16'), + ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16') + ('PixelCMYK' 'Word8'), ('PixelCMYK' 'Word16'), ('PixelYCbCr' 'Word8') * 'PBM': - * __read__: ('Binary' 'Bit') + * __read__: ('PixelY' 'Bit') * Also supports sequence of images in one file, when read as @['PBM']@ * 'PGM': - * __read__: ('Y' 'Word8'), ('Y' 'Word16') + * __read__: ('PixelY' 'Word8'), ('PixelY' 'Word16') * Also supports sequence of images in one file, when read as @['PGM']@ * 'PPM': - * __read__: ('RGB' 'Word8'), ('RGB' 'Word16') + * __read__: ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16') * Also supports sequence of images in one file, when read as @['PPM']@ -} diff --git a/src/Data/Massiv/Array/IO/Base.hs b/src/Data/Massiv/Array/IO/Base.hs --- a/src/Data/Massiv/Array/IO/Base.hs +++ b/src/Data/Massiv/Array/IO/Base.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Massiv.Array.IO.Base --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -16,29 +19,37 @@ module Data.Massiv.Array.IO.Base ( FileFormat(..) , Readable(..) + , decode' , Writable(..) + , encode' , ConvertError(..) , EncodeError(..) , DecodeError(..) , Sequence(..) , Auto(..) , Image - , defaultReadOptions + , convertImage + , toImageBaseModel + , fromImageBaseModel , defaultWriteOptions + , encodeError + , decodeError , toProxy , fromMaybeEncode - , fromEitherDecode + , fromMaybeDecode , convertEither + , MonadThrow(..) ) where +import Unsafe.Coerce import Control.Exception (Exception, throw) +import Control.Monad.Catch (MonadThrow(..)) import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import Data.Default.Class (Default(..)) -import Data.Massiv.Array -import Data.Maybe (fromMaybe) +import Data.Massiv.Array as A import Data.Typeable -import Graphics.ColorSpace (ColorSpace, Pixel) +import Graphics.Pixel.ColorSpace type Image r cs e = Array r Ix2 (Pixel cs e) @@ -63,11 +74,6 @@ instance Exception EncodeError --- | Generate default read options for a file format -defaultReadOptions :: FileFormat f => f -> ReadOptions f -defaultReadOptions _ = def - - -- | Generate default write options for a file format defaultWriteOptions :: FileFormat f => f -> WriteOptions f defaultWriteOptions _ = def @@ -80,15 +86,14 @@ -- | File format. Helps in guessing file format from a file extension, -- as well as supplying format specific options during saving the file. -class (Default (ReadOptions f), Default (WriteOptions f), Show f) => FileFormat f where - -- | Options that can be used during reading a file in this format. - type ReadOptions f - type ReadOptions f = () - +class (Default (WriteOptions f), Show f) => FileFormat f where -- | Options that can be used during writing a file in this format. type WriteOptions f type WriteOptions f = () + type Metadata f + type Metadata f = () + -- | Default file extension for this file format. ext :: f -> String @@ -103,87 +108,144 @@ instance FileFormat f => FileFormat (Auto f) where - type ReadOptions (Auto f) = ReadOptions f type WriteOptions (Auto f) = WriteOptions f + type Metadata (Auto f) = Metadata f ext (Auto f) = ext f exts (Auto f) = exts f --- | File formats that can be read into an Array. -class Readable f arr where +-- | File formats that can be read into arrays. +class FileFormat f => Readable f arr where + {-# MINIMAL (decodeM | decodeWithMetadataM) #-} + -- | Decode a `B.ByteString` into an array. Can also return whatever left over data that + -- was not consumed during decoding. + -- + -- @since 0.2.0 + decodeM :: MonadThrow m => f -> B.ByteString -> m arr + decodeM f bs = fst <$> decodeWithMetadataM f bs + -- | Just as `decodeM`, but also return any format type specific metadata + -- + -- @since 0.2.0 + decodeWithMetadataM :: MonadThrow m => f -> B.ByteString -> m (arr, Metadata f) + default decodeWithMetadataM :: (Metadata f ~ (), MonadThrow m) => + f -> B.ByteString -> m (arr, Metadata f) + decodeWithMetadataM f bs = do + arr <- decodeM f bs + pure (arr, ()) - -- | Decode a `B.ByteString` into an Array. - decode :: f -> ReadOptions f -> B.ByteString -> arr +-- | Encode an array into a `BL.ByteString`. +encode' :: Writable f arr => f -> WriteOptions f -> arr -> BL.ByteString +encode' f opts = either throw id . encodeM f opts +-- | Decode a `B.ByteString` into an Array. +decode' :: Readable f arr => f -> B.ByteString -> arr +decode' f = either throw id . decodeM f + -- | Arrays that can be written into a file. -class Writable f arr where +class FileFormat f => Writable f arr where -- | Encode an array into a `BL.ByteString`. - encode :: f -> WriteOptions f -> arr -> BL.ByteString - + -- + -- @since 0.2.0 + encodeM :: MonadThrow m => f -> WriteOptions f -> arr -> m BL.ByteString -- | Helper function to create a `Proxy` from the value. toProxy :: a -> Proxy a toProxy _ = Proxy +showImageType :: + forall r cs e. (Typeable r, ColorModel cs e) + => Proxy (Image r cs e) + -> String +showImageType _ = + ("" + + -- | Encode an image using the supplied function or throw an error in case of failure. fromMaybeEncode - :: forall f r cs e b. (ColorSpace cs e, FileFormat f, Typeable r) - => f -> Proxy (Image r cs e) -> Maybe b -> b -fromMaybeEncode _ _ (Just b) = b -fromMaybeEncode f _imgProxy Nothing = - throw $ - ConvertError - ("Format " ++ - show f ++ - " cannot be encoded as ") + :: forall f r cs e b m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m) + => f -> Proxy (Image r cs e) -> Maybe b -> m b +fromMaybeEncode f imgProxy = + \case + Just b -> pure b + Nothing -> + throwM $ + ConvertError ("Format " ++ show f ++ " cannot be encoded as " ++ showImageType imgProxy) -- | Decode an image using the supplied function or throw an error in case of failure. -fromEitherDecode :: forall r cs e a f. (ColorSpace cs e, FileFormat f, Typeable r) => - f - -> (a -> String) - -> (a -> Maybe (Image r cs e)) - -> Either String a - -> Image r cs e -fromEitherDecode _ _ _ (Left err) = throw $ DecodeError err -fromEitherDecode f showCS conv (Right eImg) = - fromMaybe - (throw $ - ConvertError - ("Cannot decode " ++ show f ++ " image <" ++ - showCS eImg ++ - "> as " ++ - "")) - (conv eImg) +fromMaybeDecode :: + forall r cs e a f m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m) + => f + -> (a -> String) + -> (a -> Maybe (Image r cs e)) + -> a + -> m (Image r cs e) +fromMaybeDecode f showCS conv eImg = + case conv eImg of + Nothing -> + throwM $ + ConvertError $ + "Cannot decode " ++ + show f ++ + " image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e)) + Just img -> pure img -- | Convert an image using the supplied function and return ConvertError error in case of failure. -convertEither :: forall r cs e a f. (ColorSpace cs e, FileFormat f, Typeable r) => - f - -> (a -> String) - -> (a -> Maybe (Image r cs e)) - -> a - -> Either ConvertError (Image r cs e) +convertEither :: + forall r cs i e a f m. (ColorSpace cs i e, FileFormat f, Typeable r, MonadThrow m) + => f + -> (a -> String) + -> (a -> Maybe (Image r cs e)) + -> a + -> m (Image r cs e) convertEither f showCS conv eImg = maybe - (Left $ + (throwM $ ConvertError - ("Cannot convert " ++ show f ++ " image <" ++ - showCS eImg ++ - "> as " ++ - "")) - Right + ("Cannot convert " ++ + show f ++ + " image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e)))) + pure (conv eImg) + + +encodeError :: MonadThrow m => Either String a -> m a +encodeError = either (throwM . EncodeError) pure + +decodeError :: MonadThrow m => Either String a -> m a +decodeError = either (throwM . DecodeError) pure + + +-- | Convert image to any supported color space +-- +-- @since 0.2.0 +convertImage :: + (Source r' Ix2 (Pixel cs' e'), ColorSpace cs' i' e', ColorSpace cs i e) + => Image r' cs' e' + -> Image D cs e +convertImage = A.map convertPixel + +-- | Cast an array. This is theoretically unsafe operation, but for all current `ColorSpace` +-- instances this function is perfectly safe. +-- +-- @since 0.2.0 +toImageBaseModel :: Array S Ix2 (Pixel cs e) -> Array S Ix2 (Pixel (BaseModel cs) e) +toImageBaseModel = unsafeCoerce + + +-- | Cast an array. This is theoretically unsafe operation, but for all current `ColorSpace` +-- instances this function is perfectly safe. +-- +-- @since 0.2.0 +fromImageBaseModel :: Array S Ix2 (Pixel (BaseModel cs) e) -> Array S Ix2 (Pixel cs e) +fromImageBaseModel = unsafeCoerce diff --git a/src/Data/Massiv/Array/IO/Image.hs b/src/Data/Massiv/Array/IO/Image.hs --- a/src/Data/Massiv/Array/IO/Image.hs +++ b/src/Data/Massiv/Array/IO/Image.hs @@ -2,29 +2,30 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Data.Massiv.Array.IO.Image --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental -- Portability : non-portable -- module Data.Massiv.Array.IO.Image - ( Encode - , encodeImage + ( module Data.Massiv.Array.IO.Image.JuicyPixels + , module Data.Massiv.Array.IO.Image.Netpbm + -- ** Helper image functions + , Encode + , encodeImageM , imageWriteFormats , imageWriteAutoFormats , Decode - , decodeImage + , decodeImageM , imageReadFormats , imageReadAutoFormats - , module Data.Massiv.Array.IO.Image.JuicyPixels - , module Data.Massiv.Array.IO.Image.Netpbm ) where -import Control.Exception (throw) import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import Data.Char (toLower) @@ -32,133 +33,144 @@ import Data.Massiv.Array.IO.Base import Data.Massiv.Array.IO.Image.JuicyPixels import Data.Massiv.Array.IO.Image.Netpbm -import Graphics.ColorSpace +import Graphics.Pixel.ColorSpace import Prelude as P import System.FilePath (takeExtension) data Encode out where - EncodeAs :: (FileFormat f, Writable f out) => f -> Encode out + EncodeAs + :: FileFormat f + => f + -> (forall m. MonadThrow m => + f -> out -> m BL.ByteString) + -> Encode out instance Show (Encode out) where - show (EncodeAs f) = show f + show (EncodeAs f _) = show f instance FileFormat (Encode (Image r cs e)) where - ext (EncodeAs f) = ext f + ext (EncodeAs f _) = ext f - exts (EncodeAs f) = exts f + exts (EncodeAs f _) = exts f instance Writable (Encode (Image r cs e)) (Image r cs e) where - encode (EncodeAs f) _ = encode f (defaultWriteOptions f) + encodeM (EncodeAs f enc) _ = enc f + -- | Encode an image into a lazy `BL.ByteString`, while selecting the appropriate format from the -- file extension. -encodeImage - :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) +-- +-- @since 0.2.0 +encodeImageM + :: MonadThrow m => [Encode (Image r cs e)] -- ^ List of image formats to choose from (useful lists are - -- `imageWriteFormats` and `imageWriteAutoFormats` + -- `imageWriteFormats` and `imageWriteAutoFormats`) -> FilePath -- ^ File name with extension, so the format can be inferred -> Image r cs e -- ^ Image to encode - -> BL.ByteString -encodeImage formats path img = do + -> m BL.ByteString +encodeImageM formats path img = do let ext' = P.map toLower . takeExtension $ path case dropWhile (not . isFormat ext') formats of - [] -> throw $ EncodeError $ "File format is not supported: " ++ ext' - (f:_) -> encode f () img + [] -> throwM $ EncodeError $ "File format is not supported: " ++ ext' + (f:_) -> encodeM f () img + + -- | List of image formats that can be encoded without any color space conversion. -imageWriteFormats :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) => [Encode (Image r cs e)] +imageWriteFormats :: (Source r Ix2 (Pixel cs e), ColorSpace cs i e) => [Encode (Image r cs e)] imageWriteFormats = - [ EncodeAs BMP - , EncodeAs GIF - , EncodeAs HDR - , EncodeAs JPG - , EncodeAs PNG - , EncodeAs TGA - , EncodeAs TIF + [ EncodeAs BMP (\ f -> encodeBMP f def . toImageBaseModel . computeSource) + , EncodeAs GIF (\ f -> encodeGIF f def . toImageBaseModel . computeSource) + , EncodeAs HDR (\ f -> encodeHDR f def . toImageBaseModel . computeSource) + , EncodeAs JPG (\ f -> encodeJPG f def . toImageBaseModel . computeSource) + , EncodeAs PNG (\ f -> encodePNG f . toImageBaseModel . computeSource) + , EncodeAs TGA (\ f -> encodeTGA f . toImageBaseModel . computeSource) + , EncodeAs TIF (\ f -> encodeTIF f . toImageBaseModel . computeSource) ] -- | List of image formats that can be encoded with any necessary color space conversions. -imageWriteAutoFormats - :: ( Source r Ix2 (Pixel cs e) - , ColorSpace cs e - , ToYA cs e - , ToRGBA cs e - , ToYCbCr cs e - , ToCMYK cs e - ) +imageWriteAutoFormats :: + (Source r Ix2 (Pixel cs e), ColorSpace cs i e, ColorSpace (BaseSpace cs) i e) => [Encode (Image r cs e)] imageWriteAutoFormats = - [ EncodeAs (Auto BMP) - , EncodeAs (Auto GIF) - , EncodeAs (Auto HDR) - , EncodeAs (Auto JPG) - , EncodeAs (Auto PNG) - , EncodeAs (Auto TGA) - , EncodeAs (Auto TIF) + [ EncodeAs (Auto BMP) (\f -> pure . encodeAutoBMP f def) + , EncodeAs (Auto GIF) (`encodeAutoGIF` def) + , EncodeAs (Auto HDR) (\f -> pure . encodeAutoHDR f def) + , EncodeAs (Auto JPG) (\f -> pure . encodeAutoJPG f def) + , EncodeAs (Auto PNG) (\f -> pure . encodeAutoPNG f) + , EncodeAs (Auto TGA) (\f -> pure . encodeAutoTGA f) + , EncodeAs (Auto TIF) (\f -> pure . encodeAutoTIF f) ] data Decode out where - DecodeAs :: (FileFormat f, Readable f out) => f -> Decode out + DecodeAs + :: FileFormat f + => f + -> (forall m. MonadThrow m => f -> B.ByteString -> m out) + -> Decode out instance Show (Decode out) where - show (DecodeAs f) = show f + show (DecodeAs f _) = show f instance FileFormat (Decode (Image r cs e)) where - ext (DecodeAs f) = ext f + ext (DecodeAs f _) = ext f - exts (DecodeAs f) = exts f + exts (DecodeAs f _) = exts f instance Readable (Decode (Image r cs e)) (Image r cs e) where - decode (DecodeAs f) _ = decode f (defaultReadOptions f) + decodeM (DecodeAs f dec) = dec f + -- | Decode an image from the strict `ByteString` while inferring format the image is encoded in -- from the file extension -decodeImage - :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) +-- +-- @since 0.2.0 +decodeImageM + :: MonadThrow m => [Decode (Image r cs e)] -- ^ List of available formats to choose from -> FilePath -- ^ File name with extension, so format can be inferred -> B.ByteString -- ^ Encoded image - -> Image r cs e -decodeImage formats path bs = do + -> m (Image r cs e) +decodeImageM formats path bs = do let ext' = P.map toLower . takeExtension $ path case dropWhile (not . isFormat ext') formats of - [] -> throw $ DecodeError $ "File format is not supported: " ++ ext' - (f:_) -> decode f () bs + [] -> throwM $ DecodeError $ "File format is not supported: " ++ ext' + (f:_) -> decodeM f bs --- | List of image formats decodable with no colorspace conversion -imageReadFormats - :: (Source S Ix2 (Pixel cs e), ColorSpace cs e) - => [Decode (Image S cs e)] +-- | List of image formats decodable with no color space conversion +imageReadFormats :: ColorSpace cs i e => [Decode (Image S cs e)] imageReadFormats = - [ DecodeAs BMP - , DecodeAs GIF - , DecodeAs HDR - , DecodeAs JPG - , DecodeAs PNG - , DecodeAs TGA - , DecodeAs TIF - , DecodeAs PBM - , DecodeAs PGM - , DecodeAs PPM + [ DecodeAs BMP (\f -> fmap fromImageBaseModel . decodeBMP f) + , DecodeAs GIF (\f -> fmap fromImageBaseModel . decodeGIF f) + , DecodeAs HDR (\f -> fmap fromImageBaseModel . decodeHDR f) + , DecodeAs JPG (\f -> fmap fromImageBaseModel . decodeJPG f) + , DecodeAs PNG (\f -> fmap fromImageBaseModel . decodePNG f) + , DecodeAs TGA (\f -> fmap fromImageBaseModel . decodeTGA f) + , DecodeAs TIF (\f -> fmap fromImageBaseModel . decodeTIF f) + , DecodeAs PBM (\f -> fmap (fromImageBaseModel . fst) . decodeNetpbmImage f) + , DecodeAs PGM (\f -> fmap (fromImageBaseModel . fst) . decodeNetpbmImage f) + , DecodeAs PPM (\f -> fmap (fromImageBaseModel . fst) . decodeNetpbmImage f) ] --- | List of image formats decodable with no colorspace conversion +-- | List of image formats decodable with automatic colorspace conversion imageReadAutoFormats - :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) + :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => [Decode (Image r cs e)] imageReadAutoFormats = - [ DecodeAs (Auto BMP) - , DecodeAs (Auto GIF) - , DecodeAs (Auto HDR) - , DecodeAs (Auto JPG) - , DecodeAs (Auto PNG) - , DecodeAs (Auto TGA) - , DecodeAs (Auto TIF) - , DecodeAs (Auto PBM) - , DecodeAs (Auto PGM) - , DecodeAs (Auto PPM) + [ DecodeAs (Auto BMP) decodeAutoBMP + , DecodeAs (Auto GIF) decodeAutoGIF + , DecodeAs (Auto HDR) decodeAutoHDR + , DecodeAs (Auto JPG) decodeAutoJPG + , DecodeAs (Auto PNG) decodeAutoPNG + , DecodeAs (Auto TGA) decodeAutoTGA + , DecodeAs (Auto TIF) decodeAutoTIF + , DecodeAs (Auto PBM) (\f -> fmap fst . decodeAutoNetpbmImage f) + , DecodeAs (Auto PGM) (\f -> fmap fst . decodeAutoNetpbmImage f) + , DecodeAs (Auto PPM) (\f -> fmap fst . decodeAutoNetpbmImage f) ] + + diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs --- a/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs @@ -1,1023 +1,51 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} --- | --- Module : Data.Massiv.Array.IO.Image.JuicyPixels --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Data.Massiv.Array.IO.Image.JuicyPixels - ( -- * JuicyPixels formats - -- ** BMP - BMP(..) - -- ** GIF - , GIF(..) - , WriteOptionsGIF - , woGetPaletteOptionsGIF - , woSetPaletteOptionsGIF - , JP.PaletteOptions(..) - , JP.PaletteCreationMethod(..) - -- *** Animated - , WriteOptionsSequenceGIF - , woGetGifLoopingGIFs - , woGetPaletteOptionsGIFs - , woSetGifLoopingGIFs - , woSetPaletteOptionsGIFs - , JP.GifDelay - , JP.GifLooping(..) - -- ** HDR - , HDR(..) - -- ** JPG - , JPG(..) - , WriteOptionsJPG - , woGetQualityJPG - , woSetQualityJPG - -- ** PNG - , PNG(..) - -- ** TGA - , TGA(..) - -- ** TIF - , TIF(..) - -- * JuciyPixels conversion - -- ** To JuicyPixels - -- O(1) Conversion to JuicyPixels images - , toAnyCS - , toJPImageY8 - , toJPImageYA8 - , toJPImageY16 - , toJPImageYA16 - , toJPImageYF - , toJPImageRGB8 - , toJPImageRGBA8 - , toJPImageRGB16 - , toJPImageRGBA16 - , toJPImageRGBF - , toJPImageYCbCr8 - , toJPImageCMYK8 - , toJPImageCMYK16 - -- ** From JuicyPixels - , fromDynamicImage - , fromAnyDynamicImage - ) where - -import Prelude as P - -import qualified Codec.Picture as JP -import qualified Codec.Picture.ColorQuant as JP -import qualified Codec.Picture.Gif as JP -import qualified Codec.Picture.Jpg as JP -import qualified Codec.Picture.Types as TypesJP -import Control.Exception -import Control.Monad (guard, msum, unless) -import Data.Bifunctor -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL (ByteString) -import Data.Default.Class (Default(..)) -import Data.Massiv.Array as M -import Data.Massiv.Array.IO.Base -import Data.Massiv.Array.Manifest.Vector -import Data.Typeable -import qualified Data.Vector.Storable as V -import Foreign.Storable (Storable(sizeOf)) -import Graphics.ColorSpace - -#if !MIN_VERSION_massiv(0, 2, 7) -pattern Sz :: ix -> ix -pattern Sz ix = ix -type Sz ix = ix -#endif -#if !MIN_VERSION_massiv(0, 3, 0) -fromVectorM :: - (Construct S ix a, Mutable S ix a, Storable a) - => Comp - -> Sz ix - -> V.Vector a - -> Maybe (Array S ix a) -fromVectorM comp sz = pure . fromVector comp sz -#endif - --------------------------------------------------------------------------------- --- BMP Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - --- | Bitmap image with @.bmp@ extension. -data BMP = BMP deriving Show - -instance FileFormat BMP where - - ext _ = ".bmp" - - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable BMP (Image r cs e) where - encode f _ img = fromMaybeEncode f (toProxy img) $ encodeBMP img - -instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto BMP) (Image r cs e) where - encode f _ = encodeAuto f encodeBMP id toPixelRGBA toPixelRGB toPixelRGBA - - -instance ColorSpace cs e => Readable BMP (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeBitmap - - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto BMP) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeBitmap - - -encodeBMP :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => Image r cs e -> Maybe BL.ByteString -encodeBMP img = - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeBitmap $ toJPImageY8 img - , return $ JP.encodeBitmap $ toJPImageY8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeBitmap $ toJPImageRGB8 img - , return $ JP.encodeBitmap $ toJPImageRGB8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGBA) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeBitmap $ toJPImageRGBA8 img - , return $ JP.encodeBitmap $ toJPImageRGBA8 $ M.map toWord8 img - ] - ] - - --------------------------------------------------------------------------------- --- PNG Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - --- | Portable Network Graphics image with @.png@ extension. -data PNG = PNG deriving Show - -instance FileFormat PNG where - - ext _ = ".png" - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable PNG (Image r cs e) where - encode f _ img = fromMaybeEncode f (toProxy img) (encodePNG img) - - -instance (ColorSpace cs e, ToYA cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto PNG) (Image r cs e) where - encode f _ = encodeAuto f encodePNG id toPixelYA toPixelRGB toPixelRGBA - - -instance ColorSpace cs e => Readable PNG (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodePng - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto PNG) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodePng - - - -encodePNG :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => Image r cs e -> Maybe BL.ByteString -encodePNG img = - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodePng $ toJPImageY8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodePng $ toJPImageY16 img - , return $ JP.encodePng $ toJPImageY16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: YA) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodePng $ toJPImageYA8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodePng $ toJPImageYA16 img - , return $ JP.encodePng $ toJPImageYA16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodePng $ toJPImageRGB8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodePng $ toJPImageRGB16 img - , return $ JP.encodePng $ toJPImageRGB16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGBA) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodePng $ toJPImageRGBA8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodePng $ toJPImageRGBA16 img - , return $ JP.encodePng $ toJPImageRGBA16 $ M.map toWord16 img - ] - ] - - - --------------------------------------------------------------------------------- --- GIF Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - --- | Graphics Interchange Format image with @.gif@ extension. -data GIF = GIF deriving Show - -newtype WriteOptionsGIF = WriteOptionsGIF - { woGetPaletteOptionsGIF :: JP.PaletteOptions - } - -woSetPaletteOptionsGIF :: JP.PaletteOptions -> WriteOptionsGIF -> WriteOptionsGIF -woSetPaletteOptionsGIF palOpts opts = opts { woGetPaletteOptionsGIF = palOpts } - -instance Default WriteOptionsGIF where - def = WriteOptionsGIF JP.defaultPaletteOptions - -instance FileFormat GIF where - type WriteOptions GIF = WriteOptionsGIF - - ext _ = ".gif" - - -data WriteOptionsSequenceGIF = WriteOptionsSequenceGIF - { woGetPaletteOptionsGIFs :: JP.PaletteOptions - , woGetGifLoopingGIFs :: JP.GifLooping - } - -woSetPaletteOptionsGIFs :: JP.PaletteOptions -> WriteOptionsSequenceGIF -> WriteOptionsSequenceGIF -woSetPaletteOptionsGIFs palOpts opts = opts { woGetPaletteOptionsGIFs = palOpts } - - -woSetGifLoopingGIFs :: JP.GifLooping -> WriteOptionsSequenceGIF -> WriteOptionsSequenceGIF -woSetGifLoopingGIFs looping opts = opts { woGetGifLoopingGIFs = looping } - - -instance Default WriteOptionsSequenceGIF where - def = WriteOptionsSequenceGIF JP.defaultPaletteOptions JP.LoopingNever - -instance FileFormat (Sequence GIF) where - - type WriteOptions (Sequence GIF) = WriteOptionsSequenceGIF - ext _ = ext GIF - - -instance FileFormat (Sequence (Auto GIF)) where - - type WriteOptions (Sequence (Auto GIF)) = WriteOptions (Sequence GIF) - ext _ = ext GIF - - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable GIF (Image r cs e) where - encode f opt img = fromMaybeEncode f (toProxy img) $ encodeGIF opt img - -instance (ColorSpace cs e, ToY cs e, ToRGB cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto GIF) (Image r cs e) where - encode f opt = encodeAuto f (encodeGIF opt) id toPixelY toPixelRGB toPixelRGB - - -instance ColorSpace cs e => Readable GIF (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeGif - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto GIF) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeGif - - - - -instance ColorSpace cs e => - Readable (Sequence GIF) (Array B Ix1 (Image S cs e)) where - decode f _ = decodeGIFs f fromDynamicImage - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Sequence (Auto GIF)) (Array B Ix1 (Image r cs e)) where - decode f _ = decodeGIFs f fromAnyDynamicImage - - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable (Sequence GIF) (Array B Ix1 (JP.GifDelay, Image r cs e)) where - encode _ opts = - fromMaybeEncode (Sequence GIF) (Proxy :: Proxy (Image r cs e)) . encodeGIFs opts - - -instance ColorSpace cs e => - Readable (Sequence GIF) (Array B Ix1 (JP.GifDelay, Image S cs e)) where - decode f _ = decodeGIFsWithDelays f fromDynamicImage - - - --- Animated GIF Format frames reading into an Array of Images - -decodeGIFs - :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) - => f - -> (JP.DynamicImage -> Maybe (Image r cs e)) - -> B.ByteString - -> Array B Ix1 (Image r cs e) -decodeGIFs f converter bs = - either throw (fromList Seq) $ do - jpImgs <- first (toException . DecodeError) $ JP.decodeGifImages bs - first toException $ P.mapM (convertEither f showJP converter) jpImgs - -- either - -- (throw . DecodeError) - -- (fromList' Seq) - -- (P.map (fromEitherDecode f showJP decoder . Right) <$> JP.decodeGifImages bs) -{-# INLINE decodeGIFs #-} - - - -decodeGIFsWithDelays - :: ColorSpace cs e - => Sequence GIF - -> (JP.DynamicImage -> Maybe (Image S cs e)) - -> B.ByteString - -> Array B Ix1 (JP.GifDelay, Image S cs e) -decodeGIFsWithDelays f converter bs = - either throw (fromList Seq) $ do - jpImgsLs <- first (toException . DecodeError) $ JP.decodeGifImages bs - delays <- first (toException . DecodeError) $ JP.getDelaysGifImages bs - imgs <- first toException $ P.mapM (convertEither f showJP converter) jpImgsLs - return $ P.zip delays imgs -{-# INLINE decodeGIFsWithDelays #-} - - - -encodeGIF :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => WriteOptionsGIF - -> Image r cs e - -> Maybe BL.ByteString -encodeGIF (WriteOptionsGIF pal) img = - (either (throw . EncodeError) id . uncurry JP.encodeGifImageWithPalette) <$> - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - jImg <- - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ toJPImageY8 img - , return $ toJPImageY8 $ M.map toWord8 img - ] - return (jImg, JP.greyPalette) - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - palettizeRGB pal img - , palettizeRGB pal $ M.map toWord8 img - ] - ] - - -encodeGIFs :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => WriteOptionsSequenceGIF - -> Array B Ix1 (JP.GifDelay, Image r cs e) - -> Maybe BL.ByteString -encodeGIFs (WriteOptionsSequenceGIF pal looping) arr = do - palImgsLs <- - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ P.map ((, JP.greyPalette) . toJPImageY8) imgsLs - , return $ - P.map ((, JP.greyPalette) . toJPImageY8 . M.map toWord8) imgsLs - ] - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - P.mapM (palettizeRGB pal) imgsLs - , P.mapM (palettizeRGB pal . M.map toWord8) imgsLs - ] - ] - let palDelImgsLs = P.zipWith (\(i, p) d -> (p, d, i)) palImgsLs delaysLs - return $ - either (throw . EncodeError) id $ JP.encodeGifImages looping palDelImgsLs - where - delaysLs = toList delays - imgsLs = toList imgs - (delays, imgs) = M.unzip arr -{-# INLINE encodeGIFs #-} - - -palettizeRGB :: forall r e . (ColorSpace RGB e, Source r Ix2 (Pixel RGB e)) - => JP.PaletteOptions - -> Image r RGB e - -> Maybe (JP.Image JP.Pixel8, JP.Palette) -palettizeRGB pal img = - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ palettize' img - , return $ palettize' $ M.map toWord8 img - ] - where - palettize' :: forall r' . Source r' Ix2 (Pixel RGB Word8) => - Image r' RGB Word8 -> (JP.Image JP.Pixel8, JP.Palette) - palettize' = JP.palettize pal . toJPImageRGB8 - {-# INLINE palettize' #-} -{-# INLINE palettizeRGB #-} - - --------------------------------------------------------------------------------- --- HDR Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - - --- | High-dynamic-range image with @.hdr@ or @.pic@ extension. -data HDR = HDR deriving Show - -instance FileFormat HDR where - - ext _ = ".hdr" - - exts _ = [".hdr", ".pic"] - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable HDR (Image r cs e) where - encode f _ img = fromMaybeEncode f (toProxy img) $ encodeHDR img - - -instance (ColorSpace cs e, ToRGB cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto HDR) (Image r cs e) where - encode f _ = - encodeAuto f encodeHDR toPixelRGB toPixelRGB toPixelRGB toPixelRGB - - -instance ColorSpace cs e => Readable HDR (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeHDR - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto HDR) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeHDR - - - - -encodeHDR :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => Image r cs e -> Maybe BL.ByteString -encodeHDR img = do - Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Float) - return $ JP.encodeHDR $ toJPImageRGBF img - , return $ JP.encodeHDR $ toJPImageRGBF $ M.map toFloat img - ] - - - - --------------------------------------------------------------------------------- --- JPG Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - -newtype WriteOptionsJPG = WriteOptionsJPG { woGetQualityJPG :: Word8 } deriving Show - --- | Set the image quality, supplied value will be clamped to @[0, 100]@ --- range. This setting directly affects the Jpeg compression level. -woSetQualityJPG :: Word8 -> WriteOptionsJPG -> WriteOptionsJPG -woSetQualityJPG q opts = opts { woGetQualityJPG = min 100 (max 0 q) } - -instance Default WriteOptionsJPG where - def = WriteOptionsJPG 100 - --- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension. -data JPG = JPG deriving Show - -instance FileFormat JPG where - type WriteOptions JPG = WriteOptionsJPG - - ext _ = ".jpg" - - exts _ = [".jpg", ".jpeg"] - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable JPG (Image r cs e) where - encode f opts img = fromMaybeEncode f (toProxy img) $ encodeJPG opts img - - -instance (ColorSpace cs e, ToYCbCr cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto JPG) (Image r cs e) where - encode f opt = - encodeAuto f (encodeJPG opt) toPixelYCbCr toPixelYCbCr toPixelYCbCr toPixelYCbCr - - -instance ColorSpace cs e => Readable JPG (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeJpeg - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto JPG) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeJpeg - - - - -encodeJPG :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => WriteOptionsJPG -> Image r cs e -> Maybe BL.ByteString -encodeJPG (WriteOptionsJPG q) img = - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ encJPG $ toJPImageY8 img - , return $ encJPG $ toJPImageY8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ encJPG $ toJPImageRGB8 img - , return $ encJPG $ toJPImageRGB8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: CMYK) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ encJPG $ toJPImageCMYK8 img - , return $ encJPG $ toJPImageCMYK8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: YCbCr) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ encJPG $ toJPImageYCbCr8 img - , return $ encJPG $ toJPImageYCbCr8 $ M.map toWord8 img - ] - ] - where - encJPG :: forall px . JP.JpgEncodable px => JP.Image px -> BL.ByteString - encJPG = JP.encodeDirectJpegAtQualityWithMetadata q mempty - {-# INLINE encJPG #-} - - - --------------------------------------------------------------------------------- --- TGA Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - - --- | Truevision Graphics Adapter image with .tga extension. -data TGA = TGA deriving Show - -instance FileFormat TGA where - - ext _ = ".tga" - {-# INLINE ext #-} - - - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable TGA (Image r cs e) where - encode f _ img = fromMaybeEncode f (toProxy img) $ encodeTGA img - -instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto TGA) (Image r cs e) where - encode f _ = encodeAuto f encodeTGA id toPixelRGBA toPixelRGB toPixelRGBA - - -instance ColorSpace cs e => Readable TGA (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeTga - - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto TGA) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeTga - - -encodeTGA :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => Image r cs e -> Maybe BL.ByteString -encodeTGA img = - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTga $ toJPImageY8 img - , return $ JP.encodeTga $ toJPImageY8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTga $ toJPImageRGB8 img - , return $ JP.encodeTga $ toJPImageRGB8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGBA) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTga $ toJPImageRGBA8 img - , return $ JP.encodeTga $ toJPImageRGBA8 $ M.map toWord8 img - ] - ] - - --------------------------------------------------------------------------------- --- TIF Format ------------------------------------------------------------------ --------------------------------------------------------------------------------- - - --- | Tagged Image File Format image with @.tif@ or @.tiff@ extension. -data TIF = TIF deriving Show - -instance FileFormat TIF where - - ext _ = ".tif" - {-# INLINE ext #-} - - exts _ = [".tif", ".tiff"] - {-# INLINE exts #-} - - -instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) => - Writable TIF (Image r cs e) where - encode f _ img = fromMaybeEncode f (toProxy img) $ encodeTIF img - - -instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) => - Writable (Auto TIF) (Image r cs e) where - encode f _ = encodeAuto f encodeTIF id id id toPixelRGBA - - -instance ColorSpace cs e => Readable TIF (Image S cs e) where - decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeTiff - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto TIF) (Image r cs e) where - decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeTiff - - - - -encodeTIF :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e)) - => Image r cs e -> Maybe BL.ByteString -encodeTIF img = - msum - [ do Refl <- eqT :: Maybe (cs :~: Y) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTiff $ toJPImageY8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodeTiff $ toJPImageY16 img -#if MIN_VERSION_JuicyPixels(3,3,0) - , do Refl <- eqT :: Maybe (e :~: Word32) - return $ JP.encodeTiff $ toJPImageY32 img - , do Refl <- eqT :: Maybe (e :~: Float) - return $ JP.encodeTiff $ toJPImageYF img -#endif - , return $ JP.encodeTiff $ toJPImageY16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: YA) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTiff $ toJPImageYA8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodeTiff $ toJPImageYA16 img - , return $ JP.encodeTiff $ toJPImageYA16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGB) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTiff $ toJPImageRGB8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodeTiff $ toJPImageRGB16 img - , return $ JP.encodeTiff $ toJPImageRGB16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: RGBA) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTiff $ toJPImageRGBA8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodeTiff $ toJPImageRGBA16 img - , return $ JP.encodeTiff $ toJPImageRGBA16 $ M.map toWord16 img - ] - , do Refl <- eqT :: Maybe (cs :~: YCbCr) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTiff $ toJPImageYCbCr8 img - , return $ JP.encodeTiff $ toJPImageYCbCr8 $ M.map toWord8 img - ] - , do Refl <- eqT :: Maybe (cs :~: CMYK) - msum - [ do Refl <- eqT :: Maybe (e :~: Word8) - return $ JP.encodeTiff $ toJPImageCMYK8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ JP.encodeTiff $ toJPImageCMYK16 img - -- for CMYK default is 8bit, instead of 16bit, since many viewers and editors - -- don't support it. - , return $ JP.encodeTiff $ toJPImageCMYK8 $ M.map toWord8 img - ] - ] - - - - --------------------------------------------------------------------------------- --- Common encoding/decoding functions ------------------------------------------ --------------------------------------------------------------------------------- - - -encodeAuto - :: forall f r cs e a csY eY csYA eYA csC eC csCA eCA. - ( ColorSpace cs e - , ColorSpace csC eC - , ColorSpace csCA eCA - , ColorSpace csY eY - , ColorSpace csYA eYA - , Source r Ix2 (Pixel cs e) - , FileFormat f - ) - => f - -> (forall r' cs' e'. (Source r' Ix2 (Pixel cs' e'), ColorSpace cs' e') => - Image r' cs' e' -> Maybe a) - -> (Pixel cs e -> Pixel csY eY) -- ^ To preferred from Luma - -> (Pixel cs e -> Pixel csYA eYA) -- ^ To preferred from Luma with Alpha - -> (Pixel cs e -> Pixel csC eC) -- ^ To preferred from any color - -> (Pixel cs e -> Pixel csCA eCA) -- ^ To preferred from any color with Alpha - -> Image r cs e - -> a -encodeAuto f enc toLuma toLumaA toColor toColorA img = - fromMaybeEncode f (toProxy img) $ msum - [ enc img - , do Refl <- eqT :: Maybe (cs :~: Y) - enc $ M.map toLuma img - , do Refl <- eqT :: Maybe (cs :~: YA) - enc $ M.map toLumaA img - , do Refl <- eqT :: Maybe (cs :~: RGB) - enc $ M.map toColor img - , do Refl <- eqT :: Maybe (cs :~: RGBA) - enc $ M.map toColorA img - , do Refl <- eqT :: Maybe (cs :~: HSI) - enc $ M.map toColor img - , do Refl <- eqT :: Maybe (cs :~: HSIA) - enc $ M.map toColorA img - , do Refl <- eqT :: Maybe (cs :~: YCbCr) - enc $ M.map toColor img - , do Refl <- eqT :: Maybe (cs :~: YCbCrA) - enc $ M.map toColorA img - , do Refl <- eqT :: Maybe (cs :~: CMYK) - enc $ M.map toColor img - , do Refl <- eqT :: Maybe (cs :~: CMYKA) - enc $ M.map toColorA img - , do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit) - enc $ M.map fromPixelBinary img - ] - - - - -elevate - :: forall cs e' e. - ( ColorSpace cs e' - , ColorSpace cs e - , Source D Ix2 (Pixel cs e') - ) - => Image D cs e' -> Maybe (Image D cs e) -elevate img = - msum - [ fmap (\Refl -> img) (eqT :: Maybe (e :~: e')) - , do Refl <- eqT :: Maybe (e :~: Word8) - return $ M.map toWord8 img - , do Refl <- eqT :: Maybe (e :~: Word16) - return $ M.map toWord16 img - , do Refl <- eqT :: Maybe (e :~: Word32) - return $ M.map toWord32 img - , do Refl <- eqT :: Maybe (e :~: Word64) - return $ M.map toWord64 img - , do Refl <- eqT :: Maybe (e :~: Double) - return $ M.map toDouble img - ] - -fromDynamicImage :: forall cs e . ColorSpace cs e - => JP.DynamicImage -> Maybe (Image S cs e) -fromDynamicImage jpDynImg = - case jpDynImg of - JP.ImageY8 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8) - fromJPImageUnsafe jimg - JP.ImageY16 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16) - fromJPImageUnsafe jimg -#if MIN_VERSION_JuicyPixels(3,3,0) - JP.ImageY32 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word32) - fromJPImageUnsafe jimg -#endif - JP.ImageYF jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Float) - fromJPImageUnsafe jimg - JP.ImageYA8 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YA Word8) - fromJPImageUnsafe jimg - JP.ImageYA16 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YA Word16) - fromJPImageUnsafe jimg - JP.ImageRGB8 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8) - fromJPImageUnsafe jimg - JP.ImageRGB16 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16) - fromJPImageUnsafe jimg - JP.ImageRGBF jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Float) - fromJPImageUnsafe jimg - JP.ImageRGBA8 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGBA Word8) - fromJPImageUnsafe jimg - JP.ImageRGBA16 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGBA Word16) - fromJPImageUnsafe jimg - JP.ImageYCbCr8 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YCbCr Word8) - fromJPImageUnsafe jimg - JP.ImageCMYK8 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CMYK Word8) - fromJPImageUnsafe jimg - JP.ImageCMYK16 jimg -> do - Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CMYK Word16) - fromJPImageUnsafe jimg - - - -fromAnyDynamicImage :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - JP.DynamicImage -> Maybe (Image r cs e) -fromAnyDynamicImage jpDynImg = - case jpDynImg of - JP.ImageY8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word8)) >>= toAnyCS - JP.ImageY16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word16)) >>= toAnyCS -#if MIN_VERSION_JuicyPixels(3,3,0) - JP.ImageY32 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word32)) >>= toAnyCS -#endif - JP.ImageYF jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Float)) >>= toAnyCS - JP.ImageYA8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YA Word8)) >>= toAnyCS - JP.ImageYA16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YA Word16)) >>= toAnyCS - JP.ImageRGB8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Word8)) >>= toAnyCS - JP.ImageRGB16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Word16)) >>= toAnyCS - JP.ImageRGBF jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Float)) >>= toAnyCS - JP.ImageRGBA8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGBA Word8)) >>= toAnyCS - JP.ImageRGBA16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGBA Word16)) >>= toAnyCS - JP.ImageYCbCr8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YCbCr Word8)) >>= toAnyCS - JP.ImageCMYK8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S CMYK Word8)) >>= toAnyCS - JP.ImageCMYK16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S CMYK Word16)) >>= toAnyCS - - -toAnyCS - :: forall r' cs' e' r cs e. - ( Source r' Ix2 (Pixel cs' e') - , Mutable r Ix2 (Pixel cs e) - , ColorSpace cs e - , ToYA cs' e' - , ToRGBA cs' e' - , ToHSIA cs' e' - , ToCMYKA cs' e' - , ToYCbCrA cs' e' - ) - => Image r' cs' e' -> Maybe (Image r cs e) -toAnyCS img = - msum - [ (\Refl -> computeSource img) <$> - (eqT :: Maybe (Pixel cs' e' :~: Pixel cs e)) - , do Refl <- eqT :: Maybe (cs :~: Y) - compute <$> elevate (M.map toPixelY img) - , do Refl <- eqT :: Maybe (cs :~: YA) - compute <$> elevate (M.map toPixelYA img) - , do Refl <- eqT :: Maybe (cs :~: RGB) - compute <$> elevate (M.map toPixelRGB img) - , do Refl <- eqT :: Maybe (cs :~: RGBA) - compute <$> elevate (M.map toPixelRGBA img) - , do Refl <- eqT :: Maybe (cs :~: HSI) - compute <$> elevate (M.map toPixelHSI img) - , do Refl <- eqT :: Maybe (cs :~: HSIA) - compute <$> elevate (M.map toPixelHSIA img) - , do Refl <- eqT :: Maybe (cs :~: CMYK) - compute <$> elevate (M.map toPixelCMYK img) - , do Refl <- eqT :: Maybe (cs :~: CMYKA) - compute <$> elevate (M.map toPixelCMYKA img) - , do Refl <- eqT :: Maybe (cs :~: YCbCr) - compute <$> elevate (M.map toPixelYCbCr img) - , do Refl <- eqT :: Maybe (cs :~: YCbCrA) - compute <$> elevate (M.map toPixelYCbCrA img) - , do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit) - return $ compute $ M.map toPixelBinary img - ] - - - -showJP :: JP.DynamicImage -> String -showJP (JP.ImageY8 _) = "Image S Y Word8" -showJP (JP.ImageY16 _) = "Image S Y Word16" -#if MIN_VERSION_JuicyPixels(3,3,0) -showJP (JP.ImageY32 _) = "Image S Y Word32" -#endif -showJP (JP.ImageYF _) = "Image S Y Float" -showJP (JP.ImageYA8 _) = "Image S YA Word8" -showJP (JP.ImageYA16 _) = "Image S YA Word16" -showJP (JP.ImageRGB8 _) = "Image S RGB Word8" -showJP (JP.ImageRGB16 _) = "Image S RGB Word16" -showJP (JP.ImageRGBF _) = "Image S RGB Float" -showJP (JP.ImageRGBA8 _) = "Image S RGBA Word8" -showJP (JP.ImageRGBA16 _) = "Image S RGBA Word16" -showJP (JP.ImageYCbCr8 _) = "Image S YCbCr Word8" -showJP (JP.ImageCMYK8 _) = "Image S CMYK Word8" -showJP (JP.ImageCMYK16 _) = "Image S CMYK Word16" - - --- Encoding - -toJPImageUnsafe - :: forall r cs a . (JP.Pixel a, Source r Ix2 (Pixel cs (JP.PixelBaseComponent a)), - ColorSpace cs (JP.PixelBaseComponent a)) - => Image r cs (JP.PixelBaseComponent a) - -> JP.Image a -toJPImageUnsafe img = JP.Image n m $ V.unsafeCast $ toVector arrS where - !arrS = computeSource img :: Image S cs (JP.PixelBaseComponent a) - Sz (m :. n) = size img -{-# INLINE toJPImageUnsafe #-} - -toJPImageY8 :: Source r Ix2 (Pixel Y Word8) => Image r Y Word8 -> JP.Image TypesJP.Pixel8 -toJPImageY8 = toJPImageUnsafe -{-# INLINE toJPImageY8 #-} - -toJPImageY16 :: Source r Ix2 (Pixel Y Word16) => Image r Y Word16 -> JP.Image TypesJP.Pixel16 -toJPImageY16 = toJPImageUnsafe -{-# INLINE toJPImageY16 #-} - -#if MIN_VERSION_JuicyPixels(3,3,0) -toJPImageY32 :: Source r Ix2 (Pixel Y Word32) => Image r Y Word32 -> JP.Image TypesJP.Pixel32 -toJPImageY32 = toJPImageUnsafe -{-# INLINE toJPImageY32 #-} -#endif - -toJPImageYA8 :: Source r Ix2 (Pixel YA Word8) => Image r YA Word8 -> JP.Image JP.PixelYA8 -toJPImageYA8 = toJPImageUnsafe -{-# INLINE toJPImageYA8 #-} - -toJPImageYA16 :: Source r Ix2 (Pixel YA Word16) => Image r YA Word16 -> JP.Image JP.PixelYA16 -toJPImageYA16 = toJPImageUnsafe -{-# INLINE toJPImageYA16 #-} - -toJPImageYF :: Source r Ix2 (Pixel Y Float) => Image r Y Float -> JP.Image JP.PixelF -toJPImageYF = toJPImageUnsafe -{-# INLINE toJPImageYF #-} - -toJPImageRGB8 :: Source r Ix2 (Pixel RGB Word8) => Image r RGB Word8 -> JP.Image JP.PixelRGB8 -toJPImageRGB8 = toJPImageUnsafe -{-# INLINE toJPImageRGB8 #-} - -toJPImageRGBA8 :: Source r Ix2 (Pixel RGBA Word8) => Image r RGBA Word8 -> JP.Image JP.PixelRGBA8 -toJPImageRGBA8 = toJPImageUnsafe -{-# INLINE toJPImageRGBA8 #-} - -toJPImageRGB16 :: Source r Ix2 (Pixel RGB Word16) => Image r RGB Word16 -> JP.Image JP.PixelRGB16 -toJPImageRGB16 = toJPImageUnsafe -{-# INLINE toJPImageRGB16 #-} - -toJPImageRGBA16 :: Source r Ix2 (Pixel RGBA Word16) => Image r RGBA Word16 -> JP.Image JP.PixelRGBA16 -toJPImageRGBA16 = toJPImageUnsafe -{-# INLINE toJPImageRGBA16 #-} - -toJPImageRGBF :: Source r Ix2 (Pixel RGB Float) => Image r RGB Float -> JP.Image JP.PixelRGBF -toJPImageRGBF = toJPImageUnsafe -{-# INLINE toJPImageRGBF #-} - -toJPImageYCbCr8 :: Source r Ix2 (Pixel YCbCr Word8) => Image r YCbCr Word8 -> JP.Image JP.PixelYCbCr8 -toJPImageYCbCr8 = toJPImageUnsafe -{-# INLINE toJPImageYCbCr8 #-} - -toJPImageCMYK8 :: Source r Ix2 (Pixel CMYK Word8) => Image r CMYK Word8 -> JP.Image JP.PixelCMYK8 -toJPImageCMYK8 = toJPImageUnsafe -{-# INLINE toJPImageCMYK8 #-} - -toJPImageCMYK16 :: Source r Ix2 (Pixel CMYK Word16) => Image r CMYK Word16 -> JP.Image JP.PixelCMYK16 -toJPImageCMYK16 = toJPImageUnsafe -{-# INLINE toJPImageCMYK16 #-} - - - - --- General decoding and helper functions - -fromJPImageUnsafe :: forall jpx cs e . (Storable (Pixel cs e), Storable e, JP.Pixel jpx) => - JP.Image jpx -> Maybe (Image S cs e) -fromJPImageUnsafe (JP.Image n m !v) = do - let numberOfComponentsFromSize = sizeOf (undefined :: Pixel cs e) `div` sizeOf (undefined :: e) - numComponentsPerPixel = JP.componentCount (undefined :: jpx) - unless (numComponentsPerPixel == numberOfComponentsFromSize) $ - error $ - concat - [ "Mismatched sizes beteen JuicyPixels: " - , show numComponentsPerPixel - , " and massiv: " - , show numberOfComponentsFromSize - ] - guard (n * m * numComponentsPerPixel == V.length v) - fromVectorM Par (Sz (m :. n)) $ V.unsafeCast v -{-# INLINE fromJPImageUnsafe #-} - +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels +-- Copyright : (c) Alexey Kuleshevich 2018-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels + ( -- * JuicyPixels formats + -- ** BMP + module BMP + -- ** GIF + , module GIF + -- ** HDR + , module HDR + -- ** JPG + , module JPG + -- ** PNG + , module PNG + -- ** TGA + , module TGA + -- ** TIF + , module TIF + -- ** JuicyPixels conversion + , toJPImageY8 + , toJPImageY16 + , toJPImageY32 + , toJPImageYA8 + , toJPImageYA16 + , toJPImageYF + , toJPImageRGB8 + , toJPImageRGB16 + , toJPImageRGBA8 + , toJPImageRGBA16 + , toJPImageRGBF + , toJPImageYCbCr8 + , toJPImageCMYK8 + , toJPImageCMYK16 + , fromDynamicImage + , fromDynamicImageAuto + ) where + +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.BMP as BMP +import Data.Massiv.Array.IO.Image.JuicyPixels.GIF as GIF +import Data.Massiv.Array.IO.Image.JuicyPixels.HDR as HDR +import Data.Massiv.Array.IO.Image.JuicyPixels.JPG as JPG +import Data.Massiv.Array.IO.Image.JuicyPixels.PNG as PNG +import Data.Massiv.Array.IO.Image.JuicyPixels.TGA as TGA +import Data.Massiv.Array.IO.Image.JuicyPixels.TIF as TIF diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/BMP.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/BMP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/BMP.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.BMP +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.BMP + ( BMP(..) + , BitmapOptions(..) + , decodeBMP + , decodeWithMetadataBMP + , decodeAutoBMP + , decodeAutoWithMetadataBMP + , encodeBMP + , encodeAutoBMP + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.Bitmap as JP +import qualified Codec.Picture.Metadata as JP +import Control.Monad (msum) +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Maybe (fromMaybe) +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P + +-------------------------------------------------------------------------------- +-- BMP Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + +newtype BitmapOptions = BitmapOptions + { bitmapMetadata :: JP.Metadatas + } deriving (Show) + +instance Default BitmapOptions where + def = BitmapOptions mempty + +-- | Bitmap image with @.bmp@ extension. +data BMP = BMP deriving Show + +instance FileFormat BMP where + type WriteOptions BMP = BitmapOptions + type Metadata BMP = JP.Metadatas + + ext _ = ".bmp" + +instance Writable BMP (Image S CM.Y Word8) where + encodeM BMP BitmapOptions {bitmapMetadata} = + pure . JP.encodeBitmapWithMetadata bitmapMetadata . toJPImageY8 + +instance Writable BMP (Image S CM.RGB Word8) where + encodeM BMP BitmapOptions {bitmapMetadata} = + pure . JP.encodeBitmapWithMetadata bitmapMetadata . toJPImageRGB8 + +instance Writable BMP (Image S (Alpha CM.RGB) Word8) where + encodeM BMP BitmapOptions {bitmapMetadata} = + pure . JP.encodeBitmapWithMetadata bitmapMetadata . toJPImageRGBA8 + + +instance Writable BMP (Image S (Y D65) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable BMP (Image S SRGB Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable BMP (Image S (Alpha SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto BMP) (Image r cs e) where + encodeM f opts = pure . encodeAutoBMP f opts + + +instance Readable BMP (Image S CM.Y Word8) where + decodeWithMetadataM = decodeWithMetadataBMP + +instance Readable BMP (Image S CM.RGB Word8) where + decodeWithMetadataM = decodeWithMetadataBMP + +instance Readable BMP (Image S (Alpha CM.RGB) Word8) where + decodeWithMetadataM = decodeWithMetadataBMP + + +instance Readable BMP (Image S (Y D65) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable BMP (Image S SRGB Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable BMP (Image S (Alpha SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +-- | Decode a Bitmap Image +decodeBMP :: (ColorModel cs e, MonadThrow m) => BMP -> B.ByteString -> m (Image S cs e) +decodeBMP f bs = convertWith f (JP.decodeBitmap bs) + +-- | Decode a Bitmap Image +decodeWithMetadataBMP :: + (ColorModel cs e, MonadThrow m) => BMP -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataBMP f bs = convertWithMetadata f (JP.decodeBitmapWithMetadata bs) + + +-- | Decode a Bitmap Image +decodeAutoBMP :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto BMP + -> B.ByteString + -> m (Image r cs e) +decodeAutoBMP f bs = convertAutoWith f (JP.decodeBitmap bs) + +-- | Decode a Bitmap Image +decodeAutoWithMetadataBMP :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto BMP + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataBMP f bs = convertAutoWithMetadata f (JP.decodeBitmapWithMetadata bs) + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto BMP) (Image r cs e) where + decodeM = decodeAutoBMP + decodeWithMetadataM = decodeAutoWithMetadataBMP + +encodeBMP :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => BMP + -> BitmapOptions + -> Image r cs e + -> m BL.ByteString +encodeBMP f BitmapOptions {bitmapMetadata} img = + fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ do + Refl <- eqT :: Maybe (e :~: Word8) + msum + [ do Refl <- eqT :: Maybe (cs :~: CM.Y) + pure $ JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageY8 img + , do Refl <- eqT :: Maybe (cs :~: CM.RGB) + pure $ JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageRGB8 img + , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB) + pure $ JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageRGBA8 img + ] + + + +encodeAutoBMP :: + forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (Pixel cs e)) + => Auto BMP + -> BitmapOptions + -> Image r cs e + -> BL.ByteString +encodeAutoBMP _ BitmapOptions {bitmapMetadata} img = + fromMaybe (toBitmap toJPImageRGB8 toSRGB8 img) $ + msum + [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Bit) + pure $ toBitmap toJPImageY8 (toPixel8 . toPixelBaseModel) img + , pure $ toBitmap toJPImageY8 (toPixel8 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs)) + pure $ toBitmap toJPImageRGBA8 toSRGBA8 img + ] + where + toBitmap :: + (JP.BmpEncodable px, Source r ix a) + => (Array D ix b -> JP.Image px) + -> (a -> b) + -> Array r ix a + -> BL.ByteString + toBitmap toJP adjustPixel = + JP.encodeBitmapWithMetadata bitmapMetadata . toJP . A.map adjustPixel diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/Base.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/Base.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.Base +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.Base + ( showJP + , convertWith + , convertWithMetadata + , convertAutoWith + , convertAutoWithMetadata + , convertSequenceWith + , convertAutoSequenceWith + , toJPImageY8 + , toJPImageY16 + , toJPImageY32 + , toJPImageYA8 + , toJPImageYA16 + , toJPImageYF + , toJPImageRGB8 + , toJPImageRGB16 + , toJPImageRGBA8 + , toJPImageRGBA16 + , toJPImageRGBF + , toJPImageYCbCr8 + , toJPImageCMYK8 + , toJPImageCMYK16 + , fromDynamicImage + , fromDynamicImageAuto + -- * Conversion to sRGB + , toYCbCr8 + , toCMYK8 + , toCMYK16 + , toSRGB8 + , toSRGB16 + , toSRGBA8 + , toSRGBA16 + ) where + +import Prelude as P +import qualified Codec.Picture as JP +import qualified Codec.Picture.Types as JP +import Control.Monad (guard, unless) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.Manifest.Vector +import Data.Typeable +import qualified Data.Vector.Storable as V +import Foreign.Storable (Storable(sizeOf)) +import Graphics.Pixel.ColorSpace +import qualified Graphics.Pixel as CM + +-------------------------------------------------------------------------------- +-- Common JuciyPixels encoding/decoding functions ------------------------------ +-------------------------------------------------------------------------------- + +convertWith :: + (MonadThrow m, ColorModel cs e, FileFormat f) + => f + -> Either String JP.DynamicImage + -> m (Image S cs e) +convertWith f = either (throwM . DecodeError) (fromMaybeDecode f showJP fromDynamicImage) + + +convertWithMetadata :: + (MonadThrow m, ColorModel cs e, FileFormat f) + => f + -> Either String (JP.DynamicImage, Metadata f) + -> m (Image S cs e, Metadata f) +convertWithMetadata f decoded = + case decoded of + Left err -> throwM $ DecodeError err + Right (jp, meta) -> do + i <- fromMaybeDecode f showJP fromDynamicImage jp + pure (i, meta) + +convertAutoWithMetadata :: + (MonadThrow m, FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) + => Auto f + -> Either String (JP.DynamicImage, Metadata f) + -> m (Image r cs e, Metadata f) +convertAutoWithMetadata f decoded = + case decoded of + Left err -> throwM $ DecodeError err + Right (jp, meta) -> do + i <- fromMaybeDecode f showJP fromDynamicImageAuto jp + pure (i, meta) + +convertAutoWith :: + (MonadThrow m, FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) + => Auto f + -> Either String JP.DynamicImage + -> m (Image r cs e) +convertAutoWith f = either (throwM . DecodeError) (fromMaybeDecode f showJP fromDynamicImageAuto) + + +convertSequenceWith :: + (MonadThrow m, ColorModel cs e, FileFormat (Sequence f)) + => Sequence f + -> Either String [JP.DynamicImage] + -> m [Image S cs e] +convertSequenceWith f ejpImgs = do + jpImgs <- decodeError ejpImgs + P.traverse (fromMaybeDecode f showJP fromDynamicImage) jpImgs + + +convertAutoSequenceWith :: + (MonadThrow m, FileFormat (Sequence f), Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) + => Auto (Sequence f) + -> Either String [JP.DynamicImage] + -> m [Image r cs e] +convertAutoSequenceWith f ejpImgs = do + jpImgs <- decodeError ejpImgs + P.traverse (fromMaybeDecode f showJP fromDynamicImageAuto) jpImgs + + +fromDynamicImage :: + forall cs e. ColorModel cs e + => JP.DynamicImage + -> Maybe (Image S cs e) +fromDynamicImage jpDynImg = + case jpDynImg of + JP.ImageY8 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word8) + fromJPImageUnsafe jimg + JP.ImageY16 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word16) + fromJPImageUnsafe jimg + JP.ImageY32 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word32) + fromJPImageUnsafe jimg + JP.ImageYF jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Float) + fromJPImageUnsafe jimg + JP.ImageYA8 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.Y) Word8) + fromJPImageUnsafe jimg + JP.ImageYA16 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.Y) Word16) + fromJPImageUnsafe jimg + JP.ImageRGB8 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8) + fromJPImageUnsafe jimg + JP.ImageRGB16 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word16) + fromJPImageUnsafe jimg + JP.ImageRGBF jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Float) + fromJPImageUnsafe jimg + JP.ImageRGBA8 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word8) + fromJPImageUnsafe jimg + JP.ImageRGBA16 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word16) + fromJPImageUnsafe jimg + JP.ImageYCbCr8 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.YCbCr Word8) + fromJPImageUnsafe jimg + JP.ImageCMYK8 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word8) + fromJPImageUnsafe jimg + JP.ImageCMYK16 jimg -> do + Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word16) + fromJPImageUnsafe jimg + + +fromDynamicImageAuto :: + forall r cs i e. (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) + => JP.DynamicImage + -> Maybe (Image r cs e) +fromDynamicImageAuto jpDynImg = + case jpDynImg of + JP.ImageY8 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Word8)) + JP.ImageY16 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Word16)) + JP.ImageY32 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Word32)) + JP.ImageYF jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Float)) + JP.ImageYA8 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha (Y D65)) Word8)) + JP.ImageYA16 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha (Y D65)) Word16)) + JP.ImageRGB8 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S SRGB Word8)) + JP.ImageRGB16 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S SRGB Word16)) + JP.ImageRGBF jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S SRGB Float)) + JP.ImageRGBA8 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha SRGB) Word8)) + JP.ImageRGBA16 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha SRGB) Word16)) + JP.ImageYCbCr8 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (YCbCr SRGB) Word8)) + JP.ImageCMYK8 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (CMYK SRGB) Word8)) + JP.ImageCMYK16 jimg -> + compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (CMYK SRGB) Word16)) + + + +showJP :: JP.DynamicImage -> String +showJP (JP.ImageY8 _) = "Image S Y Word8" +showJP (JP.ImageY16 _) = "Image S Y Word16" +showJP (JP.ImageY32 _) = "Image S Y Word32" +showJP (JP.ImageYF _) = "Image S Y Float" +showJP (JP.ImageYA8 _) = "Image S YA Word8" +showJP (JP.ImageYA16 _) = "Image S YA Word16" +showJP (JP.ImageRGB8 _) = "Image S RGB Word8" +showJP (JP.ImageRGB16 _) = "Image S RGB Word16" +showJP (JP.ImageRGBF _) = "Image S RGB Float" +showJP (JP.ImageRGBA8 _) = "Image S RGBA Word8" +showJP (JP.ImageRGBA16 _) = "Image S RGBA Word16" +showJP (JP.ImageYCbCr8 _) = "Image S YCbCr Word8" +showJP (JP.ImageCMYK8 _) = "Image S CMYK Word8" +showJP (JP.ImageCMYK16 _) = "Image S CMYK Word16" + + +-- Encoding + +toJPImageUnsafe + :: forall r cs a . (JP.Pixel a, Source r Ix2 (Pixel cs (JP.PixelBaseComponent a)), + ColorModel cs (JP.PixelBaseComponent a)) + => Image r cs (JP.PixelBaseComponent a) + -> JP.Image a +toJPImageUnsafe img = JP.Image n m $ V.unsafeCast $ toStorableVector arrS + where + !arrS = computeSource img :: Image S cs (JP.PixelBaseComponent a) + Sz (m :. n) = size img +{-# INLINE toJPImageUnsafe #-} + +toJPImageY8 :: Source r Ix2 (Pixel CM.Y Word8) => Image r CM.Y Word8 -> JP.Image JP.Pixel8 +toJPImageY8 = toJPImageUnsafe +{-# INLINE toJPImageY8 #-} + +toJPImageY16 :: Source r Ix2 (Pixel CM.Y Word16) => Image r CM.Y Word16 -> JP.Image JP.Pixel16 +toJPImageY16 = toJPImageUnsafe +{-# INLINE toJPImageY16 #-} + +toJPImageY32 :: Source r Ix2 (Pixel CM.Y Word32) => Image r CM.Y Word32 -> JP.Image JP.Pixel32 +toJPImageY32 = toJPImageUnsafe +{-# INLINE toJPImageY32 #-} + +toJPImageYF :: Source r Ix2 (Pixel CM.Y Float) => Image r CM.Y Float -> JP.Image JP.PixelF +toJPImageYF = toJPImageUnsafe +{-# INLINE toJPImageYF #-} + +toJPImageYA8 :: + Source r Ix2 (Pixel (Alpha CM.Y) Word8) => Image r (Alpha CM.Y) Word8 -> JP.Image JP.PixelYA8 +toJPImageYA8 = toJPImageUnsafe +{-# INLINE toJPImageYA8 #-} + +toJPImageYA16 :: + Source r Ix2 (Pixel (Alpha CM.Y) Word16) + => Image r (Alpha CM.Y) Word16 + -> JP.Image JP.PixelYA16 +toJPImageYA16 = toJPImageUnsafe +{-# INLINE toJPImageYA16 #-} + +toJPImageRGB8 :: Source r Ix2 (Pixel CM.RGB Word8) => Image r CM.RGB Word8 -> JP.Image JP.PixelRGB8 +toJPImageRGB8 = toJPImageUnsafe +{-# INLINE toJPImageRGB8 #-} + +toJPImageRGB16 :: + Source r Ix2 (Pixel CM.RGB Word16) => Image r CM.RGB Word16 -> JP.Image JP.PixelRGB16 +toJPImageRGB16 = toJPImageUnsafe +{-# INLINE toJPImageRGB16 #-} + +toJPImageRGBF :: Source r Ix2 (Pixel CM.RGB Float) => Image r CM.RGB Float -> JP.Image JP.PixelRGBF +toJPImageRGBF = toJPImageUnsafe +{-# INLINE toJPImageRGBF #-} + +toJPImageRGBA8 :: + Source r Ix2 (Pixel (Alpha CM.RGB) Word8) + => Image r (Alpha CM.RGB) Word8 + -> JP.Image JP.PixelRGBA8 +toJPImageRGBA8 = toJPImageUnsafe +{-# INLINE toJPImageRGBA8 #-} + +toJPImageRGBA16 :: + Source r Ix2 (Pixel (Alpha CM.RGB) Word16) + => Image r (Alpha CM.RGB) Word16 + -> JP.Image JP.PixelRGBA16 +toJPImageRGBA16 = toJPImageUnsafe +{-# INLINE toJPImageRGBA16 #-} + + +toJPImageYCbCr8 :: + Source r Ix2 (Pixel CM.YCbCr Word8) => Image r CM.YCbCr Word8 -> JP.Image JP.PixelYCbCr8 +toJPImageYCbCr8 = toJPImageUnsafe +{-# INLINE toJPImageYCbCr8 #-} + +toJPImageCMYK8 :: + Source r Ix2 (Pixel CM.CMYK Word8) => Image r CM.CMYK Word8 -> JP.Image JP.PixelCMYK8 +toJPImageCMYK8 = toJPImageUnsafe +{-# INLINE toJPImageCMYK8 #-} + +toJPImageCMYK16 :: + Source r Ix2 (Pixel CM.CMYK Word16) => Image r CM.CMYK Word16 -> JP.Image JP.PixelCMYK16 +toJPImageCMYK16 = toJPImageUnsafe +{-# INLINE toJPImageCMYK16 #-} + + +-- General decoding and helper functions + +fromJPImageUnsafe :: forall jpx cs e . (Storable (Pixel cs e), Storable e, JP.Pixel jpx) => + JP.Image jpx -> Maybe (Image S cs e) +fromJPImageUnsafe (JP.Image n m !v) = do + let numberOfComponentsFromSize = sizeOf (undefined :: Pixel cs e) `div` sizeOf (undefined :: e) + numComponentsPerPixel = JP.componentCount (undefined :: jpx) + unless (numComponentsPerPixel == numberOfComponentsFromSize) $ + error $ + concat + [ "Mismatched sizes beteen JuicyPixels: " + , show numComponentsPerPixel + , " and massiv: " + , show numberOfComponentsFromSize + ] + guard (n * m * numComponentsPerPixel == V.length v) + fromVectorM Par (Sz (m :. n)) $ V.unsafeCast v +{-# INLINE fromJPImageUnsafe #-} + +-- Conversion to sRGB color space based color models + +toYCbCr8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.YCbCr Word8 +toYCbCr8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (YCbCr SRGB) Word8) + +toCMYK8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.CMYK Word8 +toCMYK8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (CMYK SRGB) Word8) + +toCMYK16 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.CMYK Word16 +toCMYK16 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (CMYK SRGB) Word16) + +toSRGB8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.RGB Word8 +toSRGB8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel SRGB Word8) + +toSRGB16 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.RGB Word16 +toSRGB16 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel SRGB Word16) + +toSRGBA8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel (Alpha CM.RGB) Word8 +toSRGBA8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (Alpha SRGB) Word8) + +toSRGBA16 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel (Alpha CM.RGB) Word16 +toSRGBA16 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (Alpha SRGB) Word16) diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/GIF.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/GIF.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/GIF.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.GIF +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.GIF + ( GIF(..) + , GifOptions(..) + , SequenceGifOptions(..) + , JP.GifDelay + , JP.GifLooping(..) + , JP.PaletteOptions(..) + , JP.PaletteCreationMethod(..) + + -- , JP.GifDisposalMethod(..) + -- , + , decodeGIF + , decodeWithMetadataGIF + , decodeAutoGIF + , decodeAutoWithMetadataGIF + , encodeGIF + , encodeAutoGIF + -- Sequence + , decodeSequenceGIF + , decodeSequenceWithMetadataGIF + , decodeAutoSequenceGIF + , decodeAutoSequenceWithMetadataGIF + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.ColorQuant as JP +import qualified Codec.Picture.Gif as JP +import qualified Codec.Picture.Metadata as JP +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P +import Data.List.NonEmpty as NE + +-------------------------------------------------------------------------------- +-- GIF Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + + +newtype GifOptions = GifOptions + { gifPaletteOptions :: JP.PaletteOptions + } + +instance Default GifOptions where + def = GifOptions JP.defaultPaletteOptions + + +-- | Graphics Interchange Format image with @.gif@ extension. +data GIF = GIF deriving Show + +instance FileFormat GIF where + type WriteOptions GIF = GifOptions + type Metadata GIF = JP.Metadatas + ext _ = ".gif" + +instance Writable GIF (Image S CM.Y Word8) where + encodeM GIF _ = pure . JP.encodeGifImage . toJPImageY8 + +instance Writable GIF (Image S CM.RGB Word8) where + encodeM GIF = encodePalettizedRGB + +instance Writable GIF (Image S (Y D65) Word8) where + encodeM GIF opts = encodeM GIF opts . toImageBaseModel + +instance Writable GIF (Image S SRGB Word8) where + encodeM GIF opts = encodeM GIF opts . toImageBaseModel + +encodePalettizedRGB :: + (MonadThrow m, Source r Ix2 (Pixel CM.RGB Word8)) + => GifOptions + -> Image r CM.RGB Word8 + -> m BL.ByteString +encodePalettizedRGB GifOptions {gifPaletteOptions} = + encodeError . + uncurry JP.encodeGifImageWithPalette . JP.palettize gifPaletteOptions . toJPImageRGB8 + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto GIF) (Image r cs e) where + encodeM = encodeAutoGIF + + +instance Readable GIF (Image S CM.RGB Word8) where + decodeM = decodeGIF + decodeWithMetadataM = decodeWithMetadataGIF + +instance Readable GIF (Image S (Alpha CM.RGB) Word8) where + decodeM = decodeGIF + decodeWithMetadataM = decodeWithMetadataGIF + +instance Readable GIF (Image S SRGB Word8) where + decodeM f = fmap fromImageBaseModel . decodeM f + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable GIF (Image S (Alpha SRGB) Word8) where + decodeM f = fmap fromImageBaseModel . decodeM f + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +-- | Decode a Gif Image +decodeGIF :: (ColorModel cs e, MonadThrow m) => GIF -> B.ByteString -> m (Image S cs e) +decodeGIF f bs = convertWith f (JP.decodeGif bs) + +-- | Decode a Gif Image +decodeWithMetadataGIF :: + (ColorModel cs e, MonadThrow m) => GIF -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataGIF f bs = convertWithMetadata f (JP.decodeGifWithMetadata bs) + + +-- | Decode a Gif Image +decodeAutoGIF :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto GIF + -> B.ByteString + -> m (Image r cs e) +decodeAutoGIF f bs = convertAutoWith f (JP.decodeGif bs) + +-- | Decode a Gif Image +decodeAutoWithMetadataGIF :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto GIF + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataGIF f bs = convertAutoWithMetadata f (JP.decodeGifWithMetadata bs) + + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto GIF) (Image r cs e) where + decodeM = decodeAutoGIF + decodeWithMetadataM = decodeAutoWithMetadataGIF + +encodeGIF :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => GIF + -> GifOptions + -> Image r cs e + -> m BL.ByteString +encodeGIF f opts img = + fallbackEncodePalettizedRGB $ do + Refl <- eqT :: Maybe (cs :~: CM.Y) + Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeGifImage $ toJPImageY8 img + where + fallbackEncodePalettizedRGB = + \case + Just bs -> pure bs + Nothing + | Just Refl <- (eqT :: Maybe (e :~: Word8)) + , Just Refl <- (eqT :: Maybe (cs :~: CM.RGB)) -> encodePalettizedRGB opts img + Nothing -> fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) Nothing + + +encodeAutoGIF :: + forall r cs i e m. (ColorSpace cs i e, Source r Ix2 (Pixel cs e), MonadThrow m) + => Auto GIF + -> GifOptions + -> Image r cs e + -> m BL.ByteString +encodeAutoGIF _ opts img = + fallbackEncodePalettizedRGB $ do + Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y) + pure $ JP.encodeGifImage $ toJPImageY8 $ A.map (toPixel8 . toPixelBaseModel) img + where + fallbackEncodePalettizedRGB = + \case + Just bs -> pure bs + Nothing -> encodePalettizedRGB opts $ A.map toSRGB8 img + +data SequenceGifOptions = SequenceGifOptions + { sequenceGifPaletteOptions :: !JP.PaletteOptions + , sequenceGifLooping :: !JP.GifLooping + } + +instance Default SequenceGifOptions where + def = + SequenceGifOptions + {sequenceGifPaletteOptions = JP.defaultPaletteOptions, sequenceGifLooping = JP.LoopingNever} + +instance FileFormat (Sequence GIF) where + type WriteOptions (Sequence GIF) = SequenceGifOptions + type Metadata (Sequence GIF) = [JP.GifDelay] + ext _ = ext GIF + +instance Readable (Sequence GIF) [Image S CM.RGB Word8] where + decodeM = decodeSequenceGIF + decodeWithMetadataM = decodeSequenceWithMetadataGIF + +instance Readable (Sequence GIF) [Image S (Alpha CM.RGB) Word8] where + decodeM = decodeSequenceGIF + decodeWithMetadataM = decodeSequenceWithMetadataGIF + +instance Readable (Sequence GIF) [Image S SRGB Word8] where + decodeM f = fmap (fmap fromImageBaseModel) . decodeM f + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f + +instance Readable (Sequence GIF) [Image S (Alpha SRGB) Word8] where + decodeM f = fmap (fmap fromImageBaseModel) . decodeM f + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f + + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto (Sequence GIF)) [Image r cs e] where + decodeM = decodeAutoSequenceGIF + decodeWithMetadataM = decodeAutoSequenceWithMetadataGIF + + +-- | Decode a sequence of Gif images +decodeSequenceGIF :: + (ColorModel cs e, MonadThrow m) => Sequence GIF -> B.ByteString -> m [Image S cs e] +decodeSequenceGIF f bs = convertSequenceWith f (JP.decodeGifImages bs) + +-- | Decode a sequence of Gif images +decodeSequenceWithMetadataGIF :: + (ColorModel cs e, MonadThrow m) + => Sequence GIF + -> B.ByteString + -> m ([Image S cs e], [JP.GifDelay]) +decodeSequenceWithMetadataGIF = decodeSeqMetadata decodeSequenceGIF + +-- | Decode a sequence of Gif images +decodeAutoSequenceGIF :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto (Sequence GIF) + -> B.ByteString + -> m [Image r cs e] +decodeAutoSequenceGIF f bs = convertAutoSequenceWith f (JP.decodeGifImages bs) + +-- | Decode a sequence of Gif images +decodeAutoSequenceWithMetadataGIF :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto (Sequence GIF) + -> B.ByteString + -> m ([Image r cs e], [JP.GifDelay]) +decodeAutoSequenceWithMetadataGIF = decodeSeqMetadata decodeAutoSequenceGIF + +decodeSeqMetadata :: + MonadThrow m => (t -> B.ByteString -> m a) -> t -> B.ByteString -> m (a, [JP.GifDelay]) +decodeSeqMetadata decode f bs = do + imgs <- decode f bs + delays <- decodeError $ JP.getDelaysGifImages bs + pure (imgs, delays) + + +instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S CM.Y Word8)) where + encodeM _ SequenceGifOptions {sequenceGifLooping} gifs = + encodeError $ + JP.encodeComplexGifImage $ + JP.GifEncode + { JP.geWidth = cols + , JP.geHeight = rows + , JP.gePalette = Just JP.greyPalette + , JP.geBackground = Nothing + , JP.geLooping = sequenceGifLooping + , JP.geFrames = + flip fmap (NE.toList gifs) $ \(gifDelay, gif) -> + JP.GifFrame + { JP.gfXOffset = 0 + , JP.gfYOffset = 0 + , JP.gfPalette = Nothing + , JP.gfTransparent = Nothing + , JP.gfDelay = gifDelay + , JP.gfDisposal = JP.DisposalAny + , JP.gfPixels = toJPImageY8 gif + } + } + where + (rows :. cols) = foldl1 (liftIndex2 max) $ fmap (unSz . size . snd) gifs + +instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S CM.RGB Word8)) where + encodeM _ SequenceGifOptions {sequenceGifLooping, sequenceGifPaletteOptions} gifs = + encodeError $ + JP.encodeComplexGifImage $ + JP.GifEncode + { JP.geWidth = cols + , JP.geHeight = rows + , JP.gePalette = Nothing + , JP.geBackground = Nothing + , JP.geLooping = sequenceGifLooping + , JP.geFrames = + flip fmap (NE.toList gifs) $ \(gifDelay, gif) -> + let (img, palette) = JP.palettize sequenceGifPaletteOptions $ toJPImageRGB8 gif + in JP.GifFrame + { JP.gfXOffset = 0 + , JP.gfYOffset = 0 + , JP.gfPalette = Just palette + , JP.gfTransparent = Nothing + , JP.gfDelay = gifDelay + , JP.gfDisposal = JP.DisposalAny + , JP.gfPixels = img + } + } + where + (rows :. cols) = foldl1 (liftIndex2 max) $ fmap (unSz . size . snd) gifs + + +instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S (Y D65) Word8)) where + encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel) + +instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S SRGB Word8)) where + encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel) + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Writable (Auto (Sequence GIF)) (NE.NonEmpty (JP.GifDelay, Image r cs e)) where + encodeM (Auto f) opts = + encodeM f opts . + fmap (fmap (computeAs S . (convertImage :: Image r cs e -> Image D SRGB Word8))) diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/HDR.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/HDR.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/HDR.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.HDR +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.HDR + ( HDR(..) + , HdrOptions(..) + , decodeHDR + , decodeWithMetadataHDR + , decodeAutoHDR + , decodeAutoWithMetadataHDR + , encodeHDR + , encodeAutoHDR + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.HDR as JP +import qualified Codec.Picture.Metadata as JP +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P + +-------------------------------------------------------------------------------- +-- HDR Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + +newtype HdrOptions = HdrOptions + { hdrUseLightRLE :: Bool + -- ^ Use light RLE compression. Causes problems in some viewers. See: + -- `JP.encodeRLENewStyleHDR` + } deriving (Show) + +instance Default HdrOptions where + def = HdrOptions False + + +-- | High-dynamic-range image with @.hdr@ or @.pic@ extension. +data HDR = HDR deriving Show + +instance FileFormat HDR where + type WriteOptions HDR = HdrOptions + type Metadata HDR = JP.Metadatas + ext _ = ".hdr" + exts _ = [".hdr", ".pic"] + +getHdrEncoder + :: HdrOptions -> JP.Image JP.PixelRGBF -> BL.ByteString +getHdrEncoder HdrOptions {hdrUseLightRLE} + | hdrUseLightRLE = JP.encodeRLENewStyleHDR + | otherwise = JP.encodeHDR + +instance Writable HDR (Image S CM.RGB Float) where + encodeM HDR opts = pure . getHdrEncoder opts . toJPImageRGBF + +instance Writable HDR (Image S SRGB Float) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto HDR) (Image r cs e) where + encodeM f opts = pure . encodeAutoHDR f opts + + +instance Readable HDR (Image S CM.RGB Float) where + decodeWithMetadataM = decodeWithMetadataHDR + +instance Readable HDR (Image S SRGB Float) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +-- | Decode a HDR Image +decodeHDR :: (ColorModel cs e, MonadThrow m) => HDR -> B.ByteString -> m (Image S cs e) +decodeHDR f bs = convertWith f (JP.decodeHDR bs) + +-- | Decode a HDR Image +decodeWithMetadataHDR :: + (ColorModel cs e, MonadThrow m) => HDR -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataHDR f bs = convertWithMetadata f (JP.decodeHDRWithMetadata bs) + + +-- | Decode a HDR Image +decodeAutoHDR :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto HDR + -> B.ByteString + -> m (Image r cs e) +decodeAutoHDR f bs = convertAutoWith f (JP.decodeHDR bs) + +-- | Decode a HDR Image +decodeAutoWithMetadataHDR :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto HDR + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataHDR f bs = convertAutoWithMetadata f (JP.decodeHDRWithMetadata bs) + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto HDR) (Image r cs e) where + decodeM = decodeAutoHDR + decodeWithMetadataM = decodeAutoWithMetadataHDR + +encodeHDR :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => HDR + -> HdrOptions + -> Image r cs e + -> m BL.ByteString +encodeHDR f opts img = + fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ do + Refl <- eqT :: Maybe (e :~: Float) + Refl <- eqT :: Maybe (cs :~: CM.RGB) + pure $ getHdrEncoder opts $ toJPImageRGBF img + + + +encodeAutoHDR :: + forall r cs i e. (ColorSpace cs i e, Source r Ix2 (Pixel cs e)) + => Auto HDR + -> HdrOptions + -> Image r cs e + -> BL.ByteString +encodeAutoHDR _ opts = toHdr (toPixelBaseModel . toSRGBF) + where + toSRGBF = convertPixel :: Pixel cs e -> Pixel SRGB Float + toHdr :: Source r Ix2 a => (a -> Pixel CM.RGB Float) -> Array r Ix2 a -> BL.ByteString + toHdr adjustPixel = getHdrEncoder opts . toJPImageRGBF . A.map adjustPixel diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/JPG.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/JPG.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/JPG.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.JPG +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.JPG + ( JPG(..) + , JpegOptions(..) + , decodeJPG + , decodeWithMetadataJPG + , decodeAutoJPG + , decodeAutoWithMetadataJPG + , encodeJPG + , encodeAutoJPG + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.Jpg as JP +import qualified Codec.Picture.Metadata as JP +import Control.Monad (msum) +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Maybe (fromMaybe) +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P + +-------------------------------------------------------------------------------- +-- JPG Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + +-- TODOs: Check if JP is capable of writing Jpegs with PixelYA8 (No instance for +-- JpegEncodable, but it can read 'em) + +data JpegOptions = JpegOptions + { jpegQuality :: !Word8 + , jpegMetadata :: !JP.Metadatas + } deriving (Show) + +instance Default JpegOptions where + def = JpegOptions 100 mempty + + +-- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension. +data JPG = JPG deriving Show + +instance FileFormat JPG where + type WriteOptions JPG = JpegOptions + type Metadata JPG = JP.Metadatas + ext _ = ".jpg" + exts _ = [".jpg", ".jpeg"] + +instance Writable JPG (Image S CM.Y Word8) where + encodeM JPG JpegOptions {jpegQuality, jpegMetadata} = + pure . JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageY8 + +instance Writable JPG (Image S CM.RGB Word8) where + encodeM JPG JpegOptions {jpegQuality, jpegMetadata} = + pure . JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageRGB8 + +instance Writable JPG (Image S CM.YCbCr Word8) where + encodeM JPG JpegOptions {jpegQuality, jpegMetadata} = + pure . JP.encodeJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageYCbCr8 + +instance Writable JPG (Image S CM.CMYK Word8) where + encodeM JPG JpegOptions {jpegQuality, jpegMetadata} = + pure . JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageCMYK8 + +instance Writable JPG (Image S (Y D65) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable JPG (Image S SRGB Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable JPG (Image S (YCbCr SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable JPG (Image S (CMYK SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto JPG) (Image r cs e) where + encodeM f opts = pure . encodeAutoJPG f opts + + +instance Readable JPG (Image S CM.Y Word8) where + decodeWithMetadataM = decodeWithMetadataJPG + +instance Readable JPG (Image S (Alpha CM.Y) Word8) where + decodeWithMetadataM = decodeWithMetadataJPG + +instance Readable JPG (Image S CM.RGB Word8) where + decodeWithMetadataM = decodeWithMetadataJPG + +instance Readable JPG (Image S CM.CMYK Word8) where + decodeWithMetadataM = decodeWithMetadataJPG + +instance Readable JPG (Image S CM.YCbCr Word8) where + decodeWithMetadataM = decodeWithMetadataJPG + + +instance Readable JPG (Image S (Y D65) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable JPG (Image S (Alpha (Y D65)) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable JPG (Image S SRGB Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable JPG (Image S (CMYK SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable JPG (Image S (YCbCr SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + + +-- | Decode a Jpeg Image +decodeJPG :: (ColorModel cs e, MonadThrow m) => JPG -> B.ByteString -> m (Image S cs e) +decodeJPG f bs = convertWith f (JP.decodeJpeg bs) + +-- | Decode a Jpeg Image +decodeWithMetadataJPG :: + (ColorModel cs e, MonadThrow m) => JPG -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataJPG f bs = convertWithMetadata f (JP.decodeJpegWithMetadata bs) + + +-- | Decode a Jpeg Image +decodeAutoJPG :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto JPG + -> B.ByteString + -> m (Image r cs e) +decodeAutoJPG f bs = convertAutoWith f (JP.decodeJpeg bs) + +-- | Decode a Jpeg Image +decodeAutoWithMetadataJPG :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto JPG + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataJPG f bs = convertAutoWithMetadata f (JP.decodeJpegWithMetadata bs) + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto JPG) (Image r cs e) where + decodeM = decodeAutoJPG + decodeWithMetadataM = decodeAutoWithMetadataJPG + +encodeJPG :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => JPG + -> JpegOptions + -> Image r cs e + -> m BL.ByteString +encodeJPG f JpegOptions {jpegQuality, jpegMetadata} img = + fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ do + Refl <- eqT :: Maybe (e :~: Word8) + msum + [ do Refl <- eqT :: Maybe (cs :~: CM.Y) + pure $ + JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageY8 img + , do Refl <- eqT :: Maybe (cs :~: CM.RGB) + pure $ + JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageRGB8 img + , do Refl <- eqT :: Maybe (cs :~: CM.YCbCr) + pure $ JP.encodeJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageYCbCr8 img + , do Refl <- eqT :: Maybe (cs :~: CM.CMYK) + pure $ + JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageCMYK8 img + ] + + + +encodeAutoJPG :: + forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (Pixel cs e)) + => Auto JPG + -> JpegOptions + -> Image r cs e + -> BL.ByteString +encodeAutoJPG _ JpegOptions {jpegQuality, jpegMetadata} img = + fromMaybe (toJpeg toJPImageYCbCr8 toYCbCr8 img) $ + msum + [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Bit) + pure $ toJpeg toJPImageY8 (toPixel8 . toPixelBaseModel) img + , pure $ toJpeg toJPImageY8 (toPixel8 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.CMYK) + pure $ toJpeg toJPImageCMYK8 toCMYK8 img + , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.RGB) + pure $ toJpeg toJPImageRGB8 toSRGB8 img + ] + where + toJpeg :: + (JP.JpgEncodable px, Source r ix a) + => (Array D ix b -> JP.Image px) + -> (a -> b) + -> Array r ix a + -> BL.ByteString + toJpeg toJP adjustPixel = + JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJP . A.map adjustPixel diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/PNG.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/PNG.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/PNG.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.PNG +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.PNG + ( PNG(..) + , decodePNG + , decodeWithMetadataPNG + , decodeAutoPNG + , decodeAutoWithMetadataPNG + , encodePNG + , encodeAutoPNG + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.Metadata as JP +import qualified Codec.Picture.Png as JP +import Control.Monad (msum) +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Maybe (fromMaybe) +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P + +-------------------------------------------------------------------------------- +-- PNG Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + + +-- | Portable Network Graphics image with @.png@ extension. +data PNG = PNG deriving Show + +instance FileFormat PNG where + type Metadata PNG = JP.Metadatas + ext _ = ".png" + +instance Writable PNG (Image S CM.Y Word8) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageY8 img) + +instance Writable PNG (Image S CM.Y Word16) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageY16 img) + +instance Writable PNG (Image S (Alpha CM.Y) Word8) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageYA8 img) + +instance Writable PNG (Image S (Alpha CM.Y) Word16) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageYA16 img) + +instance Writable PNG (Image S CM.RGB Word8) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGB8 img) + +instance Writable PNG (Image S CM.RGB Word16) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGB16 img) + +instance Writable PNG (Image S (Alpha CM.RGB) Word8) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGBA8 img) + +instance Writable PNG (Image S (Alpha CM.RGB) Word16) where + encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGBA16 img) + + +instance Writable PNG (Image S (Y D65) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S (Y D65) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S (Alpha (Y D65)) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S (Alpha (Y D65)) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S SRGB Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S SRGB Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S (Alpha SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable PNG (Image S (Alpha SRGB) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto PNG) (Image r cs e) where + encodeM f _ = pure . encodeAutoPNG f + + +instance Readable PNG (Image S CM.Y Word8) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S CM.Y Word16) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S (Alpha CM.Y) Word8) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S (Alpha CM.Y) Word16) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S CM.RGB Word8) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S CM.RGB Word16) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S (Alpha CM.RGB) Word8) where + decodeWithMetadataM = decodeWithMetadataPNG + +instance Readable PNG (Image S (Alpha CM.RGB) Word16) where + decodeWithMetadataM = decodeWithMetadataPNG + + +instance Readable PNG (Image S (Y D65) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S (Y D65) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S (Alpha (Y D65)) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S (Alpha (Y D65)) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S SRGB Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S SRGB Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S (Alpha SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +instance Readable PNG (Image S (Alpha SRGB) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f + +-- | Decode a Png Image +decodePNG :: (ColorModel cs e, MonadThrow m) => PNG -> B.ByteString -> m (Image S cs e) +decodePNG f bs = convertWith f (JP.decodePng bs) + +-- | Decode a Png Image +decodeWithMetadataPNG :: + (ColorModel cs e, MonadThrow m) => PNG -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataPNG f bs = convertWithMetadata f (JP.decodePngWithMetadata bs) + + +-- | Decode a Png Image +decodeAutoPNG :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto PNG + -> B.ByteString + -> m (Image r cs e) +decodeAutoPNG f bs = convertAutoWith f (JP.decodePng bs) + +-- | Decode a Png Image +decodeAutoWithMetadataPNG :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto PNG + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataPNG f bs = convertAutoWithMetadata f (JP.decodePngWithMetadata bs) + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto PNG) (Image r cs e) where + decodeM = decodeAutoPNG + decodeWithMetadataM = decodeAutoWithMetadataPNG + +encodePNG :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => PNG + -> Image r cs e + -> m BL.ByteString +encodePNG f img = + fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ + msum + [ do Refl <- eqT :: Maybe (cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodePng $ toJPImageY8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodePng $ toJPImageY16 img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodePng $ toJPImageYA8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodePng $ toJPImageYA16 img + ] + , do Refl <- eqT :: Maybe (cs :~: CM.RGB) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodePng $ toJPImageRGB8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodePng $ toJPImageRGB16 img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodePng $ toJPImageRGBA8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodePng $ toJPImageRGBA16 img + ] + ] + + +encodeAutoPNG :: + forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (Pixel cs e)) + => Auto PNG + -> Image r cs e + -> BL.ByteString +encodeAutoPNG _ img = + fromMaybe (toPng toJPImageRGB16 toSRGB16 img) $ + msum + [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Bit) + pure $ toPng toJPImageY8 (toPixel8 . toPixelBaseModel) img + , do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toPng toJPImageY8 toPixelBaseModel img + , pure $ toPng toJPImageY16 (toPixel16 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (BaseModel cs :~: Alpha CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toPng toJPImageYA8 toPixelBaseModel img + , pure $ toPng toJPImageYA16 (toPixel16 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs)) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toPng toJPImageRGBA8 toSRGBA8 img + , pure $ toPng toJPImageRGBA16 toSRGBA16 img + ] + , do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toPng toJPImageRGB8 toSRGB8 img + ] + where + toPng :: + (JP.PngSavable px, Source r ix a) + => (Array D ix b -> JP.Image px) + -> (a -> b) + -> Array r ix a + -> BL.ByteString + toPng toJP adjustPixel = JP.encodePng . toJP . A.map adjustPixel diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/TGA.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/TGA.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/TGA.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.TGA +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.TGA + ( TGA(..) + , decodeTGA + , decodeWithMetadataTGA + , decodeAutoTGA + , decodeAutoWithMetadataTGA + , encodeTGA + , encodeAutoTGA + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.Metadata as JP +import qualified Codec.Picture.Tga as JP +import Control.Monad (msum) +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Maybe (fromMaybe) +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P + + +-------------------------------------------------------------------------------- +-- TGA Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + + +-- | Truevision Graphics Adapter image with .tga extension. +data TGA = TGA deriving Show + +instance FileFormat TGA where + type Metadata TGA = JP.Metadatas + ext _ = ".tga" + +instance Writable TGA (Image S CM.Y Word8) where + encodeM TGA _ img = pure $ JP.encodeTga (toJPImageY8 img) + +instance Writable TGA (Image S CM.RGB Word8) where + encodeM TGA _ img = pure $ JP.encodeTga (toJPImageRGB8 img) + +instance Writable TGA (Image S (Alpha CM.RGB) Word8) where + encodeM TGA _ img = pure $ JP.encodeTga (toJPImageRGBA8 img) + + +instance Writable TGA (Image S (Y D65) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TGA (Image S SRGB Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TGA (Image S (Alpha SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto TGA) (Image r cs e) where + encodeM f _ = pure . encodeAutoTGA f + + +instance Readable TGA (Image S CM.Y Word8) where + decodeWithMetadataM = decodeWithMetadataTGA + +instance Readable TGA (Image S CM.RGB Word8) where + decodeWithMetadataM = decodeWithMetadataTGA + +instance Readable TGA (Image S (Alpha CM.RGB) Word8) where + decodeWithMetadataM = decodeWithMetadataTGA + + +instance Readable TGA (Image S (Y D65) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TGA (Image S SRGB Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TGA (Image S (Alpha SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +-- | Decode a Tga Image +decodeTGA :: (ColorModel cs e, MonadThrow m) => TGA -> B.ByteString -> m (Image S cs e) +decodeTGA f bs = convertWith f (JP.decodeTga bs) + +-- | Decode a Tga Image +decodeWithMetadataTGA :: + (ColorModel cs e, MonadThrow m) => TGA -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataTGA f bs = convertWithMetadata f (JP.decodeTgaWithMetadata bs) + + +-- | Decode a Tga Image +decodeAutoTGA :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto TGA + -> B.ByteString + -> m (Image r cs e) +decodeAutoTGA f bs = convertAutoWith f (JP.decodeTga bs) + +-- | Decode a Tga Image +decodeAutoWithMetadataTGA :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto TGA + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataTGA f bs = convertAutoWithMetadata f (JP.decodeTgaWithMetadata bs) + + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto TGA) (Image r cs e) where + decodeWithMetadataM = decodeAutoWithMetadataTGA + +encodeTGA :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => TGA + -> Image r cs e + -> m BL.ByteString +encodeTGA f img = + fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ + msum + [ do Refl <- eqT :: Maybe (cs :~: CM.Y) + Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTga $ toJPImageY8 img + , do Refl <- eqT :: Maybe (cs :~: CM.RGB) + Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTga $ toJPImageRGB8 img + , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB) + Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTga $ toJPImageRGBA8 img + ] + + +encodeAutoTGA :: + forall r cs i e. + ( ColorSpace (BaseSpace cs) i e + , ColorSpace cs i e + , Source r Ix2 (Pixel cs e) + ) + => Auto TGA + -> Image r cs e + -> BL.ByteString +encodeAutoTGA _ img = + fromMaybe (toTga toJPImageRGB8 toSRGB8 img) $ + msum + [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Bit) + pure $ toTga toJPImageY8 (toPixel8 . toPixelBaseModel) img + , do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toTga toJPImageY8 toPixelBaseModel img + , pure $ toTga toJPImageY8 (toPixel8 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs)) + pure $ toTga toJPImageRGBA8 toSRGBA8 img + ] + where + toTga :: + (JP.TgaSaveable px, Source r ix a) + => (Array D ix b -> JP.Image px) + -> (a -> b) + -> Array r ix a + -> BL.ByteString + toTga toJP adjustPixel = JP.encodeTga . toJP . A.map adjustPixel diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels/TIF.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels/TIF.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels/TIF.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels.TIF +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.JuicyPixels.TIF + ( TIF(..) + , decodeTIF + , decodeWithMetadataTIF + , decodeAutoTIF + , decodeAutoWithMetadataTIF + , encodeTIF + , encodeAutoTIF + ) where + +import qualified Codec.Picture as JP +import qualified Codec.Picture.Metadata as JP +import qualified Codec.Picture.Tiff as JP +import Control.Monad (msum) +import Data.Bifunctor (first) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Massiv.Array as A +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels.Base +import Data.Maybe (fromMaybe) +import Data.Typeable +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace +import Prelude as P + + + +-------------------------------------------------------------------------------- +-- TIF Format ------------------------------------------------------------------ +-------------------------------------------------------------------------------- + +-- TODOs: +-- * Check on reading in YCbCr +-- * Check on "except for Y32 which is truncated to 16 bits" in `JP.decodeTiff` doc. + + +-- | Tagged Image File Format image with @.tif@ or @.tiff@ extension. +data TIF = TIF deriving Show + +instance FileFormat TIF where + type Metadata TIF = JP.Metadatas + ext _ = ".tif" + exts _ = [".tif", ".tiff"] + +instance Writable TIF (Image S CM.Y Word8) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY8 img) + +instance Writable TIF (Image S CM.Y Word16) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY16 img) + +instance Writable TIF (Image S CM.Y Word32) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY32 img) + +instance Writable TIF (Image S CM.Y Float) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYF img) + +instance Writable TIF (Image S (Alpha CM.Y) Word8) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYA8 img) + +instance Writable TIF (Image S (Alpha CM.Y) Word16) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYA16 img) + +instance Writable TIF (Image S CM.RGB Word8) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGB8 img) + +instance Writable TIF (Image S CM.RGB Word16) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGB16 img) + +instance Writable TIF (Image S (Alpha CM.RGB) Word8) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGBA8 img) + +instance Writable TIF (Image S (Alpha CM.RGB) Word16) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGBA16 img) + +instance Writable TIF (Image S CM.YCbCr Word8) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYCbCr8 img) + +instance Writable TIF (Image S CM.CMYK Word8) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageCMYK8 img) + +instance Writable TIF (Image S CM.CMYK Word16) where + encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageCMYK16 img) + +instance Writable TIF (Image S (Y D65) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Y D65) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Y D65) Word32) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Y D65) Float) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Alpha (Y D65)) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Alpha (Y D65)) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S SRGB Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S SRGB Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Alpha SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (Alpha SRGB) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (YCbCr SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (CMYK SRGB) Word8) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance Writable TIF (Image S (CMYK SRGB) Word16) where + encodeM f opts = encodeM f opts . toImageBaseModel + +instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) => + Writable (Auto TIF) (Image r cs e) where + encodeM f _ = pure . encodeAutoTIF f + + +instance Readable TIF (Image S CM.Y Word8) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.Y Word16) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.Y Word32) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.Y Float) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S (Alpha CM.Y) Word8) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S (Alpha CM.Y) Word16) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.RGB Word8) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.RGB Word16) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S (Alpha CM.RGB) Word8) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S (Alpha CM.RGB) Word16) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.CMYK Word8) where + decodeWithMetadataM = decodeWithMetadataTIF + +instance Readable TIF (Image S CM.CMYK Word16) where + decodeWithMetadataM = decodeWithMetadataTIF + + +instance Readable TIF (Image S (Y D65) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Y D65) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Y D65) Word32) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Y D65) Float) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Alpha (Y D65)) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Alpha (Y D65)) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S SRGB Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S SRGB Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Alpha SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (Alpha SRGB) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (CMYK SRGB) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +instance Readable TIF (Image S (CMYK SRGB) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + +-- | Decode a Tiff Image +decodeTIF :: (ColorModel cs e, MonadThrow m) => TIF -> B.ByteString -> m (Image S cs e) +decodeTIF f bs = convertWith f (JP.decodeTiff bs) + +-- | Decode a Tiff Image +decodeWithMetadataTIF :: + (ColorModel cs e, MonadThrow m) => TIF -> B.ByteString -> m (Image S cs e, JP.Metadatas) +decodeWithMetadataTIF f bs = convertWithMetadata f (JP.decodeTiffWithMetadata bs) + + +-- | Decode a Tiff Image +decodeAutoTIF :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto TIF + -> B.ByteString + -> m (Image r cs e) +decodeAutoTIF f bs = convertAutoWith f (JP.decodeTiff bs) + +-- | Decode a Tiff Image +decodeAutoWithMetadataTIF :: + (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadThrow m) + => Auto TIF + -> B.ByteString + -> m (Image r cs e, JP.Metadatas) +decodeAutoWithMetadataTIF f bs = convertAutoWithMetadata f (JP.decodeTiffWithMetadata bs) + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto TIF) (Image r cs e) where + decodeM = decodeAutoTIF + decodeWithMetadataM = decodeAutoWithMetadataTIF + +encodeTIF :: + forall r cs e m. + (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m) + => TIF + -> Image r cs e + -> m BL.ByteString +encodeTIF f img = + fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ + msum + [ do Refl <- eqT :: Maybe (cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTiff $ toJPImageY8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodeTiff $ toJPImageY16 img + , do Refl <- eqT :: Maybe (e :~: Word32) + pure $ JP.encodeTiff $ toJPImageY32 img + , do Refl <- eqT :: Maybe (e :~: Float) + pure $ JP.encodeTiff $ toJPImageYF img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTiff $ toJPImageYA8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodeTiff $ toJPImageYA16 img + ] + , do Refl <- eqT :: Maybe (cs :~: CM.RGB) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTiff $ toJPImageRGB8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodeTiff $ toJPImageRGB16 img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTiff $ toJPImageRGBA8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodeTiff $ toJPImageRGBA16 img + ] + , do Refl <- eqT :: Maybe (cs :~: CM.YCbCr) + Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTiff $ toJPImageYCbCr8 img + , do Refl <- eqT :: Maybe (cs :~: CM.CMYK) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ JP.encodeTiff $ toJPImageCMYK8 img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ JP.encodeTiff $ toJPImageCMYK16 img + ] + ] + + + +encodeAutoTIF :: + forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (Pixel cs e)) + => Auto TIF + -> Image r cs e + -> BL.ByteString +encodeAutoTIF _ img = + fromMaybe (toTiff toJPImageRGB8 toSRGB8 img) $ + msum + [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Bit) + pure $ toTiff toJPImageY8 (toPixel8 . toPixelBaseModel) img + , do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toTiff toJPImageY8 toPixelBaseModel img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ toTiff toJPImageY16 toPixelBaseModel img + , do Refl <- eqT :: Maybe (e :~: Word32) + pure $ toTiff toJPImageY32 toPixelBaseModel img + , do Refl <- eqT :: Maybe (e :~: Float) + pure $ toTiff toJPImageYF toPixelBaseModel img + , pure $ toTiff toJPImageY16 (toPixel16 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (BaseModel cs :~: Alpha CM.Y) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toTiff toJPImageYA8 toPixelBaseModel img + , do Refl <- eqT :: Maybe (e :~: Word16) + pure $ toTiff toJPImageYA16 toPixelBaseModel img + , pure $ toTiff toJPImageYA16 (toPixel16 . toPixelBaseModel) img + ] + , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.YCbCr) + pure $ toTiff toJPImageYCbCr8 toYCbCr8 img + , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.CMYK) + msum + [ do Refl <- eqT :: Maybe (e :~: Word16) + pure $ toTiff toJPImageCMYK16 toCMYK16 img + -- for CMYK default is 8bit, instead of 16bit, since many viewers and editors + -- don't support the latter. + , pure $ toTiff toJPImageCMYK8 toCMYK8 img + ] + , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.RGB) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toTiff toJPImageRGB8 toSRGB8 img + , pure $ toTiff toJPImageRGB16 toSRGB16 img + ] + , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs)) + msum + [ do Refl <- eqT :: Maybe (e :~: Word8) + pure $ toTiff toJPImageRGBA8 toSRGBA8 img + , pure $ toTiff toJPImageRGBA16 toSRGBA16 img + ] + ] + where + toTiff :: + (JP.TiffSaveable px, Source r ix a) + => (Array D ix b -> JP.Image px) + -> (a -> b) + -> Array r ix a + -> BL.ByteString + toTiff toJP adjustPixel = JP.encodeTiff . toJP . A.map adjustPixel diff --git a/src/Data/Massiv/Array/IO/Image/Netpbm.hs b/src/Data/Massiv/Array/IO/Image/Netpbm.hs --- a/src/Data/Massiv/Array/IO/Image/Netpbm.hs +++ b/src/Data/Massiv/Array/IO/Image/Netpbm.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Massiv.Array.IO.Image.Netpbm --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -25,156 +26,134 @@ , PGM(..) -- ** PPM , PPM(..) + , decodeNetpbmImage + , decodeNetpbmImageSequence + , decodeAutoNetpbmImage + , decodeAutoNetpbmImageSequence ) where -import Control.Exception import Control.Monad (guard) +import Data.Bifunctor (first) import qualified Data.ByteString as B (ByteString) import Data.Massiv.Array as M import Data.Massiv.Array.IO.Base -import Data.Massiv.Array.IO.Image.JuicyPixels (toAnyCS) import Data.Massiv.Array.Manifest.Vector import Data.Typeable import qualified Data.Vector.Storable as V import Foreign.Storable (Storable) -import Graphics.ColorSpace import Graphics.Netpbm as Netpbm hiding (PPM) import qualified Graphics.Netpbm as Netpbm (PPM(..)) +import qualified Graphics.Pixel as CM +import Graphics.Pixel.ColorSpace import Prelude as P -#if !MIN_VERSION_massiv(0, 2, 7) -pattern Sz :: ix -> ix -pattern Sz ix = ix -type Sz ix = ix -#endif -#if !MIN_VERSION_massiv(0, 3, 0) -fromVectorM :: - (Construct S ix a, Mutable S ix a, Storable a) - => Comp - -> Sz ix - -> V.Vector a - -> Maybe (Array S ix a) -fromVectorM comp sz = pure . fromVector comp sz -#endif - -- | Netpbm: portable bitmap image with @.pbm@ extension. data PBM = PBM deriving Show instance FileFormat PBM where + type Metadata PBM = Maybe B.ByteString ext _ = ".pbm" instance FileFormat (Sequence PBM) where type WriteOptions (Sequence PBM) = WriteOptions PBM - ext _ = ext PBM - -instance FileFormat (Sequence (Auto PBM)) where - type WriteOptions (Sequence (Auto PBM)) = WriteOptions PBM + type Metadata (Sequence PBM) = Maybe B.ByteString ext _ = ext PBM -instance ColorSpace cs e => Readable PBM (Image S cs e) where - decode f _ = decodePPM f fromNetpbmImage - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto PBM) (Image r cs e) where - decode f _ = decodePPM f fromNetpbmImageAuto - -instance ColorSpace cs e => Readable (Sequence PBM) (Array B Ix1 (Image S cs e)) where - decode f _ = decodePPMs f fromNetpbmImage - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Sequence (Auto PBM)) (Array B Ix1 (Image r cs e)) where - decode f _ = decodePPMs f fromNetpbmImageAuto - - - -- | Netpbm: portable graymap image with @.pgm@ extension. data PGM = PGM deriving Show instance FileFormat PGM where + type Metadata PGM = Maybe B.ByteString ext _ = ".pgm" instance FileFormat (Sequence PGM) where type WriteOptions (Sequence PGM) = WriteOptions PGM - ext _ = ext PGM - -instance FileFormat (Sequence (Auto PGM)) where - type WriteOptions (Sequence (Auto PGM)) = WriteOptions PGM + type Metadata (Sequence PGM) = Maybe B.ByteString ext _ = ext PGM -instance ColorSpace cs e => Readable PGM (Image S cs e) where - decode f _ = decodePPM f fromNetpbmImage - - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto PGM) (Image r cs e) where - decode f _ = decodePPM f fromNetpbmImageAuto - - -instance ColorSpace cs e => Readable (Sequence PGM) (Array B Ix1 (Image S cs e)) where - decode f _ = decodePPMs f fromNetpbmImage - - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Sequence (Auto PGM)) (Array B Ix1 (Image r cs e)) where - decode f _ = decodePPMs f fromNetpbmImageAuto - - -- | Netpbm: portable pixmap image with @.ppm@ extension. data PPM = PPM deriving Show instance FileFormat PPM where + type Metadata PPM = Maybe B.ByteString ext _ = ".ppm" exts _ = [".ppm", ".pnm"] instance FileFormat (Sequence PPM) where type WriteOptions (Sequence PPM) = WriteOptions PPM - ext _ = ext PPM - -instance FileFormat (Sequence (Auto PPM)) where - type WriteOptions (Sequence (Auto PPM)) = WriteOptions PPM + type Metadata (Sequence PPM) = Maybe B.ByteString ext _ = ext PPM - -instance ColorSpace cs e => Readable PPM (Image S cs e) where - decode f _ = decodePPM f fromNetpbmImage - -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Auto PPM) (Image r cs e) where - decode f _ = decodePPM f fromNetpbmImageAuto - -instance ColorSpace cs e => Readable (Sequence PPM) (Array B Ix1 (Image S cs e)) where - decode f _ = decodePPMs f fromNetpbmImage +-- | Try to decode a Netpbm image +-- +-- @since 0.2.0 +decodeNetpbmImage :: + (FileFormat f, ColorModel cs e, MonadThrow m) + => f + -> B.ByteString + -> m (Image S cs e, Maybe B.ByteString) +decodeNetpbmImage = decodePPM fromNetpbmImage -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - Readable (Sequence (Auto PPM)) (Array B Ix1 (Image r cs e)) where - decode f _ = decodePPMs f fromNetpbmImageAuto +-- | Try to decode a Netpbm image sequence +-- +-- @since 0.2.0 +decodeNetpbmImageSequence :: + (FileFormat (Sequence f), ColorModel cs e, MonadThrow m) + => Sequence f + -> B.ByteString + -> m ([Image S cs e], Maybe B.ByteString) +decodeNetpbmImageSequence = decodePPMs fromNetpbmImage +-- | Try to decode a Netpbm image, while auto converting the colorspace. +-- +-- @since 0.2.0 +decodeAutoNetpbmImage :: + (FileFormat f, Mutable r Ix2 (Pixel cs e), MonadThrow m, ColorSpace cs i e) + => f + -> B.ByteString + -> m (Image r cs e, Maybe B.ByteString) +decodeAutoNetpbmImage = decodePPM fromNetpbmImageAuto +-- | Try to decode a Netpbm image sequence, while auto converting the colorspace. +-- +-- @since 0.2.0 +decodeAutoNetpbmImageSequence :: + (FileFormat (Sequence f), Mutable r Ix2 (Pixel cs e), MonadThrow m, ColorSpace cs i e) + => Auto (Sequence f) + -> B.ByteString + -> m ([Image r cs e], Maybe B.ByteString) +decodeAutoNetpbmImageSequence = decodePPMs fromNetpbmImageAuto -decodePPMs :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - f - -> (Netpbm.PPM -> Maybe (Image r cs e)) +decodePPMs :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorModel cs e, MonadThrow m) => + (Netpbm.PPM -> Maybe (Image r cs e)) + -> f -> B.ByteString - -> Array B Ix1 (Image r cs e) -decodePPMs f converter bs = - either (throw . DecodeError) (fromList Seq) $ - P.map (fromEitherDecode f showNetpbmCS converter . Right) . fst <$> - parsePPM bs + -> m ([Image r cs e], Maybe B.ByteString) +decodePPMs converter f bs = + case parsePPM bs of + Left err -> throwM $ DecodeError err + Right ([], Just _) -> throwM $ DecodeError "Cannot parse PNM image" + Right (ppms, leftOver) -> do + imgs <- P.traverse (fromMaybeDecode f showNetpbmCS converter) ppms + pure (imgs, leftOver) {-# INLINE decodePPMs #-} -decodePPM :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => - f - -> (Netpbm.PPM -> Maybe (Image r cs e)) +decodePPM :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorModel cs e, MonadThrow m) => + (Netpbm.PPM -> Maybe (Image r cs e)) + -> f -> B.ByteString - -> Image r cs e -decodePPM f decoder bs = fromEitherDecode f showNetpbmCS decoder $ do - (ppms, _) <- parsePPM bs - case ppms of - [] -> Left "Cannot parse PNM image" - (ppm:_) -> Right ppm + -> m (Image r cs e, Maybe B.ByteString) +decodePPM decoder f bs = + case parsePPM bs of + Left err -> throwM $ DecodeError err + Right ([], Nothing) -> throwM $ DecodeError "PNM image is empty" + Right ([], _) -> throwM $ DecodeError "Cannot parse PNM image" + Right (ppm:_, leftover) -> do + img <- fromMaybeDecode f showNetpbmCS decoder ppm + pure (img, leftover) {-# INLINE decodePPM #-} @@ -190,47 +169,128 @@ showNetpbmCS :: Netpbm.PPM -> String showNetpbmCS Netpbm.PPM {ppmData} = case ppmData of - PbmPixelData _ -> "Image S X Bit" + PbmPixelData _ -> "Image S Y Bit" PgmPixelData8 _ -> "Image S Y Word8" PgmPixelData16 _ -> "Image S Y Word16" PpmPixelDataRGB8 _ -> "Image S RGB Word8" PpmPixelDataRGB16 _ -> "Image S RGB Word16" + +instance Readable PBM (Image S CM.Y Bit) where + decodeWithMetadataM = decodeNetpbmImage +instance Readable PBM (Image S (Y D65) Bit) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + + +instance Readable (Sequence PBM) [Image S CM.Y Bit] where + decodeWithMetadataM = decodePPMs fromNetpbmImage +instance Readable (Sequence PBM) [Image S (Y D65) Bit] where + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f + + +instance Readable PGM (Image S CM.Y Word8) where + decodeWithMetadataM = decodeNetpbmImage +instance Readable PGM (Image S CM.Y Word16) where + decodeWithMetadataM = decodeNetpbmImage + + +instance Readable PGM (Image S (Y D65) Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f +instance Readable PGM (Image S (Y D65) Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + + +instance Readable (Sequence PGM) [Image S CM.Y Word8] where + decodeWithMetadataM = decodePPMs fromNetpbmImage +instance Readable (Sequence PGM) [Image S CM.Y Word16] where + decodeWithMetadataM = decodePPMs fromNetpbmImage + + +instance Readable (Sequence PGM) [Image S (Y D65) Word8] where + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f +instance Readable (Sequence PGM) [Image S (Y D65) Word16] where + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f + + +instance Readable PPM (Image S CM.RGB Word8) where + decodeWithMetadataM = decodeNetpbmImage +instance Readable PPM (Image S CM.RGB Word16) where + decodeWithMetadataM = decodeNetpbmImage + + +instance Readable PPM (Image S SRGB Word8) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f +instance Readable PPM (Image S SRGB Word16) where + decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f + + +instance Readable (Sequence PPM) [Image S CM.RGB Word8] where + decodeWithMetadataM = decodePPMs fromNetpbmImage +instance Readable (Sequence PPM) [Image S CM.RGB Word16] where + decodeWithMetadataM = decodePPMs fromNetpbmImage + + +instance Readable (Sequence PPM) [Image S SRGB Word8] where + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f +instance Readable (Sequence PPM) [Image S SRGB Word16] where + decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f + + fromNetpbmImage - :: forall cs e . ColorSpace cs e => + :: forall cs e . ColorModel cs e => Netpbm.PPM -> Maybe (Image S cs e) fromNetpbmImage Netpbm.PPM {..} = do let m = ppmHeight ppmHeader n = ppmWidth ppmHeader case ppmData of - PbmPixelData v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit) + PbmPixelData v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Bit) fromNetpbmImageUnsafe m n v - PgmPixelData8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8) + PgmPixelData8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word8) fromNetpbmImageUnsafe m n v - PgmPixelData16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16) + PgmPixelData16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word16) fromNetpbmImageUnsafe m n v - PpmPixelDataRGB8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8) + PpmPixelDataRGB8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8) fromNetpbmImageUnsafe m n v - PpmPixelDataRGB16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16) + PpmPixelDataRGB16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word16) fromNetpbmImageUnsafe m n v +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto PBM) (Image r cs e) where + decodeWithMetadataM = decodeAutoNetpbmImage +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto (Sequence PBM)) [Image r cs e] where + decodeWithMetadataM = decodeAutoNetpbmImageSequence + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto PGM) (Image r cs e) where + decodeWithMetadataM = decodeAutoNetpbmImage +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto (Sequence PGM)) [Image r cs e] where + decodeWithMetadataM = decodeAutoNetpbmImageSequence + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto PPM) (Image r cs e) where + decodeWithMetadataM = decodeAutoNetpbmImage +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => + Readable (Auto (Sequence PPM)) [Image r cs e] where + decodeWithMetadataM = decodeAutoNetpbmImageSequence + fromNetpbmImageAuto - :: forall cs e r . (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => + :: forall cs i e r . (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) => Netpbm.PPM -> Maybe (Image r cs e) fromNetpbmImageAuto Netpbm.PPM {..} = do let m = ppmHeight ppmHeader n = ppmWidth ppmHeader case ppmData of PbmPixelData v -> - (fromNetpbmImageUnsafe m n v :: Maybe (Image S X Bit)) >>= (toAnyCS . M.map fromPixelBinary) + compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S (Y D65) Bit)) PgmPixelData8 v -> - (fromNetpbmImageUnsafe m n v :: Maybe (Image S Y Word8)) >>= toAnyCS + compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S (Y D65) Word8)) PgmPixelData16 v -> - (fromNetpbmImageUnsafe m n v :: Maybe (Image S Y Word16)) >>= toAnyCS + compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S (Y D65) Word16)) PpmPixelDataRGB8 v -> - (fromNetpbmImageUnsafe m n v :: Maybe (Image S RGB Word8)) >>= toAnyCS + compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S SRGB Word8)) PpmPixelDataRGB16 v -> - (fromNetpbmImageUnsafe m n v :: Maybe (Image S RGB Word16)) >>= toAnyCS - + compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S SRGB Word16)) diff --git a/src/Graphics/ColorModel.hs b/src/Graphics/ColorModel.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorModel.hs @@ -0,0 +1,14 @@ +-- | +-- Module : Graphics.ColorModel +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorModel + ( -- * Re-export of pixles operating on ColorModel + module Graphics.Pixel + ) where + +import Graphics.Pixel diff --git a/src/Graphics/ColorSpace.hs b/src/Graphics/ColorSpace.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace.hs +++ /dev/null @@ -1,727 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 800 - {-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# LANGUAGE MonoLocalBinds #-} -#endif --- | --- Module : Graphics.ColorSpace --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace ( - -- * Pixels - -- ** Family of Pixels - -- | Pixel is a type family for all available color spaces. Below is the - -- listed of all class instances, that pixels are installed in, as well as all - -- pixel constructors. - -- - -- >>> :t (PixelY 0) -- Black pixel in Luma - -- (PixelY 0) :: Num e => Pixel Y e - -- >>> PixelRGB 255 0 0 :: Pixel RGB Word8 -- Red pixel in RGB - -- - -- >>> PixelRGB 1 0 0 :: Pixel RGB Double -- Same red pixel in RGB with Double precision. - -- - -- >>> (PixelRGB 255 0 0 :: Pixel RGB Word8) == (toWord8 <$> (PixelRGB 1 0 0 :: Pixel RGB Double)) - -- True - -- - Pixel(..) - , ColorSpace(..) - , AlphaSpace(..) - -- ** Luma (gray scale) - -- | Conversion to Luma from other color spaces. - , toPixelY - , toPixelYA - -- ** RGB - -- | Conversion to RGB from other color spaces. - , toPixelRGB - , toPixelRGBA - -- ** HSI - -- | Conversion to HSI from other color spaces. - , toPixelHSI - , toPixelHSIA - -- ** CMYK - -- | Conversion to CMYK from other color spaces. - , toPixelCMYK - , toPixelCMYKA - -- ** YCbCr - -- | Conversion to YCbCr from other color spaces. - , toPixelYCbCr - , toPixelYCbCrA - -- ** Binary - -- | This is a Binary colorspace, pixel's of which can be created using - -- these __/constructors/__: - -- - -- [@'on'@] Represents value @1@ or 'True'. It's a foreground pixel and is - -- displayed in black. - -- - -- [@'off'@] Represents value @0@ or 'False'. It's a background pixel and is - -- displayed in white. - -- - -- Note, that values are inverted before writing to or reading from file, since - -- grayscale images represent black as a @0@ value and white as @1@ on a - -- @[0,1]@ scale. - -- - -- Binary pixels also behave as binary numbers with a size of 1-bit, for instance: - -- - -- >>> on + on -- equivalent to: 1 .|. 1 - -- - -- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0 - -- - -- >>> (on + on) - on - -- - -- - , toPixelBinary - , fromPixelBinary - , module Graphics.ColorSpace.Binary - -- ** Complex - , module Graphics.ColorSpace.Complex - -- ** X - , toPixelsX - , fromPixelsX - -- * ColorSpace - -- ** Operations on Pixels - , eqTolPx - -- ** Luma - ,Y(..), YA(..), - ToY, ToYA, - -- ** RGB - RGB(..), RGBA(..), - ToRGB, ToRGBA, - -- ** HSI - HSI(..), HSIA(..), - ToHSI, ToHSIA, - -- ** CMYK - CMYK(..), CMYKA(..), - ToCMYK, ToCMYKA, - -- ** YCbCr - YCbCr(..), YCbCrA(..), - ToYCbCr, ToYCbCrA, - -- ** X - X(..), - -- * Precision - -- ** Pixel - Elevator(..), - toWord8, - toWord16, - toWord32, - toWord64, - toFloat, - toDouble, - fromDouble, - -- ** Componenet - Word8, Word16, Word32, Word64 - ) where - -import Data.Word -import Graphics.ColorSpace.Binary -import Graphics.ColorSpace.CMYK -import Graphics.ColorSpace.Complex -import Graphics.ColorSpace.HSI -import Graphics.ColorSpace.Internal -import Graphics.ColorSpace.RGB -import Graphics.ColorSpace.X -import Graphics.ColorSpace.Y -import Graphics.ColorSpace.YCbCr - - --- -- Binary: - --- | Convert to a `Binary` pixel. -toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel X Bit -toPixelBinary px = if px == 0 then on else off - - --- | Convert a Binary pixel to Luma pixel -fromPixelBinary :: Pixel X Bit -> Pixel Y Word8 -fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound -{-# INLINE fromPixelBinary #-} - - --- | Check weather two Pixels are equal within a tolerance. Useful for comparing --- pixels with `Float` or `Double` precision. -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 - {-# INLINE comp #-} -{-# INLINE eqTolPx #-} - --- ToY - --- | Conversion to Luma color space. -class ColorSpace cs e => ToY cs e where - - -- | Convert a pixel to Luma pixel. - toPixelY :: Pixel cs e -> Pixel Y Double - - -instance Elevator e => ToY X e where - toPixelY (PixelX y) = PixelY $ eToDouble y - {-# INLINE toPixelY #-} - -instance Elevator e => ToY Y e where - toPixelY (PixelY y) = PixelY $ eToDouble y - {-# INLINE toPixelY #-} - -instance Elevator e => ToY YA e where - toPixelY (PixelYA y _) = PixelY $ eToDouble y - {-# INLINE toPixelY #-} - --- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @ -instance Elevator e => ToY RGB e where - toPixelY (toDouble -> PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b) - {-# INLINE toPixelY #-} - -instance Elevator e => ToY RGBA e where - toPixelY = toPixelY . dropAlpha - {-# INLINE toPixelY #-} - -instance Elevator e => ToY HSI e where - toPixelY = toPixelY . toPixelRGB . toDouble - {-# INLINE toPixelY #-} - -instance Elevator e => ToY HSIA e where - toPixelY = toPixelY . dropAlpha - {-# INLINE toPixelY #-} - -instance Elevator e => ToY CMYK e where - toPixelY = toPixelY . toPixelRGB . toDouble - {-# INLINE toPixelY #-} - -instance Elevator e => ToY CMYKA e where - toPixelY = toPixelY . toPixelRGB . toDouble . dropAlpha - {-# INLINE toPixelY #-} - -instance Elevator e => ToY YCbCr e where - toPixelY (PixelYCbCr y _ _) = PixelY $ eToDouble y - {-# INLINE toPixelY #-} - -instance Elevator e => ToY YCbCrA e where - toPixelY (PixelYCbCrA y _ _ _) = PixelY $ eToDouble y - {-# INLINE toPixelY #-} - - --- ToYA - --- | Conversion to Luma from another color space. -class ToY cs e => ToYA cs e where - - -- | Convert a pixel to Luma pixel with Alpha. - toPixelYA :: Pixel cs e -> Pixel YA Double - toPixelYA = addAlpha 1 . toPixelY - {-# INLINE toPixelYA #-} - - -instance ToYA X Bit where - toPixelYA (PixelX y) = PixelYA (eToDouble y) 1 - {-# INLINE toPixelYA #-} - - -instance ToY Y e => ToYA Y e - -instance Elevator e => ToYA YA e where - toPixelYA = toDouble - {-# INLINE toPixelYA #-} - -instance ToY RGB e => ToYA RGB e - -instance Elevator e => ToYA RGBA e where - toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px)) - {-# INLINE toPixelYA #-} - -instance ToY HSI e => ToYA HSI e - -instance Elevator e => ToYA HSIA e where - toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px)) - {-# INLINE toPixelYA #-} - -instance ToY CMYK e => ToYA CMYK e - -instance Elevator e => ToYA CMYKA e where - toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px)) - {-# INLINE toPixelYA #-} - -instance ToY YCbCr e => ToYA YCbCr e - -instance Elevator e => ToYA YCbCrA e where - toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px)) - {-# INLINE toPixelYA #-} - --- ToRGB - - - --- | Conversion to `RGB` color space. -class ColorSpace cs e => ToRGB cs e where - - -- | Convert to an `RGB` pixel. - toPixelRGB :: Pixel cs e -> Pixel RGB Double - - -instance ToRGB X Bit where - toPixelRGB (PixelX b) = pure $ eToDouble b - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB Y e where - toPixelRGB (PixelY g) = pure $ eToDouble g - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB YA e where - toPixelRGB = toPixelRGB . dropAlpha - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB RGB e where - toPixelRGB = toDouble - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB RGBA e where - toPixelRGB = toDouble . dropAlpha - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB HSI e where - toPixelRGB (toDouble -> PixelHSI h' s i) = getRGB (h'*2*pi) where - !is = i*s - !second = i - is - errorHue = error $ "HSI pixel is not properly scaled, Hue: " ++ show h' - getFirst !a !b = i + is*cos a/cos b - {-# INLINE getFirst #-} - getThird !v1 !v2 = i + 2*is + v1 - v2 - {-# INLINE getThird #-} - getRGB h - | h < 0 = errorHue - | h < 2*pi/3 = let !r = getFirst h (pi/3 - h) - !b = second - !g = getThird b r - in PixelRGB r g b - | h < 4*pi/3 = let !g = getFirst (h - 2*pi/3) (h + pi) - !r = second - !b = getThird r g - in PixelRGB r g b - | h < 2*pi = let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h) - !g = second - !r = getThird g b - in PixelRGB r g b - | otherwise = errorHue - {-# INLINE getRGB #-} - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB HSIA e where - toPixelRGB = toPixelRGB . dropAlpha - {-# INLINE toPixelRGB #-} - - -instance Elevator e => ToRGB YCbCr e where - toPixelRGB (toDouble -> PixelYCbCr y cb cr) = PixelRGB r g b where - !r = clamp01 (y + 1.402*(cr - 0.5)) - !g = clamp01 (y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5)) - !b = clamp01 (y + 1.772*(cb - 0.5)) - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB YCbCrA e where - toPixelRGB = toPixelRGB . dropAlpha - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB CMYK e where - toPixelRGB (toDouble -> PixelCMYK c m y k) = PixelRGB r g b where - !r = (1-c)*(1-k) - !g = (1-m)*(1-k) - !b = (1-y)*(1-k) - {-# INLINE toPixelRGB #-} - -instance Elevator e => ToRGB CMYKA e where - toPixelRGB = toPixelRGB . dropAlpha - {-# INLINE toPixelRGB #-} - - --- ToRGBA - --- | Conversion to `RGBA` from another color space with Alpha channel. -class ToRGB cs e => ToRGBA cs e where - - -- | Convert to an `RGBA` pixel. - toPixelRGBA :: Pixel cs e -> Pixel RGBA Double - toPixelRGBA = addAlpha 1 . toPixelRGB - {-# INLINE toPixelRGBA #-} - - -instance ToRGBA X Bit - -instance ToRGB Y e => ToRGBA Y e - -instance Elevator e => ToRGBA YA e where - toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) - {-# INLINE toPixelRGBA #-} - -instance ToRGB RGB e => ToRGBA RGB e - -instance Elevator e => ToRGBA RGBA e where - toPixelRGBA = toDouble - {-# INLINE toPixelRGBA #-} - -instance ToRGB HSI e => ToRGBA HSI e - -instance Elevator e => ToRGBA HSIA e where - toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) - {-# INLINE toPixelRGBA #-} - -instance ToRGB CMYK e => ToRGBA CMYK e - -instance Elevator e => ToRGBA CMYKA e where - toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) - {-# INLINE toPixelRGBA #-} - -instance ToRGB YCbCr e => ToRGBA YCbCr e - -instance Elevator e => ToRGBA YCbCrA e where - toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) - {-# INLINE toPixelRGBA #-} - - --- ToHSI - --- | Conversion to `HSI` color space. -class ColorSpace cs e => ToHSI cs e where - - -- | Convert to an `HSI` pixel. - toPixelHSI :: Pixel cs e -> Pixel HSI Double - - -instance Elevator e => ToHSI Y e where - toPixelHSI (PixelY y) = PixelHSI 0 0 $ eToDouble y - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI YA e where - toPixelHSI = toPixelHSI . dropAlpha - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI RGB e where - toPixelHSI (toDouble -> PixelRGB r g b) = PixelHSI h s i where - !h' = atan2 y x - !h = (if h' < 0 then h' + 2*pi else h') / (2*pi) - !s = if i == 0 then 0 else 1 - minimum [r, g, b] / i - !i = (r + g + b) / 3 - !x = (2*r - g - b) / 2.449489742783178 - !y = (g - b) / 1.4142135623730951 - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI RGBA e where - toPixelHSI = toPixelHSI . dropAlpha - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI HSI e where - toPixelHSI = toDouble - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI HSIA e where - toPixelHSI = toPixelHSI . dropAlpha - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI YCbCr e where - toPixelHSI = toPixelHSI . toPixelRGB - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI YCbCrA e where - toPixelHSI = toPixelHSI . dropAlpha - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI CMYK e where - toPixelHSI = toPixelHSI . toPixelRGB - {-# INLINE toPixelHSI #-} - -instance Elevator e => ToHSI CMYKA e where - toPixelHSI = toPixelHSI . dropAlpha - {-# INLINE toPixelHSI #-} - - --- ToHSIA - --- | Conversion to `HSIA` from another color space with Alpha channel. -class ToHSI cs e => ToHSIA cs e where - - -- | Convert to an `HSIA` pixel. - toPixelHSIA :: Pixel cs e -> Pixel HSIA Double - toPixelHSIA = addAlpha 1 . toPixelHSI - {-# INLINE toPixelHSIA #-} - - -instance ToHSI Y e => ToHSIA Y e - -instance Elevator e => ToHSIA YA e where - toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) - {-# INLINE toPixelHSIA #-} - -instance ToHSI RGB e => ToHSIA RGB e - -instance Elevator e => ToHSIA RGBA e where - toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) - {-# INLINE toPixelHSIA #-} - -instance ToHSI HSI e => ToHSIA HSI e - -instance Elevator e => ToHSIA HSIA e where - toPixelHSIA = toDouble - {-# INLINE toPixelHSIA #-} - -instance ToHSI CMYK e => ToHSIA CMYK e - -instance Elevator e => ToHSIA CMYKA e where - toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) - {-# INLINE toPixelHSIA #-} - -instance ToHSI YCbCr e => ToHSIA YCbCr e - -instance Elevator e => ToHSIA YCbCrA e where - toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) - {-# INLINE toPixelHSIA #-} - - - --- ToCMYK - --- | Conversion to `CMYK` color space. -class ColorSpace cs e => ToCMYK cs e where - - -- | Convert to a `CMYK` pixel. - toPixelCMYK :: Pixel cs e -> Pixel CMYK Double - - -instance Elevator e => ToCMYK Y e where - toPixelCMYK = toPixelCMYK . toPixelRGB - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK YA e where - toPixelCMYK = toPixelCMYK . dropAlpha - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK RGB e where - toPixelCMYK (toDouble -> PixelRGB r g b) = PixelCMYK c m y k where - !c = (k' - r) / k' - !m = (k' - g) / k' - !y = (k' - b) / k' - !k = 1 - k' - !k' = max r (max g b) - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK RGBA e where - toPixelCMYK = toPixelCMYK . dropAlpha - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK HSI e where - toPixelCMYK = toPixelCMYK . toPixelRGB - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK HSIA e where - toPixelCMYK = toPixelCMYK . dropAlpha - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK CMYK e where - toPixelCMYK = toDouble - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK CMYKA e where - toPixelCMYK = toPixelCMYK . dropAlpha - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK YCbCr e where - toPixelCMYK = toPixelCMYK . toPixelRGB - {-# INLINE toPixelCMYK #-} - -instance Elevator e => ToCMYK YCbCrA e where - toPixelCMYK = toPixelCMYK . dropAlpha - {-# INLINE toPixelCMYK #-} - - --- ToCMYKA - --- | Conversion to `CMYKA`. -class ToCMYK cs e => ToCMYKA cs e where - - -- | Convert to a `CMYKA` pixel. - toPixelCMYKA :: Pixel cs e -> Pixel CMYKA Double - toPixelCMYKA = addAlpha 1 . toPixelCMYK - {-# INLINE toPixelCMYKA #-} - - -instance ToCMYK Y e => ToCMYKA Y e - -instance Elevator e => ToCMYKA YA e where - toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) - {-# INLINE toPixelCMYKA #-} - -instance ToCMYK RGB e => ToCMYKA RGB e - -instance Elevator e => ToCMYKA RGBA e where - toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) - {-# INLINE toPixelCMYKA #-} - -instance ToCMYK HSI e => ToCMYKA HSI e - -instance Elevator e => ToCMYKA HSIA e where - toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) - {-# INLINE toPixelCMYKA #-} - -instance ToCMYK CMYK e => ToCMYKA CMYK e - -instance Elevator e => ToCMYKA CMYKA e where - toPixelCMYKA = toDouble - {-# INLINE toPixelCMYKA #-} - -instance ToCMYK YCbCr e => ToCMYKA YCbCr e - -instance Elevator e => ToCMYKA YCbCrA e where - toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) - {-# INLINE toPixelCMYKA #-} - - - - --- ToYCbCr - --- | Conversion to `YCbCr` color space. -class ColorSpace cs e => ToYCbCr cs e where - - -- | Convert to an `YCbCr` pixel. - toPixelYCbCr :: Pixel cs e -> Pixel YCbCr Double - - - -instance Elevator e => ToYCbCr Y e where - toPixelYCbCr = toPixelYCbCr . toPixelRGB - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr YA e where - toPixelYCbCr = toPixelYCbCr . dropAlpha - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr RGB e where - toPixelYCbCr (toDouble -> PixelRGB r g b) = PixelYCbCr y cb cr where - !y = clamp01 ( 0.299*r + 0.587*g + 0.114*b) - !cb = clamp01 (0.5 - 0.168736*r - 0.331264*g + 0.5*b) - !cr = clamp01 (0.5 + 0.5*r - 0.418688*g - 0.081312*b) - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr RGBA e where - toPixelYCbCr = toPixelYCbCr . dropAlpha - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr HSI e where - toPixelYCbCr = toPixelYCbCr . toPixelRGB - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr HSIA e where - toPixelYCbCr = toPixelYCbCr . dropAlpha - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr YCbCr e where - toPixelYCbCr = toDouble - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr YCbCrA e where - toPixelYCbCr = toPixelYCbCr . dropAlpha - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr CMYK e where - toPixelYCbCr = toPixelYCbCr . toPixelRGB - {-# INLINE toPixelYCbCr #-} - -instance Elevator e => ToYCbCr CMYKA e where - toPixelYCbCr = toPixelYCbCr . dropAlpha - {-# INLINE toPixelYCbCr #-} - - --- ToYCbCrA - - --- | Conversion to `YCbCrA` from another color space with Alpha channel. -class ToYCbCr cs e => ToYCbCrA cs e where - - -- | Convert to an `YCbCrA` pixel. - toPixelYCbCrA :: Pixel cs e -> Pixel YCbCrA Double - toPixelYCbCrA = addAlpha 1 . toPixelYCbCr - {-# INLINE toPixelYCbCrA #-} - - -instance ToYCbCr Y e => ToYCbCrA Y e - -instance Elevator e => ToYCbCrA YA e where - toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) - {-# INLINE toPixelYCbCrA #-} - -instance ToYCbCr RGB e => ToYCbCrA RGB e - - -instance ToYCbCr HSI e => ToYCbCrA HSI e - -instance Elevator e => ToYCbCrA HSIA e where - toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) - {-# INLINE toPixelYCbCrA #-} - -instance Elevator e => ToYCbCrA RGBA e where - toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) - {-# INLINE toPixelYCbCrA #-} - -instance ToYCbCr CMYK e => ToYCbCrA CMYK e - -instance Elevator e => ToYCbCrA CMYKA e where - toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) - {-# INLINE toPixelYCbCrA #-} - -instance ToYCbCr YCbCr e => ToYCbCrA YCbCr e - -instance Elevator e => ToYCbCrA YCbCrA e where - toPixelYCbCrA = toDouble - {-# INLINE toPixelYCbCrA #-} - - --- | Change pixel precision to `Word8`. -toWord8 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word8 -toWord8 = fmap eToWord8 -{-# INLINABLE toWord8 #-} - - --- | Change pixel precision to `Word16`. -toWord16 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word16 -toWord16 = fmap eToWord16 -{-# INLINABLE toWord16 #-} - - --- | Change pixel precision to `Word32`. -toWord32 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word32 -toWord32 = fmap eToWord32 -{-# INLINABLE toWord32 #-} - - --- | Change pixel precision to `Word64`. -toWord64 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word64 -toWord64 = fmap eToWord64 -{-# INLINABLE toWord64 #-} - - --- | Change pixel precision to `Float`. -toFloat :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Float -toFloat = fmap eToFloat -{-# INLINABLE toFloat #-} - - --- | Change pixel precision to `Double`. -toDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Double -toDouble = fmap eToDouble -{-# INLINABLE toDouble #-} - - - --- | Change pixel precision from `Double`. -fromDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs Double -> Pixel cs e -fromDouble = fmap eFromDouble -{-# INLINABLE fromDouble #-} diff --git a/src/Graphics/ColorSpace/Binary.hs b/src/Graphics/ColorSpace/Binary.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/Binary.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.Binary --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.Binary ( - Bit, on, off, isOn, isOff, fromBool, zero, one, bit2bool, bool2bit, toNum, fromNum - ) where - -import Control.Monad -import Data.Bits -import Data.Typeable (Typeable) -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Unboxed as U -import Data.Word (Word8) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Graphics.ColorSpace.X -import Prelude hiding (map) - - --- | Under the hood, binary pixels are represented as `Word8`, but can only take --- values of @0@ or @1@. Use `zero`\/`one` to construct a bit and `on`\/`off` to --- construct a binary pixel. -newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable) - - -instance Show Bit where - show (Bit 0) = "0" - show _ = "1" - - -instance Bits Bit where - (Bit 0) .&. _ = Bit 0 - (Bit 1) .&. (Bit 1) = Bit 1 - _ .&. (Bit 0) = Bit 0 - _ .&. _ = Bit 1 - {-# INLINE (.&.) #-} - (Bit 1) .|. _ = Bit 1 - (Bit 0) .|. (Bit 0) = Bit 0 - _ .|. _ = Bit 1 - {-# INLINE (.|.) #-} - (Bit 0) `xor` (Bit 0) = Bit 0 - (Bit 1) `xor` (Bit 1) = Bit 0 - _ `xor` _ = Bit 1 - {-# INLINE xor #-} - complement (Bit 0) = Bit 1 - complement _ = Bit 0 - {-# INLINE complement #-} - shift !b 0 = b - shift _ _ = Bit 0 - {-# INLINE shift #-} - rotate !b _ = b - {-# INLINE rotate #-} - zeroBits = Bit 0 - {-# INLINE zeroBits #-} - bit 0 = Bit 1 - bit _ = Bit 0 - {-# INLINE bit #-} - testBit (Bit 1) 0 = True - testBit _ _ = False - {-# INLINE testBit #-} - bitSizeMaybe _ = Just 1 - {-# INLINE bitSizeMaybe #-} - bitSize _ = 1 - {-# INLINE bitSize #-} - isSigned _ = False - {-# INLINE isSigned #-} - popCount (Bit 0) = 0 - popCount _ = 1 - {-# INLINE popCount #-} - - -toNum :: Num a => Bit -> a -toNum (Bit 0) = 0 -toNum _ = 1 -{-# INLINE toNum #-} - -fromNum :: (Eq a, Num a) => a -> Bit -fromNum 0 = zero -fromNum _ = one -{-# INLINE fromNum #-} - - -zero :: Bit -zero = Bit 0 -{-# INLINE zero #-} - -one :: Bit -one = Bit 1 -{-# INLINE one #-} - -bool2bit :: Bool -> Bit -bool2bit False = zero -bool2bit True = one -{-# INLINE bool2bit #-} - -bit2bool :: Bit -> Bool -bit2bool (Bit 0) = False -bit2bool _ = True -{-# INLINE bit2bool #-} - --- | Represents value 'True' or @1@ in binary. Often also called a foreground --- pixel of an object. -on :: Pixel X Bit -on = PixelX one -{-# INLINE on #-} - - --- | Represents value 'False' or @0@ in binary. Often also called a background --- pixel. -off :: Pixel X Bit -off = PixelX zero -{-# INLINE off #-} - - --- | Convert a 'Bool' to a binary pixel. --- --- >>> isOn (fromBool True) --- True --- -fromBool :: Bool -> Pixel X Bit -fromBool False = off -fromBool True = on -{-# INLINE fromBool #-} - - --- | Test if Pixel's value is 'on'. -isOn :: Pixel X Bit -> Bool -isOn (PixelX (Bit 0)) = False -isOn _ = True -{-# INLINE isOn #-} - - --- | Test if Pixel's value is 'off'. -isOff :: Pixel X Bit -> Bool -isOff = not . isOn -{-# INLINE isOff #-} - - --- | Values: @0@ and @1@ -instance Elevator Bit where - eToWord8 (Bit 0) = 0 - eToWord8 _ = maxBound - {-# INLINE eToWord8 #-} - eToWord16 (Bit 0) = 0 - eToWord16 _ = maxBound - {-# INLINE eToWord16 #-} - eToWord32 (Bit 0) = 0 - eToWord32 _ = maxBound - {-# INLINE eToWord32 #-} - eToWord64 (Bit 0) = 0 - eToWord64 _ = maxBound - {-# INLINE eToWord64 #-} - eToFloat (Bit 0) = 0 - eToFloat _ = 1 - {-# INLINE eToFloat #-} - eToDouble (Bit 0) = 0 - eToDouble _ = 1 - {-# INLINE eToDouble #-} - eFromDouble 0 = Bit 0 - eFromDouble _ = Bit 1 - {-# INLINE eFromDouble #-} - - -instance Num Bit where - (+) = (.|.) - {-# INLINE (+) #-} - -- 0 - 0 = 0 - -- 0 - 1 = 0 - -- 1 - 0 = 1 - -- 1 - 1 = 0 - (Bit 0) - (Bit 0) = Bit 0 - _ - (Bit 0) = Bit 1 - _ - _ = Bit 0 - {-# INLINE (-) #-} - (*) = (.&.) - {-# INLINE (*) #-} - abs = id - {-# INLINE abs #-} - signum = id - {-# INLINE signum #-} - fromInteger 0 = Bit 0 - fromInteger _ = Bit 1 - {-# INLINE fromInteger #-} - - -instance Storable Bit where - - sizeOf _ = sizeOf (undefined :: Word8) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: Word8) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - b <- peek q - return (Bit b) - {-# INLINE peek #-} - poke !p (Bit b) = do - let !q = castPtr p - poke q b - {-# INLINE poke #-} - - --- | 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/ColorSpace/CMYK.hs b/src/Graphics/ColorSpace/CMYK.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/CMYK.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.CMYK --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.CMYK ( - CMYK(..), CMYKA(..), Pixel(..) - ) where - -import Data.Foldable -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Prelude hiding (map) - ------------- ---- CMYK --- ------------- - --- | Cyan, Magenta, Yellow and Black color space. -data CMYK = CyanCMYK -- ^ Cyan - | MagCMYK -- ^ Magenta - | YelCMYK -- ^ Yellow - | KeyCMYK -- ^ Key (Black) - deriving (Eq, Enum, Show, Bounded, Typeable) - - -instance Show e => Show (Pixel CMYK e) where - show (PixelCMYK c m y k) = "" - - -data instance Pixel CMYK e = PixelCMYK !e !e !e !e deriving (Eq, Ord) - -instance Elevator e => ColorSpace CMYK e where - type Components CMYK e = (e, e, e, e) - - fromComponents (c, m, y, k) = PixelCMYK c m y k - {-# INLINE fromComponents #-} - toComponents (PixelCMYK c m y k) = (c, m, y, k) - {-# INLINE toComponents #-} - getPxC (PixelCMYK c _ _ _) CyanCMYK = c - getPxC (PixelCMYK _ m _ _) MagCMYK = m - getPxC (PixelCMYK _ _ y _) YelCMYK = y - getPxC (PixelCMYK _ _ _ k) KeyCMYK = k - {-# INLINE setPxC #-} - setPxC (PixelCMYK _ m y k) CyanCMYK c = PixelCMYK c m y k - setPxC (PixelCMYK c _ y k) MagCMYK m = PixelCMYK c m y k - setPxC (PixelCMYK c m _ k) YelCMYK y = PixelCMYK c m y k - setPxC (PixelCMYK c m y _) KeyCMYK k = PixelCMYK c m y k - {-# INLINE getPxC #-} - mapPxC f (PixelCMYK c m y k) = - PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k) - {-# INLINE mapPxC #-} - foldlPx = foldl' - {-# INLINE foldlPx #-} - foldlPx2 f !z (PixelCMYK c1 m1 y1 k1) (PixelCMYK c2 m2 y2 k2) = - f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2 - {-# INLINE foldlPx2 #-} - - -instance Functor (Pixel CMYK) where - fmap f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k) - {-# INLINE fmap #-} - - -instance Applicative (Pixel CMYK) where - pure !e = PixelCMYK e e e e - {-# INLINE pure #-} - (PixelCMYK fc fm fy fk) <*> (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel CMYK) where - foldr f !z (PixelCMYK c m y k) = f c (f m (f y (f k z))) - {-# INLINE foldr #-} - - -instance Traversable (Pixel CMYK) where - traverse f (PixelCMYK c m y k) = PixelCMYK <$> f c <*> f m <*> f y <*> f k - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel CMYK e) where - - sizeOf _ = 4 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - c <- peek q - m <- peekElemOff q 1 - y <- peekElemOff q 2 - k <- peekElemOff q 3 - return $! PixelCMYK c m y k - {-# INLINE peek #-} - poke !p (PixelCMYK c m y k) = do - let !q = castPtr p - poke q c - pokeElemOff q 1 m - pokeElemOff q 2 y - pokeElemOff q 3 k - {-# INLINE poke #-} - -------------- ---- CMYKA --- -------------- - --- | Cyan, Magenta, Yellow and Black color space with Alpha channel. -data CMYKA = CyanCMYKA -- ^ Cyan - | MagCMYKA -- ^ Magenta - | YelCMYKA -- ^ Yellow - | KeyCMYKA -- ^ Key (Black) - | AlphaCMYKA -- ^ Alpha - deriving (Eq, Enum, Show, Bounded, Typeable) - - -data instance Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel CMYKA e) where - show (PixelCMYKA c m y k a) = - "" - - -instance Elevator e => ColorSpace CMYKA e where - type Components CMYKA e = (e, e, e, e, e) - - fromComponents (c, m, y, k, a) = PixelCMYKA c m y k a - {-# INLINE fromComponents #-} - toComponents (PixelCMYKA c m y k a) = (c, m, y, k, a) - {-# INLINE toComponents #-} - getPxC (PixelCMYKA c _ _ _ _) CyanCMYKA = c - getPxC (PixelCMYKA _ m _ _ _) MagCMYKA = m - getPxC (PixelCMYKA _ _ y _ _) YelCMYKA = y - getPxC (PixelCMYKA _ _ _ k _) KeyCMYKA = k - getPxC (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a - {-# INLINE getPxC #-} - setPxC (PixelCMYKA _ m y k a) CyanCMYKA c = PixelCMYKA c m y k a - setPxC (PixelCMYKA c _ y k a) MagCMYKA m = PixelCMYKA c m y k a - setPxC (PixelCMYKA c m _ k a) YelCMYKA y = PixelCMYKA c m y k a - setPxC (PixelCMYKA c m y _ a) KeyCMYKA k = PixelCMYKA c m y k a - setPxC (PixelCMYKA c m y k _) AlphaCMYKA a = PixelCMYKA c m y k a - {-# INLINE setPxC #-} - mapPxC f (PixelCMYKA c m y k a) = - PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelCMYKA c1 m1 y1 k1 a1) (PixelCMYKA c2 m2 y2 k2 a2) = - f (f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2) a1 a2 - {-# INLINE foldlPx2 #-} - - -instance Elevator e => AlphaSpace CMYKA e where - type Opaque CMYKA = CMYK - - getAlpha (PixelCMYKA _ _ _ _ a) = a - {-# INLINE getAlpha #-} - - addAlpha !a (PixelCMYK c m y k) = PixelCMYKA c m y k a - {-# INLINE addAlpha #-} - - dropAlpha (PixelCMYKA c m y k _) = PixelCMYK c m y k - {-# INLINE dropAlpha #-} - - -instance Functor (Pixel CMYKA) where - fmap f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a) - {-# INLINE fmap #-} - - -instance Applicative (Pixel CMYKA) where - pure !e = PixelCMYKA e e e e e - {-# INLINE pure #-} - (PixelCMYKA fc fm fy fk fa) <*> (PixelCMYKA c m y k a) = - PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a) - {-# INLINE (<*>) #-} - - -instance 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 Traversable (Pixel CMYKA) where - traverse f (PixelCMYKA c m y k a) = PixelCMYKA <$> f c <*> f m <*> f y <*> f k <*> f a - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel CMYKA e) where - - sizeOf _ = 5 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - c <- peek q - m <- peekElemOff q 1 - y <- peekElemOff q 2 - k <- peekElemOff q 3 - a <- peekElemOff q 4 - return $! PixelCMYKA c m y k a - {-# INLINE peek #-} - poke !p (PixelCMYKA c m y k a) = do - let !q = castPtr p - poke q c - pokeElemOff q 1 m - pokeElemOff q 2 y - pokeElemOff q 3 k - pokeElemOff q 4 a - {-# INLINE poke #-} diff --git a/src/Graphics/ColorSpace/Complex.hs b/src/Graphics/ColorSpace/Complex.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/Complex.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 800 - {-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif --- | --- Module : Graphics.ColorSpace.Complex --- Copyright : (c) Alexey Kuleshevich 2016-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.Complex ( - -- *** Rectangular form - Complex(..), (+:), realPart, imagPart, - -- *** Polar form - mkPolar, cis, polar, magnitude, phase, - -- *** Conjugate - conjugate - ) where - -import Control.Applicative -import Data.Complex (Complex(..)) -import qualified Data.Complex as C hiding (Complex(..)) -import Graphics.ColorSpace.Internal - - - -infix 6 +: - --- | Constrcut a complex pixel from two pixels representing real and imaginary parts. --- --- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @ --- -(+:) :: ColorSpace cs e => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) -(+:) = liftA2 (:+) -{-# INLINE (+:) #-} - --- | Extracts the real part of a complex pixel. -realPart :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e -realPart = fmap C.realPart -{-# INLINE realPart #-} - --- | Extracts the imaginary part of a complex pixel. -imagPart :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e -imagPart = fmap C.imagPart -{-# INLINE imagPart #-} - --- | Form a complex pixel from polar components of magnitude and phase. -mkPolar :: (ColorSpace cs e, RealFloat e) => - Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) -mkPolar = liftA2 C.mkPolar -{-# INLINE mkPolar #-} - --- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@). -cis :: (ColorSpace cs e, RealFloat e) => Pixel cs e -> Pixel cs (Complex e) -cis = fmap C.cis -{-# INLINE cis #-} - --- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase) --- pair of pixels in canonical form: the magnitude is nonnegative, and the phase --- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase. -polar :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e) -polar !zPx = (magnitude zPx, phase zPx) -{-# INLINE polar #-} - --- | The nonnegative magnitude of a complex pixel. -magnitude :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e -magnitude = fmap C.magnitude -{-# INLINE magnitude #-} - --- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the --- magnitude is zero, then so is the phase. -phase :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e -phase = fmap C.phase -{-# INLINE phase #-} - --- | The conjugate of a complex pixel. -conjugate :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e) -conjugate = fmap C.conjugate -{-# INLINE conjugate #-} - - diff --git a/src/Graphics/ColorSpace/Elevator.hs b/src/Graphics/ColorSpace/Elevator.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/Elevator.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 800 - {-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif --- | --- Module : Graphics.ColorSpace.Elevator --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.Elevator ( - Elevator(..) - , clamp01 - ) where - -import qualified Data.Complex as C -import Data.Int -import Data.Typeable -import Data.Vector.Storable (Storable) -import Data.Vector.Unboxed (Unbox) -import Data.Word -import GHC.Float - - --- | A class with a set of convenient functions that allow for changing precision of --- channels within pixels, while scaling the values to keep them in an appropriate range. --- --- >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double --- >>> eToWord8 <$> rgb --- --- >>> eToWord16 <$> rgb --- --- -class (Eq e, Num e, Typeable e, Unbox e, Storable e) => Elevator e where - - -- | Values are scaled to @[0, 255]@ range. - eToWord8 :: e -> Word8 - - -- | Values are scaled to @[0, 65535]@ range. - eToWord16 :: e -> Word16 - - -- | Values are scaled to @[0, 4294967295]@ range. - eToWord32 :: e -> Word32 - - -- | Values are scaled to @[0, 18446744073709551615]@ range. - eToWord64 :: e -> Word64 - - -- | Values are scaled to @[0.0, 1.0]@ range. - eToFloat :: e -> Float - - -- | Values are scaled to @[0.0, 1.0]@ range. - eToDouble :: e -> Double - - -- | Values are scaled from @[0.0, 1.0]@ range. - eFromDouble :: Double -> e - - --- | Lower the precision -dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b -dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div` - fromIntegral (maxBound :: b)) -{-# INLINE dropDown #-} - --- | Increase the precision -raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b -raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a)) -{-# INLINE raiseUp #-} - --- | Convert to fractional with value less than or equal to 1. -squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b -squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a) -{-# INLINE squashTo1 #-} - --- | Convert to integral streaching it's value up to a maximum value. -stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b -stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e) -{-# INLINE stretch #-} - - --- | Clamp a value to @[0, 1]@ range. -clamp01 :: (Ord a, Floating a) => a -> a -clamp01 !x = min (max 0 x) 1 -{-# INLINE clamp01 #-} - - --- | Values between @[0, 255]]@ -instance Elevator Word8 where - eToWord8 = id - {-# INLINE eToWord8 #-} - eToWord16 = raiseUp - {-# INLINE eToWord16 #-} - eToWord32 = raiseUp - {-# INLINE eToWord32 #-} - eToWord64 = raiseUp - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 - {-# INLINE eToDouble #-} - eFromDouble = eToWord8 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 65535]]@ -instance Elevator Word16 where - eToWord8 = dropDown - {-# INLINE eToWord8 #-} - eToWord16 = id - {-# INLINE eToWord16 #-} - eToWord32 = raiseUp - {-# INLINE eToWord32 #-} - eToWord64 = raiseUp - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 - {-# INLINE eToDouble #-} - eFromDouble = eToWord16 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 4294967295]@ -instance Elevator Word32 where - eToWord8 = dropDown - {-# INLINE eToWord8 #-} - eToWord16 = dropDown - {-# INLINE eToWord16 #-} - eToWord32 = id - {-# INLINE eToWord32 #-} - eToWord64 = raiseUp - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 - {-# INLINE eToDouble #-} - eFromDouble = eToWord32 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 18446744073709551615]@ -instance Elevator Word64 where - eToWord8 = dropDown - {-# INLINE eToWord8 #-} - eToWord16 = dropDown - {-# INLINE eToWord16 #-} - eToWord32 = dropDown - {-# INLINE eToWord32 #-} - eToWord64 = id - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 - {-# INLINE eToDouble #-} - eFromDouble = eToWord64 - {-# INLINE eFromDouble #-} - --- | Values between @[0, 18446744073709551615]@ on 64bit -instance Elevator Word where - eToWord8 = dropDown - {-# INLINE eToWord8 #-} - eToWord16 = dropDown - {-# INLINE eToWord16 #-} - eToWord32 = dropDown - {-# INLINE eToWord32 #-} - eToWord64 = fromIntegral - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 - {-# INLINE eToDouble #-} - eFromDouble = stretch . clamp01 - {-# INLINE eFromDouble #-} - --- | Values between @[0, 127]@ -instance Elevator Int8 where - eToWord8 = fromIntegral . max 0 - {-# INLINE eToWord8 #-} - eToWord16 = raiseUp . max 0 - {-# INLINE eToWord16 #-} - eToWord32 = raiseUp . max 0 - {-# INLINE eToWord32 #-} - eToWord64 = raiseUp . max 0 - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 . max 0 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 . max 0 - {-# INLINE eToDouble #-} - eFromDouble = stretch . clamp01 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 32767]@ -instance Elevator Int16 where - eToWord8 = dropDown . max 0 - {-# INLINE eToWord8 #-} - eToWord16 = fromIntegral . max 0 - {-# INLINE eToWord16 #-} - eToWord32 = raiseUp . max 0 - {-# INLINE eToWord32 #-} - eToWord64 = raiseUp . max 0 - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 . max 0 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 . max 0 - {-# INLINE eToDouble #-} - eFromDouble = stretch . clamp01 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 2147483647]@ -instance Elevator Int32 where - eToWord8 = dropDown . max 0 - {-# INLINE eToWord8 #-} - eToWord16 = dropDown . max 0 - {-# INLINE eToWord16 #-} - eToWord32 = fromIntegral . max 0 - {-# INLINE eToWord32 #-} - eToWord64 = raiseUp . max 0 - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 . max 0 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 . max 0 - {-# INLINE eToDouble #-} - eFromDouble = stretch . clamp01 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 9223372036854775807]@ -instance Elevator Int64 where - eToWord8 = dropDown . max 0 - {-# INLINE eToWord8 #-} - eToWord16 = dropDown . max 0 - {-# INLINE eToWord16 #-} - eToWord32 = dropDown . max 0 - {-# INLINE eToWord32 #-} - eToWord64 = fromIntegral . max 0 - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 . max 0 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 . max 0 - {-# INLINE eToDouble #-} - eFromDouble = stretch . clamp01 - {-# INLINE eFromDouble #-} - - --- | Values between @[0, 9223372036854775807]@ on 64bit -instance Elevator Int where - eToWord8 = dropDown . max 0 - {-# INLINE eToWord8 #-} - eToWord16 = dropDown . max 0 - {-# INLINE eToWord16 #-} - eToWord32 = dropDown . max 0 - {-# INLINE eToWord32 #-} - eToWord64 = fromIntegral . max 0 - {-# INLINE eToWord64 #-} - eToFloat = squashTo1 . max 0 - {-# INLINE eToFloat #-} - eToDouble = squashTo1 . max 0 - {-# INLINE eToDouble #-} - eFromDouble = stretch . clamp01 - {-# INLINE eFromDouble #-} - - --- | Values between @[0.0, 1.0]@ -instance Elevator Float where - eToWord8 = stretch . clamp01 - {-# INLINE eToWord8 #-} - eToWord16 = stretch . clamp01 - {-# INLINE eToWord16 #-} - eToWord32 = stretch . clamp01 - {-# INLINE eToWord32 #-} - eToWord64 = stretch . clamp01 - {-# INLINE eToWord64 #-} - eToFloat = id - {-# INLINE eToFloat #-} - eToDouble = float2Double - {-# INLINE eToDouble #-} - eFromDouble = eToFloat - {-# INLINE eFromDouble #-} - - --- | Values between @[0.0, 1.0]@ -instance Elevator Double where - eToWord8 = stretch . clamp01 - {-# INLINE eToWord8 #-} - eToWord16 = stretch . clamp01 - {-# INLINE eToWord16 #-} - eToWord32 = stretch . clamp01 - {-# INLINE eToWord32 #-} - eToWord64 = stretch . clamp01 - {-# INLINE eToWord64 #-} - eToFloat = double2Float - {-# INLINE eToFloat #-} - eToDouble = id - {-# INLINE eToDouble #-} - eFromDouble = id - {-# INLINE eFromDouble #-} - - --- | Discards imaginary part and changes precision of real part. -instance (Num e, Elevator e, RealFloat e) => Elevator (C.Complex e) where - eToWord8 = eToWord8 . C.realPart - {-# INLINE eToWord8 #-} - eToWord16 = eToWord16 . C.realPart - {-# INLINE eToWord16 #-} - eToWord32 = eToWord32 . C.realPart - {-# INLINE eToWord32 #-} - eToWord64 = eToWord64 . C.realPart - {-# INLINE eToWord64 #-} - eToFloat = eToFloat . C.realPart - {-# INLINE eToFloat #-} - eToDouble = eToDouble . C.realPart - {-# INLINE eToDouble #-} - eFromDouble = (C.:+ 0) . eFromDouble - {-# INLINE eFromDouble #-} diff --git a/src/Graphics/ColorSpace/HSI.hs b/src/Graphics/ColorSpace/HSI.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/HSI.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.HSI --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.HSI ( - HSI(..), HSIA(..), Pixel(..) - ) where - -import Data.Foldable -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Prelude hiding (map) - ------------ ---- HSI --- ------------ - --- | Hue, Saturation and Intensity color space. -data HSI = HueHSI -- ^ Hue - | SatHSI -- ^ Saturation - | IntHSI -- ^ Intensity - deriving (Eq, Enum, Show, Bounded, Typeable) - -data instance Pixel HSI e = PixelHSI !e !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel HSI e) where - show (PixelHSI h s i) = "" - - -instance Elevator e => ColorSpace HSI e where - type Components HSI e = (e, e, e) - - toComponents (PixelHSI h s i) = (h, s, i) - {-# INLINE toComponents #-} - fromComponents (h, s, i) = PixelHSI h s i - {-# INLINE fromComponents #-} - getPxC (PixelHSI h _ _) HueHSI = h - getPxC (PixelHSI _ s _) SatHSI = s - getPxC (PixelHSI _ _ i) IntHSI = i - {-# INLINE getPxC #-} - setPxC (PixelHSI _ s i) HueHSI h = PixelHSI h s i - setPxC (PixelHSI h _ i) SatHSI s = PixelHSI h s i - setPxC (PixelHSI h s _) IntHSI i = PixelHSI h s i - {-# INLINE setPxC #-} - mapPxC f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i) - {-# INLINE mapPxC #-} - foldlPx = foldl' - {-# INLINE foldlPx #-} - foldlPx2 f !z (PixelHSI h1 s1 i1) (PixelHSI h2 s2 i2) = - f (f (f z h1 h2) s1 s2) i1 i2 - {-# INLINE foldlPx2 #-} - - -instance Functor (Pixel HSI) where - fmap f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i) - {-# INLINE fmap #-} - - -instance Applicative (Pixel HSI) where - pure !e = PixelHSI e e e - {-# INLINE pure #-} - (PixelHSI fh fs fi) <*> (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel HSI) where - foldr f !z (PixelHSI h s i) = f h (f s (f i z)) - {-# INLINE foldr #-} - -instance Traversable (Pixel HSI) where - traverse f (PixelHSI h s i) = PixelHSI <$> f h <*> f s <*> f i - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel HSI e) where - - sizeOf _ = 3 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - h <- peek q - s <- peekElemOff q 1 - i <- peekElemOff q 2 - return $! PixelHSI h s i - {-# INLINE peek #-} - poke !p (PixelHSI h s i) = do - let !q = castPtr p - poke q h - pokeElemOff q 1 s - pokeElemOff q 2 i - {-# INLINE poke #-} - ------------- ---- HSIA --- ------------- - --- | Hue, Saturation and Intensity color space with Alpha channel. -data HSIA = HueHSIA -- ^ Hue - | SatHSIA -- ^ Saturation - | IntHSIA -- ^ Intensity - | AlphaHSIA -- ^ Alpha - deriving (Eq, Enum, Show, Bounded, Typeable) - - -data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel HSIA e) where - show (PixelHSIA h s i a) = "" - - -instance Elevator e => ColorSpace HSIA e where - type Components HSIA e = (e, e, e, e) - - toComponents (PixelHSIA h s i a) = (h, s, i, a) - {-# INLINE toComponents #-} - fromComponents (h, s, i, a) = PixelHSIA h s i a - {-# INLINE fromComponents #-} - getPxC (PixelHSIA h _ _ _) HueHSIA = h - getPxC (PixelHSIA _ s _ _) SatHSIA = s - getPxC (PixelHSIA _ _ i _) IntHSIA = i - getPxC (PixelHSIA _ _ _ a) AlphaHSIA = a - {-# INLINE getPxC #-} - setPxC (PixelHSIA _ s i a) HueHSIA h = PixelHSIA h s i a - setPxC (PixelHSIA h _ i a) SatHSIA s = PixelHSIA h s i a - setPxC (PixelHSIA h s _ a) IntHSIA i = PixelHSIA h s i a - setPxC (PixelHSIA h s i _) AlphaHSIA a = PixelHSIA h s i a - {-# INLINE setPxC #-} - mapPxC f (PixelHSIA h s i a) = - PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelHSIA h1 s1 i1 a1) (PixelHSIA h2 s2 i2 a2) = - f (f (f (f z h1 h2) s1 s2) i1 i2) a1 a2 - {-# INLINE foldlPx2 #-} - - -instance Elevator e => AlphaSpace HSIA e where - type Opaque HSIA = HSI - - getAlpha (PixelHSIA _ _ _ a) = a - {-# INLINE getAlpha #-} - addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a - {-# INLINE addAlpha #-} - dropAlpha (PixelHSIA h s i _) = PixelHSI h s i - {-# INLINE dropAlpha #-} - - -instance Functor (Pixel HSIA) where - fmap f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a) - {-# INLINE fmap #-} - - -instance Applicative (Pixel HSIA) where - pure !e = PixelHSIA e e e e - {-# INLINE pure #-} - (PixelHSIA fh fs fi fa) <*> (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a) - {-# INLINE (<*>) #-} - - -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 Traversable (Pixel HSIA) where - traverse f (PixelHSIA h s i a) = PixelHSIA <$> f h <*> f s <*> f i <*> f a - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel HSIA e) where - sizeOf _ = 4 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - h <- peek q - s <- peekElemOff q 1 - i <- peekElemOff q 2 - a <- peekElemOff q 3 - return $! PixelHSIA h s i a - {-# INLINE peek #-} - poke !p (PixelHSIA h s i a) = do - let !q = castPtr p - poke q h - pokeElemOff q 1 s - pokeElemOff q 2 i - pokeElemOff q 3 a - {-# INLINE poke #-} diff --git a/src/Graphics/ColorSpace/Internal.hs b/src/Graphics/ColorSpace/Internal.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/Internal.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.Internal --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.Internal - ( Pixel - , ColorSpace(..) - , AlphaSpace(..) - , module Graphics.ColorSpace.Elevator - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf), deepseq) -import Control.Monad (liftM) -import Data.Default.Class (Default(..)) -import Data.Foldable -import Data.Typeable -import qualified Data.Vector.Generic as V -import qualified Data.Vector.Generic.Mutable as VM -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU -import Graphics.ColorSpace.Elevator - - --- | 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, - Functor (Pixel cs), Applicative (Pixel cs), Foldable (Pixel cs), Traversable (Pixel cs), - Eq (Pixel cs e), VU.Unbox (Components cs e), VS.Storable (Pixel cs e), Elevator e) - => ColorSpace cs e where - - type Components cs e - - -- | Convert a Pixel to a representation suitable for storage as an unboxed - -- element, usually a tuple of channels. - toComponents :: Pixel cs e -> Components cs e - - -- | Convert from an elemnt representation back to a Pixel. - fromComponents :: Components cs e -> Pixel cs e - - -- | Construt a Pixel by replicating the same value across all of the components. - promote :: e -> Pixel cs e - promote = pure - {-# INLINE promote #-} - - -- | Retrieve Pixel's component value - getPxC :: Pixel cs e -> cs -> e - - -- | Set Pixel's component value - setPxC :: Pixel cs e -> cs -> e -> Pixel cs e - - -- | Map a channel aware function over all Pixel's components. - mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e - - -- | Left fold on two pixels a the same time. If accumulator is nutrual to the folding funciton - -- then it's equivalent to @foldlPx2 f acc px1 px2 == foldl' acc (liftA2 (f acc) px1 px2)@ - foldlPx2 :: (b -> e -> e -> b) -> b -> Pixel cs e -> Pixel cs e -> b - - -- | Map a function over all Pixel's componenets. - liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e - liftPx = fmap - {-# INLINE liftPx #-} - - -- | Zip two Pixels with a function. - liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e - liftPx2 = liftA2 - {-# INLINE liftPx2 #-} - - -- | Right fold over all Pixel's components. - foldrPx :: (e -> b -> b) -> b -> Pixel cs e -> b - foldrPx = foldr' - {-# INLINE foldrPx #-} - - -- | Left strict fold over all Pixel's components. - foldlPx :: (b -> e -> b) -> b -> Pixel cs e -> b - foldlPx = foldl' - {-# INLINE foldlPx #-} - - foldl1Px :: (e -> e -> e) -> Pixel cs e -> e - foldl1Px = foldl1 - {-# INLINE foldl1Px #-} - -{-# DEPRECATED liftPx "Use `fmap` from `Functor` instead" #-} -{-# DEPRECATED liftPx2 "Use `liftA2` from `Applicative` instead" #-} -{-# DEPRECATED promote "Use `pure` from `Applicative` instead" #-} -{-# DEPRECATED foldlPx "Use `foldl'` from `Foldable` instead" #-} -{-# DEPRECATED foldrPx "Use `foldr'` from `Foldable` instead" #-} -{-# DEPRECATED foldl1Px "Use `foldl1` from `Foldable` instead" #-} - --- | A color space that supports transparency. -class (ColorSpace (Opaque cs) e, ColorSpace cs e) => AlphaSpace cs e where - -- | A corresponding opaque version of this color space. - type Opaque cs - - -- | Get an alpha channel of a transparant pixel. - getAlpha :: Pixel cs e -> e - - -- | Add an alpha channel to an opaque pixel. - -- - -- @ addAlpha 0 (PixelHSI 1 2 3) == PixelHSIA 1 2 3 0 @ - addAlpha :: e -> Pixel (Opaque cs) e -> Pixel cs e - - -- | Convert a transparent pixel to an opaque one by dropping the alpha - -- channel. - -- - -- @ dropAlpha (PixelRGBA 1 2 3 4) == PixelRGB 1 2 3 @ - -- - dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e - -instance ColorSpace cs e => Default (Pixel cs e) where - - def = pure 0 - {-# INLINE def #-} - - -instance ColorSpace cs e => Num (Pixel cs e) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - - -instance (ColorSpace cs e, Fractional e) => Fractional (Pixel cs e) where - (/) = liftA2 (/) - {-# INLINE (/) #-} - recip = fmap recip - {-# INLINE recip #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - - -instance (ColorSpace cs e, Floating e) => Floating (Pixel cs e) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - log = fmap log - {-# INLINE log #-} - sin = fmap sin - {-# INLINE sin #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance (ColorSpace cs e, Bounded e) => Bounded (Pixel cs e) where - maxBound = pure maxBound - {-# INLINE maxBound #-} - minBound = pure minBound - {-# INLINE minBound #-} - -instance (ColorSpace cs e, NFData e) => NFData (Pixel cs e) where - - rnf = foldr' deepseq () - {-# INLINE rnf #-} - - --- | Unboxing of a `Pixel`. -instance ColorSpace cs e => VU.Unbox (Pixel cs e) - -newtype instance VU.MVector s (Pixel cs e) = MV_Pixel (VU.MVector s (Components cs e)) - -instance ColorSpace cs e => VM.MVector VU.MVector (Pixel cs e) where - basicLength (MV_Pixel mvec) = VM.basicLength mvec - {-# INLINE basicLength #-} - basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (VM.basicUnsafeSlice idx len mvec) - {-# INLINE basicUnsafeSlice #-} - basicOverlaps (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicOverlaps mvec mvec' - {-# INLINE basicOverlaps #-} - basicUnsafeNew len = MV_Pixel `liftM` VM.basicUnsafeNew len - {-# INLINE basicUnsafeNew #-} - basicUnsafeReplicate len val = MV_Pixel `liftM` VM.basicUnsafeReplicate len (toComponents val) - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeRead (MV_Pixel mvec) idx = fromComponents `liftM` VM.basicUnsafeRead mvec idx - {-# INLINE basicUnsafeRead #-} - basicUnsafeWrite (MV_Pixel mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents val) - {-# INLINE basicUnsafeWrite #-} - basicClear (MV_Pixel mvec) = VM.basicClear mvec - {-# INLINE basicClear #-} - basicSet (MV_Pixel mvec) val = VM.basicSet mvec (toComponents val) - {-# INLINE basicSet #-} - basicUnsafeCopy (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeCopy mvec mvec' - {-# INLINE basicUnsafeCopy #-} - basicUnsafeMove (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeMove mvec mvec' - {-# INLINE basicUnsafeMove #-} - basicUnsafeGrow (MV_Pixel mvec) len = MV_Pixel `liftM` VM.basicUnsafeGrow mvec len - {-# INLINE basicUnsafeGrow #-} -#if MIN_VERSION_vector(0,11,0) - basicInitialize (MV_Pixel mvec) = VM.basicInitialize mvec - {-# INLINE basicInitialize #-} -#endif - - -newtype instance VU.Vector (Pixel cs e) = V_Pixel (VU.Vector (Components cs e)) - -instance (ColorSpace cs e) => V.Vector VU.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 - {-# INLINE basicUnsafeThaw #-} - basicLength (V_Pixel vec) = V.basicLength vec - {-# INLINE basicLength #-} - basicUnsafeSlice idx len (V_Pixel vec) = V_Pixel (V.basicUnsafeSlice idx len vec) - {-# INLINE basicUnsafeSlice #-} - basicUnsafeIndexM (V_Pixel vec) idx = fromComponents `liftM` V.basicUnsafeIndexM vec idx - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeCopy (MV_Pixel mvec) (V_Pixel vec) = V.basicUnsafeCopy mvec vec - {-# INLINE basicUnsafeCopy #-} - elemseq (V_Pixel vec) val = V.elemseq vec (toComponents val) - {-# INLINE elemseq #-} diff --git a/src/Graphics/ColorSpace/RGB.hs b/src/Graphics/ColorSpace/RGB.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/RGB.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.RGB --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.RGB ( - RGB(..), RGBA(..), Pixel(..) - ) where - -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Prelude hiding (map) - ------------ ---- RGB --- ------------ - --- | Red, Green and Blue color space. -data RGB = RedRGB - | GreenRGB - | BlueRGB deriving (Eq, Enum, Show, Bounded, Typeable) - - -data instance Pixel RGB e = PixelRGB !e !e !e deriving (Eq, Ord) - -instance Show e => Show (Pixel RGB e) where - show (PixelRGB r g b) = "" - - -instance Elevator e => ColorSpace RGB e where - type Components RGB e = (e, e, e) - - toComponents (PixelRGB r g b) = (r, g, b) - {-# INLINE toComponents #-} - fromComponents (r, g, b) = PixelRGB r g b - {-# INLINE fromComponents #-} - getPxC (PixelRGB r _ _) RedRGB = r - getPxC (PixelRGB _ g _) GreenRGB = g - getPxC (PixelRGB _ _ b) BlueRGB = b - {-# INLINE getPxC #-} - setPxC (PixelRGB _ g b) RedRGB r = PixelRGB r g b - setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b - setPxC (PixelRGB r g _) BlueRGB b = PixelRGB r g b - {-# INLINE setPxC #-} - mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelRGB r1 g1 b1) (PixelRGB r2 g2 b2) = - f (f (f z r1 r2) g1 g2) b1 b2 - {-# INLINE foldlPx2 #-} - - -instance Functor (Pixel RGB) where - fmap f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b) - {-# INLINE fmap #-} - - -instance Applicative (Pixel RGB) where - pure !e = PixelRGB e e e - {-# INLINE pure #-} - (PixelRGB fr fg fb) <*> (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel RGB) where - foldr f !z (PixelRGB r g b) = f r (f g (f b z)) - {-# INLINE foldr #-} - - -instance Traversable (Pixel RGB) where - traverse f (PixelRGB r g b) = PixelRGB <$> f r <*> f g <*> f b - {-# INLINE traverse #-} - -instance Storable e => Storable (Pixel RGB e) where - sizeOf _ = 3 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - r <- peek q - g <- peekElemOff q 1 - b <- peekElemOff q 2 - return $! PixelRGB r g b - {-# INLINE peek #-} - poke !p (PixelRGB r g b) = do - let !q = castPtr p - poke q r - pokeElemOff q 1 g - pokeElemOff q 2 b - {-# INLINE poke #-} - - ------------- ---- RGBA --- ------------- - - --- | Red, Green and Blue color space with Alpha channel. -data RGBA = RedRGBA - | GreenRGBA - | BlueRGBA - | AlphaRGBA deriving (Eq, Enum, Show, Bounded, Typeable) - -data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel RGBA e) where - show (PixelRGBA r g b a) = "" - - -instance Elevator e => ColorSpace RGBA e where - type Components RGBA e = (e, e, e, e) - - toComponents (PixelRGBA r g b a) = (r, g, b, a) - {-# INLINE toComponents #-} - fromComponents (r, g, b, a) = PixelRGBA r g b a - {-# INLINE fromComponents #-} - getPxC (PixelRGBA r _ _ _) RedRGBA = r - getPxC (PixelRGBA _ g _ _) GreenRGBA = g - getPxC (PixelRGBA _ _ b _) BlueRGBA = b - getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a - {-# INLINE getPxC #-} - setPxC (PixelRGBA _ g b a) RedRGBA r = PixelRGBA r g b a - setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a - setPxC (PixelRGBA r g _ a) BlueRGBA b = PixelRGBA r g b a - setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a - {-# INLINE setPxC #-} - mapPxC f (PixelRGBA r g b a) = - PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelRGBA r1 g1 b1 a1) (PixelRGBA r2 g2 b2 a2) = - f (f (f (f z r1 r2) g1 g2) b1 b2) a1 a2 - {-# INLINE foldlPx2 #-} - - -instance Elevator e => AlphaSpace RGBA e where - type Opaque RGBA = RGB - - getAlpha (PixelRGBA _ _ _ a) = a - {-# INLINE getAlpha #-} - addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a - {-# INLINE addAlpha #-} - dropAlpha (PixelRGBA r g b _) = PixelRGB r g b - {-# INLINE dropAlpha #-} - - -instance Functor (Pixel RGBA) where - fmap f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a) - {-# INLINE fmap #-} - -instance Applicative (Pixel RGBA) where - pure !e = PixelRGBA e e e e - {-# INLINE pure #-} - (PixelRGBA fr fg fb fa) <*> (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a) - {-# INLINE (<*>) #-} - -instance Foldable (Pixel RGBA) where - foldr f !z (PixelRGBA r g b a) = f r (f g (f b (f a z))) - {-# INLINE foldr #-} - -instance Traversable (Pixel RGBA) where - traverse f (PixelRGBA r g b a) = PixelRGBA <$> f r <*> f g <*> f b <*> f a - {-# INLINE traverse #-} - -instance Storable e => Storable (Pixel RGBA e) where - sizeOf _ = 4 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek p = do - let q = castPtr p - r <- peek q - g <- peekElemOff q 1 - b <- peekElemOff q 2 - a <- peekElemOff q 3 - return $! PixelRGBA r g b a - {-# INLINE peek #-} - poke p (PixelRGBA r g b a) = do - let q = castPtr p - poke q r - pokeElemOff q 1 g - pokeElemOff q 2 b - pokeElemOff q 3 a - {-# INLINE poke #-} diff --git a/src/Graphics/ColorSpace/X.hs b/src/Graphics/ColorSpace/X.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/X.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.X --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.X - ( X(..) - , Pixel(..) - , toPixelsX - , fromPixelsX - ) where - -import Data.Bits (Bits) -import Data.Foldable -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Prelude as P - --- | This is a single channel colorspace, that is designed to separate Gray --- level values from other types of colorspace, hence it is not convertible to --- or from, but rather is here to allow operation on arbirtary single channel --- images. If you are looking for the actual grayscale color space. --- 'Graphics.ColorSpace.Luma.Y' should be used instead. -data X = X deriving (Eq, Enum, Bounded, Show, Typeable) - - -newtype instance Pixel X e = PixelX - { getX :: e - } deriving (Ord, Eq, Enum, Bounded, Real, Integral, RealFrac, RealFloat, Bits) - - -instance Show e => Show (Pixel X e) where - show (PixelX g) = "" - - -instance Elevator e => ColorSpace X e where - type Components X e = e - - fromComponents = PixelX - {-# INLINE fromComponents #-} - toComponents (PixelX g) = g - {-# INLINE toComponents #-} - getPxC (PixelX g) X = g - {-# INLINE getPxC #-} - setPxC (PixelX _) X = PixelX - {-# INLINE setPxC #-} - mapPxC f (PixelX g) = PixelX (f X g) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelX g1) (PixelX g2) = f z g1 g2 - {-# INLINE foldlPx2 #-} - - -instance Functor (Pixel X) where - fmap f (PixelX g) = PixelX (f g) - {-# INLINE fmap #-} - - -instance Applicative (Pixel X) where - pure = PixelX - {-# INLINE pure #-} - (PixelX fg) <*> (PixelX g) = PixelX (fg g) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel X) where - foldr f !z (PixelX g) = f g z - {-# INLINE foldr #-} - - -instance Traversable (Pixel X) where - traverse f (PixelX x) = PixelX <$> f x - {-# INLINE traverse #-} - - -instance Monad (Pixel X) where - return = PixelX - {-# INLINE return #-} - (>>=) (PixelX g) f = f g - {-# INLINE (>>=) #-} - - -instance Storable e => Storable (Pixel X e) where - - sizeOf _ = sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let q = castPtr p - g <- peek q - return (PixelX g) - {-# INLINE peek #-} - poke !p (PixelX g) = do - let q = castPtr p - poke q g - {-# INLINE poke #-} - - --- | Separate a Pixel into a list of components with 'X' pixels containing every --- component from the pixel. --- --- >>> toPixelsX (PixelRGB 4 5 6) --- [,,] --- -toPixelsX :: ColorSpace cs e => Pixel cs e -> [Pixel X e] -toPixelsX = fmap PixelX . toList - --- | Combine a list of `X` pixels into a Pixel with a specified channel --- order. Not the most efficient way to construct a pixel, but might prove --- useful to someone. --- --- >>> fromPixelsX [(RedRGB, 3), (BlueRGB, 5), (GreenRGB, 4)] --- --- >>> fromPixelsX $ zip (enumFrom RedRGB) (toPixelsX $ PixelRGB 4 5 6) --- --- -fromPixelsX :: ColorSpace cs e => [(cs, Pixel X e)] -> Pixel cs e -fromPixelsX = foldl' f (pure 0) where - f !px (c, PixelX x) = setPxC px c x diff --git a/src/Graphics/ColorSpace/Y.hs b/src/Graphics/ColorSpace/Y.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/Y.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.Y --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.Y ( - Y(..), YA(..), Pixel(..) - ) where - -import Data.Foldable -import Data.Bits (Bits) -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Prelude hiding (map) - ---------- ---- Y --- ---------- - --- | Luma or brightness, which is usually denoted as @Y'@. -data Y = LumaY deriving (Eq, Enum, Show, Bounded, Typeable) - - -newtype instance Pixel Y e = PixelY e - deriving (Ord, Eq, Enum, Bounded, Real, Integral, RealFrac, RealFloat, Bits) - -instance Show e => Show (Pixel Y e) where - show (PixelY g) = "" - -instance Elevator e => ColorSpace Y e where - type Components Y e = e - fromComponents = PixelY - {-# INLINE fromComponents #-} - toComponents (PixelY y) = y - {-# INLINE toComponents #-} - getPxC (PixelY y) LumaY = y - {-# INLINE getPxC #-} - setPxC _ LumaY = PixelY - {-# INLINE setPxC #-} - mapPxC f (PixelY y) = PixelY (f LumaY y) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelY y1) (PixelY y2) = f z y1 y2 - {-# INLINE foldlPx2 #-} - - -instance Functor (Pixel Y) where - fmap f (PixelY y) = PixelY (f y) - {-# INLINE fmap #-} - - -instance Applicative (Pixel Y) where - pure = PixelY - {-# INLINE pure #-} - (PixelY fy) <*> (PixelY y) = PixelY (fy y) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel Y) where - foldr f !z (PixelY y) = f y z - {-# INLINE foldr #-} - - -instance Traversable (Pixel Y) where - traverse f (PixelY y) = PixelY <$> f y - {-# INLINE traverse #-} - - -instance Monad (Pixel Y) where - return = PixelY - {-# INLINE return #-} - (>>=) (PixelY y) f = f y - {-# INLINE (>>=) #-} - - - -instance Storable e => Storable (Pixel Y e) where - - sizeOf _ = sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let !q = castPtr p - y <- peek q - return (PixelY y) - {-# INLINE peek #-} - poke !p (PixelY y) = let !q = castPtr p in poke q y - {-# INLINE poke #-} - - - - ----------- ---- YA --- ----------- - --- | Luma with Alpha channel. -data YA = LumaYA -- ^ Luma - | AlphaYA -- ^ Alpha channel - deriving (Eq, Enum, Show, Bounded, Typeable) - -data instance Pixel YA e = PixelYA !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel YA e) where - show (PixelYA y a) = "" - - -instance Elevator e => ColorSpace YA e where - type Components YA e = (e, e) - fromComponents (y, a) = PixelYA y a - {-# INLINE fromComponents #-} - toComponents (PixelYA y a) = (y, a) - {-# INLINE toComponents #-} - getPxC (PixelYA y _) LumaYA = y - getPxC (PixelYA _ a) AlphaYA = a - {-# INLINE getPxC #-} - setPxC (PixelYA _ a) LumaYA y = PixelYA y a - setPxC (PixelYA y _) AlphaYA a = PixelYA y a - {-# INLINE setPxC #-} - mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2 - {-# INLINE foldlPx2 #-} - - -instance Elevator e => AlphaSpace YA e where - type Opaque YA = Y - - getAlpha (PixelYA _ a) = a - {-# INLINE getAlpha #-} - addAlpha !a (PixelY y) = PixelYA y a - {-# INLINE addAlpha #-} - dropAlpha (PixelYA y _) = PixelY y - {-# INLINE dropAlpha #-} - - -instance Functor (Pixel YA) where - fmap f (PixelYA y a) = PixelYA (f y) (f a) - {-# INLINE fmap #-} - - -instance Applicative (Pixel YA) where - pure !e = PixelYA e e - {-# INLINE pure #-} - (PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel YA) where - foldr f !z (PixelYA y a) = f y (f a z) - {-# INLINE foldr #-} - - -instance Traversable (Pixel YA) where - traverse f (PixelYA y a) = PixelYA <$> f y <*> f a - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel YA e) where - - sizeOf _ = 2 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let q = castPtr p - y <- peekElemOff q 0 - a <- peekElemOff q 1 - return $! PixelYA y a - {-# INLINE peek #-} - poke !p (PixelYA y a) = do - let q = castPtr p - pokeElemOff q 0 y - pokeElemOff q 1 a - {-# INLINE poke #-} - diff --git a/src/Graphics/ColorSpace/YCbCr.hs b/src/Graphics/ColorSpace/YCbCr.hs deleted file mode 100644 --- a/src/Graphics/ColorSpace/YCbCr.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Graphics.ColorSpace.YCbCr --- Copyright : (c) Alexey Kuleshevich 2018-2019 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.ColorSpace.YCbCr ( - YCbCr(..), YCbCrA(..), Pixel(..) - ) where - -import Data.Foldable -import Data.Typeable (Typeable) -import Foreign.Ptr -import Foreign.Storable -import Graphics.ColorSpace.Internal -import Prelude hiding (map) - -------------- ---- YCbCr --- -------------- - - --- | Color space is used to encode RGB information and is used in JPEG compression. -data YCbCr = LumaYCbCr -- ^ Luma component (commonly denoted as __Y'__) - | CBlueYCbCr -- ^ Blue difference chroma component - | CRedYCbCr -- ^ Red difference chroma component - deriving (Eq, Enum, Show, Bounded, Typeable) - -data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel YCbCr e) where - show (PixelYCbCr y b r) = "" - - -instance Elevator e => ColorSpace YCbCr e where - type Components YCbCr e = (e, e, e) - - fromComponents (y, b, r) = PixelYCbCr y b r - {-# INLINE fromComponents #-} - toComponents (PixelYCbCr y b r) = (y, b, r) - {-# INLINE toComponents #-} - getPxC (PixelYCbCr y _ _) LumaYCbCr = y - getPxC (PixelYCbCr _ b _) CBlueYCbCr = b - getPxC (PixelYCbCr _ _ r) CRedYCbCr = r - {-# INLINE getPxC #-} - setPxC (PixelYCbCr _ b r) LumaYCbCr y = PixelYCbCr y b r - setPxC (PixelYCbCr y _ r) CBlueYCbCr b = PixelYCbCr y b r - setPxC (PixelYCbCr y b _) CRedYCbCr r = PixelYCbCr y b r - {-# INLINE setPxC #-} - mapPxC f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelYCbCr y1 b1 r1) (PixelYCbCr y2 b2 r2) = - f (f (f z y1 y2) b1 b2) r1 r2 - {-# INLINE foldlPx2 #-} - - -instance Functor (Pixel YCbCr) where - fmap f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r) - {-# INLINE fmap #-} - - -instance Applicative (Pixel YCbCr) where - pure !e = PixelYCbCr e e e - {-# INLINE pure #-} - (PixelYCbCr fy fb fr) <*> (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel YCbCr) where - foldr f !z (PixelYCbCr y b r) = f y (f b (f r z)) - {-# INLINE foldr #-} - - -instance Traversable (Pixel YCbCr) where - traverse f (PixelYCbCr y b r) = PixelYCbCr <$> f y <*> f b <*> f r - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel YCbCr e) where - - sizeOf _ = 3 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let q = castPtr p - y <- peek q - b <- peekElemOff q 1 - r <- peekElemOff q 2 - return $! PixelYCbCr y b r - {-# INLINE poke #-} - poke !p (PixelYCbCr y b r) = do - let q = castPtr p - pokeElemOff q 0 y - pokeElemOff q 1 b - pokeElemOff q 2 r - {-# INLINE peek #-} - - --------------- ---- YCbCrA --- --------------- - - --- | YCbCr color space with Alpha channel. -data YCbCrA = LumaYCbCrA -- ^ Luma component (commonly denoted as __Y'__) - | CBlueYCbCrA -- ^ Blue difference chroma component - | CRedYCbCrA -- ^ Red difference chroma component - | AlphaYCbCrA -- ^ Alpha component. - deriving (Eq, Enum, Show, Bounded, Typeable) - -data instance Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving (Eq, Ord) - - -instance Show e => Show (Pixel YCbCrA e) where - show (PixelYCbCrA y b r a) = "" - - -instance Elevator e => ColorSpace YCbCrA e where - type Components YCbCrA e = (e, e, e, e) - - fromComponents (y, b, r, a) = PixelYCbCrA y b r a - {-# INLINE fromComponents #-} - toComponents (PixelYCbCrA y b r a) = (y, b, r, a) - {-# INLINE toComponents #-} - getPxC (PixelYCbCrA y _ _ _) LumaYCbCrA = y - getPxC (PixelYCbCrA _ b _ _) CBlueYCbCrA = b - getPxC (PixelYCbCrA _ _ r _) CRedYCbCrA = r - getPxC (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a - {-# INLINE getPxC #-} - setPxC (PixelYCbCrA _ b r a) LumaYCbCrA y = PixelYCbCrA y b r a - setPxC (PixelYCbCrA y _ r a) CBlueYCbCrA b = PixelYCbCrA y b r a - setPxC (PixelYCbCrA y b _ a) CRedYCbCrA r = PixelYCbCrA y b r a - setPxC (PixelYCbCrA y b r _) AlphaYCbCrA a = PixelYCbCrA y b r a - {-# INLINE setPxC #-} - mapPxC f (PixelYCbCrA y b r a) = - PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a) - {-# INLINE mapPxC #-} - foldlPx2 f !z (PixelYCbCrA y1 b1 r1 a1) (PixelYCbCrA y2 b2 r2 a2) = - f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2 - {-# INLINE foldlPx2 #-} - - -instance Elevator e => AlphaSpace YCbCrA e where - type Opaque YCbCrA = YCbCr - - getAlpha (PixelYCbCrA _ _ _ a) = a - {-# INLINE getAlpha #-} - addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a - {-# INLINE addAlpha #-} - dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r - {-# INLINE dropAlpha #-} - - -instance Functor (Pixel YCbCrA) where - fmap f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a) - {-# INLINE fmap #-} - - -instance Applicative (Pixel YCbCrA) where - pure !e = PixelYCbCrA e e e e - {-# INLINE pure #-} - (PixelYCbCrA fy fb fr fa) <*> (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a) - {-# INLINE (<*>) #-} - - -instance Foldable (Pixel YCbCrA) where - foldr f !z (PixelYCbCrA y b r a) = f y (f b (f r (f a z))) - {-# INLINE foldr #-} - - -instance Traversable (Pixel YCbCrA) where - traverse f (PixelYCbCrA y b r a) = PixelYCbCrA <$> f y <*> f b <*> f r <*> f a - {-# INLINE traverse #-} - - -instance Storable e => Storable (Pixel YCbCrA e) where - - sizeOf _ = 4 * sizeOf (undefined :: e) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: e) - {-# INLINE alignment #-} - peek !p = do - let q = castPtr p - y <- peekElemOff q 0 - b <- peekElemOff q 1 - r <- peekElemOff q 2 - a <- peekElemOff q 3 - return $! PixelYCbCrA y b r a - {-# INLINE peek #-} - poke !p (PixelYCbCrA y b r a) = do - let q = castPtr p - poke q y - pokeElemOff q 1 b - pokeElemOff q 2 r - pokeElemOff q 3 a - {-# INLINE poke #-} - - diff --git a/tests/Data/Massiv/Array/IOSpec.hs b/tests/Data/Massiv/Array/IOSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Massiv/Array/IOSpec.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Data.Massiv.Array.IOSpec (spec) where + +import Data.Bifunctor +import Data.List.NonEmpty as NE (NonEmpty, fromList) +import Data.Massiv.Array +import Data.Massiv.Array.IO hiding (showsType) +import qualified Data.ByteString.Lazy as BL +import Test.Massiv.Core +import System.Random +import Test.Hspec.QuickCheck + +elevatorGen :: (Random e, Elevator e) => Gen e +elevatorGen = choose (minValue, maxValue) + +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Y i) e) where + arbitrary = PixelY <$> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (Y i)) e) where + arbitrary = PixelYA <$> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel SRGB e) where + arbitrary = PixelRGB <$> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha SRGB) e) where + arbitrary = PixelRGBA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel AdobeRGB e) where + arbitrary = PixelRGB <$> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha AdobeRGB) e) where + arbitrary = PixelRGBA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (YCbCr cs) e) where + arbitrary = PixelYCbCr <$> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (YCbCr cs)) e) where + arbitrary = PixelYCbCrA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (CMYK cs) e) where + arbitrary = PixelCMYK <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen +instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (CMYK cs)) e) where + arbitrary = + PixelCMYKA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen + +specEncodeNoError :: + forall cs e i f. (Writable f (Image S cs e), Arbitrary (Pixel cs e), ColorSpace cs i e) + => f + -> Spec +specEncodeNoError f = + prop (("Image S " ++) . + showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) . + showsType @e $ "") $ + property $ \ (ArrNE img :: ArrNE S Ix2 (Pixel cs e)) -> do + bs <- encodeM f def img + bs' <- encodeImageM imageWriteFormats ("foo" ++ ext f) img + bs' `shouldBe` bs + +specEncodeDecodeNoError :: + forall cs e i f. + ( Readable f (Image S cs e) + , Writable f (Image S cs e) + , Arbitrary (Pixel cs e) + , ColorSpace cs i e + ) + => f + -> Spec +specEncodeDecodeNoError f = + prop (("Image S " ++) . + showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) . + showsType @e $ "") $ + property $ \ (ArrNE img :: ArrNE S Ix2 (Pixel cs e)) -> do + bs <- encodeM f def img + img' :: Image S cs e <- decodeM f $ BL.toStrict bs + size img' `shouldBe` size img + bs' <- encodeImageM imageWriteFormats ("foo" ++ ext f) img + bs' `shouldBe` bs + +specEncodeDecodeAutoNoError :: + forall cs e i f. + ( Readable (Auto f) (Image S cs e) + , Writable (Auto f) (Image S cs e) + , Arbitrary (Pixel cs e) + , ColorSpace (BaseSpace cs) i e + , ColorSpace cs i e + ) + => f + -> Spec +specEncodeDecodeAutoNoError nonAutoFormat = + prop (("Image S " ++) . + showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) . + showsType @e $ "") $ + property $ \ (ArrNE img :: ArrNE S Ix2 (Pixel cs e)) -> do + let f = Auto nonAutoFormat + bs <- encodeM f def img + img' :: Image S cs e <- decodeM f $ BL.toStrict bs + size img' `shouldBe` size img + bs' <- encodeImageM imageWriteAutoFormats ("foo" ++ ext f) img + bs' `shouldBe` bs + +_specEncodeDecodeGifSequenceNoError :: + forall cs e. + ( Readable (Sequence GIF) [Image S cs e] + , Writable (Sequence GIF) (NonEmpty (GifDelay, Image S cs e)) + , Arbitrary (Pixel cs e) + , ColorModel cs e + ) + => Spec +_specEncodeDecodeGifSequenceNoError = + prop (("Image S " ++) . + showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) . + showsType @e $ "") $ + property $ \ (imgsNE :: NonEmptyList (GifDelay, ArrNE S Ix2 (Pixel cs e))) -> do + let imgs = fmap (second unArr) $ NE.fromList $ getNonEmpty imgsNE + bs <- encodeM (Sequence GIF) def imgs + imgs' :: [Image S cs e] <- decodeM (Sequence GIF) $ BL.toStrict bs + length imgs' `shouldBe` length imgs + + +spec :: Spec +spec = do + describe "Readable/Writable" $ do + describe "BMP" $ do + specEncodeNoError @(Y D65) @Word8 BMP + --specEncodeDecodeNoError @(Y D65) @Word8 BMP + specEncodeDecodeNoError @SRGB @Word8 BMP + specEncodeDecodeNoError @(Alpha SRGB) @Word8 BMP + describe "GIF" $ do + specEncodeNoError @(Y D65) @Word8 GIF + specEncodeDecodeNoError @SRGB @Word8 GIF + --specEncodeGifSequenceNoError @(Y D65) @Word8 + --describe "Sequenece" $ -- Need to ensure same size for all arrays + -- TODO: Define (Arbitrary ArrListNE) (either slice 3d, or gen list of functions) + -- specEncodeDecodeGifSequenceNoError @SRGB @Word8 + -- TODO: read RGBA8, write Y8 + describe "HDR" $ do + specEncodeDecodeNoError @SRGB @Float HDR + describe "JPG" $ do + specEncodeDecodeNoError @(Y D65) @Word8 JPG + specEncodeDecodeNoError @SRGB @Word8 JPG + specEncodeDecodeNoError @(CMYK SRGB) @Word8 JPG + specEncodeDecodeNoError @(YCbCr SRGB) @Word8 JPG + -- TODO: read YA8 + describe "PNG" $ do + specEncodeDecodeNoError @(Y D65) @Word8 PNG + specEncodeDecodeNoError @(Y D65) @Word16 PNG + specEncodeDecodeNoError @(Alpha (Y D65)) @Word8 PNG + specEncodeDecodeNoError @(Alpha (Y D65)) @Word16 PNG + specEncodeDecodeNoError @SRGB @Word8 PNG + specEncodeDecodeNoError @SRGB @Word16 PNG + specEncodeDecodeNoError @(Alpha SRGB) @Word8 PNG + specEncodeDecodeNoError @(Alpha SRGB) @Word16 PNG + describe "TGA" $ do + specEncodeDecodeNoError @(Y D65) @Word8 TGA + specEncodeDecodeNoError @SRGB @Word8 TGA + specEncodeDecodeNoError @(Alpha SRGB) @Word8 TGA + describe "TIF" $ do + specEncodeDecodeNoError @(Y D65) @Word8 TIF + specEncodeDecodeNoError @(Y D65) @Word16 TIF + specEncodeDecodeNoError @(Y D65) @Word32 TIF + specEncodeDecodeNoError @(Y D65) @Float TIF + specEncodeDecodeNoError @(Alpha (Y D65)) @Word8 TIF + specEncodeDecodeNoError @(Alpha (Y D65)) @Word16 TIF + specEncodeDecodeNoError @SRGB @Word8 TIF + specEncodeDecodeNoError @SRGB @Word16 TIF + specEncodeDecodeNoError @(Alpha SRGB) @Word8 TIF + specEncodeDecodeNoError @(Alpha SRGB) @Word16 TIF + specEncodeDecodeNoError @(CMYK SRGB) @Word8 TIF + specEncodeDecodeNoError @(CMYK SRGB) @Word16 TIF + specEncodeNoError @(YCbCr SRGB) @Word8 TIF + specEncodeDecodeNoErrorAuto BMP + specEncodeDecodeNoErrorAuto GIF + --specEncodeDecodeNoErrorAuto HDR -- Get "Invalid sanline size" from JuicyPixels + specEncodeDecodeNoErrorAuto JPG + specEncodeDecodeNoErrorAuto PNG + specEncodeDecodeNoErrorAuto TGA + specEncodeDecodeNoErrorAuto TIF + + + +specEncodeDecodeNoErrorAuto :: + ( Show f + , Readable (Auto f) (Image S (Y D65) Word8) + , Readable (Auto f) (Image S (Y D65) Word16) + , Readable (Auto f) (Image S (Y D65) Word32) + , Readable (Auto f) (Image S (Y D65) Word64) + , Readable (Auto f) (Image S (CMYK SRGB) Word8) + , Readable (Auto f) (Image S (CMYK SRGB) Word16) + , Readable (Auto f) (Image S (CMYK SRGB) Word32) + , Readable (Auto f) (Image S (CMYK SRGB) Word64) + , Readable (Auto f) (Image S (CMYK AdobeRGB) Word8) + , Readable (Auto f) (Image S (CMYK AdobeRGB) Word16) + , Readable (Auto f) (Image S (CMYK AdobeRGB) Word32) + , Readable (Auto f) (Image S (CMYK AdobeRGB) Word64) + , Readable (Auto f) (Image S (YCbCr SRGB) Word8) + , Readable (Auto f) (Image S (YCbCr SRGB) Word16) + , Readable (Auto f) (Image S (YCbCr SRGB) Word32) + , Readable (Auto f) (Image S (YCbCr SRGB) Word64) + -- , Readable (Auto f) (Image S (YCbCr AdobeRGB) Word8) + -- , Readable (Auto f) (Image S (YCbCr AdobeRGB) Word16) + -- , Readable (Auto f) (Image S (YCbCr AdobeRGB) Word32) + -- , Readable (Auto f) (Image S (YCbCr AdobeRGB) Word64) + , Readable (Auto f) (Image S (Alpha (Y D65)) Word8) + , Readable (Auto f) (Image S (Alpha (Y D65)) Word16) + , Readable (Auto f) (Image S (Alpha (Y D65)) Word32) + , Readable (Auto f) (Image S (Alpha (Y D65)) Word64) + , Readable (Auto f) (Image S (Alpha SRGB) Word8) + , Readable (Auto f) (Image S (Alpha SRGB) Word16) + , Readable (Auto f) (Image S (Alpha SRGB) Word32) + , Readable (Auto f) (Image S (Alpha SRGB) Word64) + , Readable (Auto f) (Image S (Alpha AdobeRGB) Word8) + , Readable (Auto f) (Image S (Alpha AdobeRGB) Word16) + , Readable (Auto f) (Image S (Alpha AdobeRGB) Word32) + , Readable (Auto f) (Image S (Alpha AdobeRGB) Word64) + , Readable (Auto f) (Image S SRGB Word8) + , Readable (Auto f) (Image S SRGB Word16) + , Readable (Auto f) (Image S SRGB Word32) + , Readable (Auto f) (Image S SRGB Word64) + , Readable (Auto f) (Image S AdobeRGB Word8) + , Readable (Auto f) (Image S AdobeRGB Word16) + , Readable (Auto f) (Image S AdobeRGB Word32) + , Readable (Auto f) (Image S AdobeRGB Word64) + , Writable (Auto f) (Image S (Y D65) Word8) + , Writable (Auto f) (Image S (Y D65) Word16) + , Writable (Auto f) (Image S (Y D65) Word32) + , Writable (Auto f) (Image S (Y D65) Word64) + , Writable (Auto f) (Image S (CMYK SRGB) Word8) + , Writable (Auto f) (Image S (CMYK SRGB) Word16) + , Writable (Auto f) (Image S (CMYK SRGB) Word32) + , Writable (Auto f) (Image S (CMYK SRGB) Word64) + , Writable (Auto f) (Image S (CMYK AdobeRGB) Word8) + , Writable (Auto f) (Image S (CMYK AdobeRGB) Word16) + , Writable (Auto f) (Image S (CMYK AdobeRGB) Word32) + , Writable (Auto f) (Image S (CMYK AdobeRGB) Word64) + , Writable (Auto f) (Image S (YCbCr SRGB) Word8) + , Writable (Auto f) (Image S (YCbCr SRGB) Word16) + , Writable (Auto f) (Image S (YCbCr SRGB) Word32) + , Writable (Auto f) (Image S (YCbCr SRGB) Word64) + -- , Writable (Auto f) (Image S (YCbCr AdobeRGB) Word8) + -- , Writable (Auto f) (Image S (YCbCr AdobeRGB) Word16) + -- , Writable (Auto f) (Image S (YCbCr AdobeRGB) Word32) + -- , Writable (Auto f) (Image S (YCbCr AdobeRGB) Word64) + , Writable (Auto f) (Image S (Alpha (Y D65)) Word8) + , Writable (Auto f) (Image S (Alpha (Y D65)) Word16) + , Writable (Auto f) (Image S (Alpha (Y D65)) Word32) + , Writable (Auto f) (Image S (Alpha (Y D65)) Word64) + , Writable (Auto f) (Image S (Alpha SRGB) Word8) + , Writable (Auto f) (Image S (Alpha SRGB) Word16) + , Writable (Auto f) (Image S (Alpha SRGB) Word32) + , Writable (Auto f) (Image S (Alpha SRGB) Word64) + , Writable (Auto f) (Image S (Alpha AdobeRGB) Word8) + , Writable (Auto f) (Image S (Alpha AdobeRGB) Word16) + , Writable (Auto f) (Image S (Alpha AdobeRGB) Word32) + , Writable (Auto f) (Image S (Alpha AdobeRGB) Word64) + , Writable (Auto f) (Image S SRGB Word8) + , Writable (Auto f) (Image S SRGB Word16) + , Writable (Auto f) (Image S SRGB Word32) + , Writable (Auto f) (Image S SRGB Word64) + , Writable (Auto f) (Image S AdobeRGB Word8) + , Writable (Auto f) (Image S AdobeRGB Word16) + , Writable (Auto f) (Image S AdobeRGB Word32) + , Writable (Auto f) (Image S AdobeRGB Word64) + ) + => f + -> Spec +specEncodeDecodeNoErrorAuto f = + describe ("Auto " ++ show f) $ do + specEncodeDecodeAutoNoError @(Y D65) @Word8 f + specEncodeDecodeAutoNoError @(Y D65) @Word16 f + specEncodeDecodeAutoNoError @(Y D65) @Word32 f + specEncodeDecodeAutoNoError @(Y D65) @Word64 f + specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word8 f + specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word16 f + specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word32 f + specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word64 f + specEncodeDecodeAutoNoError @SRGB @Word8 f + specEncodeDecodeAutoNoError @SRGB @Word16 f + specEncodeDecodeAutoNoError @SRGB @Word32 f + specEncodeDecodeAutoNoError @SRGB @Word64 f + specEncodeDecodeAutoNoError @(Alpha SRGB) @Word8 f + specEncodeDecodeAutoNoError @(Alpha SRGB) @Word16 f + specEncodeDecodeAutoNoError @(Alpha SRGB) @Word32 f + specEncodeDecodeAutoNoError @(Alpha SRGB) @Word64 f + specEncodeDecodeAutoNoError @(CMYK SRGB) @Word8 f + specEncodeDecodeAutoNoError @(CMYK SRGB) @Word16 f + specEncodeDecodeAutoNoError @(CMYK SRGB) @Word32 f + specEncodeDecodeAutoNoError @(CMYK SRGB) @Word64 f + specEncodeDecodeAutoNoError @(YCbCr SRGB) @Word8 f + specEncodeDecodeAutoNoError @(YCbCr SRGB) @Word16 f + specEncodeDecodeAutoNoError @(YCbCr SRGB) @Word32 f + specEncodeDecodeAutoNoError @(YCbCr SRGB) @Word64 f + specEncodeDecodeAutoNoError @AdobeRGB @Word8 f + specEncodeDecodeAutoNoError @AdobeRGB @Word16 f + specEncodeDecodeAutoNoError @AdobeRGB @Word32 f + specEncodeDecodeAutoNoError @AdobeRGB @Word64 f + specEncodeDecodeAutoNoError @(Alpha AdobeRGB) @Word8 f + specEncodeDecodeAutoNoError @(Alpha AdobeRGB) @Word16 f + specEncodeDecodeAutoNoError @(Alpha AdobeRGB) @Word32 f + specEncodeDecodeAutoNoError @(Alpha AdobeRGB) @Word64 f + specEncodeDecodeAutoNoError @(CMYK AdobeRGB) @Word8 f + specEncodeDecodeAutoNoError @(CMYK AdobeRGB) @Word16 f + specEncodeDecodeAutoNoError @(CMYK AdobeRGB) @Word32 f + specEncodeDecodeAutoNoError @(CMYK AdobeRGB) @Word64 f + -- specEncodeDecodeAutoNoError @(YCbCr AdobeRGB) @Word8 f + -- specEncodeDecodeAutoNoError @(YCbCr AdobeRGB) @Word16 f + -- specEncodeDecodeAutoNoError @(YCbCr AdobeRGB) @Word32 f + -- specEncodeDecodeAutoNoError @(YCbCr AdobeRGB) @Word64 f diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Spec +import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) +import Test.Hspec + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest (doctest) + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources