{-|
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Reanimate.ColorSpace
  ( Nanometer
  , coneSensitivity
  , bigXYZCoordinates
  , lightXYZCoordinates
  , nmToColor
  ) where

import qualified Data.ByteString.Lazy       as BS
import           Data.Colour.CIE
import           Data.Csv
import           Data.Map                   (Map)
import qualified Data.Map                   as Map
import           Data.Maybe
import qualified Data.Vector                as V
import           Paths_reanimate
import           System.IO.Unsafe

-- | Wavelengths in nanometers.
type Nanometer = Integer

{-# NOINLINE lightXYZCoordinates #-}
-- | (small) xyz values for each wavelength of light.
lightXYZCoordinates :: Map Nanometer (Double, Double, Double)
lightXYZCoordinates :: Map Nanometer (Double, Double, Double)
lightXYZCoordinates = IO (Map Nanometer (Double, Double, Double))
-> Map Nanometer (Double, Double, Double)
forall a. IO a -> a
unsafePerformIO (IO (Map Nanometer (Double, Double, Double))
 -> Map Nanometer (Double, Double, Double))
-> IO (Map Nanometer (Double, Double, Double))
-> Map Nanometer (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ do
  ByteString
dat <- FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString) -> IO FilePath -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
getDataFileName FilePath
"data/CIExyz.csv"
  case HasHeader
-> ByteString
-> Either FilePath (Vector (Nanometer, Double, Double, Double))
forall a.
FromRecord a =>
HasHeader -> ByteString -> Either FilePath (Vector a)
decode HasHeader
NoHeader ByteString
dat of
    Left FilePath
err -> FilePath -> IO (Map Nanometer (Double, Double, Double))
forall a. HasCallStack => FilePath -> a
error FilePath
err
    Right Vector (Nanometer, Double, Double, Double)
vec -> Map Nanometer (Double, Double, Double)
-> IO (Map Nanometer (Double, Double, Double))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Nanometer (Double, Double, Double)
 -> IO (Map Nanometer (Double, Double, Double)))
-> Map Nanometer (Double, Double, Double)
-> IO (Map Nanometer (Double, Double, Double))
forall a b. (a -> b) -> a -> b
$ [(Nanometer, (Double, Double, Double))]
-> Map Nanometer (Double, Double, Double)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Nanometer
nm, (Double
x,Double
y,Double
z)) | (Nanometer
nm,Double
x,Double
y,Double
z) <- Vector (Nanometer, Double, Double, Double)
-> [(Nanometer, Double, Double, Double)]
forall a. Vector a -> [a]
V.toList Vector (Nanometer, Double, Double, Double)
vec, Nanometer
nm Nanometer -> Nanometer -> Bool
forall a. Ord a => a -> a -> Bool
<= Nanometer
700 ]

{-# NOINLINE bigXYZCoordinates #-}
-- | (big) XYZ values for each wavelength of light.
bigXYZCoordinates :: Map Nanometer (Double, Double, Double)
bigXYZCoordinates :: Map Nanometer (Double, Double, Double)
bigXYZCoordinates = IO (Map Nanometer (Double, Double, Double))
-> Map Nanometer (Double, Double, Double)
forall a. IO a -> a
unsafePerformIO (IO (Map Nanometer (Double, Double, Double))
 -> Map Nanometer (Double, Double, Double))
-> IO (Map Nanometer (Double, Double, Double))
-> Map Nanometer (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ do
  ByteString
dat <- FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString) -> IO FilePath -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
getDataFileName FilePath
"data/CIE_XYZ.csv"
  case HasHeader
-> ByteString
-> Either FilePath (Vector (Nanometer, Double, Double, Double))
forall a.
FromRecord a =>
HasHeader -> ByteString -> Either FilePath (Vector a)
decode HasHeader
NoHeader ByteString
dat of
    Left FilePath
err -> FilePath -> IO (Map Nanometer (Double, Double, Double))
forall a. HasCallStack => FilePath -> a
error FilePath
err
    Right Vector (Nanometer, Double, Double, Double)
vec -> Map Nanometer (Double, Double, Double)
-> IO (Map Nanometer (Double, Double, Double))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Nanometer (Double, Double, Double)
 -> IO (Map Nanometer (Double, Double, Double)))
