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