module RSAGL.Color.ColorSpace
(ColorSpace(..),
ImportColorCoordinates(..),
ExportColorCoordinates(..),
AffineColorSpace,
ColorWheel,
ColorChannel,
ChannelIndex,
LinearMetric(..),
newChannel,
newAngularChannel,
newRadialChannel,
newMaximalChannel,
viewChannel,
channel_u,
channel_v,
channel_w,
newColorSpace,
newColorWheel,
color_space_rgb,
color_wheel_rgbl,
transformColorFromTo,
transformColor)
where
import RSAGL.Math.Types
import RSAGL.Math.Matrix
import RSAGL.Math.Vector
import RSAGL.Math.AbstractVector
import RSAGL.Math.Affine
import Data.Vec (nearZero)
import RSAGL.Math.Angle
import Control.Arrow (first,second)
newtype AffineColorSpace = AffineColorSpace Matrix
deriving (Show)
newtype ColorWheel = ColorWheel Matrix
deriving (Show)
data ColorChannel =
LinearChannel Matrix
| Preconfigure (Color -> ColorChannel)
data ChannelIndex = ChannelIndex { channel_index :: Matrix }
channel_u :: ChannelIndex
channel_u = ChannelIndex identity_matrix
channel_v :: ChannelIndex
channel_v = ChannelIndex $ matrix
[[0,1,0,0],
[1,0,0,0],
[0,0,1,0],
[0,0,0,1]]
channel_w :: ChannelIndex
channel_w = ChannelIndex $ matrix
[[0,0,1,0],
[0,1,0,0],
[1,0,0,0],
[0,0,0,1]]
newChannel :: (ColorSpace cs) => ChannelIndex -> cs -> ColorChannel
newChannel (ChannelIndex ch_ix) cs = LinearChannel $ ch_ix `matrixMultiply` m
where (AffineColorSpace m) = affineColorSpaceOf cs
newAngularChannel :: ColorWheel -> Angle -> ColorChannel
newAngularChannel (ColorWheel m) a = LinearChannel $
rotationMatrix (Vector3D 0 0 1) (scalarMultiply (1) a)
`matrixMultiply`
m
newRadialChannel :: ColorWheel -> ColorChannel
newRadialChannel (ColorWheel m) = Preconfigure $ \c ->
let Point3D u v w = exportColorCoordinates c $ AffineColorSpace m
(a,_) = cartesianToPolar (u,v)
in newAngularChannel (ColorWheel m) a
newMaximalChannel :: AffineColorSpace -> ColorChannel
newMaximalChannel cs@(AffineColorSpace m) = Preconfigure $ \c ->
let Point3D u v w = exportColorCoordinates c cs
maxi = maximum [abs u,abs v, abs w]
magn = magnitude [u,v,w]
in LinearChannel $
scale' (maxi / if nearZero magn then 1.0 else magn) $
rotateToFrom (Vector3D 1 0 0) (Vector3D u v w) $
transform m identity_matrix
data LinearMetric = LinearMetric {
linear_gamut_bounds :: Maybe (RSdouble,RSdouble),
linear_color_function :: RSdouble -> Color,
linear_value :: RSdouble,
linear_original :: Color }
instance Show LinearMetric where
show x = show (linear_gamut_bounds x,
linear_value x,
exportColorCoordinates (linear_original x) color_space_rgb)
viewChannel :: (ExportColorCoordinates c) =>
ColorChannel -> c -> LinearMetric
viewChannel (LinearChannel m) c = LinearMetric {
linear_gamut_bounds = case intersections of
[] -> Nothing
is -> Just (minimum is,maximum is),
linear_color_function = \x -> importColorCoordinates $
transformColorFromTo (AffineColorSpace m) (Point3D x v w),
linear_value = u,
linear_original = transformColor c }
where Point3D u v w = exportColorCoordinates c $ AffineColorSpace m
rgb@(Point3D r g b) = exportColorCoordinates c color_space_rgb
rgb'@(Vector3D r' g' b') = colorVectorOf (AffineColorSpace m)
(Vector3D 1 0 0)
intersections = map (+u) $ filter gamutValid $
map (uncurry (/)) $ filter (not . nearZero . snd)
[(1r,r'),(1g,g'),(1b,b'),
(r,r'),(g,g'),(b,b')]
colorFunction x = rgb `add` scalarMultiply x rgb'
gamutValid x = let Point3D r'' g'' b'' = colorFunction x
in (>=3) $ length $ filter (>= (0.001)) $ filter (<= 1.001) $ [r'',g'',b'']
viewChannel (Preconfigure f) c =
viewChannel (f $ transformColor c) c
class ColorSpace cs where
affineColorSpaceOf :: cs -> AffineColorSpace
class ExportColorCoordinates c where
exportColorCoordinates ::
c -> AffineColorSpace -> Point3D
class ImportColorCoordinates c where
importColorCoordinates ::
(AffineColorSpace -> Point3D) -> c
instance ColorSpace AffineColorSpace where
affineColorSpaceOf = id
instance ColorSpace ColorWheel where
affineColorSpaceOf (ColorWheel m) = AffineColorSpace m
newtype Color = Color { fromColor ::
AffineColorSpace -> Point3D }
instance ExportColorCoordinates Color where
exportColorCoordinates = fromColor
instance ImportColorCoordinates Color where
importColorCoordinates = Color
newColorSpace :: (ExportColorCoordinates c) =>
c -> c -> c -> c -> AffineColorSpace
newColorSpace k u v w = AffineColorSpace $ matrixInverse $
translationMatrix (vectorToFrom k' zero)
`matrixMultiply`
xyzMatrix (u' `sub` k')
(v' `sub` k')
(w' `sub` k')
where k' = exportColorCoordinates k color_space_rgb
u' = exportColorCoordinates u color_space_rgb
v' = exportColorCoordinates v color_space_rgb
w' = exportColorCoordinates w color_space_rgb
newColorWheel :: (ExportColorCoordinates c) =>
c -> (c,Angle,RSdouble) ->
(c,Angle,RSdouble) ->
(c,Angle,RSdouble) ->
ColorWheel
newColorWheel k (u,theta_u,u') (v,theta_v,v') (w,theta_w,w') =
ColorWheel $ uvw_to_wheel `matrixMultiply` matrixInverse uvw_to_rgb
where uvw_to_wheel = matrix $
[ [cosine theta_u, cosine theta_v, cosine theta_w, 0 ],
[ sine theta_u, sine theta_v, sine theta_w, 0 ],
[ u', v', w', 0 ],
[ 0, 0, 0, 1 ] ]
AffineColorSpace uvw_to_rgb = newColorSpace k u v w
color_wheel_rgbl :: ColorWheel
color_wheel_rgbl = ColorWheel $ matrix $
[ [1.0 , 0.5 , 0.5 , 0.0],
[0.0 , (sqrt 3/2) , (negate $ sqrt 3 / 2) , 0.0],
[0.2126 , 0.7152 , 0.0722 , 0.0],
[0.0 , 0.0 , 0.0 , 1.0] ]
color_space_rgb :: AffineColorSpace
color_space_rgb = AffineColorSpace $ identity_matrix
transformColorFromTo :: AffineColorSpace ->
Point3D ->
AffineColorSpace ->
Point3D
transformColorFromTo (AffineColorSpace source)
uvw
(AffineColorSpace destination) =
transform (destination `matrixMultiply` matrixInverse source)
uvw
colorVectorOf :: AffineColorSpace ->
Vector3D ->
Vector3D
colorVectorOf (AffineColorSpace m) uvw =
inverseTransform m uvw
transformColor :: (ExportColorCoordinates source,
ImportColorCoordinates dest) =>
source -> dest
transformColor = importColorCoordinates . exportColorCoordinates