1{-
2Copyright (c) 2008,2009
3Russell O'Connor
4
5Permission is hereby granted, free of charge, to any person obtaining a copy
6of this software and associated documentation files (the "Software"), to deal
7in the Software without restriction, including without limitation the rights
8to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9copies of the Software, and to permit persons to whom the Software is
10furnished to do so, subject to the following conditions:
11
12The above copyright notice and this permission notice shall be included in
13all copies or substantial portions of the Software.
14
15THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21THE SOFTWARE.
22-}
23module Data.Colour.RGB where
24
25import Data.List
26import Data.Colour.Matrix
27import Data.Colour.CIE.Chromaticity
28import Control.Applicative
29
30-- |An RGB triple for an unspecified colour space.
31data RGB a = RGB {channelRed :: !a
32                 ,channelGreen :: !a
33                 ,channelBlue :: !a
34                 } deriving (Eq, Show, Read)
35
36instance Functor RGB where
37 fmap f (RGB r g b) = RGB (f r) (f g) (f b)
38
39instance Applicative RGB where
40 pure c = RGB c c c
41 (RGB fr fg fb) <*> (RGB r g b) = RGB (fr r) (fg g) (fb b)
42
43-- |Uncurries a function expecting three r, g, b parameters.
44uncurryRGB :: (a -> a -> a -> b) -> RGB a -> b
45uncurryRGB f (RGB r g b) = f r g b
46
47-- |Curries a function expecting one RGB parameter.
48curryRGB :: (RGB a -> b) -> a -> a -> a -> b
49curryRGB f r g b = f (RGB r g b)
50
51-- |An 'RGBGamut' is a 3-D colour &#8220;cube&#8221; that contains all the
52-- colours that can be displayed by a RGB device.
53-- The &#8220;cube&#8221; is normalized so that white has
54-- 'Data.Colour.CIE.luminance' 1.
55data RGBGamut = RGBGamut {primaries :: !(RGB (Chromaticity Rational))
56                         ,whitePoint :: !(Chromaticity Rational)
57                         } deriving (Eq)
58
59instance Show RGBGamut where
60  showsPrec d gamut = showParen (d > app_prec) showStr
61   where
62    showStr = showString "mkRGBGamut"
63            . showString " " . (showsPrec (app_prec+1) (primaries gamut))
64            . showString " " . (showsPrec (app_prec+1) (whitePoint gamut))
65
66instance Read RGBGamut where
67  readsPrec d r = readParen (d > app_prec)
68                  (\r -> [(mkRGBGamut p w,t)
69                         |("mkRGBGamut",s) <- lex r
70                         ,(p,s0) <- readsPrec (app_prec+1) s
71                         ,(w,t)  <- readsPrec (app_prec+1) s0]) r
72
73-- |An RGB gamut is specified by three primary colours (red, green, and
74-- blue) and a white point (often 'Data.Colour.CIE.Illuminant.d65').
75mkRGBGamut :: RGB (Chromaticity Rational) -- ^ The three primaries
76           -> Chromaticity Rational       -- ^ The white point
77           -> RGBGamut
78mkRGBGamut = RGBGamut
79
80{- not for export -}
81
82primaryMatrix :: (Fractional a) => (RGB (Chromaticity a)) -> [[a]]
83primaryMatrix p =
84  [[xr, xg, xb]
85  ,[yr, yg, yb]
86  ,[zr, zg, zb]]
87 where
88  RGB (xr, yr, zr)
89      (xg, yg, zg)
90      (xb, yb, zb) = fmap chromaCoords p
91
92rgb2xyz :: RGBGamut -> [[Rational]]
93rgb2xyz space =
94  transpose (zipWith (map . (*)) as (transpose matrix))
95 where
96  (xn, yn, zn) = chromaCoords (whitePoint space)
97  matrix = primaryMatrix (primaries space)
98  as = mult (inverse matrix) [xn/yn, 1, zn/yn]
99
100xyz2rgb :: RGBGamut -> [[Rational]]
101xyz2rgb = inverse . rgb2xyz
102
103hslsv :: (Fractional a, Ord a) => RGB a -> (a,a,a,a,a)
104hslsv (RGB r g b) | mx == mn  = (0,0,mx,0 ,mx)
105                  | otherwise = (h,s,l ,s0,mx)
106 where
107  mx = maximum [r,g,b]
108  mn = minimum [r,g,b]
109  l = (mx+mn)/2
110  s | l <= 0.5 = (mx-mn)/(mx+mn)
111    | otherwise = (mx-mn)/(2-(mx+mn))
112  s0 = (mx-mn)/mx
113  -- hue calcuation
114  [x,y,z] = take 3 $ dropWhile (/=mx) [r,g,b,r,g]
115  Just o = elemIndex mx [r,g,b]
116  h0 = 60*(y-z)/(mx-mn) + 120*(fromIntegral o)
117  h | h0 < 0 = h0 + 360
118    | otherwise = h0
119
120-- |The 'hue' coordinate of an 'RGB' value is in degrees. Its value is
121-- always in the range 0-360.
122hue :: (Fractional a, Ord a) => RGB a -> a
123hue rgb = h
124 where
125  (h,_,_,_,_) = hslsv rgb
126
127mod1 x | pf < 0 = pf+1
128       | otherwise = pf
129 where
130  (_,pf) = properFraction x
131