-> Map Nanometer (Double, Double, Double)
-> IO (Map Nanometer (Double, Double, Double))
forall a b. (a -> b) -> a -> b
$ [(Nanometer, (Double, Double, Double))]
-> Map Nanometer (Double, Double, Double)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Nanometer
nm, (Double
x,Double
y,Double
z)) | (Nanometer
nm,Double
x,Double
y,Double
z) <- Vector (Nanometer, Double, Double, Double)
-> [(Nanometer, Double, Double, Double)]
forall a. Vector a -> [a]
V.toList Vector (Nanometer, Double, Double, Double)
vec, Nanometer
nm Nanometer -> Nanometer -> Bool
forall a. Ord a => a -> a -> Bool
<= Nanometer
700 ]

-- | Helper function for converting a wavelength of light into the
--   perceived color.
nmToColor :: Nanometer -> Maybe (Colour Double)
nmToColor :: Nanometer -> Maybe (Colour Double)
nmToColor Nanometer
nm = do
  (Double
x, Double
y, Double
z) <- Nanometer
-> Map Nanometer (Double, Double, Double)
-> Maybe (Double, Double, Double)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Nanometer
nm Map Nanometer (Double, Double, Double)
bigXYZCoordinates
  Colour Double -> Maybe (Colour Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Colour Double -> Maybe (Colour Double))
-> Colour Double -> Maybe (Colour Double)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Colour Double
forall a. Fractional a => a -> a -> a -> Colour a
cieXYZ Double
x Double
y Double
z

{-# NOINLINE coneSensitivity #-}
-- (Long, Medium, Short)
-- | Cone sensitivity by light wavelength.
coneSensitivity :: Map Nanometer (Double, Double, Double)
coneSensitivity :: Map Nanometer (Double, Double, Double)
coneSensitivity = IO (Map Nanometer (Double, Double, Double))
-> Map Nanometer (Double, Double, Double)
forall a. IO a -> a
unsafePerformIO (IO (Map Nanometer (Double, Double, Double))
 -> Map Nanometer (Double, Double, Double))
-> IO (Map Nanometer (Double, Double, Double))
-> Map Nanometer (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ do
  ByteString
dat <- FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString) -> IO FilePath -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
getDataFileName FilePath
"data/cone_sensitivity_lms.csv"
  case HasHeader
-> ByteString
-> Either
     FilePath (Vector (Nanometer, Double, Double, Maybe Double))
forall a.
FromRecord a =>
HasHeader -> ByteString -> Either FilePath (Vector a)
decode HasHeader
NoHeader ByteString
dat of
    Left FilePath
err -> FilePath -> IO (Map Nanometer (Double, Double, Double))
forall a. HasCallStack => FilePath -> a
error FilePath
err
    Right Vector (Nanometer, Double, Double, Maybe Double)
vec -> Map Nanometer (Double, Double, Double)
-> IO (Map Nanometer (Double, Double, Double))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Nanometer (Double, Double, Double)
 -> IO (Map Nanometer (Double, Double, Double)))
-> Map Nanometer (Double, Double, Double)
-> IO (Map Nanometer (Double, Double, Double))
forall a b. (a -> b) -> a -> b
$ [(Nanometer, (Double, Double, Double))]
-> Map Nanometer (Double, Double, Double)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Nanometer
nm, (Double
l,Double
m,Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 Maybe Double
s)) | (Nanometer
nm,Double
l,Double
m,Maybe Double
s) <- Vector (Nanometer, Double, Double, Maybe Double)
-> [(Nanometer, Double, Double, Maybe Double)]
forall a. Vector a -> [a]
V.toList Vector (Nanometer, Double, Double, Maybe Double)
vec, Nanometer
nm Nanometer -> Nanometer -> Bool
forall a. Ord a => a -> a -> Bool
<= Nanometer
700 ]