#if __GLASGOW_HASKELL__ >= 800
#endif
module Graphics.Image.ColorSpace (
Pixel(..),
toPixelY, toImageY,
toPixelYA, toImageYA,
toPixelRGB, toImageRGB,
toPixelRGBA, toImageRGBA,
toPixelHSI, toImageHSI,
toPixelHSIA, toImageHSIA,
toPixelCMYK, toImageCMYK,
toPixelCMYKA, toImageCMYKA,
toPixelYCbCr, toImageYCbCr,
toPixelYCbCrA, toImageYCbCrA,
toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary,
module Graphics.Image.ColorSpace.Binary,
module Graphics.Image.ColorSpace.Complex,
squashWith, squashWith2,
toPixelsX, fromPixelsX,
toImagesX, fromImagesX,
eqTolPx,
Y(..), YA(..),
ToY, ToYA,
RGB(..), RGBA(..),
ToRGB, ToRGBA,
HSI(..), HSIA(..),
ToHSI, ToHSIA,
CMYK(..), CMYKA(..),
ToCMYK, ToCMYKA,
YCbCr(..), YCbCrA(..),
ToYCbCr, ToYCbCrA,
X(..),
toWord8I,
toWord16I,
toWord32I,
toFloatI,
toDoubleI,
toWord8Px,
Word8, Word16, Word32, Word64
) where
import Data.Word
import Graphics.Image.ColorSpace.Binary
import Graphics.Image.ColorSpace.CMYK
import Graphics.Image.ColorSpace.Complex
import Graphics.Image.ColorSpace.HSI
import Graphics.Image.ColorSpace.RGB
import Graphics.Image.ColorSpace.X
import Graphics.Image.ColorSpace.Y
import Graphics.Image.ColorSpace.YCbCr
import Graphics.Image.Interface as I
import Graphics.Image.Interface.Elevator
toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel X Bit
toPixelBinary px = if px == 0 then on else off
fromPixelBinary :: Pixel X Bit -> Pixel Y Word8
fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound
toImageBinary :: (Array arr cs e, Array arr X Bit) =>
Image arr cs e
-> Image arr X Bit
toImageBinary = I.map toPixelBinary
fromImageBinary :: (Array arr X Bit, Array arr Y Word8) =>
Image arr X Bit
-> Image arr Y Word8
fromImageBinary = I.map fromPixelBinary
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
class ColorSpace cs e => ToY cs e where
toPixelY :: Pixel cs e -> Pixel Y Double
toImageY :: (ToY cs e, Array arr cs e, Array arr Y Double) =>
Image arr cs e
-> Image arr Y Double
toImageY = I.map toPixelY
instance Elevator e => ToY X e where
toPixelY (PixelX y) = PixelY $ toDouble y
instance Elevator e => ToY Y e where
toPixelY (PixelY y) = PixelY $ toDouble y
instance Elevator e => ToY YA e where
toPixelY (PixelYA y _) = PixelY $ toDouble y
instance Elevator e => ToY RGB e where
toPixelY (fmap toDouble -> (PixelRGB r g b)) = PixelY (0.299*r + 0.587*g + 0.114*b)
instance Elevator e => ToY RGBA e where
toPixelY = toPixelY . dropAlpha
instance Elevator e => ToY HSI e where
toPixelY = toPixelY . toPixelRGB . fmap toDouble
instance Elevator e => ToY HSIA e where
toPixelY = toPixelY . dropAlpha
instance Elevator e => ToY CMYK e where
toPixelY = toPixelY . toPixelRGB . fmap toDouble
instance Elevator e => ToY CMYKA e where
toPixelY = toPixelY . toPixelRGB . fmap toDouble . dropAlpha
instance Elevator e => ToY YCbCr e where
toPixelY (PixelYCbCr y _ _) = PixelY $ toDouble y
instance Elevator e => ToY YCbCrA e where
toPixelY (PixelYCbCrA y _ _ _) = PixelY $ toDouble y
class ToY cs e => ToYA cs e where
toPixelYA :: Pixel cs e -> Pixel YA Double
toPixelYA = addAlpha 1 . toPixelY
toImageYA :: (ToYA cs e, Array arr cs e, Array arr YA Double) =>
Image arr cs e
-> Image arr YA Double
toImageYA = I.map toPixelYA
instance ToYA X Bit where
toPixelYA (PixelX y) = PixelYA (toDouble y) 1
instance ToY Y e => ToYA Y e
instance Elevator e => ToYA YA e where
toPixelYA = fmap toDouble
instance ToY RGB e => ToYA RGB e
instance Elevator e => ToYA RGBA e where
toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px))
instance ToY HSI e => ToYA HSI e
instance Elevator e => ToYA HSIA e where
toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px))
instance ToY CMYK e => ToYA CMYK e
instance Elevator e => ToYA CMYKA e where
toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px))
instance ToY YCbCr e => ToYA YCbCr e
instance Elevator e => ToYA YCbCrA e where
toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px))
class ColorSpace cs e => ToRGB cs e where
toPixelRGB :: Pixel cs e -> Pixel RGB Double
toImageRGB :: (ToRGB cs e, Array arr cs e, Array arr RGB Double) =>
Image arr cs e
-> Image arr RGB Double
toImageRGB = I.map toPixelRGB
instance ToRGB X Bit where
toPixelRGB (PixelX b) = pure $ toDouble b
instance Elevator e => ToRGB Y e where
toPixelRGB (PixelY g) = promote $ toDouble g
instance Elevator e => ToRGB YA e where
toPixelRGB = toPixelRGB . dropAlpha
instance Elevator e => ToRGB RGB e where
toPixelRGB = fmap toDouble
instance Elevator e => ToRGB RGBA e where
toPixelRGB = fmap toDouble . dropAlpha
instance Elevator e => ToRGB HSI e where
toPixelRGB (fmap toDouble -> PixelHSI h' s i) = getRGB (h'*2*pi) where
!is = i*s
!second = i is
getFirst !a !b = i + is*cos a/cos b
getThird !v1 !v2 = i + 2*is + v1 v2
getRGB h
| h < 0 = error ("HSI pixel is not properly scaled, Hue: "++show h')
| h < 2*pi/3 = let !r = getFirst h (pi/3 h)
!b = second
!g = getThird b r
in PixelRGB r g b
| h < 4*pi/3 = let !g = getFirst (h 2*pi/3) (h + pi)
!r = second
!b = getThird r g
in PixelRGB r g b
| h < 2*pi = let !b = getFirst (h 4*pi/3) (2*pi pi/3 h)
!g = second
!r = getThird g b
in PixelRGB r g b
| otherwise = error ("HSI pixel is not properly scaled, Hue: "++show h')
instance Elevator e => ToRGB HSIA e where
toPixelRGB = toPixelRGB . dropAlpha
instance Elevator e => ToRGB YCbCr e where
toPixelRGB (fmap 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))
instance Elevator e => ToRGB YCbCrA e where
toPixelRGB = toPixelRGB . dropAlpha
instance Elevator e => ToRGB CMYK e where
toPixelRGB (fmap toDouble -> PixelCMYK c m y k) = PixelRGB r g b where
!r = (1c)*(1k)
!g = (1m)*(1k)
!b = (1y)*(1k)
instance Elevator e => ToRGB CMYKA e where
toPixelRGB = toPixelRGB . dropAlpha
class ToRGB cs e => ToRGBA cs e where
toPixelRGBA :: Pixel cs e -> Pixel RGBA Double
toPixelRGBA = addAlpha 1 . toPixelRGB
toImageRGBA :: (ToRGBA cs e, Array arr cs e, Array arr RGBA Double) =>
Image arr cs e
-> Image arr RGBA Double
toImageRGBA = I.map toPixelRGBA
instance ToRGBA X Bit
instance ToRGB Y e => ToRGBA Y e
instance Elevator e => ToRGBA YA e where
toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
instance ToRGB RGB e => ToRGBA RGB e
instance Elevator e => ToRGBA RGBA e where
toPixelRGBA = fmap toDouble
instance ToRGB HSI e => ToRGBA HSI e
instance Elevator e => ToRGBA HSIA e where
toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
instance ToRGB CMYK e => ToRGBA CMYK e
instance Elevator e => ToRGBA CMYKA e where
toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
instance ToRGB YCbCr e => ToRGBA YCbCr e
instance Elevator e => ToRGBA YCbCrA e where
toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
class ColorSpace cs e => ToHSI cs e where
toPixelHSI :: Pixel cs e -> Pixel HSI Double
toImageHSI :: (ToHSI cs e, Array arr cs e, Array arr HSI Double) =>
Image arr cs e
-> Image arr HSI Double
toImageHSI = I.map toPixelHSI
instance Elevator e => ToHSI Y e where
toPixelHSI (PixelY y) = PixelHSI 0 0 $ toDouble y
instance Elevator e => ToHSI YA e where
toPixelHSI = toPixelHSI . dropAlpha
instance Elevator e => ToHSI RGB e where
toPixelHSI (fmap 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
instance Elevator e => ToHSI RGBA e where
toPixelHSI = toPixelHSI . dropAlpha
instance Elevator e => ToHSI HSI e where
toPixelHSI = fmap toDouble
instance Elevator e => ToHSI HSIA e where
toPixelHSI = toPixelHSI . dropAlpha
instance Elevator e => ToHSI YCbCr e where
toPixelHSI = toPixelHSI . toPixelRGB
instance Elevator e => ToHSI YCbCrA e where
toPixelHSI = toPixelHSI . dropAlpha
instance Elevator e => ToHSI CMYK e where
toPixelHSI = toPixelHSI . toPixelRGB
instance Elevator e => ToHSI CMYKA e where
toPixelHSI = toPixelHSI . dropAlpha
class ToHSI cs e => ToHSIA cs e where
toPixelHSIA :: Pixel cs e -> Pixel HSIA Double
toPixelHSIA = addAlpha 1 . toPixelHSI
toImageHSIA :: (ToHSIA cs e, Array arr cs e, Array arr HSIA Double) =>
Image arr cs e
-> Image arr HSIA Double
toImageHSIA = I.map toPixelHSIA
instance ToHSI Y e => ToHSIA Y e
instance Elevator e => ToHSIA YA e where
toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
instance ToHSI RGB e => ToHSIA RGB e
instance Elevator e => ToHSIA RGBA e where
toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
instance ToHSI HSI e => ToHSIA HSI e
instance Elevator e => ToHSIA HSIA e where
toPixelHSIA = fmap toDouble
instance ToHSI CMYK e => ToHSIA CMYK e
instance Elevator e => ToHSIA CMYKA e where
toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
instance ToHSI YCbCr e => ToHSIA YCbCr e
instance Elevator e => ToHSIA YCbCrA e where
toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
class ColorSpace cs e => ToCMYK cs e where
toPixelCMYK :: Pixel cs e -> Pixel CMYK Double
toImageCMYK :: (ToCMYK cs e, Array arr cs e, Array arr CMYK Double) =>
Image arr cs e
-> Image arr CMYK Double
toImageCMYK = I.map toPixelCMYK
instance Elevator e => ToCMYK Y e where
toPixelCMYK = toPixelCMYK . toPixelRGB
instance Elevator e => ToCMYK YA e where
toPixelCMYK = toPixelCMYK . dropAlpha
instance Elevator e => ToCMYK RGB e where
toPixelCMYK (fmap 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)
instance Elevator e => ToCMYK RGBA e where
toPixelCMYK = toPixelCMYK . dropAlpha
instance Elevator e => ToCMYK HSI e where
toPixelCMYK = toPixelCMYK . toPixelRGB
instance Elevator e => ToCMYK HSIA e where
toPixelCMYK = toPixelCMYK . dropAlpha
instance Elevator e => ToCMYK CMYK e where
toPixelCMYK = fmap toDouble
instance Elevator e => ToCMYK CMYKA e where
toPixelCMYK = toPixelCMYK . dropAlpha
instance Elevator e => ToCMYK YCbCr e where
toPixelCMYK = toPixelCMYK . toPixelRGB
instance Elevator e => ToCMYK YCbCrA e where
toPixelCMYK = toPixelCMYK . dropAlpha
class ToCMYK cs e => ToCMYKA cs e where
toPixelCMYKA :: Pixel cs e -> Pixel CMYKA Double
toPixelCMYKA = addAlpha 1 . toPixelCMYK
toImageCMYKA :: (ToCMYKA cs e, Array arr cs e, Array arr CMYKA Double) =>
Image arr cs e
-> Image arr CMYKA Double
toImageCMYKA = I.map toPixelCMYKA
instance ToCMYK Y e => ToCMYKA Y e
instance Elevator e => ToCMYKA YA e where
toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
instance ToCMYK RGB e => ToCMYKA RGB e
instance Elevator e => ToCMYKA RGBA e where
toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
instance ToCMYK HSI e => ToCMYKA HSI e
instance Elevator e => ToCMYKA HSIA e where
toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
instance ToCMYK CMYK e => ToCMYKA CMYK e
instance Elevator e => ToCMYKA CMYKA e where
toPixelCMYKA = fmap toDouble
instance ToCMYK YCbCr e => ToCMYKA YCbCr e
instance Elevator e => ToCMYKA YCbCrA e where
toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
class ColorSpace cs e => ToYCbCr cs e where
toPixelYCbCr :: Pixel cs e -> Pixel YCbCr Double
toImageYCbCr :: (ToYCbCr cs e, Array arr cs e, Array arr YCbCr Double) =>
Image arr cs e
-> Image arr YCbCr Double
toImageYCbCr = I.map toPixelYCbCr
instance Elevator e => ToYCbCr Y e where
toPixelYCbCr = toPixelYCbCr . toPixelRGB
instance Elevator e => ToYCbCr YA e where
toPixelYCbCr = toPixelYCbCr . dropAlpha
instance Elevator e => ToYCbCr RGB e where
toPixelYCbCr (fmap 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)
instance Elevator e => ToYCbCr RGBA e where
toPixelYCbCr = toPixelYCbCr . dropAlpha
instance Elevator e => ToYCbCr HSI e where
toPixelYCbCr = toPixelYCbCr . toPixelRGB
instance Elevator e => ToYCbCr HSIA e where
toPixelYCbCr = toPixelYCbCr . dropAlpha
instance Elevator e => ToYCbCr YCbCr e where
toPixelYCbCr = fmap toDouble
instance Elevator e => ToYCbCr YCbCrA e where
toPixelYCbCr = toPixelYCbCr . dropAlpha
instance Elevator e => ToYCbCr CMYK e where
toPixelYCbCr = toPixelYCbCr . toPixelRGB
instance Elevator e => ToYCbCr CMYKA e where
toPixelYCbCr = toPixelYCbCr . dropAlpha
class ToYCbCr cs e => ToYCbCrA cs e where
toPixelYCbCrA :: Pixel cs e -> Pixel YCbCrA Double
toPixelYCbCrA = addAlpha 1 . toPixelYCbCr
toImageYCbCrA :: (ToYCbCrA cs e, Array arr cs e, Array arr YCbCrA Double) =>
Image arr cs e
-> Image arr YCbCrA Double
toImageYCbCrA = I.map toPixelYCbCrA
instance ToYCbCr Y e => ToYCbCrA Y e
instance Elevator e => ToYCbCrA YA e where
toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance ToYCbCr RGB e => ToYCbCrA RGB e
instance ToYCbCr HSI e => ToYCbCrA HSI e
instance Elevator e => ToYCbCrA HSIA e where
toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance Elevator e => ToYCbCrA RGBA e where
toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance ToYCbCr CMYK e => ToYCbCrA CMYK e
instance Elevator e => ToYCbCrA CMYKA e where
toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance ToYCbCr YCbCr e => ToYCbCrA YCbCr e
instance Elevator e => ToYCbCrA YCbCrA e where
toPixelYCbCrA = fmap toDouble
toWord8I :: (Functor (Pixel cs), Array arr cs e, Array arr cs Word8)
=> Image arr cs e -> Image arr cs Word8
toWord8I = I.map (fmap toWord8)
toWord16I :: (Functor (Pixel cs), Array arr cs e, Array arr cs Word16)
=> Image arr cs e -> Image arr cs Word16
toWord16I = I.map (fmap toWord16)
toWord32I :: (Functor (Pixel cs), Array arr cs e, Array arr cs Word32)
=> Image arr cs e -> Image arr cs Word32
toWord32I = I.map (fmap toWord32)
toFloatI :: (Functor (Pixel cs), Array arr cs e, Array arr cs Float)
=> Image arr cs e -> Image arr cs Float
toFloatI = I.map (fmap toFloat)
toDoubleI :: (Functor (Pixel cs), Array arr cs e, Array arr cs Double)
=> Image arr cs e -> Image arr cs Double
toDoubleI = I.map (fmap toDouble)
toWord8Px :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word8
toWord8Px = fmap toWord8