ColorSpace.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
-- |
-- Module      : Graphics.Image.ColorSpace
-- Copyright   : (c) Alexey Kuleshevich 2016
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Image.ColorSpace (
  -- * ColorSpace
  ColorSpace, Pixel(..), Alpha, Opaque, Elevator(..),
  -- * Luma
  module Graphics.Image.ColorSpace.Luma,
  -- * RGB
  module Graphics.Image.ColorSpace.RGB,
  -- * HSI
  module Graphics.Image.ColorSpace.HSI,
  -- * CMYK
  module Graphics.Image.ColorSpace.CMYK,
  -- * YCbCr
  module Graphics.Image.ColorSpace.YCbCr,
  -- * Gray
  module Graphics.Image.ColorSpace.Gray,
  -- * Binary
  Binary, Bit, on, off, isOn, isOff, fromBool, complement,
  toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary,
  -- * Complex
  module Graphics.Image.ColorSpace.Complex,
  -- * Re-exports
  Word8, Word16, Word32, Word64
  ) where


import Data.Word
import GHC.Float
import Graphics.Image.Interface hiding (map)
import Graphics.Image.ColorSpace.Binary
import Graphics.Image.ColorSpace.Gray
import Graphics.Image.ColorSpace.Luma
import Graphics.Image.ColorSpace.RGB
import Graphics.Image.ColorSpace.HSI
import Graphics.Image.ColorSpace.CMYK
import Graphics.Image.ColorSpace.YCbCr
import Graphics.Image.ColorSpace.Complex
import qualified Graphics.Image.Interface as I (map)



-- Binary:

