Conversion.hs

{-# LANGUAGE BangPatterns
           , MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- 'Convertible' instances for conversions between pixel types.
module Vision.Image.Conversion (Convertible (..), convert) where

import Data.Convertible (Convertible (..), ConvertResult, convert)
import Data.Word

import qualified Data.Vector.Storable as VS

import Vision.Image.Grey.Type (GreyPixel (..))
import Vision.Image.HSV.Type (HSVPixel (..))
import Vision.Image.RGBA.Type (RGBAPixel (..))
import Vision.Image.RGB.Type (RGBPixel (..))

-- to Grey ---------------------------------------------------------------------

instance Convertible GreyPixel GreyPixel where
    safeConvert = Right
    {-# INLINE safeConvert #-}

instance Convertible HSVPixel GreyPixel where
    safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)
                      >>= safeConvert

instance Convertible RGBAPixel GreyPixel where
    safeConvert !(RGBAPixel r g b a) =
        Right $ GreyPixel $ word8 $ int (rgbToGrey r g b) * int a `quot` 255
    {-# INLINE safeConvert #-}

instance Convertible RGBPixel GreyPixel where
    safeConvert !(RGBPixel r g b) =
        Right $ GreyPixel $ rgbToGrey r g b
    {-# INLINE safeConvert #-}

-- | Converts the colors to greyscale using the human eye colors perception.
rgbToGrey :: Word8 -> Word8 -> Word8 -> Word8
rgbToGrey !r !g !b =   (redLookupTable   VS.! int r)
                     + (greenLookupTable VS.! int g)
                     + (blueLookupTable  VS.! int b)
{-# INLINE rgbToGrey #-}

redLookupTable, greenLookupTable, blueLookupTable :: VS.Vector Word8
redLookupTable   = VS.generate 256 (\val -> round $ double val * 0.299)
greenLookupTable = VS.generate 256 (\val -> round $ double val * 0.587)
blueLookupTable  = VS.generate 256 (\val -> round $ double val * 0.114)

-- to HSV ----------------------------------------------------------------------

instance Convertible HSVPixel HSVPixel where
    safeConvert = Right
    {-# INLINE safeConvert #-}

instance Convertible GreyPixel HSVPixel where
    safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)
                      >>= safeConvert

instance Convertible RGBPixel HSVPixel where
-- Based on :
-- http://en.wikipedia.org/wiki/HSL_and_HSV#General_approach
    safeConvert !(RGBPixel r g b) =
        Right pix
      where
        (!r', !g', !b') = (int r, int g, int b)

        !pix | r >= g && r >= b = -- r == max r g b
                let !c = r' - min b' g'
                    !h = fixHue $ hue c b' g' -- Hue can be negative
                in HSVPixel (word8 h) (sat c r') r
             | g >= r && g >= b = -- g == max r g b
                let !c = g' - min r' b'
                    !h = 60 + hue c r' b'
                in HSVPixel (word8 h) (sat c g') g
             | otherwise = -- b == max r g b
                let !c = b' - min r' g'
                    !h = 120 + hue c g' r'
                in HSVPixel (word8 h) (sat c b') b

        -- Returns a value in [-30; +30].
        hue 0  _      _     = 0
        hue !c !left !right = (30 * (right - left)) `quot` c

        sat _  0 = 0
        sat !c v = word8 $ (c * 255) `quot` v

        -- Keeps the value of the hue between [0, 179].
        -- As the Hue's unit is 2°, 180 is equal to 360° and to 0°.
        fixHue !h | h < 0     = h + 180
                  | otherwise = h

instance Convertible RGBAPixel HSVPixel where
    safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)
                      >>= safeConvert

-- to RGB ----------------------------------------------------------------------

instance Convertible RGBPixel RGBPixel where
    safeConvert = Right
    {-# INLINE safeConvert #-}

instance Convertible GreyPixel RGBPixel where
    safeConvert !(GreyPixel pix) = Right $ RGBPixel pix pix pix
    {-# INLINE safeConvert #-}

instance Convertible RGBAPixel RGBPixel where
    safeConvert !(RGBAPixel r g b a) =
        Right $ RGBPixel (withAlpha r) (withAlpha g) (withAlpha b)
      where
        !a' = int a
        withAlpha !val = word8 $ int val * a' `quot` 255
        {-# INLINE withAlpha #-}
    {-# INLINE safeConvert #-}

instance Convertible HSVPixel RGBPixel where
-- Based on :
-- http://en.wikipedia.org/wiki/HSL_and_HSV#Converting_to_RGB
    safeConvert !(HSVPixel h s v) =
        Right $! case h `quot` 30 of
                0 -> RGBPixel v                (word8 x1')      (word8 m)
                1 -> RGBPixel (word8 (x2 60))  v                (word8 m)
                2 -> RGBPixel (word8 m)        v                (word8 (x1 60))
                3 -> RGBPixel (word8 m)        (word8 (x2 120)) v
                4 -> RGBPixel (word8 (x1 120)) (word8 m)        v
                5 -> RGBPixel v                (word8 m)        (word8 (x2 180))
                _ -> error "Invalid hue value."
      where
        (!h', v') = (int h, int v)

        -- v is the major color component whereas m is the minor one.
        !m = (v' * (255 - int s)) `quot` 255

        -- Computes the remaining component by resolving the hue equation,
        -- knowing v and m. x1 is when the component is on the right of the
        -- major one, x2 when on the left.
        x1 d = (d * m - d * v' + h' * v' - h' * m + 30 * m) `quot` 30
        x1'  = (                 h' * v' - h' * m + 30 * m) `quot` 30 -- == x1 0

        x2 d = (d * v' - d * m + h' * m - h' * v' + 30 * m) `quot` 30
    {-# INLINE safeConvert #-}

-- to RGBA ---------------------------------------------------------------------

instance Convertible RGBAPixel RGBAPixel where
    safeConvert = Right
    {-# INLINE safeConvert #-}

instance Convertible GreyPixel RGBAPixel where
    safeConvert !(GreyPixel pix) = Right $ RGBAPixel pix pix pix 255
    {-# INLINE safeConvert #-}

instance Convertible HSVPixel RGBAPixel where
    safeConvert pix = (safeConvert pix :: ConvertResult RGBPixel)
                      >>= safeConvert

instance Convertible RGBPixel RGBAPixel where
    safeConvert !(RGBPixel r g b) = Right $ RGBAPixel r g b 255
    {-# INLINE safeConvert #-}

-- -----------------------------------------------------------------------------

double :: Integral a => a -> Double
double = fromIntegral

int :: Integral a => a -> Int
int = fromIntegral

word8 :: Integral a => a -> Word8
word8 = fromIntegral