module Data.Prizm.Color.RGB
( module Data.Prizm.Color.RGB.Types
) where
import Control.Applicative
import Data.Bifunctor as Bifunctor
import Data.Convertible.Base
import qualified Data.Foldable as Foldable
import Data.Monoid
import Data.Prizm.Color.CIE.Matrices.RGB
import Data.Prizm.Color.CIE.Types as CIE
import Data.Prizm.Color.RGB.Types
import Data.Prizm.Color.Transform
import Data.Prizm.Types
import qualified Data.Text as Text
import qualified Data.Text.Read as Text.Read
import Numeric (showHex)
transform :: Integer -> Double
transform v | dv > 0.04045 = (((dv + 0.055) / ap) ** 2.4) * 100
| otherwise = (dv / 12.92) * 100
where dv = fromIntegral v / 255
ap = 1.0 + 0.055
encodeHex :: RGB -> HexRGB
encodeHex (RGB rgb) = HexRGB (Text.pack $ "#" <> (Foldable.foldMap encode rgb))
where
encode x | x <= 0xf = "0"<>(showHex x "")
| otherwise = showHex x ""
decodeHex :: HexRGB -> Either String RGB
decodeHex (HexRGB orig@(Text.uncons -> cell)) =
case cell of
Just ('#', rest) ->
case Text.unpack rest of
[a, b, c, d, e, f, _g, _h]
-> mkRGB <$> hex a b <*> hex c d <*> hex e f
[a, b, c, d, e, f]
-> mkRGB <$> hex a b <*> hex c d <*> hex e f
[a, b, c, _d]
-> mkRGB <$> hex a a <*> hex b b <*> hex c c
[a, b, c]
-> mkRGB <$> hex a a <*> hex b b <*> hex c c
_ -> can'tDecode
_ -> can'tDecode
where
hex :: Char -> Char -> Either String Int
hex a b = Bifunctor.second fst $ Text.Read.hexadecimal (Text.singleton a <> Text.singleton b)
can'tDecode = Left $ "cannot decode "++(Text.unpack orig)
instance Convertible RGB CIE.XYZ where
safeConvert = Right . (toXYZMatrix d65SRGB)
instance Convertible RGB HexRGB where
safeConvert = Right . encodeHex
instance Convertible HexRGB RGB where
safeConvert v = Bifunctor.first convertibleError $ decodeHex v
where
convertibleError msg =
ConvertError
{ convSourceValue = show v
, convSourceType = "HexRGB"
, convDestType = "RGB"
, convErrorMessage = msg
}
toXYZMatrix :: RGBtoXYZ -> RGB -> CIE.XYZ
toXYZMatrix (Matrix m) (unRGB -> ColorCoord(r,g,b)) =
let t = ZipList ((transform . fromIntegral) <$> (clamp <$> [r,g,b]))
[x,y,z] = (roundN 3) <$> ((zipTransform t) <$> m)
in CIE.mkXYZ x y z