diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexey Kuleshevich (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# massiv-io +Import/export Arrays in various formats. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/massiv-io.cabal b/massiv-io.cabal new file mode 100644 --- /dev/null +++ b/massiv-io.cabal @@ -0,0 +1,60 @@ +name: massiv-io +version: 0.1.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 + image files in varios formats. +homepage: https://github.com/lehins/massiv +license: BSD3 +license-file: LICENSE +author: Alexey Kuleshevich +maintainer: alexey@kuleshevi.ch +copyright: 2018 Alexey Kuleshevich +category: Data, Data Structures +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +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 + , Data.Massiv.Array.IO.Image + , Data.Massiv.Array.IO.Image.JuicyPixels + , Data.Massiv.Array.IO.Image.Netpbm + build-depends: base >= 4.7 && < 5 + , bytestring + , data-default + , deepseq + , directory + , filepath >= 1.0 + , massiv + , process + , JuicyPixels >= 3.2.7 + , netpbm + , vector >= 0.10 + default-language: Haskell2010 + ghc-options: -Wall + if os(windows) + CPP-options: -DOS_Win32 + else + if os(linux) + CPP-options: -DOS_Linux + else + if os(darwin) + CPP-options: -DOS_Mac + +source-repository head + type: git + location: https://github.com/lehins/massiv diff --git a/src/Data/Massiv/Array/IO.hs b/src/Data/Massiv/Array/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Massiv.Array.IO +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO ( + -- * Reading + readArray, readImage, readImageAuto, + -- * Writing + writeArray ,writeImage, writeImageAuto, + -- * Displaying + ExternalViewer(..), + displayImage, + displayImageUsing, + displayImageFile, + -- ** Common viewers + defaultViewer, + eogViewer, + gpicviewViewer, + fehViewer, + gimpViewer, + -- * Supported Image Formats + module Data.Massiv.Array.IO.Base, + module Data.Massiv.Array.IO.Image + + -- $supported + ) 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.Image +import Graphics.ColorSpace +import Prelude as P hiding (readFile, writeFile) +import System.Directory (createDirectoryIfMissing, + getTemporaryDirectory) +import System.FilePath +import System.IO (hClose, openBinaryTempFile) +import System.Process (readProcess) + +-- | External viewing application to use for displaying images. +data ExternalViewer = + ExternalViewer FilePath [String] Int + -- ^ Any custom viewer, which can be specified: + -- + -- * @FilePath@ - to the actual viewer executable. + -- * @[String]@ - command line arguments that will be passed to the executable. + -- * @Int@ - position index in the above list where `FilePath` to an image should be + -- injected + deriving Show + + + +-- | Read an array from one of the supported file formats. +readArray :: Readable f arr => + 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 +{-# INLINE readArray #-} + + +writeArray :: Writable f arr => + 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) +{-# 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. +-- +-- Might throw `ConvertError`, `DecodeError` and other standard errors related to file IO. +-- +-- Result image will be read as specified by the type signature: +-- +-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S YCbCr Word8) +-- >>> displayImage frog +-- +-- In case when the result image type does not match the color space or precision of the actual +-- image file, `ConvertError` will be thrown. +-- +-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S CMYK Word8) +-- >>> displayImage frog +-- *** Exception: ConvertError "Cannot decode JPG image as " +-- +-- 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: +-- +-- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S CMYK Double) +-- >>> displayImage frogCMYK +-- +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 +{-# 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 +{-# INLINE readImageAuto #-} + + + +-- | Inverse of the 'readImage', but similarly to it, 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, <'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. +-- +-- 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 + + + +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 + + + +-- | An image is written as a @.tiff@ file into an operating system's temporary +-- directory and passed as an argument to the external viewer program. +-- displayImageUsing :: Writable (Auto TIF) (Image r cs e) => +-- ExternalViewer -- ^ Image viewer program +-- -> Bool -- ^ Should a call block the cuurrent thread untul viewer is closed. +-- -> Image r cs e -> IO () +displayImageUsing :: Writable (Auto TIF) (Image r cs e) => + ExternalViewer -- ^ Image viewer program + -> Bool -- ^ Should a call block the cuurrent thread untul viewer is closed. + -> Image r cs e -> IO () +displayImageUsing viewer block img = + if block + then display + else img `seq` void (forkIO display) + where + display = do + tmpDir <- fmap ( "hip") getTemporaryDirectory + createDirectoryIfMissing True tmpDir + bracket + (openBinaryTempFile tmpDir "tmp-img.tiff") + (hClose . snd) + (\(imgPath, imgHandle) -> do + BL.hPut imgHandle (encode (Auto TIF) () img) + hClose imgHandle + displayImageFile viewer imgPath) + + + +-- | Displays an image file by calling an external image viewer. +displayImageFile :: ExternalViewer -> FilePath -> IO () +displayImageFile (ExternalViewer exe args ix) imgPath = + void $ 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 () +displayImage = displayImageUsing defaultViewer False + +-- | Default viewer is inferred from the operating system. +defaultViewer :: ExternalViewer +defaultViewer = +#if defined(OS_Win32) + ExternalViewer "explorer.exe" [] 0 +#elif defined(OS_Linux) + ExternalViewer "xdg-open" [] 0 +#elif defined(OS_Mac) + ExternalViewer "open" [] 0 +#else + error "Graphics.Image.IO.defaultViewer: Could not determine default viewer." +#endif + + +-- | @eog \/tmp\/hip\/img.tiff@ +-- +-- +eogViewer :: ExternalViewer +eogViewer = ExternalViewer "eog" [] 0 + + +-- | @feh --fullscreen --auto-zoom \/tmp\/hip\/img.tiff@ +-- +-- +fehViewer :: ExternalViewer +fehViewer = ExternalViewer "feh" ["--fullscreen", "--auto-zoom"] 2 + + +-- | @gpicview \/tmp\/hip\/img.tiff@ +-- +-- +gpicviewViewer :: ExternalViewer +gpicviewViewer = ExternalViewer "gpicview" [] 0 + + +-- | @gimp \/tmp\/hip\/img.tiff@ +-- +-- +gimpViewer :: ExternalViewer +gimpViewer = ExternalViewer "gimp" [] 0 + + +{- $supported + +Encoding and decoding of images is done using + 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: + +* 'BMP': + + * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + +* 'GIF': + + * __read__: ('RGB' 'Word8'), ('RGBA' 'Word8') + * __write__: ('RGB' 'Word8') + * Also supports reading and writing animated images, when used as @'GIFA'@ + +* 'HDR': + + * __read__: ('RGB' 'Float') + * __write__: ('RGB' 'Float') + +* 'JPG': + + * __read__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), + ('YCbCr', 'Word8') + * __write__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), + ('YCbCr', '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') + +* 'TGA': + + * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' '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') + +* 'PBM': + + * __read__: ('Binary' 'Bit') + * Also supports sequence of images in one file, when read as @['PBM']@ + +* 'PGM': + + * __read__: ('Y' 'Word8'), ('Y' 'Word16') + * Also supports sequence of images in one file, when read as @['PGM']@ + +* 'PPM': + + * __read__: ('RGB' 'Word8'), ('RGB' '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 new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Base.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Massiv.Array.IO.Base +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Base + ( FileFormat(..) + , Readable(..) + , Writable(..) + , ConvertError(..) + , EncodeError(..) + , DecodeError(..) + , Sequence(..) + , Auto(..) + , Image + , defaultReadOptions + , defaultWriteOptions + , toProxy + , fromMaybeEncode + , fromEitherDecode + , convertEither + ) where + +import Control.Exception (throw, Exception) +import Data.Massiv.Array (Array, Ix2) +import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Default (Default (..)) +import Data.Maybe (fromMaybe) +import Data.Typeable +import Graphics.ColorSpace (ColorSpace, Pixel) + +type Image r cs e = Array r Ix2 (Pixel cs e) + +-- | Conversion error, which is thrown when there is a mismatch between the +-- expected array type and the one supported by the file format. It is also +-- thrown upon a failure of automatic conversion between those types, in case +-- such conversion is utilized. +newtype ConvertError = ConvertError String deriving Show + +instance Exception ConvertError + +-- | This exception can be thrown while reading/decoding a file and indicates an +-- error in the file itself. +newtype DecodeError = DecodeError String deriving Show + +instance Exception DecodeError + +-- | This exception can be thrown while writing/encoding into a file and +-- indicates an error in an array that is being encoded. +newtype EncodeError = EncodeError String deriving Show + +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 + + +-- | Special wrapper for formats that support encoding/decoding sequence of array. +newtype Sequence f = Sequence f deriving Show + +newtype Auto f = Auto f deriving Show + +-- | 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 = () + + -- | Options that can be used during writing a file in this format. + type WriteOptions f + type WriteOptions f = () + + -- | Default file extension for this file format. + ext :: f -> String + + -- | Other known file extensions for this file format, eg. ".jpeg", ".jpg". + exts :: f -> [String] + exts f = [ext f] + + -- | Checks if a file extension corresponds to the format, eg. + -- @isFormat ".png" PNG == True@ + isFormat :: String -> f -> Bool + isFormat e f = e `elem` exts f + + +instance FileFormat f => FileFormat (Auto f) where + type ReadOptions (Auto f) = ReadOptions f + type WriteOptions (Auto f) = WriteOptions f + + ext (Auto f) = ext f + +-- | File formats that can be read into an Array. +class Readable f arr where + + -- | Decode a `B.ByteString` into an Array. + decode :: f -> ReadOptions f -> B.ByteString -> arr + + +-- | Arrays that can be written into a file. +class Writable f arr where + + -- | Encode an array into a `BL.ByteString`. + encode :: f -> WriteOptions f -> arr -> BL.ByteString + + +-- | Helper function to create a `Proxy` from the value. +toProxy :: a -> Proxy a +toProxy _ = Proxy + +-- | 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 ") + + +-- | 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) + + +-- | 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 f showCS conv eImg = + maybe + (Left $ + ConvertError + ("Cannot convert " ++ show f ++ " image <" ++ + showCS eImg ++ + "> as " ++ + "")) + Right + (conv eImg) diff --git a/src/Data/Massiv/Array/IO/Image.hs b/src/Data/Massiv/Array/IO/Image.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image + ( Encode + , encodeImage + , imageWriteFormats + , imageWriteAutoFormats + , Decode + , decodeImage + , imageReadFormats + , imageReadAutoFormats + , module Data.Massiv.Array.IO.Image.JuicyPixels + , module Data.Massiv.Array.IO.Image.Netpbm + ) where + +import Control.Exception (throw) +import Data.Massiv.Array +import Data.Massiv.Array.IO.Base +import Data.Massiv.Array.IO.Image.JuicyPixels +import Data.Massiv.Array.IO.Image.Netpbm +import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Char (toLower) +import Graphics.ColorSpace +import Prelude as P +import System.FilePath (takeExtension) + + + +data Encode out where + EncodeAs :: (FileFormat f, Writable f out) => f -> Encode out + +instance Show (Encode out) where + show (EncodeAs f) = show f + +instance FileFormat (Encode (Image r cs e)) where + ext (EncodeAs f) = ext 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) + + +encodeImage + :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) + => [Encode (Image r cs e)] + -> FilePath + -> Image r cs e + -> BL.ByteString +encodeImage 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 + + +imageWriteFormats :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) => [Encode (Image r cs e)] +imageWriteFormats = + [ EncodeAs BMP + , EncodeAs GIF + , EncodeAs HDR + , EncodeAs JPG + , EncodeAs PNG + , EncodeAs TGA + , EncodeAs TIF + ] + +imageWriteAutoFormats + :: ( Source r Ix2 (Pixel cs e) + , ColorSpace cs e + , ToYA cs e + , ToRGBA cs e + , ToYCbCr cs e + , ToCMYK cs 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) + ] + + + +data Decode out where + DecodeAs :: (FileFormat f, Readable f out) => f -> Decode out + +instance Show (Decode out) where + show (DecodeAs f) = show f + +instance FileFormat (Decode (Image r cs e)) where + ext (DecodeAs f) = ext 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) + + +decodeImage + :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) + => [Decode (Image r cs e)] + -> FilePath + -> B.ByteString + -> Image r cs e +decodeImage 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 + + +imageReadFormats + :: (Source S Ix2 (Pixel cs e), ColorSpace cs 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 + ] + +imageReadAutoFormats + :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs 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) + ] diff --git a/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs b/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/JuicyPixels.hs @@ -0,0 +1,972 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.JuicyPixels +-- Copyright : (c) Alexey Kuleshevich 2018 +-- 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 + ) 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 Control.Exception +import Control.Monad (guard, msum) +import Data.Bifunctor +import qualified Data.ByteString as B (ByteString) +import qualified Data.ByteString.Lazy as BL (ByteString) +import Data.Default (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 Graphics.ColorSpace +-------------------------------------------------------------------------------- +-- 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 _ bs = decodeGIFs f fromDynamicImage bs + +instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => + Readable (Sequence (Auto GIF)) (Array B Ix1 (Image r cs e)) where + decode f _ bs = decodeGIFs f fromAnyDynamicImage bs + + +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 _ bs = decodeGIFsWithDelays f fromDynamicImage bs + + + +-- 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 $ 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 $ 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 = do + 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.decodePng + +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.decodePng + + + + +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 + , 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 + , 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. + ( Functor (Pixel cs) + , 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, Source S Ix2 (Pixel 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 + 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 = do + 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 + 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) + , Storable (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" +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 + +-- | TODO: Validate size +toJPImageUnsafe + :: forall r cs a . (JP.Pixel a, Source r Ix2 (Pixel cs (JP.PixelBaseComponent a)), + ColorSpace cs (JP.PixelBaseComponent a), + Storable (Pixel 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) + (m :. n) = size img +{-# INLINE toJPImageUnsafe #-} + +toJPImageY8 :: Source r Ix2 (Pixel Y Word8) => Image r Y Word8 -> JP.Image JP.Pixel8 +toJPImageY8 = toJPImageUnsafe +{-# INLINE toJPImageY8 #-} + +toJPImageY16 :: Source r Ix2 (Pixel Y Word16) => Image r Y Word16 -> JP.Image JP.Pixel16 +toJPImageY16 = toJPImageUnsafe +{-# INLINE toJPImageY16 #-} + +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 #-} + +-- FIXME: debug writing to file of TIF files. +-- toJPImageCMYK16 :: Source r Ix2 (Pixel CMYK Word16) => Image r CMYK Word16 -> JP.Image JP.PixelCMYK16 +-- toJPImageCMYK16 = toJPImageUnsafe +-- {-# INLINE toJPImageCMYK16 #-} + + + + +-- General decoding and helper functions + +-- | TODO: Validate size +fromJPImageUnsafe :: (Storable (Pixel cs e), JP.Pixel jpx) => + JP.Image jpx -> Maybe (Image S cs e) +fromJPImageUnsafe (JP.Image n m !v) = do + guard (n * m /= V.length v) + return $ fromVector Seq (m :. n) $ V.unsafeCast v +{-# INLINE fromJPImageUnsafe #-} + diff --git a/src/Data/Massiv/Array/IO/Image/Netpbm.hs b/src/Data/Massiv/Array/IO/Image/Netpbm.hs new file mode 100644 --- /dev/null +++ b/src/Data/Massiv/Array/IO/Image/Netpbm.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Massiv.Array.IO.Image.Netpbm +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Massiv.Array.IO.Image.Netpbm + ( -- * Netpbm formats + -- ** PBM + PBM(..) + -- ** PGM + , PGM(..) + -- ** PPM + , PPM(..) + ) where + +import Control.Exception +import Control.Monad (guard) +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 Prelude as P + +-- | Netpbm: portable bitmap image with @.pbm@ extension. +data PBM = PBM deriving Show + +instance FileFormat PBM where + 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 + 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 + 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 + 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 + ext _ = ".ppm" + +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 + 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 + +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 + + + +decodePPMs :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => + f + -> (Netpbm.PPM -> Maybe (Image r cs e)) + -> 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 +{-# INLINE decodePPMs #-} + + +decodePPM :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) => + f + -> (Netpbm.PPM -> Maybe (Image r cs e)) + -> 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 +{-# INLINE decodePPM #-} + + +-- | TODO: validate sizes +fromNetpbmImageUnsafe + :: (Storable a, Storable (Pixel cs e)) + => (Int, Int) -> V.Vector a -> Maybe (Image S cs e) +fromNetpbmImageUnsafe (m, n) v = do + guard (n * m /= V.length v) + return $ fromVector Seq (m :. n) $ V.unsafeCast v + + + +showNetpbmCS :: Netpbm.PPM -> String +showNetpbmCS Netpbm.PPM {ppmData} = do + case ppmData of + PbmPixelData _ -> "Image S X Bit" + PgmPixelData8 _ -> "Image S Y Word8" + PgmPixelData16 _ -> "Image S Y Word16" + PpmPixelDataRGB8 _ -> "Image S RGB Word8" + PpmPixelDataRGB16 _ -> "Image S RGB Word16" + + +fromNetpbmImage + :: forall cs e . (ColorSpace cs e, V.Storable (Pixel cs e)) => + Netpbm.PPM -> Maybe (Image S cs e) +fromNetpbmImage Netpbm.PPM {..} = do + let sz = (ppmHeight ppmHeader, ppmWidth ppmHeader) + case ppmData of + PbmPixelData v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit) + fromNetpbmImageUnsafe sz v + PgmPixelData8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8) + fromNetpbmImageUnsafe sz v + PgmPixelData16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16) + fromNetpbmImageUnsafe sz v + PpmPixelDataRGB8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8) + fromNetpbmImageUnsafe sz v + PpmPixelDataRGB16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16) + fromNetpbmImageUnsafe sz v + + +fromNetpbmImageAuto + :: forall cs e r . (Mutable r Ix2 (Pixel cs e), ColorSpace cs e, V.Storable (Pixel cs e)) => + Netpbm.PPM -> Maybe (Image r cs e) +fromNetpbmImageAuto Netpbm.PPM {..} = do + let sz = (ppmHeight ppmHeader, ppmWidth ppmHeader) + case ppmData of + PbmPixelData v -> + (fromNetpbmImageUnsafe sz v :: Maybe (Image S X Bit)) >>= (toAnyCS . M.map fromPixelBinary) + PgmPixelData8 v -> + (fromNetpbmImageUnsafe sz v :: Maybe (Image S Y Word8)) >>= toAnyCS + PgmPixelData16 v -> + (fromNetpbmImageUnsafe sz v :: Maybe (Image S Y Word16)) >>= toAnyCS + PpmPixelDataRGB8 v -> + (fromNetpbmImageUnsafe sz v :: Maybe (Image S RGB Word8)) >>= toAnyCS + PpmPixelDataRGB16 v -> + (fromNetpbmImageUnsafe sz v :: Maybe (Image S RGB Word16)) >>= toAnyCS + diff --git a/src/Graphics/ColorSpace.hs b/src/Graphics/ColorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace.hs @@ -0,0 +1,726 @@ +{-# 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 +-- 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) = promote $ eToDouble b + {-# INLINE toPixelRGB #-} + +instance Elevator e => ToRGB Y e where + toPixelRGB (PixelY g) = promote $ 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 = (1 - r - k)/(1 - k) + !m = (1 - g - k)/(1 - k) + !y = (1 - b - k)/(1 - k) + !k = 1 - 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/Binary.hs @@ -0,0 +1,300 @@ +{-# 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 +-- 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 #-} + + +instance Bits (Pixel X Bit) where + (.&.) = liftPx2 (.&.) + {-# INLINE (.&.) #-} + (.|.) = liftPx2 (.|.) + {-# INLINE (.|.) #-} + xor = liftPx2 xor + {-# INLINE xor #-} + complement = liftPx complement + {-# INLINE complement #-} + shift !b !n = liftPx (`shift` n) b + {-# INLINE shift #-} + rotate !b !n = liftPx (`rotate` n) b + {-# INLINE rotate #-} + zeroBits = promote zeroBits + {-# INLINE zeroBits #-} + bit = promote . bit + {-# INLINE bit #-} + testBit (PixelX (Bit 1)) 0 = True + testBit _ _ = False + {-# INLINE testBit #-} + bitSizeMaybe _ = Just 1 + {-# INLINE bitSizeMaybe #-} + bitSize _ = 1 + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + popCount (PixelX (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 + q <- return $ castPtr p + b <- peek q + return (Bit b) + {-# INLINE peek #-} + poke !p (Bit b) = do + q <- return $ 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/CMYK.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.CMYK +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.CMYK ( + CMYK(..), CMYKA(..), Pixel(..) + ) where + +import Control.Applicative +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 + +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 #-} + promote !e = PixelCMYK e e e e + {-# INLINE promote #-} + 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 #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelCMYK c1 m1 y1 k1) (PixelCMYK c2 m2 y2 k2) = + f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel CMYK) where + 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 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 + + +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 #-} + promote !e = PixelCMYKA e e e e e + {-# INLINE promote #-} + getPxC (PixelCMYKA c _ _ _ _) CyanCMYKA = c + getPxC (PixelCMYKA _ m _ _ _) MagCMYKA = m + getPxC (PixelCMYKA _ _ y _ _) YelCMYKA = y + 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 #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelCMYKA c1 m1 y1 k1 a1) (PixelCMYKA c2 m2 y2 k2 a2) = + f (f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2) a1 a2 + {-# INLINE foldlPx2 #-} + + +instance Elevator e => 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 Storable e => Storable (Pixel CMYKA e) where + + sizeOf _ = 5 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ castPtr p + c <- peek q + m <- peekElemOff q 1 + y <- peekElemOff q 2 + k <- peekElemOff q 3 + a <- peekElemOff q 4 + return (PixelCMYKA c m y k a) + {-# INLINE peek #-} + poke !p (PixelCMYKA c m y k a) = do + q <- return $ castPtr p + poke q c + pokeElemOff q 1 m + pokeElemOff q 2 y + pokeElemOff q 3 k + pokeElemOff q 4 a + {-# INLINE poke #-} diff --git a/src/Graphics/ColorSpace/Complex.hs b/src/Graphics/ColorSpace/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/Complex.hs @@ -0,0 +1,85 @@ +{-# 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 +-- 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) @ +-- +(+:) :: Applicative (Pixel cs) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) +(+:) = liftA2 (:+) +{-# INLINE (+:) #-} + +-- | Extracts the real part of a complex pixel. +realPart :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +realPart = liftA C.realPart +{-# INLINE realPart #-} + +-- | Extracts the imaginary part of a complex pixel. +imagPart :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +imagPart = liftA C.imagPart +{-# INLINE imagPart #-} + +-- | Form a complex pixel from polar components of magnitude and phase. +mkPolar :: (Applicative (Pixel cs), RealFloat e) => + Pixel cs e -> Pixel cs e -> Pixel cs (Complex e) +mkPolar = liftA2 C.mkPolar +{-# INLINE mkPolar #-} + +-- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@). +cis :: (Applicative (Pixel cs), RealFloat e) => Pixel cs e -> Pixel cs (Complex e) +cis = liftA C.cis +{-# INLINE cis #-} + +-- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase) +-- pair of pixels in canonical form: the magnitude is nonnegative, and the phase +-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase. +polar :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e) +polar !zPx = (magnitude zPx, phase zPx) +{-# INLINE polar #-} + +-- | The nonnegative magnitude of a complex pixel. +magnitude :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +magnitude = liftA C.magnitude +{-# INLINE magnitude #-} + +-- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the +-- magnitude is zero, then so is the phase. +phase :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e +phase = liftA C.phase +{-# INLINE phase #-} + +-- | The conjugate of a complex pixel. +conjugate :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e) +conjugate = liftA C.conjugate +{-# INLINE conjugate #-} + + diff --git a/src/Graphics/ColorSpace/Elevator.hs b/src/Graphics/ColorSpace/Elevator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/Elevator.hs @@ -0,0 +1,319 @@ +{-# 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 +-- 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/HSI.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.HSI +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.HSI ( + HSI(..), HSIA(..), Pixel(..) + ) where + +import Control.Applicative +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 + + +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 #-} + promote = pure + {-# INLINE promote #-} + 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 #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelHSI h1 s1 i1) (PixelHSI h2 s2 i2) = + f (f (f z h1 h2) s1 s2) i1 i2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel HSI) where + 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 Storable e => Storable (Pixel HSI e) where + + sizeOf _ = 3 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ castPtr p + r <- peek q + g <- peekElemOff q 1 + b <- peekElemOff q 2 + return (PixelHSI r g b) + {-# INLINE peek #-} + poke !p (PixelHSI r g b) = do + q <- return $ castPtr p + poke q r + pokeElemOff q 1 g + pokeElemOff q 2 b + {-# 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 + + +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 #-} + promote = pure + {-# INLINE promote #-} + 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 #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelHSIA h1 s1 i1 a1) (PixelHSIA h2 s2 i2 a2) = + f (f (f (f z h1 h2) s1 s2) i1 i2) a1 a2 + {-# INLINE foldlPx2 #-} + + +instance Elevator e => 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 Storable e => Storable (Pixel HSIA e) where + sizeOf _ = 4 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ castPtr p + h <- peek q + s <- peekElemOff q 1 + i <- peekElemOff q 2 + a <- peekElemOff q 3 + return (PixelHSIA h s i a) + {-# INLINE peek #-} + poke !p (PixelHSIA h s i a) = do + q <- return $ castPtr p + poke q h + pokeElemOff q 1 s + pokeElemOff q 2 i + pokeElemOff q 3 a + {-# INLINE poke #-} diff --git a/src/Graphics/ColorSpace/Internal.hs b/src/Graphics/ColorSpace/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/Internal.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.Internal +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.Internal + ( Pixel + , ColorSpace(..) + , AlphaSpace(..) + , module Graphics.ColorSpace.Elevator + ) where + +import Control.DeepSeq (NFData (rnf), deepseq) +import Control.Monad (liftM) +import Data.Default +import Data.Foldable +import Data.Maybe (fromMaybe) +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, + 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 + + -- | 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 + + -- | Map a function over all Pixel's componenets. + liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e + + -- | Zip two Pixels with a function. + liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e + + -- | Left fold on two pixels a the same time. + foldlPx2 :: (b -> e -> e -> b) -> b -> Pixel cs e -> Pixel cs e -> b + + -- | Right fold over all Pixel's components. + foldrPx :: (e -> b -> b) -> b -> Pixel cs e -> b + foldrPx f !z0 !xs = foldlPx f' id xs z0 + where f' k x !z = k $! f x z + + -- | Left strict fold over all Pixel's components. + foldlPx :: (b -> e -> b) -> b -> Pixel cs e -> b + foldlPx f !z0 !xs = foldrPx f' id xs z0 + where f' x k !z = k $! f z x + + foldl1Px :: (e -> e -> e) -> Pixel cs e -> e + foldl1Px f !xs = fromMaybe (error "foldl1Px: empty Pixel") + (foldlPx mf Nothing xs) + where + mf m !y = Just (case m of + Nothing -> y + Just x -> f x y) + toListPx :: Pixel cs e -> [e] + toListPx !px = foldr' f [] (enumFrom (toEnum 0)) + where f !cs !ls = getPxC px cs:ls + + +-- | A color space that supports transparency. +class (ColorSpace (Opaque cs) 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 = promote 0 + {-# INLINE def #-} + + +instance ColorSpace cs e => Num (Pixel cs e) where + (+) = liftPx2 (+) + {-# INLINE (+) #-} + (-) = liftPx2 (-) + {-# INLINE (-) #-} + (*) = liftPx2 (*) + {-# INLINE (*) #-} + abs = liftPx abs + {-# INLINE abs #-} + signum = liftPx signum + {-# INLINE signum #-} + fromInteger = promote . fromInteger + {-# INLINE fromInteger #-} + + +instance (ColorSpace cs e, Fractional e) => Fractional (Pixel cs e) where + (/) = liftPx2 (/) + {-# INLINE (/) #-} + recip = liftPx recip + {-# INLINE recip #-} + fromRational = promote . fromRational + {-# INLINE fromRational #-} + + +instance (ColorSpace cs e, Floating e) => Floating (Pixel cs e) where + pi = promote pi + {-# INLINE pi #-} + exp = liftPx exp + {-# INLINE exp #-} + log = liftPx log + {-# INLINE log #-} + sin = liftPx sin + {-# INLINE sin #-} + cos = liftPx cos + {-# INLINE cos #-} + asin = liftPx asin + {-# INLINE asin #-} + atan = liftPx atan + {-# INLINE atan #-} + acos = liftPx acos + {-# INLINE acos #-} + sinh = liftPx sinh + {-# INLINE sinh #-} + cosh = liftPx cosh + {-# INLINE cosh #-} + asinh = liftPx asinh + {-# INLINE asinh #-} + atanh = liftPx atanh + {-# INLINE atanh #-} + acosh = liftPx acosh + {-# INLINE acosh #-} + +instance (ColorSpace cs e, Bounded e) => Bounded (Pixel cs e) where + maxBound = promote maxBound + {-# INLINE maxBound #-} + minBound = promote minBound + {-# INLINE minBound #-} + +instance (ColorSpace cs e, NFData e) => NFData (Pixel cs e) where + + rnf = foldrPx 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/RGB.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.RGB +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.RGB ( + RGB(..), RGBA(..), Pixel(..) + ) where + +import Prelude hiding (map) +import Control.Applicative +import Foreign.Ptr +import Foreign.Storable +import Data.Foldable +import Data.Typeable (Typeable) +import Graphics.ColorSpace.Internal + +----------- +--- 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 + +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 #-} + promote = pure + {-# INLINE promote #-} + getPxC (PixelRGB r _ _) RedRGB = r + getPxC (PixelRGB _ g _) GreenRGB = g + getPxC (PixelRGB _ _ b) BlueRGB = b + {-# INLINE getPxC #-} + setPxC (PixelRGB _ g b) RedRGB r = PixelRGB r g b + setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b + setPxC (PixelRGB r g _) BlueRGB b = PixelRGB r g b + {-# INLINE setPxC #-} + mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelRGB r1 g1 b1) (PixelRGB r2 g2 b2) = + f (f (f z r1 r2) g1 g2) b1 b2 + {-# INLINE foldlPx2 #-} + + +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 Storable e => Storable (Pixel RGB e) where + sizeOf _ = 3 * sizeOf (undefined :: e) + alignment _ = alignment (undefined :: e) + peek !p = do + let !q = castPtr p + r <- peek q + g <- peekElemOff q 1 + b <- peekElemOff q 2 + return (PixelRGB r g b) + poke !p (PixelRGB r g b) = do + let !q = castPtr p + poke q r + pokeElemOff q 1 g + pokeElemOff q 2 b + + +------------ +--- RGBA --- +------------ + + +-- | Red, Green and Blue color space with Alpha channel. +data RGBA = RedRGBA + | GreenRGBA + | BlueRGBA + | AlphaRGBA deriving (Eq, Enum, Show, Bounded, Typeable) + +data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq + + +instance Show e => Show (Pixel RGBA e) where + show (PixelRGBA r g b a) = "" + + +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 #-} + promote = pure + {-# INLINE promote #-} + getPxC (PixelRGBA r _ _ _) RedRGBA = r + getPxC (PixelRGBA _ g _ _) GreenRGBA = g + getPxC (PixelRGBA _ _ b _) BlueRGBA = b + getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a + {-# INLINE getPxC #-} + setPxC (PixelRGBA _ g b a) RedRGBA r = PixelRGBA r g b a + setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a + setPxC (PixelRGBA r g _ a) BlueRGBA b = PixelRGBA r g b a + setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a + {-# INLINE setPxC #-} + mapPxC f (PixelRGBA r g b a) = + PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelRGBA r1 g1 b1 a1) (PixelRGBA r2 g2 b2 a2) = + f (f (f (f z r1 r2) g1 g2) b1 b2) a1 a2 + {-# INLINE foldlPx2 #-} + + +instance Elevator e => 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 Storable e => Storable (Pixel RGBA e) where + sizeOf _ = 4 * sizeOf (undefined :: e) + alignment _ = alignment (undefined :: e) + peek p = do + q <- return $ castPtr p + r <- peek q + g <- peekElemOff q 1 + b <- peekElemOff q 2 + a <- peekElemOff q 3 + return (PixelRGBA r g b a) + poke p (PixelRGBA r g b a) = do + q <- return $ castPtr p + poke q r + pokeElemOff q 1 g + pokeElemOff q 2 b + pokeElemOff q 3 a diff --git a/src/Graphics/ColorSpace/X.hs b/src/Graphics/ColorSpace/X.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/X.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.X +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.X + ( X(..) + , Pixel(..) + , toPixelsX + , fromPixelsX + ) where + +import Control.Applicative +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 a true grayscale colorspace +-- '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) + + +instance Show e => Show (Pixel X e) where + show (PixelX g) = "" + + +instance Elevator e => ColorSpace X e where + type Components X e = e + + promote = PixelX + {-# INLINE promote #-} + fromComponents = PixelX + {-# INLINE fromComponents #-} + toComponents (PixelX g) = g + {-# INLINE toComponents #-} + getPxC (PixelX g) X = g + {-# INLINE getPxC #-} + setPxC (PixelX _) X g = PixelX g + {-# INLINE setPxC #-} + mapPxC f (PixelX g) = PixelX (f X g) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelX g1) (PixelX g2) = f z g1 g2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel X) where + fmap f (PixelX g) = PixelX (f g) + {-# INLINE fmap #-} + + +instance Applicative (Pixel X) where + pure = PixelX + {-# INLINE pure #-} + (PixelX fg) <*> (PixelX g) = PixelX (fg g) + {-# INLINE (<*>) #-} + + +instance Foldable (Pixel X) where + foldr f !z (PixelX g) = f g z + {-# INLINE foldr #-} + + +instance Monad (Pixel X) where + + return = PixelX + {-# INLINE return #-} + + (>>=) (PixelX g) f = f g + {-# INLINE (>>=) #-} + + +instance Storable e => Storable (Pixel X e) where + + sizeOf _ = sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ castPtr p + g <- peek q + return (PixelX g) + {-# INLINE peek #-} + poke !p (PixelX g) = do + q <- return $ 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 = foldrPx ((:) . PixelX) [] + +-- | 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 (promote 0) where + f !px (c, PixelX x) = setPxC px c x + + + +-- -- | Apply a left fold to each of the pixels in the image. +-- squashWith :: (Array arr cs e, Array arr X b) => +-- (b -> e -> b) -> b -> Image arr cs e -> Image arr X b +-- squashWith f !a = I.map (PixelX . foldlPx f a) where +-- {-# INLINE squashWith #-} + + +-- -- | Combination of zipWith and simultanious left fold on two pixels at the same time. +-- squashWith2 :: (Array arr cs e, Array arr X b) => +-- (b -> e -> e -> b) -> b -> Image arr cs e -> Image arr cs e -> Image arr X b +-- squashWith2 f !a = I.zipWith (PixelX .:! foldlPx2 f a) where +-- {-# INLINE squashWith2 #-} + + +-- -- | Separate an image into a list of images with 'X' pixels containing every +-- -- channel from the source image. +-- -- +-- -- >>> frog <- readImageRGB "images/frog.jpg" +-- -- >>> let [frog_red, frog_green, frog_blue] = toImagesX frog +-- -- >>> writeImage "images/frog_red.png" $ toImageY frog_red +-- -- >>> writeImage "images/frog_green.jpg" $ toImageY frog_green +-- -- >>> writeImage "images/frog_blue.jpg" $ toImageY frog_blue +-- -- +-- -- <> <> <> +-- -- +-- toImagesX :: (Array arr cs e, Array arr X e) => Image arr cs e -> [Image arr X e] +-- toImagesX !img = P.map getCh (enumFrom minBound) where +-- getCh !ch = I.map (PixelX . (`getPxC` ch)) img +-- {-# INLINE getCh #-} +-- {-# INLINE toImagesX #-} + + +-- -- | Combine a list of images with 'X' pixels into an image of any color +-- -- space, by supplying an order of color space channels. +-- -- +-- -- For example here is a frog with swapped 'BlueRGB' and 'GreenRGB' channels. +-- -- +-- -- >>> writeImage "images/frog_rbg.jpg" $ fromImagesX [(RedRGB, frog_red), (BlueRGB, frog_green), (GreenRGB, frog_blue)] +-- -- +-- -- <> <> +-- -- +-- -- It is worth noting though, despite that separating image channels can be +-- -- sometimes pretty useful, exactly the same effect as in example above can be +-- -- achieved in a much simpler and a more efficient way: +-- -- +-- -- @ `I.map` (\\(PixelRGB r g b) -> PixelRGB r b g) frog @ +-- -- +-- fromImagesX :: (Array arr X e, Array arr cs e) => +-- [(cs, Image arr X e)] -> Image arr cs e +-- fromImagesX = fromXs 0 where +-- updateCh !ch !px (PixelX e) = setPxC px ch e +-- {-# INLINE updateCh #-} +-- fromXs img [] = img +-- fromXs img ((c, i):xs) = fromXs (I.zipWith (updateCh c) img i) xs +-- {-# INLINE fromXs #-} +-- {-# INLINE fromImagesX #-} diff --git a/src/Graphics/ColorSpace/Y.hs b/src/Graphics/ColorSpace/Y.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/Y.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.Y +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.Y ( + Y(..), YA(..), Pixel(..) + ) where + +import Control.Applicative +import Data.Foldable +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) + +instance Show e => Show (Pixel Y e) where + show (PixelY g) = "" + +instance Elevator e => ColorSpace Y e where + type Components Y e = e + promote = PixelY + {-# INLINE promote #-} + fromComponents = PixelY + {-# INLINE fromComponents #-} + toComponents (PixelY y) = y + {-# INLINE toComponents #-} + getPxC (PixelY y) LumaY = y + {-# INLINE getPxC #-} + setPxC _ LumaY y = PixelY y + {-# INLINE setPxC #-} + mapPxC f (PixelY y) = PixelY (f LumaY y) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelY y1) (PixelY y2) = f z y1 y2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel Y) where + fmap f (PixelY y) = PixelY (f y) + {-# INLINE fmap #-} + + +instance Applicative (Pixel Y) where + pure = PixelY + {-# INLINE pure #-} + (PixelY fy) <*> (PixelY y) = PixelY (fy y) + {-# INLINE (<*>) #-} + + +instance Foldable (Pixel Y) where + foldr f !z (PixelY y) = f y z + {-# INLINE foldr #-} + + +instance Monad (Pixel Y) where + + return = PixelY + {-# INLINE return #-} + + (>>=) (PixelY y) f = f y + {-# INLINE (>>=) #-} + + + +instance 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 + + +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) + promote e = PixelYA e e + {-# INLINE promote #-} + fromComponents (y, a) = PixelYA y a + {-# INLINE fromComponents #-} + toComponents (PixelYA y a) = (y, a) + {-# INLINE toComponents #-} + getPxC (PixelYA y _) LumaYA = y + getPxC (PixelYA _ a) AlphaYA = a + {-# INLINE getPxC #-} + setPxC (PixelYA _ a) LumaYA y = PixelYA y a + setPxC (PixelYA y _) AlphaYA a = PixelYA y a + {-# INLINE setPxC #-} + mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a) + {-# INLINE mapPxC #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2 + {-# INLINE foldlPx2 #-} + + +instance Elevator e => 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 Storable e => Storable (Pixel YA e) where + + sizeOf _ = 2 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ castPtr p + y <- peekElemOff q 0 + a <- peekElemOff q 1 + return (PixelYA y a) + {-# INLINE peek #-} + poke !p (PixelYA y a) = do + q <- return $ 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/ColorSpace/YCbCr.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.ColorSpace.YCbCr +-- Copyright : (c) Alexey Kuleshevich 2018 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.ColorSpace.YCbCr ( + YCbCr(..), YCbCrA(..), Pixel(..) + ) where + +import Control.Applicative +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 + + +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) + + promote !e = PixelYCbCr e e e + {-# INLINE promote #-} + fromComponents !(y, b, r) = PixelYCbCr y b r + {-# INLINE fromComponents #-} + toComponents (PixelYCbCr y b r) = (y, b, r) + {-# 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 #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelYCbCr y1 b1 r1) (PixelYCbCr y2 b2 r2) = + f (f (f z y1 y2) b1 b2) r1 r2 + {-# INLINE foldlPx2 #-} + + +instance Functor (Pixel YCbCr) where + 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 Storable e => Storable (Pixel YCbCr e) where + + sizeOf _ = 3 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ 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 + q <- return $ 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 + + +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) + + promote !e = PixelYCbCrA e e e e + {-# INLINE promote #-} + fromComponents !(y, b, r, a) = PixelYCbCrA y b r a + {-# INLINE fromComponents #-} + toComponents (PixelYCbCrA y b r a) = (y, b, r, a) + {-# 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 #-} + liftPx = fmap + {-# INLINE liftPx #-} + liftPx2 = liftA2 + {-# INLINE liftPx2 #-} + foldlPx = foldl' + {-# INLINE foldlPx #-} + foldlPx2 f !z (PixelYCbCrA y1 b1 r1 a1) (PixelYCbCrA y2 b2 r2 a2) = + f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2 + {-# INLINE foldlPx2 #-} + + +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 Storable e => Storable (Pixel YCbCrA e) where + + sizeOf _ = 4 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek !p = do + q <- return $ castPtr p + y <- peekElemOff q 0 + b <- peekElemOff q 1 + r <- peekElemOff q 2 + a <- peekElemOff q 3 + return (PixelYCbCrA y b r a) + {-# INLINE peek #-} + poke !p (PixelYCbCrA y b r a) = do + q <- return $ castPtr p + poke q y + pokeElemOff q 1 b + pokeElemOff q 2 r + pokeElemOff q 3 a + {-# INLINE poke #-} + +