-- | Convert any pixel to binary pixel.
toPixelBinary :: (ColorSpace cs, Eq (Pixel cs e), Num e) => Pixel cs e -> Pixel Binary Bit
toPixelBinary px = if px == 0 then on else off
{-# INLINE toPixelBinary #-}

-- | Convert a Binary pixel to Luma pixel
fromPixelBinary :: Pixel Binary Bit -> Pixel Y Word8
fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound
{-# INLINE fromPixelBinary #-}


-- | Convert any image to binary image.
toImageBinary :: (Array arr cs e, Array arr Binary Bit, Eq (Pixel cs e)) =>
                 Image arr cs e
              -> Image arr Binary Bit
toImageBinary = I.map toPixelBinary
{-# INLINE toImageBinary #-}


-- | Convert a Binary image to Luma image
fromImageBinary :: (Array arr Binary Bit, Array arr Y Word8) =>
                   Image arr Binary Bit
                -> Image arr Y Word8
fromImageBinary = I.map fromPixelBinary
{-# INLINE fromImageBinary #-}


-- Conversion:


instance ToY Gray where
  toPixelY (PixelGray y) = PixelY y
  {-# INLINE toPixelY #-}

-- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @
instance ToY RGB where
  toPixelY (PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b)
  {-# INLINE toPixelY #-}

instance ToYA RGBA where

instance ToY HSI where
  toPixelY = toPixelY . toPixelRGB
  {-# INLINE toPixelY #-}

instance ToYA HSIA where

instance ToY CMYK where
  toPixelY = toPixelY . toPixelRGB
  {-# INLINE toPixelY #-}

  
instance ToY YCbCr where
  toPixelY (PixelYCbCr y _ _) = PixelY y
  {-# INLINE toPixelY #-}
  
instance ToYA YCbCrA where
  
instance ToRGB Y where
  toPixelRGB (PixelY g) = fromChannel g
  {-# INLINE toPixelRGB #-}

instance ToRGBA YA where

instance ToRGB HSI where
  toPixelRGB (PixelHSI h' s i) = getRGB (h'*2*pi) where
    !is = i*s
    !second = i - is
    getFirst !a !b = i + is*cos a/cos b
    {-# INLINE getFirst #-}
    getThird !v1 !v2 = i + 2*is + v1 - v2
    {-# INLINE getThird #-}
    getRGB 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')
    {-# INLINE getRGB #-}
  {-# INLINE toPixelRGB #-}

instance ToRGBA HSIA where


instance ToRGB YCbCr where

  toPixelRGB (PixelYCbCr y cb cr) = PixelRGB r g b where
    !r = y                      +   1.402*(cr - 0.5)
    !g = y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5)
    !b = y +   1.772*(cb - 0.5)
  {-# INLINE toPixelRGB #-}

instance ToRGBA YCbCrA where

instance ToRGB CMYK where

  toPixelRGB (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 ToRGBA CMYKA where

  
instance ToHSI Y where
  toPixelHSI (PixelY g) = PixelHSI 0 0 g
  {-# INLINE toPixelHSI #-}

instance ToHSIA YA where
  
instance ToHSI RGB where
  toPixelHSI (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 ToHSIA RGBA where


instance ToYCbCr RGB where

  toPixelYCbCr (PixelRGB r g b) = PixelYCbCr y cb cr where
    !y  =          0.299*r +    0.587*g +    0.114*b
    !cb = 0.5 - 0.168736*r - 0.331264*g +      0.5*b
    !cr = 0.5 +      0.5*r - 0.418688*g - 0.081312*b
  {-# INLINE toPixelYCbCr #-}

instance ToYCbCrA RGBA where
  

instance ToCMYK RGB where

  toPixelCMYK (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 ToCMYKA RGBA where

  
-- | Values are scaled to @[0, 255]@ range.
instance Elevator Word8 where

  toWord8 = id
  {-# INLINE toWord8 #-}

  toWord16 = liftA toWord16' where
    toWord16' !e = fromIntegral e * ((maxBound :: Word16) `div` fromIntegral (maxBound :: Word8)) 
    {-# INLINE toWord16' #-}
  {-# INLINE toWord16 #-}

  toWord32 = liftA toWord32' where
    toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word8)) 
    {-# INLINE toWord32' #-}
  {-# INLINE toWord32 #-}

  toWord64 = liftA toWord64' where
    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word8))
    {-# INLINE toWord64' #-}
  {-# INLINE toWord64 #-}

  toFloat = liftA toFloat' where
    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word8)
    {-# INLINE toFloat' #-}
  {-# INLINE toFloat #-}

  toDouble = liftA toDouble' where
    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word8)
    {-# INLINE toDouble' #-}
  {-# INLINE toDouble #-}

  fromDouble = toWord8
  {-# INLINE fromDouble #-}


-- | Values are scaled to @[0, 65535]@ range.
instance Elevator Word16 where

  toWord8 = liftA toWord8' where
    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word16) `div`
                                                      fromIntegral (maxBound :: Word8)) 
    {-# INLINE toWord8' #-}
  {-# INLINE toWord8 #-}

  toWord16 = id
  {-# INLINE toWord16 #-}
  
  toWord32 = liftA toWord32' where
    toWord32' !e = fromIntegral e * ((maxBound :: Word32) `div` fromIntegral (maxBound :: Word16)) 
    {-# INLINE toWord32' #-}
  {-# INLINE toWord32 #-}

  toWord64 = liftA toWord64' where
    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word16))
    {-# INLINE toWord64' #-}
  {-# INLINE toWord64 #-}

  toFloat = liftA toFloat' where
    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word16)
    {-# INLINE toFloat' #-}
  {-# INLINE toFloat #-}

  toDouble = liftA toDouble' where
    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word16)
    {-# INLINE toDouble' #-}
  {-# INLINE toDouble #-}

  fromDouble = toWord16
  {-# INLINE fromDouble #-}


-- | Values are scaled to @[0, 4294967295]@ range.
instance Elevator Word32 where

  toWord8 = liftA toWord8' where
    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div`
                                                       fromIntegral (maxBound :: Word8)) 
    {-# INLINE toWord8' #-}
  {-# INLINE toWord8 #-}

  toWord16 = liftA toWord16' where
    toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word32) `div`
                                                        fromIntegral (maxBound :: Word16)) 
    {-# INLINE toWord16' #-}
  {-# INLINE toWord16 #-}

  toWord32 = id
  {-# INLINE toWord32 #-}

  toWord64 = liftA toWord64' where
    toWord64' !e = fromIntegral e * ((maxBound :: Word64) `div` fromIntegral (maxBound :: Word32))
    {-# INLINE toWord64' #-}
  {-# INLINE toWord64 #-}

  toFloat = liftA toFloat' where
    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word32)
    {-# INLINE toFloat' #-}
  {-# INLINE toFloat #-}

  toDouble = liftA toDouble' where
    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word32)
    {-# INLINE toDouble' #-}
  {-# INLINE toDouble #-}

  fromDouble = toWord32
  {-# INLINE fromDouble #-}


-- | Values are scaled to @[0, 18446744073709551615]@ range.
instance Elevator Word64 where

  toWord8 = liftA toWord8' where
    toWord8' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`
                                                       fromIntegral (maxBound :: Word8)) 
    {-# INLINE toWord8' #-}
  {-# INLINE toWord8 #-}

  toWord16 = liftA toWord16' where
    toWord16' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`
                                                        fromIntegral (maxBound :: Word16)) 
    {-# INLINE toWord16' #-}
  {-# INLINE toWord16 #-}

  toWord32 = liftA toWord32' where
    toWord32' !e = fromIntegral $ fromIntegral e `div` ((maxBound :: Word64) `div`
                                                        fromIntegral (maxBound :: Word32)) 
    {-# INLINE toWord32' #-}
  {-# INLINE toWord32 #-}

  toWord64 = id
  {-# INLINE toWord64 #-}

  toFloat = liftA toFloat' where
    toFloat' !e = fromIntegral e / fromIntegral (maxBound :: Word64)
    {-# INLINE toFloat' #-}
  {-# INLINE toFloat #-}

  toDouble = liftA toDouble' where
    toDouble' !e = fromIntegral e / fromIntegral (maxBound :: Word64)
    {-# INLINE toDouble' #-}
  {-# INLINE toDouble #-}

  fromDouble = toWord64
  {-# INLINE fromDouble #-}


-- | Values are scaled to @[0.0, 1.0]@ range.
instance Elevator Float where

  toWord8 = liftA toWord8' where
    toWord8' !e = round (fromIntegral (maxBound :: Word8) * e)
    {-# INLINE toWord8' #-}
  {-# INLINE toWord8 #-}

  toWord16 = liftA toWord16' where
    toWord16' !e = round (fromIntegral (maxBound :: Word16) * e)
    {-# INLINE toWord16' #-}
  {-# INLINE toWord16 #-}

  toWord32 = liftA toWord32' where
    toWord32' !e = round (fromIntegral (maxBound :: Word32) * e)
    {-# INLINE toWord32' #-}
  {-# INLINE toWord32 #-}

  toWord64 = liftA toWord64' where
    toWord64' !e = round (fromIntegral (maxBound :: Word64) * e)
    {-# INLINE toWord64' #-}
  {-# INLINE toWord64 #-}

  toFloat = id
  {-# INLINE toFloat #-}

  toDouble = liftA float2Double
  {-# INLINE toDouble #-}

  fromDouble = toFloat
  {-# INLINE fromDouble #-}


-- | Values are scaled to @[0.0, 1.0]@ range.
instance Elevator Double where

  toWord8 = liftA toWord8' where
    toWord8' !e = round (fromIntegral (maxBound :: Word8) * e)
    {-# INLINE toWord8' #-}
  {-# INLINE toWord8 #-}

  toWord16 = liftA toWord16' where
    toWord16' !e = round (fromIntegral (maxBound :: Word16) * e)
    {-# INLINE toWord16' #-}
  {-# INLINE toWord16 #-}

  toWord32 = liftA toWord32' where
    toWord32' !e = round (fromIntegral (maxBound :: Word32) * e)
    {-# INLINE toWord32' #-}
  {-# INLINE toWord32 #-}

  toWord64 = liftA toWord64' where
    toWord64' !e = round (fromIntegral (maxBound :: Word64) * e)
    {-# INLINE toWord64' #-}
  {-# INLINE toWord64 #-}

  toFloat = liftA double2Float
  {-# INLINE toFloat #-}

  toDouble = id
  {-# INLINE toDouble #-}

  fromDouble = id
  {-# INLINE fromDouble #-}