1{-
2Copyright (c) 2008
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-}
23-- |Specifies 'Colour's in accordance with the sRGB standard.
24module Data.Colour.SRGB
25 (Colour, RGB(..)
26 ,sRGB24, sRGBBounded, sRGB
27 ,toSRGB24, toSRGBBounded, toSRGB
28
29 ,sRGB24shows, sRGB24show
30 ,sRGB24reads, sRGB24read
31
32 ,sRGBSpace
33 )
34where
35
36import Data.Word (Word8)
37import Numeric (readHex, showHex)
38import Data.Colour.Internal (quantize)
39import Data.Colour.SRGB.Linear
40import Data.Colour.RGBSpace hiding (transferFunction)
41
42{- Non-linear colour space -}
43{- the sRGB transfer function approximates a gamma of about 1/2.2 -}
44transferFunction lin | lin == 1         = 1
45                     | lin <= 0.0031308 = 12.92*lin
46                     | otherwise        = (1 + a)*lin**(1/2.4) - a
47 where
48  a = 0.055
49
50invTransferFunction nonLin | nonLin == 1       = 1
51                           | nonLin <= 0.04045 = nonLin/12.92
52                           | otherwise         =
53  ((nonLin + a)/(1 + a))**2.4
54 where
55  a = 0.055
56
57-- |Construct a colour from an sRGB specification.
58-- Input components are expected to be in the range [0..1].
59sRGB :: (Ord b, Floating b) =>  b -> b -> b -> Colour b
60sRGB = curryRGB (uncurryRGB rgb . fmap invTransferFunction)
61
62-- |Construct a colour from an sRGB specification.
63-- Input components are expected to be in the range [0..'maxBound'].
64sRGBBounded :: (Ord b, Floating b, Integral a, Bounded a) =>
65               a -> a -> a -> Colour b
66sRGBBounded r' g' b' = uncurryRGB sRGB (fmap f (RGB r' g' b'))
67 where
68  f x' = (fromIntegral x'/m)
69  m = fromIntegral $ maxBound `asTypeOf` r'
70
71-- |Construct a colour from a 24-bit (three 8-bit words) sRGB
72-- specification.
73sRGB24 :: (Ord b, Floating b) => Word8 -> Word8 -> Word8 -> Colour b
74sRGB24 = sRGBBounded
75
76-- |Return the sRGB colour components in the range [0..1].
77toSRGB :: (Ord b, Floating b) => Colour b -> RGB b
78toSRGB c = fmap transferFunction (toRGB c)
79
80{- Results are clamped and quantized -}
81-- |Return the approximate sRGB colour components in the range
82-- [0..'maxBound'].
83-- Out of range values are clamped.
84toSRGBBounded :: (RealFrac b, Floating b, Integral a, Bounded a) =>
85                 Colour b -> RGB a
86toSRGBBounded c = fmap f (toSRGB c)
87 where
88  f x' = quantize (m*x')
89  m = fromIntegral $ maxBound `asTypeOf` (f undefined)
90
91-- |Return the approximate 24-bit sRGB colour components as three 8-bit
92-- components.
93-- Out of range values are clamped.
94toSRGB24 :: (RealFrac b, Floating b) => Colour b -> RGB Word8
95toSRGB24 = toSRGBBounded
96
97-- |Show a colour in hexadecimal form, e.g. \"#00aaff\"
98sRGB24shows :: (RealFrac b, Floating b) => Colour b -> ShowS
99sRGB24shows c =
100  ("#"++) . showHex2 r' . showHex2 g' . showHex2 b'
101 where
102  RGB r' g' b' = toSRGB24 c
103  showHex2 x | x <= 0xf = ("0"++) . showHex x
104             | otherwise = showHex x
105
106-- |Show a colour in hexadecimal form, e.g. \"#00aaff\"
107sRGB24show :: (RealFrac b, Floating b) => Colour b -> String
108sRGB24show x = sRGB24shows x ""
109
110-- |Read a colour in hexadecimal form, e.g. \"#00aaff\" or \"00aaff\"
111sRGB24reads :: (Ord b, Floating b) => ReadS (Colour b)
112sRGB24reads "" = []
113sRGB24reads x =
114  [(sRGB24 a b c, c0)
115  |(a,a0) <- readPair x', (b,b0) <- readPair a0, (c,c0) <- readPair b0]
116 where
117  x' | head x == '#' = tail x
118     | otherwise = x
119  readPair [] = []
120  readPair [_] = []
121  readPair a = [(x,a1)|(x,"") <- readHex a0]
122   where
123    (a0,a1) = splitAt 2 a
124
125-- |Read a colour in hexadecimal form, e.g. \"#00aaff\" or \"00aaff\"
126sRGB24read :: (Ord b, Floating b) => String -> (Colour b)
127sRGB24read x | length rx /= 1 || not (null (snd (head rx))) =
128  error "Data.Colour.SRGB.sRGB24read: no parse"
129             | otherwise = fst (head rx)
130 where
131  rx = sRGB24reads x
132
133-- |The sRGB colour space
134sRGBSpace :: (Ord a, Floating a) => RGBSpace a
135sRGBSpace = mkRGBSpace sRGBGamut transfer
136 where
137  transfer = TransferFunction transferFunction invTransferFunction (recip 2.2)
138