#if __GLASGOW_HASKELL__ >= 800
#endif
module Graphics.ColorSpace (
Pixel(..)
, ColorSpace(..)
, AlphaSpace(..)
, toPixelY
, toPixelYA
, toPixelRGB
, toPixelRGBA
, toPixelHSI
, toPixelHSIA
, toPixelCMYK
, toPixelCMYKA
, toPixelYCbCr
, toPixelYCbCrA
, toPixelBinary
, fromPixelBinary
, module Graphics.ColorSpace.Binary
, module Graphics.ColorSpace.Complex
, toPixelsX
, fromPixelsX
, eqTolPx
,Y(..), YA(..),
ToY, ToYA,
RGB(..), RGBA(..),
ToRGB, ToRGBA,
HSI(..), HSIA(..),
ToHSI, ToHSIA,
CMYK(..), CMYKA(..),
ToCMYK, ToCMYKA,
YCbCr(..), YCbCrA(..),
ToYCbCr, ToYCbCrA,
X(..),
Elevator,
toWord8,
toWord16,
toWord32,
toWord64,
toFloat,
toDouble,
fromDouble,
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
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
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
instance Elevator e => ToY X e where
toPixelY (PixelX y) = PixelY $ eToDouble y
instance Elevator e => ToY Y e where
toPixelY (PixelY y) = PixelY $ eToDouble y
instance Elevator e => ToY YA e where
toPixelY (PixelYA y _) = PixelY $ eToDouble y
instance Elevator e => ToY RGB e where
toPixelY (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 . toDouble
instance Elevator e => ToY HSIA e where
toPixelY = toPixelY . dropAlpha
instance Elevator e => ToY CMYK e where
toPixelY = toPixelY . toPixelRGB . toDouble
instance Elevator e => ToY CMYKA e where
toPixelY = toPixelY . toPixelRGB . toDouble . dropAlpha
instance Elevator e => ToY YCbCr e where
toPixelY (PixelYCbCr y _ _) = PixelY $ eToDouble y
instance Elevator e => ToY YCbCrA e where
toPixelY (PixelYCbCrA y _ _ _) = PixelY $ eToDouble y
class ToY cs e => ToYA cs e where
toPixelYA :: Pixel cs e -> Pixel YA Double
toPixelYA = addAlpha 1 . toPixelY
instance ToYA X Bit where
toPixelYA (PixelX y) = PixelYA (eToDouble y) 1
instance ToY Y e => ToYA Y e
instance Elevator e => ToYA YA e where
toPixelYA = toDouble
instance ToY RGB e => ToYA RGB e
instance Elevator e => ToYA RGBA e where
toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))
instance ToY HSI e => ToYA HSI e
instance Elevator e => ToYA HSIA e where
toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))
instance ToY CMYK e => ToYA CMYK e
instance Elevator e => ToYA CMYKA e where
toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))
instance ToY YCbCr e => ToYA YCbCr e
instance Elevator e => ToYA YCbCrA e where
toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))
class ColorSpace cs e => ToRGB cs e where
toPixelRGB :: Pixel cs e -> Pixel RGB Double
instance ToRGB X Bit where
toPixelRGB (PixelX b) = promote $ eToDouble b
instance Elevator e => ToRGB Y e where
toPixelRGB (PixelY g) = promote $ eToDouble g
instance Elevator e => ToRGB YA e where
toPixelRGB = toPixelRGB . dropAlpha
instance Elevator e => ToRGB RGB e where
toPixelRGB = toDouble
instance Elevator e => ToRGB RGBA e where
toPixelRGB = toDouble . dropAlpha
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
getThird !v1 !v2 = i + 2*is + v1 v2
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
instance Elevator e => ToRGB HSIA e where
toPixelRGB = toPixelRGB . dropAlpha
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))
instance Elevator e => ToRGB YCbCrA e where
toPixelRGB = toPixelRGB . dropAlpha
instance Elevator e => ToRGB CMYK e where
toPixelRGB (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
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))
instance ToRGB RGB e => ToRGBA RGB e
instance Elevator e => ToRGBA RGBA e where
toPixelRGBA = toDouble
instance ToRGB HSI e => ToRGBA HSI e
instance Elevator e => ToRGBA HSIA e where
toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
instance ToRGB CMYK e => ToRGBA CMYK e
instance Elevator e => ToRGBA CMYKA e where
toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
instance ToRGB YCbCr e => ToRGBA YCbCr e
instance Elevator e => ToRGBA YCbCrA e where
toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))
class ColorSpace cs e => ToHSI cs e where
toPixelHSI :: Pixel cs e -> Pixel HSI Double
instance Elevator e => ToHSI Y e where
toPixelHSI (PixelY y) = PixelHSI 0 0 $ eToDouble y
instance Elevator e => ToHSI YA e where
toPixelHSI = toPixelHSI . dropAlpha
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
instance Elevator e => ToHSI RGBA e where
toPixelHSI = toPixelHSI . dropAlpha
instance Elevator e => ToHSI HSI e where
toPixelHSI = 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
instance ToHSI Y e => ToHSIA Y e
instance Elevator e => ToHSIA YA e where
toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
instance ToHSI RGB e => ToHSIA RGB e
instance Elevator e => ToHSIA RGBA e where
toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
instance ToHSI HSI e => ToHSIA HSI e
instance Elevator e => ToHSIA HSIA e where
toPixelHSIA = toDouble
instance ToHSI CMYK e => ToHSIA CMYK e
instance Elevator e => ToHSIA CMYKA e where
toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
instance ToHSI YCbCr e => ToHSIA YCbCr e
instance Elevator e => ToHSIA YCbCrA e where
toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))
class ColorSpace cs e => ToCMYK cs e where
toPixelCMYK :: Pixel cs e -> Pixel CMYK Double
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 (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 = 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
instance ToCMYK Y e => ToCMYKA Y e
instance Elevator e => ToCMYKA YA e where
toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
instance ToCMYK RGB e => ToCMYKA RGB e
instance Elevator e => ToCMYKA RGBA e where
toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
instance ToCMYK HSI e => ToCMYKA HSI e
instance Elevator e => ToCMYKA HSIA e where
toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
instance ToCMYK CMYK e => ToCMYKA CMYK e
instance Elevator e => ToCMYKA CMYKA e where
toPixelCMYKA = toDouble
instance ToCMYK YCbCr e => ToCMYKA YCbCr e
instance Elevator e => ToCMYKA YCbCrA e where
toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))
class ColorSpace cs e => ToYCbCr cs e where
toPixelYCbCr :: Pixel cs e -> Pixel YCbCr Double
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 (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 = 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
instance ToYCbCr Y e => ToYCbCrA Y e
instance Elevator e => ToYCbCrA YA e where
toPixelYCbCrA !px = addAlpha (eToDouble $ 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 (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance Elevator e => ToYCbCrA RGBA e where
toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance ToYCbCr CMYK e => ToYCbCrA CMYK e
instance Elevator e => ToYCbCrA CMYKA e where
toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))
instance ToYCbCr YCbCr e => ToYCbCrA YCbCr e
instance Elevator e => ToYCbCrA YCbCrA e where
toPixelYCbCrA = toDouble
toWord8 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word8
toWord8 = fmap eToWord8
toWord16 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word16
toWord16 = fmap eToWord16
toWord32 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word32
toWord32 = fmap eToWord32
toWord64 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word64
toWord64 = fmap eToWord64
toFloat :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Float
toFloat = fmap eToFloat
toDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Double
toDouble = fmap eToDouble
fromDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs Double -> Pixel cs e
fromDouble = fmap eFromDouble