{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Array.Accelerate.Data.Colour.SRGB (
Colour,
SRGB,
srgb, srgb8,
toRGB, fromRGB,
) where
import Data.Array.Accelerate as A hiding ( clamp )
import Data.Array.Accelerate.Data.Colour.RGB ( RGB(..) )
import Data.Functor ( fmap )
type Colour = SRGB Float
type SRGB a = RGB a
srgb :: Exp Float
-> Exp Float
-> Exp Float
-> Exp Colour
srgb r g b
= clamp
$ lift (RGB r g b)
srgb8 :: Exp Word8
-> Exp Word8
-> Exp Word8
-> Exp Colour
srgb8 r g b
= lift
$ RGB (fromIntegral r / 255 :: Exp Float)
(fromIntegral g / 255)
(fromIntegral b / 255)
clamp :: Exp Colour -> Exp Colour
clamp = lift1 (fmap c :: SRGB (Exp Float) -> SRGB (Exp Float))
where
c x = 0 `max` x `min` 1
fromRGB :: Exp (RGB Float) -> Exp (SRGB Float)
fromRGB (unlift -> RGB r g b)
= lift
$ RGB (invTransferFunction r)
(invTransferFunction g)
(invTransferFunction b)
toRGB :: Exp (SRGB Float) -> Exp (RGB Float)
toRGB (unlift -> RGB r g b)
= lift
$ RGB (transferFunction r)
(transferFunction g)
(transferFunction b)
transferFunction :: Exp Float -> Exp Float
transferFunction lin
= lin == 1 ? ( 1
, lin <= 0.0031308 ? ( 12.92 * lin
, let a = 0.055
in (1 + a)*lin**(1/2.4) - a ))
invTransferFunction :: Exp Float -> Exp Float
invTransferFunction nonlin
= nonlin == 1 ? ( 1
, nonlin <= 0.04045 ? ( nonlin/12.92
, let a = 0.055
in ((nonlin + a)/(1 + a))**2.4 ))